X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=5cf0520adb2a8d68f50d664ae427a994e0052a0f;hb=74b900cf6db033a51e177f7f85d835dae44217e5;hp=0c5b55273cb8d7fb05f1fe73dc1fa069409ff49c;hpb=978dc486bf8c83cf9cad0925e3128574639656e0;p=cc1516.git diff --git a/sem.icl b/sem.icl index 0c5b552..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 @@ -185,7 +191,7 @@ 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 ---- @@ -193,46 +199,57 @@ instance infer Expr where infer e = case e of VarExpr _ (VarDef k fs) = lookup k >>= \t -> foldM foldFieldSelectors t fs >>= \finalT -> - pure (zero, 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) + pure (compose s2 s1, subst s2 tv, Op1Expr p op e1) - EmptyListExpr _ = (\tv->(zero,tv)) <$> fresh + EmptyListExpr _ = (\tv->(zero,tv,e)) <$> fresh - TupleExpr _ (e1, e2) = - infer e1 >>= \(s1, t1) -> - infer e2 >>= \(s2, t2) -> - pure (compose s2 s1, TupleType (t1,t2)) + 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_)) - 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-> - let fReturnType = subst s2 tv in - foldM foldFieldSelectors fReturnType fs >>= \returnType -> - pure (compose s2 s1, returnType) + LambdaExpr _ _ _ = liftT $ Left $ Error "PANIC: lambdas should be tasnformed" - IntExpr _ _ = pure $ (zero, IntType) - BoolExpr _ _ = pure $ (zero, BoolType) - CharExpr _ _ = pure $ (zero, CharType) + 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 @@ -265,37 +282,55 @@ 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 s2 s1, 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 s2 s1, subst s3 wht) + infer wh >>= \(s3, wht, wh_)-> + pure (compose s3 $ compose s2 s1, subst s3 wht, WhileStmt e_ wh_) - AssStmt (VarDef k fs) e = + AssStmt vd=:(VarDef k fs) e = lookup k >>= \expected -> - infer e >>= \(s1, given)-> + 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) - - FunStmt f es _ = pure (zero, VoidType) + pure (s, VoidType, AssStmt vd e_) - ReturnStmt Nothing = pure (zero, VoidType) - ReturnStmt (Just e) = infer 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 @@ -306,18 +341,18 @@ 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 [] = pure (zero, VoidType) + infer [] = pure (zero, VoidType, []) infer [stmt:ss] = - infer stmt >>= \(s1, t1) -> + infer stmt >>= \(s1, t1, s_) -> applySubst s1 >>| - infer ss >>= \(s2, t2) -> + infer ss >>= \(s2, t2, ss_) -> applySubst s2 >>| case t1 of - VoidType = pure (compose s2 s1, t2) + VoidType = pure (compose s2 s1, t2, [s_:ss_]) _ = case t2 of - VoidType = pure (compose s2 s1, t1) + VoidType = pure (compose s2 s1, t1, [s_:ss_]) _ = lift (unify t1 t2) >>= \s3 -> - pure (compose s3 $ compose s2 s1, t1) + 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 @@ -325,7 +360,7 @@ class type a :: a -> Typing (Substitution, a) instance type VarDecl where type (VarDecl p expected k e) = - infer e >>= \(s1, given) -> + infer e >>= \(s1, given, e_) -> applySubst s1 >>| case expected of Nothing = pure zero @@ -335,7 +370,7 @@ instance type VarDecl where 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) + pure (compose s2 s1, VarDecl p (Just vtype) k e_) instance type FunDecl where type (FunDecl p f args expected vds stmts) = @@ -344,20 +379,24 @@ instance type FunDecl where mapM introduce args >>= \argTs-> type vds >>= \(s1, tVds)-> applySubst s1 >>| - infer stmts >>= \(s2, result)-> + infer stmts >>= \(s2, result, stmts_)-> applySubst s1 >>| let argTs_ = map (subst $ compose s2 s1) argTs in - //abort (concat $ intersperse "\n" $ map toString argTs_) >>| 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, [])