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

Add layout grammar

Browse source
This commit is contained in:
Martin Fredin 2023-04-03 09:24:13 +02:00
parent bd02f52795
commit cc5755c3a9
5 changed files with 155 additions and 176 deletions
Download patch file Download diff file Expand all files Collapse all files

10
Grammar.cf
View file

@ -37,7 +37,6 @@ internal MkTEVar. TEVar ::= LIdent;
Data. Data ::= "data" Type "where" "{" [Inj] "}" ; Data. Data ::= "data" Type "where" "{" [Inj] "}" ;
Inj. Inj ::= UIdent ":" Type ; Inj. Inj ::= UIdent ":" Type ;
separator nonempty Inj " " ;
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- * Expressions -- * Expressions
@ -76,8 +75,13 @@ PInj. Pattern ::= UIdent [Pattern1];
-- * AUX -- * AUX
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
terminator Def ";"; layout "of", "where", "let";
terminator Branch ";" ; layout stop "in";
layout toplevel;
separator Def ";";
separator Branch ";" ;
separator Inj ";";
separator LIdent ""; separator LIdent "";
separator Type " "; separator Type " ";

6
Makefile
View file

@ -3,7 +3,7 @@
language : src/Grammar/Test language : src/Grammar/Test
cabal install --installdir=. --overwrite-policy=always cabal install --installdir=. --overwrite-policy=always
src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y : Grammar.cf src/Grammar/Test.hs src/Grammar/Lex.x src/Grammar/Par.y src/Grammar/Layout : Grammar.cf
bnfc -o src -d $< bnfc -o src -d $<
src/Grammar/Par.hs : src/Grammar/Par.y src/Grammar/Par.hs : src/Grammar/Par.y
@ -15,8 +15,8 @@ src/Grammar/Lex.hs : src/Grammar/Lex.x
src/Grammar/%.y : Grammar.cf src/Grammar/%.y : Grammar.cf
bnfc -o src -d $< bnfc -o src -d $<
src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Test : src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Layout
ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs -o src/Grammar/test ghc src/Grammar/Test.hs src/Grammar/Par.hs src/Grammar/Lex.hs src/Grammar/Abs.hs src/Grammar/Skel.hs src/Grammar/Print.hs src/Grammar/Layout -o src/Grammar/test
clean : clean :
rm -r src/Grammar rm -r src/Grammar

3
language.cabal
View file

@ -30,6 +30,8 @@ executable language
Grammar.Print Grammar.Print
Grammar.Skel Grammar.Skel
Grammar.ErrM Grammar.ErrM
Grammar.ErrM
Grammar.Layout
Auxiliary Auxiliary
Renamer.Renamer Renamer.Renamer
TypeChecker.TypeChecker TypeChecker.TypeChecker
@ -82,6 +84,7 @@ Test-suite language-testsuite
Grammar.Print Grammar.Print
Grammar.Skel Grammar.Skel
Grammar.ErrM Grammar.ErrM
Grammar.Layout
Auxiliary Auxiliary
Monomorphizer.Monomorphizer Monomorphizer.Monomorphizer
Monomorphizer.MonomorphizerIr Monomorphizer.MonomorphizerIr

76
src/Main.hs
View file

@ -2,44 +2,36 @@
module Main where module Main where
import Codegen.Codegen (generateCode) import Codegen.Codegen (generateCode)
import Compiler (compile) import Compiler (compile)
import Control.Monad (when) import Control.Monad (when)
import Data.Bool (bool) import Data.Bool (bool)
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.Par (myLexer, pProgram) import Grammar.Layout (resolveLayout)
import Grammar.Print (printTree) import Grammar.Par (myLexer, pProgram)
import LambdaLifter (lambdaLift) import Grammar.Print (printTree)
import Monomorphizer.Monomorphizer (monomorphize) import LambdaLifter (lambdaLift)
import Renamer.Renamer (rename) import Monomorphizer.Monomorphizer (monomorphize)
import System.Console.GetOpt ( import Renamer.Renamer (rename)
ArgDescr (NoArg, ReqArg), import System.Console.GetOpt (ArgDescr (NoArg, ReqArg),
ArgOrder (RequireOrder), ArgOrder (RequireOrder),
OptDescr (Option), OptDescr (Option), getOpt,
getOpt, usageInfo)
usageInfo, import System.Directory (createDirectory, doesPathExist,
) getDirectoryContents,
import System.Directory ( removeDirectoryRecursive,
createDirectory, setCurrentDirectory)
doesPathExist, import System.Environment (getArgs)
getDirectoryContents, import System.Exit (ExitCode (ExitFailure),
removeDirectoryRecursive, exitFailure, exitSuccess,
setCurrentDirectory, exitWith)
) import System.IO (stderr)
import System.Environment (getArgs) import System.Process (spawnCommand, waitForProcess)
import System.Exit ( import TypeChecker.TypeChecker (TypeChecker (Bi, Hm), typecheck)
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'
@ -86,11 +78,11 @@ 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
, typechecker :: Maybe TypeChecker , typechecker :: Maybe TypeChecker
} }
@ -99,7 +91,7 @@ main' opts s = do
file <- readFile s file <- readFile s
printToErr "-- Parse Tree -- " printToErr "-- Parse Tree -- "
parsed <- fromSyntaxErr . pProgram $ myLexer file parsed <- fromSyntaxErr . pProgram . resolveLayout True $ myLexer file
bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug bool (printToErr $ printTree parsed) (printToErr $ show parsed) opts.debug
printToErr "-- Desugar --" printToErr "-- Desugar --"

