diff options
| -rw-r--r-- | AST.hs | 4 | ||||
| -rw-r--r-- | Parser.hs | 126 |
2 files changed, 126 insertions, 4 deletions
@@ -40,7 +40,7 @@ data Expr t = ELit t Literal | EList t [Expr t] | ETup t [Expr t] - | EApp t (Expr t) (Expr t) + | EApp t (Expr t) [Expr t] | EOp t (Expr t) Operator (Expr t) | EIf t (Expr t) (Expr t) (Expr t) | ECase t (Expr t) [(Pattern t, RHS t)] @@ -50,5 +50,5 @@ data Expr t data Literal = LInt Int | LFloat Double | LChar Char | LString String deriving (Show) -data Operator = OAdd | OSub | OMul | ODiv | OMod +data Operator = OAdd | OSub | OMul | ODiv | OMod | OEqu | OPow deriving (Show) @@ -143,8 +143,122 @@ pFunEq mCheckName = do raise Fatal "Name of function clause does not correspond with type signature" _ -> return () - pats <- many pPattern - _ + pats <- many (pPattern 11) + rhs <- pRHS + return (FunEq name pats rhs) + +pRHS :: Parser (RHS ()) +pRHS = do + -- TODO: parse guards + inlineWhite + string "=" + Plain <$> pExpr + +pPattern :: Int -> Parser (Pattern ()) +pPattern d = inlineWhite >> pPattern0 d + +pPattern0 :: Int -> Parser (Pattern ()) +pPattern0 d = do + asum [pPatWildcard0 + ,pPatVarOrAs0 + ,pPatCon0 + ,pPatList0 + ,pPatParens0] + where + pPatWildcard0 = string "_" >> return (PWildcard ()) + pPatVarOrAs0 = do + var <- pIdentifier0 Lowercase + asum [do inlineWhite + string "@" + p <- pPattern 11 + return (PAs () var p) + ,return (PVar () var)] + pPatCon0 = do + con <- pIdentifier0 Uppercase + if d > 0 + then return (PCon () con []) + else do args <- many (pPattern 11) + return (PCon () con args) + pPatList0 = do + string "[" + ps <- pPattern 0 `sepBy` (inlineWhite >> string ",") + inlineWhite + string "]" + return (PList () ps) + pPatParens0 = do + string "(" + inlineWhite + asum [do string ")" + return (PTup () []) + ,do p <- pPattern0 0 + inlineWhite + asum [do string ")" + return p + ,do string "," + ps <- pPattern 0 `sepBy1` (inlineWhite >> string ",") + return (PTup () (p : ps))]] + +pExpr :: Parser (Expr ()) +pExpr = do + inlineWhite + -- basics: lit, list, tup + -- expression atom: application of basics + -- expression parser: op + -- around: let, case, if + asum [pELet0 + ,pECase0 + ,pEIf0 + ,pExprOpExpr0 0] + +pExprOpExpr :: Int -> Parser (Expr ()) +pExprOpExpr d = inlineWhite >> pExprOpExpr0 d + +pExprOpExpr0 :: Int -> Parser (Expr ()) +pExprOpExpr0 d = do + e0 <- pEApp0 + climbRight e0 Nothing + where + climbRight :: Expr () -> Maybe ParsedOperator -> Parser (Expr ()) + climbRight lhs mlhsop = do + asum [do paop@(PaOp op d2 a2) <- pInfixOp + guard (d2 >= d) -- respect global minimum precedence + case mlhsop of -- check operator compatibility + Just (PaOp _ d1 a1) -> + guard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone)) + Nothing -> + return () + let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1 + rhs <- pExprOpExpr oprhsd + climbRight (EOp () lhs op rhs) (Just paop)] + +pEApp0 :: Parser (Expr ()) +pEApp0 = do + e1 <- pEAtom0 + es <- many (inlineWhite >> pEAtom0) + case es of + [] -> return e1 + _ -> return (EApp () e1 es) + +pEAtom0 :: Parser (Expr ()) +pEAtom0 = pELit <|> pEList <|> pEParens + +data Associativity = AssocLeft | AssocRight | AssocNone + deriving (Show, Eq) + +data ParsedOperator = PaOp Operator Int Associativity + deriving (Show) + +pInfixOp :: Parser ParsedOperator +pInfixOp = do + inlineWhite + asum [PaOp OEqu 4 AssocNone <$ string "==" + ,PaOp OAdd 6 AssocLeft <$ string "+" + ,PaOp OSub 6 AssocLeft <$ string "-" + ,PaOp OMul 7 AssocLeft <$ string "*" + ,PaOp ODiv 7 AssocLeft <$ string "/" + ,PaOp OMod 7 AssocLeft <$ string "%" + ,PaOp OPow 8 AssocRight <$ string "^" + ] pStandaloneTypesig0 :: Parser (Name, Type) pStandaloneTypesig0 = do @@ -278,6 +392,14 @@ pParens0 p = do return res +sepBy1 :: Parser a -> Parser sep -> Parser [a] +sepBy1 p psep = do + x1 <- p + (psep >> (x1 :) <$> sepBy1 p psep) <|> return [x1] + +sepBy :: Parser a -> Parser sep -> Parser [a] +sepBy p psep = sepBy1 p psep <|> return [] + -- | Start a new layout block at the current position. The old layout block is -- restored after completion of this subparser. startLayoutBlock :: Parser a -> Parser a |