typed-peg 0.3.0.0 → 0.4.0.0

raw patch · 22 files changed

+1508/−373 lines, 22 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +125/−0
• README.md +70/−20
• bench/Bench/Peg.hs +6/−6
• examples/Arith.hs +9/−7
• examples/Compat.hs +3/−3
• examples/Layout.hs +2/−1
• examples/Main.hs +4/−0
• examples/MiniPython.hs +362/−0
• examples/Patterns.hs +4/−4
• peg-patterns.md +8/−2
• src/PEG.hs +9/−7
• src/PEG/Analysis.hs +122/−41
• src/PEG/Grammar.hs +33/−16
• src/PEG/Key.hs +81/−0
• src/PEG/Member.hs +4/−2
• src/PEG/Parse.hs +79/−37
• src/PEG/QQ.hs +330/−89
• src/PEG/QQ/Compat.hs +27/−0
• src/PEG/QQ/Syntax.hs +3/−3
• src/PEG/Syntax.hs +84/−104
• tests/Analysis.hs +130/−23
• typed-peg.cabal +13/−8

@@ -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

@@ -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

@@ -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|

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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")+      ]

@@ -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|

@@ -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") ``` 

@@ -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

@@ -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]

@@ -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

@@ -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

@@ -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 (..)

@@ -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

@@ -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)

@@ -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

@@ -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) 

@@ -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

@@ -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;#<i>;#<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 =

@@ -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