Added monadic fail to renamer

src/Renamer/Renamer.hs

@@ -7,7 +7,7 @@ module Renamer.Renamer (rename) where
 
 import Auxiliary (mapAccumM)
 import Control.Applicative (Applicative (liftA2))
-import Control.Monad.Except (ExceptT, runExceptT)
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
 import Control.Monad.Identity (Identity, runIdentity)
 import Control.Monad.State (
     MonadState,
@@ -41,19 +41,21 @@ renameDefs defs = runIdentity $ runExceptT $ evalStateT (runRn $ mapM renameDef
             rhs' <- snd <$> renameExp new_names rhs
             pure . DBind $ Bind name (coerce vars') rhs'
         DData (Data (Indexed cname types) constrs) -> do
-            tvars' <- mapM nextNameTVar tvars
+            tvars_ <- tvars
-            let tvars_lt = zip tvars tvars'
+            tvars' <- mapM nextNameTVar tvars_
+            let tvars_lt = zip tvars_ tvars'
                 typ' = map (substituteTVar tvars_lt) types
                 constrs' = map (renameConstr tvars_lt) constrs
             pure . DData $ Data (Indexed cname typ') constrs'
           where
-            tvars = concatMap (collectTVars []) types
+            tvars = concat <$> mapM (collectTVars []) types
+            collectTVars :: [TVar] -> Type -> Rn [TVar]
             collectTVars tvars = \case
                 TAll tvar t -> collectTVars (tvar : tvars) t
-                TIndexed _ -> tvars
+                TIndexed _ -> return tvars
                 -- Should be monad error
-                TVar v -> [v]
+                TVar v -> return [v]
-                _ -> error ("Bad data type definition: " ++ show types)
+                _ -> throwError ("Bad data type definition: " ++ show types)
 
     renameConstr :: [(TVar, TVar)] -> Constructor -> Constructor
     renameConstr new_types (Constructor name typ) =
@@ -88,7 +90,7 @@ data Cxt = Cxt
 
 -- | Rename monad. State holds the number of renamed names.
 newtype Rn a = Rn {runRn :: StateT Cxt (ExceptT String Identity) a}
-    deriving (Functor, Applicative, Monad, MonadState Cxt)
+    deriving (Functor, Applicative, Monad, MonadState Cxt, MonadError String)
 
 -- | Maps old to new name
 type Names = Map LIdent LIdent

src/TypeChecker/TypeChecker.hs

@@ -77,7 +77,9 @@ checkPrg :: Program -> Infer T.Program
 checkPrg (Program bs) = do
     preRun bs
     -- Type check the program twice to produce all top-level types in the first pass through
-    _ <- checkDef bs
+    bs' <- checkDef bs
+    trace "\nFIRST ITERATION" return ()
+    trace (printTree bs' ++ "\nSECOND ITERATION\n") return ()
     bs'' <- checkDef bs
     return $ T.Program bs''
   where
@@ -107,8 +109,6 @@ checkBind (Bind name args e) = do
     let lambda = makeLambda e (reverse $ coerce args)
     e@(_, t') <- inferExp lambda
     s <- gets sigs
-    -- let fs = map (second Just) $ getFunctionTypes s e
-    -- mapM_ (uncurry insertSig) fs
     case M.lookup (coerce name) s of
         Just (Just t) -> do
             sub <- unify t t'
@@ -122,18 +122,6 @@ checkBind (Bind name args e) = do
     makeLambda :: Exp -> [Ident] -> Exp
     makeLambda = foldl (flip (EAbs . coerce))
 
-    -- getFunctionTypes :: Map Ident (Maybe T.Type) -> T.ExpT -> [(Ident, T.Type)]
-    -- getFunctionTypes s = \case
-    --     (T.EId b, t) -> case M.lookup b s of
-    --         Just Nothing -> return (b, t)
-    --         _ -> []
-    --     (T.ELit _, _) -> []
-    --     (T.ELet (T.Bind _ _ e1) e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EApp e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EAdd e1 e2, _) -> getFunctionTypes s e1 ++ getFunctionTypes s e2
-    --     (T.EAbs _ e, _) -> getFunctionTypes s e
-    --     (T.ECase e injs, _) -> getFunctionTypes s e ++ concatMap (getFunctionTypes s . \(T.Inj _ e) -> e) injs
-
 isMoreSpecificOrEq :: T.Type -> T.Type -> Bool
 isMoreSpecificOrEq _ (T.TAll _ _) = True
 isMoreSpecificOrEq (T.TFun a b) (T.TFun c d) =
@@ -231,7 +219,7 @@ algoW = \case
             (s1, (e', t')) <- algoW e
             let varType = apply s1 fr
             let newArr = T.TFun varType t'
-            return (s1, apply s1 (T.EAbs (coerce name, varType) (e', t'), newArr))
+            return (s1, apply s1 (T.EAbs (coerce name) (e', t'), newArr))
 
     -- \| Γ ⊢ e₀ : τ₀, S₀    S₀Γ ⊢ e₁ : τ₁, S₁
     -- \| s₂ = mgu(s₁τ₀, Int)    s₃ = mgu(s₂τ₁, Int)
@@ -424,7 +412,7 @@ instance FreeVars T.ExpT where
         (T.ELet (T.Bind (ident, t1) args e1) e2, t2) -> (T.ELet (T.Bind (ident, apply s t1) args (apply s e1)) (apply s e2), apply s t2)
         (T.EApp e1 e2, t) -> (T.EApp (apply s e1) (apply s e2), apply s t)
         (T.EAdd e1 e2, t) -> (T.EAdd (apply s e1) (apply s e2), apply s t)
-        (T.EAbs (ident, t2) e, t1) -> (T.EAbs (ident, apply s t2) (apply s e), apply s t1)
+        (T.EAbs ident e, t1) -> (T.EAbs ident (apply s e), apply s t1)
         (T.ECase e injs, t) -> (T.ECase (apply s e) (apply s injs), apply s t)
 
 instance FreeVars T.Inj where

src/TypeChecker/TypeCheckerIr.hs

@@ -52,7 +52,7 @@ data Exp
     | ELet Bind ExpT
     | EApp ExpT ExpT
     | EAdd ExpT ExpT
-    | EAbs Id ExpT
+    | EAbs Ident ExpT
     | ECase ExpT [Inj]
     deriving (C.Eq, C.Ord, C.Read, C.Show)
 
@@ -156,7 +156,7 @@ instance Print Exp where
             prPrec i 0 $
                 concatD
                     [ doc $ showString "λ"
-                    , prtId 0 n
+                    , prt 0 n
                     , doc $ showString "."
                     , prt 0 e
                     ]