mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-08-17 23:50:21 +03:00
Merge pull request #89 from VitorCBSB/master
Fix let inference (attempts to fix #72 and #82).
This commit is contained in:
commit
903371f6c0
@ -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
|
||||
|
@ -15,3 +15,4 @@ Contributors
|
||||
* Christian Sievers
|
||||
* Franklin Chen
|
||||
* Jake Taylor
|
||||
* Vitor Coimbra
|
||||
|
@ -20,6 +20,7 @@ executable poly
|
||||
, repline >= 0.1.2.0
|
||||
|
||||
other-modules:
|
||||
Env
|
||||
Eval
|
||||
Infer
|
||||
Lexer
|
||||
|
@ -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
|
||||
|
@ -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;
|
||||
|
Loading…
Reference in New Issue
Block a user