X-Git-Url: https://git.martlubbers.net/?a=blobdiff_plain;f=src%2Fparse.icl;h=0860819c20748b7d5a3b3a523691250172818c6f;hb=6e527e30012f8809594452cb9559b301b4a8afc6;hp=f5cb0c855a7f411e2e18dd9c101dbf1c6f76b28d;hpb=178532b9e5843308b2b076b4d8881f6971cd718c;p=cc1516.git diff --git a/src/parse.icl b/src/parse.icl index f5cb0c8..0860819 100644 --- a/src/parse.icl +++ b/src/parse.icl @@ -54,8 +54,8 @@ parseStmt = parseIfStmt <|> parseWhileStmt <|> parseIfStmt = liftM3 IfStmt (satTok IfToken *> parseBBraces parseExpr) (parseBlock <|> parseOneLine) - (optional (satTok ElseToken *> (parseBlock <|> parseOneLine) - ) >>= pure o fromMaybe []) + (liftM (fromMaybe []) + (optional (satTok ElseToken *> (parseBlock<|> parseOneLine)))) parseWhileStmt :: Parser Token Stmt parseWhileStmt = satTok WhileToken *> @@ -68,44 +68,32 @@ parseStmt = parseIfStmt <|> parseWhileStmt <|> //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 - -parseBCBraces :: (Parser Token a) -> Parser Token a -parseBCBraces p = satTok CBraceOpenToken *> p <* satTok CBraceCloseToken - parseFunType :: Parser Token FunType -parseFunType = satTok DoubleColonToken *> - (parseInOutType <|> (parseVoidOrType >>= \t->pure $ FunType [] t)) +parseFunType = satTok DoubleColonToken *> + (parseInOutType <|> (liftM (FunType []) parseVoidOrType)) where parseInOutType :: Parser Token FunType - parseInOutType = some parseType <* satTok ArrowToken - >>= \intypes-> parseVoidOrType - >>= \outtypes->pure $ FunType intypes outtypes + parseInOutType = liftM2 FunType + (some parseType <* satTok ArrowToken) parseVoidOrType parseVoidOrType :: Parser Token (Maybe Type) parseVoidOrType = (satTok VoidToken *> pure Nothing) <|> - (parseType >>= \type->pure $ Just type) + (liftM Just parseType) parseVarDecl :: Parser Token VarDecl -parseVarDecl = +parseVarDecl = liftM3 VarDecl (parseType <|> trans1 VarToken VarType ) - >>= \t->parseIdent <* satTok AssignmentToken - >>= \i->parseExpr <* satTok SColonToken - >>= \e->pure $ VarDecl i t e + (parseIdent <* satTok AssignmentToken) + (parseExpr <* satTok SColonToken) parseType :: Parser Token Type parseType = trans1 IntTypeToken IntType <|> trans1 CharTypeToken CharType <|> trans1 BoolTypeToken BoolType <|> - (satTok SquareOpenToken *> parseType <* satTok SquareCloseToken - >>= \t.pure $ ListType t) <|> - (satTok BraceOpenToken *> parseType <* satTok CommaToken - >>= \t1->parseType <* satTok BraceCloseToken - >>= \t2->pure $ TupleType t1 t2) <|> - (parseIdent >>= \e.pure $ IdType e) <|> - empty + (liftM ListType (parseBSqBraces parseType)) <|> + (liftM TupleType (parseTuple parseType)) <|> + (liftM IdType parseIdent) parseExpr :: Parser Token Expr parseExpr = //Operators in order of binding strength @@ -136,37 +124,48 @@ parseExpr = //Operators in order of binding strength parseBasicExpr :: Parser Token Expr parseBasicExpr = - (satTok BraceOpenToken *> parseExpr <* satTok CommaToken - >>= \e1->parseExpr <* satTok BraceCloseToken - >>= \e2->pure $ TupleExpr e1 e2) <|> - (parseFunCall >>= \fc->pure $ FunExpr fc) <|> + (liftM TupleExpr (parseTuple parseExpr)) <|> + (liftM FunExpr parseFunCall) <|> parseBBraces parseExpr <|> trans1 EmptyListToken EmptyListExpr <|> - trans2 TrueToken (const $ BoolExpr True) <|> - trans2 FalseToken (const $ BoolExpr False) <|> + trans1 TrueToken (BoolExpr True) <|> + trans1 FalseToken (BoolExpr False) <|> trans2 (NumberToken zero) (\(NumberToken i)->IntExpr i) <|> trans2 (CharToken zero) (\(CharToken c)->CharExpr c) <|> - (parseOp1 >>= \o->parseExpr >>= \e.pure $ Op1Expr o e) <|> - (parseVarDef >>= \ve->pure $ VarExpr ve) + (liftM2 Op1Expr parseOp1 parseExpr) <|> + (liftM VarExpr parseVarDef) parseFunCall :: Parser Token FunCall -parseFunCall = parseIdent <* satTok BraceOpenToken - >>= \i->parseSepList CommaToken parseExpr - <* satTok BraceCloseToken >>= \es->pure $ FunCall i es +parseFunCall = liftM2 FunCall + parseIdent (parseBBraces $ parseSepList CommaToken parseExpr) parseVarDef :: Parser Token VarDef -parseVarDef = parseIdent - >>= \i-> many (satTok DotToken *> ( +parseVarDef = liftM2 VarDef + parseIdent + (many (satTok DotToken *> ( (parseIdent >>= (\i.if (i == "hd") (pure FieldHd) empty)) <|> (parseIdent >>= \i.if (i == "tl") (pure FieldTl) empty) <|> (parseIdent >>= \i.if (i == "fst") (pure FieldFst) empty) <|> - (parseIdent >>= \i.if (i == "snd") (pure FieldSnd) empty)) - ) >>= \f->pure $ VarDef i f + (parseIdent >>= \i.if (i == "snd") (pure FieldSnd) empty)))) parseOp1 :: Parser Token Op1 parseOp1 = trans1 DashToken UnMinus <|> trans1 ExclamationToken UnNegation +parseBBraces :: (Parser Token a) -> Parser Token a +parseBBraces p = satTok BraceOpenToken *> p <* satTok BraceCloseToken + +parseBCBraces :: (Parser Token a) -> Parser Token a +parseBCBraces p = satTok CBraceOpenToken *> p <* satTok CBraceCloseToken + +parseBSqBraces :: (Parser Token a) -> Parser Token a +parseBSqBraces p = satTok SquareOpenToken *> p <* satTok SquareCloseToken + +parseTuple :: (Parser Token a) -> Parser Token (a, a) +parseTuple p = satTok BraceOpenToken *> + (liftM2 (\a->(\b->(a,b))) (p <* satTok CommaToken) p) + <* satTok BraceCloseToken + trans2 :: TokenValue (TokenValue -> a) -> Parser Token a trans2 t f = satTok t >>= \(_, r).pure (f r) @@ -174,13 +173,19 @@ trans1 :: TokenValue a -> Parser Token a trans1 t r = trans2 t $ const r derive gPrint TokenValue +derive gEq TokenValue satTok :: TokenValue -> Parser Token Token -satTok t = top >>= \tok=:(pos, tv) -> if (t === tok) (return tok) (fail (printToString t, pos)) +satTok t = top >>= \tok=:(pos, tv) -> if (eq t tok) (return tok) (fail (printToString t, pos)) + 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 = (some (p <* satTok sep) >>= \es->p >>= \e.pure $ reverse [e:es]) <|> - (p >>= \e->pure [e]) <|> pure [] + (liftM pure p) <|> pure empty parseIdent :: Parser Token String parseIdent = trans2 (IdentToken []) (\(IdentToken e).toString e) @@ -220,7 +225,7 @@ printStatements [s:ss] i = (case s of printCodeBlock [] _ = ["{}"] printCodeBlock [x] i = ["\n":printStatements [x] (i+1)] printCodeBlock x i = - ["{\n":printStatements x (i+1)] ++ indent i ["}"] + ["{\n":printStatements x (i+1)] ++ indent i ["}\n"] indent :: Int [String] -> [String] indent i rest = replicate i "\t" ++ rest @@ -230,10 +235,10 @@ instance print FunType where [if (isEmpty at) "" "->":maybe ["Void"] print rt] instance print VarDecl where - print (VarDecl i t e) = print t ++ [" ":i:"=":print e] ++ [";"] + print (VarDecl t i e) = print t ++ [" ":i:"=":print e] ++ [";"] instance print Type where - print (TupleType t1 t2) = ["(":print t1] ++ [",":print t2] ++ [")"] + print (TupleType (t1, t2)) = ["(":print t1] ++ [",":print t2] ++ [")"] print (ListType t) = ["[":print t] ++ ["]"] print (IdType s) = print s print IntType = print "Int" @@ -276,4 +281,4 @@ instance print Expr where print (BoolExpr b) = [toString b] print (FunExpr fc) = print fc print EmptyListExpr = ["[]"] - print (TupleExpr e1 e2) = ["(":print e1] ++ [",":print e2] ++ [")"] + print (TupleExpr (e1, e2)) = ["(":print e1] ++ [",":print e2] ++ [")"]