diff --git a/src/Init/Lean/Elab/Syntax.lean b/src/Init/Lean/Elab/Syntax.lean index 525eb38652..991fdb5098 100644 --- a/src/Init/Lean/Elab/Syntax.lean +++ b/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); diff --git a/src/Init/Lean/Parser/Parser.lean b/src/Init/Lean/Parser/Parser.lean index a2d2bf1bf8..02ddb0ebc9 100644 --- a/src/Init/Lean/Parser/Parser.lean +++ b/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 :=