unified top level type with expression type

src/TypeChecker/TypeChecker.hs

@@ -9,13 +9,13 @@ import Control.Monad.Reader
 import Control.Monad.State
 import Data.Foldable (traverse_)
 import Data.Functor.Identity (runIdentity)
-import Debug.Trace (trace)
 import Data.List (foldl')
 import Data.Map (Map)
 import Data.Map qualified as M
+import Data.Maybe (fromMaybe)
 import Data.Set (Set)
 import Data.Set qualified as S
-import Data.Maybe (fromMaybe)
+import Debug.Trace (trace)
 import Grammar.Abs
 import Grammar.Print (printTree)
 import TypeChecker.TypeCheckerIr (
@@ -115,10 +115,12 @@ checkPrg (Program bs) = do
             d' <- freshenData d
             fmap (T.DData d' :) (checkDef xs)
 
+-- TODO: Unify top level types with the types of the expressions beneath
+-- PERHAPS DONE
 checkBind :: Bind -> Infer T.Bind
 checkBind (Bind n t _ args e) = do
-    (t', e') <- inferExp $ makeLambda e (reverse args)
-    s <- unify t t'
+    (t', e) <- inferExp $ makeLambda e (reverse args)
+    s <- unify t' t
     let t'' = apply s t
     unless
         (t `typeEq` t'')
@@ -130,7 +132,7 @@ checkBind (Bind n t _ args e) = do
                 , printTree t''
                 ]
         )
-    return $ T.Bind (n, t) e'
+    return $ T.Bind (n, t) (apply s e)
   where
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip EAbs)
@@ -287,7 +289,6 @@ algoW = \case
             (s2, t2, e1') <- algoW e1
             let composition = s2 `compose` s1
             return (composition, t2, apply composition $ T.ELet (T.Bind (name, t2) e0') e1')
-
     ECase caseExpr injs -> do
         (_, t0, e0') <- algoW caseExpr
         (injs', ts) <- mapAndUnzipM (checkInj t0) injs
@@ -340,7 +341,7 @@ I.E. { a = a -> b } is an unsolvable constraint since there is no substitution
 where these are equal
 -}
 occurs :: Ident -> Type -> Infer Subst
-occurs _ (TPol _) = return nullSubst
+occurs i t@(TPol a) = return (M.singleton i t)
 occurs i t =
     if S.member i (free t)
         then
@@ -469,14 +470,12 @@ checkInj caseType (Inj it expr) = do
     (args, t') <- initType caseType it
     subst <- unify caseType t'
     applySt subst $ do
-        (_, t, e') <- local (\st -> st { vars = args `M.union` vars st }) (algoW expr)
+        (_, t, e') <- local (\st -> st{vars = args `M.union` vars st}) (algoW expr)
         return (T.Inj (it, t') e', t)
 
 initType :: Type -> Init -> Infer (Map Ident Poly, Type)
 initType expected = \case
-
     InitLit lit -> error "Pattern match on literals not implemented yet"
-
     InitConstr c args -> do
         st <- gets constructors
         case M.lookup c st of

test_program

@@ -1,10 +1,2 @@
-data Maybe ('a) where {
-    Nothing : Maybe ('a)
-    Just : 'a -> Maybe ('a)
-};
-
 id : 'a -> 'a ;
-id x = x ;
-
-main : Maybe ('a -> 'a) ;
-main = Just id ;
+id = \x. x ;