Rakarake/churf
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Parens removed on types and infix symbols work almost, just need to adapt in LLVM

Browse source
This commit is contained in:
sebastian 2023-05-04 22:50:15 +02:00
parent c309c439cb
commit 0dc06eaf80
10 changed files with 494 additions and 437 deletions
Download patch file Download diff file Expand all files Collapse all files

14
Grammar.cf
View file

@ -22,12 +22,14 @@ internal Bind. Bind ::= LIdent [LIdent] "=" Exp;
-- * Types -- * Types
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
TLit. Type1 ::= UIdent; -- τ internal TLit. Type3 ::= UIdent; -- τ
TVar. Type1 ::= TVar; -- α TIdent. Type3 ::= UIdent;
internal TEVar. Type1 ::= TEVar; -- ά TVar. Type3 ::= TVar; -- α
TData. Type1 ::= UIdent "(" [Type] ")"; -- D () TApp. Type2 ::= Type2 Type3 ;
TFun. Type ::= Type1 "->" Type; -- A → A TFun. Type1 ::= Type1 "->" Type; -- A → A
TAll. Type ::= "forall" TVar "." Type; -- ∀α. A TAll. Type ::= "forall" TVar "." Type; -- ∀α. A
internal TEVar. Type1 ::= TEVar; -- ά
internal TData. Type1 ::= UIdent "(" [Type] ")"; -- D ()
MkTVar. TVar ::= LIdent; MkTVar. TVar ::= LIdent;
internal MkTEVar. TEVar ::= LIdent; internal MkTEVar. TEVar ::= LIdent;
@ -98,7 +100,7 @@ separator nonempty Pattern1 " ";
coercions Pattern 1; coercions Pattern 1;
coercions Exp 4; coercions Exp 4;
coercions Type 1 ; coercions Type 3 ;
token UIdent (upper (letter | digit | '_')*) ; token UIdent (upper (letter | digit | '_')*) ;
token LIdent (lower (letter | digit | '_')*) ; token LIdent (lower (letter | digit | '_')*) ;

25
src/Desugar/Desugar.hs
View file

