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

diff --git a/sem.icl b/sem.icl
index 272ef5a..5cf0520 100644
--- a/sem.icl
+++ b/sem.icl
@@ -26,9 +26,9 @@ 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
 :: Substitution :== 'Map'.Map TVar Type
 :: Constraints :== [(Type, Type)]
 :: SemError
@@ -48,34 +48,23 @@ instance zero Gamma where
 variableStream :: [TVar]
 variableStream = map toString [1..]
 
-sem :: AST -> Either [SemError] Constraints
+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 [] (FuncType CharType))
+                $ extend "1printchar" (Forall [] (CharType ->> VoidType))
+                $ extend "1printint" (Forall [] (IntType ->> VoidType))
+                $ extend "1printbool" (Forall [] (BoolType ->> VoidType))
+                zero
+
+sem :: AST -> Either [SemError] AST
 sem (AST fd) = case foldM (const $ hasNoDups fd) () fd 
-		>>| foldM (const isNiceMain) () fd
-		>>| hasMain fd of
+            		>>| foldM (const isNiceMain) () fd
+            		>>| hasMain fd
+                    >>| evalStateT (type fd) (defaultGamma, variableStream) of
 	Left e = Left [e]
-    _ = Right []
-	//_ = case execRWST (constraints fd) zero variableStream of
-	//	Left e = Left [e]
-	//	Right (a, b) = Right b
+    Right (_,fds) = Right (AST fds)
 where
-		constraints :: [FunDecl] -> Typing ()
-        constraints _ = pure ()
-        //TODO: fix
-		//constraints fds = mapM_ funconstraint fds >>| pure ()
-
-		funconstraint :: FunDecl -> Typing ()
-		funconstraint fd=:(FunDecl _ ident args mt vardecls stmts) = case mt of
-			Nothing = abort "Cannot infer functions yet"
-            _ = pure ()
-			//Just t = inEnv (ident, (Forall [] t)) (
-			//	mapM_ vardeclconstraint vardecls >>| pure ())
-
-		vardeclconstraint :: VarDecl -> Typing ()
-        vardeclconstraint _ = pure ()
-        //TODO: fix!
-		//vardeclconstraint (VarDecl p mt ident expr) = infer expr
-			//>>= \it->inEnv (ident, (Forall [] it)) (pure ())
-
 		hasNoDups :: [FunDecl] FunDecl -> Either SemError ()
 		hasNoDups fds (FunDecl p n _ _ _ _)
 		# mbs = map (\(FunDecl p` n` _ _ _ _)->if (n == n`) (Just p`) Nothing) fds
@@ -116,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
@@ -144,25 +135,24 @@ occurs :: TVar a -> Bool | Typeable a
 occurs tvar a = elem tvar (ftv a)
 
 unify :: Type Type -> Either SemError Substitution
-unify t1=:(IdType tv) t2 = unify t2 t1
 unify t1 t2=:(IdType tv)    | t1 == (IdType tv) = Right zero
                             | occurs tv t1 = Left $ InfiniteTypeError zero t1
                             | otherwise = Right $ 'Map'.singleton tv t1
+unify t1=:(IdType tv) t2 = unify t2 t1
 unify (ta1->>ta2) (tb1->>tb2) = unify ta1 tb1 >>= \s1->
-                                unify tb1 tb2 >>= \s2->
+                                unify ta2 tb2 >>= \s2->
                                 Right $ compose s1 s2
 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
 
 //// ------------------------
 //// Algorithm M, Inference and Solving
 //// ------------------------
-//The typing monad
-:: Typing a :== StateT (Gamma, [TVar]) (Either SemError) a
 gamma :: Typing Gamma
 gamma = gets fst
 putGamma :: Gamma -> Typing ()
@@ -201,53 +191,72 @@ lookup k = gamma >>= \g-> case 'Map'.member k g of
 //The inference class
 //When tying it all together we will treat the program is a big 
 //let x=e1 in let y=e2 in .... 
-class infer a :: a -> Typing (Substitution, Type)
+class infer a :: a -> Typing (Substitution, Type, a)
 
 ////---- Inference for Expressions ----
 
 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, e)
 
-    Op2Expr _ e1 op e2 =
-        infer e1 >>= \(s1, t1) -> 
-        infer e2 >>= \(s2, t2) ->
+    Op2Expr p e1 op e2 =
+        infer e1 >>= \(s1, t1, e1_) -> 
+        infer e2 >>= \(s2, t2, e2_) ->
         fresh >>= \tv ->
         let given = t1 ->> t2 ->> tv in 
         op2Type op >>= \expected ->
         lift (unify expected given) >>= \s3 ->
