More parser work

1 files changed, 124 insertions, 2 deletions

diff --git a/Parser.hs b/Parser.hs
index 71a0f69..2cd3ffc 100644
--- a/Parser.hs
+++ b/Parser.hs
@@ -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