mirror of
https://github.com/sdiehl/write-you-a-haskell.git
synced 2024-09-11 11:46:57 +03:00
rework poly directory
This commit is contained in:
parent
1b9f62c1d2
commit
480252bf0e
10
007_path.md
10
007_path.md
@ -745,7 +745,15 @@ Frontend
|
||||
========
|
||||
|
||||
The Frontend language for ProtoHaskell is a fairly large language, consisting of
|
||||
many different types. Let's walk through the different constructions.
|
||||
many different types. Let's walk through the different constructions. The
|
||||
frontend syntax is split across several datatypes.
|
||||
|
||||
* ``Decls`` - Declarations syntax
|
||||
* ``Expr`` - Expressions syntax
|
||||
* ``Lit`` - Literal syntax
|
||||
* ``Pat`` - Pattern syntax
|
||||
* ``Types`` - Type syntax
|
||||
* ``Binds`` - Binders
|
||||
|
||||
At the top is the named *Module* and all toplevel declarations contained
|
||||
therein. The first revision of the compiler has a very simple module structure,
|
||||
|
@ -19,4 +19,5 @@ executable poly
|
||||
, transformers >= 0.4.2 && <0.5
|
||||
, repline >= 0.1.2.0
|
||||
default-language: Haskell2010
|
||||
hs-source-dirs: src
|
||||
main-is: Main.hs
|
||||
|
@ -18,17 +18,18 @@ import Data.Foldable (foldr)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
newtype TypeEnv = TypeEnv (Map.Map Var Scheme) deriving Monoid
|
||||
newtype TypeEnv = TypeEnv (Map.Map Var Scheme)
|
||||
deriving Monoid
|
||||
|
||||
data Unique = Unique { count :: Int }
|
||||
type Infer a = ExceptT TypeError (State Unique) a
|
||||
|
||||
type Infer = ExceptT TypeError (State Unique)
|
||||
type Subst = Map.Map TVar Type
|
||||
|
||||
data TypeError
|
||||
= UnificationFail Type Type
|
||||
| InfiniteType TVar Type
|
||||
| UnboundVariable String
|
||||
| GenericTypeError
|
||||
|
||||
runInfer :: Infer (Subst, Type) -> Either TypeError Scheme
|
||||
runInfer m = case evalState (runExceptT m) initUnique of
|
||||
@ -86,9 +87,9 @@ s1 `compose` s2 = Map.map (apply s1) s2 `Map.union` s1
|
||||
|
||||
unify :: Type -> Type -> Infer Subst
|
||||
unify (l `TArr` r) (l' `TArr` r') = do
|
||||
s1 <- unify l l'
|
||||
s2 <- unify (apply s1 r) (apply s1 r')
|
||||
return (s2 `compose` s1)
|
||||
s1 <- unify l l'
|
||||
s2 <- unify (apply s1 r) (apply s1 r')
|
||||
return (s2 `compose` s1)
|
||||
|
||||
unify (TVar a) t = bind a t
|
||||
unify t (TVar a) = bind a t
|
||||
@ -96,9 +97,10 @@ unify (TCon a) (TCon b) | a == b = return nullSubst
|
||||
unify t1 t2 = throwError $ UnificationFail t1 t2
|
||||
|
||||
bind :: TVar -> Type -> Infer Subst
|
||||
bind a t | t == TVar a = return nullSubst
|
||||
| occursCheck a t = throwError $ InfiniteType a t
|
||||
| otherwise = return $ Map.singleton a t
|
||||
bind a t
|
||||
| t == TVar a = return nullSubst
|
||||
| occursCheck a t = throwError $ InfiniteType a t
|
||||
| otherwise = return $ Map.singleton a t
|
||||
|
||||
occursCheck :: Substitutable a => TVar -> a -> Bool
|
||||
occursCheck a t = a `Set.member` ftv t
|
||||
@ -120,7 +122,7 @@ instantiate (Forall as t) = do
|
||||
|
||||
generalize :: TypeEnv -> Type -> Scheme
|
||||
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 :: Binop -> Type
|
||||
ops Add = typeInt `TArr` typeInt `TArr` typeInt
|
||||
@ -129,7 +131,7 @@ ops Sub = typeInt `TArr` typeInt `TArr` typeInt
|
||||
ops Eql = typeInt `TArr` typeInt `TArr` typeBool
|
||||
|
||||
lookupEnv :: TypeEnv -> Var -> Infer (Subst, Type)
|
||||
lookupEnv (TypeEnv env) x = do
|
||||
lookupEnv (TypeEnv env) x =
|
||||
case Map.lookup x env of
|
||||
Nothing -> throwError $ UnboundVariable (show x)
|
||||
Just s -> do t <- instantiate s
|
||||
@ -180,17 +182,17 @@ inferPrim env l t = do
|
||||
(s1, tf) <- foldM inferStep (nullSubst, id) l
|
||||
s2 <- unify (apply s1 (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))
|
||||
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
|
||||
|
||||
inferTop :: TypeEnv -> [(String, Expr)] -> Either TypeError TypeEnv
|
||||
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
|
||||
|
Loading…
Reference in New Issue
Block a user