-        pure ((compose s3 $ compose s2 s1), subst s3 tv)
+        pure ((compose s3 $ compose s2 s1), subst s3 tv, Op2Expr p e1_ op e2_)
 
-    Op1Expr _ op e1 =
-        infer e1 >>= \(s1, t1) -> 
+    Op1Expr p op e1 =
+        infer e1 >>= \(s1, t1, e1_) -> 
         fresh >>= \tv ->
         let given = t1 ->> tv in 
         op1Type op >>= \expected ->
         lift (unify expected given) >>= \s2 ->
-        pure (compose s2 s1, subst s2 tv)
-
-    EmptyListExpr _ = (\tv->(zero,tv)) <$> fresh
+        pure (compose s2 s1, subst s2 tv, Op1Expr p op e1)
 
-    TupleExpr _ (e1, e2) = 
-        infer e1 >>= \(s1, t1) -> 
-        infer e2 >>= \(s2, t2) ->
-        pure (compose s2 s1, TupleType (t1,t2))
+    EmptyListExpr _ = (\tv->(zero,tv,e)) <$> fresh
 
-    FunExpr _ f args fs = //todo: fieldselectors
-        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)
+    TupleExpr p (e1, e2) = 
+        infer e1 >>= \(s1, t1, e1_) -> 
+        infer e2 >>= \(s2, t2, e2_) ->
+        pure (compose s2 s1, TupleType (t1,t2), TupleExpr p (e1_,e2_))
 
-    IntExpr _ _ = pure $ (zero, IntType)
-    BoolExpr _ _ = pure $ (zero, BoolType)
-    CharExpr _ _ = pure $ (zero, CharType)
+    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->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)
+    CharExpr _ _ = pure $ (zero, CharType, e)
+
+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
@@ -273,151 +282,181 @@ applySubst s = changeGamma (subst s)
 instance infer Stmt where
  infer s = case s of
     IfStmt e th el = 
-        infer e >>= \(s1, et)->
+        infer e >>= \(s1, et, e_)->
         lift (unify et BoolType) >>= \s2 ->
         applySubst (compose s2 s1) >>|        
-        infer th >>= \(s3, tht)->
+        infer th >>= \(s3, tht, th_)->
         applySubst s3 >>|
-        infer el >>= \(s4, elt)->
+        infer el >>= \(s4, elt, el_)->
         applySubst s4 >>|
         lift (unify tht elt) >>= \s5-> 
-        pure (compose s5 $ compose s4 $ compose s3 $ compose s1 s2, subst s5 tht)
+        let sub = compose s5 $ compose s4 $ compose s3 $ compose s2 s1 in
+        pure (sub, subst s5 tht, IfStmt e_ th_ el_)
 
     WhileStmt e wh = 
-        infer e >>= \(s1, et)->
+        infer e >>= \(s1, et, e_)->
         lift (unify et BoolType) >>= \s2 ->
         applySubst (compose s2 s1) >>|
