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)
where
generalize t = gamma >>= \g-> pure $ Forall (difference (ftv t) (ftv g)) t
lookup :: String -> Typing Type
-lookup "isEmpty" = ListType <$> fresh
lookup k = gamma >>= \g-> case 'Map'.member k g of
False = liftT (Left $ UndeclaredVariableError zero k)
True = instantiate $ 'Map'.find k g
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) ->
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
AssStmt (VarDef k fs) e =
lookup k >>= \expected ->
infer e >>= \(s1, given)->
- lift (unify expected given) >>= \s2->
+ foldM reverseFs given (reverse fs) >>= \varType->
+ lift (unify expected varType) >>= \s2->
let s = compose s2 s1 in
applySubst s >>|
- changeGamma (extend k (Forall [] given)) >>| //todo: fieldselectors
+ 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