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)

37
src/Main.hs
View file

@ -19,18 +19,27 @@ 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 (
ArgDescr (NoArg, ReqArg),
ArgOrder (RequireOrder), ArgOrder (RequireOrder),
OptDescr (Option), getOpt, OptDescr (Option),
usageInfo) getOpt,
import System.Directory (createDirectory, doesPathExist, usageInfo,
)
import System.Directory (
createDirectory,
doesPathExist,
getDirectoryContents, getDirectoryContents,
removeDirectoryRecursive, removeDirectoryRecursive,
setCurrentDirectory) setCurrentDirectory,
)
import System.Environment (getArgs) import System.Environment (getArgs)
import System.Exit (ExitCode (ExitFailure), import System.Exit (
exitFailure, exitSuccess, ExitCode (ExitFailure),
exitWith) exitFailure,
exitSuccess,
exitWith,
)
import System.IO (stderr) import System.IO (stderr)
import System.Process (spawnCommand, waitForProcess) import System.Process (spawnCommand, waitForProcess)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck) import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
@ -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)))

127
tests/TestAnnForall.hs
View file

@ -1,26 +1,33 @@
{-# 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 DoStrings qualified as D
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import ReportForall (reportForall) import ReportForall (reportForall)
import Test.Hspec (describe, hspec, shouldBe, import Test.Hspec (
shouldNotSatisfy, shouldSatisfy, describe,
shouldThrow, specify) hspec,
shouldBe,
shouldNotSatisfy,
shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.ReportTEVar (reportTEVar) import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
import TypeChecker.TypeCheckerBidir (typecheck) import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr qualified as T
test = hspec testAnnForall test = hspec testAnnForall
@ -34,64 +41,72 @@ testAnnForall = describe "Test AnnForall" $ do
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 =
ann_sig1 = specify "Annotate signature" $ specify "Annotate signature" $
"f : a -> b -> (forall a. a -> a) -> a" "f : a -> b -> (forall a. a -> a) -> a"
`shouldBePrg` `shouldBePrg` "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
ann_sig2 = specify "Annotate signature 2" $ ann_sig2 =
D.do "const : forall a. forall b. a -> b -> a" specify "Annotate signature 2" $
D.do
"const : forall a. forall b. a -> b -> a"
"const x y = x" "const x y = x"
"main = const 'a' 65" "main = const 'a' 65"
`shouldBePrg` `shouldBePrg` D.do
D.do "const : forall a. forall b. a -> b -> a" "const : forall a. forall b. a -> b -> a"
"const x y = x" "const x y = x"
"main = const 'a' 65" "main = const 'a' 65"
ann_bind = specify "Annotate bind" $ ann_bind =
specify "Annotate bind" $
"f = (\\x.\\y. x : a -> b -> a) 4" "f = (\\x.\\y. x : a -> b -> a) 4"
`shouldBePrg` `shouldBePrg` "f = (\\x.\\y. x : forall a. forall b. a -> b -> a) 4"
"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"

51
tests/TestLambdaLifter.hs
View file

@ -1,8 +1,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# 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 OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}
module TestLambdaLifter where module TestLambdaLifter where
@ -12,6 +12,7 @@ import AnnForall (annotateForall)
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Control.Monad.Error.Class (liftEither) import Control.Monad.Error.Class (liftEither)
import Control.Monad.Extra (eitherM) import Control.Monad.Extra (eitherM)
import Desugar.Desugar (desugar)
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
@ -25,11 +26,11 @@ import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck) import TypeChecker.TypeCheckerBidir (typecheck)
import TypeChecker.TypeCheckerIr 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,49 +44,48 @@ 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"
, " Cons : a -> List a -> List a"
, "map : (a -> b) -> List a -> List b"
, "add : Int -> Int -> Int" , "add : Int -> Int -> Int"
, "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))"
] ]
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 =
s1 = unlines [ "add : Int -> Int -> Int" unlines
[ "add : Int -> Int -> Int"
, "f : Int -> Int -> Int" , "f : Int -> Int -> Int"
, "f x y = add x y" , "f x y = add x y"
, "f = \\x. (\\y. add x y)" , "f = \\x. (\\y. add x y)"
] ]
s2 = unlines [ "data List (a) where" s2 =
unlines
[ "data List a where"
, " Nil : List (a)" , " Nil : List (a)"
, " Cons : a -> List (a) -> List (a)" , " Cons : a -> List a -> List a"
, "add : Int -> Int -> Int" , "add : Int -> Int -> Int"
, "map : (a -> b) -> List (a) -> List (b)" , "map : (a -> b) -> List a -> List b"
-- , "map f xs = case xs of" , -- , "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
@ -94,16 +94,13 @@ 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' =
fmap removeForall
. reportTEVar . reportTEVar
<=< typecheck <=< typecheck
<=< run'' <=< 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

76
tests/TestRenamer.hs
View file

@ -1,23 +1,26 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-} {-# 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 (ErrorCall (ErrorCall), import Control.Exception (
ErrorCall (ErrorCall),
Exception (displayException), Exception (displayException),
SomeException (SomeException), SomeException (SomeException),
evaluate, try) evaluate,
try,
)
import Control.Exception.Extra (try_) import Control.Exception.Extra (try_)
import Control.Monad (unless, (<=<)) import Control.Monad (unless, (<=<))
import Control.Monad.Except (throwError) import Control.Monad.Except (throwError)
import Data.Either.Extra (fromEither) import Data.Either.Extra (fromEither)
import qualified DoStrings as D import Desugar.Desugar (desugar)
import DoStrings qualified as D
import GHC.Generics (Generic, Generic1) import GHC.Generics (Generic, Generic1)
import Grammar.Abs (Program (Program)) import Grammar.Abs (Program (Program))
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
@ -26,14 +29,21 @@ import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import System.IO.Error (catchIOError, tryIOError) import System.IO.Error (catchIOError, tryIOError)
import Test.Hspec (anyErrorCall, anyException, import Test.Hspec (
describe, hspec, shouldBe, anyErrorCall,
shouldNotSatisfy, shouldReturn, anyException,
shouldSatisfy, shouldThrow, describe,
specify) hspec,
shouldBe,
shouldNotSatisfy,
shouldReturn,
shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.ReportTEVar (reportTEVar) import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeCheckerBidir (typecheck) import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T import TypeChecker.TypeCheckerIr qualified as T
-- FIXME tests sucks -- FIXME tests sucks
@ -47,38 +57,46 @@ 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 =
specify "Rename signature" $
shouldSatisfyOk
"f : forall a. forall b. a -> b -> (forall a. a -> a) -> a" "f : forall a. forall b. a -> b -> (forall a. a -> a) -> a"
rn_bind1 = specify "Rename simple bind" $ shouldSatisfyOk rn_bind1 =
specify "Rename simple bind" $
shouldSatisfyOk
"f x = (\\y. let y2 = y + 1 in y2) (x + 1)" "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"
@ -93,4 +111,4 @@ ok = \case
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

35
tests/TestReportForall.hs
View file

@ -6,16 +6,23 @@ 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 DoStrings qualified as D
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import ReportForall (reportForall) import ReportForall (reportForall)
import Test.Hspec (describe, hspec, shouldBe, import Test.Hspec (
shouldNotSatisfy, shouldSatisfy, describe,
shouldThrow, specify) hspec,
shouldBe,
shouldNotSatisfy,
shouldSatisfy,
shouldThrow,
specify,
)
import TypeChecker.TypeChecker (TypeChecker (Bi, Hm)) import TypeChecker.TypeChecker (TypeChecker (Bi, Hm))
testReportForall = describe "Test ReportForall" $ do testReportForall = describe "Test ReportForall" $ do
@ -25,23 +32,23 @@ testReportForall = describe "Test ReportForall" $ do
test = hspec testReportForall test = hspec testReportForall
rp_unused1 = specify "Unused forall 1" $ rp_unused1 =
specify "Unused forall 1" $
"g : forall a. forall a. a -> (forall a. a -> a) -> a" "g : forall a. forall a. a -> (forall a. a -> a) -> a"
`shouldBeErrBi` `shouldBeErrBi` "Unused forall"
"Unused forall"
rp_unused2 = specify "Unused forall 2" $ rp_unused2 =
specify "Unused forall 2" $
"g : forall a. (forall a. a -> a) -> Int" "g : forall a. (forall a. a -> a) -> Int"
`shouldBeErrBi` `shouldBeErrBi` "Unused forall"
"Unused forall"
rp_forall = specify "Rank2 forall with Hm" $ rp_forall =
specify "Rank2 forall with Hm" $
"f : a -> b -> (forall a. a -> a) -> a" "f : a -> b -> (forall a. a -> a) -> a"
`shouldBeErrHm` `shouldBeErrHm` "Higher rank forall not allowed"
"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

83
tests/TestTypeCheckerBidir.hs
View file

@ -10,6 +10,7 @@ import Test.Hspec
import AnnForall (annotateForall) import AnnForall (annotateForall)
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Desugar.Desugar (desugar)
import Grammar.Abs (Program) import Grammar.Abs (Program)
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
@ -21,8 +22,7 @@ import TypeChecker.RemoveForall (removeForall)
import TypeChecker.ReportTEVar (reportTEVar) import TypeChecker.ReportTEVar (reportTEVar)
import TypeChecker.TypeChecker (TypeChecker (Bi)) import TypeChecker.TypeChecker (TypeChecker (Bi))
import TypeChecker.TypeCheckerBidir (typecheck) import TypeChecker.TypeCheckerBidir (typecheck)
import qualified TypeChecker.TypeCheckerIr as T 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,31 +296,36 @@ tc_infer_case = describe "Infer case expression" $ do
, " _ => 1" , " _ => 1"
] ]
tc_rec1 = specify "Infer simple recursive definition" $ tc_rec1 =
specify "Infer simple recursive definition" $
run ["test x = 1 + test (x + 1)"] `shouldSatisfy` ok 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"
, " True : Bool"
, "test = \\x. case x of" , "test = \\x. case x of"
, " 10 => True" , " 10 => True"
, " _ => test (x+1)" , " _ => test (x+1)"
] `shouldSatisfy` ok ]
`shouldSatisfy` ok
run :: [String] -> Err T.Program run :: [String] -> Err T.Program
run = fmap removeForall run =
fmap removeForall
. reportTEVar . reportTEVar
<=< typecheck <=< typecheck
<=< run' <=< 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 =
(putStrLn . either show printTree . run')
["double x = x + x"] ["double x = x + x"]
ok = \case ok = \case

75
tests/TestTypeCheckerHm.hs
View file

@ -6,7 +6,8 @@ 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 DoStrings qualified as D
import Grammar.Layout (resolveLayout) import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Grammar.Print (printTree) import Grammar.Print (printTree)
@ -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;"
@ -187,39 +188,30 @@ 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
@ -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