-        infer wh >>= \(s3, wht)->
-        pure (compose s3 $ compose s1 s2, subst s3 wht)
-
-    AssStmt (VarDef k fs) e =
-        infer e >>= \(s1, et)->
-        applySubst s1 >>|
-        changeGamma (extend k (Forall [] et)) >>| //todo: fieldselectors
-        pure (s1, VoidType)
-
-    FunStmt f es = undef //what is this? 
-
-    ReturnStmt Nothing = pure (zero, VoidType)
-    ReturnStmt (Just e) = infer e
-
-
+        infer wh >>= \(s3, wht, wh_)->
+        pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_)
+
+    AssStmt vd=:(VarDef k fs) e =
+        lookup k >>= \expected ->
+        infer e >>= \(s1, given, e_)->
+        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, AssStmt vd e_)
+
+    FunStmt 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 zero ("can not print " +++ toString t)
+            _ = pure f) >>= \newF->
+        pure (compose s2 s1, VoidType, FunStmt newF args_ fs)
+
+    ReturnStmt Nothing = pure (zero, VoidType, s)
+    ReturnStmt (Just e) = infer e >>= \(sub, t, _)-> pure (sub, t, s)
+
+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
-    infer _ = undef
+    infer []        = pure (zero, VoidType, [])
+    infer [stmt:ss] = 
+        infer stmt >>= \(s1, t1, s_) ->
+        applySubst s1 >>|
+        infer ss >>= \(s2, t2, ss_) ->
+        applySubst s2 >>|
+        case t1 of
+            VoidType = pure (compose s2 s1, t2, [s_:ss_])
+            _ = case t2 of
+                VoidType = pure (compose s2 s1, t1, [s_:ss_])
+                _ = lift (unify t1 t2) >>= \s3 -> 
+                    pure (compose s3 $ compose s2 s1, t1, [s_:ss_])
+
+//the type class inferes the type of an AST element (VarDecl or FunDecl)
+//and adds it to the AST element
+class type a :: a -> Typing (Substitution, a)
+
+instance type VarDecl where
+    type (VarDecl p expected k e) = 
+        infer e >>= \(s1, given, e_) ->
+        applySubst s1 >>| 
+        case expected of
+            Nothing = pure zero
+            Just expected_ = lift (unify expected_ given)
+        >>= \s2->
+        applySubst s2 >>|
+        let vtype = subst (compose s2 s1) given in
+        generalize vtype >>= \t ->
+        changeGamma (extend k t) >>| 
+        pure (compose s2 s1, VarDecl p (Just vtype) k e_)
+
+instance type FunDecl where
+    type (FunDecl p f args expected vds stmts) = 
+        gamma >>= \outerScope-> //functions are infered in their own scopde
+        introduce f >>|
+        mapM introduce args >>= \argTs->
+        type vds >>= \(s1, tVds)->
+        applySubst s1 >>|
+        infer stmts >>= \(s2, result, stmts_)->
+        applySubst s1 >>|
+        let argTs_ = map (subst $ compose s2 s1) argTs in 
+        let given = foldr (->>) result argTs_ in 
+        (case expected of
+            Nothing = pure zero
+            Just (FuncType expected_) = lift (unify expected_ given)
+            Just expected_ = lift (unify expected_ given)
+        ) >>= \s3 ->
+        let ftype = subst (compose s3 $ compose s2 s1) given in
+        (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_)
+
+instance type [a] | type a where
+    type []     = pure (zero, [])
+    type [v:vs] = 
+        type v >>= \(s1, v_)->
+        applySubst s1 >>|
+        type vs >>= \(s2, vs_)->
+        applySubst (compose s2 s1) >>|
+        pure (compose s2 s1, [v_:vs_])
 
-Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
-Mapmap _ 'Map'.Tip = 'Map'.Tip
-Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v) 
-                                        (Mapmap f ml) 
-                                        (Mapmap f mr)
+introduce :: String -> Typing Type
+introduce k = 
+    fresh >>= \tv ->
+    changeGamma (extend k (Forall [] tv)) >>|
+    pure tv
 
 instance toString Scheme where
     toString (Forall x t) = 
-        concat ["Forall ": map ((+++) "\n") x] +++ toString t
+        concat ["Forall ": intersperse "," x] +++ concat [". ", toString t];
 
 instance toString Gamma where
     toString mp = 
         concat [concat [k, ": ", toString v, "\n"]\\(k, v)<-'Map'.toList mp]
 
+instance toString Substitution where
+    toString subs = 
+        concat [concat [k, ": ", toString t, "\n"]\\(k, t)<-'Map'.toList subs]
+
 instance toString SemError where
     toString (SanityError p e) = concat [toString p, 
         "SemError: SanityError: ", e]
-    toString se = "SemError: "
+    toString (ParseError p s) = concat [toString p, 
+        "ParseError: ", s]
+    toString (UnifyError p t1 t2) = concat [toString p, 
+        "Can not unify types, expected|given:\n", toString t1,
+        "\n", toString t2]
+    toString (InfiniteTypeError p t) = concat [toString p, 
+        "Infinite type: ", toString t]
+    toString (FieldSelectorError p t fs) = concat [toString p,
+        "Can not run fieldselector '", toString fs, "' on type: ",
+        toString t]
+    toString (OperatorError p op t) = concat [toString p,
+        "Operator error, operator '", toString op, "' can not be",
+        "used on type: ", toString t]
+    toString (UndeclaredVariableError p k) = concat [toString p,
+        "Undeclared identifier: ", k]
+    toString (ArgumentMisMatchError p str) = concat [toString p,
+        "Argument mismatch: ", str]
+    toString (Error e) = concat ["Unknown error during semantical",
+        "analysis: ", e]
+
+instance toString (Maybe a) | toString a where
+    toString Nothing = "Nothing"
+    toString (Just e) = concat ["Just ", toString e]
 
 instance MonadTrans (StateT (Gamma, [TVar])) where
     liftT m = StateT \s-> m >>= \a-> return (a, s)
 
