liftm voor statement

[cc1516.git] / src / parse.icl

diff --git a/src/parse.icl b/src/parse.icl
index d04b0f9..bc93239 100644 (file)
--- a/src/parse.icl
+++ b/src/parse.icl
@@ -3,14 +3,14 @@ implementation module parse
 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
@@ -23,46 +23,49 @@ parser (Right r) = case runParser parseProgram r of
        (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
@@ -194,26 +197,31 @@ instance print FunDecl where
        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 ["}"]
+
+               indent :: Int [String] -> [String]
+               indent i rest = replicate i "\t" ++ rest
 
 instance print FunType where
        print (FunType at rt) = printersperse " " at ++