diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,131 @@ ## Unreleased +### Breaking. A non-terminal is a key, and `pegGrammar` declares the key type + +`PExp` and `Grammar` are indexed by the type of the grammar's non-terminal +keys, `nt :: Type -> Type`, instead of by a type-level environment: + +```haskell +data PExp (s :: Type) (nt :: Type -> Type) (a :: Type) +data Grammar (s :: Type) (nt :: Type -> Type) (a :: Type) + +NT :: nt a -> PExp s nt a +``` + +`pegGrammar` in declaration position now declares a GADT with one constructor +per rule, its `Tabulate` instance, and one binding per rule whose signature is +the rule's annotation: + +```haskell +data ArithEnv s a where + ArithEnv_expr :: ArithEnv s Exp + ArithEnv_term :: ArithEnv s Exp +instance Tabulate (ArithEnv s) +arith'expr :: Stream s => PExp s (ArithEnv s) Exp +arith :: Stream s => Grammar s (ArithEnv s) Exp -- = Keyed rules start +``` + +A grammar written that way needs no change beyond `{-# LANGUAGE GADTs #-}`, +which the splice asks for by name when it is missing: `%env` still names the +generated type and `Grammar s (ArithEnv s) Exp` is still its signature. + +A type-level environment is still supported, through the key `InEnv env`, a +membership proof into it. `nt @"expr"`, `ntw`, `pegRules`, `RCons` and +`pegGrammar` in expression position all go through it, and so does a +hand-written environment, whose signatures gain an `InEnv`: + +```haskell +calc :: Stream s => Grammar s (InEnv (CalcEnv s)) Expr -- was Grammar s (CalcEnv s) Expr +``` + +A combinator over expressions, `PExp s env a -> PExp s env a`, works unchanged +over either kind of key. `PEG.Syntax.NTW` is gone (`ntw` remains, as +`NT . InEnv`), and `nt` no longer asks for `KnownSymbol`. + +**Why.** Removing the FIRST sets from the environment left a cost that grew +faster than the grammar, and it was the proof itself. A reference into a list +carries `There (There ... Here)`, and GHC's evidence for it is proportional to +the rule's depth times the size of what is left of the list. Handing GHC the +proof instead of having it search saved a constant; the proof still had to be +checked. Through `pegGrammar` a 128-rule grammar needed 2.2 GB of heap, and a +256-rule one did not fit in 8 GB. A constructor's type does not depend on the +rest of the grammar (`ghc -fno-code`, `bench-compile/`): + +| rules | before | key type | +|---|---|---| +| 64 | 1.16 s, 385 MiB | 0.44 s, 49 MiB | +| 128 | 5.70 s, 2 180 MiB | 0.50 s, 51 MiB | +| 256 | exhausts 8 GB | 0.57 s, 80 MiB | +| 512 | — | 0.70 s, 98 MiB | +| 1024 | — | 1.17 s, 159 MiB | + +The per-rule bindings also cut what the simplifier does with a grammar: +MiniPython at `-O1` went from 2.4 s and 177 MiB to 1.5 s and 111 MiB. + +Parsing is unaffected: the allocation benchmark agrees with the previous +commit on every row, to within 0.1 byte per input byte on three of the +smallest inputs, and MiniPython over its key type allocates what it does over +an environment. + +### Added + +- `PEG.Key`: `Tabulate`, `Table` and `InEnv`. +- `Keyed`, the `Grammar` constructor for a key type. +- `%param name :: Type` in `pegGrammar`: the grammar and every rule take an + argument in scope in every semantic action, which is what a grammar that + used to be written in expression position to capture a variable needs. + Repeatable. +- `examples/MiniPython.hs`, the 27-rule grammar of the MiniPython language of + the compilers course at UFOP, and a `minipython` mode in `bench-compile/`. +- `bench-compile/run.sh` reports GHC's peak heap, and has `qq-grammar-expr` + (a grammar over a list, through `pegGrammar`) and `lookup-key` (the keys + with no library) modes. + +### Shared prefixes of alternatives are parsed once + +The quasi-quoters translate consecutive alternatives that begin with the same +items as the common prefix followed by a choice of the remainders: +`A B / A C` becomes `A (B / C)`, recursively, with each remainder's action +still seeing the prefix under its own labels. In a PEG the two accept the +same inputs with the same results, since `A` would parse exactly the same +thing the second time. + +Without it, a precedence level written `e:or_expr ws "if" ... / e:or_expr` +parses its operand twice, and the cost is exponential in how deeply the +*input* nests. On MiniPython, `print(str(mdc(f(g(x)))))` took 348 ms, eight +times as long per level; a 13.6 KB file of the course's examples took 965 ms. +Both now take under 15 ms. The copy of the library the course's reference +compiler used to vendor escaped this only by accident: its grammar was static +combinator code, and GHC's CSE shared the repeated call. Compiled with +`-O0` it took 6.9 s on the same expression. + +Only consecutive alternatives are grouped, and an alternative that is not a +sequence is left alone. `PEG.QQ.Syntax`'s `PExpr`, `Item` and `RelS` now +derive `Eq`. + +### Fixed + +- The library builds with GHC 9.6 again, as `tested-with` and the + `template-haskell >= 2.19` bound said it did: `PEG.Parse` no longer needs + `TypeAbstractions`, the binders `pegGrammar` generates go through + `PEG.QQ.Compat` rather than naming `BndrReq`, which template-haskell 2.21 + introduced, and the analysis test-suite no longer relies on `foldl'` being + in the Prelude. + +### The analysis is linear + +`PEG.Analysis` ran on every splice and computed every rule's FIRST set by +Kleene iteration over whole sets, rebuilding and comparing all of them on +each pass. A precedence ladder of `N` rules has FIRST sets of `N^2/2` names, +and on 1024 rules that was 49 of the 58 seconds a keyed grammar took to +compile. The diagnostics need none of it: nullability is a fixpoint over +booleans, left recursion is a cyclic strongly connected component of the +direct-head graph, and the cycle reported is a shortest one, found breadth +first. The FIRST sets in the environment `analyse` returns are that graph's +closure, built only when the environment is inspected — 0.5 s at 1024 rules +when they are. `typed-peg` now depends on `containers`. + ### Breaking. The environment no longer carries FIRST sets An entry of a grammar's environment was a rule's nullability, its FIRST set diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,9 +2,11 @@ Type-safe PEG (Parsing Expression Grammar) parser combinators for Haskell. -Grammar non-terminals are checked at the type level against an environment -that binds each rule to the type it returns, and left-recursive grammars are -caught when the grammar is written rather than looping at runtime. +Grammar non-terminals are checked at the type level — a reference is a key +whose type is the result of the rule it names — and left-recursive grammars +are caught when the grammar is written rather than looping at runtime. +Checking a grammar costs GHC time and memory linear in its size: a 1024-rule +grammar type-checks in about a second. ## Features @@ -43,7 +45,7 @@ matters. A `Grammar` is monomorphic in its stream. To reuse one across several, give -it a `forall s. Stream s => Grammar s Env _ A` signature — but note that makes +it a `forall s. Stream s => Grammar s (Env s) A` signature — but note that makes it a function of a dictionary, so the compiled parser is no longer shared between calls. Bind a monomorphic parser where that matters: @@ -72,28 +74,72 @@ |] ``` -That declares three things: `type ArithEnv s`, the signature -`arith :: Stream s => Grammar s (ArithEnv s) Exp`, and `arith` itself. Run -it with `parse arith "1+2*3"`. +That declares the grammar's key type, one constructor per rule, +```haskell +data ArithEnv s a where + ArithEnv_expr :: ArithEnv s Exp + ArithEnv_term :: ArithEnv s Exp + ... +``` + +a binding per rule (`arith'expr :: Stream s => PExp s (ArithEnv s) Exp`, ...), +and `arith :: Stream s => Grammar s (ArithEnv s) Exp`. Run it with +`parse arith "1+2*3"`. The module needs `GADTs`. + A rule's **result type** is the one thing the grammar does not determine — it comes from the Haskell in the semantic action — which is what the `:: T` -annotations are for. They are claims, and GHC checks them: `Grammar` demands -`Rules s env env`, so an annotation that disagrees with what the body returns -is a type error. +annotations are for. They are claims, and GHC checks them: each is the +signature of that rule's binding, so an annotation that disagrees with what the +body returns is a type error reported against the rule. +A grammar that needs a value from outside — a file name for error positions, +a table of operators — takes it as a parameter: + +```haskell +[pegGrammar| + %name lang + %stream String + %param file :: FilePath + %start program + ... +|] +-- lang :: FilePath -> Grammar String (LangEnv String) Program +``` + `pegRules` remains, for a rule set that is only part of a grammar or that is -combined with hand-written `PExp` combinators. It needs the environment -written out by hand; `examples/Compat.hs` and `examples/Patterns.hs` show -that style. See `examples/Arith.hs` and `examples/Layout.hs` for the -generated one. +combined with hand-written `PExp` combinators. Its non-terminals are a +type-level list written out by hand, and the grammar is a +`Grammar s (InEnv env) a`; `examples/Compat.hs` and `examples/Patterns.hs` +show that style. See `examples/Arith.hs`, `examples/Layout.hs` and +`examples/MiniPython.hs` for the generated one. ## Grammar size, and what is checked where A grammar's size shows up as compile time, because every reference in it is a -constraint GHC has to solve against the environment. An entry of that -environment is a rule's name and the type it returns: +constraint GHC has to solve. How much each one costs depends on what the +reference points into. +**A declared key type** — what `pegGrammar` generates — makes a reference a +constructor, `NT ArithEnv_term`, whose type GHC checks without looking at the +rest of the grammar. The cost is linear in the number of rules +(`ghc -fno-code`, GHC 9.10; `bench-compile/`): + +| rules | through a key type | through a type-level list | +|---|---|---| +| 64 | 0.44 s, 49 MiB | 1.10 s, 375 MiB | +| 128 | 0.50 s, 51 MiB | 5.74 s, 2 298 MiB | +| 256 | 0.57 s, 80 MiB | exhausts 8 GB | +| 1024 | 1.17 s, 159 MiB | — | + +The 27-rule MiniPython grammar in `examples/` takes 0.43 s and 57 MiB. + +**A type-level list** is what `nt @"expr"`, `pegRules` and `pegGrammar` in +expression position use. A reference carries a proof of where its rule sits +in the list, `There (There Here)`, and GHC's evidence for it grows with the +rule's depth and the size of the list, so the total grows faster than the +grammar. An entry of that list is a rule's name and the type it returns: + ```haskell type CalcEnv = '[ '("expr" , 'EnvEntry Expr) @@ -114,7 +160,7 @@ the measurements. Nullability and FIRST sets are still computed — by `PEG.Analysis`, in ordinary -Haskell, when the quasi-quoter runs, in 6 ms for a 64-rule grammar. It is +Haskell, when the quasi-quoter runs, in time linear in the grammar. It is what reports left recursion, a nullable repetition, an undefined non-terminal or a duplicate rule **from the splice**, naming the rule and the chain of head references that closes the cycle: @@ -128,11 +174,16 @@ would not consume input before calling itself ``` +A PEG does not memoise, so `A B / A C` parses `A` twice when `B` fails. The +quasi-quoters factor such alternatives into `A (B / C)` when they are +consecutive, which keeps a grammar whose precedence levels are written that +way linear in the input rather than exponential in its nesting. + So the checks divide like this: | what | checked by | when | |---|---|---| -| a reference names a rule that exists, at the right type | GHC | every compilation | +| a reference names a rule that exists, at the right type | GHC, or the splice for `pegGrammar` | every compilation | | a rule's `:: T` annotation matches what its body returns | GHC | every compilation | | left recursion, nullable repetition, duplicate rule | `PEG.Analysis` | at the splice | @@ -143,8 +194,7 @@ closes *across* two blocks is reported by neither it nor GHC. Writing the grammar as one `pegGrammar` closes both gaps — it is closed-world, so every reference resolves and every cycle is visible — and it is also the fastest to -compile, because it knows each rule's position and emits the membership proof -instead of a `KnownMember` search. +compile, because it declares a key type instead of a list. Since nothing recomputes what `PEG.Analysis` concludes, the `typed-peg-analysis` test-suite checks it against a separate statement of what diff --git a/bench/Bench/Peg.hs b/bench/Bench/Peg.hs --- a/bench/Bench/Peg.hs +++ b/bench/Bench/Peg.hs @@ -69,7 +69,7 @@ ] {-# INLINABLE arith #-} -arith :: Stream s => Grammar s ArithEnv Exp +arith :: Stream s => Grammar s (InEnv ArithEnv) Exp arith = Grammar [pegRules| @@ -93,7 +93,7 @@ ] {-# INLINABLE csv #-} -csv :: Stream s => Grammar s CsvEnv [[Int]] +csv :: Stream s => Grammar s (InEnv CsvEnv) [[Int]] csv = Grammar [pegRules| @@ -118,7 +118,7 @@ ] {-# INLINABLE idents #-} -idents :: Stream s => Grammar s (IdentEnv s) [s] +idents :: Stream s => Grammar s (InEnv (IdentEnv s)) [s] idents = Grammar [pegRules| @@ -162,7 +162,7 @@ ] {-# INLINABLE json #-} -json :: Stream s => Grammar s JsonEnv JValue +json :: Stream s => Grammar s (InEnv JsonEnv) JValue json = Grammar [pegRules| @@ -207,7 +207,7 @@ ] {-# INLINABLE quotedNot #-} -quotedNot :: Stream s => Grammar s QuotedNotEnv [String] +quotedNot :: Stream s => Grammar s (InEnv QuotedNotEnv) [String] quotedNot = Grammar [pegRules| @@ -217,7 +217,7 @@ (nt @"qs") {-# INLINABLE quotedCls #-} -quotedCls :: Stream s => Grammar s (QuotedClsEnv s) [s] +quotedCls :: Stream s => Grammar s (InEnv (QuotedClsEnv s)) [s] quotedCls = Grammar [pegRules| diff --git a/examples/Arith.hs b/examples/Arith.hs --- a/examples/Arith.hs +++ b/examples/Arith.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -50,14 +51,15 @@ addOp l ('/', r) = Div l r addOp _ (c , _) = error ("addOp: unexpected operator " ++ show c) --- | The environment, the signature and the grammar are all declared by the --- quasi-quoter. A rule's result type is the one thing the grammar does not --- determine, which is what the @:: T@ annotations are for; left recursion and --- the rest are checked by 'PEG.Analysis' at the splice. +-- | The key type, a binding per rule, the signature and the grammar are all +-- declared by the quasi-quoter. A rule's result type is the one thing the +-- grammar does not determine, which is what the @:: T@ annotations are for; +-- left recursion and the rest are checked by 'PEG.Analysis' at the splice. -- --- The annotations are still claims that GHC checks, not assertions: --- 'PEG.Grammar.Grammar' demands @Rules s env env@, so an annotation that --- disagrees with what the rule body actually returns is a type error here. +-- The annotations are still claims that GHC checks, not assertions: each is +-- the signature of its rule's binding (@arith'term :: Stream s => PExp s +-- (ArithEnv s) Exp@), so an annotation that disagrees with what the rule body +-- actually returns is a type error here, reported against that rule. -- -- Being polymorphic in the stream has a cost: this is a function of a -- 'Stream' dictionary rather than a constant, so the compiled parser is not diff --git a/examples/Compat.hs b/examples/Compat.hs --- a/examples/Compat.hs +++ b/examples/Compat.hs @@ -83,7 +83,7 @@ , '("digits1", 'EnvEntry s) ] -spanG :: Stream s => Grammar s (SpanEnv s) (s, s) +spanG :: Stream s => Grammar s (InEnv (SpanEnv s)) (s, s) spanG = Grammar [pegRules| @@ -94,10 +94,10 @@ -- @!'x'+ .@ accepts any character that is not an @x@; @!'x'* .@ accepts -- nothing at all. -notSpan1G :: Stream s => Grammar s '[] Char +notSpan1G :: Stream s => Grammar s (InEnv '[]) Char notSpan1G = Grammar RNil [pegExpr| !'x'+ c:. |] -notSpanG :: Stream s => Grammar s '[] Char +notSpanG :: Stream s => Grammar s (InEnv '[]) Char notSpanG = Grammar RNil [pegExpr| !'x'* c:. |] spanCases :: [String] diff --git a/examples/Layout.hs b/examples/Layout.hs --- a/examples/Layout.hs +++ b/examples/Layout.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -21,7 +22,7 @@ -- | @name@ is a character class, so its result is a chunk of the input rather -- than a 'String' — which is why its annotation is @s@ and why the generated --- environment takes the stream as a parameter. +-- key type takes the stream as a parameter. -- -- @ws@ has neither a label nor an action, so it returns @()@: that is the -- DSL's rule for a rule body, and the annotation has to agree with it. A diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -5,6 +5,7 @@ import Layout (doExp, layoutOpts) import Compat (compatMain) import Patterns (patternsMain) +import MiniPython (miniPythonMain) showResult :: Show a => Result String a -> String showResult (OK a _ _) = "OK " ++ show a @@ -28,6 +29,9 @@ putStrLn "\n=== Patterns (see peg-patterns.md) ===" patternsMain + + putStrLn "\n=== MiniPython ===" + miniPythonMain putStrLn "\n=== Differential battery ===" compatMain diff --git a/examples/MiniPython.hs b/examples/MiniPython.hs new file mode 100644 --- /dev/null +++ b/examples/MiniPython.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | The grammar of MiniPython, the language of the compilers course at UFOP. +-- +-- It is ported from the course's reference implementation (the @mpyc@ +-- compiler, @MiniPython.ParserPEG@), with one change to the AST: source +-- positions are dropped, since that grammar filled every one of them with +-- @Pos file 0 0@ anyway. +-- +-- Two things the specification has and that grammar lacked are added, as +-- they were to the course's parsers: a method's explicit @self@ parameter, +-- and a field declared in the body of a class with a type and no initialiser +-- (@x: int@), which is 'SFieldDecl'. +-- +-- It is here for its size rather than for its language. With 27 rules, a +-- dozen precedence levels and some very long ordered choices it is the +-- largest grammar in @examples/@, and a realistic check on what a generated +-- grammar costs the type checker. While environments carried FIRST sets (see +-- "PEG.Type"), this grammar with an inferred environment exhausted a 10 GB +-- heap after four minutes. Over a generated key type (see "PEG.Key") it +-- type-checks in under half a second and 57 MiB; @bench-compile/@ measures it +-- as the @minipython@ mode. +-- +-- Blocks are indentation-sensitive: @block@ requires its statements to be +-- indented further than the line that opened it, and each statement to be +-- aligned with the first one. Run it with 'mpyOpts'. +module MiniPython + ( AnnType (..) + , BinOp (..) + , UnOp (..) + , Expr (..) + , Param (..) + , Stmt (..) + , Program (..) + , MiniPythonEnv + , miniPython + , mpyOpts + , parseMiniPython + , miniPythonMain + ) where + +import PEG hiding (Not) +import PEG.QQ (pegGrammar) + +type Ident = String + +data AnnType + = ATInt + | ATFloat + | ATBool + | ATStr + | ATNone + | ATList AnnType + | ATFunc [AnnType] AnnType + | ATClass Ident + deriving (Show, Eq) + +data BinOp + = Add | Sub | Mul | Div | IDiv | Mod | Pow + | Eq | Ne | Lt | Le | Gt | Ge + | And | Or + deriving (Show, Eq) + +data UnOp = Neg | Not + deriving (Show, Eq) + +data Expr + = EInt Integer + | EFloat Double + | EBool Bool + | EStr String + | ENone + | EVar Ident + | EBinOp BinOp Expr Expr + | EUnOp UnOp Expr + | ECall Expr [Expr] + | EIndex Expr Expr + | EField Expr Ident + | EList [Expr] + | ELambda [Ident] Expr + | EIfExpr Expr Expr Expr + deriving (Show, Eq) + +data Param = Param Ident (Maybe AnnType) + deriving (Show, Eq) + +data Stmt + = SAssign Ident (Maybe AnnType) Expr + | SAssignIdx Expr Expr Expr + | SAssignFld Expr Ident Expr + | SAugAssign Ident BinOp Expr + | SExpr Expr + | SIf [(Expr, [Stmt])] (Maybe [Stmt]) + | SWhile Expr [Stmt] + | SFor Ident Expr [Stmt] + | SReturn (Maybe Expr) + | SBreak + | SContinue + | SPass + | SDef Ident [Param] (Maybe AnnType) [Stmt] + | SClass Ident (Maybe Ident) [Stmt] + | SFieldDecl Ident AnnType + deriving (Show, Eq) + +newtype Program = Program [Stmt] + deriving (Show, Eq) + +data Postfix + = PFCall [Expr] + | PFIndex Expr + | PFField Ident + +applyPostfixes :: Expr -> [Postfix] -> Expr +applyPostfixes = foldl step + where + step e (PFCall args) = ECall e args + step e (PFIndex idx) = EIndex e idx + step e (PFField n) = EField e n + +-- | The left-hand side of an assignment is parsed as an expression and +-- checked afterwards, as Python's own grammar does. +assignTo :: Expr -> Expr -> Stmt +assignTo (EField base n) rhs = SAssignFld base n rhs +assignTo (EIndex base i) rhs = SAssignIdx base i rhs +assignTo (EVar n) rhs = SAssign n Nothing rhs +assignTo e rhs = SExpr (EBinOp Eq e rhs) + +binLeft :: BinOp -> Expr -> [Expr] -> Expr +binLeft o = foldl (EBinOp o) + +binOps :: Expr -> [(BinOp, Expr)] -> Expr +binOps = foldl (\l (o, r) -> EBinOp o l r) + +-- | A keyword is a literal not followed by an identifier character; every +-- @![a-zA-Z0-9_]@ below is that lookahead. +[pegGrammar| + %name miniPython + %start program + %stream String + + program :: Program <- ws ss:(ws st:|s:stmtbody|)* ws !. { Program ss } + + ws :: () <- ([ \t\n\r] / '#' [^\n]* ('\n' / !.))*_~ + + name :: String <- + !( ( "and" / "break" / "bool" / "class" / "continue" + / "def" / "elif" / "else" / "False" / "float" + / "for" / "if" / "int" / "in" / "lambda" + / "None" / "not" / "or" / "pass" / "return" + / "self" / "str" / "True" / "while" ) ![a-zA-Z0-9_] ) + c:[a-zA-Z_] cs:[a-zA-Z0-9_]* { c : cs } + + block :: [Stmt] <- ':' ss:(ws st:|s:stmtbody|)+^> { ss } + + stmtbody :: Stmt <- + d:def_stmt { d } + / cl:class_stmt { cl } + / i:if_stmt { i } + / "while" ![a-zA-Z0-9_] ws wc:expr ws wb:block { SWhile wc wb } + / "for" ![a-zA-Z0-9_] ws fn:name ws "in" ![a-zA-Z0-9_] ws fe:expr ws fb:block + { SFor fn fe fb } + / "return" ![a-zA-Z0-9_] ws re:(re2:expr { Just re2 } / { Nothing }) + { SReturn re } + / "break" ![a-zA-Z0-9_] { SBreak } + / "continue" ![a-zA-Z0-9_] { SContinue } + / "pass" ![a-zA-Z0-9_] { SPass } + / a:assign_stmt { a } + + def_stmt :: Stmt <- + "def" ![a-zA-Z0-9_] ws n:name ws '(' ws + ps:( p:param rest:(ws ',' ws q:param { q })* { p : rest } + / { [] } ) + ws ')' + rt:(ws "->" ws t:ann_type { Just t } / { Nothing }) + ws b:block + { SDef n ps rt b } + + param :: Param <- + "self" ![a-zA-Z0-9_] { Param "self" Nothing } + / pn:name ws ':' ws pt:ann_type { Param pn (Just pt) } + / pn:name { Param pn Nothing } + + class_stmt :: Stmt <- + "class" ![a-zA-Z0-9_] ws n:name ws + par:('(' ws cn:name ws ')' { Just cn } / { Nothing }) + ws b:class_block + { SClass n par b } + + class_block :: [Stmt] <- ':' ss:(ws st:|s:class_member|)+^> { ss } + + class_member :: Stmt <- + n:name ws ':' ws t:ann_type !(ws '=' !'=') { SFieldDecl n t } + / s:stmtbody { s } + + if_stmt :: Stmt <- + "if" ![a-zA-Z0-9_] ws c:expr ws b:block + elifs:(ws "elif" ![a-zA-Z0-9_] ws ec:expr ws eb:block { (ec, eb) })* + alt:(ws "else" ![a-zA-Z0-9_] ws ab:block { Just ab } / { Nothing }) + { SIf ((c, b) : elifs) alt } + + assign_stmt :: Stmt <- + n:name ws ':' ws t:ann_type ws '=' !'=' ws e:expr { SAssign n (Just t) e } + / n:name ws "//=" ws e:expr { SAugAssign n IDiv e } + / n:name ws "+=" ws e:expr { SAugAssign n Add e } + / n:name ws "-=" ws e:expr { SAugAssign n Sub e } + / n:name ws "*=" ws e:expr { SAugAssign n Mul e } + / n:name ws "/=" ws e:expr { SAugAssign n Div e } + / n:name ws "%=" ws e:expr { SAugAssign n Mod e } + / e:postfix_expr ws '=' !'=' ws r:expr { assignTo e r } + / e:expr { SExpr e } + + ann_type :: AnnType <- + "int" ![a-zA-Z0-9_] { ATInt } + / "float" ![a-zA-Z0-9_] { ATFloat } + / "bool" ![a-zA-Z0-9_] { ATBool } + / "str" ![a-zA-Z0-9_] { ATStr } + / "None" ![a-zA-Z0-9_] { ATNone } + / '[' ws t:ann_type ws ']' { ATList t } + / '(' ws ts:(t:ann_type ts2:(ws ',' ws u:ann_type { u })* { t : ts2 } / { [] }) + ws ')' ws "->" ws r:ann_type + { ATFunc ts r } + / n:name ws '[' ws t2:ann_type ws ']' + { if n == "list" then ATList t2 else ATClass n } + / n2:name { ATClass n2 } + + expr :: Expr <- + "lambda" ![a-zA-Z0-9_] ws + ps:(n:name ns:(ws ',' ws m:name { m })* { n : ns } / { [] }) + ws ':' ws b:expr + { ELambda ps b } + / e:or_expr ws "if" ![a-zA-Z0-9_] ws c:or_expr ws "else" ![a-zA-Z0-9_] ws a:expr + { EIfExpr c e a } + / e:or_expr { e } + + or_expr :: Expr <- e:and_expr es:(ws "or" ![a-zA-Z0-9_] ws r:and_expr)* + { binLeft Or e es } + + and_expr :: Expr <- e:not_expr es:(ws "and" ![a-zA-Z0-9_] ws r:not_expr)* + { binLeft And e es } + + not_expr :: Expr <- + "not" ![a-zA-Z0-9_] ws e:not_expr { EUnOp Not e } + / e:add_expr ws o:cmp_op ws r:add_expr { EBinOp o e r } + / e:add_expr { e } + + cmp_op :: BinOp <- + "==" { Eq } / "!=" { Ne } / "<=" { Le } / ">=" { Ge } / '<' { Lt } / '>' { Gt } + + add_expr :: Expr <- + e:mul_expr es:(ws o:('+' { Add } / '-' { Sub }) ws r:mul_expr { (o, r) })* + { binOps e es } + + mul_expr :: Expr <- + e:pow_expr + es:(ws o:("//" { IDiv } / '/' { Div } / '%' { Mod } / '*' !'*' { Mul }) + ws r:pow_expr { (o, r) })* + { binOps e es } + + pow_expr :: Expr <- e:unary_expr ws "**" ws r:pow_expr { EBinOp Pow e r } + / e:unary_expr { e } + + unary_expr :: Expr <- '-' ws e:unary_expr { EUnOp Neg e } + / e:postfix_expr { e } + + postfix_expr :: Expr <- + e:atom + ps:( ws '(' ws as:(ea:expr eas:(ws ',' ws r:expr { r })* { ea : eas } / { [] }) + ws ')' { PFCall as } + / ws '[' ws i:expr ws ']' { PFIndex i } + / ws '.' ws fn:name { PFField fn } )* + { applyPostfixes e ps } + + atom :: Expr <- + "True" ![a-zA-Z0-9_] { EBool True } + / "False" ![a-zA-Z0-9_] { EBool False } + / "None" ![a-zA-Z0-9_] { ENone } + / "self" ![a-zA-Z0-9_] { EVar "self" } + / "int" ![a-zA-Z0-9_] { EVar "int" } + / "float" ![a-zA-Z0-9_] { EVar "float" } + / "bool" ![a-zA-Z0-9_] { EVar "bool" } + / "str" ![a-zA-Z0-9_] { EVar "str" } + / n:name { EVar n } + / ds:[0-9]+ '.' fs:[0-9]+ ep:exponent + { EFloat (read (ds ++ "." ++ fs ++ ep) :: Double) } + / ds:[0-9]+ ep:(e:[eE] s:sign xs:[0-9]+ { (e : s) ++ xs }) + { EFloat (read (ds ++ ep) :: Double) } + / d:[0-9] ds:[0-9_]* { EInt (read (d : filter (/= '_') ds) :: Integer) } + / '"' cs:(c:str_char { c } / !'"' c3:. { c3 })* '"' { EStr cs } + / '\'' cs:(c:str_char { c } / !'\'' c3:. { c3 })* '\'' { EStr cs } + / '(' ws e:expr ws ')' { e } + / '[' ws les:(le:expr les2:(ws ',' ws lr:expr { lr })* { le : les2 } / { [] }) + ws ']' + { EList les } + + exponent :: String <- + e:[eE] s:sign xs:[0-9]+ { (e : s) ++ xs } + / { "" } + + sign :: String <- '+' { "+" } / '-' { "-" } / { "" } + + str_char :: Char <- + '\\' c:( 'n' { '\n' } / 't' { '\t' } / 'r' { '\r' } + / '\\' { '\\' } / '"' { '"' } / '\'' { '\'' } + / '0' { '\0' } / c2:. { c2 } ) + { c } +|] + +-- | Blocks are delimited by indentation, so tokens are compared with the +-- enclosing block's column. +mpyOpts :: Opts +mpyOpts = defaultOpts { optTokenMode = relD geR } + +parseMiniPython :: String -> Maybe Program +parseMiniPython src = case parseWith mpyOpts miniPython src of + OK p _ _ -> Just p + Fail -> Nothing + +miniPythonMain :: IO () +miniPythonMain = mapM_ run samples + where + run (label, src) = putStrLn $ label ++ " => " ++ case parseMiniPython src of + Just (Program ss) -> "OK, " ++ show (length ss) ++ " statement(s): " + ++ take 100 (show ss) + Nothing -> "Fail" + + samples = + [ ("assign", "x: int = 1 + 2 * 3\n") + , ("def", unlines + [ "def fib(n: int) -> int:" + , " if n < 2:" + , " return n" + , " else:" + , " return fib(n - 1) + fib(n - 2)" + , "print(fib(10))" + ]) + , ("while", unlines + [ "i = 0" + , "while i < 10:" + , " i += 1" + , " if i % 2 == 0:" + , " continue" + , " xs[i] = i ** 2" + ]) + , ("class", unlines + [ "class Point:" + , " x: float" + , " y: float" + , " def __init__(self, x: float, y: float) -> None:" + , " self.x = x" + , " self.y = y" + , " def norm(self) -> float:" + , " return self.x * self.x + self.y * self.y" + , "p = Point(3.0, 4.0)" + , "s = 'a\\n' if not p.norm() >= 1.5e3 else \"b\"" + ]) + , ("missing colon", "if x > 1\n pass\n") + ] diff --git a/examples/Patterns.hs b/examples/Patterns.hs --- a/examples/Patterns.hs +++ b/examples/Patterns.hs @@ -139,7 +139,7 @@ -- Note what is /not/ here: no @try@, no left recursion, and no rule that can -- loop. @expr <- expr '+' term@ would be rejected by 'PEG.Analysis' when the -- @pegRules@ block below is spliced, naming @expr@ and the cycle. -calc :: Stream s => Grammar s (CalcEnv s) Expr +calc :: Stream s => Grammar s (InEnv (CalcEnv s)) Expr calc = Grammar [pegRules| @@ -157,7 +157,7 @@ -- by a negative lookahead on the identifier-continuation class. type KwEnv = '[ '("kw", 'EnvEntry String) ] -kwG :: Stream s => Grammar s KwEnv String +kwG :: Stream s => Grammar s (InEnv KwEnv) String kwG = Grammar [pegRules| kw <- k:"negate" ![a-zA-Z0-9_] { k } |] (nt @"kw") -------------------------------------------------------------------------------- @@ -172,7 +172,7 @@ type OpEnv = '[ '("op", 'EnvEntry (Expr -> Expr -> Expr)) ] -addOp :: Stream s => Grammar s OpEnv (Expr -> Expr -> Expr) +addOp :: Stream s => Grammar s (InEnv OpEnv) (Expr -> Expr -> Expr) addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op") -------------------------------------------------------------------------------- @@ -194,7 +194,7 @@ -- illustrates is the one PEG newcomers get wrong: in an ordered choice the -- longer alternative must come first, because the first success wins and -- there is no backtracking into a committed branch. -prog :: Stream s => Grammar s (ProgEnv s) [Asgn] +prog :: Stream s => Grammar s (InEnv (ProgEnv s)) [Asgn] prog = Grammar [pegRules| diff --git a/peg-patterns.md b/peg-patterns.md --- a/peg-patterns.md +++ b/peg-patterns.md @@ -154,12 +154,18 @@ to write down is the part only you know: what the rule returns. Better still, do not write it down at all. `pegGrammar` generates the -environment from the same `:: T` annotations: +grammar's non-terminals from the same `:: T` annotations — as a key type with +one constructor per rule, `data CalcEnv s a where CalcEnv_expr :: CalcEnv s +Expr; ...`, rather than as a list — and that is also what keeps a grammar of +hundreds of rules cheap to compile: ``` expr :: Expr <- t:term ts:(o:[+-] u:term)* { chainl t ts } ``` +A grammar over a hand-written list names it through `InEnv`: +`Grammar s (InEnv (CalcEnv s)) Expr`. + ### 1.4 Precedence tables: absent, but not impossible *(Willis & Wu, Pattern 1c: Precedence Tables.)* @@ -372,7 +378,7 @@ ```haskell type OpEnv = '[ '("op", 'EnvEntry (Expr -> Expr -> Expr)) ] -addOp :: Stream s => Grammar s OpEnv (Expr -> Expr -> Expr) +addOp :: Stream s => Grammar s (InEnv OpEnv) (Expr -> Expr -> Expr) addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op") ``` diff --git a/src/PEG.hs b/src/PEG.hs --- a/src/PEG.hs +++ b/src/PEG.hs @@ -16,15 +16,15 @@ -- @ -- -- 1. Write the grammar with the 'PEG.QQ.pegGrammar' quasi-quoter, giving each --- rule its result type. It declares the environment, the grammar and its --- signature. +-- rule its result type. It declares the grammar's key type — one +-- constructor per rule, see "PEG.Key" — the grammar and its signature. -- 2. Run the grammar on a 'String' with 'parse' or 'parseWith'. -- --- The environment can also be declared by hand — a type-level list of --- @(name, entry)@ pairs, see 'PEG.Type.Env' — and the rules built with --- 'PEG.QQ.pegRules' or the combinators in "PEG.Syntax". That is what --- 'PEG.QQ.pegGrammar' generates, and it stays supported; it is only more to --- write and slower to compile. +-- The rules can also be named by a type-level list declared by hand — see +-- 'PEG.Type.Env' — and built with 'PEG.QQ.pegRules' or the combinators in +-- "PEG.Syntax", as a @'Grammar' s ('InEnv' env) a@. That stays supported; it +-- is more to write, and compiling it costs more than linearly in the number of +-- rules. -- -- See the @examples/@ directory for complete working grammars. module PEG @@ -33,6 +33,7 @@ , module PEG.Type , module PEG.TyLevel , module PEG.Member + , module PEG.Key , module PEG.Indent , module PEG.Syntax , module PEG.Grammar @@ -43,6 +44,7 @@ import PEG.Grammar import PEG.Stream import PEG.Indent +import PEG.Key import PEG.Member import PEG.Parse import PEG.Syntax diff --git a/src/PEG/Analysis.hs b/src/PEG/Analysis.hs --- a/src/PEG/Analysis.hs +++ b/src/PEG/Analysis.hs @@ -56,8 +56,13 @@ , spannable ) where -import Data.List (foldl1', nub) -import Data.Maybe (fromMaybe) +import Data.Graph (SCC (..), stronglyConnComp) +import Data.List (foldl1') +import qualified Data.List as L +import qualified Data.Map.Strict as M +import Data.Sequence (Seq (..), (|>)) +import qualified Data.Sequence as Seq +import qualified Data.Set as S import PEG.QQ.Syntax (Def (..), Item (..), PExpr (..)) @@ -217,6 +222,27 @@ analyse = analyseWith Closed -- | 'analyse', over a whole grammar or a fragment of one. +-- +-- == Cost +-- +-- This runs inside every splice of a grammar, so its cost is paid on every +-- compilation of the module, and it is written to be linear in the grammar +-- wherever the answer allows. Nothing the diagnostics need is a FIRST set: +-- +-- * Nullability is a least fixpoint over booleans alone. +-- * The /direct/ head references of each rule — 'exprTy' again, with every +-- rule's FIRST set taken to be empty — form a graph, and a rule is +-- left-recursive exactly when it lies on a cycle of that graph, which its +-- strongly connected components say directly. +-- * The cycle reported is a shortest one, found by a breadth-first search +-- inside the rule's component. +-- +-- The FIRST sets in the environment returned are the transitive closure of +-- that graph, and are computed only if the environment is inspected. They +-- used to be computed, by Kleene iteration over whole sets, on every splice: +-- a precedence ladder of @N@ rules has FIRST sets of @N^2/2@ names in total, +-- and each iteration rebuilt and compared all of them, which on 1024 rules +-- was 49 seconds of a 58-second compile. analyseWith :: World -> [Def] -> Either [Diagnostic] RuleEnv analyseWith world defs | not (null dups) = Left dups @@ -225,73 +251,128 @@ | not (null leftRecs) = Left leftRecs | otherwise = Right env where - names = [ n | Def n _ _ <- defs ] + names = [ n | Def n _ _ <- defs ] + defined = S.fromList names - dups = [ DuplicateRule n - | n <- nub names, length (filter (== n) names) > 1 ] + -- The first definition of each name, as 'bodyOf' used to take it. + bodies :: M.Map String PExpr + bodies = M.fromList [ (n, e) | Def n _ e <- reverse defs ] + dups = [ DuplicateRule n | n <- nubOrd names, M.findWithDefault 0 n counts > 1 ] + where counts = M.fromListWith (+) [ (n, 1 :: Int) | n <- names ] + undefs = case world of Open -> [] Closed -> [ UndefinedNT n names - | n <- nub (concatMap (refs . body) defs), n `notElem` names ] - where body (Def _ _ e) = e + | n <- nubOrd (concatMap (\(Def _ _ e) -> refs e) defs) + , not (S.member n defined) ] - -- Kleene iteration from the empty environment. Every clause of 'exprTy' - -- is monotone in the environment and the lattice is finite, so this - -- terminates; it is the least solution of the equations the type families - -- state. - env = fix [ (n, Ty False []) | n <- names ] + -- Kleene iteration over nullability alone, from "nothing is nullable". + -- Each pass updates the rules in order, reading what earlier rules of + -- the same pass concluded, and stops at the first pass that changes + -- nothing; that is still the least solution, since every step is + -- monotone. + nullables :: M.Map String Bool + nullables = fix (M.fromList [ (n, False) | n <- names ]) where - fix m = let m' = step m in if m' == m then m else fix m' - step m = [ (n, exprTy (at m) e) | Def n _ e <- defs ] + fix m = case L.foldl' update (m, False) defs of + (m', True) -> fix m' + (m', _) -> m' + update (m, changed) (Def n _ e) = + let new = tyNullable (exprTy (headsOnly m) e) + in if new && not (M.findWithDefault False n m) + then (M.insert n True m, True) + else (m, changed) - at m n = fromMaybe (Ty False []) (lookup n m) + -- An environment that knows each rule's nullability and nothing of its + -- FIRST set, under which 'exprTy' yields an expression's /direct/ heads. + headsOnly m k = Ty (M.findWithDefault False k m) [] + nullableEnv = headsOnly nullables + + -- The graph of direct head references. A name no rule defines is a node + -- with no successors, as it is opaque in an 'Open' block. + heads :: M.Map String [String] + heads = M.map (tyFirst . exprTy nullableEnv) bodies + + succs k = M.findWithDefault [] k heads + -- A repetition must consume input, which 'PEG.Syntax.Star' states as a -- non-nullable operand. Checking it here names the rule it is in. - illFormed = [ NullableStar n | Def n _ e <- defs, hasNullableRep (at env) e ] + illFormed = [ NullableStar n | Def n _ e <- defs, hasNullableRep nullableEnv e ] + -- Each rule's strongly connected component. A rule is on a cycle when + -- its component is cyclic, which includes a rule heading itself. + component :: M.Map String Int + component = M.fromList + [ (n, i) | (i, CyclicSCC ns) <- zip [0 ..] sccs, n <- ns ] + where + sccs = stronglyConnComp + [ (n, n, [ h | h <- succs n, S.member h defined ]) + | n <- M.keys bodies ] + -- Every rule on a cycle is left-recursive, and reporting each of them -- prints the same cycle once per entry point. Two paths that are -- rotations of each other are the same cycle, so only the first is kept. - leftRecs = dedupe [] [ LeftRecursive n (cycleFrom n) - | (n, t) <- env, n `elem` tyFirst t ] + leftRecs = dedupe S.empty [ LeftRecursive n (cycleFrom n) + | n <- names, M.member n component ] where dedupe _ [] = [] dedupe seen (d@(LeftRecursive _ path) : rest) - | key `elem` seen = dedupe seen rest - | otherwise = d : dedupe (key : seen) rest + | S.member key seen = dedupe seen rest + | otherwise = d : dedupe (S.insert key seen) rest where key = canonical path dedupe seen (d : rest) = d : dedupe seen rest -- A cycle is written as @n -> ... -> n@; drop the repeated end and turn - -- it so that it starts at its least name. + -- it so that it starts at its least name. A shortest cycle visits no + -- rule twice, so that rotation is unique. canonical path = case reverse (drop 1 (reverse path)) of [] -> [] - nodes -> minimum [ rotate k nodes | k <- [0 .. length nodes - 1] ] - where rotate k xs = drop k xs ++ take k xs + nodes -> let (pre, post) = break (== minimum nodes) nodes + in post ++ pre - -- The FIRST set is already transitive, so it says /that/ a rule is - -- left-recursive but not /how/. The chain is recovered from the graph of - -- direct head references, which is 'exprTy' again with the environment - -- cut back to nullability alone. - heads n = tyFirst (exprTy (\k -> Ty (tyNullable (at env k)) []) (bodyOf n)) + -- A shortest cycle through @n@: breadth first from @n@, never leaving its + -- component, until a rule that heads @n@ is dequeued. + cycleFrom n = go (M.singleton n n) (Seq.singleton n) + where + comp = M.lookup n component + go _ Empty = [] + go parents (cur :<| queue) + | n `elem` succs cur = reverse (pathTo parents cur) ++ [n] + | otherwise = + let new = [ h | h <- nubOrd (succs cur) + , M.lookup h component == comp + , not (M.member h parents) ] + parents' = L.foldl' (\m h -> M.insert h cur m) parents new + in go parents' (L.foldl' (|>) queue new) + pathTo parents cur + | cur == n = [n] + | otherwise = cur : pathTo parents (M.findWithDefault n cur parents) - bodyOf n = case [ e | Def m _ e <- defs, m == n ] of - (e:_) -> e - [] -> ESeq [] Nothing + -- The environment, with FIRST sets as the transitive closure of the head + -- graph: exactly what iterating 'exprTy' over whole sets converges to, + -- because 'exprTy' is a union of its operands' sets under a fixed + -- nullability. Lazy, and only built when someone looks. + env = [ (n, Ty (M.findWithDefault False n nullables) + (S.toAscList (reach (succs n)))) + | n <- names ] - cycleFrom n = go [n] n + reach = grow S.empty where - go path cur = case [ h | h <- heads cur, h == n ] of - (_:_) -> reverse (n : path) - [] -> case [ p | h <- heads cur - , h `notElem` path - , n `elem` tyFirst (at env h) - , p <- [go (h : path) h] - , not (null p) ] of - (p:_) -> p - [] -> [] + grow seen [] = seen + grow seen (x:xs) + | S.member x seen = grow seen xs + | otherwise = grow (S.insert x seen) (succs x ++ xs) + +-- | 'Data.List.nub' in @O(n log n)@, keeping first occurrences in order. +nubOrd :: Ord a => [a] -> [a] +nubOrd = go S.empty + where + go _ [] = [] + go seen (x:xs) + | S.member x seen = go seen xs + | otherwise = x : go (S.insert x seen) xs -- | Every non-terminal a body references, at any position. refs :: PExpr -> [String] diff --git a/src/PEG/Grammar.hs b/src/PEG/Grammar.hs --- a/src/PEG/Grammar.hs +++ b/src/PEG/Grammar.hs @@ -5,6 +5,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE RankNTypes #-} -- | Grammar and rule-set types. -- @@ -30,7 +31,8 @@ -- -- * A 'Rules' chain assembled by hand from 'RCons', or a 'Grammar' built -- around one, is checked for /reference/ errors only. A rule that begins --- with itself compiles, and loops when run. +-- with itself compiles, and loops when run. So is a 'Keyed' grammar whose +-- key type and rules were written by hand. -- * 'PEG.QQ.pegRules' analyses its block open-world, because 'RCons' lets two -- blocks be combined and a name the block does not define may be defined by -- the other one. Left recursion that closes /across/ two blocks is @@ -39,9 +41,10 @@ -- reference is resolved and every cycle is visible. -- -- Prefer 'PEG.QQ.pegGrammar'. It is the only way to write a grammar that is --- checked completely, and it is also the fastest to compile, because it knows --- each rule's position and emits 'PEG.Syntax.ntw' with the membership proof --- rather than a 'PEG.Member.KnownMember' search. +-- checked completely, and it is also the fastest to compile: in declaration +-- position it declares a key type for the grammar, one constructor per rule, +-- and builds a 'Keyed' grammar whose references cost the type checker the +-- same however many rules there are. See "PEG.Key". module PEG.Grammar ( Rules (..) , Grammar (..) @@ -49,10 +52,12 @@ import Data.Kind (Type) +import PEG.Key (InEnv, Tabulate) import PEG.Syntax (Name, PExp) import PEG.Type --- | A typed, heterogeneous list of named grammar rules. +-- | A typed, heterogeneous list of named grammar rules over a type-level +-- environment. -- -- @'Rules' s env defs@ is a list of rules over the stream @s@ whose bodies -- reference non-terminals in @env@ and whose definitions together form @@ -60,25 +65,37 @@ data Rules (s :: Type) (env :: Env) (defs :: Env) where RNil :: Rules s env '[] RCons :: Name n - -> PExp s env a + -> PExp s (InEnv env) a -> Rules s env rest -> Rules s env ('(n, 'EnvEntry a) ': rest) -- | A complete PEG grammar over the stream @s@: a set of mutually recursive --- rules and a start expression. --- --- The @Rules s env env@ field is what ties the two halves together: every --- rule's body is checked against the same environment the rule set defines, --- so a reference can only name a rule that exists and only at the type that --- rule has. +-- rules and a start expression, with its non-terminals named by keys of type +-- @nt@. -- -- A 'Grammar' is monomorphic in its stream. To reuse one grammar across -- several stream types, give it a signature of the form --- @forall s. 'PEG.Stream.Stream' s => Grammar s Env a@ — but note that +-- @forall s. 'PEG.Stream.Stream' s => Grammar s (Env s) a@ — but note that -- doing so turns the value into a function of a dictionary, so the compiled -- parser is no longer shared between calls. Prefer a monomorphic top-level -- signature. -data Grammar (s :: Type) (env :: Env) (a :: Type) where +data Grammar (s :: Type) (nt :: Type -> Type) (a :: Type) where + -- | A grammar over a type-level environment. + -- + -- The @Rules s env env@ field is what ties the two halves together: every + -- rule's body is checked against the same environment the rule set + -- defines, so a reference can only name a rule that exists and only at the + -- type that rule has. Grammar :: Rules s env env - -> PExp s env a - -> Grammar s env a + -> PExp s (InEnv env) a + -> Grammar s (InEnv env) a + -- | A grammar over a declared key type: the rule each key names, and the + -- start expression. + -- + -- The rules are a function rather than a list, so that a rule's body is + -- found by matching on its key — a @case@ whose every branch is checked on + -- its own — and not by walking a type-level structure. + Keyed :: Tabulate nt + => (forall b. nt b -> PExp s nt b) + -> PExp s nt a + -> Grammar s nt a diff --git a/src/PEG/Key.hs b/src/PEG/Key.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Key.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + +-- | What a non-terminal reference points at. +-- +-- A 'PEG.Syntax.PExp' is indexed by a /key type/ @nt :: Type -> Type@: a +-- value of type @nt a@ names a rule returning @a@, and +-- @'PEG.Syntax.NT' :: nt a -> PExp s nt a@ is a reference to it. Checking a +-- reference is then checking the type of one constructor, which costs the +-- type checker the same whatever the size of the grammar. +-- +-- There are two kinds of key. +-- +-- * A key type declared for one grammar, one constructor per rule: +-- +-- @ +-- data ArithEnv s a where +-- ArithEnv_expr :: ArithEnv s Exp +-- ArithEnv_term :: ArithEnv s Exp +-- @ +-- +-- This is what 'PEG.QQ.pegGrammar' generates in declaration position, +-- together with its 'Tabulate' instance, and it is what a grammar of any +-- size should use. +-- +-- * @'InEnv' env@, a membership proof into a type-level list of rules +-- ('PEG.Type.Env'). This is what @'PEG.Syntax.nt' \@"expr"@, +-- 'PEG.QQ.pegRules' and a hand-written environment go through. +-- +-- == Why keys +-- +-- The environment used to be the only index. A reference carried a unary +-- proof, @There (There ... Here)@, of where its rule sits in a type-level +-- list, and the type checker's evidence for that proof is proportional to how +-- deep the rule is times how much of the list is left. Summed over every +-- reference of a grammar, that was the whole of what compiling a large +-- grammar cost: 2.2 GB of heap at 128 rules and more than 8 GB at 256, even +-- with the proof supplied by the splice rather than searched for. A declared +-- key costs 50 MB at 512 rules. See @bench-compile/@. +module PEG.Key + ( Tabulate (..) + , Table (..) + , InEnv (..) + ) where + +import Data.Kind (Type) + +import PEG.Member +import PEG.Type + +-- | A total function out of a key type, as a value. +newtype Table (nt :: Type -> Type) (f :: Type -> Type) = + Table { lookupTable :: forall b. nt b -> f b } + +-- | A key type whose rules can be enumerated. +-- +-- This is what lets a grammar over declared keys be compiled with a knot: +-- 'PEG.Parse.compileGrammar' tabulates the compiled rule bodies once and +-- resolves every reference through the table. +class Tabulate (nt :: Type -> Type) where + -- | Memoise a function out of the key type. + -- + -- @'lookupTable' (tabulate f)@ must agree with @f@, and must evaluate + -- @f k@ at most once for each key @k@ however often it is looked up. The + -- instance 'PEG.QQ.pegGrammar' generates binds @f k@ for every constructor + -- in a @let@ outside the lookup. + tabulate :: (forall b. nt b -> f b) -> Table nt f + + -- | The name of the rule a key refers to. + ruleName :: nt b -> String + +-- | A reference into a type-level environment: a proof that @env@ binds some +-- name to a rule returning @a@. +-- +-- The name is not in the type. It does not have to be: a reference is built +-- by 'PEG.Syntax.nt' or 'PEG.Syntax.ntw', which state the name and demand +-- that the environment agrees about the result type. +data InEnv (env :: Env) (a :: Type) where + InEnv :: Member n env a -> InEnv env a diff --git a/src/PEG/Member.hs b/src/PEG/Member.hs --- a/src/PEG/Member.hs +++ b/src/PEG/Member.hs @@ -29,8 +29,10 @@ -- "PEG.Type"), so the same discipline is cheap to keep and worth keeping. -- -- Better still is not to search at all: 'PEG.Syntax.ntw' takes the witness --- rather than deriving it, which is what a quasi-quoter emits, since a splice --- knows every rule's position. +-- rather than deriving it, which is what 'PEG.QQ.pegGrammar' emits in +-- expression position, since a splice knows every rule's position. Best is +-- not to have a list: in declaration position 'PEG.QQ.pegGrammar' declares a +-- key type instead, and a reference is a constructor; see "PEG.Key". module PEG.Member ( Member (..) , KnownMember (..) diff --git a/src/PEG/Parse.hs b/src/PEG/Parse.hs --- a/src/PEG/Parse.hs +++ b/src/PEG/Parse.hs @@ -1,11 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -68,10 +68,11 @@ import PEG.CharSet (CharSet, memberCS) import PEG.Grammar import PEG.Indent +import PEG.Key import PEG.Member import PEG.Stream import PEG.Syntax -import PEG.Type +import PEG.Type (Env, EnvEntry (..)) -- | The result of running a grammar. -- @@ -132,20 +133,20 @@ } -- | Run a grammar with 'defaultOpts'. -parse :: Stream s => Grammar s env a -> s -> Result s a +parse :: Stream s => Grammar s nt a -> s -> Result s a parse = parseWith defaultOpts {-# INLINABLE parse #-} -{-# SPECIALIZE parse :: Grammar String env a -> String -> Result String a #-} -{-# SPECIALIZE parse :: Grammar T.Text env a -> T.Text -> Result T.Text a #-} +{-# SPECIALIZE parse :: Grammar String nt a -> String -> Result String a #-} +{-# SPECIALIZE parse :: Grammar T.Text nt a -> T.Text -> Result T.Text a #-} {-# SPECIALIZE parse - :: Grammar B.ByteString env a -> B.ByteString -> Result B.ByteString a #-} + :: Grammar B.ByteString nt a -> B.ByteString -> Result B.ByteString a #-} -- | Run a grammar with custom 'Opts'. -- -- Partially applying this to the options and the grammar yields a compiled -- parser; see the note at the top of this module. -parseWith :: forall s env a. - Stream s => Opts -> Grammar s env a -> s -> Result s a +parseWith :: forall s nt a. + Stream s => Opts -> Grammar s nt a -> s -> Result s a parseWith opts g = run where step = compileGrammar (optTabWidth opts) g @@ -156,11 +157,11 @@ (# | (# a, st #) #) -> OK a (takeS (stOff st) input) (stInput st) {-# INLINABLE parseWith #-} {-# SPECIALIZE parseWith - :: Opts -> Grammar String env a -> String -> Result String a #-} + :: Opts -> Grammar String nt a -> String -> Result String a #-} {-# SPECIALIZE parseWith - :: Opts -> Grammar T.Text env a -> T.Text -> Result T.Text a #-} + :: Opts -> Grammar T.Text nt a -> T.Text -> Result T.Text a #-} {-# SPECIALIZE parseWith - :: Opts -> Grammar B.ByteString env a + :: Opts -> Grammar B.ByteString nt a -> B.ByteString -> Result B.ByteString a #-} -------------------------------------------------------------------------------- @@ -170,42 +171,88 @@ -- | A rule table in which every body has already been compiled to a 'Step'. -- Built with a knot so that mutually recursive rules resolve to each other's -- closures. -data CRules (s :: Type) (env :: Env) (defs :: Env) where - CNil :: CRules s env '[] +data CRules (s :: Type) (defs :: Env) where + CNil :: CRules s '[] CCons :: Step s a - -> CRules s env rest - -> CRules s env ('(n, 'EnvEntry a) ': rest) + -> CRules s rest + -> CRules s ('(n, 'EnvEntry a) ': rest) -clookup :: Member n defs a -> CRules s env defs -> Step s a +clookup :: Member n defs a -> CRules s defs -> Step s a clookup Here (CCons f _) = f clookup (There m) (CCons _ rest) = clookup m rest +-- | A compiled rule, wrapped so that 'Step' can be the image of a 'Table'. +newtype CStep s a = CStep { unCStep :: Step s a } + -- | Traverse the grammar once and return a closure that consumes input. -- -- The traversal resolves every non-terminal reference to the corresponding -- compiled rule, so at parse time a non-terminal costs one indirect call -- instead of a walk down the rule list. -compileGrammar :: forall s env a. - Stream s => Int -> Grammar s env a -> Step s a -compileGrammar tw (Grammar rules start) = compileE tw table start +compileGrammar :: forall s nt a. + Stream s => Int -> Grammar s nt a -> Step s a +compileGrammar tw (Grammar rules start) = compileListed tw rules start +compileGrammar tw (Keyed rules start) = compileKeyed tw tabulate rules start + +-- | A grammar over a type-level environment: the rules are compiled into a +-- list, and a reference is resolved by following its membership proof down +-- that list, once, while the grammar is being compiled. +compileListed :: forall s env a. Stream s + => Int -> Rules s env env -> PExp s (InEnv env) a -> Step s a +compileListed tw rules start = compileE tw resolve start where - table :: CRules s env env + table :: CRules s env table = build rules - build :: forall defs. Rules s env defs -> CRules s env defs + resolve :: forall b. InEnv env b -> Step s b + resolve (InEnv w) = clookup w table + + build :: forall defs. Rules s env defs -> CRules s defs build RNil = CNil - build (RCons _ body rest) = CCons (compileE tw table body) (build rest) + build (RCons _ body rest) = CCons (compileE tw resolve body) (build rest) +{-# INLINABLE compileListed #-} + +-- | A grammar over declared keys: the compiled rules are tabulated once, and +-- a reference is resolved by looking its key up in the table. +-- +-- The knot is safe for the same reason as the list's: looking a key up yields +-- the (lazy) compiled rule without running it, so compiling a rule body never +-- forces the rules it refers to. +-- +-- 'tabulate' is an argument rather than a 'Tabulate' constraint, and that is +-- a matter of performance, not of style. GHC specialises a function only on +-- dictionaries it knows, and at the call in 'compileGrammar' the key type is +-- still a variable: with the constraint, the @SPECIALIZE@ pragmas below never +-- reached this function, and a grammar over keys ran the whole parse through +-- the 'Stream' dictionary — on MiniPython, 37% slower and 48% more allocation +-- per character than the same grammar over an environment. With only +-- 'Stream' left to specialise on, the two compile to the same code. +compileKeyed :: forall s nt a. Stream s + => Int + -> (forall f. (forall b. nt b -> f b) -> Table nt f) + -> (forall b. nt b -> PExp s nt b) + -> PExp s nt a + -> Step s a +compileKeyed tw tab rules start = compileE tw resolve start + where + table :: Table nt (CStep s) + table = tab (\k -> CStep (compileE tw resolve (rules k))) + + resolve :: forall b. nt b -> Step s b + resolve k = unCStep (lookupTable table k) +{-# INLINABLE compileKeyed #-} + {-# INLINABLE compileGrammar #-} {-# INLINABLE compileE #-} -- Without these the whole parse runs through a 'Stream' dictionary, and the -- per-character path stops being allocation-free. Callers using another -- stream should mark their own monomorphic parser bindings INLINABLE. {-# SPECIALIZE compileGrammar - :: Int -> Grammar String env a -> Step String a #-} + :: Int -> Grammar String nt a -> Step String a #-} {-# SPECIALIZE compileGrammar - :: Int -> Grammar T.Text env a -> Step T.Text a #-} + :: Int -> Grammar T.Text nt a -> Step T.Text a #-} {-# SPECIALIZE compileGrammar - :: Int -> Grammar B.ByteString env a -> Step B.ByteString a #-} + :: Int -> Grammar B.ByteString nt a -> Step B.ByteString a #-} -- | Does this class avoid the two characters whose column advance is not -- simply @+1@? When it does, the column after a matched run is the column @@ -213,9 +260,9 @@ simpleCS :: CharSet -> Bool simpleCS cs = not (memberCS '\n' cs) && not (memberCS '\t' cs) -compileE :: forall s env a. - Stream s => Int -> CRules s env env -> PExp s env a -> Step s a -compileE tw table = comp +compileE :: forall s nt a. Stream s + => Int -> (forall b. nt b -> Step s b) -> PExp s nt a -> Step s a +compileE tw resolve = comp where -- Select the stream operations once per compiled grammar. Leaving them -- as class-method applications would repeat the dictionary lookup on @@ -228,7 +275,7 @@ !packS = packString :: String -> s !emptyS = packS [] - comp :: forall b. PExp s env b -> Step s b + comp :: forall b. PExp s nt b -> Step s b comp (Pure x) = \_ st -> (# | (# x, st #) #) @@ -245,14 +292,9 @@ comp (Span cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) False comp (Span1 cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) True - -- 'a' comes from the constructor's own equality - -- @Lookup n env ~ 'EnvEntry a@, so no type family has to be reduced - -- here at all. - comp (NT @n _) = clookup (member @n @env) table - - -- The witness came with the reference, so there is no search at all: - -- neither here nor, more to the point, in the type checker. - comp (NTW _ w) = clookup w table + -- The key has already been resolved to its compiled rule by whoever + -- built @resolve@; this is one lookup per occurrence, at compile time. + comp (NT k) = resolve k -- Neither this nor 'Map' below allocates: the intermediate results travel -- in registers, so a quasi-quoted rule of @n@ items costs @n@ calls and diff --git a/src/PEG/QQ.hs b/src/PEG/QQ.hs --- a/src/PEG/QQ.hs +++ b/src/PEG/QQ.hs @@ -31,8 +31,10 @@ , pegGrammar ) where -import Control.Monad (foldM) -import Data.List (elemIndex, nub) +import Control.Monad (foldM, unless) +import Data.Data (Data, gmapQ) +import Data.Typeable (cast) +import Data.List (elemIndex, groupBy, nub) import Language.Haskell.TH (Exp (..), Pat (..), Q) import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote (QuasiQuoter (..)) @@ -40,6 +42,7 @@ import PEG import PEG.Analysis (Diagnostic (..), World (..), analyse, analyseWith, renderDiagnostic, spannable) +import PEG.QQ.Compat (requiredKindedTV, requiredTV) import PEG.QQ.HsExp (parseHsExp, parseHsType) import PEG.QQ.Syntax (Def (..), Directive (..), Item (..), PExpr (..), RelS (..), parseDirectives, parseExpr, parseGrammar, @@ -110,14 +113,16 @@ go (EAlign e) = do e' <- go e [| Align $(pure e') |] - go (EChoice es) = case es of - [] -> fail "QQ: empty choice (should be impossible)" - (e:rest) -> do - e' <- go e - rest' <- mapM go rest - foldM (\acc x -> [| $(pure acc) .||. $(pure x) |]) e' rest' - go (ESeq items act) = translateSeqWith ntRef items act + go (EChoice es) = do + alts <- mapM toAlt es + translateAlts ntRef alts + go (ESeq items act) = do + body <- seqBody items act + translateAlt ntRef (Alt items [] body) + toAlt (ESeq items act) = Alt items [] <$> seqBody items act + toAlt e = pure (Opaque e) + -- | Emit @nt \@"name"@: the environment is searched by the type checker. ntByName :: String -> Q Exp ntByName name = pure (TH.AppTypeE (TH.VarE 'nt) (TH.LitT (TH.StrTyLit name))) @@ -130,29 +135,120 @@ translateRel (ROffset n) = [| offsetR n |] translateRel (RNamed nm) = pure (TH.VarE (TH.mkName nm)) -translateSeqWith :: (String -> Q Exp) -> [Item] -> Maybe String -> Q Exp -translateSeqWith ntRef items act = do +-- | One alternative of an ordered choice, on its way to being translated. +-- +-- An 'Alt' is the part of a sequence still to be parsed, together with the +-- patterns for values an enclosing factoring has already parsed on its +-- behalf, and the semantic action over all of them. It translates to an +-- expression returning a function of those earlier values: @\rest... -> +-- \outer... -> body@. An alternative that is not a sequence is 'Opaque' and +-- never shares a prefix with anything. +data Alt + = Alt [Item] [Pat] Exp + | Opaque PExpr + +-- | Translate an ordered choice, factoring out prefixes that consecutive +-- alternatives share. +-- +-- == Why +-- +-- A PEG does not memoise, so in +-- +-- @ +-- expr <- e:or_expr ws "if" c:or_expr ws "else" a:expr { ... } +-- / e:or_expr { e } +-- @ +-- +-- a plain expression is parsed twice: once by the alternative that fails +-- at @"if"@ and once by the one that succeeds. Each precedence level written +-- this way doubles the work, and levels nest — through parentheses, call +-- arguments, list elements — so the cost is exponential in how deeply the +-- /input/ nests. On the MiniPython grammar @print(str(mdc(f(g(x)))))@ took +-- a third of a second, eight times as long per level. +-- +-- == What it does +-- +-- In a PEG, @A B \/ A C@ and @A (B \/ C)@ accept the same inputs with the +-- same results: @A@ is deterministic, so the second alternative would parse +-- exactly what the first one did before it failed. Consecutive alternatives +-- whose leading items are the same expression — labels aside — are +-- translated as their longest common prefix followed by a choice of what is +-- left of each, which is factored again. Only /consecutive/ alternatives +-- are grouped: in @A B \/ X \/ A C@ the @X@ must still be tried between them. +-- +-- Each remainder returns a function of the prefix's values, so that its +-- action still sees the prefix under the labels it gave it. +translateAlts :: (String -> Q Exp) -> [Alt] -> Q Exp +translateAlts ntRef alts = do + es <- mapM (translateGroup ntRef) (groupBy sameHead alts) + case es of + [] -> fail "QQ: empty choice (should be impossible)" + (e:rest) -> foldM (\acc x -> [| $(pure acc) .||. $(pure x) |]) e rest + where + sameHead (Alt (Item _ a : _) _ _) (Alt (Item _ b : _) _ _) = a == b + sameHead _ _ = False + +translateGroup :: (String -> Q Exp) -> [Alt] -> Q Exp +translateGroup ntRef [alt] = translateAlt ntRef alt +translateGroup ntRef grp = do + let itemss = [ is | Alt is _ _ <- grp ] + k = commonPrefix itemss + prefix = [ e | Item _ e <- take k (headItems itemss) ] + xs <- mapM (\i -> TH.newName ("p" ++ show i)) [1 .. k] + kf <- TH.newName "rest" + let apply = LamE (map VarP xs ++ [VarP kf]) + (foldl AppE (VarE kf) (map VarE xs)) + remainders = [ Alt (drop k is) (map itemPat (take k is) ++ outer) body + | Alt is outer body <- grp ] + pes <- mapM (translateExprWith ntRef) prefix + rest <- translateAlts ntRef remainders + case pes of + [] -> fail "QQ: factoring an empty prefix (should be impossible)" + (p:ps) -> do + hd <- [| fmapP $(pure apply) $(pure p) |] + foldM (\acc x -> [| $(pure acc) <*>. $(pure x) |]) hd (ps ++ [rest]) + where + headItems (is:_) = is + headItems [] = [] + + commonPrefix [] = 0 + commonPrefix (i:iss) = foldr (min . agree i) (length i) iss + agree as bs = length (takeWhile id (zipWith sameItem as bs)) + sameItem (Item _ a) (Item _ b) = a == b + +-- | Translate one alternative that nothing is factored out of. +translateAlt :: (String -> Q Exp) -> Alt -> Q Exp +translateAlt ntRef (Opaque e) = translateExprWith ntRef e +translateAlt ntRef (Alt items outer body) = do + es <- mapM (\(Item _ e) -> translateExprWith ntRef e) items + case es of + [] -> [| pureP $(pure (lambda outer body)) |] + (e:rest) -> do + hd <- [| fmapP $(pure (LamE (map itemPat items ++ outer) body)) $(pure e) |] + foldM (\acc x -> [| $(pure acc) <*>. $(pure x) |]) hd rest + where + lambda [] b = b + lambda ps b = LamE ps b + +itemPat :: Item -> Pat +itemPat (Item (Just l) _) = VarP (TH.mkName l) +itemPat (Item Nothing _) = WildP + +-- | The value a sequence returns: its semantic action, or its labelled items +-- when it has none — one of them bare, several as a tuple, none as @()@. +seqBody :: [Item] -> Maybe String -> Q Exp +seqBody items act = do let labels = [ l | Item (Just l) _ <- items ] case duplicates labels of (l:_) -> fail ("QQ: the label " ++ show l ++ " is used twice in the same sequence") [] -> pure () - body <- case act of + case act of Nothing -> pure (defaultBody labels) Just src -> case parseHsExp src of Right e -> pure e Left err -> fail ("QQ: in the semantic action {" ++ src ++ "}: " ++ err) - es <- mapM (\(Item _ e) -> translateExprWith ntRef e) items - case es of - [] -> [| pureP $(pure body) |] - (e:rest) -> do - let pats = zipWith itemPat [1 :: Int ..] items - hd <- [| fmapP $(pure (LamE pats body)) $(pure e) |] - foldM (\acc x -> [| $(pure acc) <*>. $(pure x) |]) hd rest where - itemPat i (Item ml _) = - VarP (TH.mkName (maybe ('_' : show i) id ml)) - defaultBody [] = TH.ConE '() defaultBody [l] = TH.VarE (TH.mkName l) defaultBody ls = TH.TupE (map (Just . TH.VarE . TH.mkName) ls) @@ -235,31 +331,14 @@ -- | Quasi-quoter for a complete grammar. -- -- Unlike 'pegRules', which is one part of a rule set and can be combined with --- another, this owns the whole grammar. Two things follow from that. --- --- It knows every rule's position in the environment, so it emits --- 'PEG.Syntax.ntw' and the membership proof rather than @nt@ and a --- 'PEG.Member.KnownMember' search. That is worth about 2.6x on the compile --- time of a 64-rule grammar; see @bench-compile/@. --- --- And it knows the whole grammar is in front of it, so a reference to a name --- no rule defines is an error at the splice rather than a type error later. --- --- == In expression position --- --- @ --- arith :: Stream s => Grammar s ArithEnv _ Exp --- arith = [pegGrammar| --- %start expr --- expr \<- t:term ts:(o:[+-] u:term)* { foldl addOp t ts } --- term \<- ... --- |] --- @ +-- another, this owns the whole grammar, so a reference to a name no rule +-- defines is an error at the splice rather than a type error later, and left +-- recursion is looked for across every rule. -- -- == In declaration position -- --- Give each rule its result type and the environment need not be written at --- all — the quasi-quoter declares it, along with the grammar and its +-- Give each rule its result type and nothing else need be written — the +-- quasi-quoter declares the grammar's key type, the grammar, and its -- signature: -- -- @ @@ -271,24 +350,61 @@ -- |] -- @ -- --- declares @type ArithEnv s@, @arith :: Stream s => Grammar s (ArithEnv s) Exp@ --- and @arith@ itself. An entry of the environment is a rule's name and the --- type it returns; the type is the one thing the grammar does not determine, --- which is what the annotations are for. +-- declares -- +-- @ +-- data ArithEnv s a where +-- ArithEnv_expr :: ArithEnv s Exp +-- ArithEnv_term :: ArithEnv s Exp +-- instance 'Tabulate' (ArithEnv s) +-- +-- arith'expr :: Stream s => PExp s (ArithEnv s) Exp +-- arith'term :: Stream s => PExp s (ArithEnv s) Exp +-- +-- arith :: Stream s => Grammar s (ArithEnv s) Exp +-- @ +-- +-- A reference to @term@ is @'NT' ArithEnv_term@, whose type is checked +-- without looking at the rest of the grammar, so the cost of type-checking a +-- grammar grows with its size and no faster. Each rule is a binding of its +-- own with the declared type as its signature, so an annotation that +-- disagrees with the rule's body is reported against that rule. The module +-- needs @GADTs@, since the key type is one. +-- +-- == In expression position +-- +-- @ +-- arith :: Grammar String _ Exp +-- arith = [pegGrammar| +-- %start expr +-- expr \<- t:term ts:(o:[+-] u:term)* { foldl addOp t ts } +-- term \<- ... +-- |] +-- @ +-- +-- An expression cannot declare a type, so there is no key type to generate: +-- the grammar is built over a type-level environment, as 'pegRules' builds +-- it, with each reference carrying its membership proof. That is fine for a +-- grammar of a few dozen rules and increasingly expensive past that; see +-- "PEG.Key". Prefer declaration position, with @%param@ for what the +-- expression form would have captured from its surroundings. +-- -- == Directives -- -- [@%start@] Required. The start expression: a non-terminal's name, or any -- PEG expression over the grammar's rules. -- [@%name@] Required in declaration position: the name to bind the grammar -- to. --- [@%env@] The name of the generated environment synonym. Defaults to the --- grammar's name, capitalised, with @Env@ appended. +-- [@%env@] The name of the generated key type. Defaults to the grammar's +-- name, capitalised, with @Env@ appended. -- [@%stream@] The stream type. Defaults to a variable @s@ with a -- 'PEG.Stream.Stream' constraint. -- [@%result@] The grammar's result type, for the rare start expression whose -- type cannot be read off the rules — one with a semantic action -- of its own. +-- [@%param@] @%param name :: Type@, in declaration position: the grammar and +-- every rule take an argument @name@, in scope in every semantic +-- action. May be repeated; the arguments are taken in order. pegGrammar :: QuasiQuoter pegGrammar = QuasiQuoter { quoteExp = pegGrammarExp @@ -370,13 +486,16 @@ normaliseStart e = e knownDirectives :: [String] -knownDirectives = ["start", "name", "env", "stream", "result"] +knownDirectives = ["start", "name", "env", "stream", "result", "param"] directive :: String -> [Directive] -> Maybe String -directive k ds = case [ v | Directive k' v <- ds, k' == k ] of +directive k ds = case directives k ds of (v:_) -> Just v [] -> Nothing +directives :: String -> [Directive] -> [String] +directives k ds = [ v | Directive k' v <- ds, k' == k ] + -- | Emit @ntw \@"name" (There (... Here))@: the proof instead of the search. ntByWitness :: [String] -> String -> Q Exp ntByWitness names name = case elemIndex name names of @@ -391,6 +510,9 @@ pegGrammarExp :: String -> Q Exp pegGrammarExp src = do gs <- parseGrammarSrc src + unless (null (directives "param" (gsDirs gs))) $ + fail "pegGrammar: %param is only meaningful in declaration position;\n\ + \ an expression can use the variables in scope around it" let ntRef = ntByWitness (gsNames gs) rules <- translateRules ntRef (gsDefs gs) start <- translateExprWith ntRef (gsStart gs) @@ -399,47 +521,179 @@ pegGrammarDec :: String -> Q [TH.Dec] pegGrammarDec src = do gs <- parseGrammarSrc src - gname <- case directive "name" (gsDirs gs) of - Just v -> pure (TH.mkName v) + gadts <- TH.isExtEnabled TH.GADTs + unless gadts $ + fail "pegGrammar: declaring a grammar declares a GADT, its key type;\n\ + \ enable {-# LANGUAGE GADTs #-} in this module" + baseName <- case directive "name" (gsDirs gs) of + Just v -> pure v Nothing -> fail "pegGrammar: no %name directive, which declaring a \ \grammar needs" - let baseName = maybe "" id (directive "name" (gsDirs gs)) - envName = TH.mkName (maybe (capitalise baseName ++ "Env") id - (directive "env" (gsDirs gs))) + let gname = TH.mkName baseName + envStr = maybe (capitalise baseName ++ "Env") id + (directive "env" (gsDirs gs)) + envName = TH.mkName envStr streamV = TH.mkName "s" + polyStream = directive "stream" (gsDirs gs) == Nothing streamT <- case directive "stream" (gsDirs gs) of Nothing -> pure (TH.VarT streamV) Just t -> either (\e -> fail ("pegGrammar: in %stream: " ++ e)) pure (parseHsType t) - anns <- mapM (resultAnnotation gname) (gsDefs gs) - let envRhs = promotedList [ envEntry n ty | (n, ty) <- anns ] + params <- mapM parseParam (directives "param" (gsDirs gs)) + anns0 <- mapM (resultAnnotation gname) (gsDefs gs) + -- A result type may mention the stream as @s@. In the key type @s@ is the + -- type's own parameter, so it can stay; in a signature of a grammar over a + -- fixed stream it has to become that stream. + let atStream = if polyStream then id else substVar streamV streamT + anns = [ (n, atStream t) | (n, t) <- anns0 ] startRes <- case directive "result" (gsDirs gs) of - Just t -> either (\e -> fail ("pegGrammar: in %result: " ++ e)) pure - (parseHsType t) + Just t -> either (\e -> fail ("pegGrammar: in %result: " ++ e)) + (pure . atStream) (parseHsType t) Nothing -> case resultTypeOf streamT anns (gsStart gs) of Just t -> pure t Nothing -> fail "pegGrammar: cannot tell what the start expression \ \returns.\n It has a semantic action of its own; state \ \its type with %result." - let envApplied = TH.AppT (TH.ConT envName) streamT - grammarTy = foldl TH.AppT (TH.ConT ''Grammar) - [streamT, envApplied, startRes] - sigTy = case directive "stream" (gsDirs gs) of - Just _ -> grammarTy - Nothing -> TH.ForallT [TH.PlainTV streamV TH.SpecifiedSpec] - [TH.AppT (TH.ConT ''Stream) (TH.VarT streamV)] - grammarTy - body <- pegGrammarExp src - pure [ TH.TySynD envName [TH.PlainTV streamV TH.BndrReq] envRhs - , TH.SigD gname sigTy - , TH.FunD gname [TH.Clause [] (TH.NormalB body) []] - ] + let keyCon n = TH.mkName (envStr ++ "_" ++ n) + ruleVar n = TH.mkName (baseName ++ "'" ++ n) + ntT = TH.AppT (TH.ConT envName) streamT + ntRef n = pure (TH.AppE (TH.ConE 'NT) (TH.ConE (keyCon n))) + -- A rule that does not use a parameter binds it to @_@, so that a + -- grammar with a parameter only some actions need compiles cleanly + -- under @-Wunused-matches@. + usedPats body = [ if mentions p body then TH.VarP p else TH.WildP + | (p, _) <- params ] + paramArgs = [ TH.VarE p | (p, _) <- params ] + -- @forall s. Stream s => P1 -> ... -> t@, or @P1 -> ... -> t@ over a + -- fixed stream. + signature t = + let body = foldr (\(_, pt) r -> TH.AppT (TH.AppT TH.ArrowT pt) r) + t params + in if polyStream + then TH.ForallT [TH.PlainTV streamV TH.SpecifiedSpec] + [TH.AppT (TH.ConT ''Stream) (TH.VarT streamV)] + body + else body + names = gsNames gs + + -- The key type: one constructor per rule, indexed by the rule's result. + resV <- TH.newName "a" + let keyDecl = TH.DataD [] envName + [ requiredTV streamV + , requiredKindedTV resV TH.StarT ] + Nothing + [ TH.GadtC [keyCon n] [] + (TH.AppT (TH.AppT (TH.ConT envName) (TH.VarT streamV)) ty) + | (n, ty) <- anns0 ] + [] + + -- Its 'Tabulate' instance. Every rule's image is bound once, outside the + -- lookup, which is what makes the table a memo table. + fV <- TH.newName "f" + kV <- TH.newName "k" + xs <- mapM (\n -> TH.newName ("x_" ++ n)) names + let onKey arms = TH.LamE [TH.VarP kV] (caseOrAbsurd (TH.VarE kV) arms) + caseOrAbsurd scrut [] = + -- A grammar with no rules has an uninhabited key type. + TH.AppE (TH.AppE (TH.VarE 'seq) scrut) + (TH.AppE (TH.VarE 'error) + (TH.LitE (TH.StringL "PEG: no rules"))) + caseOrAbsurd scrut arms = TH.CaseE scrut arms + arm n e = TH.Match (TH.ConP (keyCon n) [] []) (TH.NormalB e) [] + tabulateD = TH.FunD 'tabulate + [ TH.Clause [TH.VarP fV] + (TH.NormalB + (letOrBody + [ TH.ValD (TH.VarP x) + (TH.NormalB (TH.AppE (TH.VarE fV) + (TH.ConE (keyCon n)))) + [] + | (n, x) <- zip names xs ] + (TH.AppE (TH.ConE 'Table) + (onKey [ arm n (TH.VarE x) + | (n, x) <- zip names xs ])))) + [] ] + letOrBody [] e = e + letOrBody ds e = TH.LetE ds e + ruleNameD = TH.FunD 'ruleName + [ TH.Clause [TH.VarP kV] + (TH.NormalB (caseOrAbsurd (TH.VarE kV) + [ arm n (TH.LitE (TH.StringL n)) | n <- names ])) + [] ] + instDecl = TH.InstanceD Nothing [] + (TH.AppT (TH.ConT ''Tabulate) + (TH.AppT (TH.ConT envName) (TH.VarT streamV))) + [tabulateD, ruleNameD] + + -- One binding per rule, with the declared type as its signature. + ruleDecls <- fmap concat $ mapM + (\(Def n _ e, (_, ty)) -> do + body <- translateExprWith ntRef e + pure [ TH.SigD (ruleVar n) + (signature (foldl TH.AppT (TH.ConT ''PExp) [streamT, ntT, ty])) + , TH.FunD (ruleVar n) + [TH.Clause (usedPats body) (TH.NormalB body) []] + ]) + (zip (gsDefs gs) anns) + + -- The grammar: the rules as a function of their keys, and the start. + start <- translateExprWith ntRef (gsStart gs) + let rulesE = onKey [ arm n (foldl TH.AppE (TH.VarE (ruleVar n)) paramArgs) + | n <- names ] + grammarTy = foldl TH.AppT (TH.ConT ''Grammar) [streamT, ntT, startRes] + pure $ [ keyDecl, instDecl ] ++ ruleDecls ++ + [ TH.SigD gname (signature grammarTy) + , TH.FunD gname + [ TH.Clause (usedPats (TH.AppE rulesE start)) + (TH.NormalB (TH.AppE (TH.AppE (TH.ConE 'Keyed) rulesE) start)) [] ] + ] where capitalise [] = [] capitalise (c:cs) = toUpper c : cs toUpper c = if c >= 'a' && c <= 'z' then toEnum (fromEnum c - 32) else c --- | A rule's declared result type, which declaring an environment needs. +-- | @%param name :: Type@. +parseParam :: String -> Q (TH.Name, TH.Type) +parseParam src = case breakOnSig src of + Just (nm, ty) + | validName nm -> either (\e -> fail ("pegGrammar: in %param " ++ nm + ++ ": " ++ e)) + (\t -> pure (TH.mkName nm, t)) + (parseHsType ty) + _ -> fail ("pegGrammar: expected %param name :: Type, found %param " ++ src) + where + breakOnSig = go [] + where + go acc (':':':':rest) = Just (trim (reverse acc), rest) + go acc (c:cs) = go (c:acc) cs + go _ [] = Nothing + trim = reverse . dropWhile (== ' ') . reverse . dropWhile (== ' ') + validName (c:cs) = (c == '_' || (c >= 'a' && c <= 'z')) + && all (\x -> x == '_' || x == '\'' || (x >= 'a' && x <= 'z') + || (x >= 'A' && x <= 'Z') + || (x >= '0' && x <= '9')) cs + validName [] = False + +-- | Does the name occur anywhere in the expression? Conservative: a +-- binding of the same name inside counts as an occurrence. +mentions :: Data a => TH.Name -> a -> Bool +mentions n x = case cast x of + Just n' -> n' == n + Nothing -> or (gmapQ (mentions n) x) + +-- | Replace a type variable. +substVar :: TH.Name -> TH.Type -> TH.Type -> TH.Type +substVar v new = go + where + go (TH.VarT n) | n == v = new + go (TH.AppT a b) = TH.AppT (go a) (go b) + go (TH.AppKindT t k) = TH.AppKindT (go t) k + go (TH.SigT t k) = TH.SigT (go t) k + go (TH.InfixT a n b) = TH.InfixT (go a) n (go b) + go (TH.ParensT t) = TH.ParensT (go t) + go t = t + +-- | A rule's declared result type, which declaring the key type needs. resultAnnotation :: TH.Name -> Def -> Q (String, TH.Type) resultAnnotation gname (Def n ann _) = case ann of Nothing -> fail ("pegGrammar: the rule " ++ n ++ " has no result type.\n\ @@ -453,7 +707,7 @@ -- | What the start expression returns, read off the rules' declared types. -- --- This follows @translateSeqWith@: a sequence with no semantic action returns +-- This follows @seqBody@: a sequence with no semantic action returns -- its labelled items, one of them bare and several as a tuple. A sequence -- /with/ an action returns whatever the action does, which is Haskell and so -- not knowable here — hence the 'Maybe', and the @%result@ directive. @@ -486,16 +740,3 @@ firstJust xs = case [ x | Just x <- xs ] of (x:_) -> Just x [] -> Nothing - --------------------------------------------------------------------------------- --- Building the environment's type --------------------------------------------------------------------------------- - -promotedList :: [TH.Type] -> TH.Type -promotedList = foldr (\x acc -> TH.AppT (TH.AppT TH.PromotedConsT x) acc) - TH.PromotedNilT - -envEntry :: String -> TH.Type -> TH.Type -envEntry n res = - TH.AppT (TH.AppT (TH.PromotedTupleT 2) (TH.LitT (TH.StrTyLit n))) - (TH.AppT (TH.PromotedT 'EnvEntry) res) diff --git a/src/PEG/QQ/Compat.hs b/src/PEG/QQ/Compat.hs new file mode 100644 --- /dev/null +++ b/src/PEG/QQ/Compat.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +-- | What differs between the versions of template-haskell the quasi-quoters +-- build against. Kept apart from "PEG.QQ" because CPP does not understand +-- Haskell's string gaps, which that module's error messages use. +module PEG.QQ.Compat + ( requiredTV + , requiredKindedTV + ) where + +import qualified Language.Haskell.TH as TH + +-- | The binders of a data declaration. template-haskell 2.21 (GHC 9.8) gave +-- them a visibility flag; before it they carry @()@. +#if MIN_VERSION_template_haskell(2,21,0) +requiredTV :: TH.Name -> TH.TyVarBndr TH.BndrVis +requiredTV n = TH.PlainTV n TH.BndrReq + +requiredKindedTV :: TH.Name -> TH.Kind -> TH.TyVarBndr TH.BndrVis +requiredKindedTV n k = TH.KindedTV n TH.BndrReq k +#else +requiredTV :: TH.Name -> TH.TyVarBndr () +requiredTV n = TH.PlainTV n () + +requiredKindedTV :: TH.Name -> TH.Kind -> TH.TyVarBndr () +requiredKindedTV n k = TH.KindedTV n () k +#endif diff --git a/src/PEG/QQ/Syntax.hs b/src/PEG/QQ/Syntax.hs --- a/src/PEG/QQ/Syntax.hs +++ b/src/PEG/QQ/Syntax.hs @@ -34,7 +34,7 @@ deriving Show data Item = Item (Maybe String) PExpr - deriving Show + deriving (Eq, Show) data PExpr = EChoice [PExpr] @@ -52,7 +52,7 @@ | EIndent RelS PExpr | EPos RelS PExpr | EAlign PExpr - deriving Show + deriving (Eq, Show) data RelS = RGt @@ -61,7 +61,7 @@ | RAny | ROffset Int | RNamed String - deriving Show + deriving (Eq, Show) type P a = String -> Either String (a, String) diff --git a/src/PEG/Syntax.hs b/src/PEG/Syntax.hs --- a/src/PEG/Syntax.hs +++ b/src/PEG/Syntax.hs @@ -11,11 +11,12 @@ -- | The PEG expression GADT and combinator API. -- --- 'PExp' is the core type: a GADT indexed by the input stream, the grammar --- environment, and the Haskell result type. Every non-terminal reference is --- checked against the environment, so @nt \@\"expr\"@ is a type error unless --- the grammar has a rule called @expr@, and it has whatever type that rule --- has. +-- 'PExp' is the core type: a GADT indexed by the input stream, the type of +-- the grammar's non-terminal keys (see "PEG.Key"), and the Haskell result +-- type. A non-terminal reference is a key, so it can only name a rule that +-- exists and only at the type that rule has: @NT ArithEnv_expr@ for a +-- generated grammar, @nt \@\"expr\"@ for one whose environment is a +-- type-level list. -- -- The first parameter, @s@, is the stream the expression consumes; see -- "PEG.Stream". It appears in the type because a character class produces a @@ -47,8 +48,9 @@ -- lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a -- @ -- --- is now @PExp s env a -> PExp s env a@, and composes without the caller --- having to get a nesting of type families right. +-- is now @PExp s nt a -> PExp s nt a@, and composes without the caller +-- having to get a nesting of type families right. It works unchanged over +-- both kinds of key. module PEG.Syntax ( Name (..) , PExp (..) @@ -75,11 +77,12 @@ ) where import Data.Kind (Type) -import GHC.TypeLits (Symbol, KnownSymbol) +import GHC.TypeLits (Symbol) import PEG.CharSet (CharSet) import qualified PEG.CharSet as CS import PEG.Indent (Rel) +import PEG.Key import PEG.Type import PEG.TyLevel import PEG.Member @@ -98,7 +101,7 @@ -- * 'Span' — match a run of characters of a 'CharSet', possibly empty -- * 'Span1' — match a non-empty run of characters of a 'CharSet' -- * 'AnyChar'— match any character --- * 'NT' — invoke a named non-terminal +-- * 'NT' — invoke a non-terminal, named by its key -- * 'Seq' — sequential composition (@e1 e2@) -- * 'Choice' — ordered choice (@e1 \/ e2@) -- * 'Star' — Kleene star (@e*@) @@ -107,159 +110,136 @@ -- * 'Indent' — require the next token to satisfy an indentation relation -- * 'Position'— set the column relation for tokens inside the sub-expression -- * 'Align' — require the next token to be aligned with the current position -data PExp (s :: Type) (env :: Env) (a :: Type) where - Pure :: a -> PExp s env a - Term :: Char -> PExp s env Char +data PExp (s :: Type) (nt :: Type -> Type) (a :: Type) where + Pure :: a -> PExp s nt a + Term :: Char -> PExp s nt Char -- | Match one character of a class. This is what a character class such as -- @[a-zA-Z0-9_]@ compiles to: a single bit test instead of a chain of -- ordered choices. - Sat :: !CharSet -> PExp s env Char + Sat :: !CharSet -> PExp s nt Char -- | Match a string literal. The string must be non-empty; use 'pureP' @""@ -- otherwise. -- -- The result is the literal itself, so it is shared rather than sliced out -- of the input. - Str :: String -> PExp s env String + Str :: String -> PExp s nt String -- | Match the longest run of characters belonging to a class, possibly -- empty — what @[a-z]*@ compiles to. The result is a chunk of the input -- stream, so on 'Data.Text.Text' this is a slice and costs no copy. - Span :: !CharSet -> PExp s env s + Span :: !CharSet -> PExp s nt s -- | As 'Span', but the run must be non-empty: @[a-z]+@. - Span1 :: !CharSet -> PExp s env s - AnyChar :: PExp s env Char - -- The environment is looked up /once/, by the equality below, and the - -- result is bound to the rigid variable @a@. Passing @ResOf (Lookup n - -- env)@ straight to 'KnownMember' instead makes GHC re-reduce the lookup at - -- every step of the instance chain that walks @env@, which costs - -- @O(|env|^2)@ per non-terminal occurrence. - NT :: forall n s env a. - ( KnownSymbol n - , Lookup n env ~ 'EnvEntry a - , KnownMember n env a - ) - => Name n - -> PExp s env a - -- | As 'NT', but the proof that the rule is in the environment is supplied - -- rather than searched for. - -- - -- The @Lookup@ equality is kept, so this is not a weaker claim than 'NT': - -- @a@ still comes from the environment, and a witness that points at a - -- different rule does not type-check. What is gone is the 'KnownMember' - -- instance chain, which walks the environment one entry at a time for every - -- occurrence of every non-terminal. On a 64-rule grammar that chain is - -- about three quarters of what resolving a reference costs; see - -- @bench-compile/@. - -- - -- A splice knows each rule's position and so can write the witness down. - -- Hand-written grammars have nothing to gain here and should keep using - -- 'nt'. - NTW :: forall n s env a. - ( KnownSymbol n - , Lookup n env ~ 'EnvEntry a - ) - => Name n - -> Member n env a - -> PExp s env a - Seq :: PExp s env (a -> b) - -> PExp s env a - -> PExp s env b - Choice :: PExp s env a - -> PExp s env a - -> PExp s env a + Span1 :: !CharSet -> PExp s nt s + AnyChar :: PExp s nt Char + -- | A reference to the rule the key names. Its result type is the key's + -- index, so nothing about the rest of the grammar is consulted. + NT :: nt a -> PExp s nt a + Seq :: PExp s nt (a -> b) + -> PExp s nt a + -> PExp s nt b + Choice :: PExp s nt a + -> PExp s nt a + -> PExp s nt a -- | Kleene star. The argument must not match the empty string, or the -- parser will not terminate; that is checked by "PEG.Analysis" when the -- grammar is spliced, and not at all when a 'Star' is built by hand. - Star :: PExp s env a - -> PExp s env [a] - Not :: PExp s env a - -> PExp s env () + Star :: PExp s nt a + -> PExp s nt [a] + Not :: PExp s nt a + -> PExp s nt () Map :: (a -> b) - -> PExp s env a - -> PExp s env b + -> PExp s nt a + -> PExp s nt b Indent :: Rel n - -> PExp s env a - -> PExp s env a + -> PExp s nt a + -> PExp s nt a Position :: Rel n - -> PExp s env a - -> PExp s env a - Align :: PExp s env a - -> PExp s env a + -> PExp s nt a + -> PExp s nt a + Align :: PExp s nt a + -> PExp s nt a -instance Functor (PExp s env) where +instance Functor (PExp s nt) where fmap = Map --- | Reference a non-terminal by name using a type application: --- @nt \@\"ruleName\"@. +-- | Reference a rule of a type-level environment by name, using a type +-- application: @nt \@\"ruleName\"@. -- -- The name is deliberately the /first/ quantified variable, so that -- @nt \@\"expr\"@ keeps working: the stream and environment are recovered by -- unification. +-- +-- The environment is searched by the 'KnownMember' instance chain, once for +-- every occurrence, which is what makes a large environment slow to compile. +-- A grammar written with 'PEG.QQ.pegGrammar' in declaration position has +-- declared keys instead, and does not search anything. nt :: forall n env s a. - ( KnownSymbol n - , Lookup n env ~ 'EnvEntry a + ( Lookup n env ~ 'EnvEntry a , KnownMember n env a ) - => PExp s env a -nt = NT (Name :: Name n) + => PExp s (InEnv env) a +nt = NT (InEnv (member :: Member n env a)) --- | Reference a non-terminal by name, supplying the membership proof: --- @ntw \@"ruleName" (There Here)@. +-- | Reference a rule of a type-level environment by name, supplying the +-- membership proof: @ntw \@"ruleName" (There Here)@. -- --- This is what a generated grammar emits; see 'NTW'. +-- The @Lookup@ equality is kept, so this is not a weaker claim than 'nt': @a@ +-- still comes from the environment, and a witness that points at a different +-- rule does not type-check. What is gone is the 'KnownMember' search. The +-- proof itself still costs the type checker in proportion to its depth; see +-- "PEG.Key". ntw :: forall n env s a. - ( KnownSymbol n - , Lookup n env ~ 'EnvEntry a + ( Lookup n env ~ 'EnvEntry a ) => Member n env a - -> PExp s env a -ntw = NTW (Name :: Name n) + -> PExp s (InEnv env) a +ntw w = NT (InEnv w) -- | Succeed without consuming any input. -pureP :: a -> PExp s env a +pureP :: a -> PExp s nt a pureP = Pure -- | Apply a function to the result of an expression. -fmapP :: (a -> b) -> PExp s env a -> PExp s env b +fmapP :: (a -> b) -> PExp s nt a -> PExp s nt b fmapP = Map -- | Require the sub-expression to satisfy the given column relation. -indent :: Rel n -> PExp s env a -> PExp s env a +indent :: Rel n -> PExp s nt a -> PExp s nt a indent = Indent -- | Override the token mode for the sub-expression. -position :: Rel n -> PExp s env a -> PExp s env a +position :: Rel n -> PExp s nt a -> PExp s nt a position = Position -- | Require the sub-expression to start at the current alignment column. -align :: PExp s env a -> PExp s env a +align :: PExp s nt a -> PExp s nt a align = Align -- | Infix synonym for 'fmapP'. -(<$>.) :: (a -> b) -> PExp s env a -> PExp s env b +(<$>.) :: (a -> b) -> PExp s nt a -> PExp s nt b (<$>.) = Map infixl 4 <$>. -- | Infix sequential composition. -(<*>.) :: PExp s env (a -> b) - -> PExp s env a - -> PExp s env b +(<*>.) :: PExp s nt (a -> b) + -> PExp s nt a + -> PExp s nt b (<*>.) = Seq infixl 4 <*>. -- | Sequence two expressions, discarding the result of the first. -(.>>.) :: PExp s env a - -> PExp s env b - -> PExp s env b +(.>>.) :: PExp s nt a + -> PExp s nt b + -> PExp s nt b e1 .>>. e2 = Map (\_ b -> b) e1 <*>. e2 infixl 6 .>>. -- | Infix ordered choice (@e1 \/ e2@): try @e1@; if it fails, try @e2@. -(.||.) :: PExp s env a -> PExp s env a -> PExp s env a +(.||.) :: PExp s nt a -> PExp s nt a -> PExp s nt a (.||.) = Choice infixl 5 .||. -- | Optional match: @opt e = (Just \<$\>. e) .||. pureP Nothing@. -opt :: PExp s env a -> PExp s env (Maybe a) +opt :: PExp s nt a -> PExp s nt (Maybe a) opt e = (Just <$>. e) .||. pureP Nothing -- | One-or-more: @plus e = (:) \<$\>. e \<*\>. Star e@. @@ -268,40 +248,40 @@ -- -- For a single character class, prefer 'spanOf1': it matches the whole run in -- one scan and returns a chunk of the stream instead of a list. -plus :: PExp s env a -> PExp s env [a] +plus :: PExp s nt a -> PExp s nt [a] plus e = (:) <$>. e <*>. Star e -- | Match any character of the given set. -sat :: CharSet -> PExp s env Char +sat :: CharSet -> PExp s nt Char sat = Sat -- | Match any character inside one of the given inclusive ranges. -- This is the representation the quasi-quoter emits for @[a-z]@ and -- friends. -charClass :: [(Char, Char)] -> PExp s env Char +charClass :: [(Char, Char)] -> PExp s nt Char charClass = Sat . CS.fromRanges -- | Match any character /outside/ the given inclusive ranges. -- The quasi-quoter emits this for @[^\"]@. -notCharClass :: [(Char, Char)] -> PExp s env Char +notCharClass :: [(Char, Char)] -> PExp s nt Char notCharClass = Sat . CS.notInRanges -- | Match the longest run of characters of the set, possibly empty. The -- result is a chunk of the input stream. -spanOf :: CharSet -> PExp s env s +spanOf :: CharSet -> PExp s nt s spanOf = Span -- | Match a non-empty run of characters of the set. -spanOf1 :: CharSet -> PExp s env s +spanOf1 :: CharSet -> PExp s nt s spanOf1 = Span1 -- | Match any character in the given list. The list must be non-empty. -oneOf :: [Char] -> PExp s env Char +oneOf :: [Char] -> PExp s nt Char oneOf [] = error "PEG.Syntax.oneOf: empty character class" oneOf [c] = Term c oneOf cs = Sat (CS.fromList cs) -- | Match an exact string literal. The string must be non-empty. -stringNE :: String -> PExp s env String +stringNE :: String -> PExp s nt String stringNE [] = error "PEG.Syntax.stringNE: empty string" stringNE s = Str s diff --git a/tests/Analysis.hs b/tests/Analysis.hs --- a/tests/Analysis.hs +++ b/tests/Analysis.hs @@ -48,9 +48,12 @@ import Control.Monad (forM, unless) import Data.List (isPrefixOf, nub, sort, union) +import qualified Data.List as L import System.Exit (exitFailure) +import System.Timeout (timeout) +import Control.Exception (evaluate) -import Data.Proxy (Proxy (..)) +import Data.Functor.Const (Const (..)) import PEG import PEG.QQ (pegGrammar) @@ -64,6 +67,7 @@ , "examples/Layout.hs" , "examples/Patterns.hs" , "examples/Compat.hs" + , "examples/MiniPython.hs" ] main :: IO () @@ -77,8 +81,8 @@ unless (null failures) exitFailure -- The examples are half the point of this test; a refactor that stops -- finding them must fail rather than pass vacuously. - unless (checked + length failures >= 7) $ do - putStrLn "PEG.Analysis: expected at least 7 grammars in examples/, \ + unless (checked + length failures >= 8) $ do + putStrLn "PEG.Analysis: expected at least 8 grammars in examples/, \ \found fewer" exitFailure let generated = [ checkDefs ("generated/" ++ show i) g @@ -97,7 +101,9 @@ unless (recursive >= 20 && withHeads >= 20) $ do putStrLn "PEG.Analysis: the generated corpus has gone degenerate" exitFailure + nested <- nestingCheck let checks = standaloneChecks ++ [witnessCheck] ++ generatedChecks + ++ factoringChecks ++ [nested] mapM_ report checks unless (all (\(_, ok) -> ok) checks) exitFailure where @@ -169,7 +175,7 @@ go (EIndent _ e) = go e go (EPos _ e) = go e go (EAlign e) = go e - go (EChoice es) = foldl' union [] (map go es) + go (EChoice es) = L.foldl' union [] (map go es) go (ESeq its _) = seqHeads [ e | Item _ e <- its ] seqHeads [] = [] @@ -296,7 +302,7 @@ seeds = iterate (\x -> (x * 1103515245 + 12345) `mod` 2147483648) 1 grammarFrom :: Int -> [Def] -grammarFrom seed0 = snd (foldl' rule (seed0, []) [0 .. n - 1]) +grammarFrom seed0 = snd (L.foldl' rule (seed0, []) [0 .. n - 1]) where n = 2 + seed0 `mod` 4 names = [ "r" ++ show i | i <- [0 .. n - 1] ] @@ -398,10 +404,10 @@ , '("digits", 'EnvEntry Int) ] -digitsCount :: PExp String NtwEnv Int +digitsCount :: PExp String (InEnv NtwEnv) Int digitsCount = fmapP (length . chunkToString) (spanOf1 (fromRanges [('0', '9')])) -ntwGrammar :: Grammar String NtwEnv (Int, Int) +ntwGrammar :: Grammar String (InEnv NtwEnv) (Int, Int) ntwGrammar = Grammar (RCons (Name @"pair") @@ -423,32 +429,133 @@ digits :: Int <- ds:[0-9]+ { length (chunkToString ds) } |] --- The environment a reader would have written for that grammar. GHC has --- already agreed that the generated one is well-formed — it type-checked --- @tiny@ — so what this pins down is that it is also the /expected/ one: same --- rules, same order, same spelling. -type ExpectedTinyEnv s = - '[ '("pair" , 'EnvEntry (Int, Int)) - , '("digits", 'EnvEntry Int) - ] +-- The key type a reader would have written for that grammar: one constructor +-- per rule, named after the rule, at the rule's declared type. GHC checks +-- these signatures against the generated declarations, so what this pins down +-- is that the generated key type is also the /expected/ one — same rules, +-- same spelling, same types — and so are the per-rule bindings. +expectedKeys :: (TinyEnv String (Int, Int), TinyEnv String Int) +expectedKeys = (TinyEnv_pair, TinyEnv_digits) -sameEnv :: forall (a :: Env) (b :: Env). (a ~ b) => Proxy a -> Proxy b -> () -sameEnv _ _ = () +expectedBindings :: ( PExp String (TinyEnv String) (Int, Int) + , PExp String (TinyEnv String) Int ) +expectedBindings = (tiny'pair, tiny'digits) -generatedEnvIsExpected :: () -generatedEnvIsExpected = - sameEnv (Proxy :: Proxy (TinyEnv String)) - (Proxy :: Proxy (ExpectedTinyEnv String)) +-- A grammar over a fixed stream, with a parameter, whose result types mention +-- the stream as @s@: the one place a result type has to be rewritten, since +-- the stream is no longer a variable. +[pegGrammar| + %name scaled + %stream String + %param factor :: Int + %start num + num :: Int <- ds:digits { factor * length ds } + digits :: s <- ds:[0-9]+ +|] + generatedChecks :: [(String, Bool)] generatedChecks = - [ ("pegGrammar generates the expected environment", - generatedEnvIsExpected == ()) + [ ("pegGrammar generates the expected keys", + case expectedKeys of + (p, d) -> ruleName p == "pair" && ruleName d == "digits") + , ("pegGrammar generates the expected rule bindings", + case expectedBindings of (_, _) -> True) + , ("a generated key table agrees with the function it tabulates", + [ getConst (lookupTable table TinyEnv_pair) + , getConst (lookupTable table TinyEnv_digits) ] == ["pair", "digits"]) , ("a generated grammar parses", case parse tiny "12,345" of OK r _ rest -> r == (2, 3) && rest == "" Fail -> False) + , ("%param and %stream: a result type of s becomes the stream", + case parse (scaled 10) "123" of + OK r _ rest -> r == 30 && rest == "" + Fail -> False) ] + where + table :: Table (TinyEnv String) (Const String) + table = tabulate (\k -> Const (ruleName k)) + +-------------------------------------------------------------------------------- +-- Factoring shared prefixes out of an ordered choice +-------------------------------------------------------------------------------- + +-- The translation turns @A B / A C@ into @A (B / C)@. What can go wrong is +-- which alternative wins and what its action sees, so this grammar has: +-- +-- * a group of alternatives sharing one item, under a different label in +-- each, whose remainders share two more items and are factored again; +-- * an alternative that is all prefix, so that its remainder is empty; +-- * two alternatives with the same prefix that are /not/ consecutive, which +-- must not be grouped, since the one between them has to be tried first; +-- * two identical alternatives, of which the first must win; +-- * unlabelled prefixes and sequences with no action, whose value is their +-- labels. +[pegGrammar| + %name shared + %stream String + %start top + + top :: [String] <- ss:(s:stmt ';')* !. + + stmt :: String <- + 'x' "yz" { "xyz" } + / n:ident "+=" v:num { n ++ " add " ++ v } + / m:ident "-=" w:num { m ++ " sub " ++ w } + / p:ident ':' q:ident '=' r:num { p ++ ":" ++ q ++ " set " ++ r } + / p2:ident ':' q2:ident { p2 ++ ":" ++ q2 } + / k:ident '=' u:num { k ++ " set " ++ u } + / j:ident { "bare " ++ j } + / 'x' 'q' { "unreachable" } + / '#' t:tag { t } + / '@' { "first" } + / '@' { "second" } + + tag :: String <- '<' a:ident '>' / '<' b:num + + ident :: s <- cs:[a-z]+ + num :: s <- ds:[0-9]+ +|] + +factoringChecks :: [(String, Bool)] +factoringChecks = + [ ("factoring keeps which alternative wins and what its action sees", + parse shared "a+=1;b-=2;c:d=3;e:f;g=4;h;xyz;xq;#;#<5;@;" + `okWith` [ "a add 1", "b sub 2", "c:d set 3", "e:f", "g set 4" + , "bare h", "xyz", "bare xq", "i", "5", "first" ]) + , ("factoring keeps a failure a failure", + case parse shared "a+=;" of + Fail -> True + _ -> False) + ] + where + okWith (OK r _ rest) want = r == want && rest == "" + okWith Fail _ = False + +-- Every level of this grammar would parse its operand twice without +-- factoring — once by the alternative that fails at '+', once by the one +-- that succeeds — so forty nested parentheses would take 2^40 steps. With +-- it they take forty. The time limit turns a regression into a failure +-- instead of a hang. +[pegGrammar| + %name nest + %stream String + %start e + + e :: Int <- a:atom '+' b:e { a + b } / a:atom { a } + atom :: Int <- '(' x:e ')' { x } / ds:[0-9]+ { length ds } +|] + +nestingCheck :: IO (String, Bool) +nestingCheck = do + let depth = 40 :: Int + input = replicate depth '(' ++ "1+22" ++ replicate depth ')' + r <- timeout 5000000 (evaluate (case parse nest input of + OK n _ rest -> n == 3 && rest == "" + Fail -> False)) + pure ("a shared prefix is parsed once, not once per alternative", + r == Just True) witnessCheck :: (String, Bool) witnessCheck = diff --git a/typed-peg.cabal b/typed-peg.cabal --- a/typed-peg.cabal +++ b/typed-peg.cabal @@ -1,14 +1,15 @@ cabal-version: 3.0 name: typed-peg -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Type-safe PEG parser combinators description: A library for building Parsing Expression Grammars parsers - with compile-time safety guarantees. Non-terminal references are - checked at the type level against an environment binding each rule - to the type it returns; left recursion, a repetition that cannot - consume input, an undefined non-terminal and a duplicate rule are - reported when the grammar is spliced, naming the rule. + with compile-time safety guarantees. A non-terminal reference is a + key whose type is the result of the rule it names, so references are + checked by the type checker in time linear in the size of the grammar; + left recursion, a repetition that cannot consume input, an undefined + non-terminal and a duplicate rule are reported when the grammar is + spliced, naming the rule. . A quasi-quoter (@PEG.QQ@) allows writing grammars in a concrete DSL syntax. Indentation-sensitive parsing is supported natively @@ -31,7 +32,7 @@ extra-doc-files: CHANGELOG.md peg-patterns.md -tested-with: GHC == 9.10.3 +tested-with: GHC == 9.6.6 || == 9.10.3 source-repository head type: git @@ -65,6 +66,7 @@ PEG.CharSet PEG.Grammar PEG.Indent + PEG.Key PEG.Member PEG.Parse PEG.QQ @@ -75,9 +77,12 @@ PEG.Syntax PEG.TyLevel PEG.Type + other-modules: + PEG.QQ.Compat build-depends: base >= 4.18 && < 5 , bytestring >= 0.11 && < 0.13 + , containers >= 0.6 && < 0.8 , template-haskell >= 2.19 && < 2.24 , text >= 2.0 && < 2.2 @@ -86,7 +91,7 @@ type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Main.hs - other-modules: Arith, Layout, Compat, Patterns + other-modules: Arith, Layout, Compat, Patterns, MiniPython build-depends: base , bytestring