Fix many bugs, add more checks and make all test pass.

app/Main.hs

@@ -3,15 +3,20 @@ module Main (main) where
 import Parser.Parser (ParserError, parseProgram, composeASTs)
 import Parser.TypeDefs (fnName, AST(AST), typeDecls, mapFromDeclList)
 import TypeSystem.PatternChecker (PatternError, runCoverageCheck, checkPatterns)
-import TypeSystem.TypeDefs (TypeSystemError)
+import TypeSystem.TypeDefs
 import System.Environment (getArgs)
 import Data.Bifunctor (first)
 import Semantics.Builtins (makePrelude)
 import TypeSystem.Preprocessor (preprocess)
 import TypeSystem.TypeSystem (typeCheck)
 import Semantics.Interpreter (interpretAST)
+import Semantics.TypeDefs
 import Debug.Trace (traceM)
-
+import System.IO
+import Data.Either (isLeft, isRight)
+import Control.Monad (when, unless)
+import System.Exit (exitFailure)
+import System.Directory
 
 data ProgramError =
     ParseError ParserError
@@ -31,31 +36,56 @@ showResult :: Show a => Either ProgramError a -> String
 showResult = either show show
 
 preludeFileName :: String
-preludeFileName = "examples/prelude.cont"
+preludeFileName = "prelude.cont"
 
 parseRealProgram :: String -> String -> Either ProgramError AST
 parseRealProgram name = first ParseError . parseProgram name
 
 mapPrelude :: AST -> AST
 mapPrelude (AST types fns) = AST types $ map (\fn -> fn { fnName = makePrelude $ fnName fn }) fns
 
+getRight :: Either e a -> a
+getRight (Right x) = x
+
+doInterpret :: Either ProgramError IAST -> IO Value
+doInterpret res = if isRight res then interpretAST (getRight res) else return (VAlg "Error occured, exiting!" [])
+
+doChecks :: String -> String -> String -> Either ProgramError IAST
+doChecks fname contents preludeContents =
+  do prelude <- mapPrelude <$> parseRealProgram preludeFileName preludeContents
+     ast <- parseRealProgram fname contents
+     let full = composeASTs prelude ast
+     iast <- first ContinuationError $ preprocess full
+     let typeEnv = mapFromDeclList $ typeDecls full
+     traceM $ "Full AST is: " ++ show full
+     traceM $ "Full IAST is: " ++ show iast
+     first PatternCoverageError $ runCoverageCheck typeEnv $ checkPatterns full
+     first TypeError $ typeCheck iast
+     return iast
+
+-- prints to stdout to separate from trace output;
+-- TODO: replace by die when removing trace
+printAndExit :: String -> IO ()
+printAndExit s = putStrLn s >> exitFailure
+
+assertFileExists :: String -> IO ()
+assertFileExists name = do
+  exists <- doesFileExist name
+  unless exists . printAndExit $ "Cannot find file \"" ++ name ++ "\"."
+
 {- | Parses one file, typechecks it and prints the AST. -}
 oneFileParser :: IO ()
 oneFileParser = do
   fname:_ <- getArgs
+  assertFileExists preludeFileName
+  assertFileExists fname
   contents <- readFile fname
   preludeContents <- readFile preludeFileName
-  putStrLn . showResult $ do
-    prelude <- mapPrelude <$> parseRealProgram preludeFileName preludeContents
-    ast <- parseRealProgram fname contents
-    let full = composeASTs prelude ast
-    iast <- first ContinuationError $   preprocess full
-    let typeEnv = mapFromDeclList $ typeDecls full
-    traceM $ "Full AST is: " ++ show full
-    traceM $ "Full IAST is: " ++ show iast
-    first PatternCoverageError $ runCoverageCheck typeEnv $ checkPatterns full
-    first TypeError $ typeCheck iast
-    return $ interpretAST iast
+  let res = doChecks fname contents preludeContents
+  when (isLeft res) . printAndExit $ showResult res
+  v <- doInterpret res
+  print v
+  hFlush stderr
 
 main :: IO ()
 main = oneFileParser

bad/bad10.cont

