feat: improve prattParser tables

We can delete the simple category after this change

cc @Kha

src/Init/Lean/Elab/Syntax.lean

@@ -34,7 +34,6 @@ else
 /- The translator from `syntax` to `ParserDescr` syntax uses the following modes -/
 inductive ToParserDescrMode
 | anyCat -- Node kind `Lean.Parser.Syntax.cat` is allowed for any category
-| noCat  -- Node kind `Lean.Parser.Syntax.cat` is not allowed for any category
 | exceptCat (catName : Name) -- Node kind `Lean.Parser.Syntax.cat` is allowed if the category is not `catName`
 | toPushLeading (catName : Name) -- Node kind `Lean.Parser.Syntax.cat` is allowed if the category is `catName`, and it is translated into `ParserDescr.pushLeading`
 
@@ -49,8 +48,8 @@ fun mode => match mode, first with
 
 @[inline] private def withNoPushLeading {α} (x : ToParserDescrM α) : ToParserDescrM α :=
 fun mode => match mode with
-  | ToParserDescrMode.toPushLeading _ => x ToParserDescrMode.noCat
-  | mode                              => x mode
+  | ToParserDescrMode.toPushLeading cat => x (ToParserDescrMode.exceptCat cat)
+  | mode                                => x mode
 
 partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
 | stx =>
@@ -75,18 +74,17 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
         markAsTrailingParser; -- mark as trailing par
         `(ParserDescr.pushLeading)
       else
-        liftM $ throwError (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', '" ++ cat' ++ "', atom, or literal expected")
+        let rbp := rbp?.getD 0;
+        `(ParserDescr.parser $(quote cat) $(quote rbp))
     | ToParserDescrMode.anyCat =>
       let rbp := rbp?.getD 0;
       `(ParserDescr.parser $(quote cat) $(quote rbp))
     | ToParserDescrMode.exceptCat cat' =>
       if cat == cat' then
-        liftM $ throwError (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', simple parser categories do not allow left recursion (try `pratt` category)")
+        liftM $ throwError (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', parser algorithm does not allow this form of left recursion")
       else
         let rbp := rbp?.getD 0;
         `(ParserDescr.parser $(quote cat) $(quote rbp))
-    | ToParserDescrMode.noCat  =>
-      liftM $ throwError (stx.getArg 3) ("invalid occurrence of '" ++ cat ++ "', atom or literal expected")
   else if kind == `Lean.Parser.Syntax.atom then do
     match (stx.getArg 0).isStrLit? with
     | some atom =>
@@ -135,8 +133,8 @@ partial def toParserDescrAux : Syntax → ToParserDescrM Syntax
   Given a `stx` of category `syntax`, return a pair `(newStx, trailingParser)`,
   where `newStx` is of category `term`. After elaboration, `newStx` should have type
   `TrailingParserDescr` if `trailingParser == true`, and `ParserDescr` otherwise. -/
-def toParserDescr (stx : Syntax) (catName : Name) (isSimpleCategory : Bool)  : TermElabM (Syntax × Bool) :=
-let mode := if isSimpleCategory then ToParserDescrMode.exceptCat catName else ToParserDescrMode.toPushLeading catName;
+def toParserDescr (stx : Syntax) (catName : Name) : TermElabM (Syntax × Bool) :=
+let mode := ToParserDescrMode.toPushLeading catName;
 (toParserDescrAux stx mode).run false
 
 end Term
@@ -146,20 +144,9 @@ namespace Command
 @[builtinCommandElab syntaxCat] def elabDeclareSyntaxCat : CommandElab :=
 fun stx => do
   let catName  := stx.getIdAt 1;
-  -- kind is of the form `optional (":" >> (nonReservedSymbol "simple" <|> nonReservedSymbol "pratt"))`
-  let kind     := stx.getArg 2;
-  let isSimple :=
-    if kind.isNone then true
-    else match kind.getArg 1 with
-    | Syntax.atom _ "simple" => true
-    | _                      => false;
   let attrName := catName.appendAfter "Parser";
   env ← getEnv;
-  env ← liftIO stx $
-    if isSimple then
-      Parser.registerSimpleParserCategory env attrName catName
-    else
-      Parser.registerPrattParserCategory env attrName catName;
+  env ← liftIO stx $ Parser.registerPrattParserCategory env attrName catName;
   setEnv env
 
 def mkFreshKind (catName : Name) : CommandElabM Name := do
@@ -185,10 +172,9 @@ fun stx => do
   env ← getEnv;
   let cat := (stx.getIdAt 4).eraseMacroScopes;
   unless (Parser.isParserCategory env cat) $ throwError (stx.getArg 4) ("unknown category '" ++ cat ++ "'");
-  let isSimpleCategory := Parser.isSimpleParserCategory env cat;
   kind ← elabKind (stx.getArg 1) cat;
   let catParserId := mkIdentFrom stx (cat.appendAfter "Parser");
-  (val, trailingParser) ← runTermElabM none $ fun _ => Term.toParserDescr (stx.getArg 2) cat isSimpleCategory;
+  (val, trailingParser) ← runTermElabM none $ fun _ => Term.toParserDescr (stx.getArg 2) cat;
   type ← if trailingParser then `(Lean.TrailingParserDescr) else `(Lean.ParserDescr);
   -- TODO: meaningful, unhygienic def name for selective parser `open`ing?
   d ← `(@[$catParserId:ident] def myParser : $type := ParserDescr.node $(quote kind) $val);

src/Init/Lean/Parser/Parser.lean

@@ -1276,6 +1276,7 @@ end TokenMap
 
 structure PrattParsingTables :=
 (leadingTable    : TokenMap Parser := {})
+(leadingParsers  : List Parser := []) -- for supporting parsers we cannot obtain first token
 (trailingTable   : TokenMap TrailingParser := {})
 (trailingParsers : List TrailingParser := []) -- for supporting parsers such as function application
 
@@ -1364,6 +1365,7 @@ def leadingParser (kind : Name) (tables : PrattParsingTables) (leadingIdentAsSym
 fun a c s =>
   let iniSz   := s.stackSize;
   let (s, ps) := indexed tables.leadingTable c s leadingIdentAsSymbol;
+  let ps      := tables.leadingParsers ++ ps;
   if ps.isEmpty then
     s.mkError (toString kind)
   else
@@ -1588,7 +1590,9 @@ match categories.find? catName with
   match p.info.firstTokens with
   | FirstTokens.tokens tks    => addTokens tks
   | FirstTokens.optTokens tks => addTokens tks
-  | _ => throw ("invalid parser '" ++ toString parserName ++ "', initial token is not statically known")
+  | _ =>
+    let tables := { leadingParsers := p :: tables.leadingParsers, .. tables };
+    pure $ categories.insert catName (ParserCategory.pratt tables i)
 
 private def addTrailingParserAux (tables : PrattParsingTables) (p : TrailingParser) : PrattParsingTables :=
 let addTokens (tks : List TokenConfig) : PrattParsingTables :=