checker update

[minfp.git] / check.icl

diff --git a/check.icl b/check.icl
index d717040..c2a7506 100644 (file)
--- a/check.icl
+++ b/check.icl
@@ -16,10 +16,18 @@ from Data.Map import instance Functor (Map k)
 
 import ast
 
-check :: AST -> Either [String] AST
+//Start = runRWST (infer (AST [(Function ['s','t','a','r','t'] [] (Lit (Int 42)))])
+Start = runRWST (infer (TypeEnv 'DM'.newMap) t) [] {tiSupply=0,tiSubst='DM'.newMap}
+where
+       t = Function ['start'] [] (Lit (Int 42))
+
+check :: AST -> Either [String] (Type, AST)
 check (AST fs) = case find (\f->f=:(Function ['start'] [] _)) fs of
        Nothing = Left ["No start function defined"]
-       Just _ = Right (AST fs)
+       Just _ = Right undef/*case runRWST (infer fs) [] 'DM'.newMap of
+               Left e = Left e
+               Right (a, s, _) = Right (a, s)
+*/
 
 :: Type
        = TVar [Char]
@@ -27,6 +35,7 @@ check (AST fs) = case find (\f->f=:(Function ['start'] [] _)) fs of
        | TBool
        | TChar
        | TFun Type Type
+
 instance == Type where
        (==) (TVar a) (TVar b) = a == b
        (==) TInt TInt = True
@@ -34,16 +43,19 @@ instance == Type where
        (==) TChar TChar = True
        (==) (TFun a1 a2) (TFun b1 b2) = a1 == b1 && a2 == b2
        (==) _ _ = False
+
 instance toString Type where
        toString (TVar s) = toString s
        toString TInt = "Int"
        toString TBool = "Bool"
        toString TChar = "Char"
        toString (TFun t1 t2) = toString t1 +++ " -> " +++ toString t2
+
 :: Scheme = Scheme [[Char]] Type
 class Types a where
        ftv :: a -> [[Char]]
        apply :: Subst a -> a
+
 instance Types Type where
        ftv (TVar n) = [n]
        ftv TInt = []
@@ -56,9 +68,11 @@ instance Types Type where
                Just t = t
        apply s (TFun t1 t2) = TFun (apply s t1) (apply s t2)
        apply s t = t
+
 instance Types Scheme where
        ftv (Scheme vars t) = difference (ftv t) vars
        apply s (Scheme vars t) = Scheme vars (apply (foldr 'DM'.del s vars) t)
+
 instance Types [a] | Types a where
        ftv l = foldr union [] (map ftv l)
        apply s l = map (apply s) l
@@ -108,10 +122,12 @@ instantiate (Scheme vars t)
        >>= \nvars->pure (apply ('DM'.fromList (zip2 vars nvars)) t)
 
 class infer a :: TypeEnv a -> TI (Subst, Type)
+
 instance infer Value where
        infer _ (Int _) = pure ('DM'.newMap, TInt)
        infer _ (Bool _) = pure ('DM'.newMap, TBool)
        infer _ (Char _) = pure ('DM'.newMap, TChar)
+
 instance infer Expression where
        infer e (Lit a) = infer e a
        infer (TypeEnv env) (Var v) = case 'DM'.get v env of
@@ -123,7 +139,17 @@ instance infer Expression where
                >>= \(s1, t1)->infer (apply s1 env) e2
                >>= \(s2, t2)->mgu (apply s2 t1) (TFun t2 tv)
                >>= \s3->pure (composeSubst s3 (composeSubst s2 s1), apply s3 tv)
-       //infer env (Lambda s e)
-       //      =        newTyVar ['l']
-       //      >>= \tv->pure undef//inEnv (s, Forall [] tv) (infer e)
-       //      >>= \t-> pure (TFun tv t)
+       infer env (Lambda s e)
+               =        newTyVar ['l']
+               >>= \tv->
+                       let (TypeEnv env`) = remove env s
+                           env`` = TypeEnv ('DM'.union env` ('DM'.singleton s (Scheme [] tv)))
+                       in infer env`` e
+               >>= \(s1, t1)->pure (s1, TFun (apply s1 tv) t1)
+
+instance infer Function where
+       infer env (Function name [] body)
+               = infer env body
+
+typeInference :: ('DM'.Map [Char] Scheme) Expression -> TI Type
+typeInference env e = uncurry apply <$> infer (TypeEnv env) e