@ -1,9 +1,12 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Desugar.Desugar where module Desugar.Desugar (desugar) where
import Data.Function (on) import Data.Function (on)
import Debug.Trace (traceShow)
import Grammar.Abs import Grammar.Abs
import Grammar.Print
{- {-
@ -37,7 +40,25 @@ desugarData :: Data -> Data
desugarData (Data typ injs) = Data (desugarType typ) (map desugarInj injs) desugarData (Data typ injs) = Data (desugarType typ) (map desugarInj injs)
desugarType :: Type -> Type desugarType :: Type -> Type
desugarType t = t desugarType = \case
TIdent (UIdent "Int") -> TLit "Int"
TIdent (UIdent "Char") -> TLit "Char"
TIdent ident -> TData ident []
TApp t1 t2 ->
let (name : tvars) = flatten t1 ++ [t2]
in case name of
TIdent ident -> TData ident (map desugarType tvars)
_ -> error "desugarType in Desugar.hs is not implemented correctly"
TLit l -> TLit l
TVar v -> TVar v
(TAll i t) -> TAll i (desugarType t)
TFun t1 t2 -> TFun (desugarType t1) (desugarType t2)
TEVar v -> TEVar v
TData ident typ -> TData ident (map desugarType typ)
where
flatten :: Type -> [Type]
flatten (TApp a b) = flatten a <> flatten b
flatten a = [a]
desugarInj :: Inj -> Inj desugarInj :: Inj -> Inj
desugarInj (Inj ident typ) = Inj ident (desugarType typ) desugarInj (Inj ident typ) = Inj ident (desugarType typ)

93
src/Main.hs
View file

@ -2,38 +2,47 @@
module Main where module Main where
import AnnForall (annotateForall) import AnnForall (annotateForall)
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import Compiler (compile) import Compiler (compile)
import Control.Monad (when, (<=<)) import Control.Monad (when, (<=<))
import Data.List.Extra (isSuffixOf) import Data.List.Extra (isSuffixOf)
import Data.Maybe (fromJust, isNothing) import Data.Maybe (fromJust, isNothing)
import Desugar.Desugar (desugar) import Desugar.Desugar (desugar)
import GHC.IO.Handle.Text (hPutStrLn) import GHC.IO.Handle.Text (hPutStrLn)
import Grammar.ErrM (Err) import Grammar.ErrM (Err)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (Print, printTree) import Grammar.Print (Print, printTree)
import LambdaLifter (lambdaLift) import LambdaLifter (lambdaLift)
import Monomorphizer.Monomorphizer (monomorphize) import Monomorphizer.Monomorphizer (monomorphize)
import OrderDefs (orderDefs) import OrderDefs (orderDefs)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import ReportForall (reportForall) import ReportForall (reportForall)
import System.Console.GetOpt (ArgDescr (NoArg, ReqArg), import System.Console.GetOpt (
ArgOrder (RequireOrder), ArgDescr (NoArg, ReqArg),
OptDescr (Option), getOpt, ArgOrder (RequireOrder),
usageInfo) OptDescr (Option),
import System.Directory (createDirectory, doesPathExist, getOpt,
getDirectoryContents, usageInfo,
removeDirectoryRecursive, )
setCurrentDirectory) import System.Directory (
import System.Environment (getArgs) createDirectory,
import System.Exit (ExitCode (ExitFailure), doesPathExist,
exitFailure, exitSuccess, getDirectoryContents,
exitWith) removeDirectoryRecursive,
import System.IO (stderr) setCurrentDirectory,
import System.Process (spawnCommand, waitForProcess) )
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) import System.Environment (getArgs)
import System.Exit (
ExitCode (ExitFailure),
exitFailure,
exitSuccess,
exitWith,
)
import System.IO (stderr)
import System.Process (spawnCommand, waitForProcess)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
main :: IO () main :: IO ()
main = getArgs >>= parseArgs >>= uncurry main' main = getArgs >>= parseArgs >>= uncurry main'
@ -85,12 +94,12 @@ chooseTypechecker s options = options{typechecker = tc}
tc = case s of tc = case s of
"hm" -> pure Hm "hm" -> pure Hm
"bi" -> pure Bi "bi" -> pure Bi
_ -> Nothing _ -> Nothing
data Options = Options data Options = Options
{ help :: Bool { help :: Bool
, debug :: Bool , debug :: Bool
, gc :: Bool , gc :: Bool
, typechecker :: Maybe TypeChecker , typechecker :: Maybe TypeChecker
} }
@ -169,12 +178,12 @@ prelude :: String
prelude = prelude =
unlines unlines
[ "\n" [ "\n"
--, "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()" , -- , "customHelperFunctionCuzPoorImplementation : Bool () -> Int -> Bool ()"
--, "customHelperFunctionCuzPoorImplementation x y = x" -- , "customHelperFunctionCuzPoorImplementation x y = x"
, "data Bool () where" "data Bool where"
, " False : Bool ()" , " False : Bool"
, " True : Bool ()" , " True : Bool"
, "lt : Int -> Int -> Bool ()" , "lt : Int -> Int -> Bool"
, "lt x y = True" , "lt x y = True"
, "\n" , "\n"
] ]

30
test_program.crf
View file

@ -1,23 +1,15 @@
data List (a) where { data List a where
Nil : List (a) Cons : a -> List a -> List a
Cons : a -> List (a) -> List (a) Nil : List a
};
main = length (Cons 1 (Cons 2 Nil)) ; .++ xs ys = case xs of
id x = x; Nil => ys
const x y = x ; Cons z zs => Cons z (zs ++ ys)
map : (o -> g) -> List (o) -> List (g) ; length xs = case xs of
map f xs = case xs of { Cons x xs => 1 + length xs
Nil => Nil ;
Cons x xs => Cons (f x) (map f xs) ;
};
length : List (Int) -> Int ; main = length (list1 ++ list2)
length xs = case xs of {
Nil => 0 ;
Cons _ xs => 1 + length xs ;
};
id_int : a -> b ; list1 = Cons 0 (Cons 1 (Cons 2 (Cons 3 Nil)))
id_int x = (x : a) ; list2 = Cons 4 (Cons 5 (Cons 6 (Cons 7 Nil)))

177
tests/TestAnnForall.hs
View file

@ -1,97 +1,112 @@
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QualifiedDo #-}
{-# HLINT ignore "Use camelCase" #-} {-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE QualifiedDo #-}
module TestAnnForall (testAnnForall, test) where module TestAnnForall (testAnnForall, test) where
import AnnForall (annotateForall) import AnnForall (annotateForall)
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import qualified DoStrings as D import Desugar.Desugar (desugar)
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import DoStrings qualified as D
import Grammar.Layout (resolveLayout) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Par (myLexer, pProgram) import Grammar.Layout (resolveLayout)
import Grammar.Print (printTree) import Grammar.Par (myLexer, pProgram)
import Renamer.Renamer (rename) import Grammar.Print (printTree)
import ReportForall (reportForall) import Renamer.Renamer (rename)
import Test.Hspec (describe, hspec, shouldBe, import ReportForall (reportForall)
shouldNotSatisfy, shouldSatisfy, import Test.Hspec (
shouldThrow, specify) describe,
import TypeChecker.ReportTEVar (reportTEVar) hspec,
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) shouldBe,
import TypeChecker.TypeCheckerBidir (typecheck) shouldNotSatisfy,
import qualified TypeChecker.TypeCheckerIr as T shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr qualified as T
test = hspec testAnnForall test = hspec testAnnForall
testAnnForall = describe "Test AnnForall" $ do testAnnForall = describe "Test AnnForall" $ do
ann_data1 ann_data1
ann_data2 ann_data2
ann_bad_data1 ann_bad_data1
ann_bad_data2 ann_bad_data2
ann_bad_data3 ann_bad_data3
ann_sig1 ann_sig1
ann_sig2 ann_sig2
ann_bind ann_bind
ann_data1 = specify "Annotate data type" $ ann_data1 =
D.do "data Either (a b) where" specify "Annotate data type" $
" Left : a -> Either (a b)" D.do
" Right : b -> Either (a b)" "data Either a b where"
`shouldBePrg` " Left : a -> Either a b"
D.do "data forall a. forall b. Either (a b) where" " Right : b -> Either a b"
" Left : a -> Either (a b)" `shouldBePrg` D.do
" Right : b -> Either (a b)" "data forall a. forall b. Either a b where"
" Left : a -> Either a b"
" Right : b -> Either a b"
ann_data2 = specify "Annotate constructor with additional type variable" $ ann_data2 =
D.do "data forall a. forall b. Either (a b) where" specify "Annotate constructor with additional type variable" $
" Left : c -> a -> Either (a b)" D.do
" Right : b -> Either (a b)" "data forall a. forall b. Either a b where"
`shouldBePrg` " Left : c -> a -> Either a b"
D.do "data forall a. forall b. Either (a b) where" " Right : b -> Either a b"
" Left : forall c. c -> a -> Either (a b)" `shouldBePrg` D.do
" Right : b -> Either (a b)" "data forall a. forall b. Either a b where"
" Left : forall c. c -> a -> Either a b"
" Right : b -> Either a b"
ann_bad_data1 = specify "Bad data type variables" $ ann_bad_data1 =
D.do "data Either (Int b) where" specify "Bad data type variables" $
" Left : a -> Either (a b)" D.do
" Right : b -> Either (a b)" "data Either Int b where"
`shouldBeErr` " Left : a -> Either a b"
"Misformed data declaration: Non type variable argument" " Right : b -> Either a b"
`shouldBeErr` "Misformed data declaration: Non type variable argument"
ann_bad_data2 = specify "Bad data identifer" $ ann_bad_data2 =
D.do "data Int -> Either (a b) where" specify "Bad data identifer" $
" Left : a -> Either (a b)" D.do
" Right : b -> Either (a b)" "data Int -> Either a b where"
`shouldBeErr` " Left : a -> Either a b"
"Misformed data declaration" " Right : b -> Either a b"
`shouldBeErr` "Misformed data declaration"
ann_bad_data3 = specify "Constructor forall duplicate" $ ann_bad_data3 =
D.do "data Int -> Either (a b) where" specify "Constructor forall duplicate" $
" Left : forall a. a -> Either (a b)" D.do
" Right : b -> Either (a b)" "data Int -> Either a b where"
`shouldBeErr` " Left : forall a. a -> Either a b"
"Misformed data declaration" " Right : b -> Either a b"
`shouldBeErr` "Misformed data declaration"
ann_sig1 =
specify "Annotate signature" $
"f : a -> b -> (forall a. a -> a) -> a"
`shouldBePrg` "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
ann_sig1 = specify "Annotate signature" $ ann_sig2 =
"f : a -> b -> (forall a. a -> a) -> a" specify "Annotate signature 2" $
`shouldBePrg` D.do
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" "const : forall a. forall b. a -> b -> a"
"const x y = x"
"main = const 'a' 65"
`shouldBePrg` D.do
"const : forall a. forall b. a -> b -> a"
"const x y = x"
"main = const 'a' 65"
ann_sig2 = specify "Annotate signature 2" $ ann_bind =
D.do "const : forall a. forall b. a -> b -> a" specify "Annotate bind" $
"const x y = x" "f = (\\x.\\y. x : a -> b -> a) 4"
"main = const 'a' 65" `shouldBePrg` "f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4"
`shouldBePrg`
D.do "const : forall a. forall b. a -> b -> a"
"const x y = x"
"main = const 'a' 65"
ann_bind = specify "Annotate bind" $
"f = (\\x.\\y. x : a -> b -> a) 4"
`shouldBePrg`
"f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4"
shouldBeErr s err = run s `shouldBe` Bad err shouldBeErr s err = run s `shouldBe` Bad err
@ -104,10 +119,10 @@ run' s = do
p <- run'' s p <- run'' s
reportForall Bi p reportForall Bi p
pure p pure p
run'' = pProgram . resolveLayout True . myLexer run'' = fmap desugar . pProgram . resolveLayout True . myLexer
runPrint = (putStrLn . either show printTree . run) $ runPrint = (putStrLn . either show printTree . run) $
D.do "data forall a. forall b. Either (a b) where" D.do
" Left : c -> a -> Either (a b)" "data forall a. forall b. Either a b where"
" Right : b -> Either (a b)" " Left : c -> a -> Either a b"
" Right : b -> Either a b"

119
tests/TestLambdaLifter.hs
View file

@ -1,35 +1,36 @@
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QualifiedDo #-}
{-# HLINT ignore "Use camelCase" #-} {-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}
module TestLambdaLifter where module TestLambdaLifter where
import Test.Hspec import Test.Hspec
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Extra (eitherM)
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import LambdaLifter
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import Control.Monad.Error.Class (liftEither)
import Control.Monad.Extra (eitherM)
import Desugar.Desugar (desugar)
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import LambdaLifter
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr
test = hspec testLambdaLifter test = hspec testLambdaLifter
testLambdaLifter = describe "Test Lambda Lifter" $ do testLambdaLifter = describe "Test Lambda Lifter" $ do
undefined undefined
-- frees_exp1 -- frees_exp1
-- frees_exp1 = specify "Free variables 1" $ -- frees_exp1 = specify "Free variables 1" $
@ -43,67 +44,63 @@ testLambdaLifter = describe "Test Lambda Lifter" $ do
-- ),TVar (MkTVar (Ident "a"))) -- ),TVar (MkTVar (Ident "a")))
-- } -- }
abs_1 = undefined abs_1 = undefined
where where
input = unlines [ "data List (a) where" input =
, " Nil : List (a)" unlines
, " Cons : a -> List (a) -> List (a)" [ "data List a where"
, "map : (a -> b) -> List (a) -> List (b)" , " Nil : List a"
, "add : Int -> Int -> Int" , " Cons : a -> List a -> List a"
, "map : (a -> b) -> List a -> List b"
, "f : List (Int)" , "add : Int -> Int -> Int"
, "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" , "f : List Int"
] , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))"
]
runFreeVars = either putStrLn print (runFree s2) runFreeVars = either putStrLn print (runFree s2)
runAbstract = either putStrLn (putStrLn . printTree) (runAbs s2) runAbstract = either putStrLn (putStrLn . printTree) (runAbs s2)
runCollect = either putStrLn (putStrLn . printTree) (run s2) runCollect = either putStrLn (putStrLn . printTree) (run s2)
s1 =
unlines
[ "add : Int -> Int -> Int"
, "f : Int -> Int -> Int"
, "f x y = add x y"
, "f = \\x. (\\y. add x y)"
]
s1 = unlines [ "add : Int -> Int -> Int" s2 =
, "f : Int -> Int -> Int" unlines
, "f x y = add x y" [ "data List a where"
, "f = \\x. (\\y. add x y)" , " Nil : List (a)"
] , " Cons : a -> List a -> List a"
, "add : Int -> Int -> Int"
s2 = unlines [ "data List (a) where" , "map : (a -> b) -> List a -> List b"
, " Nil : List (a)" , -- , "map f xs = case xs of"
, " Cons : a -> List (a) -> List (a)"
, "add : Int -> Int -> Int"
, "map : (a -> b) -> List (a) -> List (b)"
-- , "map f xs = case xs of"
-- , " Nil => Nil" -- , " Nil => Nil"
-- , " Cons x xs => Cons (f x) (map f xs)" -- , " Cons x xs => Cons (f x) (map f xs)"
, "f : List (Int)" "f : List Int"
, "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))" , "f = (\\x.\\ys. map (\\y. add y x) ys) 4 (Cons 1 (Cons 2 Nil))"
] ]
s3 = "main = (\\plussq. (\\f. f (f 0)) (plussq 3)) (\\x. \\y. y + x + x)" s3 = "main = (\\plussq. (\\f. f (f 0)) (plussq 3)) (\\x. \\y. y + x + x)"
run = fmap collectScs . runAbs run = fmap collectScs . runAbs
runAbs = fmap abstract . runFree runAbs = fmap abstract . runFree
runFree s = do runFree s = do
Program ds <- run' s Program ds <- run' s
pure $ freeVars [b | DBind b <- ds] pure $ freeVars [b | DBind b <- ds]
run' = fmap removeForall run' =
. reportTEVar fmap removeForall
<=< typecheck . reportTEVar
<=< run'' <=< typecheck
<=< run''
run'' s = do run'' s = do
p <- (pProgram . resolveLayout True . myLexer) s p <- (fmap desugar . pProgram . resolveLayout True . myLexer) s
reportForall Bi p reportForall Bi p
(rename <=< annotateForall) p (rename <=< annotateForall) p

