From b036b1cac1377cdbb9cc57ae6124cd6d6e5775a9 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Sun, 16 Apr 2023 12:20:16 +0200
Subject: More parser work

---
 AST.hs    |   4 +-
 Parser.hs | 126 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 126 insertions(+), 4 deletions(-)

diff --git a/AST.hs b/AST.hs
index 0b98618..b9dd3df 100644
--- a/AST.hs
+++ b/AST.hs
@@ -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)
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
-- 
cgit v1.2.3-70-g09d2