sdiehl/write-you-a-haskell
1
1
Fork 0
mirror of https://github.com/sdiehl/write-you-a-haskell.git synced 2024-07-14 23:10:53 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #89 from VitorCBSB/master

Browse Source 
Fix let inference (attempts to fix #72 and #82).
This commit is contained in:
Stephen Diehl 2016-10-31 12:19:02 +00:00 committed by GitHub
commit 903371f6c0
5 changed files with 86 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
006_hindley_milner.md
View File

@ -109,7 +109,7 @@ Polymorphism
We will add an additional constructs to our language that will admit a new form
of *polymorphism* for our language. Polymorphism is the property of a term to
simultaneously admit several distinct types for the same function
implementation.
implementation.
For instance the polymorphic signature for the identity function maps an input of
type $\alpha$
@ -123,7 +123,7 @@ $$
Now instead of having to duplicate the functionality for every possible type
(i.e. implementing idInt, idBool, ...) we our type system admits any
instantiation that is subsumed by the polymorphic type signature.
instantiation that is subsumed by the polymorphic type signature.
$$
\begin{aligned}
@ -425,13 +425,13 @@ $$
\tau_1 \sim \tau_1' : \theta_1 \andalso [\theta_1] \tau_2 \sim [\theta_1] \tau_2' : \theta_2
}{
\tau_1 \tau_2 \sim \tau_1' \tau_2' : \theta_2 \circ \theta_1
}
}
& \quad \trule{Uni-Con} \\ \\
\infrule{
\tau_1 \sim \tau_1' : \theta_1 \andalso [\theta_1] \tau_2 \sim [\theta_1] \tau_2' : \theta_2
}{
\tau_1 \rightarrow \tau_2 \sim \tau_1' \rightarrow \tau_2' : \theta_2 \circ \theta_1
}
}
& \quad \trule{Uni-Arrow} \\ \\
\end{array}
$$
@ -560,9 +560,9 @@ By contrast, binding ``f`` in a lambda will result in a type error.
```haskell
Poly> (\f -> let g = (f True) in (f 3)) (\x -> x)
Cannot unify types:
Cannot unify types:
Bool
with
with
Int
```
@ -572,7 +572,7 @@ Typing Rules
------------
And finally with all the typing machinery in place, we can write down the typing
rules for our simple little polymorphic lambda calculus.
rules for our simple little polymorphic lambda calculus.
```haskell
infer :: TypeEnv -> Expr -> Infer (Subst, Type)
@ -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.
@ -760,9 +760,9 @@ ops = Map.fromList [
$$
\begin{array}{cl}
(+) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(\times) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(-) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(+) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(\times) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(-) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Int} \\
(=) &: \t{Int} \rightarrow \t{Int} \rightarrow \t{Bool} \\
\end{array}
$$
@ -786,7 +786,7 @@ Constraint Generation
The previous implementation of Hindley Milner is simple, but has this odd
property of intermingling two separate processes: constraint solving and
traversal. Let's discuss another implementation of the inference algorithm that
does not do this.
does not do this.
In the *constraint generation* approach, constraints are generated by bottom-up
traversal, added to a ordered container, canonicalized, solved, and then
@ -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
@ -993,7 +993,7 @@ By applying **Uni-Arrow** we can then deduce the following set of substitutions.
1. ``a ~ Int``
2. ``b ~ Int``
3. ``c ~ Int``
4. ``d ~ Int``
4. ``d ~ Int``
5. ``e ~ Int``
Substituting this solution back over the type yields the inferred type:
@ -1033,7 +1033,7 @@ So we get this type:
compose :: forall c d e. (d -> e) -> (c -> d) -> c -> e
```
If desired, we can rename the variables in alphabetical order to get:
If desired, we can rename the variables in alphabetical order to get:
```haskell
compose :: forall a b c. (a -> b) -> (c -> a) -> c -> b
@ -1086,7 +1086,7 @@ eval env expr = case expr of
VInt b' <- eval env b
return $ (binop op) a' b'
Lam x body ->
Lam x body ->
return (VClosure x body env)
App fun arg -> do
@ -1338,9 +1338,9 @@ Also programs that are also not well-typed are now rejected outright as well.
```haskell
Poly> 1 + True
Cannot unify types:
Cannot unify types:
Bool
with
with
Int
```
@ -1356,15 +1356,15 @@ instance both ``fact`` and ``fib`` functions uses the fixpoint to compute
Fibonacci numbers or factorials.
```haskell
let fact = fix (\fact -> \n ->
if (n == 0)
then 1
let fact = fix (\fact -> \n ->
if (n == 0)
then 1
else (n * (fact (n-1))));
let rec fib n =
if (n == 0)
let rec fib n =
if (n == 0)
then 0
else if (n==1)
else if (n==1)
then 1
else ((fib (n-1)) + (fib (n-2)));
```

1
CONTRIBUTORS.md
View File

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

3
chapter7/poly_constraints/poly.cabal
View File

@ -9,7 +9,7 @@ extra-source-files: README.md
cabal-version: >=1.10
executable poly
build-depends:
build-depends:
base >= 4.6 && <4.9
, pretty >= 1.1 && <1.2
, parsec >= 3.1 && <3.2
@ -20,6 +20,7 @@ executable poly
, repline >= 0.1.2.0
other-modules:
Env
Eval
Infer
Lexer

96
chapter7/poly_constraints/src/Infer.hs
View File

@ -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

18
chapter7/poly_constraints/test.ml
View File

@ -47,7 +47,7 @@ let sub m n = (n pred) m;
let unbool n = n True False;
let unchurch n = n (\i -> i + 1) 0;
let rec church n =
let rec church n =
if (n == 0)
then zero
else \f x -> f (church (n-1) f x);
@ -77,10 +77,10 @@ let indx xs n = head (n tail xs);
let fact = fix (\fact -> \n -> if (n == 0) then 1 else (n * (fact (n-1))));
let rec fib n =
if (n == 0)
let rec fib n =
if (n == 0)
then 0
else if (n==1)
else if (n==1)
then 1
else ((fib (n-1)) + (fib (n-2)));
@ -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;
@ -105,7 +113,7 @@ 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
let notbool x = if x then False else True;
let eqzero x = if (x == 0) then True else False;
let rec until p f x =
let rec until p f x =
if (p x)
then x
else (until p f (f x));