Remade the algorithm myself. Still some bugs.

Grammar.cf

@@ -1,22 +1,21 @@
 
 Program. Program ::= [Bind] ;
 
-Bind. Bind ::= Ident [Ident] "=" Exp ;
+
+Bind. Bind ::= Ident ":" Type ";"
+               Ident [Ident] "=" Exp ;
 
 EAnn.   Exp5 ::= "(" Exp ":" Type ")" ;
 EId.    Exp4 ::= Ident ;
-EConst. Exp4 ::= Const ;
+EInt.   Exp4 ::= Integer ;
 EApp.   Exp3 ::= Exp3 Exp4 ;
 EAdd.   Exp1 ::= Exp1 "+" Exp2 ;
 ELet.   Exp ::= "let" Ident "=" Exp "in" Exp ; 
 EAbs.   Exp  ::= "\\" Ident "." Exp ;
 
-CInt. Const ::= Integer ;
-CStr. Const ::= String ;
-
 TMono. Type1 ::= "Mono" Ident ;
-TPoly. Type1 ::= "Poly" Ident ;
+TPol. Type1 ::= "Poly" Ident ;
-TArrow. Type ::= Type1 "->" Type ;
+TArr. Type ::= Type1 "->" Type ;
 
 -- This doesn't seem to work so we'll have to live with ugly keywords for now
 -- token Upper (upper (letter | digit | '_')*) ;
@@ -30,7 +29,3 @@ coercions Exp 5 ;
 
 comment "--" ;
 comment "{-" "-}" ;
-
--- Adt. Adt ::= "data" UIdent "=" [Constructor] ;
--- Sum. Constructor ::= UIdent ; 
--- separator Constructor "|" ;

language.cabal

@@ -31,11 +31,15 @@ executable language
       Grammar.Print
       Grammar.Skel
       Grammar.ErrM
-      TypeChecker.TypeChecker
+      Auxiliary
-      TypeChecker.TypeCheckerIr
+      -- TypeChecker.TypeChecker
-      TypeChecker.Unification
+      -- TypeChecker.TypeCheckerIr
-      Renamer.Renamer
+      -- TypeChecker.Unification
-      Renamer.RenamerIr
+      TypeChecker.HM
+      TypeChecker.HMIr
+      Renamer.RenamerM
+      -- Renamer.Renamer
+      -- Renamer.RenamerIr
 
     hs-source-dirs:   src
 

