Mixfix operators

src/Lib/Common.idr

@@ -1,6 +1,7 @@
 module Lib.Common
 
 import Data.String
+import public Data.SortedMap
 
 -- I was going to use a record, but we're peeling this off of bounds at the moment.
 public export
@@ -54,10 +55,19 @@ Show Fixity where
   show InfixR = "infixr"
   show Infix = "infix"
 
+
 public export
 record OpDef where
   constructor MkOp
   name : String
   prec : Int
   fix : Fixity
+  isPrefix : Bool
+  ||| rule is everything after the first part of the operator, splitting on `_`
+  ||| a normal infix operator will have a trailing `""` which will match to
+  ||| prec / prec - 1
+  rule : List String
 
+public export
+Operators : Type
+Operators = SortedMap String OpDef

src/Lib/Parser.idr

@@ -74,10 +74,6 @@ 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"
@@ -98,22 +94,55 @@ pArg = do
 
 AppSpine = List (Icit,FC,Raw)
 
-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
+-- helper for debugging
+traceM : Monad m => String -> m ()
+traceM msg = trace msg $ pure ()
+
+pratt : Operators -> Int -> String -> Raw -> AppSpine -> Parser (Raw, AppSpine)
+pratt ops prec stop left spine = do
+  (left, spine) <- runPrefix stop left spine
+  case spine of
+    [] => pure (left, [])
+    ((Explicit, fc, tm@(RVar x nm)) :: rest) =>
+        if nm == stop then pure (left,spine) else
+        case lookup nm ops of
+          Just (MkOp name p fix False rule) => if p < prec
+            then pure (left, spine)
+            else
+              runRule p fix stop rule (RApp fc (RVar fc name) left Explicit) rest
+          Just _ => fail "expected operator"
+          Nothing => pratt ops prec stop (RApp fc left tm Explicit) rest
+    ((icit, fc, tm) :: rest) => pratt ops prec stop (RApp fc left tm icit) rest
+  where
+    runRule : Int -> Fixity -> String -> List String -> Raw -> AppSpine -> Parser (Raw,AppSpine)
+    runRule p fix stop [] left spine = pure (left,spine)
+    runRule p fix stop [""] left spine = do
+      let pr = case fix of InfixR => p; _ => p + 1
+      case spine of
+                ((_, fc, right) :: rest) => do
+                  (right, rest) <- pratt ops pr stop right rest
+                  pratt ops prec stop (RApp fc left right Explicit) rest
+                _ => fail "trailing operator"
+
+    runRule p fix stop (nm :: rule) left spine = do
+      let ((_,_,right)::rest) = spine | _ => fail "short"
+      (right,rest) <- pratt ops 0 nm right rest -- stop!!
+      let ((_,fc',RVar fc name) :: rest) = rest
+        | _ => fail "expected \{nm}"
+
+      if name == nm
+          then runRule p fix stop rule (RApp fc left right Explicit) rest
+          else fail "expected \{nm}"
+
+
+    runPrefix : String -> Raw -> AppSpine -> Parser (Raw, AppSpine)
+    runPrefix stop (RVar fc nm) spine =
+      case lookup nm ops of
+           -- TODO False should be an error here
+         Just (MkOp name p fix True rule) => do
+            runRule p fix stop rule (RVar fc name) spine
+         _ => pure (left, spine)
+    runPrefix stop left spine = pure (left, spine)
 
 parseOp : Parser Raw
 parseOp = do
@@ -121,7 +150,7 @@ parseOp = do
   ops <- getOps
   hd <- atom
   rest <- many pArg
-  (res, []) <- pratt ops 0 hd rest
+  (res, []) <- pratt ops 0 "" hd rest
     | _ => fail "extra stuff"
   pure res
 

src/Lib/Parser/Impl.idr

@@ -4,6 +4,7 @@ import Lib.Token
 import Lib.Common
 import Data.String
 import Data.Nat
+import Data.List1
 
 public export
 TokenList : Type
@@ -12,8 +13,8 @@ TokenList = List BTok
 -- Result of a parse
 public export
 data Result : Type -> Type where
-  OK : a -> (toks : TokenList) -> (com : Bool) -> List OpDef -> Result a
-  Fail : Bool -> Error -> (toks : TokenList) -> (com : Bool) -> List OpDef -> Result a
+  OK : a -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
+  Fail : Bool -> Error -> (toks : TokenList) -> (com : Bool) -> Operators -> Result a
 
 export
 Functor Result where
@@ -34,10 +35,10 @@ Functor Result where
 -- This is a Reader in FC, a State in Operators, Commit flag, TokenList
 
 export
-data Parser a = P (TokenList -> Bool -> List OpDef -> (lc : FC) -> Result a)
+data Parser a = P (TokenList -> Bool -> Operators -> (lc : FC) -> Result a)
 
 export
-runP : Parser a -> TokenList -> Bool -> List OpDef -> FC -> Result a
+runP : Parser a -> TokenList -> Bool -> Operators -> FC -> Result a
 runP (P f) = f
 
 error : TokenList -> String -> Error
@@ -46,14 +47,14 @@ error ((MkBounded val isIrrelevant (MkBounds line col _ _)) :: _) msg = E (line,
 
 export
 parse : Parser a -> TokenList -> Either Error a
-parse pa toks = case runP pa toks False [] (-1,-1) of
+parse pa toks = case runP pa toks False empty (-1,-1) of
   Fail fatal err toks com ops => Left err
   OK a [] _ _ => Right a
   OK a ts _ _ => Left (error ts "Extra toks")
 
 ||| Intended for parsing a top level declaration
 export
-partialParse : Parser a -> List OpDef -> TokenList -> Either Error (a, List OpDef, TokenList)
+partialParse : Parser a -> Operators -> TokenList -> Either Error (a, Operators, TokenList)
 partialParse pa ops toks = case runP pa toks False ops (0,0) of
   Fail fatal err toks com ops => Left err
   OK a ts _ ops => Right (a,ops,ts)
@@ -75,13 +76,18 @@ fatal : String -> Parser a
 fatal msg = P $ \toks,com,ops,col => Fail True (error toks msg) toks com ops
 
 export
-getOps : Parser (List OpDef)
+getOps : Parser (Operators)
 getOps = P $ \ toks, com, ops, col => OK ops toks com ops
 
 export
 addOp : String -> Int -> Fixity -> Parser ()
 addOp nm prec fix = P $ \ toks, com, ops, col =>
-  OK () toks com ((MkOp nm prec fix) :: ops)
+  let parts = split (=='_') nm in
+  case parts of
+    "" ::: key :: rule => OK () toks com (insert key (MkOp nm prec fix False rule) ops)
+    key ::: rule => OK () toks com (insert key (MkOp nm prec fix True rule) ops)
+
+
 
 export
 Functor Parser where

src/Lib/Tokenizer.idr

@@ -8,11 +8,14 @@ import Lib.Common
 keywords : List String
 keywords = ["let", "in", "where", "case", "of", "data", "U", "do",
             "ptype", "pfunc", "module", "infixl", "infixr", "infix",
-            "∀", "forall", ".",
+            "∀", "forall",
              "->", "→", ":", "=>", ":=", "=", "<-", "\\", "_"]
 
 checkKW : String -> Token Kind
-checkKW s = if elem s keywords then Tok Keyword s else Tok Ident s
+checkKW s =
+  if s /= "_" && elem '_' (unpack s) then Tok MixFix s else
+  if elem s keywords then Tok Keyword s
+  else Tok Ident s
 
 checkUKW : String -> Token Kind
 checkUKW s = if elem s keywords then Tok Keyword s else Tok UIdent s
@@ -54,7 +57,7 @@ rawTokens
   -- for now, our lambda slash is singleton
   <|> match (singleton) (Tok Symbol)
   -- TODO Drop MixFix token type when we support if_then_else_
-  <|> match (exact "_" <+> (some opMiddle) <+> exact "_") (Tok MixFix)
+  <|> match (exact "_,_" <|> exact "_._") (Tok MixFix)
   -- REVIEW - expect non-alpha after?
   <|> match (some digit) (Tok Number)
   -- for module names and maybe type constructors

src/Lib/TopContext.idr

@@ -23,7 +23,7 @@ Show TopContext where
 
 public export
 empty : HasIO m => m TopContext
-empty = pure $ MkTop [] !(newIORef (MC [] 0)) False !(newIORef []) [] []
+empty = pure $ MkTop [] !(newIORef (MC [] 0)) False !(newIORef []) [] empty
 
 ||| set or replace def. probably need to check types and Axiom on replace
 public export

src/Lib/Types.idr

@@ -398,7 +398,7 @@ record TopContext where
   errors : IORef (List Error)
   ||| loaded modules
   loaded : List String
-  ops : List OpDef
+  ops : Operators
 
 -- we'll use this for typechecking, but need to keep a TopContext around too.
 public export