mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-09-11 19:47:31 +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**
|
**T-App**
|
||||||
|
|
||||||
For applications, the first argument must be a lambda expression or return a
|
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
|
lambda expression, so we know it must be of form ``t1 -> t2`` but the output
|
||||||
is not determined except by the confluence of the two values. We infer both
|
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
|
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
|
inferred type and then unify the two types with the excepted form of the entire
|
||||||
application expression.
|
application expression.
|
||||||
@ -841,7 +841,7 @@ Typing
|
|||||||
The typing rules are identical, except they now can be written down in a much
|
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
|
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
|
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
|
```haskell
|
||||||
infer :: Expr -> Infer Type
|
infer :: Expr -> Infer Type
|
||||||
|
@ -15,3 +15,4 @@ Contributors
|
|||||||
* Christian Sievers
|
* Christian Sievers
|
||||||
* Franklin Chen
|
* Franklin Chen
|
||||||
* Jake Taylor
|
* Jake Taylor
|
||||||
|
* Vitor Coimbra
|
||||||
|
@ -20,6 +20,7 @@ executable poly
|
|||||||
, repline >= 0.1.2.0
|
, repline >= 0.1.2.0
|
||||||
|
|
||||||
other-modules:
|
other-modules:
|
||||||
|
Env
|
||||||
Eval
|
Eval
|
||||||
Infer
|
Infer
|
||||||
Lexer
|
Lexer
|
||||||
|
@ -16,7 +16,7 @@ import Syntax
|
|||||||
|
|
||||||
import Control.Monad.Except
|
import Control.Monad.Except
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.RWS
|
import Control.Monad.Reader
|
||||||
import Control.Monad.Identity
|
import Control.Monad.Identity
|
||||||
|
|
||||||
import Data.List (nub)
|
import Data.List (nub)
|
||||||
@ -28,12 +28,12 @@ import qualified Data.Set as Set
|
|||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Inference monad
|
-- | Inference monad
|
||||||
type Infer a = (RWST
|
type Infer a = (ReaderT
|
||||||
Env -- Typing environment
|
Env -- Typing environment
|
||||||
[Constraint] -- Generated constraints
|
(StateT -- Inference state
|
||||||
InferState -- Inference state
|
InferState
|
||||||
(Except -- Inference errors
|
(Except -- Inference errors
|
||||||
TypeError)
|
TypeError))
|
||||||
a) -- Result
|
a) -- Result
|
||||||
|
|
||||||
-- | Inference state
|
-- | Inference state
|
||||||
@ -95,8 +95,8 @@ data TypeError
|
|||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Run the inference monad
|
-- | Run the inference monad
|
||||||
runInfer :: Env -> Infer Type -> Either TypeError (Type, [Constraint])
|
runInfer :: Env -> Infer (Type, [Constraint]) -> Either TypeError (Type, [Constraint])
|
||||||
runInfer env m = runExcept $ evalRWST m env initInfer
|
runInfer env m = runExcept $ evalStateT (runReaderT m env) initInfer
|
||||||
|
|
||||||
-- | Solve for the toplevel type of an expression in a given environment
|
-- | Solve for the toplevel type of an expression in a given environment
|
||||||
inferExpr :: Env -> Expr -> Either TypeError Scheme
|
inferExpr :: Env -> Expr -> Either TypeError Scheme
|
||||||
@ -112,7 +112,7 @@ constraintsExpr env ex = case runInfer env (infer ex) of
|
|||||||
Left err -> Left err
|
Left err -> Left err
|
||||||
Right (ty, cs) -> case runSolve cs of
|
Right (ty, cs) -> case runSolve cs of
|
||||||
Left err -> Left err
|
Left err -> Left err
|
||||||
Right subst -> Right $ (cs, subst, ty, sc)
|
Right subst -> Right (cs, subst, ty, sc)
|
||||||
where
|
where
|
||||||
sc = closeOver $ apply subst ty
|
sc = closeOver $ apply subst ty
|
||||||
|
|
||||||
@ -120,10 +120,6 @@ constraintsExpr env ex = case runInfer env (infer ex) of
|
|||||||
closeOver :: Type -> Scheme
|
closeOver :: Type -> Scheme
|
||||||
closeOver = normalize . generalize Env.empty
|
closeOver = normalize . generalize Env.empty
|
||||||
|
|
||||||
-- | Unify two types
|
|
||||||
uni :: Type -> Type -> Infer ()
|
|
||||||
uni t1 t2 = tell [(t1, t2)]
|
|
||||||
|
|
||||||
-- | Extend type environment
|
-- | Extend type environment
|
||||||
inEnv :: (Name, Scheme) -> Infer a -> Infer a
|
inEnv :: (Name, Scheme) -> Infer a -> Infer a
|
||||||
inEnv (x, sc) m = do
|
inEnv (x, sc) m = do
|
||||||
@ -150,7 +146,7 @@ fresh = do
|
|||||||
|
|
||||||
instantiate :: Scheme -> Infer Type
|
instantiate :: Scheme -> Infer Type
|
||||||
instantiate (Forall as t) = do
|
instantiate (Forall as t) = do
|
||||||
as' <- mapM (\_ -> fresh) as
|
as' <- mapM (const fresh) as
|
||||||
let s = Subst $ Map.fromList $ zip as as'
|
let s = Subst $ Map.fromList $ zip as as'
|
||||||
return $ apply s t
|
return $ apply s t
|
||||||
|
|
||||||
@ -158,66 +154,64 @@ generalize :: Env -> Type -> Scheme
|
|||||||
generalize env t = Forall as t
|
generalize env t = Forall as t
|
||||||
where as = Set.toList $ ftv t `Set.difference` ftv env
|
where as = Set.toList $ ftv t `Set.difference` ftv env
|
||||||
|
|
||||||
ops :: Map.Map Binop Type
|
ops :: Binop -> Type
|
||||||
ops = Map.fromList [
|
ops Add = typeInt `TArr` (typeInt `TArr` typeInt)
|
||||||
(Add, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
ops Mul = typeInt `TArr` (typeInt `TArr` typeInt)
|
||||||
, (Mul, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
ops Sub = typeInt `TArr` (typeInt `TArr` typeInt)
|
||||||
, (Sub, (typeInt `TArr` (typeInt `TArr` typeInt)))
|
ops Eql = typeInt `TArr` (typeInt `TArr` typeBool)
|
||||||
, (Eql, (typeInt `TArr` (typeInt `TArr` typeBool)))
|
|
||||||
]
|
|
||||||
|
|
||||||
infer :: Expr -> Infer Type
|
infer :: Expr -> Infer (Type, [Constraint])
|
||||||
infer expr = case expr of
|
infer expr = case expr of
|
||||||
Lit (LInt _) -> return $ typeInt
|
Lit (LInt _) -> return (typeInt, [])
|
||||||
Lit (LBool _) -> return $ typeBool
|
Lit (LBool _) -> return (typeBool, [])
|
||||||
|
|
||||||
Var x -> lookupEnv x
|
Var x -> do
|
||||||
|
t <- lookupEnv x
|
||||||
|
return (t, [])
|
||||||
|
|
||||||
Lam x e -> do
|
Lam x e -> do
|
||||||
tv <- fresh
|
tv <- fresh
|
||||||
t <- inEnv (x, Forall [] tv) (infer e)
|
(t, c) <- inEnv (x, Forall [] tv) (infer e)
|
||||||
return (tv `TArr` t)
|
return (tv `TArr` t, c)
|
||||||
|
|
||||||
App e1 e2 -> do
|
App e1 e2 -> do
|
||||||
t1 <- infer e1
|
(t1, c1) <- infer e1
|
||||||
t2 <- infer e2
|
(t2, c2) <- infer e2
|
||||||
tv <- fresh
|
tv <- fresh
|
||||||
uni t1 (t2 `TArr` tv)
|
return (tv, c1 ++ c2 ++ [(t1, t2 `TArr` tv)])
|
||||||
return tv
|
|
||||||
|
|
||||||
Let x e1 e2 -> do
|
Let x e1 e2 -> do
|
||||||
env <- ask
|
env <- ask
|
||||||
t1 <- infer e1
|
(t1, c1) <- infer e1
|
||||||
let sc = generalize env t1
|
case runSolve c1 of
|
||||||
t2 <- inEnv (x, sc) (infer e2)
|
Left err -> throwError err
|
||||||
return t2
|
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
|
Fix e1 -> do
|
||||||
t1 <- infer e1
|
(t1, c1) <- infer e1
|
||||||
tv <- fresh
|
tv <- fresh
|
||||||
uni (tv `TArr` tv) t1
|
return (tv, c1 ++ [(tv `TArr` tv, t1)])
|
||||||
return tv
|
|
||||||
|
|
||||||
Op op e1 e2 -> do
|
Op op e1 e2 -> do
|
||||||
t1 <- infer e1
|
(t1, c1) <- infer e1
|
||||||
t2 <- infer e2
|
(t2, c2) <- infer e2
|
||||||
tv <- fresh
|
tv <- fresh
|
||||||
let u1 = t1 `TArr` (t2 `TArr` tv)
|
let u1 = t1 `TArr` (t2 `TArr` tv)
|
||||||
u2 = ops Map.! op
|
u2 = ops op
|
||||||
uni u1 u2
|
return (tv, c1 ++ c2 ++ [(u1, u2)])
|
||||||
return tv
|
|
||||||
|
|
||||||
If cond tr fl -> do
|
If cond tr fl -> do
|
||||||
t1 <- infer cond
|
(t1, c1) <- infer cond
|
||||||
t2 <- infer tr
|
(t2, c2) <- infer tr
|
||||||
t3 <- infer fl
|
(t3, c3) <- infer fl
|
||||||
uni t1 typeBool
|
return (t2, c1 ++ c2 ++ c3 ++ [(t1, typeBool), (t2, t3)])
|
||||||
uni t2 t3
|
|
||||||
return t2
|
|
||||||
|
|
||||||
inferTop :: Env -> [(String, Expr)] -> Either TypeError Env
|
inferTop :: Env -> [(String, Expr)] -> Either TypeError Env
|
||||||
inferTop env [] = Right 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
|
Left err -> Left err
|
||||||
Right ty -> inferTop (extend env (name, ty)) xs
|
Right ty -> inferTop (extend env (name, ty)) xs
|
||||||
|
|
||||||
@ -276,12 +270,12 @@ solver (su, cs) =
|
|||||||
[] -> return su
|
[] -> return su
|
||||||
((t1, t2): cs0) -> do
|
((t1, t2): cs0) -> do
|
||||||
su1 <- unifies t1 t2
|
su1 <- unifies t1 t2
|
||||||
solver (su1 `compose` su, (apply su1 cs0))
|
solver (su1 `compose` su, apply su1 cs0)
|
||||||
|
|
||||||
bind :: TVar -> Type -> Solve Subst
|
bind :: TVar -> Type -> Solve Subst
|
||||||
bind a t | t == TVar a = return emptySubst
|
bind a t | t == TVar a = return emptySubst
|
||||||
| occursCheck a t = throwError $ InfiniteType a t
|
| 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 :: Substitutable a => TVar -> a -> Bool
|
||||||
occursCheck a t = a `Set.member` ftv t
|
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 innerlet = \x -> (let y = \z -> z in y);
|
||||||
let innerletrec = \x -> (let rec 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
|
-- 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 ->
|
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;
|
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