src/Auxiliary.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE LambdaCase #-}
+module Auxiliary (module Auxiliary) where
+import           Control.Monad.Error.Class (liftEither)
+import           Control.Monad.Except      (MonadError)
+import           Data.Either.Combinators   (maybeToRight)
+
+snoc :: a -> [a] -> [a]
+snoc x xs = xs ++ [x]
+
+maybeToRightM :: MonadError l m => l -> Maybe r -> m r
+maybeToRightM err = liftEither . maybeToRight err
+
+mapAccumM :: Monad m => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
+mapAccumM f = go
+  where
+    go acc = \case
+      [] -> pure (acc, [])
+      x:xs -> do
+        (acc', x') <- f acc x
+        (acc'', xs') <- go acc' xs
+        pure (acc'', x':xs')

src/Main.hs

@@ -6,10 +6,10 @@ import           Grammar.Par             (myLexer, pProgram)
 -- import           TypeChecker.TypeChecker (typecheck)
 
 import           Grammar.Print      (printTree)
-import           Renamer.Renamer         (rename)
+import           Renamer.RenamerM   (rename)
 import           System.Environment (getArgs)
 import           System.Exit        (exitFailure, exitSuccess)
-import           TypeChecker.TypeChecker (typecheck)
+import           TypeChecker.HM     (typecheck)
 
 main :: IO ()
 main =
@@ -27,24 +27,18 @@ main =
                     putStrLn " ----- PARSER ----- "
                     putStrLn ""
                     putStrLn . printTree $ prg
-                    case rename prg of
+                    case typecheck (rename prg) of
-                        Left err -> do
-                            putStrLn "FAILED RENAMING"
-                            print err
-                            exitFailure
-                        Right prg -> do
-                            putStrLn ""
-                            putStrLn " ----- RENAMER ----- "
-                            putStrLn ""
-                            putStrLn . printTree $ prg
-                            case typecheck prg of
                         Left err -> do
                             putStrLn "TYPECHECK ERROR"
                             print err
                             exitFailure
                         Right prg -> do
                             putStrLn ""
-                                    putStrLn " ----- TYPECHECKER ----- "
+                            putStrLn " ----- RAW ----- "
                             putStrLn ""
                             print prg
+                            putStrLn ""
+                            putStrLn " ----- TYPECHECKER ----- "
+                            putStrLn ""
+                            putStrLn $ printTree prg
                             exitSuccess

src/Renamer/Renamer.hs

@@ -38,7 +38,7 @@ renamePrg (Old.Program xs) = do
     return $ RProgram xs'
 
 renameBind :: Old.Bind -> Rename RBind
-renameBind (Old.Bind i args e) = do
+renameBind (Old.Bind n t i args e) = do
     insertSig i
     e' <- renameExp (makeLambda (reverse args) e)
     return $ RBind i e'
@@ -53,12 +53,12 @@ renameExp = \case
     Old.EId i -> do
         st <- get
         case M.lookup i st.env of
-            Just n -> return $ RBound n i
+            Just n -> return $ RId i
             Nothing -> case S.member i st.sig of
-                         True -> return $ RFree i
+                         True -> return $ RId i
                          False -> throwError $ UnboundVar (show i)
 
-    Old.EConst c -> return $ RConst c
+    Old.EInt c -> return $ RInt c
 
     Old.EAnn e t -> flip RAnn t <$> renameExp e
 

src/Renamer/RenamerIr.hs

@@ -4,14 +4,12 @@ module Renamer.RenamerIr (
     RExp (..),
     RBind (..),
     RProgram (..),
-    Const (..),
     Ident (..),
     Type (..),
 ) where
 
 import Grammar.Abs (
     Bind (..),
-    Const (..),
     Ident (..),
     Program (..),
     Type (..),
@@ -26,35 +24,9 @@ data RBind = RBind Ident RExp
 
 data RExp
     = RAnn RExp Type
-    | RBound Integer Ident
+    | RId Ident
-    | RFree Ident
+    | RInt Integer
-    | RConst Const
     | RApp RExp RExp
     | RAdd RExp RExp
     | RAbs Integer Ident RExp
     deriving (Eq, Ord, Show, Read)
-
-instance Print RProgram where
-    prt i = \case
-        RProgram defs -> prPrec i 0 (concatD [prt 0 defs])
-
-instance Print RBind where
-    prt i = \case
-        RBind x e ->
-            prPrec i 0 $
-                concatD
-                    [ prt 0 x
-                    , doc (showString "=")
-                    , prt 0 e
-                    , doc (showString "\n")
-                    ]
-
-instance Print RExp where
-    prt i = \case
-        RAnn e t -> prPrec i 2 (concatD [prt 0 e, doc (showString ":"), prt 1 t])
-        RBound n _ -> prPrec i 3 (concatD [prt 0 n])
-        RFree id -> prPrec i 3 (concatD [prt 0 id])
-        RConst n -> prPrec i 3 (concatD [prt 0 n])
-        RApp e e1 -> prPrec i 2 (concatD [prt 2 e, prt 3 e1])
-        RAdd e e1 -> prPrec i 1 (concatD [prt 1 e, doc (showString "+"), prt 2 e1])
-        RAbs u _ e -> prPrec i 0 (concatD [doc (showString "λ"), prt 0 u, doc (showString "."), prt 0 e])

src/Renamer/RenamerM.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Renamer.RenamerM  where
+
+import           Auxiliary           (mapAccumM)
+import           Control.Monad.State (MonadState, State, evalState, gets,
+                                      modify)
+import           Data.Map            (Map)
+import qualified Data.Map            as Map
+import           Data.Maybe          (fromMaybe)
+import           Data.Tuple.Extra    (dupe)
+import           Grammar.Abs
+
+
+-- | Rename all variables and local binds
+rename :: Program -> Program
+rename (Program bs) = Program $ evalState (runRn $ mapM (renameSc initNames) bs) 0
+  where
+    initNames = Map.fromList $ map (\(Bind name _ _ _ _) -> dupe name) bs
+    renameSc :: Names -> Bind -> Rn Bind
+    renameSc old_names (Bind name t _ parms rhs) = do
+        (new_names, parms') <- newNames old_names parms
+        rhs'                <- snd <$> renameExp new_names rhs
+        pure $ Bind name t name parms' rhs'
+
+
+-- | Rename monad. State holds the number of renamed names.
+newtype Rn a = Rn { runRn :: State Int a }
+  deriving (Functor, Applicative, Monad, MonadState Int)
+
+-- | Maps old to new name
+type Names = Map Ident Ident
+
+renameLocalBind :: Names -> Bind -> Rn (Names, Bind)
+renameLocalBind old_names (Bind name t _ parms rhs) = do
+    (new_names, name')   <- newName old_names name
+    (new_names', parms') <- newNames new_names parms
+    (new_names'', rhs')  <- renameExp new_names' rhs
+    pure (new_names'', Bind name' t name' parms' rhs')
+
+renameExp :: Names -> Exp -> Rn (Names, Exp)
+renameExp old_names = \case
+    EId  n     -> pure (old_names, EId . fromMaybe n $ Map.lookup n old_names)
+
+    EInt i1    -> pure (old_names, EInt i1)
+
+    EApp e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EApp e1' e2')
+
+    EAdd e1 e2 -> do
+        (env1, e1') <- renameExp old_names e1
+        (env2, e2') <- renameExp old_names e2
+        pure (Map.union env1 env2, EAdd e1' e2')
+
+    ELet i e1 e2  -> do
+        (new_names, e1')   <- renameExp old_names e1
+        (new_names', e2') <- renameExp new_names e2
+        pure (new_names', ELet i e1' e2')
+
+    EAbs par e  -> do
+        (new_names, par') <- newName old_names par
+        (new_names', e')  <- renameExp new_names e
+        pure (new_names', EAbs par' e')
+
+    EAnn e t -> do
+        (new_names, e') <- renameExp old_names e
+        pure (new_names, EAnn e' t)
+
+-- | Create a new name and add it to name environment.
+newName :: Names -> Ident -> Rn (Names, Ident)
+newName env old_name = do
+    new_name <- makeName old_name
+    pure (Map.insert old_name new_name env, new_name)
+
+-- | Create multiple names and add them to the name environment
+newNames :: Names -> [Ident] -> Rn (Names, [Ident])
+newNames = mapAccumM newName
+
+-- | Annotate name with number and increment the number @prefix ⇒ prefix_number@.
+makeName :: Ident -> Rn Ident
+makeName (Ident prefix) = gets (\i -> Ident $ prefix ++ "_" ++ show i) <* modify succ

src/TypeChecker/HM.hs

@@ -0,0 +1,155 @@
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+{-# HLINT ignore "Use traverse_" #-}
+
+module TypeChecker.HM (typecheck) where
+
+import           Control.Monad.Except
+import           Control.Monad.State
+import           Data.Bifunctor        (second)
+import           Data.Functor.Identity (Identity, runIdentity)
+import           Data.Map              (Map)
+import qualified Data.Map              as M
+
+import           Grammar.Abs
+import           Grammar.Print
+import qualified TypeChecker.HMIr      as T
+
+type Infer = StateT Ctx (ExceptT String Identity)
+type Error = String
+
+data Ctx = Ctx { constr :: Map Type Type
+               , vars   :: Map Ident Type
+               , sigs   :: Map Ident Type
+               , frsh   :: Char }
+    deriving Show
+
+run :: Infer a -> Either String a
+run = runIdentity . runExceptT . flip evalStateT initC
+
+int = TMono "Int"
+
+initC :: Ctx
+initC = Ctx M.empty M.empty M.empty 'a'
+
+typecheck :: Program -> Either Error T.Program
+typecheck = run . inferPrg
+
+inferPrg :: Program -> Infer T.Program
+inferPrg (Program bs) = do
+    traverse (\(Bind n t _ _ _) -> insertSig n t) bs
+    bs' <- mapM inferBind bs
+    return $ T.Program bs'
+
+inferBind :: Bind -> Infer T.Bind
+inferBind (Bind i t _ params rhs) = do
+    (t',e') <- inferExp (makeLambda (reverse params) rhs)
+    addConstraint t t'
+    -- when (t /= t') (throwError $ "Signature of function" ++ printTree i ++ "does not match inferred type of expression: " ++ printTree e')
+    return $ T.Bind (t,i) [] e'
+
+makeLambda :: [Ident] -> Exp -> Exp
+makeLambda xs e = foldl (flip EAbs) e xs
+
+inferExp :: Exp -> Infer (Type, T.Exp)
+inferExp = \case
+    EAnn e t -> do
+        (t',e') <- inferExp e
+        when (t' /= t) (throwError "Annotated type and inferred type don't match")
+        return (t', e')
+    EInt i -> return (int, T.EInt int i)
+    EId i -> (\t -> (t, T.EId t i)) <$> lookupVar i
+    EAdd e1 e2 -> do
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        unless (isInt t1 && isInt t2) (throwError "Can not add non-ints")
+        return (int,T.EAdd int e1' e2')
+    EApp e1 e2 -> do
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        fr <- fresh
+        addConstraint t1 (TArr t2 fr)
+        return (fr, T.EApp fr e1' e2')
+    EAbs name e -> do
+        fr <- fresh
+        insertVar name fr
+        (ret_t,e') <- inferExp e
+        t <- solveConstraints (TArr fr ret_t)
+        return (t, T.EAbs t name e')
+    ELet name e1 e2 -> do
+        fr <- fresh
+        insertVar name fr
+        (t1, e1') <- inferExp e1
+        (t2, e2') <- inferExp e2
+        ret_t <- solveConstraints t1
+        return (ret_t, T.ELet ret_t name e1' e2')
+
+
+isInt :: Type -> Bool
+isInt (TMono "Int") = True
+isInt _             = False
+
+lookupVar :: Ident -> Infer Type
+lookupVar i = do
+    st <- get
+    case M.lookup i (vars st) of
+      Just t -> return t
+      Nothing -> case M.lookup i (sigs st) of
+        Just t  -> return t
+        Nothing -> throwError $ "Unbound variable or function" ++ printTree i
+
+insertVar :: Ident -> Type -> Infer ()
+insertVar s t = modify ( \st -> st { vars = M.insert s t (vars st) } )
+
+insertSig :: Ident -> Type -> Infer ()
+insertSig s t = modify ( \st -> st { sigs = M.insert s t (sigs st) } )
+
+
+fresh :: Infer Type
+fresh = do
+    chr <- gets frsh
+    modify (\st -> st { frsh = succ chr })
+    return $ TPol (Ident [chr])
+
+addConstraint :: Type -> Type -> Infer ()
+addConstraint t1 t2 = do
+    when (t2 `contains` t1) (throwError $ "Can't match type " ++ printTree t1 ++ " with " ++ printTree t2)
+    modify (\st -> st { constr = M.insert t1 t2 (constr st) })
+
+contains :: Type -> Type -> Bool
+contains (TArr t1 t2) b      = t1 `contains` b || t2 `contains` b
+contains (TMono a) (TMono b) = False
+contains a b                 = a == b
+
+solveConstraints :: Type -> Infer Type
+solveConstraints t = do
+    c <- gets constr
+    v <- gets vars
+    subst t <$> solveAll (M.toList c)
+
+subst :: Type -> [(Type, Type)] -> Type
+subst t []                = t
+subst (TArr t1 t2) (x:xs) = subst (TArr (replace x t1) (replace x t2)) xs
+subst t (x:xs)            = subst (replace x t) xs
+
+solveAll :: [(Type, Type)] -> Infer [(Type, Type)]
+solveAll [] = return []
+solveAll (x:xs) = case x of
+    (TArr t1 t2, TArr t3 t4) -> solveAll $ (t1,t3) : (t2,t4) : xs
+    (TArr t1 t2, b)          -> fmap ((b, TArr t1 t2) :) $ solveAll $ solve (b, TArr t1 t2) xs
+    (a, TArr t1 t2)          -> fmap ((a, TArr t1 t2) :) $ solveAll $ solve (a, TArr t1 t2) xs
+    (TMono a, TPol b)        -> fmap ((TPol b, TMono a) :) $ solveAll $ solve (TPol b, TMono a) xs
+    (TPol a, TMono b)        -> fmap ((TPol a, TMono a) :) $ solveAll $ solve (TPol a, TMono b) xs
+    (TMono a, TMono b)       -> if a == b then solveAll xs else throwError "Can't unify types"
+    (TPol a, TPol b)         -> fmap ((TPol a, TPol b) :) $ solveAll $ solve (TPol a, TPol b) xs
+
+solve :: (Type, Type) -> [(Type, Type)] -> [(Type, Type)]
+solve x = map (second (replace x))
+
+replace :: (Type, Type) -> Type -> Type
+replace a (TArr t1 t2) = TArr (replace a t1) (replace a t2)
+replace (a,b) c        = if a==c then b else c
+
+-- Known bugs
+-- (x : a) + 3 type checks

src/TypeChecker/HMIr.hs

@@ -0,0 +1,102 @@
+{-# LANGUAGE LambdaCase #-}
+
+module TypeChecker.HMIr
+  ( module Grammar.Abs
+  , module TypeChecker.HMIr
+  ) where
+
+import           Grammar.Abs   (Ident (..), Type (..))
+import           Grammar.Print
+import           Prelude
+import qualified Prelude       as C (Eq, Ord, Read, Show)
+
+newtype Program = Program [Bind]
+  deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+data Exp
+    = EId  Type Ident
+    | EInt Type Integer
+    | ELet Type Ident Exp Exp
+    | EApp Type Exp Exp
+    | EAdd Type Exp Exp
+    | EAbs Type Ident Exp
+      deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+type Id = (Type, Ident)
+
+data Bind = Bind Id [Id] Exp
+    deriving (C.Eq, C.Ord, C.Show, C.Read)
+
+instance Print Program where
+    prt i (Program sc) = prPrec i 0 $ prt 0 sc
+
+instance Print Bind where
+    prt i (Bind name@(n, _) parms rhs) = prPrec i 0 $ concatD
+        [ prtId 0 name
+        , doc $ showString ";"
+        , prt 0 n
+        , prtIdPs 0 parms
+        , doc $ showString "="
+        , prt 0 rhs
+        ]
+
+instance Print [Bind] where
+  prt _ []     = concatD []
+  prt _ [x]    = concatD [prt 0 x]
+  prt _ (x:xs) = concatD [prt 0 x, doc (showString ";"), prt 0 xs]
+
+prtIdPs :: Int -> [Id] -> Doc
+prtIdPs i = prPrec i 0 . concatD . map (prtIdP i)
+
+prtId :: Int -> Id -> Doc
+prtId i (name, t) = prPrec i 0 $ concatD
+    [ prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    ]
+
+prtIdP :: Int -> Id -> Doc
+prtIdP i (name, t) = prPrec i 0 $ concatD
+    [ doc $ showString "("
+    , prt 0 name
+    , doc $ showString ":"
+    , prt 0 t
+    , doc $ showString ")"
+    ]
+
+
+instance Print Exp where
+  prt i = \case
+    EId _ n       -> prPrec i 3 $ concatD [prt 0 n]
+    EInt _ i1      -> prPrec i 3 $ concatD [prt 0 i1]
+    ELet _ name e1 e2    -> prPrec i 3 $ concatD
+                        [ doc $ showString "let"
+                        , prt 0 name
+                        , prt 0 e1
+                        , doc $ showString "in"
+                        , prt 0 e2
+                        ]
+    EApp t e1 e2 -> prPrec i 2 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , prt 2 e1
+                        , prt 3 e2
+                        ]
+    EAdd t e1 e2 -> prPrec i 1 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , prt 1 e1
+                        , doc $ showString "+"
+                        , prt 2 e2
+                        ]
+    EAbs t n e  -> prPrec i 0 $ concatD
+                        [ doc $ showString "@"
+                        , prt 0 t
+                        , doc $ showString "\\"
+                        , prt 0 n
+                        , doc $ showString "."
+                        , prt 0 e
+                        ]
+
+
+

src/TypeChecker/TypeChecker.hs

@@ -1,153 +1,153 @@
-{-# LANGUAGE LambdaCase          #-}
+-- {-# LANGUAGE LambdaCase          #-}
-{-# LANGUAGE OverloadedRecordDot #-}
+-- {-# LANGUAGE OverloadedRecordDot #-}
-{-# LANGUAGE OverloadedStrings   #-}
+-- {-# LANGUAGE OverloadedStrings   #-}
 
 module TypeChecker.TypeChecker where
 
-import           Control.Monad             (void)
+-- import           Control.Monad             (void)
-import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
+-- import           Control.Monad.Except      (ExceptT, runExceptT, throwError)
-import           Control.Monad.State       (StateT)
+-- import           Control.Monad.State       (StateT)
-import qualified Control.Monad.State       as St
+-- import qualified Control.Monad.State       as St
-import           Data.Functor.Identity     (Identity, runIdentity)
+-- import           Data.Functor.Identity     (Identity, runIdentity)
-import           Data.Map                  (Map)
+-- import           Data.Map                  (Map)
-import qualified Data.Map                  as M
+-- import qualified Data.Map                  as M
 
-import           TypeChecker.TypeCheckerIr
+-- import           TypeChecker.TypeCheckerIr
 
-data Ctx = Ctx
+-- data Ctx = Ctx
-    { vars      :: Map Integer Type
+--     { vars      :: Map Integer Type
-    , sigs      :: Map Ident Type
+--     , sigs      :: Map Ident Type
-    , nextFresh :: Int
+--     , nextFresh :: Int
-    }
+--     }
-    deriving (Show)
+--     deriving (Show)
 
--- Perhaps swap over to reader monad instead for vars and sigs.
+-- -- Perhaps swap over to reader monad instead for vars and sigs.
-type Infer = StateT Ctx (ExceptT Error Identity)
+-- type Infer = StateT Ctx (ExceptT Error Identity)
 
-{-
+-- {-
 
-The type checker will assume we first rename all variables to unique name, as to not
+-- The type checker will assume we first rename all variables to unique name, as to not
-have to care about scoping. It significantly improves the quality of life of the
+-- have to care about scoping. It significantly improves the quality of life of the
-programmer.
+-- programmer.
 
-TODOs:
+-- TODOs:
-    Add skolemization variables. i.e
+--     Add skolemization variables. i.e
-    { \x. 3 : forall a. a -> a }
+--     { \x. 3 : forall a. a -> a }
-    should not type check
+--     should not type check
 
-    Generalize. Not really sure what that means though
+--     Generalize. Not really sure what that means though
 
--}
+-- -}
 
-typecheck :: RProgram -> Either Error TProgram
+-- typecheck :: RProgram -> Either Error TProgram
-typecheck = todo
+-- typecheck = todo
 
-run :: Infer a -> Either Error a
+-- run :: Infer a -> Either Error a
-run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
+-- run = runIdentity . runExceptT . flip St.evalStateT (Ctx mempty mempty 0)
 
--- Have to figure out a way to coerce polymorphic types to monomorphic ones where necessary
+-- -- 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 }
+-- -- { \x. \y. x + y } will have the type { a -> b -> Int }
-inferExp :: RExp -> Infer Type
+-- inferExp :: RExp -> Infer Type
-inferExp = \case
+-- inferExp = \case
 
-    RAnn expr typ -> do
+--     RAnn expr typ -> do
-        t <- inferExp expr
+--         t <- inferExp expr
-        void $ t =:= typ
+--         void $ t =:= typ
-        return t
+--         return t
 
-    RBound num name -> lookupVars num
+--     RBound num name -> lookupVars num
 
-    RFree name -> lookupSigs name
+--     RFree name -> lookupSigs name
 
-    RConst (CInt i) -> return $ TMono "Int"
+--     RConst (CInt i) -> return $ TMono "Int"
 
-    RConst (CStr str) -> return $ TMono "Str"
+--     RConst (CStr str) -> return $ TMono "Str"
 
-    RAdd expr1 expr2 -> do
+--     RAdd expr1 expr2 -> do
-        let int = TMono "Int"
+--         let int = TMono "Int"
-        typ1 <- check expr1 int
+--         typ1 <- check expr1 int
-        typ2 <- check expr2 int
+--         typ2 <- check expr2 int
-        return int
+--         return int
 
-    RApp expr1 expr2 -> do
+--     RApp expr1 expr2 -> do
-        fn_t <- inferExp expr1
+--         fn_t <- inferExp expr1
-        arg_t <- inferExp expr2
+--         arg_t <- inferExp expr2
-        res <- fresh
+--         res <- fresh
-        new_t <- fn_t =:= TArrow arg_t res
+--         new_t <- fn_t =:= TArrow arg_t res
-        return res
+--         return res
 
-    RAbs num name expr -> do
+--     RAbs num name expr -> do
-        arg <- fresh
+--         arg <- fresh
-        insertVars num arg
+--         insertVars num arg
-        typ <- inferExp expr
+--         typ <- inferExp expr
-        return $ TArrow arg typ
+--         return $ TArrow arg typ
 
-check :: RExp -> Type -> Infer ()
+-- check :: RExp -> Type -> Infer ()
-check e t = do
+-- check e t = do
-    t' <- inferExp e
+--     t' <- inferExp e
-    t =:= t'
+--     t =:= t'
-    return ()
+--     return ()
 
-fresh :: Infer Type
+-- fresh :: Infer Type
-fresh = do
+-- fresh = do
-    var <- St.gets nextFresh
+--     var <- St.gets nextFresh
-    St.modify (\st -> st {nextFresh = succ var})
+--     St.modify (\st -> st {nextFresh = succ var})
-    return (TPoly $ Ident (show var))
+--     return (TPoly $ Ident (show var))
 
--- | Unify two types.
+-- -- | Unify two types.
-(=:=) :: Type -> Type -> Infer Type
+-- (=:=) :: Type -> Type -> Infer Type
-(=:=) (TPoly _) b = return b
+-- (=:=) (TPoly _) b = return b
-(=:=) a (TPoly _) = return a
+-- (=:=) a (TPoly _) = return a
-(=:=) (TMono a) (TMono b) | a == b = return (TMono a)
+-- (=:=) (TMono a) (TMono b) | a == b = return (TMono a)
-(=:=) (TArrow a b) (TArrow c d) = do
+-- (=:=) (TArrow a b) (TArrow c d) = do
-    t1 <- a =:= c
+--     t1 <- a =:= c
-    t2 <- b =:= d
+--     t2 <- b =:= d
-    return $ TArrow t1 t2
+--     return $ TArrow t1 t2
-(=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
+-- (=:=) a b = throwError (TypeMismatch $ unwords ["Can not unify type", show a, "with", show b])
 
-lookupVars :: Integer -> Infer Type
+-- lookupVars :: Integer -> Infer Type
-lookupVars i = do
+-- lookupVars i = do
-    st <- St.gets vars
+--     st <- St.gets vars
-    case M.lookup i st of
+--     case M.lookup i st of
-       Just t  -> return t
+--        Just t  -> return t
-       Nothing -> throwError $ UnboundVar "lookupVars"
+--        Nothing -> throwError $ UnboundVar "lookupVars"
 
-insertVars :: Integer -> Type -> Infer ()
+-- insertVars :: Integer -> Type -> Infer ()
-insertVars i t = do
+-- insertVars i t = do
-    st <- St.get
+--     st <- St.get
-    St.put (st {vars = M.insert i t st.vars})
+--     St.put (st {vars = M.insert i t st.vars})
 
-lookupSigs :: Ident -> Infer Type
+-- lookupSigs :: Ident -> Infer Type
-lookupSigs i = do
+-- lookupSigs i = do
-    st <- St.gets sigs
+--     st <- St.gets sigs
-    case M.lookup i st of
+--     case M.lookup i st of
-        Just t  -> return t
+--         Just t  -> return t
-        Nothing -> throwError $ UnboundVar "lookupSigs"
+--         Nothing -> throwError $ UnboundVar "lookupSigs"
 
-insertSigs :: Ident -> Type -> Infer ()
+-- insertSigs :: Ident -> Type -> Infer ()
-insertSigs i t = do
+-- insertSigs i t = do
-    st <- St.get
+--     st <- St.get
-    St.put (st {sigs = M.insert i t st.sigs})
+--     St.put (st {sigs = M.insert i t st.sigs})
 
-{-# WARNING todo "TODO IN CODE" #-}
+-- {-# WARNING todo "TODO IN CODE" #-}
-todo :: a
+-- todo :: a
-todo = error "TODO in code"
+-- todo = error "TODO in code"
 
-data Error
+-- data Error
-    = TypeMismatch String
+--     = TypeMismatch String
-    | NotNumber String
+--     | NotNumber String
-    | FunctionTypeMismatch String
+--     | FunctionTypeMismatch String
-    | NotFunction String
+--     | NotFunction String
-    | UnboundVar String
+--     | UnboundVar String
-    | AnnotatedMismatch String
+--     | AnnotatedMismatch String
-    | Default String
+--     | Default String
-    deriving (Show)
+--     deriving (Show)
 
 
-{-
+-- {-
 
-The procedure inst(σ) specializes the polytype
+-- The procedure inst(σ) specializes the polytype
-σ by copying the term and replacing the bound type variables
+-- σ by copying the term and replacing the bound type variables
-consistently by new monotype variables.
+-- consistently by new monotype variables.
 
--}
+-- -}

src/TypeChecker/TypeCheckerIr.hs

@@ -1,74 +1,74 @@
-{-# LANGUAGE LambdaCase #-}
+-- {-# LANGUAGE LambdaCase #-}
 
-module TypeChecker.TypeCheckerIr (
+module TypeChecker.TypeCheckerIr --(
-    TProgram (..),
+--     TProgram (..),
-    TBind (..),
+--     TBind (..),
-    TExp (..),
+--     TExp (..),
-    RProgram (..),
+--     RProgram (..),
-    RBind (..),
+--     RBind (..),
-    RExp (..),
+--     RExp (..),
-    Type (..),
+--     Type (..),
-    Const (..),
+--     Const (..),
-    Ident (..),
+--     Ident (..),
-) where
+-- ) where
 
-import           Grammar.Print
+-- import           Grammar.Print
-import           Renamer.RenamerIr
+-- import           Renamer.RenamerIr
 
-newtype TProgram = TProgram [TBind]
+-- newtype TProgram = TProgram [TBind]
-    deriving (Eq, Show, Read, Ord)
+--     deriving (Eq, Show, Read, Ord)
 
-data TBind = TBind Ident Type TExp
+-- data TBind = TBind Ident Type TExp
-    deriving (Eq, Show, Read, Ord)
+--     deriving (Eq, Show, Read, Ord)
 
-data TExp
+-- data TExp
-    = TAnn TExp Type
+--     = TAnn TExp Type
-    | TBound Integer Ident Type
+--     | TBound Integer Ident Type
-    | TFree Ident Type
+--     | TFree Ident Type
-    | TConst Const Type
+--     | TConst Const Type
-    | TApp TExp TExp Type
+--     | TApp TExp TExp Type
-    | TAdd TExp TExp Type
+--     | TAdd TExp TExp Type
-    | TAbs Integer Ident TExp Type
+--     | TAbs Integer Ident TExp Type
-    deriving (Eq, Ord, Show, Read)
+--     deriving (Eq, Ord, Show, Read)
 
-instance Print TProgram where
+-- instance Print TProgram where
-    prt i = \case
+--     prt i = \case
-        TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
+--         TProgram defs -> prPrec i 0 (concatD [prt 0 defs])
 
-instance Print TBind where
+-- instance Print TBind where
-    prt i = \case
+--     prt i = \case
-        TBind x t e ->
+--         TBind x t e ->
-            prPrec i 0 $
+--             prPrec i 0 $
-                concatD
+--                 concatD
-                    [ prt 0 x
+--                     [ prt 0 x
-                    , doc (showString ":")
+--                     , doc (showString ":")
-                    , prt 0 t
+--                     , prt 0 t
-                    , doc (showString "=")
+--                     , doc (showString "=")
-                    , prt 0 e
+--                     , prt 0 e
-                    , doc (showString "\n")
+--                     , doc (showString "\n")
-                    ]
+--                     ]
 
-instance Print TExp where
+-- instance Print TExp where
-    prt i = \case
+--     prt i = \case
-        TAnn e t ->
+--         TAnn e t ->
-            prPrec i 2 $
+--             prPrec i 2 $
-                concatD
+--                 concatD
-                    [ prt 0 e
+--                     [ prt 0 e
-                    , doc (showString ":")
+--                     , doc (showString ":")
-                    , prt 1 t
+--                     , prt 1 t
-                    ]
+--                     ]
-        TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
+--         TBound _ u t -> prPrec i 3 $ concatD [prt 0 u]
-        TFree u t -> prPrec i 3 $ concatD [prt 0 u]
+--         TFree u t -> prPrec i 3 $ concatD [prt 0 u]
-        TConst c _ -> prPrec i 3 (concatD [prt 0 c])
+--         TConst c _ -> prPrec i 3 (concatD [prt 0 c])
-        TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
+--         TApp e e1 t -> prPrec i 2 $ concatD [prt 2 e, prt 3 e1]
-        TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
+--         TAdd e e1 t -> prPrec i 1 $ concatD [prt 1 e, doc (showString "+"), prt 2 e1]
-        TAbs _ u e t ->
+--         TAbs _ u e t ->
-            prPrec i 0 $
+--             prPrec i 0 $
-                concatD
+--                 concatD
-                    [ doc (showString "(")
+--                     [ doc (showString "(")
-                    , doc (showString "λ")
+--                     , doc (showString "λ")
-                    , prt 0 u
+--                     , prt 0 u
-                    , doc (showString ".")
+--                     , doc (showString ".")
-                    , prt 0 e
+--                     , prt 0 e
-                    , doc (showString ")")
+--                     , doc (showString ")")
-                    ]
+--                     ]

test_program

@@ -1,3 +1,4 @@
-test = \x. (x : Mono String) ;
+main : Mono Int ;
+main = let f = \x. x in f 5 ;
+
 
-apply x y = x + y ;