X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=sem.icl;h=0ffcdd282015af67631b0cd926d3042b01650379;hb=24472f94b2af1d2c01db24c4ddfe61143dda1459;hp=34675d282d94c352db56e42bfdab771c35871f32;hpb=ad0d73c9a00ded40c77b87a82059980acfb5edaf;p=cc1516.git diff --git a/sem.icl b/sem.icl index 34675d2..0ffcdd2 100644 --- 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,13 +48,19 @@ 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 [] (IntType ->> (ListType 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) + Right (_,fds) = Right (AST fds) where hasNoDups :: [FunDecl] FunDecl -> Either SemError () hasNoDups fds (FunDecl p n _ _ _ _) @@ -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 @@ -298,7 +321,7 @@ instance infer [a] | infer a where //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 a +class type a :: a -> Typing (Substitution, a) instance type VarDecl where type (VarDecl p expected k e) = @@ -312,31 +335,38 @@ instance type VarDecl where let vtype = subst (compose s2 s1) given in generalize vtype >>= \t -> changeGamma (extend k t) >>| - pure (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) = + gamma >>= \outerScope-> //functions are infered in their own scopde introduce f >>| mapM introduce args >>= \argTs-> - type vds >>= \tVds-> - infer stmts >>= \(s1, result)-> - let given = foldr (->>) result argTs in + type vds >>= \(s1, tVds)-> + applySubst s1 >>| + infer stmts >>= \(s2, result)-> 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)) - >>= \s2 -> - let ftype = subst (compose s2 s1) given in + >>= \s3 -> + let ftype = subst (compose s3 $ compose s2 s1) given in generalize ftype >>= \t-> + putGamma outerScope >>| changeGamma (extend f t) >>| - pure (FunDecl p f args (Just ftype) tVds stmts) - -instance toString (Maybe a) | toString a where - toString Nothing = "Nothing" - toString (Just e) = concat ["Just ", toString e] + pure (compose s3 $ compose s2 s1, FunDecl p f args (Just ftype) tVds stmts) instance type [a] | type a where - type dcls = mapM type dcls + 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_]) introduce :: String -> Typing Type introduce k = @@ -379,6 +409,10 @@ instance toString SemError where 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)