import StdString
import StdTuple
import StdList
-from StdFunc import const
+from StdFunc import const, o
import Data.Either
import Data.Functor
import Data.Maybe
import Control.Monad
import Control.Applicative
import Data.Func
-from Data.List import intercalate, replicate
+from Data.List import intercalate, replicate, instance Functor []
from Text import class Text(concat), instance Text String
import yard
(Left e, _) = Left $ toString e
parseProgram :: Parser Token AST
-parseProgram = many parseVarDecl
- >>= \vd->some parseFunDecl
- >>= \fd->pure $ AST vd fd
+parseProgram = liftM2 AST (many parseVarDecl) (some parseFunDecl)
parseFunDecl :: Parser Token FunDecl
-parseFunDecl = parseIdent <* satTok BraceOpenToken
- >>= \ident->parseSepList CommaToken parseIdent <* satTok BraceCloseToken
- >>= \args->parseFunType <* satTok CBraceOpenToken
- >>= \funtype->many parseVarDecl
- >>= \vardecls->many parseStmt
- <* satTok CBraceCloseToken
- >>= \stmts->pure $ FunDecl ident args funtype vardecls stmts
+parseFunDecl = liftM5 FunDecl
+ (parseIdent <* satTok BraceOpenToken)
+ (parseSepList CommaToken parseIdent <* satTok BraceCloseToken)
+ (parseFunType <* satTok CBraceOpenToken)
+ (many parseVarDecl)
+ (many parseStmt <* satTok CBraceCloseToken)
parseStmt :: Parser Token Stmt
-parseStmt = parseIfStmt <|>
- parseWhileStmt <|>
- (parseAssStmt <* satTok SColonToken) <|>
- (parseReturnStmt <* satTok SColonToken) <|>
- (parseFunCall <* satTok SColonToken >>= \fc->pure $ FunStmt fc)
+parseStmt = parseIfStmt <|> parseWhileStmt <|>
+ parseSColon parseAssStmt <|> parseSColon parseReturnStmt <|>
+ (liftM FunStmt (parseSColon parseFunCall))
where
+ parseSColon :: (Parser Token a) -> Parser Token a
+ parseSColon p = p <* satTok SColonToken
+
parseReturnStmt :: Parser Token Stmt
- parseReturnStmt = satTok ReturnToken
- *> optional parseExpr >>= \me->pure $ ReturnStmt me
+ parseReturnStmt =
+ satTok ReturnToken *> liftM ReturnStmt (optional parseExpr)
parseAssStmt :: Parser Token Stmt
- parseAssStmt = parseVarDef <* satTok AssignmentToken
- >>= \var-> parseExpr >>= \expr->pure $ AssStmt var expr
+ parseAssStmt =
+ liftM2 AssStmt (parseVarDef <* satTok AssignmentToken) parseExpr
parseIfStmt :: Parser Token Stmt
- parseIfStmt = satTok IfToken
- *> parseBBraces parseExpr
- >>= \pred->parseBCBraces (many parseStmt)
- >>= \thens->optional (
- satTok ElseToken *> parseBCBraces (many parseStmt)
- )>>= \elses->pure $ IfStmt pred thens (fromMaybe [] elses)
+ parseIfStmt = liftM3 IfStmt
+ (satTok IfToken *> parseBBraces parseExpr)
+ (parseBlock <|> parseOneLine)
+ (optional (satTok ElseToken *> (parseBlock <|> parseOneLine)
+ ) >>= pure o fromMaybe [])
parseWhileStmt :: Parser Token Stmt
- parseWhileStmt = satTok WhileToken *> parseBBraces parseExpr
- >>= \pred->parseBCBraces (many parseStmt)
- >>= \body->pure $ WhileStmt pred body
+ parseWhileStmt = satTok WhileToken *>
+ liftM2 WhileStmt (parseBBraces parseExpr) parseBlock
+
+ parseBlock :: Parser Token [Stmt]
+ parseBlock = parseBCBraces (many parseStmt)
+
+ parseOneLine :: Parser Token [Stmt]
+ //first pure makes singleton list from the statement
+ parseOneLine = liftM pure parseStmt
parseBBraces :: (Parser Token a) -> Parser Token a
parseBBraces p = satTok BraceOpenToken *> p <* satTok BraceCloseToken
trans1 :: TokenValue a -> Parser Token a
trans1 t r = trans2 t $ const r
+derive gEq TokenValue
satTok :: TokenValue -> Parser Token Token
-satTok t = satisfy ((===) t)
+satTok t = satisfy $ eq t
+ where
+ eq (IdentToken _) (_, IdentToken _) = True
+ eq (NumberToken _) (_, NumberToken _) = True
+ eq (CharToken _) (_, CharToken _) = True
+ eq x (_, y) = gEq {|*|} x y
parseSepList :: TokenValue (Parser Token a) -> Parser Token [a]
parseSepList sep p =
print (FunDecl i as t vs ss) =
["\n", i, " (":printersperse "," as] ++
[") :: ":print t] ++
- ["{\n\t":printersperse "\n\t" vs] ++
- ["\n":printStatements ss 1] ++ ["\n}"]
+ ["{":printersperse "\n\t" vs] ++
+ ["\n":printStatements ss 1] ++ ["}"]
printStatements :: [Stmt] Int -> [String]
printStatements [] i = []
printStatements [s:ss] i = (case s of
- (IfStmt b thens elses) = indent i ["if (":print b] ++ ["){\n"] ++
- printStatements thens (i+1) ++
- indent i ["} else {\n":printStatements elses (i+1)] ++
- indent i ["}\n"]
+ (IfStmt b thens elses) = indent i ["if (":print b] ++ [")"] ++
+ printCodeBlock thens i ++
+ indent i ["else ":printCodeBlock elses i] ++ ["\n"]
(WhileStmt b dos) = indent i ["while (":print b] ++
- ["){\n":printStatements dos (i+1)] ++ indent i ["}\n"]
+ [")":printCodeBlock dos i]
(AssStmt vardef val) =
indent i $ print vardef ++ ["=":print val] ++ [";\n"]
(FunStmt fc) = indent i $ print fc ++ [";\n"]
(ReturnStmt me) = indent i ["return ":maybe [""] print me] ++ [";\n"]
) ++ printStatements ss i
-
-indent :: Int [String] -> [String]
-indent i rest = replicate i "\t" ++ rest
+ where
+ printCodeBlock :: [Stmt] Int -> [String]
+ printCodeBlock [] _ = ["{}"]
+ printCodeBlock [x] i = ["\n":printStatements [x] (i+1)]
+ printCodeBlock x i =
+ ["{\n":printStatements x (i+1)] ++ indent i ["}\n"]
+
+ indent :: Int [String] -> [String]
+ indent i rest = replicate i "\t" ++ rest
instance print FunType where
print (FunType at rt) = printersperse " " at ++