@@ -0,0 +1,3 @@
+# multiple top-level identifiers with the same name
+main = const 1;
+main = const 3;

bad/bad11.cont

@@ -0,0 +1 @@
+# empty program is rejected because of no main

bad/bad12.cont

@@ -0,0 +1,6 @@
+# Unbound type.
+
+NonExistentType ::
+a = [];
+
+main = const a;

bad/bad6.cont

@@ -0,0 +1,6 @@
+# non-continuation style factorial function
+
+Int -> Int ::
+fac n = if n == 0
+          then 1
+          else n * fac (n - 1);

bad/bad7.cont

@@ -0,0 +1,5 @@
+# non-continuation style factorial defined as lambda without a type signature
+fac2 = fn n . if n == 0
+                then 1
+                else n * fac2 (n - 1);
+

bad/bad8.cont

@@ -0,0 +1,4 @@
+# non-continuation function defined as alias on a prelude non-continuation function
+Int -> Int ::
+intId = id;
+

bad/bad9.cont

@@ -0,0 +1,6 @@
+# Kind error
+
+Maybe ::
+a = Nothing;
+
+main = const a;

badout/bad1.out

@@ -0,0 +1,2 @@
+Type error occured:
+Occurs check: cannot construct infinite type a72 ~ a72 -> a73

badout/bad10.out

@@ -0,0 +1,2 @@
+Type error occured:
+Multiple bindings of identifier "main" in program

badout/bad11.out

@@ -0,0 +1,2 @@
+Type error occured:
+Cannot find the entry point of the program. Did you specify the `main` function?

badout/bad12.out

@@ -0,0 +1,2 @@
+Type error occured:
+Unbound type variable NonExistentType, expected [a73]

badout/bad2.out

@@ -0,0 +1,2 @@
+Type error occured:
+Multiple bindings of identifier "True" in program

badout/bad3.out

@@ -0,0 +1,2 @@
+Type error occured:
+Cannot unify type Int -> Int with Int

badout/bad4.out

@@ -0,0 +1 @@
+Cannot merge coverage Ctors "Maybe" (fromList [("Just",[Anything])]) with ExactInt

badout/bad5.out

@@ -0,0 +1,2 @@
+Type error occured:
+Cannot unify type [a77] with Maybe a78

badout/bad6.out

@@ -0,0 +1,2 @@
+Type error occured:
+Cannot unify type (Int -> a81) -> a81 with Int

badout/bad7.out

@@ -0,0 +1,2 @@
+Type error occured:
+Forbidden non-continuation style type of top-level function Int -> Int

badout/bad8.out

@@ -0,0 +1,2 @@
+Type error occured:
+Cannot unify type (Int -> a14) -> a14 with Int

badout/bad9.out

@@ -0,0 +1,2 @@
+Type error occured:
+Kind error occured: Cannot unify kind * with kind * -> *

examples/conttest.cont → good/conttest.cont

@@ -23,4 +23,4 @@ max3 x y z =
     else max2 x y;
 
 Int ::
-main = max3 1 2 3 id;
+main = max3 1 2 3;

examples/fullInference.cont → good/fullInference.cont

@@ -2,8 +2,8 @@ type Tree a = Empty | Node a (Tree a) (Tree a);
 
 mapTree f t c = match t with
   | Empty => c Empty
-  | Node x t1 t2 => mapTree f t1 (λl . mapTree f t2 (λr . Node (f x) l r));
+  | Node x t1 t2 => mapTree f t1 (λl . mapTree f t2 (λr . c (Node (f x) l r)));
 
 testTree = Node 1 (Node 2 Empty Empty) (Node 3 Empty Empty);
 
-main = mapTree succ testTree id;
+main = mapTree succ testTree;

examples/listTest.cont → good/listTest.cont

@@ -1,9 +1,9 @@
 type TwoLists a b = TwoLists [a] [b];
 
-#[a] -> Maybe a ::
-#safeHead xs c = match xs with
-#  | h : _ => c (Just h)
-#  | [] => c Nothing;
+[a] -> Maybe a ::
+safeHead xs c = match xs with
+  | h : _ => c (Just h)
+  | [] => c Nothing;
 
 d :
 (a -> b -> (c -> d) -> d) -> [a] -> [b] -> Maybe c ::
