add constant functs

[cc1516.git] / sem.icl

diff --git a/sem.icl b/sem.icl
index 0da9c77..668bbeb 100644 (file)
--- a/sem.icl
+++ b/sem.icl
@@ -50,8 +50,8 @@ variableStream = map toString [1..]
 
 defaultGamma :: Gamma //includes all default functions
 defaultGamma = extend "print" (Forall ["a"] ((IdType "a") ->> VoidType))
-                $ extend "isEmpty" (Forall ["a"] (ListType (IdType "a") ->> BoolType))
-                $ extend "read" (Forall [] (IntType ->> (ListType CharType)))
+                $ extend "isEmpty" (Forall ["a"] ((ListType (IdType "a")) ->> BoolType))
+                $ extend "read" (Forall [] (FuncType CharType))
                 zero
 
 sem :: AST -> Either [SemError] AST
@@ -102,10 +102,12 @@ instance Typeable Type where
     ftv (TupleType (t1, t2))    = ftv t1 ++ ftv t2
     ftv (ListType t)            = ftv t
     ftv (IdType tvar)           = [tvar]
+    ftv (FuncType t)            = ftv t
     ftv (t1 ->> t2)             = ftv t1 ++ ftv t2
     ftv _                       = []
     subst s (TupleType (t1, t2))= TupleType (subst s t1, subst s t2)
     subst s (ListType t1)       = ListType (subst s t1)
+    subst s (FuncType t)         = FuncType (subst s t)
     subst s (t1 ->> t2)         = (subst s t1) ->> (subst s t2)
     subst s t1=:(IdType tvar)   = 'Map'.findWithDefault t1 tvar s
     subst s t                   = t
@@ -178,7 +180,6 @@ generalize :: Type -> Typing Scheme
 generalize t = gamma >>= \g-> pure $ Forall (difference (ftv t) (ftv g)) t
 
 lookup :: String -> Typing Type 
-lookup "isEmpty" = ListType <$> fresh
 lookup k = gamma >>= \g-> case 'Map'.member k g of
     False = liftT (Left $ UndeclaredVariableError zero k)
     True = instantiate $ 'Map'.find k g
@@ -192,9 +193,9 @@ class infer a :: a -> Typing (Substitution, Type)
 
 instance infer Expr where 
  infer e = case e of
-    VarExpr _ (VarDef k fs) = (\t->(zero,t)) <$> lookup k
-    //instantiate is key for the let polymorphism!
-    //TODO: field selectors
+    VarExpr _ (VarDef k fs) = lookup k >>= \t ->
+        foldM foldFieldSelectors t fs >>= \finalT ->
+        pure (zero, finalT)
 
     Op2Expr _ e1 op e2 =
         infer e1 >>= \(s1, t1) -> 
@@ -224,15 +225,24 @@ instance infer Expr where
         lookup f >>= \expected ->
         let accST = (\(s,ts) e->infer e >>= \(s_,et)->pure (compose s_ s,ts++[et])) in
         foldM accST (zero,[]) args >>= \(s1, argTs)->
-        fresh >>= \tv->
-        let given = foldr (->>) tv argTs in
-        lift (unify expected given) >>= \s2->
-        pure (compose s2 s1, subst s2 tv)
+        fresh >>= \tv->case expected of
+                       FuncType t = pure (s1, t)
+                       _ = (let given = foldr (->>) tv argTs in
+                       lift (unify expected given) >>= \s2->
+                       let fReturnType = subst s2 tv in
+                       foldM foldFieldSelectors fReturnType fs >>= \returnType ->
+                       pure (compose s2 s1, returnType))
 
     IntExpr _ _ = pure $ (zero, IntType)
     BoolExpr _ _ = pure $ (zero, BoolType)
     CharExpr _ _ = pure $ (zero, CharType)
 
+foldFieldSelectors :: Type FieldSelector -> Typing Type 
+foldFieldSelectors (ListType t) (FieldHd) = pure t
+foldFieldSelectors t=:(ListType _) (FieldTl) = pure t 
+foldFieldSelectors (TupleType (t1, _)) (FieldFst) = pure t1
+foldFieldSelectors (TupleType (_, t2)) (FieldSnd) = pure t2
+foldFieldSelectors t fs = liftT $ Left $ FieldSelectorError zero t fs
 
 op2Type :: Op2 -> Typing Type
 op2Type op
@@ -278,17 +288,24 @@ instance infer Stmt where
     AssStmt (VarDef k fs) e =
         lookup k >>= \expected ->
         infer e >>= \(s1, given)->
-        lift (unify expected given) >>= \s2->
+        foldM reverseFs given (reverse fs) >>= \varType->
+        lift (unify expected varType) >>= \s2->
         let s = compose s2 s1 in
         applySubst s >>|
-        changeGamma (extend k (Forall [] given)) >>| //todo: fieldselectors
+        changeGamma (extend k (Forall [] (subst s varType))) >>| 
         pure (s, VoidType)
 
-    FunStmt f es = pure (zero, VoidType) 
+    FunStmt f es _ = pure (zero, VoidType) 
 
     ReturnStmt Nothing = pure (zero, VoidType)
     ReturnStmt (Just e) = infer e
 
+reverseFs :: Type FieldSelector -> Typing Type 
+reverseFs t FieldHd = pure $ ListType t
+reverseFs t FieldTl = pure $ ListType t 
+reverseFs t FieldFst = fresh >>= \tv -> pure $ TupleType (t, tv)
+reverseFs t FieldSnd = fresh >>= \tv -> pure $ TupleType (tv, t)
+
 //The type of a list of statements is either an encountered
 //return, or VoidType
 instance infer [a] | infer a where