x = fst x
parseProgram :: Parser Token AST
-parseProgram = AST <$> some parseFunDecl
+parseProgram = many parseLetDecl >>= \fds1->
+ some parseFunDecl >>= \fds2->
+ pure $ AST (fds1++fds2)
+
+parseLetDecl :: Parser Token FunDecl
+parseLetDecl = peekPos >>= \p->
+ satTok LetToken >>|
+ (optional parseFunType) >>= \mt->
+ parseIdent >>= \f->
+ satTok AssignmentToken >>|
+ parseExpr >>= \e->
+ satTok SColonToken >>|
+ pure (FunDecl p f [] mt [] [ReturnStmt $ Just e])
parseFunDecl :: Parser Token FunDecl
parseFunDecl = liftM6 FunDecl
(peekPos)
(parseIdent)
(parseBBraces $ parseSepList CommaToken parseIdent)
- (optional parseFunType)
+ (optional (satTok DoubleColonToken *> parseFunType))
(satTok CBraceOpenToken *> many parseVarDecl)
(many parseStmt <* satTok CBraceCloseToken)
parseOneLine = pure <$> parseStmt
parseFunType :: Parser Token Type
-parseFunType = satTok DoubleColonToken *> parseFT
+parseFunType = parseFT
where
parseFT :: Parser Token Type
parseFT = (liftM2 (->>) (parseSF <* satTok ArrowToken) (parseFT)) <|>
- parseSF
+ parseSF <|>
+ (FuncType <$> parseType)
parseSF :: Parser Token Type
- parseSF = parseBBraces parseFT <|> parseType
+ parseSF = parseBBraces parseFT
parseVarDecl :: Parser Token VarDecl
parseVarDecl = liftM4 VarDecl
satTok :: TokenValue -> Parser Token Token
satTok t = top >>= \tok=:({line,col},token) -> if (eq t token)
(pure tok) (fail <?> PositionalError line col
- ("ParseError: Unexpected token: " +++ printToString token))
+ ("ParseError: Unexpected token: " +++ printToString token
+ +++ "\nExpected: " +++ printToString t))
where
eq (IdentToken _) (IdentToken _) = True
eq (NumberToken _) (NumberToken _) = True
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 (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
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
- generalize ftype >>= \t->
+ (case expected of
+ Just (FuncType _) = pure (FuncType ftype)
+ _ = pure 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, [])