@@ -14,7 +14,4 @@ joinSafeHeads f xs ys c = match TwoLists xs ys with
 add x y c = c (x + y);
 
 Maybe Int ::
-main = joinSafeHeads add [2, 1, 3, 7] [4, 2, 0] id;
-
-
-sub = add 1 2;
+main = joinSafeHeads add [3, 1, 3, 7] [4, 2, 12];

examples/tiny.cont → good/tiny.cont

@@ -12,3 +12,7 @@ type BExpr =
   | EAnd BExpr BExpr
   | EOr BExpr BExpr
   | EEq Expr Expr;
+
+type NotImplemented = NotImplemented;
+
+main = const NotImplemented;

good/typeMutualRecursion.cont

@@ -0,0 +1,4 @@
+type Box a = Boxed a;
+type Tree a = Node a (Tree a) (Tree a) | Empty;
+
+main = const (Node (Boxed Empty) Empty Empty);

goodout/conttest.out

@@ -0,0 +1 @@
+3

goodout/fullInference.out

@@ -0,0 +1 @@
+Node 2 (Node 3 Empty Empty) (Node 4 Empty Empty)

goodout/listTest.out

@@ -0,0 +1 @@
+Just 7

goodout/tiny.out

@@ -0,0 +1 @@
+NotImplemented

goodout/typeMutualRecursion.out

@@ -0,0 +1 @@
+Node (Boxed Empty) Empty Empty

loop.cont

@@ -0,0 +1,20 @@
+# this program loops, thus demonstrating that the language is strictly evaluated.
+
+c = 1 : c;
+
+Int -> [a] -> [a] ::
+drop x l c = match x with
+| 0 => c l
+| _ => match l with
+       | []  => c []
+       | _:t => drop (x - 1) t c;
+
+[a] :
+Int -> [a] -> [a] ::
+take x l c = match x with
+| 0 => c []
+| _ => match l with
+       | []  => []
+       | h:t => take (x - 1) t (\res . c (h : res));
+
+main = take 3 c;

package.yaml

@@ -29,6 +29,7 @@ dependencies:
 - hspec >= 2.6.1
 - hspec-megaparsec
 - containers
+- directory
 
 library:
   source-dirs: src

prelude.cont

@@ -0,0 +1,31 @@
+# prelude.cont
+# this file is loaded before all the input files by the interpreter and contains basic
+# definitions of standard library functions and types.
+
+type Bool = True | False;
+type Maybe a = Just a | Nothing;
+type Either e a = Left e | Right a;
+
+a -> a ::
+id x = x;
+
+id2 = \x.x;
+
+Int -> Int ::
+succ x = x + 1;
+
+(a -> b) -> (b -> c) -> a -> c ::
+comp f g x = g (f x);
+
+(a -> b) -> [a] -> [b] ::
+map f xs = match xs with
+  | [] => []
+  | h:t => f h : map f t;
+
+(a -> (b -> c) -> c) -> [a] -> ([b] -> c) -> c ::
+contMap f xs c = match xs with
+  | [] => c []
+  | h:t => f h (\x . contMap f t (\rest . c (x : rest)));
+
+a -> b -> a ::
+const x _ = x;

scripts/output-generator.py

@@ -0,0 +1,7 @@
+import os
+
+for file_name in os.listdir("good"):
+    os.system("stack run good/%s 2>/dev/null >goodout/%s" % (file_name, file_name.replace(".cont", ".out")))
+
+for file_name in os.listdir("bad"):
+    os.system("stack run bad/%s 2>/dev/null >badout/%s" % (file_name, file_name.replace(".cont", ".out")))

src/Parser/Parser.hs

@@ -28,7 +28,7 @@ step :: Parser AST
 step = flip AST [] . (:[]) <$> try typeDecl <|> AST [] .  (:[]) <$> funDecl
 
 program :: Parser AST
-program = sc *> (foldr1 composeASTs <$> many step) <* eof
+program = sc *> (foldr composeASTs (AST [] []) <$> many step) <* eof
 
 type ParserError = String