X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=5cf0520adb2a8d68f50d664ae427a994e0052a0f;hb=74b900cf6db033a51e177f7f85d835dae44217e5;hp=75b55851e5f4bd1e6e04165ed7c45913676fd916;hpb=a5c4e896f3f80da310ebd2a562672a47b62d323a;p=cc1516.git

diff --git a/sem.icl b/sem.icl
index 75b5585..5cf0520 100644
--- a/sem.icl
+++ b/sem.icl
@@ -51,7 +51,10 @@ 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)
+                $ extend "read" (Forall [] (FuncType CharType))
+                $ extend "1printchar" (Forall [] (CharType ->> VoidType))
+                $ extend "1printint" (Forall [] (IntType ->> VoidType))
+                $ extend "1printbool" (Forall [] (BoolType ->> VoidType))
                 zero
 
 sem :: AST -> Either [SemError] AST
@@ -102,10 +105,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
@@ -141,6 +146,7 @@ unify (TupleType (ta1,ta2)) (TupleType (tb1,tb2)) = unify ta1 tb1 >>= \s1->
                                                     unify ta2 tb2 >>= \s2->
                                                     Right $ compose s1 s2
 unify (ListType t1) (ListType t2) = unify t1 t2
+unify (FuncType t1) (FuncType t2) = unify t1 t2
 unify t1 t2 | t1 == t2  = Right zero
             | otherwise = Left $ UnifyError zero t1 t2
 
@@ -219,24 +225,27 @@ instance infer Expr where
         infer e2 >>= \(s2, t2, e2_) ->
         pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 
-    FunExpr p f args fs = //todo: fix print
+    LambdaExpr _ _ _ = liftT $ Left $ Error "PANIC: lambdas should be tasnformed"
+
+    FunExpr p f args fs =
         lookup f >>= \expected ->
         let accST = (\(s,ts,es) e->infer e >>= \(s_,et,e_)-> pure (compose s_ s,ts++[et],es++[e_])) in
         foldM accST (zero,[],[]) args >>= \(s1, argTs, args_)->
-        fresh >>= \tv->
-        let given = foldr (->>) tv argTs in
-        lift (unify expected given) >>= \s2->
-        let fReturnType = subst s2 tv in
-        foldM foldFieldSelectors fReturnType fs >>= \returnType ->
-        (case f of
-            "print" = case head argTs of
-                IntType = pure "1printint"
-                CharType = pure "1printchar"
-                BoolType = pure "1printbool"
-                ListType (CharType) = pure "1printstr"
-                t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
-            _ = pure f) >>= \newF->
-        pure (compose s2 s1, returnType, FunExpr p newF args_ fs)
+        fresh >>= \tv->case expected of
+            FuncType t = pure (s1, t, e)
+            _ = (let given = foldr (->>) tv argTs in
+                lift (unify expected given) >>= \s2->
+                let fReturnType = subst s2 tv in
+                foldM foldFieldSelectors fReturnType fs >>= \returnType ->
+                (case f of
+                    "print" = case head argTs of
+                        IntType = pure "1printint"
+                        CharType = pure "1printchar"
+                        BoolType = pure "1printbool"
+                        ListType (CharType) = pure "1printstr"
+                        t = liftT $ Left $ SanityError p ("can not print " +++ toString t)
+                    _ = pure f) >>= \newF->
+                pure (compose s2 s1, returnType, FunExpr p newF args_ fs))
 
     IntExpr _ _ = pure $ (zero, IntType, e)
     BoolExpr _ _ = pure $ (zero, BoolType, e)
@@ -376,13 +385,18 @@ instance type FunDecl where
         let given = foldr (->>) result argTs_ in 
         (case expected of
             Nothing = pure zero
-            Just expected_ = lift (unify expected_ given))
-        >>= \s3 ->
+            Just (FuncType expected_) = lift (unify expected_ given)
+            Just expected_ = lift (unify expected_ given)
+        ) >>= \s3 ->
         let ftype = subst (compose s3 $ compose s2 s1) given in
-        generalize ftype >>= \t->
+        (case ftype of
+            _ ->> _ = pure ftype
+            _       = pure $ FuncType ftype
+        ) >>= \ftype_->
+        generalize ftype_ >>= \t->
         putGamma outerScope >>|
         changeGamma (extend f t) >>| 
-        pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype) tVds stmts_)
+        pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype_) tVds stmts_)
 
 instance type [a] | type a where
     type []     = pure (zero, [])