236
tests/TestTypeCheckerBidir.hs
View file

@ -10,6 +10,7 @@ import Test.Hspec
import Control.Monad ((<=<)) import Control.Monad ((<=<))
import Grammar.ErrM (Err, pattern Bad, pattern Ok) import Grammar.ErrM (Err, pattern Bad, pattern Ok)
import Grammar.Layout (resolveLayout)
import Grammar.Par (myLexer, pProgram) import Grammar.Par (myLexer, pProgram)
import Renamer.Renamer (rename) import Renamer.Renamer (rename)
import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar)) import TypeChecker.RemoveTEVar (RemoveTEVar (rmTEVar))
@ -38,52 +39,52 @@ testTypeCheckerBidir = describe "Bidirectional type checker test" $ do
tc_id = tc_id =
specify "Basic identity function polymorphism" $ specify "Basic identity function polymorphism" $
run run
[ "id : forall a. a -> a;" [ "id : forall a. a -> a"
, "id x = x;" , "id x = x"
, "main = id 4;" , "main = id 4"
] ]
`shouldSatisfy` ok `shouldSatisfy` ok
tc_double = tc_double =
specify "Addition inference" $ specify "Addition inference" $
run run
["double x = x + x;"] ["double x = x + x"]
`shouldSatisfy` ok `shouldSatisfy` ok
tc_add_lam = tc_add_lam =
specify "Addition lambda inference" $ specify "Addition lambda inference" $
run run
["four = (\\x. x + x) 2;"] ["four = (\\x. x + x) 2"]
`shouldSatisfy` ok `shouldSatisfy` ok
tc_const = tc_const =
specify "Basic polymorphism with multiple type variables" $ specify "Basic polymorphism with multiple type variables" $
run run
[ "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"
] ]
`shouldSatisfy` ok `shouldSatisfy` ok
tc_simple_rank2 = tc_simple_rank2 =
specify "Simple rank two polymorphism" $ specify "Simple rank two polymorphism" $
run run
[ "id : forall a. a -> a;" [ "id : forall a. a -> a"
, "id x = x;" , "id x = x"
, "f : forall a. a -> (forall b. b -> b) -> a;" , "f : forall a. a -> (forall b. b -> b) -> a"
, "f x g = g x;" , "f x g = g x"
, "main = f 4 id;" , "main = f 4 id"
] ]
`shouldSatisfy` ok `shouldSatisfy` ok
tc_rank2 = tc_rank2 =
specify "Rank two polymorphism is ok" $ specify "Rank two polymorphism is ok" $
run run
[ "const : forall a. forall b. a -> b -> a;" [ "const : forall a. forall b. a -> b -> a"
, "const x y = x;" , "const x y = x"
, "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int;" , "rank2 : forall a. forall b. a -> (forall c. c -> Int) -> b -> Int"
, "rank2 x f y = f x + f y;" , "rank2 x f y = f x + f y"
, "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h';" , "main = rank2 3 (\\x. const 5 x : forall a. a -> Int) 'h'"
] ]
`shouldSatisfy` ok `shouldSatisfy` ok
@ -92,20 +93,20 @@ tc_identity = describe "(∀b. b → b) should only accept the identity function
specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok specify "identity is accepted" $ run (fs ++ id) `shouldSatisfy` ok
where where
fs = fs =
[ "f : forall a. a -> (forall b. b -> b) -> a;" [ "f : forall a. a -> (forall b. b -> b) -> a"
, "f x g = g x;" , "f x g = g x"
, "id : forall a. a -> a;" , "id : forall a. a -> a"
, "id x = x;" , "id x = x"
, "id_int : Int -> Int;" , "id_int : Int -> Int"
, "id_int x = x;" , "id_int x = x"
] ]
id = id =
[ "main : Int;" [ "main : Int"
, "main = f 4 id;" , "main = f 4 id"
] ]
id_int = id_int =
[ "main : Int;" [ "main : Int"
, "main = f 4 id_int;" , "main = f 4 id_int"
] ]
tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do tc_pair = describe "Pair. Type variables in Pair a b typechecked" $ do
@ -113,26 +114,24 @@ 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 forall a. forall b. Pair (a b) where {" [ "data forall a. forall b. 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'"]
tc_tree = describe "Tree. Recursive data type" $ do tc_tree = describe "Tree. Recursive data type" $ do
specify "Wrong tree is rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok specify "Wrong tree is rejected" $ run (fs ++ wrong) `shouldNotSatisfy` ok
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 forall a. Tree (a) where {" [ "data forall a. 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)"]
tc_mono_case = describe "Monomorphic pattern matching" $ do tc_mono_case = describe "Monomorphic pattern matching" $ do
specify "First wrong case expression rejected" $ specify "First wrong case expression rejected" $
@ -147,39 +146,34 @@ tc_mono_case = describe "Monomorphic pattern matching" $ do
run correct2 `shouldSatisfy` ok run correct2 `shouldSatisfy` ok
where where
wrong1 = wrong1 =
[ "simple : Int -> Int;" [ "simple : Int -> Int"
, "simple c = case c of {" , "simple c = case c of"
, " 'F' => 0;" , " 'F' => 0"
, " 'T' => 1;" , " 'T' => 1"
, "};"
] ]
wrong2 = wrong2 =
[ "simple : Char -> Int;" [ "simple : Char -> Int"
, "simple c = case c of {" , "simple c = case c of"
, " 'F' => 0;" , " 'F' => 0"
, " 1 => 1;" , " 1 => 1"
, "};"
] ]
wrong3 = wrong3 =
[ "simple : Char -> Int;" [ "simple : Char -> Int"
, "simple c = case c of {" , "simple c = case c of"
, " 'F' => 0;" , " 'F' => 0"
, " 'T' => '1';" , " 'T' => '1'"
, "};"
] ]
correct1 = correct1 =
[ "simple : Char -> Int;" [ "simple : Char -> Int"
, "simple c = case c of {" , "simple c = case c of"
, " 'F' => 0;" , " 'F' => 0"
, " 'T' => 1;" , " 'T' => 1"
, "};"
] ]
correct2 = correct2 =
[ "simple : Char -> Int;" [ "simple : Char -> Int"
, "simple c = case c of {" , "simple c = case c of"
, " 'F' => 0;" , " 'F' => 0"
, " _ => 1;" , " _ => 1"
, "};"
] ]
tc_pol_case = describe "Polymophic and recursive pattern matching" $ do tc_pol_case = describe "Polymophic and recursive pattern matching" $ do
@ -201,72 +195,63 @@ 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 forall a. List (a) where {" [ "data forall a. List (a) where"
, " Nil : List (a)" , " Nil : List (a)"
, " Cons : a -> List (a) -> List (a)" , " Cons : a -> List (a) -> List (a)"
, "};"
] ]
wrong1 = wrong1 =
[ "length : forall c. List (c) -> Int;" [ "length : forall c. 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 : forall c. List (c) -> Int;" [ "length : forall c. 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 : forall c. List (c) -> Int;" [ "length : forall c. 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 : forall c. List (List(c)) -> Int;" [ "elems : forall c. 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"
, " Cons Nil xs => elems xs;" , " Cons Nil xs => elems xs"
, " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs);" , " Cons (Cons Nil ys) xs => 1 + elems (Cons ys xs)"
, "};"
] ]
correct1 = correct1 =
[ "length : forall c. List (c) -> Int;" [ "length : forall c. 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 : forall c. List (c) -> Int;" [ "length : forall c. 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 : forall c. List (List(c)) -> Int;" [ "elems : forall c. 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"
, " Cons Nil xs => elems xs;" , " Cons Nil xs => elems xs"
, " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs);" , " Cons (Cons _ ys) xs => 1 + elems (Cons ys xs)"
, "};"
] ]
@ -277,44 +262,39 @@ 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 =
[ "toBool = case 0 of {" [ "toBool = case 0 of"
, " 0 => False;" , " 0 => False"
, " _ => True;" , " _ => True"
, "};"
] ]
wrong = wrong =
[ "toBool = case 0 of {" [ "toBool = case 0 of"
, " 0 => False;" , " 0 => False"
, " _ => 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 = specify "Infer recursive definition with pattern matching" $ run
[ "data Bool () where {" [ "data Bool () where"
, " False : Bool ()" , " False : Bool ()"
, " True : 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 = rmTEVar <=< typecheck <=< pProgram . myLexer . unlines run = rmTEVar <=< typecheck <=< pProgram . resolveLayout True . myLexer . unlines
ok = \case ok = \case
Ok _ -> True Ok _ -> True