-//// ------------------------
-//// First step: Inference
-//// ------------------------//
-
-//unify :: Type Type -> Infer ()
-//unify t1 t2 = tell [(t1, t2)]//
-
-//fresh :: Infer Type
-//fresh = (gets id) >>= \vars-> (put $ tail vars) >>| (pure $ IdType $ head vars)//
-
-//op2Type :: Op2 -> Infer Type
-//op2Type op
-//| elem op [BiPlus, BiMinus, BiTimes, BiDivide, BiMod]
-//	= pure (IntType ->> IntType ->> IntType)
-//| elem op [BiEquals, BiUnEqual]
-//	= fresh >>= \t1-> fresh >>= \t2-> pure (t1 ->> t2 ->> BoolType)
-//| elem op [BiLesser, BiGreater, BiLesserEq, BiGreaterEq]
-//	= pure (IntType ->> IntType ->> BoolType)
-//| elem op [BiAnd, BiOr]
-//	= pure (BoolType ->> BoolType ->> BoolType)
-//| op == BiCons 
-//	= fresh >>= \t1-> pure (t1 ->> ListType t1 ->> ListType t1)//
-
-//op1Type :: Op1 -> Infer Type
-//op1Type UnNegation = pure $ (BoolType ->> BoolType)
-//op1Type UnMinus = pure $ (IntType ->> IntType)//
-
-////instantiate :: Scheme -> Infer Type
-////instantiate (Forall as t) = mapM (const fresh) as//
-
-//lookupEnv :: String -> Infer Type
-//lookupEnv ident = asks ('Map'.get ident)
-//	>>= \m->case m of
-//		Nothing = liftT $ Left $ UndeclaredVariableError zero ident
-//		Just (Forall as t) = pure t //instantiate ???//
-
-//class infer a :: a -> Infer Type
-//instance infer Expr where
-//	infer (VarExpr _ (VarDef ident fs)) = lookupEnv ident
-//    infer (Op2Expr _ e1 op e2) = 
-//        infer e1 >>= \t1 -> 
-//        infer e2 >>= \t2 ->
-//        fresh >>= \frsh -> 
-//        let given = t1 ->> (t2 ->> frsh) in
-//        op2Type op >>= \expected -> 
-//        unify expected given >>| 
-//        return frsh
-//	infer (Op1Expr _ op e) = 
-//        infer e >>= \t1 -> 
-//        fresh >>= \frsh -> 
-//        let given = t1 ->> frsh in
-//        op1Type op >>= \expected -> 
-//        unify expected given >>| 
-//        pure frsh
-//	infer (IntExpr _ _) = pure IntType
-//	infer (CharExpr _ _) = pure CharType
-//	infer (BoolExpr _ _) = pure BoolType
-//	infer (FunExpr _ f args sels) =  //todo, iets met field selectors
-//        lookupEnv f >>= \expected ->
-//        fresh >>= \frsh -> 
-//        mapM infer args >>= \argTypes ->
-//        let given = foldr (->>) frsh argTypes in
-//        unify expected given >>|
-//        pure frsh
-//	infer (EmptyListExpr _) = ListType <$> fresh
-//	infer (TupleExpr _ (e1, e2)) =
-//		infer e1 >>= \et1->infer e2 >>= \et2->pure $ TupleType (et1, et2)//
-
-////:: VarDef = VarDef String [FieldSelector]
-////:: FieldSelector = FieldHd | FieldTl | FieldFst | FieldSnd
-////:: Op1 = UnNegation | UnMinus
-////:: Op2 = BiPlus | BiMinus | BiTimes | BiDivide | BiMod | BiEquals | BiLesser |
-////	BiGreater | BiLesserEq | BiGreaterEq | BiUnEqual | BiAnd | BiOr | BiCons
-////:: FunDecl = FunDecl Pos String [String] (Maybe Type) [VarDecl] [Stmt]
-////:: FunCall = FunCall String [Expr]
-////:: Stmt 
-////	= IfStmt Expr [Stmt] [Stmt]
-////	| WhileStmt Expr [Stmt]
-////	| AssStmt VarDef Expr
-////	| FunStmt FunCall
-////	| ReturnStmt (Maybe Expr)
-////:: Pos = {line :: Int, col :: Int}
-////:: AST = AST [VarDecl] [FunDecl]
-////:: VarDecl = VarDecl Pos Type String Expr
-////:: Type 
-////	= TupleType (Type, Type)
-////	| ListType Type
-////	| IdType String 
-////	| IntType 
-////	| BoolType
-////	| CharType
-////	| VarType
-////    | VoidType
-////    | (->>) infixl 7 Type Type
+Mapmap :: (a->b) ('Map'.Map k a) -> ('Map'.Map k b)
+Mapmap _ 'Map'.Tip = 'Map'.Tip
+Mapmap f ('Map'.Bin sz k v ml mr) = 'Map'.Bin sz k (f v) 
+                                        (Mapmap f ml) 
+                                        (Mapmap f mr)