Merge pull request #37 from chsievers/inferL

poly: infer - a new approach

chapter7/poly/Infer.hs

@@ -158,34 +158,33 @@ infer env ex = case ex of
     let env' = apply s1 env
         t'   = generalize env' t1
     (s2, t2) <- infer (env' `extend` (x, t')) e2
-    return (s1 `compose` s2, t2)
+    return (s2 `compose` s1, t2)
 
   If cond tr fl -> do
-    (s1, t1) <- infer env cond
-    (s2, t2) <- infer env tr
-    (s3, t3) <- infer env fl
-    s4 <- unify (apply (compose s2 s3) t1) typeBool
-    s5 <- unify (apply (compose s1 s4) t2) (apply (compose s1 s4) t3)
-    let s6 = s4 `compose` s5
-    return (s6, apply s6 t2)
+    tv <- fresh
+    inferPrim env [cond, tr, fl] (typeBool `TArr` tv `TArr` tv `TArr` tv)
 
   Fix e1 -> do
-    (s1, t) <- infer env e1
     tv <- fresh
-    s2 <- unify (apply s1 (TArr tv tv)) (apply s1 t)
-    let s3 = s2 `compose` s1
-    return (s3, apply s3 tv)
+    inferPrim env [e1] ((tv `TArr` tv) `TArr` tv)
 
   Op op e1 e2 -> do
-    (s1, t1) <- infer env e1
-    (s2, t2) <- infer env e2
-    tv <- fresh
-    s3 <- unify (TArr t1 (TArr t2 tv)) (ops op)
-    return (s1 `compose` s2 `compose` s3, apply s3 tv)
+    inferPrim env [e1, e2] (ops op)
 
   Lit (LInt _)  -> return (nullSubst, typeInt)
   Lit (LBool _) -> return (nullSubst, typeBool)
 
+inferPrim :: TypeEnv -> [Expr] -> Type -> Infer (Subst, Type)
+inferPrim env l t = do
+  tv <- fresh
+  (s1, tf) <- foldM inferStep (nullSubst, id) l
+  s2 <- unify (tf tv) t
+  return (s2 `compose` s1, apply s2 tv)
+
+  where inferStep (s, tf) exp = do 
+          (s', t) <- infer (apply s env) exp
+          return (s' `compose` s, tf . (TArr t))
+
 inferExpr :: TypeEnv -> Expr -> Either TypeError Scheme
 inferExpr env = runInfer . infer env