136
tests/TestRenamer.hs
View file

@ -1,39 +1,49 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QualifiedDo #-}
{-# HLINT ignore "Use camelCase" #-} {-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE QualifiedDo #-}
module TestRenamer (testRenamer, test, runPrint) where module TestRenamer (testRenamer, test, runPrint) where
import AnnForall (annotateForall)
import AnnForall (annotateForall) import Control.Exception (
import Control.Exception (ErrorCall (ErrorCall), ErrorCall (ErrorCall),
Exception (displayException), Exception (displayException),
SomeException (SomeException), SomeException (SomeException),
evaluate, try) evaluate,
import Control.Exception.Extra (try_) try,
import Control.Monad (unless, (<=<)) )
import Control.Monad.Except (throwError) import Control.Exception.Extra (try_)
import Data.Either.Extra (fromEither) import Control.Monad (unless, (<=<))
import qualified DoStrings as D import Control.Monad.Except (throwError)
import GHC.Generics (Generic, Generic1) import Data.Either.Extra (fromEither)
import Grammar.Abs (Program (Program)) import Desugar.Desugar (desugar)
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import DoStrings qualified as D
import Grammar.Layout (resolveLayout) import GHC.Generics (Generic, Generic1)
import Grammar.Par (myLexer, pProgram) import Grammar.Abs (Program (Program))
import Grammar.Print (printTree) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Renamer.Renamer (rename) import Grammar.Layout (resolveLayout)
import System.IO.Error (catchIOError, tryIOError) import Grammar.Par (myLexer, pProgram)
import Test.Hspec (anyErrorCall, anyException, import Grammar.Print (printTree)
describe, hspec, shouldBe, import Renamer.Renamer (rename)
shouldNotSatisfy, shouldReturn, import System.IO.Error (catchIOError, tryIOError)
shouldSatisfy, shouldThrow, import Test.Hspec (
specify) anyErrorCall,
import TypeChecker.ReportTEVar (reportTEVar) anyException,
import TypeChecker.TypeCheckerBidir (typecheck) describe,
import qualified TypeChecker.TypeCheckerIr as T hspec,
shouldBe,
shouldNotSatisfy,
shouldReturn,
shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr qualified as T
-- FIXME tests sucks -- FIXME tests sucks
@ -47,50 +57,58 @@ testRenamer = describe "Test Renamer" $ do
rn_bind2 rn_bind2
rn_data1 = specify "Rename data type" . shouldSatisfyOk $ rn_data1 = specify "Rename data type" . shouldSatisfyOk $
D.do "data forall a. forall b. Either (a b) where" D.do
" Left : a -> Either (a b)" "data forall a. forall b. Either a b where"
" Right : b -> Either (a b)" " Left : a -> Either a b"
" Right : b -> Either a b"
rn_data2 = specify "Rename data type forall in constructor " . shouldSatisfyOk $ rn_data2 = specify "Rename data type forall in constructor " . shouldSatisfyOk $
D.do "data forall a. forall b. Either (a b) where" D.do
" Left : forall c. c -> a -> Either (a b)" "data forall a. forall b. Either a b where"
" Right : b -> Either (a b)" " Left : forall c. c -> a -> Either a b"
" Right : b -> Either a b"
rn_sig = specify "Rename signature" $ shouldSatisfyOk rn_sig =
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" specify "Rename signature" $
shouldSatisfyOk
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
rn_bind1 = specify "Rename simple bind" $ shouldSatisfyOk rn_bind1 =
"f x = (\\y. let y2 = y + 1 in y2) (x + 1)" specify "Rename simple bind" $
shouldSatisfyOk
"f x = (\\y. let y2 = y + 1 in y2) (x + 1)"
rn_bind2 = specify "Rename bind with case" . shouldSatisfyOk $ rn_bind2 = specify "Rename bind with case" . shouldSatisfyOk $
D.do "data forall a. List (a) where" D.do
" Nil : List (a) " "data forall a. List a where"
" Cons : a -> List (a) -> List (a)" " Nil : List a "
" Cons : a -> List a -> List a"
"length : forall a. List (a) -> Int" "length : forall a. List a -> Int"
"length list = case list of" "length list = case list of"
" Nil => 0" " Nil => 0"
" Cons x Nil => 1" " Cons x Nil => 1"
" Cons x (Cons y ys) => 2 + length ys" " Cons x (Cons y ys) => 2 + length ys"
runPrint = putStrLn . either show printTree . run $ runPrint = putStrLn . either show printTree . run $
D.do "data forall a. List (a) where" D.do
" Nil : List (a) " "data forall a. List a where"
" Cons : a -> List (a) -> List (a)" " Nil : List a "
" Cons : a -> List a -> List a"
"length : forall a. List (a) -> Int" "length : forall a. List a -> Int"
"length list = case list of" "length list = case list of"
" Nil => 0" " Nil => 0"
" Cons x Nil => 1" " Cons x Nil => 1"
" Cons x (Cons y ys) => 2 + length ys" " Cons x (Cons y ys) => 2 + length ys"
shouldSatisfyOk s = run s `shouldSatisfy` ok shouldSatisfyOk s = run s `shouldSatisfy` ok
ok = \case ok = \case
Ok !_ -> True Ok !_ -> True
Bad !_ -> False Bad !_ -> False
shouldBeErr s err = run s `shouldBe` Bad err shouldBeErr s err = run s `shouldBe` Bad err
run = rename <=< run' run = rename <=< run'
run' = pProgram . resolveLayout True . myLexer run' = fmap desugar . pProgram . resolveLayout True . myLexer

59
tests/TestReportForall.hs
View file

@ -4,19 +4,26 @@
module TestReportForall (testReportForall, test) where module TestReportForall (testReportForall, test) where
import AnnForall (annotateForall) import AnnForall (annotateForall)
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import qualified DoStrings as D import Desugar.Desugar (desugar)
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import DoStrings qualified as D
import Grammar.Layout (resolveLayout) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Par (myLexer, pProgram) import Grammar.Layout (resolveLayout)
import Grammar.Print (printTree) import Grammar.Par (myLexer, pProgram)
import Renamer.Renamer (rename) import Grammar.Print (printTree)
import ReportForall (reportForall) import Renamer.Renamer (rename)
import Test.Hspec (describe, hspec, shouldBe, import ReportForall (reportForall)
shouldNotSatisfy, shouldSatisfy, import Test.Hspec (
shouldThrow, specify) describe,
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) hspec,
shouldBe,
shouldNotSatisfy,
shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
testReportForall = describe "Test ReportForall" $ do testReportForall = describe "Test ReportForall" $ do
rp_unused1 rp_unused1
@ -25,23 +32,23 @@ testReportForall = describe "Test ReportForall" $ do
test = hspec testReportForall test = hspec testReportForall
rp_unused1 = specify "Unused forall 1" $ rp_unused1 =
"g : forall a. forall a. a -> (forall a. a -> a) -> a" specify "Unused forall 1" $
`shouldBeErrBi` "g : forall a. forall a. a -> (forall a. a -> a) -> a"
"Unused forall" `shouldBeErrBi` "Unused forall"
rp_unused2 = specify "Unused forall 2" $ rp_unused2 =
"g : forall a. (forall a. a -> a) -> Int" specify "Unused forall 2" $
`shouldBeErrBi` "g : forall a. (forall a. a -> a) -> Int"
"Unused forall" `shouldBeErrBi` "Unused forall"
rp_forall = specify "Rank2 forall with Hm" $ rp_forall =
"f : a -> b -> (forall a. a -> a) -> a" specify "Rank2 forall with Hm" $
`shouldBeErrHm` "f : a -> b -> (forall a. a -> a) -> a"
"Higher rank forall not allowed" `shouldBeErrHm` "Higher rank forall not allowed"
shouldBeErrBi = shouldBeErr Bi shouldBeErrBi = shouldBeErr Bi
shouldBeErrHm = shouldBeErr Hm shouldBeErrHm = shouldBeErr Hm
shouldBeErr tc s err = run tc s `shouldBe` Bad err shouldBeErr tc s err = run tc s `shouldBe` Bad err
run tc = reportForall tc <=< pProgram . resolveLayout True . myLexer run tc = reportForall tc <=< fmap desugar . pProgram . resolveLayout True . myLexer

133
tests/TestTypeCheckerBidir.hs
View file

@ -1,28 +1,28 @@
{-# LANGUAGE LambdaCase #-} {-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE PatternSynonyms #-}
{-# HLINT ignore "Use camelCase" #-} {-# HLINT ignore "Use camelCase" #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
module TestTypeCheckerBidir (test, testTypeCheckerBidir) where module TestTypeCheckerBidir (test, testTypeCheckerBidir) where
import Test.Hspec import Test.Hspec
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import Grammar.Abs (Program)
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T
import AnnForall (annotateForall)
import Control.Monad ((<=<))
import Desugar.Desugar (desugar)
import Grammar.Abs (Program)
import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree)
import Renamer.Renamer (rename)
import ReportForall (reportForall)
import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr qualified as T
test = hspec testTypeCheckerBidir test = hspec testTypeCheckerBidir
@ -120,9 +120,9 @@ tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do
specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok specify "Correct arguments are accepted" $ run (fs ++ correct) `shouldSatisfy` ok
where where
fs = fs =
[ "data Pair (a b) where" [ "data Pair a b where"
, " Pair : a -> b -> Pair (a b)" , " Pair : a -> b -> Pair a b"
, "main : Pair (Int Char)" , "main : Pair Int Char"
] ]
wrong = ["main = Pair 'a' 65"] wrong = ["main = Pair 'a' 65"]
correct = ["main = Pair 65 'a'"] correct = ["main = Pair 65 'a'"]
@ -132,9 +132,9 @@ tc_tree = describe "Tree. Recursive data type" $ do
specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok specify "Correct tree is accepted" $ run (fs ++ correct) `shouldSatisfy` ok
where where
fs = fs =
[ "data Tree (a) where" [ "data Tree a where"
, " Node : a -> Tree (a) -> Tree (a) -> Tree (a)" , " Node : a -> Tree a -> Tree a -> Tree a"
, " Leaf : a -> Tree (a)" , " Leaf : a -> Tree a"
] ]
wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3)"] wrong = ["tree = Node 1 (Node 2 (Node 4) (Leaf 5)) (Leaf 3)"]
correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3)"] correct = ["tree = Node 1 (Node 2 (Leaf 4) (Leaf 5)) (Leaf 3)"]
@ -201,30 +201,30 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
run (fs ++ correct4) `shouldSatisfy` ok run (fs ++ correct4) `shouldSatisfy` ok
where where
fs = fs =
[ "data List (a) where" [ "data List a where"
, " Nil : List (a)" , " Nil : List a"
, " Cons : a -> List (a) -> List (a)" , " Cons : a -> List a -> List a"
] ]
wrong1 = wrong1 =
[ "length : List (c) -> Int" [ "length : List c -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " Cons 6 xs => 1 + length xs" , " Cons 6 xs => 1 + length xs"
] ]
wrong2 = wrong2 =
[ "length : List (c) -> Int" [ "length : List c -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " Cons => 0" , " Cons => 0"
, " Cons x xs => 1 + length xs" , " Cons x xs => 1 + length xs"
] ]
wrong3 = wrong3 =
[ "length : List (c) -> Int" [ "length : List c -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " 0 => 0" , " 0 => 0"
, " Cons x xs => 1 + length xs" , " Cons x xs => 1 + length xs"
] ]
wrong4 = wrong4 =
[ "elems : List (List(c)) -> Int" [ "elems : List (List c) -> Int"
, "elems = \\list. case list of" , "elems = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " Cons Nil Nil => 0" , " Cons Nil Nil => 0"
@ -232,27 +232,27 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
, " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)" , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)"
] ]
correct1 = correct1 =
[ "length : List (c) -> Int" [ "length : List c -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " Cons x xs => 1 + length xs" , " Cons x xs => 1 + length xs"
, " Cons x (Cons y Nil) => 2" , " Cons x (Cons y Nil) => 2"
] ]
correct2 = correct2 =
[ "length : List (c) -> Int" [ "length : List c -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " non_empty => 1" , " non_empty => 1"
] ]
correct3 = correct3 =
[ "length : List (Int) -> Int" [ "length : List Int -> Int"
, "length = \\list. case list of" , "length = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " Cons 1 Nil => 1" , " Cons 1 Nil => 1"
, " Cons x (Cons 2 xs) => 2 + length xs" , " Cons x (Cons 2 xs) => 2 + length xs"
] ]
correct4 = correct4 =
[ "elems : List (List(c)) -> Int" [ "elems : List (List c) -> Int"
, "elems = \\list. case list of" , "elems = \\list. case list of"
, " Nil => 0" , " Nil => 0"
, " Cons Nil Nil => 0" , " Cons Nil Nil => 0"
@ -261,16 +261,16 @@ tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
] ]
tc_if = specify "Test if else case expression" $ do tc_if = specify "Test if else case expression" $ do
run [ "data Bool () where" run
, " True : Bool ()" [ "data Bool where"
, " False : Bool ()" , " True : Bool"
, " False : Bool"
, "ifThenElse : Bool () -> a -> a -> a" , "ifThenElse : Bool -> a -> a -> a"
, "ifThenElse b if else = case b of" , "ifThenElse b if else = case b of"
, " True => if" , " True => if"
, " False => else" , " False => else"
] `shouldSatisfy` ok ]
`shouldSatisfy` ok
tc_infer_case = describe "Infer case expression" $ do tc_infer_case = describe "Infer case expression" $ do
specify "Wrong case expression rejected" $ specify "Wrong case expression rejected" $
@ -279,9 +279,9 @@ tc_infer_case = describe "Infer case expression" $ do
run (fs ++ correct) `shouldSatisfy` ok run (fs ++ correct) `shouldSatisfy` ok
where where
fs = fs =
[ "data Bool () where" [ "data Bool where"
, " True : Bool ()" , " True : Bool"
, " False : Bool ()" , " False : Bool"
] ]
correct = correct =
@ -296,33 +296,38 @@ tc_infer_case = describe "Infer case expression" $ do
, " _ => 1" , " _ => 1"
] ]
tc_rec1 = specify "Infer simple recursive definition" $ tc_rec1 =
run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok specify "Infer simple recursive definition" $
run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok
tc_rec2 = specify "Infer recursive definition with pattern matching" $ run tc_rec2 =
[ "data Bool () where" specify "Infer recursive definition with pattern matching" $
, " False : Bool ()" run
, " True : Bool ()" [ "data Bool where"
, " False : Bool"
, "test = \\x. case x of" , " True : Bool"
, " 10 => True" , "test = \\x. case x of"
, " _ => test (x+1)" , " 10 => True"
] `shouldSatisfy` ok , " _ => test (x+1)"
]
`shouldSatisfy` ok
run :: [String] -> Err T.Program run :: [String] -> Err T.Program
run = fmap removeForall run =
. reportTEVar fmap removeForall
<=< typecheck . reportTEVar
<=< run' <=< typecheck
<=< run'
run' s = do run' s = do
p <- (pProgram . resolveLayout True . myLexer . unlines) s p <- (fmap desugar . pProgram . resolveLayout True . myLexer . unlines) s
reportForall Bi p reportForall Bi p
(rename <=< annotateForall) p (rename <=< annotateForall) p
runPrint = (putStrLn . either show printTree . run') runPrint =
["double x = x + x"] (putStrLn . either show printTree . run')
["double x = x + x"]
ok = \case ok = \case
Ok _ -> True Ok _ -> True
Bad _ -> False Bad _ -> False

145
tests/TestTypeCheckerHm.hs
View file

@ -2,19 +2,20 @@
module TestTypeCheckerHm where module TestTypeCheckerHm where
import Control.Monad (sequence_, (<=<)) import Control.Monad (sequence_, (<=<))
import Test.Hspec import Test.Hspec
import AnnForall (annotateForall) import AnnForall (annotateForall)
import qualified DoStrings as D import Desugar.Desugar (desugar)
import Grammar.Layout (resolveLayout) import DoStrings qualified as D
import Grammar.Par (myLexer, pProgram) import Grammar.Layout (resolveLayout)
import Grammar.Print (printTree) import Grammar.Par (myLexer, pProgram)
import Renamer.Renamer (rename) import Grammar.Print (printTree)
import ReportForall (reportForall) import Renamer.Renamer (rename)
import TypeChecker.TypeChecker (TypeChecker (Hm)) import ReportForall (reportForall)
import TypeChecker.TypeCheckerHm (typecheck) import TypeChecker.TypeChecker (TypeChecker (Hm))
import TypeChecker.TypeCheckerIr (Program) import TypeChecker.TypeCheckerHm (typecheck)
import TypeChecker.TypeCheckerIr (Program)
testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do testTypeCheckerHm = describe "Hindley-Milner type checker test" $ do
sequence_ goods sequence_ goods
@ -47,10 +48,10 @@ goods =
"Pattern matching on a nested list" "Pattern matching on a nested list"
( D.do ( D.do
_List _List
"main : List (List (a)) -> Int ;" "main : List (List a) -> Int;"
"main xs = case xs of {" "main xs = case xs of {"
" Cons Nil _ => 1 ;" " Cons Nil _ => 1;"
" _ => 0 ;" " _ => 0;"
"};" "};"
) )
ok ok
@ -78,7 +79,7 @@ bads =
( D.do ( D.do
_Bool _Bool
_not _not
"f : a -> Bool () ;" "f : a -> Bool ;"
"f x = not x ;" "f x = not x ;"
) )
bad bad
@ -102,7 +103,7 @@ bads =
"Pattern matching on literal and _List should not succeed" "Pattern matching on literal and _List should not succeed"
( D.do ( D.do
_List _List
"length : List (c) -> Int;" "length : List c -> Int;"
"length _List = case _List of {" "length _List = case _List of {"
" 0 => 0;" " 0 => 0;"
" Cons x xs => 1 + length xs;" " Cons x xs => 1 + length xs;"
@ -120,29 +121,29 @@ bads =
" };" " };"
) )
bad bad
-- FIXME FAILING TEST -- FIXME FAILING TEST
-- , testSatisfy -- , testSatisfy
-- "id with incorrect signature" -- "id with incorrect signature"
-- ( D.do -- ( D.do
-- "id : a -> b;" -- "id : a -> b;"
-- "id x = x;" -- "id x = x;"
-- ) -- )
-- bad -- bad
-- FIXME FAILING TEST -- FIXME FAILING TEST
-- , testSatisfy -- , testSatisfy
-- "incorrect signature on const" -- "incorrect signature on const"
-- ( D.do -- ( D.do
-- "const : a -> b -> b;" -- "const : a -> b -> b;"
-- "const x y = x" -- "const x y = x"
-- ) -- )
-- bad -- bad
-- FIXME FAILING TEST -- FIXME FAILING TEST
-- , testSatisfy -- , testSatisfy
-- "incorrect type signature on id lambda" -- "incorrect type signature on id lambda"
-- ( D.do -- ( D.do
-- "id = ((\\x. x) : a -> b);" -- "id = ((\\x. x) : a -> b);"
-- ) -- )
-- bad -- bad
] ]
bes = bes =
@ -187,42 +188,33 @@ bes =
, testBe , testBe
"length function on int list infers correct signature" "length function on int list infers correct signature"
( D.do ( D.do
"data List () where {" "data List where "
" Nil : List ()" " Nil : List"
" Cons : Int -> List () -> List ()" " Cons : Int -> List -> List"
"};"
"length xs = case xs of {" "length xs = case xs of"
" Nil => 0 ;" " Nil => 0"
" Cons _ xs => 1 + length xs ;" " Cons _ xs => 1 + length xs"
"};"
) )
( D.do ( D.do
"data List () where {" "data List where"
" Nil : List ()" " Nil : List"
" Cons : Int -> List () -> List ()" " Cons : Int -> List -> List"
"};"
"length : List () -> Int ;" "length : List -> Int"
"length xs = case xs of {" "length xs = case xs of"
" Nil => 0 ;" " Nil => 0"
" Cons _ xs => 1 + length xs ;" " Cons _ xs => 1 + length xs"
"};"
) )
] ]
testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction testSatisfy desc test satisfaction = specify desc $ run test `shouldSatisfy` satisfaction
testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe testBe desc test shouldbe = specify desc $ run test `shouldBe` run shouldbe
run = fmap (printTree . fst) . typecheck <=< pProgram . myLexer run = fmap (printTree . fst) . typecheck <=< fmap desugar . pProgram . myLexer
run' s = do
p <- (pProgram . resolveLayout True . myLexer) s
reportForall Hm p
(rename <=< annotateForall) p
ok (Right _) = True ok (Right _) = True
ok (Left _) = False ok (Left _) = False
bad = not . ok bad = not . ok
@ -232,14 +224,13 @@ _const = D.do
"const : a -> b -> a ;" "const : a -> b -> a ;"
"const x y = x ;" "const x y = x ;"
_List = D.do _List = D.do
"data List (a) where" "data List a where {"
" {" " Nil : List a;"
" Nil : List (a);" " Cons : a -> List a -> List a;"
" Cons : a -> List (a) -> List (a)" "};"
" };"
_headSig = D.do _headSig = D.do
"head : List (a) -> a ;" "head : List a -> a ;"
_head = D.do _head = D.do
"head xs = " "head xs = "
@ -248,13 +239,13 @@ _head = D.do
" };" " };"
_Bool = D.do _Bool = D.do
"data Bool () where {" "data Bool where {"
" True : Bool ()" " True : Bool"
" False : Bool ()" " False : Bool"
"};" "};"
_not = D.do _not = D.do
"not : Bool () -> Bool () ;" "not : Bool -> Bool ;"
"not x = case x of {" "not x = case x of {"
" True => False ;" " True => False ;"
" False => True ;" " False => True ;"
@ -262,9 +253,9 @@ _not = D.do
_id = "id x = x ;" _id = "id x = x ;"
_Maybe = D.do _Maybe = D.do
"data Maybe (a) where {" "data Maybe a where {"
" Nothing : Maybe (a)" " Nothing : Maybe a"
" Just : a -> Maybe (a)" " Just : a -> Maybe a"
" };" " };"
_fmap = D.do _fmap = D.do