Combine parser of app and operator

TODO.md

@@ -1,6 +1,9 @@
 
 ## TODO
 
+- [ ] Allow unicode operators/names
+  - refactored parser to prep for this
+- [ ] handle if_then_else_
 - [x] Remember operators from imports
 - [ ] Default cases for non-primitives (currently gets expanded to all constructors)
 - [x] Case for primitives

src/Lib/Parser.idr

@@ -74,6 +74,10 @@ export term : (Parser Raw)
 withPos : Parser a -> Parser (FC, a)
 withPos pa = (,) <$> getPos <*> pa
 
+lookup : String -> List OpDef -> Maybe OpDef
+lookup _ [] = Nothing
+lookup name (op :: ops) = if op.name == name then Just op else lookup name ops
+
 -- the inside of Raw
 atom : Parser Raw
 atom = RU <$> getPos <* keyword "U"
@@ -91,40 +95,36 @@ pArg = do
   (Explicit,fc,) <$> atom
     <|> (Implicit,fc,) <$> braces typeExpr
     <|> (Auto,fc,) <$> dbraces typeExpr
+    <|> (Explicit,fc,) . RVar fc <$> token Oper
 
-parseApp : Parser Raw
-parseApp = do
-  fc <- getPos
-  hd <- atom
-  rest <- many pArg
-  pure $ foldl (\a, (icit,fc,b) => RApp fc a b icit) hd rest
+AppSpine = List (Icit,FC,Raw)
 
-lookup : String -> List OpDef -> Maybe OpDef
-lookup _ [] = Nothing
-lookup name (op :: ops) = if op.name == name then Just op else lookup name ops
+pratt : List OpDef -> Int -> Raw -> AppSpine -> Parser (Raw, AppSpine)
+pratt ops prec left [] = pure (left, [])
+pratt ops prec left rest@((Explicit, fc, tm@(RVar x nm)) :: xs) =
+  let op' = ("_" ++ nm ++ "_") in
+  case lookup op' ops of
+    Nothing => pratt ops prec (RApp fc left tm Explicit) xs
+    Just (MkOp name p fix) => if p < prec
+      then pure (left, rest)
+      else
+        let pr = case fix of InfixR => p; _ => p + 1 in
+        case xs of
+          ((_, _, right) :: rest) => do
+            (right, rest) <- pratt ops pr right rest
+            pratt ops prec (RApp fc(RApp fc (RVar fc op') left Explicit) right Explicit) rest
+          _ => fail "trailing operator"
+pratt ops prec left ((icit, fc, tm) :: xs) = pratt ops prec (RApp fc left tm icit) xs
 
 parseOp : Parser Raw
-parseOp = parseApp >>= go 0
-  where
-    go : Int -> Raw -> Parser Raw
-    go prec left =
-      try (do
-        fc <- getPos
-        op <- token Oper
-        ops <- getOps
-        let op' = "_" ++ op ++ "_"
-        let Just (MkOp _ p fix) = lookup op' ops
-          -- this is eaten, but we need `->` and `:=` to not be an operator to have fatal here
-         | Nothing => case op of
-         -- Location is poor on these because we pull off of the remaining token list...
-          "->" => fail "no infix decl for \{op}"
-          ":=" => fail "no infix decl for \{op}"
-          op => fatal "no infix decl for \{op}"
-        if p >= prec then pure () else fail ""
-        let pr = case fix of InfixR => p; _ => p + 1
-        right <- go pr !(parseApp)
-        go prec (RApp fc (RApp fc (RVar fc op') left Explicit) right Explicit))
-      <|> pure left
+parseOp = do
+  fc <- getPos
+  ops <- getOps
+  hd <- atom
+  rest <- many pArg
+  (res, []) <- pratt ops 0 hd rest
+    | _ => fail "extra stuff"
+  pure res
 
 export
 letExpr : Parser Raw

src/Lib/Syntax.idr

@@ -60,19 +60,19 @@ public export
 data RCaseAlt = MkAlt Raw Raw
 
 data Raw : Type where
-  RVar : FC -> (nm : Name) -> Raw
-  RLam : FC -> (nm : String) -> (icit : Icit) -> (ty : Raw) -> Raw
-  RApp : FC -> (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw
-  RU   : FC -> Raw
-  RPi  : FC -> (nm : Maybe Name) -> (icit : Icit) -> (ty : Raw) -> (sc : Raw) -> Raw
-  RLet : FC -> (nm : Name) -> (ty : Raw) -> (v : Raw) -> (sc : Raw) -> Raw
-  RAnn  : FC -> (tm : Raw) -> (ty : Raw) -> Raw
-  RLit : FC -> Literal -> Raw
-  RCase : FC -> (scrut : Raw) -> (alts : List RCaseAlt) -> Raw
-  RImplicit : FC -> Raw
-  RHole : FC -> Raw
+  RVar : (fc : FC) -> (nm : Name) -> Raw
+  RLam : (fc : FC) -> (nm : String) -> (icit : Icit) -> (ty : Raw) -> Raw
+  RApp : (fc : FC) -> (t : Raw) -> (u : Raw) -> (icit : Icit) -> Raw
+  RU   : (fc : FC) -> Raw
+  RPi  : (fc : FC) -> (nm : Maybe Name) -> (icit : Icit) -> (ty : Raw) -> (sc : Raw) -> Raw
+  RLet : (fc : FC) -> (nm : Name) -> (ty : Raw) -> (v : Raw) -> (sc : Raw) -> Raw
+  RAnn : (fc : FC) -> (tm : Raw) -> (ty : Raw) -> Raw
+  RLit : (fc : FC) -> Literal -> Raw
+  RCase : (fc : FC) -> (scrut : Raw) -> (alts : List RCaseAlt) -> Raw
+  RImplicit : (fc : FC) -> Raw
+  RHole : (fc : FC) -> Raw
   -- not used, but intended to allow error recovery
-  RParseError : FC -> String -> Raw
+  RParseError : (fc : FC) -> String -> Raw
 
 %name Raw tm
 

src/Lib/Tokenizer.idr

@@ -48,6 +48,8 @@ unquote str = case unpack str of
     go ('\\' :: (x :: xs)) = x :: go xs
     go (x :: xs) = x :: go xs
 
+opMiddle = pred (\c => not (isSpace c || c == '_'))
+
 rawTokens : Tokenizer (Token Kind)
 rawTokens
    =  match (lower <+> many identMore) checkKW
@@ -55,7 +57,7 @@ rawTokens
   <|> match (some digit) (Tok Number)
   <|> match (is '#' <+> many alpha) (Tok Pragma)
   <|> match charLit (Tok Character)
-  <|> match (exact "_" <+> (some opChar <|> exact ",") <+> exact "_") (Tok MixFix)
+  <|> match (exact "_" <+> (some opMiddle) <+> exact "_") (Tok MixFix)
   <|> match (quo <+> manyUntil quo (esc any <|> any) <+> quo) (Tok StringKind . unquote)
   <|> match (lineComment (exact "--")) (Tok Space)
   <|> match (blockComment (exact "/-") (exact "-/")) (Tok Space)