readchar in sem

[cc1516.git] / sem.icl

diff --git a/sem.icl b/sem.icl
index 082cfe9..0c5b552 100644 (file)
--- a/sem.icl
+++ b/sem.icl
@@ -26,7 +26,6 @@ from Text import class Text(concat), instance Text String
 
 import AST
 
-
 :: Scheme = Forall [TVar] Type
 :: Gamma :== 'Map'.Map String Scheme //map from Variables! to types
 :: Typing a :== StateT (Gamma, [TVar]) (Either SemError) a
@@ -49,11 +48,17 @@ instance zero Gamma where
 variableStream :: [TVar]
 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 [] CharType)
+                zero
+
 sem :: AST -> Either [SemError] AST
 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd 
                        >>| foldM (const isNiceMain) () fd
                        >>| hasMain fd
-                    >>| evalStateT (type fd) (zero, variableStream) of
+                    >>| evalStateT (type fd) (defaultGamma, variableStream) of
        Left e = Left [e]
     Right (_,fds) = Right (AST fds)
 where
@@ -186,9 +191,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) -> 
@@ -221,12 +226,20 @@ instance infer Expr where
         fresh >>= \tv->
         let given = foldr (->>) tv argTs in
         lift (unify expected given) >>= \s2->
-        pure (compose s2 s1, subst s2 tv)
+        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
@@ -270,16 +283,26 @@ instance infer Stmt where
         pure (compose s3 $ compose s2 s1, subst s3 wht)
 
     AssStmt (VarDef k fs) e =
-        infer e >>= \(s1, et)->
-        applySubst s1 >>|
-        changeGamma (extend k (Forall [] et)) >>| //todo: fieldselectors
-        pure (s1, VoidType)
+        lookup k >>= \expected ->
+        infer e >>= \(s1, given)->
+        foldM reverseFs given (reverse fs) >>= \varType->
+        lift (unify expected varType) >>= \s2->
+        let s = compose s2 s1 in
+        applySubst s >>|
+        changeGamma (extend k (Forall [] (subst s varType))) >>| 
+        pure (s, VoidType)
 
-    FunStmt f es = undef //what is this? 
+    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
@@ -345,25 +368,6 @@ instance type [a] | type a where
         applySubst (compose s2 s1) >>|
         pure (compose s2 s1, [v_:vs_])
 
-//        mapM processGamma dcls//
-
-////add the infered type in Gamma to AST constructs
-//class processGamma a :: a -> Typing a//
-
-//instance processGamma VarDecl where
-//    processGamma v=:(VarDecl p _ k e) = 
-//        gamma >>= \g -> case 'Map'.member k g of
-//            False = undef
-//            True  = instantiate ('Map'.find k g) >>= \t->
-//                    pure (VarDecl p (Just t) k e)//
-
-//instance processGamma FunDecl where
-//    processGamma v=:(FunDecl p k args _ vds stmts) = 
-//        gamma >>= \g -> case 'Map'.member k g of
-//            False = undef
-//            True  = instantiate ('Map'.find k g) >>= \t->
-//                    pure (FunDecl p k args (Just t) vds stmts) 
-
 introduce :: String -> Typing Type
 introduce k = 
     fresh >>= \tv ->