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
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
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
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)
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, [])