Removed adhoc tests

src/Main.hs

@@ -1,47 +1,50 @@
 {-# LANGUAGE LambdaCase #-}
+
 module Main where
 
-import           Grammar.Par        (myLexer, pProgram)
+import Grammar.Par (myLexer, pProgram)
-import           Grammar.Print      (printTree)
-import           System.Environment (getArgs)
-import           System.Exit        (exitFailure, exitSuccess)
 -- import           TypeChecker.TypeChecker (typecheck)
-import           TypeChecker.Unification (typecheck)
+
-import           Renamer.Renamer (rename)
+import Grammar.Print (printTree)
-import           Grammar.Print (prt)
+import Renamer.Renamer (rename)
+import System.Environment (getArgs)
+import System.Exit (exitFailure, exitSuccess)
+import TypeChecker.TypeChecker (typecheck)
 
 main :: IO ()
-main = getArgs >>= \case
+main =
-  []    -> print "Required file path missing"
+    getArgs >>= \case
-  (x:_) -> do
+        [] -> print "Required file path missing"
-    file <- readFile x
+        (x : _) -> do
-    case pProgram (myLexer file) of
+            file <- readFile x
-      Left err -> do
+            case pProgram (myLexer file) of
-       putStrLn "SYNTAX ERROR"
+                Left err -> do
-       putStrLn err
+                    putStrLn "SYNTAX ERROR"
-       exitFailure
+                    putStrLn err
-      Right prg -> do
+                    exitFailure
-        putStrLn ""
+                Right prg -> do
-        putStrLn " ----- PARSER ----- "
+                    putStrLn ""
-        putStrLn ""
+                    putStrLn " ----- PARSER ----- "
-        putStrLn . printTree $ prg
+                    putStrLn ""
-        case rename prg of
+                    putStrLn . printTree $ prg
-            Left err -> do
+                    case rename prg of
-              putStrLn "FAILED RENAMING"
+                        Left err -> do
-              putStrLn . show $ err
+                            putStrLn "FAILED RENAMING"
-              exitFailure
+                            print err
-            Right prg ->do
+                            exitFailure
-                putStrLn ""
+                        Right prg -> do
-                putStrLn " ----- RENAMER ----- "
+                            putStrLn ""
-                putStrLn ""
+                            putStrLn " ----- RENAMER ----- "
-                putStrLn . printTree $ prg
+                            putStrLn ""
-                case typecheck prg of
+                            putStrLn . printTree $ prg
-                    Left err -> do
+                            case typecheck prg of
-                        putStrLn "TYPECHECK ERROR"
+                                Left err -> do
-                        putStrLn . show $ err
+                                    putStrLn "TYPECHECK ERROR"
-                        exitFailure
+                                    print err
-                    Right prg -> do
+                                    exitFailure
-                        putStrLn ""
+                                Right prg -> do
-                        putStrLn " ----- TYPECHECKER ----- "
+                                    putStrLn ""
-                        putStrLn ""
+                                    putStrLn " ----- TYPECHECKER ----- "
-                        putStrLn . show $ prg
+                                    putStrLn ""
+                                    putStrLn . printTree $ prg
+                                    exitSuccess

src/TypeChecker/TypeChecker.hs

@@ -18,7 +18,7 @@ import TypeChecker.TypeCheckerIr
 
 data Ctx = Ctx
     { vars :: Map Integer Type
-    , sigs :: Map Ident Type
+    , sigs :: Map Ident (RBind, Maybe Type)
     , nextFresh :: Int
     }
     deriving (Show)
@@ -52,12 +52,16 @@ inferPrg (RProgram xs) = do
     xs' <- mapM inferBind xs
     return $ TProgram xs'
 
+-- Binds are not correctly added to the context.
+-- Can't type check programs with more than one function currently
 inferBind :: RBind -> Infer TBind
-inferBind (RBind name e) = do
+inferBind b@(RBind name e) = do
+    insertSigs name b Nothing
     (t, e') <- inferExp e
-    insertSigs name t
     return $ TBind name t e'
 
+-- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
+-- { \x. \y. x + y } will have the type { a -> b -> Int }
 inferExp :: RExp -> Infer (Type, TExp)
 inferExp = \case
     RAnn expr typ -> do
@@ -68,8 +72,14 @@ inferExp = \case
         t <- lookupVars num
         return (t, TBound num name t)
     RFree name -> do
-        t <- lookupSigs name
+        (b@(RBind name _), t) <- lookupSigs name
-        return (t, TFree name t)
+        t' <- case t of
+            Nothing -> do
+                (TBind _ a _) <- inferBind b
+                insertSigs name b (Just a)
+                return a
+            Just a -> return a
+        return (t', TFree name t')
     RConst (CInt i) -> return (TMono "Int", TConst (CInt i) (TMono "Int"))
     RConst (CStr str) -> return (TMono "Str", TConst (CStr str) (TMono "Str"))
     RAdd expr1 expr2 -> do
@@ -126,17 +136,17 @@ insertVars i t = do
     st <- St.get
     St.put (st {vars = M.insert i t st.vars})
 
-lookupSigs :: Ident -> Infer Type
+lookupSigs :: Ident -> Infer (RBind, Maybe Type)
 lookupSigs i = do
     st <- St.gets sigs
     case M.lookup i st of
         Just t -> return t
         Nothing -> throwError $ UnboundVar "lookupSigs"
 
-insertSigs :: Ident -> Type -> Infer ()
+insertSigs :: Ident -> RBind -> Maybe Type -> Infer ()
-insertSigs i t = do
+insertSigs i b t = do
     st <- St.get
-    St.put (st {sigs = M.insert i t st.sigs})
+    St.put (st {sigs = M.insert i (b, t) st.sigs})
 
 {-# WARNING todo "TODO IN CODE" #-}
 todo :: a
@@ -151,29 +161,3 @@ data Error
     | AnnotatedMismatch String
     | Default String
     deriving (Show)
-
--- Tests
-
--- (\x. x + 1) 1
-app_lambda :: RExp
-app_lambda = app lambda one
-
-lambda :: RExp
-lambda = RAbs 0 "x" $ add bound one
-
-add :: RExp -> RExp -> RExp
-add = RAdd
-
-bound = RBound 0 "x"
-
-app :: RExp -> RExp -> RExp
-app = RApp
-
-one :: RExp
-one = RConst (CInt 1)
-
-fn_t = TArrow (TPoly (Ident "0")) (TMono (Ident "Int"))
-
-arr_t = TArrow (TMono "Int") (TPoly "1")
-
-f_x = RAbs 0 "f" (RAbs 1 "x" (RApp (RBound 0 "f") (RBound 1 "x")))

test_program

@@ -1,3 +1 @@
-apply w x = \y. \z. w + x + y + z ;
+apply = \x. \y. (x : Mono Int)
-
-main = apply 1 2 3 4 ;