Merge pull request #89 from VitorCBSB/master

Fix let inference (attempts to fix #72 and #82).

006_hindley_milner.md

@@ -691,8 +691,8 @@ $$
 **T-App**
 
 For applications, the first argument must be a lambda expression or return a
-lambda expression, so know it must be of form ``t1 -> t2`` but the output type
-is not determined except by the confluence of the two values. We infer both
+lambda expression, so we know it must be of form ``t1 -> t2`` but the output
+type is not determined except by the confluence of the two values. We infer both
 types, apply the constraints from the first argument over the result second
 inferred type and then unify the two types with the excepted form of the entire
 application expression.
@@ -841,7 +841,7 @@ Typing
 The typing rules are identical, except they now can be written down in a much
 less noisy way that isn't threading so much state. All of the details are taken
 care of under the hood and encoded in specific combinators manipulating the
-state of our Infer monad in a way that lets focus on the domain logic.
+state of our Infer monad in a way that lets us focus on the domain logic.
 
 ```haskell
 infer :: Expr -> Infer Type

CONTRIBUTORS.md

@@ -15,3 +15,4 @@ Contributors
 * Christian Sievers
 * Franklin Chen
 * Jake Taylor
+* Vitor Coimbra

chapter7/poly_constraints/poly.cabal

@@ -20,6 +20,7 @@ executable poly
     , repline       >= 0.1.2.0
 
   other-modules:
+    Env
     Eval
     Infer
     Lexer

chapter7/poly_constraints/src/Infer.hs

@@ -16,7 +16,7 @@ import Syntax
 
 import Control.Monad.Except
 import Control.Monad.State
-import Control.Monad.RWS
+import Control.Monad.Reader
 import Control.Monad.Identity
 
 import Data.List (nub)
@@ -28,12 +28,12 @@ import qualified Data.Set as Set
 -------------------------------------------------------------------------------
 
 -- | Inference monad
-type Infer a = (RWST
+type Infer a = (ReaderT
                   Env             -- Typing environment
-                  [Constraint]    -- Generated constraints
-                  InferState      -- Inference state
+                  (StateT         -- Inference state
+                  InferState
                   (Except         -- Inference errors
-                    TypeError)
+                    TypeError))
                   a)              -- Result
 
 -- | Inference state
@@ -95,8 +95,8 @@ data TypeError
 -------------------------------------------------------------------------------
 
 -- | Run the inference monad
-runInfer :: Env -> Infer Type -> Either TypeError (Type, [Constraint])
-runInfer env m = runExcept $ evalRWST m env initInfer
+runInfer :: Env -> Infer (Type, [Constraint]) -> Either TypeError (Type, [Constraint])
+runInfer env m = runExcept $ evalStateT (runReaderT m env) initInfer
 
 -- | Solve for the toplevel type of an expression in a given environment
 inferExpr :: Env -> Expr -> Either TypeError Scheme
@@ -112,7 +112,7 @@ constraintsExpr env ex = case runInfer env (infer ex) of
   Left err -> Left err
   Right (ty, cs) -> case runSolve cs of
     Left err -> Left err
-    Right subst -> Right $ (cs, subst, ty, sc)
+    Right subst -> Right (cs, subst, ty, sc)
       where
         sc = closeOver $ apply subst ty
 
@@ -120,10 +120,6 @@ constraintsExpr env ex = case runInfer env (infer ex) of
 closeOver :: Type -> Scheme
 closeOver = normalize . generalize Env.empty
 
--- | Unify two types
-uni :: Type -> Type -> Infer ()
-uni t1 t2 = tell [(t1, t2)]
-
 -- | Extend type environment
 inEnv :: (Name, Scheme) -> Infer a -> Infer a
 inEnv (x, sc) m = do
@@ -150,7 +146,7 @@ fresh = do
 
 instantiate ::  Scheme -> Infer Type
 instantiate (Forall as t) = do
-    as' <- mapM (\_ -> fresh) as
+    as' <- mapM (const fresh) as
     let s = Subst $ Map.fromList $ zip as as'
     return $ apply s t
 
@@ -158,66 +154,64 @@ generalize :: Env -> Type -> Scheme
 generalize env t  = Forall as t
     where as = Set.toList $ ftv t `Set.difference` ftv env
 
-ops :: Map.Map Binop Type
-ops = Map.fromList [
-      (Add, (typeInt `TArr` (typeInt `TArr` typeInt)))
-    , (Mul, (typeInt `TArr` (typeInt `TArr` typeInt)))
-    , (Sub, (typeInt `TArr` (typeInt `TArr` typeInt)))
-    , (Eql, (typeInt `TArr` (typeInt `TArr` typeBool)))
-  ]
+ops :: Binop -> Type
+ops Add = typeInt `TArr` (typeInt `TArr` typeInt)
+ops Mul = typeInt `TArr` (typeInt `TArr` typeInt)
+ops Sub = typeInt `TArr` (typeInt `TArr` typeInt)
+ops Eql = typeInt `TArr` (typeInt `TArr` typeBool)
 
-infer :: Expr -> Infer Type
+infer :: Expr -> Infer (Type, [Constraint])
 infer expr = case expr of
-  Lit (LInt _)  -> return $ typeInt
-  Lit (LBool _) -> return $ typeBool
+  Lit (LInt _)  -> return (typeInt, [])
+  Lit (LBool _) -> return (typeBool, [])
 
-  Var x -> lookupEnv x
+  Var x -> do
+      t <- lookupEnv x
+      return (t, [])
 
   Lam x e -> do
     tv <- fresh
-    t <- inEnv (x, Forall [] tv) (infer e)
-    return (tv `TArr` t)
+    (t, c) <- inEnv (x, Forall [] tv) (infer e)
+    return (tv `TArr` t, c)
 
   App e1 e2 -> do
-    t1 <- infer e1
-    t2 <- infer e2
+    (t1, c1) <- infer e1
+    (t2, c2) <- infer e2
     tv <- fresh
-    uni t1 (t2 `TArr` tv)
-    return tv
+    return (tv, c1 ++ c2 ++ [(t1, t2 `TArr` tv)])
 
   Let x e1 e2 -> do
     env <- ask
-    t1 <- infer e1
-    let sc = generalize env t1
-    t2 <- inEnv (x, sc) (infer e2)
-    return t2
+    (t1, c1) <- infer e1
+    case runSolve c1 of
+        Left err -> throwError err
+        Right sub -> do
+            let sc = generalize (apply sub env) (apply sub t1)
+            (t2, c2) <- inEnv (x, sc) $ local (apply sub) (infer e2)
+            return (t2, c1 ++ c2)
 
   Fix e1 -> do
-    t1 <- infer e1
+    (t1, c1) <- infer e1
     tv <- fresh
-    uni (tv `TArr` tv) t1
-    return tv
+    return (tv, c1 ++ [(tv `TArr` tv, t1)])
 
   Op op e1 e2 -> do
-    t1 <- infer e1
-    t2 <- infer e2
+    (t1, c1) <- infer e1
+    (t2, c2) <- infer e2
     tv <- fresh
     let u1 = t1 `TArr` (t2 `TArr` tv)
-        u2 = ops Map.! op
-    uni u1 u2
-    return tv
+        u2 = ops op
+    return (tv, c1 ++ c2 ++ [(u1, u2)])
 
   If cond tr fl -> do
-    t1 <- infer cond
-    t2 <- infer tr
-    t3 <- infer fl
-    uni t1 typeBool
-    uni t2 t3
-    return t2
+    (t1, c1) <- infer cond
+    (t2, c2) <- infer tr
+    (t3, c3) <- infer fl
+    return (t2, c1 ++ c2 ++ c3 ++ [(t1, typeBool), (t2, t3)])
 
 inferTop :: Env -> [(String, Expr)] -> Either TypeError Env
 inferTop env [] = Right env
-inferTop env ((name, ex):xs) = case (inferExpr env ex) of
+inferTop env ((name, ex):xs) = case inferExpr env ex of
   Left err -> Left err
   Right ty -> inferTop (extend env (name, ty)) xs
 
@@ -276,12 +270,12 @@ solver (su, cs) =
     [] -> return su
     ((t1, t2): cs0) -> do
       su1  <- unifies t1 t2
-      solver (su1 `compose` su, (apply su1 cs0))
+      solver (su1 `compose` su, apply su1 cs0)
 
 bind ::  TVar -> Type -> Solve Subst
 bind a t | t == TVar a     = return emptySubst
          | occursCheck a t = throwError $ InfiniteType a t
-         | otherwise       = return $ (Subst $ Map.singleton a t)
+         | otherwise       = return (Subst $ Map.singleton a t)
 
 occursCheck ::  Substitutable a => TVar -> a -> Bool
 occursCheck a t = a `Set.member` ftv t

chapter7/poly_constraints/test.ml

@@ -97,6 +97,14 @@ let self = (\x -> x) (\x -> x);
 let innerlet = \x -> (let y = \z -> z in y);
 let innerletrec = \x -> (let rec y = \z -> z in y);
 
+-- Issue #72
+let f = let add = \a b -> a + b in add;
+
+-- Issue #82
+let y = \y -> (let f = \x -> if x then True else False in const (f y) y);
+let id x = x;
+let foo x = let y = id x in y + 1;
+
 -- Fresh variables
 let wtf = \a b c d e e' f g h i j k l m n o o' o'' o''' p q r r' s t u u' v w x y z ->
     q u i c k b r o w n f o' x j u' m p s o'' v e r' t h e' l a z y d o''' g;