typed-peg 0.1.0.0 → 0.2.0.0

raw patch · 24 files changed

+3435/−261 lines, 24 filesdep +bytestringdep +criteriondep +deepseqdep ~basedep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, criterion, deepseq, megaparsec, text

Dependency ranges changed: base, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +224/−0
• README.md +132/−0
• bench/Bench/Inputs.hs +92/−0
• bench/Bench/Mega.hs +191/−0
• bench/Bench/Peg.hs +416/−0
• bench/Main.hs +165/−0
• examples/Arith.hs +9/−3
• examples/Compat.hs +164/−0
• examples/Layout.hs +9/−5
• examples/Main.hs +9/−1
• examples/Patterns.hs +253/−0
• peg-patterns.md +573/−0
• src/PEG.hs +5/−1
• src/PEG/CharSet.hs +105/−0
• src/PEG/Grammar.hs +30/−21
• src/PEG/Indent.hs +12/−0
• src/PEG/Member.hs +42/−24
• src/PEG/Parse.hs +398/−101
• src/PEG/QQ.hs +43/−9
• src/PEG/Semantics/Simple.hs +7/−5
• src/PEG/Stream.hs +263/−0
• src/PEG/Syntax.hs +162/−69
• src/PEG/TyLevel.hs +91/−14
• typed-peg.cabal +40/−8

@@ -1,5 +1,229 @@ # Changelog +## Unreleased — compile time of large grammars++Checking a grammar was **exponential in the size of its FIRST sets**.  On a+chain of `n` mutually referring rules, GHC needed 0.7 s at `n = 8`, 12 s at+`n = 12`, and more than five minutes at `n = 15`; anything the size of a real+language front end never finished.  The same grammars now check in+milliseconds-to-seconds and the curve is polynomial: `n = 12` takes 0.5 s,+`n = 30` 1.7 s, `n = 60` 14 s.++One limit is new rather than fixed: the union of two FIRST sets nests one+type-family reduction per element of the result, so a FIRST set of more than+about a hundred non-terminals now reports `Reduction stack overflow` instead+of being slow.  `-freduction-depth=0` lifts it, and a union of two 128-element+sets then takes about 0.3 s.++### Fixed++- **`Union` and `ConsIfAbsent` were exponential.**  `ConsIfAbsent x xs`+  expanded to `If (Elem x xs) xs (x ': xs)`, naming `xs` three times.  In+  `Union (x ': xs) ys = ConsIfAbsent x (Union xs ys)` that `xs` is an+  unreduced `Union`, so each step left GHC three copies of the pending+  computation to reduce and each of those tripled again: `3^n` reductions for+  a union of two `n`-element sets.  Both families now dispatch on an+  already-computed `Ordering` in a helper whose every right-hand side names+  each argument — and in particular the recursive call — exactly once.+- **`Lookup` threaded the whole environment through its recursion** so that+  the not-found case could list the available non-terminals.  An environment+  of `n` rules is `O(n^2)` type nodes, because every entry carries a FIRST+  set, and there is one lookup per occurrence of every non-terminal.  The+  search now carries only the tail it has still to scan; the environment is+  named once, in the branch that reports the error.+- **`Lookup` matched through `CmpSymbol` and a dispatch family**, two+  type-family reductions per entry scanned.  It now matches on a non-linear+  pattern — the name appears twice in the clause — so GHC decides each entry+  by syntactic equality and apartness, in one reduction.  The trick is+  `Data.Type.Map`'s, from `type-level-sets`.  Worth 1.4x-1.6x on a large+  grammar, since the search runs once per occurrence of every non-terminal.+- **`nt` and `PExp`'s `NT` made GHC search the environment several times per+  occurrence.**  Their constraint was+  `KnownMember n env (TyOf (Lookup n env)) (ResOf (Lookup n env))`, and+  resolving `KnownMember` walks `env` one instance at a time, re-normalising+  every index at each step.  Both now name the entry once, through a+  `Lookup n env ~ 'EnvEntry ty a` equality, and pass the resulting rigid+  types to `KnownMember`.++### Changed++- **Breaking.  A FIRST set is now written in alphabetical order**, and a+  declared environment that lists one in any other order is a type error+  naming the first position that disagrees.  Sortedness is what makes a set+  have a single spelling, which is what lets `Union` be one merge pass.+  Migration is mechanical: sort each `'[...]` in your `Env`, so+  `'["term", "factor", "number"]` becomes `'["factor", "number", "term"]`.+- **Breaking.** `Member` and `KnownMember` lose their `Ty` index:+  `Member s env a` and `KnownMember s env a`.  Every index of a class is+  carried along and re-normalised at each step of the instance chain that+  walks the environment, and a `Ty` carries a FIRST set — so an index for it+  made each step cost `O(|env|)`.  Nothing needed it; `Here` binds the+  entry's `ty` existentially, which is enough to pull a rule out of a rule+  table.+- `PEG.Syntax` exports `NTGo`, the `Ty` of a reference to a non-terminal+  whose own `Ty` is already known.  `NTTy n env` is now defined as+  `NTGo n (TyOf (Lookup n env))` and keeps working in signatures.++`SeqTy` and `ChoiceTy` are deliberately **unchanged**.  They duplicate their+operands across their right-hand sides too, but measurement says that costs+nothing here, and writing them as type synonyms is what makes them reduce to a+`'MkTy` head while their operands are still abstract — which is what lets a+polymorphic combinator such as `lexeme` compose without its caller having to+get the nesting of `SeqTy` exactly right.++## 0.2.0.0 — 2026-09-04++This release is **not source-compatible with 0.1.0.0**: `PExp`, `Rules`,+`Grammar`, `Result` and `PState` all gain a leading stream type parameter, and+a rule whose result is a character-class repetition changes result type. See+*Changed* below for the migration.++### Added — parsing any stream, not just `String`++`PEG.Stream` introduces a `Stream` class, with instances for `String`, strict+and lazy `Data.Text.Text`, and strict and lazy `Data.ByteString.ByteString`.+A grammar written once runs over any of them.++The genericity reaches the *results*, not just the input: a character-class+repetition such as `cs:[a-zA-Z0-9_]+` now produces a **chunk of the input+stream** — a real `Text` slice — instead of unpacking into a `[Char]`.  Two new+`PExp` constructors, `Span` and `Span1`, carry this; the quasi-quoter emits+them for `[...]*`, `[...]+`, `'c'*`, `'c'+`, `.*` and `.+`.++`ByteString` is read as Latin-1, exactly as `Data.ByteString.Char8` does: fast,+correct for ASCII, and wrong for multi-byte UTF-8.  `PEG.Stream`'s Haddock+states this as a law rather than a footnote.++Only `unconsS` has no default, so a user instance is one method.  It returns an+unboxed sum rather than `Maybe (Char, s)` on purpose — behind a class+dictionary the boxed version would allocate a `Just` and a pair for every+character, losing the zero-allocation terminal path.++### Changed++- **Breaking.** `PExp`, `Rules` and `Grammar` take a leading stream parameter:+  `PExp s env ty a`, `Rules s env defs`, `Grammar s env ty a`.  `Result` and+  `PState` likewise: `Result s a`, `PState s`.+- **Breaking.** A rule whose result is a character-class repetition now has+  result type `s`, so its `Env` synonym takes a parameter.  Semantic actions+  that fed such a result to something expecting a `String` need+  `chunkToString`: `number <- ds:[0-9]+ { Lit (read (chunkToString ds)) }`.+- **Breaking.** The symbol variable in `PExp`'s `NT`, in `nt`, and in+  `Rules`'s `RCons` is now named `n`; `s` is the stream.  `nt @"name"` is+  unaffected — the name is deliberately still the first quantified variable.+- `PEG.Semantics.Simple`'s unrelated `Stream` class is renamed+  `SimpleStream`, to leave the name to `PEG.Stream`.+- `PState`'s input field is now strict.++A `Grammar` is monomorphic in its stream.  Reusing one across stream types+needs a `forall s. Stream s => Grammar s env ty a` signature, which turns the+value into a function of a dictionary and so stops the compiled parser being+shared between calls.  Give parsers a monomorphic top-level binding where that+matters; `PEG.Parse`'s Haddock spells this out.++### Performance++Measured on the benchmark suite, bytes allocated per input byte, against the+previous release of the evaluator:++| grammar | before (String) | String | Text | ByteString | megaparsec |+|---|---|---|---|---|---|+| arith  | 990 | 943 | 1127 |  969 | 1239 |+| csv    | 834 | 787 |  951 |  805 | 1035 |+| json   | 459 | 404 |  583 |  452 |  782 |+| nested | 265 | 312 |  481 |  336 | 1283 |+| quoted `(!'"' .)*` | 162 | 209 | 320 | 250 | 128 |++`ByteString` is the cheapest column on five of the seven grammars and beats+megaparsec on six.  `Text` costs more than `String` throughout — the same+result the earlier study found for megaparsec, and worth knowing before+reaching for it.++Two grammars regressed on `String` (`nested` +18%, the `(!'"' .)*` idiom++29%).  Both are dominated by single-character steps rather than bulk scans,+where `unconsS` is one indirect call that the previous direct cons-cell match+did not need.  The five grammars that do any bulk scanning improved by 5-12%.++The `idents` and `quoted [^"]*` groups are not in the table because their+grammars changed: `ident` moved from `c:[a-zA-Z_] cs:[a-zA-Z0-9_]*` to+`&[a-zA-Z_] cs:[a-zA-Z0-9_]+` so that it returns a chunk rather than consing a+character onto one, and `Bench.Mega`'s `identP` moved to `takeWhile1P` to keep+the comparison like-for-like.  On the new grammars typed-peg allocates 100+B/byte over `String` and 84 over `ByteString`, against megaparsec's 179.++### Performance++The evaluator was rewritten twice: once around a compilation step, once around+an unboxed step result.  On the benchmark suite in `bench/` (see `cabal bench`),+measured against megaparsec 9.8 in the same run, typed-peg went from taking+2.1x-58x the time megaparsec takes to taking 0.95x-1.17x of it — and it now+allocates less than megaparsec on six of the seven grammars.  The one grammar+where it still loses is the `(!'"' .)*` idiom, which scans every character+twice by construction; written as `[^"]*` it costs 1.23x-1.35x.++- A compiled step returns an unboxed sum, `(# (# #) | (# a, PState #) #)`,+  rather than `Maybe (a, PState)`.  The two are isomorphic, but the unboxed+  sum travels in registers, so a step that succeeds no longer allocates a+  `Just` *and* a pair on top of the new state, and a step that fails+  allocates nothing at all.  This makes `Seq` and `Map` — the two+  constructors the quasi-quoter emits for every grammar item — completely+  allocation-free, and cuts total allocation by a further 9–53%.+- String literals match in a single loop that builds one `PState`, rather+  than one per character, whenever the grammar does not use layout.+- `PEG.Parse` now *compiles* a `Grammar` into a closure once, instead of+  walking the `PExp` GADT and the rule list on every step.  Resolving a+  non-terminal is now one indirect call rather than a linear scan of the rule+  environment.  `parseWith opts g` is written so that partially applying it+  yields the compiled parser; bind it to a name to reuse it.+- Character classes compile to a single `Sat` node holding a `PEG.CharSet`+  (a 256-bit bitmap), instead of expanding into a chain of ordered choices.+  Matching one character of `[a-zA-Z0-9_]` used to cost 63 parser steps.+- String literals compile to a single `Str` node instead of a chain of+  `Seq`/`Map`/`Term`.+- The parser no longer builds a `[(Char, Int)]` copy of the input; the column+  of the current character is carried in the state and updated incrementally.+- Terminals take a fast path that skips all interval arithmetic when the+  ambient column relation is total (`anyR`), which is the case for every+  grammar that does not use layout.  The new `rdTotal` field of `RelD` records+  this.+- `parse` returns the unconsumed suffix in `O(1)` instead of recomputing it+  with two `length` calls and a `drop`.+- `Star` no longer builds a chain of selector thunks.++### Added++- Negated character classes in the quasi-quoter: `[^"]` matches any character+  other than a quote.  Previously the only way to write this was+  `(!'"' .)`, which scans every character twice — once for the lookahead and+  once for the dot.  On the `quoted` benchmark the class form halves the+  allocation.+- `PEG.CharSet`: compact character sets, re-exported from `PEG`.+- `PEG.Syntax.Sat` / `PEG.Syntax.Str` constructors, and the `sat`,+  `charClass` and `notCharClass` smart constructors.+- `PEG.Parse.compileGrammar` and the `Step` and `Res` types, for callers that+  want the compiled parser directly.+- `PEG.Indent.rdTotal`.+- A criterion benchmark suite comparing typed-peg with megaparsec+  (`bench/`, run with `cabal bench`).+- `examples/Compat.hs`: a differential battery used to check that the+  optimisation work did not change any observable behaviour.++### Changed++- **Breaking.** `PState` now holds the remaining input as a `String` plus the+  current column and offset (`stInput`, `stCol`, `stOff`), rather than a+  precomputed `[(Char, Int)]`.  `PEG.Parse.Input`, `PEG.Parse.columns` and+  `PEG.Parse.eval` are gone; use `compileGrammar` instead of `eval`.+- **Breaking.** `RelD` has a new `rdTotal` field.+- **Breaking.** `PEG.Parse.Step` now returns the unboxed sum `Res a` instead+  of `Maybe (a, PState)`.  This only affects code that called+  `compileGrammar` directly; `parse` and `parseWith` are unchanged.+- **Breaking.** In a quasi-quoted grammar, a `^` immediately after `[` now+  negates the class instead of standing for itself; write `[\^]` for a class+  containing a caret.+- The `template-haskell` upper bound now admits the version shipped with+  GHC 9.10 (`< 2.24`).+ ## 0.1.0.0 — 2026-08-28  ### Added

@@ -12,7 +12,46 @@ - Compile-time left-recursion detection (type error) - Indentation-sensitive parsing (`PEG.Indent`) - Quasi-quoter for concrete grammar syntax (`PEG.QQ`)+- Parses any `PEG.Stream`: `String`, strict/lazy `Text`, strict/lazy+  `ByteString` +## Input streams++A grammar is written once and runs over any stream:++```haskell+import qualified Data.Text as T++parse arith "1+2*3"              -- Result String Exp+parse arith (T.pack "1+2*3")     -- Result Text   Exp+```++Character classes produce a **chunk of the stream**, not a `[Char]`: matching+`[a-z]+` against a `Text` yields a `Text` slice and copies nothing.  Semantic+actions that want a `String` ask for one:++```haskell+number <- ds:[0-9]+   { Lit (read (chunkToString ds)) }+strlit <- '"' cs:[^"]* '"'   { cs }     -- :: s, no copy+```++Only `unconsS` has no default, so adding a stream is one method.++`ByteString` is read as Latin-1, like `Data.ByteString.Char8`: fast and+correct for ASCII, wrong for multi-byte UTF-8.  Decode to `Text` if that+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 function of a dictionary, so the compiled parser is no longer shared+between calls.  Bind a monomorphic parser where that matters:++```haskell+arithString :: String -> Result String Exp+arithString = parse arith+{-# NOINLINE arithString #-}+```+ ## Quick start  ```haskell@@ -22,6 +61,42 @@ -- See examples/Arith.hs for a complete arithmetic expression parser ``` +## Grammar size++The nullability and FIRST set of every rule are computed by GHC while it+type-checks the grammar, so a grammar's size shows up as compile time.  A+FIRST set is a type-level list of non-terminal names kept in **alphabetical+order**:++```haskell+type CalcEnv =+  '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr)+   , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"])         Expr)+   , '("unary", 'EnvEntry ('MkTy 'False '["atom"])                  Expr)+   , '("atom" , 'EnvEntry ('MkTy 'False '[])                        Expr)+   ]+```++The order is not cosmetic.  It gives a set exactly one spelling, which is what+lets the union of two FIRST sets be a single merge pass; listing one in some+other order is a type error naming the first position that disagrees.++That merge nests one type-family reduction per element of the result, so a+grammar with a FIRST set of more than about a hundred non-terminals hits GHC's+default reduction limit and reports `Reduction stack overflow`.  Add+`-freduction-depth=0` to `ghc-options` if you get there; it is a limit rather+than a slowdown, and a union of two 128-element sets takes about 0.3 s once it+is lifted.++## Patterns++[`peg-patterns.md`](peg-patterns.md) works through patterns for specifying+languages with PEGs and this library, following Willis and Wu's *Design+Patterns for Parser Combinators* (Haskell 2021) and noting where a PEG differs+— committed choice, left recursion as a type error, keywords as negative+lookahead — and where typed-peg cannot yet follow.  Every fragment in it+compiles, in [`examples/Patterns.hs`](examples/Patterns.hs).+ ## Building  ```bash@@ -32,6 +107,63 @@  ```bash cabal test typed-peg-examples+```++## Benchmarks++`bench/` holds a criterion suite that measures typed-peg against+[megaparsec](https://hackage.haskell.org/package/megaparsec) on seven grammars+(arithmetic expressions, CSV, identifier lists, a mini JSON, deeply nested+parentheses, and quoted strings spelled two ways) written twice, rule for+rule.  Both libraries consume byte-identical inputs, and the suite+cross-checks that they produce the same result before timing anything.++```bash+cabal bench+```++`cabal bench --benchmark-options=--alloc` prints bytes allocated per parse+instead of running criterion; allocation is the number that separates the two+libraries most clearly once the algorithmic differences are gone.++On GHC 9.10.3 against megaparsec 9.8.1, bytes allocated per input byte on the+largest input of each group:++| grammar | typed-peg `String` | `Text` | `ByteString` | megaparsec `String` |+|---|---|---|---|---|+| arithmetic | 943 | 1127 | 969 | 1239 |+| CSV | 787 | 951 | 805 | 1035 |+| identifiers | 100 | 190 | 84 | 179 |+| JSON | 404 | 583 | 452 | 782 |+| nested parens | 312 | 481 | 336 | 1283 |+| `'"' [^"]* '"'` | 90 | 167 | 65 | 128 |+| `'"' (!'"' .)* '"'` | 209 | 320 | 250 | 128 |++`ByteString` is the cheapest column on five of the seven grammars and beats+megaparsec on six.  `Text` costs more than `String` throughout — the same+result the study found for megaparsec, so reach for it for interoperability+rather than for speed.++Allocation is deterministic and reproduces exactly.  Time is the noisier+measurement: on a machine with heterogeneous cores, unpinned runs of the+*same* megaparsec binary varied by up to 1.8x, so only the ratio taken within+one run is meaningful.++The reference implementation is `Bench.Peg`; its megaparsec twin is+`Bench.Mega`.  Since PEG ordered choice backtracks unconditionally while+megaparsec's `<|>` does not, every megaparsec alternative that can consume+input before failing is wrapped in `try`, so the two are recognising the same+language.++### Parsing many inputs++`parseWith opts grammar` traverses the grammar and returns a compiled closure.+Bind it once and reuse it, rather than calling `parse grammar input` inline in+a loop:++```haskell+myParser :: String -> Result Exp+myParser = parse myGrammar ```  ## License

@@ -0,0 +1,92 @@+-- | Deterministic input generators shared by the typed-peg and megaparsec+-- benchmark groups.  Everything is pure and reproducible (a small LCG), so+-- both libraries are always measured on byte-identical inputs.+module Bench.Inputs+  ( arithInput+  , csvInput+  , identInput+  , jsonInput+  , nestedInput+  , quotedInput+  ) where++-- | A tiny linear congruential generator (glibc constants) so the benchmark+-- inputs do not depend on @random@.+lcg :: Int -> Int+lcg s = (1103515245 * s + 12345) `mod` 2147483648++randoms :: Int -> [Int]+randoms = drop 1 . iterate lcg++-- | @arithInput n@ builds an arithmetic expression with @n@ operands, mixing+-- binary operators, parentheses and unary minus.+arithInput :: Int -> String+arithInput n = go n (randoms 7)+  where+    go k rs+      | k <= 1    = operand rs+      | otherwise = case drop 2 rs of+          (r : rs') -> operand rs ++ ["+-*/" !! (r `mod` 4)] ++ go (k - 1) rs'+          []        -> operand rs++    operand (r : s : _) = case r `mod` 8 of+      0 -> "(" ++ show (s `mod` 1000) ++ "+" ++ show (s `mod` 97) ++ ")"+      1 -> "-" ++ show (s `mod` 1000)+      _ -> show (s `mod` 100000)+    operand _ = "0"++-- | @csvInput rows cols@ builds @rows@ lines of @cols@ comma-separated+-- integers.+csvInput :: Int -> Int -> String+csvInput rows cols =+  intercalate' "\n"+    [ intercalate' "," [ show (v `mod` 1000000) | v <- take cols (drop (r * cols) vs) ]+    | r <- [0 .. rows - 1]+    ]+  where+    vs = randoms 42++-- | @identInput n@ builds @n@ space-separated identifiers.  Identifiers use a+-- wide character class (@[a-zA-Z0-9_]@), which is the worst case for a parser+-- that expands classes into a chain of ordered choices.+identInput :: Int -> String+identInput n = unwords' [ ident v | v <- take n (randoms 3) ]+  where+    alphabet = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_"+    ident v  = 'z' : [ alphabet !! ((v `div` (7 ^ k)) `mod` length alphabet)+                     | k <- [1 .. 6 :: Int] ]++-- | @jsonInput n@ builds a JSON array of @n@ small objects.+jsonInput :: Int -> String+jsonInput n =+  "[" ++ intercalate' ",\n " [ obj v | v <- take n (randoms 11) ] ++ "]"+  where+    obj v = "{\"id\": " ++ show (v `mod` 100000)+         ++ ", \"name\": \"item" ++ show (v `mod` 997) ++ "\""+         ++ ", \"tags\": [" ++ intercalate' ", " [ show (t :: Int) | t <- [1 .. 3] ] ++ "]"+         ++ ", \"ok\": " ++ (if even v then "true" else "false")+         ++ ", \"extra\": null}"++-- | @quotedInput n@ builds @n@ space-separated double-quoted strings.  Used to+-- compare the two ways of spelling \"any character but a quote\": the PEG+-- idiom @(!'\"' .)*@, which scans every character twice, against the negated+-- character class @[^\"]*@.+quotedInput :: Int -> String+quotedInput n = unwords' [ "\"" ++ body v ++ "\"" | v <- take n (randoms 23) ]+  where+    body v = [ alphabet !! ((v `div` (5 ^ k)) `mod` length alphabet)+             | k <- [1 .. 12 :: Int] ]+    alphabet = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ " ,.;:!?-"++-- | @nestedInput d@ builds @d@ nested parentheses around a literal.  This is+-- the deep-recursion / backtracking stress case for the arithmetic grammar.+nestedInput :: Int -> String+nestedInput d = replicate d '(' ++ "1" ++ replicate d ')'++intercalate' :: String -> [String] -> String+intercalate' _   []       = []+intercalate' _   [x]      = x+intercalate' sep (x : xs) = x ++ sep ++ intercalate' sep xs++unwords' :: [String] -> String+unwords' = intercalate' " "

@@ -0,0 +1,191 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++-- | The megaparsec side of the benchmark suite.+--+-- The grammars mirror "Bench.Peg" rule-for-rule.  Because PEG ordered choice+-- backtracks unconditionally while megaparsec's '<|>' only backtracks when the+-- left branch consumed nothing, every alternative that can consume input+-- before failing is wrapped in 'try'.  Without that the two libraries would+-- not be recognising the same language.+--+-- Parsers are polymorphic in the stream so the same code can be measured over+-- 'String' (the input type typed-peg supports) and over 'Data.Text.Text' (what+-- a megaparsec user would actually reach for).+module Bench.Mega+  ( runArith+  , runCsv+  , runIdents+  , runJson+  , runQuoted+  ) where++import Data.Char             (isAlphaNum, isAlpha, isDigit)+import Data.Proxy            (Proxy (..))+import Data.String           (IsString)+import Data.Void             (Void)+import Text.Megaparsec+import Text.Megaparsec.Char  (char, string)++import Bench.Peg (Exp (..), JValue (..), evalExp)++type Str s = ( Stream s, VisualStream s, TraversableStream s+              , Token s ~ Char, IsString (Tokens s), Ord (Token s) )++type P s = Parsec Void s++--------------------------------------------------------------------------------+-- Arithmetic expressions+--------------------------------------------------------------------------------++addOp :: Exp -> (Char, Exp) -> Exp+addOp l ('+', r) = Add l r+addOp l ('-', r) = Sub l r+addOp l ('*', r) = Mul l r+addOp l ('/', r) = Div l r+addOp _ (c  , _) = error ("addOp: unexpected operator " ++ show c)++exprP :: Str s => P s Exp+exprP = foldl addOp <$> termP <*> many (try ((,) <$> satisfy addSym <*> termP))+  where addSym c = c == '+' || c == '-'++termP :: Str s => P s Exp+termP = foldl addOp <$> factorP <*> many (try ((,) <$> satisfy mulSym <*> factorP))+  where mulSym c = c == '*' || c == '/'++factorP :: Str s => P s Exp+factorP =+      try numberP+  <|> try (char '(' *> exprP <* char ')')+  <|> (Neg <$> (char '-' *> factorP))++numberP :: Str s => P s Exp+numberP = (Lit . read) <$> some (satisfy isDigit)++--------------------------------------------------------------------------------+-- CSV of integers+--------------------------------------------------------------------------------++csvP :: Str s => P s [[Int]]+csvP = (:) <$> rowP <*> many (try (char '\n' *> rowP))++rowP :: Str s => P s [Int]+rowP = (:) <$> natP <*> many (try (char ',' *> natP))++natP :: Str s => P s Int+natP = read <$> some (satisfy isDigit)++--------------------------------------------------------------------------------+-- Identifier list+--------------------------------------------------------------------------------++identsP :: Str s => P s [Tokens s]+identsP = (:) <$> identP <*> many (try (char ' ' *> identP))++-- Both sides use their bulk primitive: typed-peg spans the class into a chunk+-- of the stream, megaparsec into a 'Tokens'.  A lookahead pins the first+-- character to the narrower class without consuming it, exactly as+-- @&[a-zA-Z_] [a-zA-Z0-9_]+@ does on the typed-peg side.+identP :: Str s => P s (Tokens s)+identP = lookAhead (satisfy startC) *> takeWhile1P Nothing contC+  where+    startC c = isAlpha c || c == '_'+    contC  c = isAlphaNum c || c == '_'++--------------------------------------------------------------------------------+-- Mini JSON+--------------------------------------------------------------------------------++wsP :: Str s => P s ()+wsP = () <$ takeWhileP Nothing isSpace'+  where isSpace' c = c == ' ' || c == '\t' || c == '\r' || c == '\n'++jsonP :: Str s => P s JValue+jsonP = wsP *> valueP <* wsP++valueP :: Str s => P s JValue+valueP =+      try objectP+  <|> try arrayP+  <|> try (JStr <$> strP)+  <|> try numberJP+  <|> try (JBool True  <$ string "true")+  <|> try (JBool False <$ string "false")+  <|> (JNull <$ string "null")++objectP :: Str s => P s JValue+objectP =+  JObj . orEmpty+    <$> (char '{' *> wsP *> optional (try membersP) <* wsP <* char '}')++membersP :: Str s => P s [(String, JValue)]+membersP = (:) <$> pairP <*> many (try (wsP *> char ',' *> wsP *> pairP))++pairP :: Str s => P s (String, JValue)+pairP = (,) <$> strP <*> (wsP *> char ':' *> wsP *> valueP)++arrayP :: Str s => P s JValue+arrayP =+  JArr . orEmpty+    <$> (char '[' *> wsP *> optional (try elemsP) <* wsP <* char ']')++elemsP :: Str s => P s [JValue]+elemsP = (:) <$> valueP <*> many (try (wsP *> char ',' *> wsP *> valueP))++strP :: Str s => P s String+strP = char '"' *> many (satisfy (/= '"')) <* char '"'++numberJP :: Str s => P s JValue+numberJP = mk <$> optional (char '-') <*> some (satisfy isDigit)+  where+    mk Nothing  ds = JNum (read ds)+    mk (Just _) ds = JNum (negate (read ds))++orEmpty :: Maybe [a] -> [a]+orEmpty Nothing   = []+orEmpty (Just xs) = xs++--------------------------------------------------------------------------------+-- Quoted strings+--------------------------------------------------------------------------------++quotedP :: Str s => P s [String]+quotedP = (:) <$> qP <*> many (try (char ' ' *> qP))++qP :: Str s => P s String+qP = char '"' *> many (satisfy (/= '"')) <* char '"'++--------------------------------------------------------------------------------+-- Runners+--------------------------------------------------------------------------------++run :: Str s => P s a -> (a -> Int) -> String -> s -> Int+run p k what s = case runParser p "<bench>" s of+  Left  e -> error (what ++ ": " ++ errorBundlePretty e)+  Right a -> k a++runArith :: Str s => s -> Int+runArith = run exprP evalExp "runArith"++runCsv :: Str s => s -> Int+runCsv = run csvP (sum . map sum) "runCsv"++runIdents :: forall s. Str s => s -> Int+runIdents = run identsP (sum . map (chunkLength (Proxy :: Proxy s))) "runIdents"++runJson :: Str s => s -> Int+runJson = run jsonP sizeJ "runJson"++runQuoted :: Str s => s -> Int+runQuoted = run quotedP (sum . map length) "runQuoted"++sizeJ :: JValue -> Int+sizeJ JNull     = 1+sizeJ (JBool _) = 1+sizeJ (JNum n)  = n+sizeJ (JStr t)  = length t+sizeJ (JArr xs) = 1 + sum (map sizeJ xs)+sizeJ (JObj ps) = 1 + sum [ length k + sizeJ v | (k, v) <- ps ]

@@ -0,0 +1,416 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}+{-# OPTIONS_GHC -Wno-missing-signatures #-}++-- | The typed-peg side of the benchmark suite.  Every grammar here has a+-- structurally identical megaparsec counterpart in "Bench.Mega".+module Bench.Peg+  ( Exp (..)+  , evalExp+  , arith+  , csv+  , idents+  , JValue (..)+  , json+  , arithS, csvS, identsS, jsonS, quotedNotS, quotedClsS+  , arithT, csvT, identsT, jsonT, quotedNotT, quotedClsT+  , arithB, csvB, identsB, jsonB, quotedNotB, quotedClsB+  ) where++import qualified Data.ByteString as B+import qualified Data.Text       as T++import PEG+import PEG.QQ (pegRules)++--------------------------------------------------------------------------------+-- Arithmetic expressions+--------------------------------------------------------------------------------++data Exp+  = Lit Int+  | Neg Exp+  | Add Exp Exp+  | Sub Exp Exp+  | Mul Exp Exp+  | Div Exp Exp+  deriving (Eq, Show)++evalExp :: Exp -> Int+evalExp (Lit n)   = n+evalExp (Neg e)   = negate (evalExp e)+evalExp (Add a b) = evalExp a + evalExp b+evalExp (Sub a b) = evalExp a - evalExp b+evalExp (Mul a b) = evalExp a * evalExp b+evalExp (Div a b) = let d = evalExp b in if d == 0 then 0 else evalExp a `div` d++addOp :: Exp -> (Char, Exp) -> Exp+addOp l ('+', r) = Add l r+addOp l ('-', r) = Sub l r+addOp l ('*', r) = Mul l r+addOp l ('/', r) = Div l r+addOp _ (c  , _) = error ("addOp: unexpected operator " ++ show c)++foldOps :: Exp -> [(Char, Exp)] -> Exp+foldOps = foldl addOp++readInt :: Stream s => s -> Exp+readInt ds = Lit (read (chunkToString ds))++type ArithEnv =+  '[ '("expr"  , 'EnvEntry ('MkTy 'False '["factor", "number", "term"]) Exp)+   , '("term"  , 'EnvEntry ('MkTy 'False '["factor", "number"])         Exp)+   , '("factor", 'EnvEntry ('MkTy 'False '["number"])                   Exp)+   , '("number", 'EnvEntry ('MkTy 'False '[])                           Exp)+   ]++{-# INLINABLE arith #-}+arith :: Stream s => Grammar s ArithEnv _ Exp+arith =+  Grammar+    [pegRules|+       expr   <- t:term ts:(o:[+-] u:term)*   { foldOps t ts }+       term   <- f:factor fs:(o:[*/] g:factor)* { foldOps f fs }+       factor <- n:number+               / '(' e:expr ')'+               / '-' f:factor                 { Neg f }+       number <- ds:[0-9]+                    { readInt ds }+    |]+    (nt @"expr")++--------------------------------------------------------------------------------+-- CSV of integers+--------------------------------------------------------------------------------++type CsvEnv =+  '[ '("csv", 'EnvEntry ('MkTy 'False '["num", "row"]) [[Int]])+   , '("row", 'EnvEntry ('MkTy 'False '["num"])        [Int])+   , '("num", 'EnvEntry ('MkTy 'False '[])             Int)+   ]++{-# INLINABLE csv #-}+csv :: Stream s => Grammar s CsvEnv _ [[Int]]+csv =+  Grammar+    [pegRules|+       csv <- r:row rs:('\n' t:row)* { r : rs }+       row <- n:num ns:(',' m:num)*  { n : ns }+       num <- ds:[0-9]+              { readNat ds }+    |]+    (nt @"csv")++readNat :: Stream s => s -> Int+readNat = read . chunkToString++--------------------------------------------------------------------------------+-- Identifier list (wide character classes)+--------------------------------------------------------------------------------++-- The environment is parameterised by the stream: @ident@ is a character+-- class, so its result is a chunk of the input.+type IdentEnv s =+  '[ '("idents", 'EnvEntry ('MkTy 'False '["ident"]) [s])+   , '("ident" , 'EnvEntry ('MkTy 'False '[])        s)+   ]++{-# INLINABLE idents #-}+idents :: Stream s => Grammar s (IdentEnv s) _ [s]+idents =+  Grammar+    [pegRules|+       idents <- i:ident is:(' ' j:ident)*     { i : is }+       ident  <- &[a-zA-Z_] cs:[a-zA-Z0-9_]+   { cs }+    |]+    (nt @"idents")++--------------------------------------------------------------------------------+-- Mini JSON+--------------------------------------------------------------------------------++data JValue+  = JNull+  | JBool Bool+  | JNum  Int+  | JStr  String+  | JArr  [JValue]+  | JObj  [(String, JValue)]+  deriving (Eq, Show)++mkNum :: Stream s => Maybe Char -> s -> JValue+mkNum Nothing  ds = JNum (read (chunkToString ds))+mkNum (Just _) ds = JNum (negate (read (chunkToString ds)))++orEmpty :: Maybe [a] -> [a]+orEmpty Nothing   = []+orEmpty (Just xs) = xs++type JsonEnv =+  '[ '("json"   , 'EnvEntry ('MkTy 'False '["array","number","object","strlit","value","ws"]) JValue)+   , '("value"  , 'EnvEntry ('MkTy 'False '["array","number","object","strlit"])              JValue)+   , '("object" , 'EnvEntry ('MkTy 'False '[])                                                JValue)+   , '("members", 'EnvEntry ('MkTy 'False '["pair","strlit"])                    [(String, JValue)])+   , '("pair"   , 'EnvEntry ('MkTy 'False '["strlit"])                             (String, JValue))+   , '("array"  , 'EnvEntry ('MkTy 'False '[])                                                JValue)+   , '("elems"  , 'EnvEntry ('MkTy 'False '["array","number","object","strlit","value"])    [JValue])+   , '("strlit" , 'EnvEntry ('MkTy 'False '[])                                                String)+   , '("number" , 'EnvEntry ('MkTy 'False '[])                                                JValue)+   , '("ws"     , 'EnvEntry ('MkTy 'True  '[])                                                    ())+   ]++{-# INLINABLE json #-}+json :: Stream s => Grammar s JsonEnv _ JValue+json =+  Grammar+    [pegRules|+       json    <- ws v:value ws                    { v }+       value   <- o:object                         { o }+                / a:array                          { a }+                / s:strlit                         { JStr s }+                / n:number                         { n }+                / "true"                           { JBool True }+                / "false"                          { JBool False }+                / "null"                           { JNull }+       object  <- '{' ws ms:members? ws '}'        { JObj (orEmpty ms) }+       members <- p:pair ps:(ws ',' ws q:pair)*    { p : ps }+       pair    <- k:strlit ws ':' ws v:value       { (k, v) }+       array   <- '[' ws es:elems? ws ']'          { JArr (orEmpty es) }+       elems   <- e:value es:(ws ',' ws f:value)*  { e : es }+       strlit  <- '"' cs:(!'"' c:.)* '"'           { cs }+       number  <- s:'-'? ds:[0-9]+                 { mkNum s ds }+       ws      <- [ \t\r\n]*+    |]+    (nt @"json")++--------------------------------------------------------------------------------+-- Quoted strings: negative lookahead vs. negated character class+--+-- Two grammars that accept exactly the same language.  The first spells+-- \"any character but a quote\" the way a PEG traditionally does, with a+-- negative lookahead; the second uses a negated character class, which+-- compiles to one 'Sat' node.+--------------------------------------------------------------------------------++-- @(!'"' .)*@ is a compound repetition, so it still yields a @['Char']@ ...+type QuotedNotEnv =+  '[ '("qs", 'EnvEntry ('MkTy 'False '["q"]) [String])+   , '("q" , 'EnvEntry ('MkTy 'False '[])    String)+   ]++-- ... whereas @[^"]*@ is a character class and yields a chunk.+type QuotedClsEnv s =+  '[ '("qs", 'EnvEntry ('MkTy 'False '["q"]) [s])+   , '("q" , 'EnvEntry ('MkTy 'False '[])    s)+   ]++{-# INLINABLE quotedNot #-}+quotedNot :: Stream s => Grammar s QuotedNotEnv _ [String]+quotedNot =+  Grammar+    [pegRules|+       qs <- s:q ss:(' ' t:q)*      { s : ss }+       q  <- '"' cs:(!'"' c:.)* '"' { cs }+    |]+    (nt @"qs")++{-# INLINABLE quotedCls #-}+quotedCls :: Stream s => Grammar s (QuotedClsEnv s) _ [s]+quotedCls =+  Grammar+    [pegRules|+       qs <- s:q ss:(' ' t:q)*      { s : ss }+       q  <- '"' cs:[^"]* '"'       { cs }+    |]+    (nt @"qs")++--------------------------------------------------------------------------------+-- Runners (force the result so criterion measures the whole parse)+--+-- Each parser is bound monomorphically at each stream type.  That matters: a+-- grammar left polymorphic in its stream is a function of a 'Stream'+-- dictionary rather than a constant, so the compiled parser would be rebuilt+-- on every call.  NOINLINE keeps each one a shared CAF, so the measurement is+-- of parsing rather than of re-traversing the grammar.+--------------------------------------------------------------------------------++runArith :: Stream s => (s -> Result s Exp) -> s -> Int+runArith p s = case p s of+  OK e _ _ -> evalExp e+  Fail     -> error "runArith: parse failed"+{-# INLINE runArith #-}++runCsv :: Stream s => (s -> Result s [[Int]]) -> s -> Int+runCsv p s = case p s of+  OK rs _ _ -> sum (map sum rs)+  Fail      -> error "runCsv: parse failed"+{-# INLINE runCsv #-}++runIdents :: Stream s => (s -> Result s [s]) -> s -> Int+runIdents p s = case p s of+  OK is _ _ -> sum (map lengthS is)+  Fail      -> error "runIdents: parse failed"+{-# INLINE runIdents #-}++runJson :: Stream s => (s -> Result s JValue) -> s -> Int+runJson p s = case p s of+  OK v _ _ -> sizeJ v+  Fail     -> error "runJson: parse failed"+{-# INLINE runJson #-}++runQuotedNot :: Stream s => (s -> Result s [String]) -> s -> Int+runQuotedNot p s = case p s of+  OK xs _ _ -> sum (map length xs)+  Fail      -> error "runQuotedNot: parse failed"+{-# INLINE runQuotedNot #-}++runQuotedCls :: Stream s => (s -> Result s [s]) -> s -> Int+runQuotedCls p s = case p s of+  OK xs _ _ -> sum (map lengthS xs)+  Fail      -> error "runQuotedCls: parse failed"+{-# INLINE runQuotedCls #-}++sizeJ :: JValue -> Int+sizeJ JNull      = 1+sizeJ (JBool _)  = 1+sizeJ (JNum n)   = n+sizeJ (JStr t)   = length t+sizeJ (JArr xs)  = 1 + sum (map sizeJ xs)+sizeJ (JObj ps)  = 1 + sum [ length k + sizeJ v | (k, v) <- ps ]++--------------------------------------------------------------------------------+-- Monomorphic entry points, one set per stream.+--+-- The parser must be bound as its own CAF.  Writing @arithS = runArith (parse+-- arith)@ instead lets GHC eta-expand to @\s -> case parse arith s of ...@,+-- which rebuilds the compiled parser on every single call -- a 2.5x slowdown+-- that no amount of specialisation recovers.+--------------------------------------------------------------------------------++pArithS :: String -> Result String Exp+pArithS = parse arith+{-# NOINLINE pArithS #-}++arithS :: String -> Int+arithS = runArith pArithS++pCsvS :: String -> Result String [[Int]]+pCsvS = parse csv+{-# NOINLINE pCsvS #-}++csvS :: String -> Int+csvS = runCsv pCsvS++pJsonS :: String -> Result String JValue+pJsonS = parse json+{-# NOINLINE pJsonS #-}++jsonS :: String -> Int+jsonS = runJson pJsonS++pQuotedNotS :: String -> Result String [String]+pQuotedNotS = parse quotedNot+{-# NOINLINE pQuotedNotS #-}++quotedNotS :: String -> Int+quotedNotS = runQuotedNot pQuotedNotS++pIdentsS :: String -> Result String [String]+pIdentsS = parse idents+{-# NOINLINE pIdentsS #-}++identsS :: String -> Int+identsS = runIdents pIdentsS++pQuotedClsS :: String -> Result String [String]+pQuotedClsS = parse quotedCls+{-# NOINLINE pQuotedClsS #-}++quotedClsS :: String -> Int+quotedClsS = runQuotedCls pQuotedClsS++pArithT :: T.Text -> Result T.Text Exp+pArithT = parse arith+{-# NOINLINE pArithT #-}++arithT :: T.Text -> Int+arithT = runArith pArithT++pCsvT :: T.Text -> Result T.Text [[Int]]+pCsvT = parse csv+{-# NOINLINE pCsvT #-}++csvT :: T.Text -> Int+csvT = runCsv pCsvT++pJsonT :: T.Text -> Result T.Text JValue+pJsonT = parse json+{-# NOINLINE pJsonT #-}++jsonT :: T.Text -> Int+jsonT = runJson pJsonT++pQuotedNotT :: T.Text -> Result T.Text [String]+pQuotedNotT = parse quotedNot+{-# NOINLINE pQuotedNotT #-}++quotedNotT :: T.Text -> Int+quotedNotT = runQuotedNot pQuotedNotT++pIdentsT :: T.Text -> Result T.Text [T.Text]+pIdentsT = parse idents+{-# NOINLINE pIdentsT #-}++identsT :: T.Text -> Int+identsT = runIdents pIdentsT++pQuotedClsT :: T.Text -> Result T.Text [T.Text]+pQuotedClsT = parse quotedCls+{-# NOINLINE pQuotedClsT #-}++quotedClsT :: T.Text -> Int+quotedClsT = runQuotedCls pQuotedClsT++pArithB :: B.ByteString -> Result B.ByteString Exp+pArithB = parse arith+{-# NOINLINE pArithB #-}++arithB :: B.ByteString -> Int+arithB = runArith pArithB++pCsvB :: B.ByteString -> Result B.ByteString [[Int]]+pCsvB = parse csv+{-# NOINLINE pCsvB #-}++csvB :: B.ByteString -> Int+csvB = runCsv pCsvB++pJsonB :: B.ByteString -> Result B.ByteString JValue+pJsonB = parse json+{-# NOINLINE pJsonB #-}++jsonB :: B.ByteString -> Int+jsonB = runJson pJsonB++pQuotedNotB :: B.ByteString -> Result B.ByteString [String]+pQuotedNotB = parse quotedNot+{-# NOINLINE pQuotedNotB #-}++quotedNotB :: B.ByteString -> Int+quotedNotB = runQuotedNot pQuotedNotB++pIdentsB :: B.ByteString -> Result B.ByteString [B.ByteString]+pIdentsB = parse idents+{-# NOINLINE pIdentsB #-}++identsB :: B.ByteString -> Int+identsB = runIdents pIdentsB++pQuotedClsB :: B.ByteString -> Result B.ByteString [B.ByteString]+pQuotedClsB = parse quotedCls+{-# NOINLINE pQuotedClsB #-}++quotedClsB :: B.ByteString -> Int+quotedClsB = runQuotedCls pQuotedClsB

@@ -0,0 +1,165 @@+{-# LANGUAGE OverloadedStrings #-}++-- | criterion driver comparing typed-peg against megaparsec.+--+-- Each grammar is written twice, rule for rule (see "Bench.Peg" and+-- "Bench.Mega"), and both libraries consume the exact same input.+--+-- typed-peg is measured over 'String', 'Data.Text.Text' and+-- 'Data.ByteString.ByteString'; megaparsec over 'String' and+-- 'Data.Text.Text' only, because its @Token ByteString@ is 'Data.Word.Word8'+-- rather than 'Char', so the same grammars do not typecheck over it.+module Main (main) where++import Control.DeepSeq   (force)+import Control.Exception (evaluate)+import Criterion.Main+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString       as B+import qualified Data.Text             as T+import GHC.Stats          (RTSStats (..), getRTSStats)+import System.Environment (getArgs)+import System.Mem         (performGC)++import qualified Bench.Inputs as I+import qualified Bench.Mega   as M+import qualified Bench.Peg    as P++-- | Everything needed to measure one grammar on every library and stream.+data Group = Group+  { gName  :: String+  , gPegS  :: String        -> Int+  , gPegT  :: T.Text        -> Int+  , gPegB  :: B.ByteString  -> Int+  , gMegaS :: String        -> Int+  , gMegaT :: T.Text        -> Int+  }++groups :: [(Group, [String])]+groups =+  [ ( Group "arith"  P.arithS  P.arithT  P.arithB  M.runArith  M.runArith+    , map I.arithInput [50, 200, 800] )+  , ( Group "csv"    P.csvS    P.csvT    P.csvB    M.runCsv    M.runCsv+    , map (`I.csvInput` 8) [20, 100, 400] )+  , ( Group "idents" P.identsS P.identsT P.identsB M.runIdents M.runIdents+    , map I.identInput [100, 500, 2000] )+  , ( Group "json"   P.jsonS   P.jsonT   P.jsonB   M.runJson   M.runJson+    , map I.jsonInput [10, 50, 200] )+  , ( Group "nested" P.arithS  P.arithT  P.arithB  M.runArith  M.runArith+    , map I.nestedInput [50, 200] )+    -- The same language spelled two ways in typed-peg, against one megaparsec+    -- parser: this isolates the cost of the negative-lookahead idiom.+  , ( Group "quoted-lookahead" P.quotedNotS P.quotedNotT P.quotedNotB+                               M.runQuoted  M.runQuoted+    , map I.quotedInput [50, 200] )+  , ( Group "quoted-class"     P.quotedClsS P.quotedClsT P.quotedClsB+                               M.runQuoted  M.runQuoted+    , map I.quotedInput [50, 200] )+  ]++label :: Group -> String -> String+label g input = gName g ++ " [" ++ show (length input) ++ "B]"++--------------------------------------------------------------------------------+-- Cross-check: every library and every stream must agree before anything is+-- timed, otherwise the measurements compare different amounts of work.+--------------------------------------------------------------------------------++verify :: Group -> String -> IO ()+verify g input = do+  let ps = gPegS  g input+      pt = gPegT  g (T.pack input)+      pb = gPegB  g (BC.pack input)+      ms = gMegaS g input+      mt = gMegaT g (T.pack input)+  if all (== ps) [pt, pb, ms, mt]+    then putStrLn ("  ok  " ++ label g input ++ " -> " ++ show ps)+    else error ("MISMATCH in " ++ label g input+                  ++ ": peg(String)=" ++ show ps+                  ++ " peg(Text)="    ++ show pt+                  ++ " peg(BS)="      ++ show pb+                  ++ " mega(String)=" ++ show ms+                  ++ " mega(Text)="   ++ show mt)++verifyAll :: IO ()+verifyAll = do+  putStrLn "== cross-checking typed-peg against megaparsec, on every stream =="+  sequence_ [ verify g i | (g, is) <- groups, i <- is ]+  putStrLn ""++--------------------------------------------------------------------------------+-- Allocation report+--+-- @cabal bench --benchmark-options=--alloc@ prints bytes allocated per parse+-- instead of running criterion.  Allocation is deterministic, so it is the+-- measurement to trust when the timings are noisy.+--------------------------------------------------------------------------------++allocFor :: (a -> Int) -> a -> IO Integer+allocFor f x = do+  performGC+  before <- getRTSStats+  n <- evaluate (f x)+  n `seq` performGC+  after <- getRTSStats+  pure (fromIntegral (allocated_bytes after - allocated_bytes before))++allocRow :: Group -> String -> IO ()+allocRow g input = do+  s <- evaluate (force input)+  t <- evaluate (force (T.pack input))+  b <- evaluate (force (BC.pack input))+  aps <- allocFor (gPegS  g) s+  apt <- allocFor (gPegT  g) t+  apb <- allocFor (gPegB  g) b+  ams <- allocFor (gMegaS g) s+  amt <- allocFor (gMegaT g) t+  let n = fromIntegral (length input) :: Double+      per v = rjust 9 (showF (fromIntegral v / n))+  putStrLn (concat+    [ pad 24 (label g input)+    , per aps, per apt, per apb, per ams, per amt ])+  where+    pad k x   = x ++ replicate (k - length x) ' '+    rjust k x = replicate (k - length x) ' ' ++ x+    showF v   = show (fromIntegral (round (v * 10) :: Int) / 10 :: Double)++allocReport :: IO ()+allocReport = do+  putStrLn "bytes allocated per input byte"+  putStrLn (concat [ replicate 24 ' '+                   , "  peg/Str", "  peg/Txt", "   peg/BS"+                   , " mega/Str", " mega/Txt" ])+  sequence_ [ allocRow g i | (g, is) <- groups, i <- is ]++--------------------------------------------------------------------------------++main :: IO ()+main = do+  args <- getArgs+  if "--alloc" `elem` args+    then allocReport+    else verifyAll >> defaultMain benchmarks++benchmarks :: [Benchmark]+benchmarks =+  [ bgroup (gName g)+      [ env (prepare input) $ \ ~(s, t, b) ->+          bgroup (label g input)+            [ bench "typed-peg   (String)"     $ whnf (gPegS  g) s+            , bench "typed-peg   (Text)"       $ whnf (gPegT  g) t+            , bench "typed-peg   (ByteString)" $ whnf (gPegB  g) b+            , bench "megaparsec  (String)"     $ whnf (gMegaS g) s+            , bench "megaparsec  (Text)"       $ whnf (gMegaT g) t+            ]+      | input <- is+      ]+  | (g, is) <- groups+  ]++prepare :: String -> IO (String, T.Text, B.ByteString)+prepare s = do+  s' <- evaluate (force s)+  t' <- evaluate (force (T.pack s))+  b' <- evaluate (force (BC.pack s))+  pure (s', t', b')

@@ -52,13 +52,19 @@ addOp _ (c  , _) = error ("addOp: unexpected operator " ++ show c)  type ArithEnv =-  '[ '("expr"  , 'EnvEntry ('MkTy 'False '["term", "factor", "number"]) Exp)+  '[ '("expr"  , 'EnvEntry ('MkTy 'False '["factor", "number", "term"]) Exp)    , '("term"  , 'EnvEntry ('MkTy 'False '["factor", "number"])         Exp)    , '("factor", 'EnvEntry ('MkTy 'False '["number"])                   Exp)    , '("number", 'EnvEntry ('MkTy 'False '[])                           Exp)    ] -arith :: Grammar ArithEnv _ Exp+-- | Polymorphic in the stream, so the same grammar can be run over 'String',+-- 'Data.Text.Text' and 'Data.ByteString.ByteString'.  Note the cost: this is+-- a function of a 'Stream' dictionary rather than a constant, so the compiled+-- parser is not shared between calls.  Bind a monomorphic parser+-- (@arithString = parse arith :: String -> Result String Exp@) where that+-- matters.+arith :: Stream s => Grammar s ArithEnv _ Exp arith =   Grammar     [pegRules|@@ -68,6 +74,6 @@        factor <- n:number                / '(' e:expr ')'                / '-' f:factor { Neg f }-       number <- ds:[0-9]+ { Lit (read ds :: Int) }+       number <- ds:[0-9]+ { Lit (read (chunkToString ds) :: Int) }     |]     (nt @"expr")

@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE PartialTypeSignatures  #-}+{-# LANGUAGE QuasiQuotes            #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++-- | A differential test: it renders the complete 'Result' (value, consumed+-- prefix and remaining suffix) for a fixed battery of inputs.+--+-- It serves two purposes.+--+-- * The output is compared byte-for-byte between successive versions of the+--   evaluator, which is how the optimisation work was checked for behavioural+--   drift — including the layout-sensitive paths that the other examples do+--   not exercise.+--+-- * The same battery is run over 'String', 'Data.Text.Text' and+--   'Data.ByteString.ByteString', and the three renderings must agree.  That+--   is what pins the "PEG.Stream" instances to each other: a stream whose+--   @spanS@ or column bookkeeping is wrong shows up here as a diff.+--+-- The renderings can be compared directly because 'Show' for 'Data.Text.Text'+-- and 'Data.ByteString.ByteString' agrees with 'Show' for 'String' on the+-- Latin-1 range, which is all these inputs use.+module Compat (compatMain) where++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text             as T++import PEG+import PEG.QQ (pegExpr, pegRules)+import Arith  (arith, Exp)+import Layout (DoStmt, doExp, layoutOpts)++showR :: (Show s, Show a) => Result s a -> String+showR (OK a c r) = "OK " ++ show a ++ " consumed=" ++ show c ++ " rest=" ++ show r+showR Fail       = "Fail"++arithCases :: [String]+arithCases =+  [ "1+2*3", "(1+2)*3", "42", "-7", "1+", "", "((((1))))"+  , "1+2)rest", "12*34/5-6", "9"+  , "1+2*3+4*5+6/7-8", "(((1+2)*(3+4))-(5*6))"+  , "0000123", "1--2", "-(1+2)"+  ]++layoutCases :: [String]+layoutCases =+  [ "do\n  foo\n  bar"+  , "do\n  foo\n  bar\nbaz"+  , "do { foo ; bar }"+  , "do\n  foo\n  do\n    bar\n  baz"+  , "do\n foo\n  bar"+  , "do\n\tfoo\n\tbar"+  , "do foo bar"+  , "do"+  , "  do\n    a\n    b"+  , "do\n  a\n b"+  , "do { a }"+  , "do\n  do\n    x"+  ]++-- Several option sets, so tab expansion and the token relation are covered.+optSets :: [(String, Opts)]+optSets =+  [ ("layout(ge,tab8)" , layoutOpts)+  , ("layout(ge,tab4)" , layoutOpts  { optTabWidth  = 4 })+  , ("layout(ge,tab1)" , layoutOpts  { optTabWidth  = 1 })+  , ("layout(gt)"      , layoutOpts  { optTokenMode = relD gtR })+  , ("layout(eq)"      , layoutOpts  { optTokenMode = relD eqR })+  , ("layout(any)"     , defaultOpts)+  , ("layout(off2)"    , layoutOpts  { optTokenMode = relD (offsetR 2) })+  , ("layout(cands)"   , layoutOpts  { optCands     = Interval 1 (Fin 20) })+  ]++-- | Chunk primitives and the lookaheads over them.+--+-- @Span@ and @Span1@ are what a character-class repetition compiles to, and+-- @!c+@ / @!c*@ have dedicated compile cases; nothing else in the battery+-- reaches them.  @!c*@ can never succeed, because the star matches the empty+-- run.+type SpanEnv s =+  '[ '("digits", 'EnvEntry ('MkTy 'True  '[]) s)+   , '("digits1", 'EnvEntry ('MkTy 'False '[]) s)+   ]++spanG :: Stream s => Grammar s (SpanEnv s) _ (s, s)+spanG =+  Grammar+    [pegRules|+       digits  <- ds:[0-9]*   { ds }+       digits1 <- ds:[0-9]+   { ds }+    |]+    [pegExpr| a:digits '/' b:digits1 |]++-- @!'x'+ .@ accepts any character that is not an @x@; @!'x'* .@ accepts+-- nothing at all.+notSpan1G :: Stream s => Grammar s '[] _ Char+notSpan1G = Grammar RNil [pegExpr| !'x'+ c:. |]++notSpanG :: Stream s => Grammar s '[] _ Char+notSpanG = Grammar RNil [pegExpr| !'x'* c:. |]++spanCases :: [String]+spanCases = ["/1", "12/34", "/", "12/", "abc", "", "007/8"]++notCases :: [String]+notCases = ["y", "x", "", "yx"]++-- | The whole battery, rendered as lines, for one stream type.+--+-- @pack@ is the only stream-specific part; everything else is the same code+-- running at a different instance.+battery :: forall s. (Stream s, Show s) => (String -> s) -> [String]+battery pack =+  [ "### arith (defaultOpts)" ]+  ++ [ show s ++ " => " ++ showR (parse arith (pack s) :: Result s Exp)+     | s <- arithCases ]+  ++ [ "### arith (varying Opts)" ]+  ++ [ nm ++ " " ++ show s ++ " => "+         ++ showR (parseWith o arith (pack s) :: Result s Exp)+     | (nm, o) <- optSets, s <- arithCases ]+  ++ [ "### span primitives" ]+  ++ [ show c ++ " => " ++ showR (parse spanG (pack c) :: Result s (s, s))+     | c <- spanCases ]+  ++ [ "### !c+ (peek) and !c* (never succeeds)" ]+  ++ [ show c ++ " => " ++ showR (parse notSpan1G (pack c) :: Result s Char)+         ++ " | " ++ showR (parse notSpanG (pack c) :: Result s Char)+     | c <- notCases ]+  ++ [ "### layout" ]+  ++ [ nm ++ " " ++ show s ++ " => "+         ++ showR (parseWith o doExp (pack s) :: Result s [DoStmt])+     | (nm, o) <- optSets, s <- layoutCases ]++-- | Print the 'String' rendering — this is the output compared against+-- previous versions of the evaluator — then check the other two streams+-- against it.+compatMain :: IO ()+compatMain = do+  let reference = battery id+  mapM_ putStrLn reference++  putStrLn "### stream agreement"+  agree "Data.Text.Text"             reference (battery T.pack)+  agree "Data.ByteString.ByteString" reference (battery BC.pack)++-- | Report the first disagreement, if any.  A count alone would say that+-- something is wrong without saying what, and these are 234 dense lines.+agree :: String -> [String] -> [String] -> IO ()+agree name reference actual =+  case [ (i, r, a)+       | (i, r, a) <- zip3 [1 :: Int ..] reference actual, r /= a ] of+    [] | length reference == length actual ->+           putStrLn (name ++ ": agrees with String on all "+                       ++ show (length reference) ++ " lines")+       | otherwise ->+           putStrLn (name ++ ": MISMATCH in length, " ++ show (length reference)+                       ++ " vs " ++ show (length actual))+    ((i, r, a) : rest) -> do+      putStrLn (name ++ ": MISMATCH on " ++ show (length rest + 1)+                  ++ " line(s), first at line " ++ show i)+      putStrLn ("  String: " ++ r)+      putStrLn ("  " ++ name ++ ": " ++ a)

@@ -20,16 +20,20 @@   | Nested [DoStmt]   deriving (Eq, Show) -type DoEnv =+-- | The environment is parameterised by the stream, because @name@ is a+-- character class and so produces a chunk of the input rather than a+-- 'String'.  Any rule whose result is a chunk pushes @s@ into the+-- environment this way.+type DoEnv s =   '[ '("doexp" , 'EnvEntry ('MkTy 'False '[])                               [DoStmt])-   , '("istmts", 'EnvEntry ('MkTy 'False '["ws", "stmt", "doexp", "name"]) [DoStmt])+   , '("istmts", 'EnvEntry ('MkTy 'False '["doexp", "name", "stmt", "ws"]) [DoStmt])    , '("stmts" , 'EnvEntry ('MkTy 'False '["ws"])                          [DoStmt])    , '("stmt"  , 'EnvEntry ('MkTy 'False '["doexp", "name"])               DoStmt)-   , '("name"  , 'EnvEntry ('MkTy 'False '[])                              String)+   , '("name"  , 'EnvEntry ('MkTy 'False '[])                              s)    , '("ws"    , 'EnvEntry ('MkTy 'True  '[])                              ())    ] -doExp :: Grammar DoEnv _ [DoStmt]+doExp :: Stream s => Grammar s (DoEnv s) _ [DoStmt] doExp =   Grammar     [pegRules|@@ -39,7 +43,7 @@         stmts  <- r:(ws '{' ws s:stmt ss:(ws ';' ws t:stmt)* ws '}' { s : ss })^~ -       stmt   <- d:doexp { Nested d } / n:name { Atom n }+       stmt   <- d:doexp { Nested d } / n:name { Atom (chunkToString n) }         name   <- cs:[a-z]+ 

@@ -3,8 +3,10 @@ import PEG (parse, parseWith, Result(..)) import Arith (arith, evalExp) import Layout (doExp, layoutOpts)+import Compat (compatMain)+import Patterns (patternsMain) -showResult :: Show a => Result a -> String+showResult :: Show a => Result String a -> String showResult (OK a _ _) = "OK " ++ show a showResult Fail        = "Fail" @@ -23,3 +25,9 @@   putStrLn "\n=== Layout (do-notation) ==="   let testLayout s = putStrLn $ showResult (parseWith layoutOpts doExp s)   testLayout "foo\n  bar\n  baz\nqux"++  putStrLn "\n=== Patterns (see peg-patterns.md) ==="+  patternsMain++  putStrLn "\n=== Differential battery ==="+  compatMain

@@ -0,0 +1,253 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}++-- | Worked examples for @peg-patterns.md@.+--+-- Every snippet quoted in that document appears here, so the document cannot+-- drift away from code that compiles.  'patternsMain' exercises each one.+module Patterns+  ( Expr (..)+  , Asgn (..)+  , evalE+  , ws, lexeme, keyword, eof, fully+  , calc+  , addOp+  , kwG+  , prog+  , patternsMain+  ) where++import PEG+import PEG.QQ (pegExpr, pegRules)++--------------------------------------------------------------------------------+-- Pattern 2a/2bi: whitespace and token combinators, at the PExp level+--------------------------------------------------------------------------------++-- | Zero or more layout characters.  A character class, so this compiles to a+-- single 'Span' node and returns a chunk of the input.+ws :: PExp s env ('MkTy 'True '[]) s+ws = spanOf (fromRanges [(' ', ' '), ('\t', '\t'), ('\r', '\r'), ('\n', '\n')])++-- | Run @p@, then consume /trailing/ whitespace only.+lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a+lexeme p = (\x _ -> x) <$>. p <*>. ws++-- | End of input: nothing can follow.+eof :: PExp s env ('MkTy 'True '[]) ()+eof = Not AnyChar++-- | Leading whitespace, then @p@, then end of input.+fully :: PExp s env ty a+      -> PExp s env (SeqTy ('MkTy 'True '[])+                           (SeqTy ty ('MkTy 'True '[]))) a+fully p = (\_ x _ -> x) <$>. ws <*>. p <*>. eof++--------------------------------------------------------------------------------+-- Pattern 2bii: keyword combinator+--------------------------------------------------------------------------------++identCont :: CharSet+identCont = fromRanges [('a', 'z'), ('A', 'Z'), ('0', '9'), ('_', '_')]++-- | Match a keyword that is not a prefix of a longer identifier.+--+-- The negative lookahead is the whole pattern: @keyword "negate"@ fails on+-- @negatex@ because an identifier character follows.  In a backtracking+-- combinator library this needs @try@; in a PEG it is just @!@.+keyword :: String -> PExp s env ('MkTy 'False '[]) ()+keyword k = (\_ _ -> ()) <$>. stringNE k <*>. Not (sat identCont)++--------------------------------------------------------------------------------+-- The AST, one layer per precedence level (Pattern 1b)+--------------------------------------------------------------------------------++data Expr+  = Add Expr Expr+  | Sub Expr Expr+  | Mul Expr Expr+  | Div Expr Expr+  | Neg Expr+  | Num Int+  | Var String+  deriving (Eq, Show)++data Asgn = Asgn String Expr+  deriving (Eq, Show)++evalE :: [(String, Int)] -> Expr -> Int+evalE g (Add a b) = evalE g a + evalE g b+evalE g (Sub a b) = evalE g a - evalE g b+evalE g (Mul a b) = evalE g a * evalE g b+evalE g (Div a b) = let d = evalE g b in if d == 0 then 0 else evalE g a `div` d+evalE g (Neg a)   = negate (evalE g a)+evalE _ (Num n)   = n+evalE g (Var v)   = maybe 0 id (lookup v g)++--------------------------------------------------------------------------------+-- Pattern 3a: lifted constructors+--+-- The semantic actions stay one application wide; the dispatch on which+-- constructor an operator denotes lives in ordinary Haskell.+--------------------------------------------------------------------------------++-- | Fold a left-associative chain: an operand followed by @(op, operand)@+-- pairs.  This is what @chainl1@ buys in a combinator library, written out.+chainl :: Expr -> [(Char, Expr)] -> Expr+chainl = foldl step+  where+    step l ('+', r) = Add l r+    step l ('-', r) = Sub l r+    step l ('*', r) = Mul l r+    step l ('/', r) = Div l r+    step _ (c  , _) = error ("chainl: unexpected operator " ++ show c)++mkNum :: Stream s => s -> Expr+mkNum = Num . read . chunkToString++mkVar :: Stream s => s -> Expr+mkVar = Var . chunkToString++mkAsgn :: Stream s => s -> Expr -> Asgn+mkAsgn v e = Asgn (chunkToString v) e++--------------------------------------------------------------------------------+-- Pattern 1a/1c: a precedence ladder, one rule per level+--------------------------------------------------------------------------------++type CalcEnv s =+  '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr)+   , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"])         Expr)+   , '("unary", 'EnvEntry ('MkTy 'False '["atom"])                  Expr)+   , '("atom" , 'EnvEntry ('MkTy 'False '[])                        Expr)+   ]++-- | The classic expression language.+--+-- Note what is /not/ here: no @try@, no left recursion, and no rule that can+-- loop.  @expr <- expr '+' term@ would be rejected by 'PEG.Grammar.Acyclic'+-- at compile time with a type error naming @expr@.+calc :: Stream s => Grammar s (CalcEnv s) _ Expr+calc =+  Grammar+    [pegRules|+       expr  <- t:term  ts:(o:[+-] u:term)*  { chainl t ts }+       term  <- f:unary fs:(o:[*/] g:unary)* { chainl f fs }+       unary <- '-' e:unary                  { Neg e }+              / a:atom+       atom  <- '(' e:expr ')'+              / ds:[0-9]+                    { mkNum ds }+              / &[a-zA-Z_] cs:[a-zA-Z0-9_]+  { mkVar cs }+    |]+    (nt @"expr")++-- | The same pattern inside a quasi-quoted grammar: a string literal followed+-- by a negative lookahead on the identifier-continuation class.+type KwEnv = '[ '("kw", 'EnvEntry ('MkTy 'False '[]) String) ]++kwG :: Stream s => Grammar s KwEnv _ String+kwG = Grammar [pegRules| kw <- k:"negate" ![a-zA-Z0-9_]  { k } |] (nt @"kw")++--------------------------------------------------------------------------------+-- Pattern 3b: deferred constructors+--+-- A rule may return a *function*, so the choice of constructor is made where+-- the operator is read and applied where the operands are known.  This is the+-- defunctionalised chain the paper describes, and it removes the partial+-- 'error' case from 'chainl' above.+--------------------------------------------------------------------------------++type OpEnv =+  '[ '("op", 'EnvEntry ('MkTy 'False '[]) (Expr -> Expr -> Expr)) ]++addOp :: Stream s => Grammar s OpEnv _ (Expr -> Expr -> Expr)+addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op")++--------------------------------------------------------------------------------+-- Statements, to show ordered choice and the lexeme discipline+--------------------------------------------------------------------------------++type ProgEnv s =+  '[ '("prog" , 'EnvEntry ('MkTy 'False '["asgn"]) [Asgn])+   , '("asgn" , 'EnvEntry ('MkTy 'False '[])       Asgn)+   , '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr)+   , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"])         Expr)+   , '("unary", 'EnvEntry ('MkTy 'False '["atom"])                  Expr)+   , '("atom" , 'EnvEntry ('MkTy 'False '[])                        Expr)+   ]++-- | @a := 1; b := a * 2@+--+-- @':='@ comes before @':'@ nowhere in this grammar, but the ordering rule it+-- 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 =+  Grammar+    [pegRules|+       prog  <- a:asgn as:(';' b:asgn)*      { a : as }+       asgn  <- &[a-zA-Z_] v:[a-zA-Z0-9_]+ ":=" e:expr  { mkAsgn v e }++       expr  <- t:term  ts:(o:[+-] u:term)*  { chainl t ts }+       term  <- f:unary fs:(o:[*/] g:unary)* { chainl f fs }+       unary <- '-' e:unary                  { Neg e }+              / a:atom+       atom  <- '(' e:expr ')'+              / ds:[0-9]+                    { mkNum ds }+              / &[a-zA-Z_] cs:[a-zA-Z0-9_]+  { mkVar cs }+    |]+    (nt @"prog")++--------------------------------------------------------------------------------+-- Demonstration+--------------------------------------------------------------------------------++showR :: Show a => Result String a -> String+showR (OK a _ r) = "OK " ++ show a ++ (if null r then "" else " rest=" ++ show r)+showR Fail       = "Fail"++patternsMain :: IO ()+patternsMain = do+  putStrLn "### precedence ladder"+  mapM_ (\s -> putStrLn (show s ++ " => " ++ show (fmap' (evalE []) (parse calc s))))+    [ "1+2*3", "(1+2)*3", "2*3+4", "-3+4", "10/2/5", "1-2-3", "x" ]++  putStrLn "### ordered choice / statements"+  mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (parse prog s)))+    [ "a:=1", "a:=1;b:=a*2", "a:=", "a:=1;" ]++  putStrLn "### keyword vs bare literal"+  -- No 'fully' here: the point is what each one leaves behind.+  let kw   = parse (Grammar RNil (keyword "negate"))+               :: String -> Result String ()+      bare = parse (Grammar RNil (const () <$>. stringNE "negate"))+               :: String -> Result String ()+  mapM_ (\s -> putStrLn (show s ++ " keyword => " ++ showR (kw s)+                           ++ " | bare => " ++ showR (bare s)))+    [ "negate", "negatex", "negate2", "negate x" ]++  putStrLn "### keyword, in quasi-quoter syntax"+  mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (parse kwG s)))+    [ "negate", "negatex", "negate x" ]++  putStrLn "### deferred constructor: a rule returning a function"+  mapM_ (\s -> putStrLn (show s ++ " => " +++          case parse addOp s of+            OK f _ _ -> show (f (Num 1) (Num 2))+            Fail     -> "Fail"))+    [ "+", "-", "*" ]++  putStrLn "### lexeme discipline: fully (lexeme p)"+  let toks = parse (Grammar RNil (fully (lexeme [pegExpr| ds:[0-9]+ |])))+               :: String -> Result String String+  mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (toks s)))+    [ "12", "  12  ", "12 x", "" ]+  where+    fmap' f (OK a _ _) = Just (f a)+    fmap' _ Fail       = Nothing

@@ -0,0 +1,573 @@+# PEG patterns for typed-peg++A companion to Jamie Willis and Nicolas Wu, *Design Patterns for Parser+Combinators (Functional Pearl)*, Haskell 2021+([10.1145/3471874.3472984](https://doi.org/10.1145/3471874.3472984)).++That paper collects eleven patterns for writing parsers with a backtracking+combinator library of the `parsec` family. Most of them transfer to typed-peg,+but three things change the picture:++- **Ordered choice is committed.** Once an alternative succeeds, a PEG never+  reconsiders it. There is no `try`, because there is nothing to undo — but the+  order in which you write alternatives becomes part of the specification.+- **Left recursion is a type error**, not a discipline to remember. The+  `Acyclic` constraint is checked when you construct a `Grammar`.+- **The grammar's shape is written down in a type.** The `Env` records every+  rule's nullability, FIRST set and result type. Several of the paper's+  patterns become things the compiler enforces rather than things you adopt.++Every code fragment below is compiled: it lives in+[`examples/Patterns.hs`](examples/Patterns.hs) and runs as part of+`cabal test`.++## The patterns at a glance++| Willis & Wu | In typed-peg |+|---|---|+| 1a Homogeneous Chains | [§1.2](#12-chains-fold-a-starred-tail) — write the fold out; no `chainl1` |+| 1b Heterogeneous Chains | [§1.3](#13-one-rule-per-precedence-level) — one rule per level, types declared in the `Env` |+| 1c Precedence Tables | [§1.4](#14-precedence-tables-absent-but-not-impossible) — absent; what it would take |+| 2a Whitespace Combinators | [§2.1](#21-consume-trailing-whitespace-only) — `lexeme` / `fully`, same discipline |+| 2bi Tokenizing Combinators | [§2.2](#22-tokens) — same |+| 2bii Keyword Combinators | [§2.3](#23-keywords-are-negative-lookahead) — **simpler**: `!` instead of `try` |+| 2c Overloaded Strings | [§2.4](#24-the-quasi-quoter-is-the-facade) — subsumed by the quasi-quoter |+| 3a Lifted Constructors | [§3.1](#31-lifted-constructors) — same |+| 3b Deferred Constructors | [§3.2](#32-deferred-constructors-and-the-position-gap) — **partly**; no source positions |+| 4a Verified Errors | [§4](#4-errors-the-shape-without-the-message) — shape only; no messages |+| 4b Preventative Errors | [§4](#4-errors-the-shape-without-the-message) — shape only; no messages |++Sections [§5](#5-patterns-that-are-specific-to-pegs) and+[§6](#6-what-typed-peg-cannot-do-yet) add patterns the paper has no reason to+cover, and summarise the gaps.++---++## 1. Expressions++### 1.1 Left recursion is a type error++The paper opens by writing the textbook grammar directly:++```haskell+expr = Add <$> expr <*> (char '+' *> term) <|> ... <|> term+```++and observing that it loops. Section 2 is then about the rewrite that fixes it.++In typed-peg you cannot write it in the first place. Each rule's type carries+its FIRST set, and `Grammar` demands `Acyclic env`:++```+expr <- e:expr '+' t:term { Add e t }+```++```+Left-recursive non-terminal: "expr"+Its head set already contains itself: ["expr", "term"]+Violates the acyclicity condition i `notElem` Gamma(i).F.+```++reported at the `Grammar` constructor, before anything runs.++**Pattern.** Do not treat left-recursion removal as a step you perform. Write+the grammar; if it compiles, no rule can loop on its own head. The rewrite+below is then the *only* shape available, which is why it is worth having a+name for.++### 1.2 Chains: fold a starred tail++*(Willis & Wu, Pattern 1a: Homogeneous Chains.)*++Their advice is to reach for `chainl1`/`chainr1` rather than hand-rolling+associativity. typed-peg has no chain combinator, so the pattern is the shape+you write instead: **an operand, then a starred tail of (operator, operand)+pairs, folded in the semantic action.**++```+expr <- t:term  ts:(o:[+-] u:term)*  { chainl t ts }+```++Left association comes from `foldl`, right association from `foldr`. Keep the+fold itself in Haskell, out of the grammar:++```haskell+chainl :: Expr -> [(Char, Expr)] -> Expr+chainl = foldl step+  where+    step l ('+', r) = Add l r+    step l ('-', r) = Sub l r+    step l ('*', r) = Mul l r+    step l ('/', r) = Div l r+    step _ (c  , _) = error ("chainl: unexpected operator " ++ show c)+```++The `error` case is the price of a homogeneous chain: the operator is a `Char`,+so nothing stops a mismatched table. The paper makes exactly this observation,+and its answer is the next pattern.++### 1.3 One rule per precedence level++*(Willis & Wu, Pattern 1b: Heterogeneous Chains.)*++Their fix is to give each precedence level its own AST layer so the types rule+out a mismatched chain. In typed-peg the level structure is *already* forced on+you — a PEG expresses precedence by descent — and the `Env` makes you declare+what each level produces:++```haskell+type CalcEnv s =+  '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr)+   , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"])         Expr)+   , '("unary", 'EnvEntry ('MkTy 'False '["atom"])                  Expr)+   , '("atom" , 'EnvEntry ('MkTy 'False '[])                        Expr)+   ]+```++```+expr  <- t:term  ts:(o:[+-] u:term)*  { chainl t ts }+term  <- f:unary fs:(o:[*/] g:unary)* { chainl f fs }+unary <- '-' e:unary                  { Neg e }+       / a:atom+atom  <- '(' e:expr ')'+       / ds:[0-9]+                    { mkNum ds }+       / &[a-zA-Z_] cs:[a-zA-Z0-9_]+  { mkVar cs }+```++**Pattern.** Give each level a distinct result type in the `Env` when you want+the paper's type safety. Above, every level produces `Expr`, which is the+homogeneous choice; changing `term` to produce a `Term` and `expr` an `Expr`+makes a misplaced operator a type error, exactly as in the paper — at the cost+of an AST with one constructor per layer.++Note the FIRST set columns. They are not decoration: `'["atom", "term", "unary"]` says that entering `expr` can immediately enter any of those, and it+is what the acyclicity check consumes. Getting them wrong is a compile error,+so they double as a checked comment.++A FIRST set is written in **alphabetical order**, and with no repeats. The+order is not a matter of taste: it is what makes a set have exactly one+spelling, which in turn lets the compiler take the union of two FIRST sets in+one merge pass instead of re-scanning one of them for every element of the+other. Write `'["atom", "term", "unary"]`, not `'["term", "unary", "atom"]`;+the latter is a type error naming the first position that disagrees.++### 1.4 Precedence tables: absent, but not impossible++*(Willis & Wu, Pattern 1c: Precedence Tables.)*++Their `precedence` combinator folds a table of levels into the ladder:++```haskell+expr = precedence $+  sops InfixL [Add <$ char '+', Sub <$ char '-'] +<+  sops InfixL [Mul <$ char '*']                  +<+  sops Prefix [Neg <$ string "negate"]           +<+  Atom atom+```++**typed-peg does not provide this**, and adding it is more than a convenience+wrapper — but less than impossible, so it is worth being precise about what it+would take.++`Prec` in the paper is already a type-indexed structure: each `Op a b`+connects a layer producing `a` to one producing `b`, which is what makes+adding or removing a level a type error. A typed-peg version would have to+carry the `Ty` index as well, since every `PExp` is indexed by its nullability+and FIRST set:++```haskell+data Prec s env ty a where ...      -- sketch, not implemented+```++The good news is that the `Ty` arithmetic is tractable. Precedence layers are+anonymous `PExp` values rather than named non-terminals, and FIRST sets track+only non-terminal names — so every layer built from operators and a starred+tail has an empty FIRST set, and its nullability follows from `SeqTy`. What is+needed is a GADT whose indices compose the way `SeqTy` and `ChoiceTy` do, plus+`infixl1`/`infixr1`/`prefix`/`postfix` at the `PExp` level.++Until then, write the levels out as in §1.3. For four or five levels that is+barely longer than the table, and it keeps each level visible in the `Env`.++---++## 2. Lexing++### 2.1 Consume trailing whitespace only++*(Willis & Wu, Pattern 2a: Whitespace Combinators.)*++Their rule, which transfers unchanged: **every lexeme consumes the whitespace+*after* it, never before; one `fully` at the top consumes leading whitespace+and demands end of input.** Consuming leading whitespace inside a lexeme breaks+position reporting and makes it ambiguous who is responsible for a given space.++```haskell+ws :: PExp s env ('MkTy 'True '[]) s+ws = spanOf (fromRanges [(' ', ' '), ('\t', '\t'), ('\r', '\r'), ('\n', '\n')])++lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a+lexeme p = (\x _ -> x) <$>. p <*>. ws++eof :: PExp s env ('MkTy 'True '[]) ()+eof = Not AnyChar++fully :: PExp s env ty a+      -> PExp s env (SeqTy ('MkTy 'True '[])+                           (SeqTy ty ('MkTy 'True '[]))) a+fully p = (\_ x _ -> x) <$>. ws <*>. p <*>. eof+```++```+"12"     => OK "12"+"  12  " => OK "12"+"12 x"   => Fail+""       => Fail+```++Two typed-peg specifics. `ws` is a character class, so it compiles to a single+`Span` node and returns a chunk of the input — over `Text` that is a slice, and+when the item is unlabelled in a quasi-quoted rule the chunk is discarded+anyway. And `eof` is `Not AnyChar`, written `!.` in the quasi-quoter: a PEG+gets end-of-input from negative lookahead rather than from a primitive.++**`fully` matters more in a PEG than in `parsec`.** A PEG parser is happy to+succeed on a prefix:++```+"a:=1;" => OK [Asgn "a" (Num 1)] rest=";"+```++Nothing is wrong here — the grammar matched what it could. If you want the+whole input consumed you must say so, and `fully` is where you say it.++### 2.2 Tokens++*(Willis & Wu, Pattern 2bi: Tokenizing Combinators.)*++Same pattern: annotate terminals with `lexeme`, not the composite rules. Their+`token = lexeme . try` loses its `try` here, since ordered choice needs no+backtracking marker.++In a quasi-quoted grammar the usual spelling is a `ws` rule invoked after each+terminal, as `examples/Layout.hs` and the JSON benchmark do:++```+pair <- k:strlit ws ':' ws v:value  { (k, v) }+```++**Keep the `ws` calls at terminal boundaries and nowhere else.** A `ws` in the+middle of a composite rule is the same mistake as leading whitespace in a+lexeme: it makes two rules disagree about who owns the space between them.++### 2.3 Keywords are negative lookahead++*(Willis & Wu, Pattern 2bii: Keyword Combinators.)*++This is the pattern a PEG expresses best. The problem is that `string "negate"`+happily matches the prefix of `negatex`. Their answer is a `keyword` combinator+that checks no identifier character follows — which in `parsec` needs `try` to+undo the partial match.++In a PEG it is just `!`:++```haskell+keyword :: String -> PExp s env ('MkTy 'False '[]) ()+keyword k = (\_ _ -> ()) <$>. stringNE k <*>. Not (sat identCont)+```++or, in the quasi-quoter, `"negate" ![a-zA-Z0-9_]`.++```+"negate"   keyword => OK ()          | bare => OK ()+"negatex"  keyword => Fail           | bare => OK () rest="x"+"negate2"  keyword => Fail           | bare => OK () rest="2"+"negate x" keyword => OK () rest=" x"| bare => OK () rest=" x"+```++The `bare` column is the bug the pattern prevents: without the lookahead,+`negatex` parses as the keyword `negate` followed by the variable `x`.++**The same shape covers every longest-match ambiguity**, not only keywords:+`'<' !'='` is "less-than, but not the start of `<=`". See §5.1 for the+alternative spelling.++### 2.4 The quasi-quoter is the facade++*(Willis & Wu, Pattern 2c: Overloaded Strings.)*++Their goal is to write `"if" *> expr` and have the string literal quietly+become a tokenizing parser, via `IsString`. The quasi-quoter already provides+this, and more directly: inside `[pegRules| ... |]`, `"do"` *is* a string+literal in grammar syntax, `[a-z]` is a character class, and `/` is ordered+choice. There is no Haskell-level plumbing to hide.++The residue of the pattern still applies: **keep token definitions in one+place.** A rule named `ident` or `number` used everywhere beats the same+character class copy-pasted into five rules — not for concision, but because+the `Env` then names it, and a change happens once.++---++## 3. Building the AST++### 3.1 Lifted constructors++*(Willis & Wu, Pattern 3a: Lifted Constructors.)*++Their advice — put bookkeeping in a smart constructor so the parser reads like+the grammar — transfers unchanged, and typed-peg gives it an extra job. Because+a character class produces a chunk of the stream rather than a `String`, the+conversion belongs in the smart constructor rather than smeared through the+actions:++```haskell+mkNum :: Stream s => s -> Expr+mkNum = Num . read . chunkToString++mkVar :: Stream s => s -> Expr+mkVar = Var . chunkToString+```++```+atom <- '(' e:expr ')'+      / ds:[0-9]+                    { mkNum ds }+      / &[a-zA-Z_] cs:[a-zA-Z0-9_]+  { mkVar cs }+```++**Keep semantic actions one application wide.** An action is Haskell spliced+unhygienically into the generated code; a long one is hard to read in grammar+syntax and hard to debug when it fails to typecheck, because the error points+at the quasi-quote.++### 3.2 Deferred constructors, and the position gap++*(Willis & Wu, Pattern 3b: Deferred Constructors.)*++Their motivating example is source positions: a node needs the position from+*before* its first token, so the constructor is returned by a parser and+applied later.++**typed-peg cannot do this**, because no combinator exposes the current+position to a semantic action. `PState` tracks `stCol` and `stOff`, and+`PEG.Indent` uses columns for layout, but neither is reachable from `{ ... }`.+A grammar cannot annotate its AST with source locations.++What does transfer is the general form — returning a function to be applied+later, so that bookkeeping is decoupled from the parser. In typed-peg this is+just a rule whose result type is a function:++```haskell+type OpEnv = '[ '("op", 'EnvEntry ('MkTy 'False '[]) (Expr -> Expr -> Expr)) ]++addOp :: Stream s => Grammar s OpEnv _ (Expr -> Expr -> Expr)+addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op")+```++```+"+" => Add (Num 1) (Num 2)+"-" => Sub (Num 1) (Num 2)+"*" => Fail+```++The rule's result type is a function, and the chain rule applies it. This is the same defunctionalisation the paper describes, and it+removes the partial `error` case from §1.2's `chainl`.++See §6: exposing position is the single change that would unlock the most of+this paper.++---++## 4. Errors: the shape without the message++*(Willis & Wu, Patterns 4a Verified Errors and 4b Preventative Errors.)*++Their patterns are about *messages*: use `lookAhead` to check that an error is+warranted before raising it, and `notFollowedBy` to rule out input that would+otherwise produce a confusing failure further along.++**typed-peg has no error messages at all.** `Result` is++```haskell+data Result s a = OK a s s | Fail+```++There is no position, no expected set, no label. Both patterns are therefore+unavailable in their stated form.++The *rejection* half still works, and is worth using. Preventative errors+become preventative failures:++```+asgn <- &[a-zA-Z_] v:[a-zA-Z0-9_]+ ":=" e:expr !'<'  { mkAsgn v e }+```++— an assignment whose right-hand side is followed by `<` is rejected here+rather than half-consumed and rejected somewhere less obvious. You lose the+message; you keep the locality.++Positive lookahead `&e` is `Not (Not e)`, so the verification half of Pattern+4a is expressible as a guard even though nothing can be reported.++---++## 5. Patterns that are specific to PEGs++### 5.1 In an ordered choice, the longest alternative goes first++Nothing in the paper needs this, because `<|>` with `try` reconsiders. A PEG+commits to the first success:++```+op <- '<'  / '<='      -- WRONG: '<=' is never reached+op <- '<=' / '<'       -- right+```++The first line silently parses `a <= b` as `a < (= b)` and then fails+somewhere else entirely. There is no warning: both grammars typecheck, and both+have the same FIRST set.++**Pattern.** When two alternatives share a prefix, order them longest-first.+When that is awkward — because the alternatives are non-terminals whose lengths+are not obvious — use the §2.3 lookahead spelling instead, which states the+constraint locally rather than relying on the order of a list.++This is the one place where typed-peg's type-level machinery does *not* help,+and it is worth knowing that the acyclicity check is not a substitute for+thinking about the order.++### 5.2 Prefer a negated class to the `!c .` idiom++The traditional PEG spelling of "any character except a quote" is+`(!'"' .)*` — a negative lookahead followed by a wildcard, which inspects+every character twice. typed-peg's quasi-quoter accepts a negated class:++```+q <- '"' cs:[^"]* '"'        -- one bit test per character+q <- '"' cs:(!'"' c:.)* '"'  -- two passes per character, and a cons list+```++The two describe the same language. On the benchmark suite the class form+allocates **90 bytes per input byte against 209**, and runs about **1.5×+faster**. It also returns a chunk of the stream rather than a `[Char]`.++**Pattern.** Reach for `[^...]` whenever the lookahead is a single character.+Keep `!e` for the cases a class cannot express — a keyword boundary, a+multi-character sentinel, a non-terminal.++### 5.3 A starred character class returns a chunk++`[a-z]*` and `[a-z]+` compile to `Span`/`Span1` and produce a slice of the+input stream, not a `[Char]`. That has a consequence for a very common idiom:++```+ident <- c:[a-zA-Z_] cs:[a-zA-Z0-9_]*  { c : cs }+```++`c` is a `Char` and `cs` is a chunk. This still compiles if the grammar is+fixed to `String` — where a chunk *is* a `[Char]` — but a stream-polymorphic+grammar is rejected:++```+Couldn't match expected type 's' with actual type '[Char]'+  's' is a rigid type variable bound by the inferred type of+    identG :: Stream s => Grammar s (IdEnv s) (MkTy False '["ident"]) s+```++So the idiom quietly ties a grammar to one stream. The fix is also faster,+because it scans once instead of twice and copies nothing:++```+ident <- &[a-zA-Z_] cs:[a-zA-Z0-9_]+   { cs }+```++The positive lookahead pins the first character to the narrower class without+consuming it, then one span takes the whole identifier.++**Pattern.** When a token is "one character from class A, then characters from+class B" and A is a subset of B, write it as `&A B+`.++### 5.4 The `Env` is a specification, so write it first++The environment is not boilerplate to be derived from the rules — it is the+grammar's interface, and it is checked:++```haskell+type CalcEnv s =+  '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr)+   , ...+   ]+```++Each entry states three things: whether the rule can match the empty string,+which non-terminals it can enter first, and what it produces. All three are+verified against the rule bodies.++**Pattern.** Write the `Env` before the rules, as you would write a signature+before a function. When a rule's FIRST set surprises you, that is usually the+grammar telling you something — a rule that is unexpectedly nullable is often a+`*` that should have been a `+`.++Two practical notes. A rule whose result is a character-class repetition has+result type `s`, so its `Env` synonym takes the stream as a parameter+(`CalcEnv s`). And GHC's error when an entry is wrong points at the whole+quasi-quote, not at the offending rule — so add rules a few at a time.++### 5.5 Layout is a grammar concern, not a lexer concern++`PEG.Indent` gives rules a column relation, so indentation-sensitive syntax+stays in the grammar instead of being pushed into a layout-inserting lexer:++```+istmts <- ss:(ws st:|s:stmt|)+^>          -- each statement strictly indented+stmts  <- r:(ws '{' ... ws '}')^~         -- braces: any column+```++`^>`, `^~`, `^=` and `_~` attach a relation to a sub-expression. This has no+counterpart in the paper, whose language is layout-insensitive.++**Pattern.** Give the brace form and the layout form as two alternatives of one+rule, with the relation attached to each, rather than deciding between them+before parsing.++---++## 6. What typed-peg cannot do yet++Collected from above, in the order that would most help a user of this library:++1. **Source positions in semantic actions.** Blocks Pattern 3b's motivating+   use and any AST that records where its nodes came from. `PState` already+   carries `stOff` and `stCol`; what is missing is a `PExp` constructor that+   hands them to an action.+2. **Error messages.** `Result` is `OK` or `Fail`. Patterns 4a and 4b are+   about phrasing good errors, and neither can be expressed. This is the+   largest single gap between typed-peg and the paper.+3. **A `precedence` combinator.** Needs a `Ty`-indexed `Prec` GADT and+   `infixl1`/`infixr1`/`prefix`/`postfix` at the `PExp` level (§1.4). Real+   work, but the index arithmetic is tractable.+4. **Chain combinators.** `chainl1`/`chainr1` are a small, unblocked+   convenience: they would remove the hand-written `foldl` from every+   expression grammar.+5. **A token/lexeme vocabulary in the quasi-quoter.** `lexeme`, `keyword` and+   `fully` are ten lines each (§2.1, §2.3) but every user writes them again.++None of 1, 2, 4 or 5 is blocked by the type-level design; they are absent+rather than impossible.++---++## Reading the examples++```bash+cabal test typed-peg-examples+```++runs `examples/Patterns.hs` along with the rest, printing the output quoted+throughout this document. The grammars are in:++- [`examples/Patterns.hs`](examples/Patterns.hs) — every fragment above+- [`examples/Arith.hs`](examples/Arith.hs) — the minimal precedence ladder+- [`examples/Layout.hs`](examples/Layout.hs) — indentation-sensitive `do`+- [`bench/Bench/Peg.hs`](bench/Bench/Peg.hs) — JSON, CSV, and the two+  quoted-string spellings of §5.2

@@ -19,7 +19,9 @@ -- -- See the @examples/@ directory for complete working grammars. module PEG-  ( module PEG.Type+  ( module PEG.CharSet+  , module PEG.Stream+  , module PEG.Type   , module PEG.TyLevel   , module PEG.Member   , module PEG.Indent@@ -28,7 +30,9 @@   , module PEG.Parse   ) where +import PEG.CharSet import PEG.Grammar+import PEG.Stream import PEG.Indent import PEG.Member import PEG.Parse

@@ -0,0 +1,105 @@+{-# LANGUAGE BangPatterns #-}++-- | Compact character sets used by the 'PEG.Syntax.Sat' combinator.+--+-- A character class such as @[a-zA-Z0-9_]@ used to be compiled into a chain of+-- 63 ordered choices, so matching a single character could cost 63 parser+-- steps.  A 'CharSet' answers the same question with one bit test.+--+-- The Latin-1 range (@\\0@ .. @\\255@), which covers essentially every class+-- that appears in a practical grammar, is stored as a 256-bit bitmap held in+-- four 'Word64's.  Characters above that range fall back to a list of ranges.+module PEG.CharSet+  ( CharSet (..)+  , memberCS+  , fromRanges+  , notInRanges+  , fromList+  , singletonCS+  , complementCS+  , nullCS+  , anyCS+  ) where++import Data.Bits (setBit, testBit)+import Data.Char (chr, ord)+import Data.Word (Word64)++-- | A set of characters.  The four 'Word64' fields form a bitmap of the+-- Latin-1 range; 'csWide' holds any ranges that reach beyond it.+--+-- Negation is a flag rather than an actual complement, so a negated class is+-- exactly as cheap to test as a positive one and stays exact for the whole of+-- 'Char' (complementing the ranges above Latin-1 explicitly would not).+data CharSet = CharSet+  { csNeg  :: !Bool+  , csB0   :: !Word64+  , csB1   :: !Word64+  , csB2   :: !Word64+  , csB3   :: !Word64+  , csWide :: ![(Char, Char)]+  }+  deriving (Eq, Show)++-- | Is the character a member of the set?  @O(1)@ for Latin-1 characters.+memberCS :: Char -> CharSet -> Bool+memberCS c cs = csNeg cs /= rawMember c cs+{-# INLINE memberCS #-}++-- | Membership ignoring the negation flag.+rawMember :: Char -> CharSet -> Bool+rawMember c (CharSet _ b0 b1 b2 b3 wide)+  | n < 64    = testBit b0 n+  | n < 128   = testBit b1 (n - 64)+  | n < 192   = testBit b2 (n - 128)+  | n < 256   = testBit b3 (n - 192)+  | otherwise = inWide wide+  where+    !n = ord c+    inWide []              = False+    inWide ((lo, hi) : rs) = (n >= ord lo && n <= ord hi) || inWide rs+{-# INLINE rawMember #-}++-- | Build a set from a list of inclusive character ranges.+fromRanges :: [(Char, Char)] -> CharSet+fromRanges = mkRanges False++-- | The complement of 'fromRanges': every character /outside/ the given+-- ranges.  This is what the quasi-quoter emits for @[^\"]@.+notInRanges :: [(Char, Char)] -> CharSet+notInRanges = mkRanges True++-- | Flip a set\'s polarity.+complementCS :: CharSet -> CharSet+complementCS cs = cs { csNeg = not (csNeg cs) }++mkRanges :: Bool -> [(Char, Char)] -> CharSet+mkRanges neg rs = CharSet neg (word 0) (word 64) (word 128) (word 192) wide+  where+    lows = [ n | (lo, hi) <- rs, n <- [ord lo .. min 255 (ord hi)] ]++    word base = go 0 lows+      where+        go !w []       = w+        go !w (n : ns)+          | n >= base && n < base + 64 = go (setBit w (n - base)) ns+          | otherwise                  = go w ns++    wide = [ (max lo (chr 256), hi) | (lo, hi) <- rs, ord hi > 255 ]++-- | Build a set from an explicit list of characters.+fromList :: [Char] -> CharSet+fromList cs = fromRanges [ (c, c) | c <- cs ]++-- | The set containing exactly one character.+singletonCS :: Char -> CharSet+singletonCS c = fromRanges [(c, c)]++-- | The set of every character.  This is what @.*@ compiles to.+anyCS :: CharSet+anyCS = notInRanges []++-- | Is the set empty?+nullCS :: CharSet -> Bool+nullCS (CharSet False 0 0 0 0 []) = True+nullCS _                          = False

@@ -29,35 +29,44 @@  -- | A typed, heterogeneous list of named grammar rules. ----- @'Rules' env defs@ is a list of rules whose bodies reference non-terminals--- in @env@ and whose definitions together form @defs@.-data Rules (env :: Env) (defs :: Env) where-  RNil  :: Rules env '[]-  RCons :: Name s-        -> PExp env ty a-        -> Rules env rest-        -> Rules env ('(s, 'EnvEntry ty a) ': rest)+-- @'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+-- @defs@.+data Rules (s :: Type) (env :: Env) (defs :: Env) where+  RNil  :: Rules s env '[]+  RCons :: Name n+        -> PExp s env ty a+        -> Rules s env rest+        -> Rules s env ('(n, 'EnvEntry ty a) ': rest)  type family Acyclic (env :: Env) :: Constraint where-  Acyclic '[]                             = ()-  Acyclic ('(s, 'EnvEntry ty _) ': rest) =-    (NotLeftRec s (Elem s (First ty)) ty, Acyclic rest)+  Acyclic '[]                                      = ()+  Acyclic ('(s, 'EnvEntry ('MkTy _ f) _) ': rest) =+    (NotLeftRec s (Elem s f) f, Acyclic rest) -type family NotLeftRec (s :: Symbol) (b :: Bool) (ty :: Ty) :: Constraint where-  NotLeftRec _ 'False _  = ()-  NotLeftRec s 'True  ty =+type family NotLeftRec (s :: Symbol) (b :: Bool)+                       (f :: [Symbol]) :: Constraint where+  NotLeftRec _ 'False _ = ()+  NotLeftRec s 'True  f =     TypeError ('Text "Left-recursive non-terminal: " ':<>: 'ShowType s          ':$$: 'Text "Its head set already contains itself: "-               ':<>: 'ShowType (First ty)+               ':<>: 'ShowType f          ':$$: 'Text "Violates the acyclicity condition i `notElem` Gamma(i).F.") --- | A complete PEG grammar: a set of mutually recursive rules and a start--- expression.+-- | A complete PEG grammar over the stream @s@: a set of mutually recursive+-- rules and a start expression. --+-- 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 ty 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.+-- -- Constructing a 'Grammar' value discharges the 'Acyclic' constraint, so -- any left-recursion in @env@ becomes a compile-time type error.-data Grammar (env :: Env) (startTy :: Ty) (startA :: Type) where+data Grammar (s :: Type) (env :: Env) (startTy :: Ty) (startA :: Type) where   Grammar :: Acyclic env-          => Rules env env-          -> PExp env startTy startA-          -> Grammar env startTy startA+          => Rules s env env+          -> PExp s env startTy startA+          -> Grammar s env startTy startA

@@ -76,6 +76,13 @@  data RelD = RelD   { rdName      :: String+  , rdTotal     :: !Bool+    -- ^ 'True' when the relation places no constraint at all on columns, i.e.+    -- when @'preimage' rd i == 'fullI'@ and @'image' rd j@ leaves the+    -- candidate interval untouched, for every non-empty @i@ and every @j@.+    -- Only 'anyR' satisfies this.  The parser uses the flag to skip all+    -- interval arithmetic on grammars that do not use layout, which is the+    -- overwhelmingly common case.   , rdDom       :: Interval   , rdLo        :: Int -> Int   , rdHi        :: Int -> Bound@@ -126,6 +133,7 @@ eqR :: Rel "=" eqR = Rel RelD   { rdName      = "="+  , rdTotal     = False   , rdDom       = fullI   , rdLo        = id   , rdHi        = Fin@@ -143,6 +151,7 @@ gapD :: String -> Int -> RelD gapD name k = RelD   { rdName      = name+  , rdTotal     = False   , rdDom       = Interval k Inf   , rdLo        = const 0   , rdHi        = \i -> Fin (i - k)@@ -163,6 +172,7 @@ anyR :: Rel "~" anyR = Rel RelD   { rdName      = "~"+  , rdTotal     = True   , rdDom       = fullI   , rdLo        = const 0   , rdHi        = const Inf@@ -177,6 +187,7 @@ constR :: Int -> Rel "const" constR c = Rel RelD   { rdName      = "const " ++ show c+  , rdTotal     = False   , rdDom       = singletonI c   , rdLo        = const 0   , rdHi        = const Inf@@ -191,6 +202,7 @@ offsetR :: Int -> Rel "offset" offsetR k = Rel RelD   { rdName      = "+" ++ show k+  , rdTotal     = False   , rdDom       = Interval k Inf   , rdLo        = \i -> i - k   , rdHi        = \i -> Fin (i - k)

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-}@@ -5,16 +6,27 @@ {-# LANGUAGE KindSignatures        #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}  -- | Membership witnesses for heterogeneous type-level environments. ----- 'Member' is a proof that a name @s@ with type @ty@ and result @a@ is--- present in the environment @env@.  'KnownMember' is the class that allows--- the proof to be materialised from type information at runtime, enabling--- non-terminal lookup during parsing.+-- 'Member' is a proof that a name @s@ with result type @a@ is present in the+-- environment @env@.  'KnownMember' is the class that allows the proof to be+-- materialised from type information at runtime, enabling non-terminal lookup+-- during parsing.+--+-- == Why the 'PEG.Type.Ty' is not an index+--+-- The witness deliberately does /not/ record the non-terminal's+-- 'PEG.Type.Ty'.  Resolving @KnownMember s env a@ walks @env@ one instance at+-- a time, and every index of the class is carried along — and re-normalised —+-- at each of those steps.  A 'PEG.Type.Ty' carries a FIRST set, so an index+-- for it makes each step cost @O(|env|)@ instead of @O(1)@.  Nothing needs+-- it: 'Here' binds the entry's @ty@ existentially, which is enough to pull+-- the matching rule out of a rule table. module PEG.Member   ( Member (..)   , KnownMember (..)@@ -22,35 +34,41 @@  import Data.Kind    (Type) import Data.Proxy   (Proxy (..))-import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError)+import GHC.TypeLits (CmpSymbol, ErrorMessage (..), Symbol, TypeError)  import PEG.Type-import PEG.TyLevel (SymEq) -data Member (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where-  Here  :: Member s ('(s, 'EnvEntry ty a) ': rest) ty a-  There :: Member s rest ty a -> Member s (e ': rest) ty a+-- | @'Member' s env a@ witnesses that @env@ binds the name @s@ to a rule+-- returning @a@, and records /where/ in @env@ that binding is.+data Member (s :: Symbol) (env :: Env) (a :: Type) where+  Here  :: Member s ('(s, 'EnvEntry ty a) ': rest) a+  There :: Member s rest a -> Member s (e ': rest) a -class KnownMember (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where-  member :: Member s env ty a+class KnownMember (s :: Symbol) (env :: Env) (a :: Type) where+  member :: Member s env a  instance TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s                ':$$: 'Text "The grammar has no rule for this name.")-      => KnownMember s '[] ty a where+      => KnownMember s '[] a where   member = error "PEG.Member: unreachable" -instance KnownMember' (SymEq s t) s ('(t, e) ': rest) ty a-      => KnownMember s ('(t, e) ': rest) ty a where-  member = member' (Proxy :: Proxy (SymEq s t))+-- Dispatch on 'CmpSymbol' directly rather than through a @SymEq@ wrapper:+-- that is one fewer type-family application to reduce per entry scanned, and+-- an environment is scanned once per occurrence of every non-terminal.+instance KnownMemberStep (CmpSymbol s t) s ('(t, e) ': rest) a+      => KnownMember s ('(t, e) ': rest) a where+  member = memberStep (Proxy :: Proxy (CmpSymbol s t)) -class KnownMember' (b :: Bool) (s :: Symbol) (env :: Env)-                   (ty :: Ty) (a :: Type) where-  member' :: Proxy b -> Member s env ty a+class KnownMemberStep (o :: Ordering) (s :: Symbol) (env :: Env) (a :: Type) where+  memberStep :: Proxy o -> Member s env a -instance (s ~ t, e ~ 'EnvEntry ty a)-      => KnownMember' 'True s ('(t, e) ': rest) ty a where-  member' _ = Here+-- The entry is taken apart in the instance head, so @ty@ is bound by+-- matching and never has to be threaded through the class.+instance (s ~ t) => KnownMemberStep 'EQ s ('(t, 'EnvEntry ty a) ': rest) a where+  memberStep _ = Here -instance KnownMember s rest ty a-      => KnownMember' 'False s ('(t, e) ': rest) ty a where-  member' _ = There member+instance KnownMember s rest a => KnownMemberStep 'LT s ('(t, e) ': rest) a where+  memberStep _ = There member++instance KnownMember s rest a => KnownMemberStep 'GT s ('(t, e) ': rest) a where+  memberStep _ = There member

@@ -1,70 +1,121 @@+{-# LANGUAGE BangPatterns        #-} {-# LANGUAGE DataKinds           #-} {-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE MagicHash           #-} {-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeAbstractions    #-} {-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeFamilies        #-} {-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE UnboxedSums         #-}+{-# LANGUAGE UnboxedTuples       #-} --- | Running a 'Grammar' against a 'String'.+-- | Running a 'Grammar' against an input stream. -- -- The top-level entry points are 'parse' (uses 'defaultOpts') and 'parseWith' -- (accepts custom 'Opts' for indentation-sensitive parsing).  Both return a -- 'Result' that records the matched value, the consumed prefix, and the -- remaining suffix.+--+-- The input can be any "PEG.Stream" instance: 'String', strict or lazy+-- 'Data.Text.Text', strict or lazy 'Data.ByteString.ByteString'.+--+-- == Compiling once, parsing many times+--+-- 'parseWith' is written so that @'parseWith' opts g@ is a /closure/ that has+-- already traversed the grammar: every non-terminal reference has been+-- resolved to a function, and no 'PExp' constructor is examined again while+-- input is being consumed.  Bind it once and reuse it:+--+-- @+-- myParser :: String -> Result String Exp+-- myParser = parse myGrammar     -- compiled once, at first use+-- @+--+-- Writing @'parse' myGrammar input@ inline inside a loop instead re-does the+-- traversal on every call.  Give the binding a /monomorphic/ signature: a+-- grammar left polymorphic in its stream is a function of a 'Stream'+-- dictionary rather than a constant, so nothing is shared between calls.+--+-- == Why the result of a step is an unboxed sum+--+-- A compiled step returns @(# (# #) | (# a, 'PState' s #) #)@ rather than+-- @'Maybe' (a, 'PState' s)@.  The two are isomorphic, but the unboxed sum+-- lives in registers: a step that succeeds no longer allocates a @Just@ /and/+-- a pair on top of the new state, and a step that fails allocates nothing at+-- all.  Because the intermediate results of 'Seq' and 'Map' never escape,+-- this makes those two constructors — the ones the quasi-quoter emits for+-- every single grammar item — allocation-free. module PEG.Parse   ( Result (..)   , parse   , parseWith-  , eval+  , compileGrammar+  , Step+  , Res   , Opts (..)   , defaultOpts-  , Input   , PState (..)-  , columns+  , nextCol   ) where +import Data.Kind (Type)+import qualified Data.ByteString as B+import qualified Data.Text       as T++import PEG.CharSet (CharSet, memberCS) import PEG.Grammar import PEG.Indent import PEG.Member+import PEG.Stream import PEG.Syntax import PEG.Type-import PEG.TyLevel (Lookup)  -- | The result of running a grammar. -- -- @'OK' a consumed rest@ means the grammar matched, producing value @a@. -- @consumed@ is the prefix of the input that was consumed; @rest@ is the -- remaining input.-data Result a-  = OK a String String+data Result s a+  = OK a s s   | Fail   deriving (Show, Eq) --- | A string annotated with column positions, as produced by 'columns'.-type Input = [(Char, Int)]- -- | Internal parser state.-data PState = PState-  { stInput :: Input     -- ^ Remaining input with column positions.+--+-- The column of the character at the head of 'stInput' is carried alongside+-- the input rather than being precomputed for the whole stream, so nothing+-- proportional to the input is ever allocated up front.+data PState s = PState+  { stInput :: !s        -- ^ Remaining input.+  , stCol   :: !Int      -- ^ Column of the head of 'stInput'.+  , stOff   :: !Int      -- ^ Characters consumed so far.   , stCands :: !Interval -- ^ Current candidate column interval.   , stAlign :: !Bool     -- ^ Whether the next token must be aligned.   } --- | Annotate every character in a string with its column position.--- Tab stops are expanded according to @tabWidth@.-columns :: Int -> String -> Input-columns tabWidth = go 0-  where-    go _ []     = []-    go c (x:xs) = (x, c) : go (next c x) xs+-- | What a compiled step returns: either failure (the left injection, which+-- carries nothing) or a value together with the state after it.+--+-- This is @'Maybe' (a, 'PState' s)@ with the two boxes removed.+type Res s a = (# (# #) | (# a, PState s #) #) -    next _ '\n' = 0-    next c '\t'-      | tabWidth > 1 = ((c `div` tabWidth) + 1) * tabWidth-      | otherwise    = c + 1-    next c _    = c + 1+-- | A compiled parser: it still takes the ambient column relation, because a+-- rule body inherits the relation in force at its call site.+type Step s a = RelD -> PState s -> Res s a +-- | Column of the character following @c@, given a column of @c@ and a tab+-- width.+nextCol :: Int -> Int -> Char -> Int+nextCol _  _ '\n' = 0+nextCol tw c '\t'+  | tw > 1        = ((c `div` tw) + 1) * tw+  | otherwise     = c + 1+nextCol _  c _    = c + 1+{-# INLINE nextCol #-}+ -- | Parser configuration. data Opts = Opts   { optTokenMode :: RelD     -- ^ Default column relation between tokens.@@ -81,102 +132,348 @@   }  -- | Run a grammar with 'defaultOpts'.-parse :: Grammar env ty a -> String -> Result a+parse :: Stream s => Grammar s env ty a -> s -> Result s a parse = parseWith defaultOpts+{-# INLINABLE parse #-}+{-# SPECIALIZE parse :: Grammar String env ty a -> String -> Result String a #-}+{-# SPECIALIZE parse :: Grammar T.Text env ty a -> T.Text -> Result T.Text a #-}+{-# SPECIALIZE parse+      :: Grammar B.ByteString env ty a -> B.ByteString -> Result B.ByteString a #-}  -- | Run a grammar with custom 'Opts'.-parseWith :: Opts -> Grammar env ty a -> String -> Result a-parseWith opts (Grammar rules start) input =-  case eval rules start (optTokenMode opts) st0 of-    Nothing      -> Fail-    Just (a, st) ->-      let n = length input - length (stInput st)-      in OK a (take n input) (drop n input)+--+-- 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 ty a.+             Stream s => Opts -> Grammar s env ty a -> s -> Result s a+parseWith opts g = run   where-    st0 = PState-      { stInput = columns (optTabWidth opts) input-      , stCands = optCands opts-      , stAlign = False-      }+    step = compileGrammar (optTabWidth opts) g+    tau0 = optTokenMode opts --- | Low-level evaluator: run a 'PExp' against a 'PState' under a given column--- relation.  Exposed for advanced use; most callers should use 'parse' or--- 'parseWith'.-eval :: forall env ty a-      . Rules env env-     -> PExp env ty a-     -> RelD-     -> PState-     -> Maybe (a, PState)-eval rules = go+    run input = case step tau0 (PState input 0 0 (optCands opts) False) of+      (# (# #) | #)       -> Fail+      (# | (# a, st #) #) -> OK a (takeS (stOff st) input) (stInput st)+{-# INLINABLE parseWith #-}+{-# SPECIALIZE parseWith+      :: Opts -> Grammar String env ty a -> String -> Result String a #-}+{-# SPECIALIZE parseWith+      :: Opts -> Grammar T.Text env ty a -> T.Text -> Result T.Text a #-}+{-# SPECIALIZE parseWith+      :: Opts -> Grammar B.ByteString env ty a+      -> B.ByteString -> Result B.ByteString a #-}++--------------------------------------------------------------------------------+-- Compilation+--------------------------------------------------------------------------------++-- | 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 '[]+  CCons :: Step s a+        -> CRules s env rest+        -> CRules s env ('(n, 'EnvEntry ty a) ': rest)++clookup :: Member n defs a -> CRules s env defs -> Step s a+clookup Here      (CCons f _)    = f+clookup (There m) (CCons _ rest) = clookup m rest++-- | 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 ty a.+                  Stream s => Int -> Grammar s env ty a -> Step s a+compileGrammar tw (Grammar rules start) = compileE tw table start   where-    go :: forall t b. PExp env t b -> RelD -> PState -> Maybe (b, PState)-    go (Pure x) _ st = Just (x, st)+    table :: CRules s env env+    table = build rules -    go (Term c) tau st = do-      (x, st') <- terminal tau st-      if x == c then Just (c, st') else Nothing+    build :: forall defs. Rules s env defs -> CRules s env defs+    build RNil                = CNil+    build (RCons _ body rest) = CCons (compileE tw table body) (build rest)+{-# 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 ty a -> Step String a #-}+{-# SPECIALIZE compileGrammar+      :: Int -> Grammar T.Text env ty a -> Step T.Text a #-}+{-# SPECIALIZE compileGrammar+      :: Int -> Grammar B.ByteString env ty a -> Step B.ByteString a #-} -    go AnyChar tau st = terminal tau st+-- | 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+-- before it plus the run's length, and no fold is needed.+simpleCS :: CharSet -> Bool+simpleCS cs = not (memberCS '\n' cs) && not (memberCS '\t' cs) -    go (NT (_ :: Name s)) tau st =-      go (ruleFor (member :: Member s env (TyOf (Lookup s env))-                                          (ResOf (Lookup s env)))-                  rules)-         tau st+compileE :: forall s env ty a.+            Stream s => Int -> CRules s env env -> PExp s env ty a -> Step s a+compileE tw table = comp+  where+    -- Select the stream operations once per compiled grammar.  Leaving them+    -- as class-method applications would repeat the dictionary lookup on+    -- every character.+    !uncons  = unconsS       :: s -> (# (# #) | (# Char, s #) #)+    !spanS'  = spanS         :: (Char -> Bool) -> s -> (s, s)+    !lenS'   = lengthS       :: s -> Int+    !foldS'  = foldlS'       :: (Int -> Char -> Int) -> Int -> s -> Int+    !toStr   = chunkToString :: s -> String+    !packS   = packString    :: String -> s+    !emptyS  = packS [] -    go (Seq ef ex) tau st = do-      (f, st')  <- go ef tau st-      (x, st'') <- go ex tau st'-      pure (f x, st'')+    comp :: forall t b. PExp s env t b -> Step s b -    go (Choice e1 e2) tau st = case go e1 tau st of-      Just r  -> Just r-      Nothing -> go e2 tau st+    comp (Pure x) = \_ st -> (# | (# x, st #) #) -    go (Star e) tau st = Just (starLoop (go e tau) st)+    comp (Term c) = satStep (c ==) -    go (Not e) tau st = case go e tau st of-      Just _  -> Nothing-      Nothing -> Just ((), st)+    comp (Sat cs) = satStep (\c -> memberCS c cs) -    go (Map f e) tau st = do-      (x, st') <- go e tau st-      pure (f x, st')+    comp AnyChar  = satStep (const True) -    go (Indent rho e) tau st = do-      (x, st') <- go e tau st { stCands = preimage rd (stCands st) }-      pure ( x-           , st' { stCands = interI (stCands st) (image rd (stCands st')) } )+    comp (Str lit) = litStep lit++    -- A run of a character class, returned as a chunk of the stream.  On+    -- 'Data.Text.Text' this is a slice: no copy, no cons cells.+    comp (Span  cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) False+    comp (Span1 cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) True++    -- 'ty' and 'a' come from the constructor's own equality+    -- @Lookup n env ~ 'EnvEntry ty a@, so no type family has to be reduced+    -- here at all.+    comp (NT @n _) = clookup (member @n @env) table++    -- Neither this nor 'Map' below allocates: the intermediate results travel+    -- in registers, so a quasi-quoted rule of @n@ items costs @n@ calls and+    -- nothing else.+    comp (Seq ef ex) =+      let pf = comp ef+          px = comp ex+      in \tau st -> case pf tau st of+           (# (# #) | #)       -> (# (# #) | #)+           (# | (# f, s1 #) #) -> case px tau s1 of+             (# (# #) | #)       -> (# (# #) | #)+             (# | (# x, s2 #) #) -> (# | (# f x, s2 #) #)++    comp (Choice e1 e2) =+      let p = comp e1+          q = comp e2+      in \tau st -> case p tau st of+           (# (# #) | #) -> q tau st+           r             -> r++    -- A hand-written @'Star' ('Sat' cs)@ still produces a @['Char']@ rather+    -- than a chunk, so it needs its own scanner.  The quasi-quoter emits+    -- 'Span' instead, but 'PExp' values built by hand can be either.+    comp (Star (Sat cs)) = spanList (\c -> memberCS c cs) (simpleCS cs)+    comp (Star (Term c)) = spanList (c ==) (c /= '\n' && c /= '\t')+    comp (Star AnyChar)  = spanList (const True) False++    comp (Star e) =+      let p = comp e+          go acc tau st = case p tau st of+            (# (# #) | #)        -> (# | (# reverse acc, st #) #)+            (# | (# x, st' #) #) -> go (x : acc) tau st'+      in go []++    -- A negative lookahead at a single character only needs to peek.+    comp (Not (Sat cs))   = notCharStep (\c -> memberCS c cs)+    comp (Not (Term c))   = notCharStep (c ==)+    comp (Not AnyChar)    = notCharStep (const True)+    -- @!e+@ succeeds exactly when the next character is not in the class, so+    -- it is the same peek.  Without this case the generic 'Not' below would+    -- run the whole scan to answer a one-character question.+    comp (Not (Span1 cs)) = notCharStep (\c -> memberCS c cs)+    -- @!e*@ can never succeed: the star always matches, if only the empty+    -- run.  Say so directly rather than scanning the input to find out.+    comp (Not (Span _))   = \_ _ -> (# (# #) | #)++    comp (Not e) =+      let p = comp e+      in \tau st -> case p tau st of+           (# (# #) | #) -> (# | (# (), st #) #)+           _             -> (# (# #) | #)++    comp (Map f e) =+      let p = comp e+      in \tau st -> case p tau st of+           (# (# #) | #)       -> (# (# #) | #)+           (# | (# x, s1 #) #) -> (# | (# f x, s1 #) #)++    comp (Indent rho e) =+      let p  = comp e+          !rd = relD rho+      in \tau st ->+           case p tau st { stCands = preimage rd (stCands st) } of+             (# (# #) | #)       -> (# (# #) | #)+             (# | (# x, s1 #) #) ->+               (# | (# x+                     , s1 { stCands = interI (stCands st)+                                             (image rd (stCands s1)) } #) #)++    comp (Position sigma e) =+      let p  = comp e+          !rd = relD sigma+      in \_ st -> p rd st++    comp (Align e) =+      let p = comp e+      in \tau st -> case p tau st { stAlign = True } of+           (# (# #) | #)       -> (# (# #) | #)+           (# | (# x, s1 #) #) ->+             (# | (# x, s1 { stAlign = stAlign st && stAlign s1 } #) #)++    ------------------------------------------------------------------------+    -- Terminals.  These live here rather than at the top level so that they+    -- close over the hoisted stream operations above.+    ------------------------------------------------------------------------++    -- | Match one character satisfying a predicate.  The predicate is tested+    -- /before/ any column bookkeeping, so a failing alternative costs one+    -- comparison and nothing else.+    satStep :: (Char -> Bool) -> Step s Char+    satStep p = \tau st -> case uncons (stInput st) of+      (# | (# x, xs #) #) | p x -> advance tw tau st x xs+      _                         -> (# (# #) | #)++    -- | Match a literal string.  On the fast path the whole literal is+    -- matched with a single loop and a single new 'PState'; otherwise it goes+    -- character by character so that column bookkeeping stays exactly as it+    -- would be for the equivalent chain of 'Term's.+    --+    -- The result is the literal itself, so no chunk is built.+    litStep :: String -> Step s String+    litStep lit = \tau st ->+      if plainly tau st+        then fast (stInput st) lit (stCol st) (stOff st) (stCands st)+        else slow lit tau st       where-        rd = relD rho+        fast rest [] !col !off cands =+          (# | (# lit, PState rest col off cands False #) #)+        fast rest (c : cs) !col !off cands = case uncons rest of+          (# | (# x, xs #) #)+            | x == c -> fast xs cs (nextCol tw col x) (off + 1) cands+          _          -> (# (# #) | #) -    go (Position sigma e) _ st = go e (relD sigma) st+        slow []       _   st = (# | (# lit, st #) #)+        slow (c : cs) tau st = case uncons (stInput st) of+          (# | (# x, xs #) #)+            | x == c -> case advance tw tau st x xs of+                          (# (# #) | #)        -> (# (# #) | #)+                          (# | (# _, st' #) #) -> slow cs tau st'+          _          -> (# (# #) | #) -    go (Align e) tau st = do-      (x, st') <- go e tau st { stAlign = True }-      pure (x, st' { stAlign = stAlign st && stAlign st' })+    -- | A run of a character class, returned as a chunk.+    --+    -- On the fast path this is one native @span@ — a slice for 'Text' and+    -- 'ByteString' — plus, when the class can contain a newline or a tab, one+    -- fold to find the resulting column.+    spanChunk :: (Char -> Bool) -> Bool -> Bool -> Step s s+    spanChunk p simple atLeastOne = go+      where+        go tau st+          | plainly tau st = case uncons (stInput st) of+              -- Peek before spanning.  A class that cannot match the very+              -- next character is the common case in an ordered choice, and+              -- calling 'spanS' just to be handed an empty prefix would+              -- allocate a pair on every failed alternative.+              (# | (# c, _ #) #) | p c -> chunk tau st+              _ | atLeastOne -> (# (# #) | #)+                | otherwise  -> (# | (# emptyS, st #) #)+          | otherwise = loop [] tau st -terminal :: RelD -> PState -> Maybe (Char, PState)-terminal tau (PState input cands aligned) = case input of-  []            -> Nothing-  ((x, i) : xs)-    | aligned   ->-        if memberI i cands-          then Just (x, PState xs (singletonI i) False)-          else Nothing-    | otherwise ->-        if memberI i (preimage tau cands)-          then Just (x, PState xs (interI cands (image tau (singletonI i))) False)-          else Nothing+        chunk _ st = case spanS' p (stInput st) of+          (pre, rest) ->+            let !n    = lenS' pre+                !col' = if simple then stCol st + n+                                  else foldS' (nextCol tw) (stCol st) pre+            in (# | (# pre+                     , PState rest col' (stOff st + n)+                              (stCands st) False #) #) -starLoop :: (PState -> Maybe (a, PState)) -> PState -> ([a], PState)-starLoop step = loop+        -- The layout-sensitive path: every character has to go through the+        -- interval arithmetic, so the chunk is rebuilt from the characters.+        loop acc tau st = case satStep p tau st of+          (# | (# x, st' #) #) -> loop (x : acc) tau st'+          (# (# #) | #)+            | atLeastOne && null acc -> (# (# #) | #)+            | otherwise -> (# | (# packS (reverse acc), st #) #)++    -- | A run of a character class, returned as a @['Char']@.  Only reachable+    -- from a hand-written @'Star' ('Sat' _)@; the quasi-quoter emits 'Span'.+    spanList :: (Char -> Bool) -> Bool -> Step s String+    spanList p simple = go+      where+        go tau st+          | plainly tau st = case uncons (stInput st) of+              (# | (# c, _ #) #) | p c -> case spanS' p (stInput st) of+                (pre, rest) ->+                  let !n    = lenS' pre+                      !col' = if simple then stCol st + n+                                        else foldS' (nextCol tw) (stCol st) pre+                  in (# | (# toStr pre+                           , PState rest col' (stOff st + n)+                                    (stCands st) False #) #)+              _ -> (# | (# [], st #) #)+          | otherwise = loop [] tau st++        loop acc tau st = case satStep p tau st of+          (# | (# x, st' #) #) -> loop (x : acc) tau st'+          (# (# #) | #)        -> (# | (# reverse acc, st #) #)++    -- | Negative lookahead at a single character: a peek, with no state built.+    notCharStep :: (Char -> Bool) -> Step s ()+    notCharStep p = go+      where+        go tau st+          | plainly tau st = case uncons (stInput st) of+              (# | (# x, _ #) #) | p x -> (# (# #) | #)+              _                        -> (# | (# (), st #) #)+          | otherwise = case satStep p tau st of+              (# (# #) | #) -> (# | (# (), st #) #)+              _             -> (# (# #) | #)++--------------------------------------------------------------------------------+-- Column bookkeeping+--------------------------------------------------------------------------------++-- | Consume the head character, updating column, offset and the candidate+-- interval.+--+-- When the ambient relation is total ('rdTotal', i.e. 'anyR') and no+-- alignment is pending, the candidate interval is provably unchanged, so the+-- whole interval computation is skipped.  Grammars that do not use layout+-- take this branch for every single character.+advance :: Int -> RelD -> PState s -> Char -> s -> Res s Char+advance tw tau (PState _ col off cands aligned) x xs+  | aligned =+      if memberI col cands+        then (# | (# x, PState xs col' off' (singletonI col) False #) #)+        else (# (# #) | #)+  | rdTotal tau =+      if nullI cands+        then (# (# #) | #)+        else (# | (# x, PState xs col' off' cands False #) #)+  | memberI col (preimage tau cands) =+      (# | (# x, PState xs col' off'+                        (interI cands (image tau (singletonI col))) False #) #)+  | otherwise = (# (# #) | #)   where-    loop st = case step st of-      Nothing       -> ([], st)-      Just (x, st') -> let (xs, rest) = loop st' in (x : xs, rest)+    !col' = nextCol tw col x+    !off' = off + 1+{-# INLINE advance #-} -ruleFor :: Member s defs ty a -> Rules env defs -> PExp env ty a-ruleFor Here      (RCons _ body _)    = body-ruleFor (There m) (RCons _ _    rest) = ruleFor m rest+-- | Does the cheap path apply?  It does when the ambient relation constrains+-- nothing, no alignment is pending, and the candidate interval is inhabited:+-- under those conditions 'advance' provably leaves the interval alone, so a+-- run of characters can be consumed without touching it once.+plainly :: RelD -> PState s -> Bool+plainly tau st = rdTotal tau && not (stAlign st) && not (nullI (stCands st))+{-# INLINE plainly #-}

@@ -15,8 +15,13 @@ -- a Haskell action in braces: @{ haskellExpr }@. -- Ordered choice is written with @\/@; Kleene star with @*@; plus with @+@; -- optional with @?@; negation with @!@.--- Character classes use @[...]@ syntax. --+-- Character classes use @[...]@ syntax and may contain ranges: @[a-zA-Z0-9_]@.+-- A leading @^@ negates the class, so @[^\"]@ matches any character other than+-- a double quote; write @[\\^]@ for a class containing a caret.  Prefer a+-- negated class over the @(!c .)@ idiom: the class is one bit test, whereas+-- the lookahead scans every character twice.+-- -- The 'pegExpr' quasi-quoter produces a single 'PEG.Syntax.PExp' value, -- while 'pegRules' produces a complete set of named rules (a -- 'PEG.Grammar.Rules' value) to be passed to 'PEG.Grammar.Grammar'.@@ -50,7 +55,7 @@   | EPlus    PExpr   | EChar    Char   | EString  String-  | EClass   [(Char,Char)]+  | EClass   Bool [(Char,Char)]   -- ^ 'True' when the class is negated.   | EDot   | ENT      String   | EIndent  RelS PExpr@@ -127,16 +132,26 @@   '['  -> Right ('[',  xs)   ']'  -> Right (']',  xs)   '0'  -> Right ('\0', xs)+  '^'  -> Right ('^',  xs)   _    -> errorAt ("unknown escape \\" ++ [e]) xs escChar stopC (c:xs)   | c == stopC = errorAt "unexpected close quote" (c:xs)   | otherwise  = Right (c, xs) escChar _ [] = Left "unexpected end of input in literal" -classLit :: P [(Char, Char)]+-- | A character class.  A leading @^@ negates it, as in POSIX; write+-- @[\\^]@ for a class containing the caret itself.+classLit :: P (Bool, [(Char, Char)]) classLit s0 = case spaces s0 of-  ('[':xs) -> loop xs-  s        -> errorAt "expected character class" s+  ('[':'^':xs) -> do+    (rs, r) <- loop xs+    if null rs+      then errorAt "empty negated character class" s0+      else Right ((True, rs), r)+  ('[':xs)     -> do+    (rs, r) <- loop xs+    Right ((False, rs), r)+  s            -> errorAt "expected character class" s   where     loop (']':r) = Right ([], r)     loop []      = Left "unterminated character class"@@ -302,7 +317,7 @@         Left _ -> case strLit s of           Right (cs, s1) -> Right (EString cs, s1)           Left _ -> case classLit s of-            Right (rs, s1) -> Right (EClass rs, s1)+            Right ((neg, rs), s1) -> Right (EClass neg rs, s1)             Left _ -> case ident s of               Right (name, s1) ->                 case tok "<-" s1 of@@ -344,9 +359,13 @@ translateExpr (EString s)   | null s    = [| pureP "" |]   | otherwise = [| stringNE s |]-translateExpr (EClass rs) =-  let allChars = concat [ [lo..hi] | (lo, hi) <- rs ]-  in [| oneOf allChars |]+translateExpr (EClass neg rs)+  -- A character class becomes a single 'Sat' node holding a compact+  -- 'PEG.CharSet.CharSet'.  Expanding it into a chain of ordered choices, as+  -- an earlier version did, made matching one character of @[a-zA-Z0-9_]@+  -- cost 63 parser steps.+  | neg       = [| notCharClass rs |]+  | otherwise = [| charClass rs |] translateExpr (EAnd e)  = do   e' <- translateExpr e   [| Not (Not $(pure e')) |]@@ -356,6 +375,21 @@ translateExpr (EOpt e)  = do   e' <- translateExpr e   [| opt $(pure e') |]+-- A repetition of a single character -- @[a-z]*@, @','+@, @.*@ -- compiles to+-- one 'PEG.Syntax.Span' node and produces a /chunk of the input stream/: a+-- 'Data.Text.Text' slice rather than a @['Char']@.  Only a bare class, literal+-- or dot qualifies; a wrapper such as @[a-z]^>*@ changes the meaning of each+-- iteration, so those keep the generic 'Star'.+translateExpr (EStar (EClass neg rs))+  | neg       = [| spanOf (notInRanges rs) |]+  | otherwise = [| spanOf (fromRanges rs) |]+translateExpr (EStar (EChar c)) = [| spanOf (singletonCS c) |]+translateExpr (EStar EDot)      = [| spanOf anyCS |]+translateExpr (EPlus (EClass neg rs))+  | neg       = [| spanOf1 (notInRanges rs) |]+  | otherwise = [| spanOf1 (fromRanges rs) |]+translateExpr (EPlus (EChar c)) = [| spanOf1 (singletonCS c) |]+translateExpr (EPlus EDot)      = [| spanOf1 anyCS |] translateExpr (EStar e) = do   e' <- translateExpr e   [| Star $(pure e') |]

@@ -73,17 +73,19 @@ p </> q = try p <|> q  -class Stream d where+-- | Unrelated to "PEG.Stream": this is the reference semantics' own+-- token-polymorphic input class, used only inside this module.+class SimpleStream d where   type Elem d   anyChar :: PExp d (Elem d) -instance Stream [a] where+instance SimpleStream [a] where   type Elem [a] = a    anyChar = PExp $ \s -> case s of     (x:xs) -> Commit xs x     [] -> Fail "EOF" False -satisfy :: Stream d => (Elem d -> Bool) -> PExp d (Elem d)+satisfy :: SimpleStream d => (Elem d -> Bool) -> PExp d (Elem d) satisfy p = try $ do   x <- anyChar   x <$ guard (p x)@@ -101,10 +103,10 @@         Fail{} -> Pure ()         _      -> Fail "unexpected" False -eof :: Stream d => PExp d ()+eof :: SimpleStream d => PExp d () eof = not anyChar -char :: Eq (Elem d) => Stream d => Elem d -> PExp d (Elem d)+char :: Eq (Elem d) => SimpleStream d => Elem d -> PExp d (Elem d) char c = satisfy (c ==)  lexeme :: PExp String a -> PExp String a

@@ -0,0 +1,263 @@+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash         #-}+{-# LANGUAGE UnboxedSums       #-}+{-# LANGUAGE UnboxedTuples     #-}++-- | Input streams the parser can consume.+--+-- A 'Stream' is anything the parser can read one 'Char' at a time and slice+-- chunks out of.  Instances are provided for 'String', strict and lazy+-- 'Data.Text.Text', and strict and lazy 'Data.ByteString.ByteString'.+--+-- == ByteString is Latin-1+--+-- The 'ByteString' instances read each byte as the 'Char' with that code+-- point, exactly as "Data.ByteString.Char8" does.  This is what makes them+-- fast — every character lands in the Latin-1 range that+-- "PEG.CharSet" answers with a single bit test — and it is correct for+-- grammars over ASCII or Latin-1 text.  It is /wrong/ for UTF-8: a+-- multi-byte character arrives as its individual bytes, and columns and+-- offsets count bytes rather than characters.  Decode to 'Data.Text.Text'+-- first if that matters.+--+-- Two laws follow, and only the 'ByteString' instances need the caveat:+--+-- * @'chunkToString' . 'packString' == 'id'@, for arguments in the range the+--   stream can represent (all of 'Char' except for 'ByteString', where it is+--   @\'\\0\'@ .. @\'\\255\'@).+-- * A 'PEG.CharSet.CharSet' containing only characters above @\'\\255\'@+--   never matches a 'ByteString', with no diagnostic.+--+-- == Writing an instance+--+-- Only 'unconsS' has no default.  Everything else is derived from it, so a+-- minimal instance is one method — but a type with native slicing should+-- override 'spanS', 'takeS', 'lengthS' and 'foldlS'' , which is where the+-- performance of 'Text' and 'ByteString' comes from.+module PEG.Stream+  ( Stream (..)+  ) where++import Data.Char (chr, ord)++import qualified Data.ByteString            as B+import qualified Data.ByteString.Char8      as BC+import qualified Data.ByteString.Lazy       as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Text                  as T+import qualified Data.Text.Lazy             as TL++-- | A sequence of characters the parser can consume.+--+-- The chunk type is the stream type itself: slicing a 'Data.Text.Text'+-- yields a 'Data.Text.Text', so a character class such as @[a-z]+@ produces+-- a real slice rather than unpacking into a @['Char']@.+class Stream s where+  -- | Split off the first character.+  --+  -- This returns an unboxed sum rather than @'Maybe' ('Char', s)@ on+  -- purpose.  It is called once per character of input, and the boxed+  -- version would allocate a @Just@ and a pair every time — behind a class+  -- dictionary GHC cannot cancel them, so the parser's zero-allocation+  -- terminal path would be lost.+  unconsS :: s -> (# (# #) | (# Char, s #) #)++  -- | @'spanS' p s@ splits @s@ into the longest prefix all of whose+  -- characters satisfy @p@, and the rest.+  spanS :: (Char -> Bool) -> s -> (s, s)++  -- | Strict left fold over the characters.  Used to advance the column+  -- across a chunk that has already been matched in bulk.+  foldlS' :: (b -> Char -> b) -> b -> s -> b++  -- | Prepend a character.  @O(1)@ for 'String' and the lazy types; the+  -- strict types must copy.+  consS :: Char -> s -> s++  -- | @'takeS' n s@ is the first @n@ characters of @s@.+  takeS :: Int -> s -> s++  -- | Number of characters.+  lengthS :: s -> Int++  -- | Is the stream empty?+  nullS :: s -> Bool++  -- | Convert a chunk to a 'String'.  Semantic actions need this whenever a+  -- character class feeds something that expects a 'String', such as 'read'.+  chunkToString :: s -> String++  -- | Build a chunk from a 'String'.+  packString :: String -> s++  -- Defaults, all in terms of 'unconsS'.++  spanS p s0 = go id s0+    where+      go acc s = case unconsS s of+        (# | (# c, s' #) #) | p c -> go (acc . (c :)) s'+        _                         -> (packString (acc []), s)++  foldlS' f = go+    where+      go !acc s = case unconsS s of+        (# | (# c, s' #) #) -> go (f acc c) s'+        _                   -> acc++  consS c s = packString (c : chunkToString s)++  takeS n0 s0 = packString (go n0 s0)+    where+      go n s+        | n <= 0    = []+        | otherwise = case unconsS s of+            (# | (# c, s' #) #) -> c : go (n - 1) s'+            _                   -> []++  lengthS = foldlS' (\ !n _ -> n + 1) 0++  nullS s = case unconsS s of+    (# (# #) | #) -> True+    _             -> False++  chunkToString s = case unconsS s of+    (# | (# c, s' #) #) -> c : chunkToString s'+    _                   -> []++  {-# MINIMAL unconsS, packString #-}++--------------------------------------------------------------------------------+-- String+--------------------------------------------------------------------------------++instance Stream [Char] where+  unconsS (c : cs) = (# | (# c, cs #) #)+  unconsS []       = (# (# #) | #)+  {-# INLINE unconsS #-}++  -- NOT 'Data.List.span': that one is lazy in its pair, so it allocates a+  -- tuple and two selector thunks for every character it accepts.  Finding+  -- the split point first and slicing costs one tuple in total.+  spanS p s0    = go (0 :: Int) s0+    where+      go !n s = case s of+        (c : cs) | p c -> go (n + 1) cs+        _              -> (take n s0, s)+  foldlS' f     = go+    where+      go !acc (c : cs) = go (f acc c) cs+      go !acc []       = acc+  consS         = (:)+  takeS         = take+  lengthS       = length+  nullS         = null+  chunkToString = id+  packString    = id+  {-# INLINE spanS #-}+  {-# INLINE foldlS' #-}+  {-# INLINE consS #-}+  {-# INLINE takeS #-}+  {-# INLINE lengthS #-}+  {-# INLINE nullS #-}+  {-# INLINE chunkToString #-}+  {-# INLINE packString #-}++--------------------------------------------------------------------------------+-- Text+--------------------------------------------------------------------------------++instance Stream T.Text where+  unconsS t = case T.uncons t of+    Just (c, t') -> (# | (# c, t' #) #)+    Nothing      -> (# (# #) | #)+  {-# INLINE unconsS #-}++  spanS         = T.span+  foldlS'       = T.foldl'+  consS         = T.cons+  takeS         = T.take+  lengthS       = T.length+  nullS         = T.null+  chunkToString = T.unpack+  packString    = T.pack+  {-# INLINE spanS #-}+  {-# INLINE foldlS' #-}+  {-# INLINE takeS #-}+  {-# INLINE lengthS #-}+  {-# INLINE nullS #-}++instance Stream TL.Text where+  unconsS t = case TL.uncons t of+    Just (c, t') -> (# | (# c, t' #) #)+    Nothing      -> (# (# #) | #)+  {-# INLINE unconsS #-}++  spanS         = TL.span+  foldlS'       = TL.foldl'+  consS         = TL.cons+  takeS n       = TL.take (fromIntegral n)+  lengthS       = fromIntegral . TL.length+  nullS         = TL.null+  chunkToString = TL.unpack+  packString    = TL.pack+  {-# INLINE spanS #-}+  {-# INLINE foldlS' #-}+  {-# INLINE nullS #-}++--------------------------------------------------------------------------------+-- ByteString (Latin-1)+--------------------------------------------------------------------------------++-- | Byte to character, Latin-1.+w2c :: Int -> Char+w2c = chr+{-# INLINE w2c #-}++instance Stream B.ByteString where+  unconsS b = case B.uncons b of+    Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #)+    Nothing      -> (# (# #) | #)+  {-# INLINE unconsS #-}++  spanS         = BC.span+  foldlS'       = BC.foldl'+  consS         = BC.cons+  takeS         = B.take+  lengthS       = B.length+  nullS         = B.null+  chunkToString = BC.unpack+  -- 'BC.pack' truncates characters above '\255'; clamp explicitly so the+  -- behaviour is the documented one rather than whatever pack happens to do.+  packString    = BC.pack . map clampLatin1+  {-# INLINE spanS #-}+  {-# INLINE foldlS' #-}+  {-# INLINE takeS #-}+  {-# INLINE lengthS #-}+  {-# INLINE nullS #-}++instance Stream BL.ByteString where+  unconsS b = case BL.uncons b of+    Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #)+    Nothing      -> (# (# #) | #)+  {-# INLINE unconsS #-}++  spanS         = BLC.span+  foldlS'       = BLC.foldl'+  consS         = BLC.cons+  takeS n       = BL.take (fromIntegral n)+  lengthS       = fromIntegral . BL.length+  nullS         = BL.null+  chunkToString = BLC.unpack+  packString    = BLC.pack . map clampLatin1+  {-# INLINE spanS #-}+  {-# INLINE foldlS' #-}+  {-# INLINE nullS #-}++-- | Characters a 'ByteString' cannot represent become @\'\\255\'@ rather+-- than silently wrapping around modulo 256.+clampLatin1 :: Char -> Char+clampLatin1 c+  | ord c > 255 = '\255'+  | otherwise   = c+{-# INLINE clampLatin1 #-}

@@ -11,18 +11,28 @@  -- | The PEG expression GADT and combinator API. ----- 'PExp' is the core type: a GADT indexed by the grammar environment,--- the 'PEG.Type.Ty' of the expression (nullability + FIRST set), and the--- Haskell result type.  Combinators like '<*>.' and '.||.' propagate type--- information at the kind level so that 'PEG.Grammar.Acyclic' can be checked--- without running the parser.+-- 'PExp' is the core type: a GADT indexed by the input stream, the grammar+-- environment, the 'PEG.Type.Ty' of the expression (nullability + FIRST set),+-- and the Haskell result type.  Combinators like '<*>.' and '.||.' propagate+-- type information at the kind level so that 'PEG.Grammar.Acyclic' can be+-- checked without running the parser. --+-- The first parameter, @s@, is the stream the expression consumes; see+-- "PEG.Stream".  It appears in the type because a character class produces a+-- /chunk of that stream/ — matching @[a-z]+@ against a 'Data.Text.Text'+-- yields a 'Data.Text.Text' slice, not a @['Char']@.+-- -- Most users will not build 'PExp' values directly; instead they use the -- quasi-quoter in "PEG.QQ". module PEG.Syntax   ( Name (..)   , PExp (..)   , nt+  , sat+  , charClass+  , notCharClass+  , spanOf+  , spanOf1   , pureP   , fmapP   , indent@@ -39,20 +49,36 @@   , SeqTy   , ChoiceTy   , NTTy+  , NTGo   ) where  import Data.Kind    (Type) import GHC.TypeLits (Symbol, KnownSymbol) +import PEG.CharSet (CharSet)+import qualified PEG.CharSet as CS import PEG.Indent (Rel) import PEG.Type import PEG.TyLevel import PEG.Member --- | A singleton witness for a non-terminal name @s@.-data Name (s :: Symbol) = Name+-- | A singleton witness for a non-terminal name @n@.+data Name (n :: Symbol) = Name  -- | The 'Ty' of a sequence @e1 e2@.+--+-- Written as a projective type synonym rather than a type family so that it+-- reduces to a @'MkTy'@ head even when its operands are still abstract.  That+-- is what lets a polymorphic combinator such as+--+-- @+-- lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a+-- @+--+-- compose without the caller having to get the nesting of 'SeqTy' exactly+-- right.  The cost it used to carry — an exponential blow-up as the operands+-- get duplicated across the right-hand side — came from 'Union' and+-- 'ConsIfAbsent', not from here; see "PEG.TyLevel". type SeqTy t1 t2 =   'MkTy (And (Nullable t1) (Nullable t2))         (Union (First t1) (If (Nullable t1) (First t2) '[]))@@ -62,17 +88,30 @@   'MkTy (Or  (Nullable t1) (Nullable t2))         (Union (First t1) (First t2)) --- | The 'Ty' of a non-terminal reference @s@ looked up in @env@.-type NTTy s env =-  'MkTy (Nullable (TyOf (Lookup s env)))-        (ConsIfAbsent s (First (TyOf (Lookup s env))))+-- | The 'Ty' of a non-terminal reference @n@ looked up in @env@.+type NTTy n env = NTGo n (TyOf (Lookup n env)) --- | A typed PEG expression.+-- | The 'Ty' of a reference to a non-terminal named @n@ whose own 'Ty' is+-- @t@. --+-- 'NT' and 'nt' are stated in terms of this rather than 'NTTy' so that the+-- environment is searched /once/ per occurrence, by the constructor's+-- @Lookup n env ~ 'EnvEntry ty a@ equality.  Naming @Lookup n env@ twice, as+-- an expansion of 'NTTy' does, doubles the cost of what profiling shows to be+-- the dominant term in checking a large grammar.+type family NTGo (n :: Symbol) (t :: Ty) :: Ty where+  NTGo n ('MkTy nu f) = 'MkTy nu (ConsIfAbsent n f)++-- | A typed PEG expression over the stream @s@.+-- -- Constructors correspond to the standard PEG operators: -- -- * 'Pure'   — succeed without consuming input, return a value -- * 'Term'   — match a specific character+-- * 'Sat'    — match any character of a 'CharSet' (a character class)+-- * 'Str'    — match a non-empty string literal+-- * '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 -- * 'Seq'    — sequential composition (@e1 e2@)@@ -83,111 +122,165 @@ -- * '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 (env :: Env) (ty :: Ty) (a :: Type) where-  Pure     :: a -> PExp env ('MkTy 'True '[]) a-  Term     :: Char -> PExp env ('MkTy 'False '[]) Char-  AnyChar  :: PExp env ('MkTy 'False '[]) Char-  NT       :: ( KnownSymbol s-              , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env))+data PExp (s :: Type) (env :: Env) (ty :: Ty) (a :: Type) where+  Pure     :: a -> PExp s env ('MkTy 'True '[]) a+  Term     :: Char -> PExp s env ('MkTy 'False '[]) 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 ('MkTy 'False '[]) Char+  -- | Match a string literal.  The string must be non-empty (the 'Ty' index+  -- claims the expression is not nullable); 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 ('MkTy 'False '[]) 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 ('MkTy 'True  '[]) s+  -- | As 'Span', but the run must be non-empty: @[a-z]+@.+  Span1    :: !CharSet -> PExp s env ('MkTy 'False '[]) s+  AnyChar  :: PExp s env ('MkTy 'False '[]) Char+  -- The environment is looked up /once/, by the equality below, and the+  -- result is bound to the rigid variables @ty@ and @a@.  Passing+  -- @TyOf (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 ty s env a.+              ( KnownSymbol n+              , Lookup n env ~ 'EnvEntry ty a+              , KnownMember n env a               )-           => Name s-           -> PExp env (NTTy s env) (ResOf (Lookup s env))-  Seq      :: PExp env t1 (a -> b)-           -> PExp env t2 a-           -> PExp env (SeqTy t1 t2) b-  Choice   :: PExp env t1 a-           -> PExp env t2 a-           -> PExp env (ChoiceTy t1 t2) a-  Star     :: PExp env ('MkTy 'False f) a-           -> PExp env ('MkTy 'True  f) [a]-  Not      :: PExp env ('MkTy n f) a-           -> PExp env ('MkTy 'True f) ()+           => Name n+           -> PExp s env (NTGo n ty) a+  Seq      :: PExp s env t1 (a -> b)+           -> PExp s env t2 a+           -> PExp s env (SeqTy t1 t2) b+  Choice   :: PExp s env t1 a+           -> PExp s env t2 a+           -> PExp s env (ChoiceTy t1 t2) a+  Star     :: PExp s env ('MkTy 'False f) a+           -> PExp s env ('MkTy 'True  f) [a]+  Not      :: PExp s env ('MkTy n f) a+           -> PExp s env ('MkTy 'True f) ()   Map      :: (a -> b)-           -> PExp env ty a-           -> PExp env ty b+           -> PExp s env ty a+           -> PExp s env ty b   Indent   :: Rel n-           -> PExp env ty a-           -> PExp env ty a+           -> PExp s env ty a+           -> PExp s env ty a   Position :: Rel n-           -> PExp env ty a-           -> PExp env ty a-  Align    :: PExp env ty a-           -> PExp env ty a+           -> PExp s env ty a+           -> PExp s env ty a+  Align    :: PExp s env ty a+           -> PExp s env ty a -instance Functor (PExp env ty) where+instance Functor (PExp s env ty) where   fmap = Map  -- | Reference a non-terminal by name using a type application: -- @nt \@\"ruleName\"@.-nt :: forall s env.-      ( KnownSymbol s-      , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env))+--+-- The name is deliberately the /first/ quantified variable, so that+-- @nt \@\"expr\"@ keeps working: the stream and environment are recovered by+-- unification.+nt :: forall n env s ty a.+      ( KnownSymbol n+      , Lookup n env ~ 'EnvEntry ty a+      , KnownMember n env a       )-   => PExp env (NTTy s env) (ResOf (Lookup s env))-nt = NT (Name :: Name s)+   => PExp s env (NTGo n ty) a+nt = NT (Name :: Name n)  -- | Succeed without consuming any input.-pureP :: a -> PExp env ('MkTy 'True '[]) a+pureP :: a -> PExp s env ('MkTy 'True '[]) a pureP = Pure  -- | Apply a function to the result of an expression.-fmapP :: (a -> b) -> PExp env ty a -> PExp env ty b+fmapP :: (a -> b) -> PExp s env ty a -> PExp s env ty b fmapP = Map  -- | Require the sub-expression to satisfy the given column relation.-indent :: Rel n -> PExp env ty a -> PExp env ty a+indent :: Rel n -> PExp s env ty a -> PExp s env ty a indent = Indent  -- | Override the token mode for the sub-expression.-position :: Rel n -> PExp env ty a -> PExp env ty a+position :: Rel n -> PExp s env ty a -> PExp s env ty a position = Position  -- | Require the sub-expression to start at the current alignment column.-align :: PExp env ty a -> PExp env ty a+align :: PExp s env ty a -> PExp s env ty a align = Align  -- | Infix synonym for 'fmapP'.-(<$>.) :: (a -> b) -> PExp env ty a -> PExp env ty b+(<$>.) :: (a -> b) -> PExp s env ty a -> PExp s env ty b (<$>.) = Map infixl 4 <$>.  -- | Infix sequential composition.-(<*>.) :: PExp env t1 (a -> b)-       -> PExp env t2 a-       -> PExp env (SeqTy t1 t2) b+(<*>.) :: PExp s env t1 (a -> b)+       -> PExp s env t2 a+       -> PExp s env (SeqTy t1 t2) b (<*>.) = Seq infixl 4 <*>.  -- | Sequence two expressions, discarding the result of the first.-(.>>.) :: PExp env t1 a-       -> PExp env t2 b-       -> PExp env (SeqTy t1 t2) b+(.>>.) :: PExp s env t1 a+       -> PExp s env t2 b+       -> PExp s env (SeqTy t1 t2) b e1 .>>. e2 = Map (\_ b -> b) e1 <*>. e2 infixl 6 .>>.  -- | Infix ordered choice (@e1 \/ e2@): try @e1@; if it fails, try @e2@.-(.||.) :: PExp env t1 a -> PExp env t2 a -> PExp env (ChoiceTy t1 t2) a+(.||.) :: PExp s env t1 a -> PExp s env t2 a -> PExp s env (ChoiceTy t1 t2) a (.||.) = Choice infixl 5 .||.  -- | Optional match: @opt e = (Just \<$\>. e) .||. pureP Nothing@.-opt :: PExp env t a-    -> PExp env (ChoiceTy t ('MkTy 'True '[])) (Maybe a)+opt :: PExp s env t a+    -> PExp s env (ChoiceTy t ('MkTy 'True '[])) (Maybe a) opt e = (Just <$>. e) .||. pureP Nothing  -- | One-or-more: @plus e = (:) \<$\>. e \<*\>. Star e@.-plus :: PExp env ('MkTy 'False f) a-     -> PExp env (SeqTy ('MkTy 'False f) ('MkTy 'True f)) [a]+--+-- 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 ('MkTy 'False f) a+     -> PExp s env (SeqTy ('MkTy 'False f) ('MkTy 'True f)) [a] plus e = (:) <$>. e <*>. Star e +-- | Match any character of the given set.+sat :: CharSet -> PExp s env ('MkTy 'False '[]) Char+sat = Sat++-- | Match any character inside one of the given inclusive ranges.+-- This is the representation the quasi-quoter emits for @[a-z0-9]@ and+-- friends.+charClass :: [(Char, Char)] -> PExp s env ('MkTy 'False '[]) 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 ('MkTy 'False '[]) 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 ('MkTy 'True '[]) s+spanOf = Span++-- | Match a non-empty run of characters of the set.+spanOf1 :: CharSet -> PExp s env ('MkTy 'False '[]) s+spanOf1 = Span1+ -- | Match any character in the given list. The list must be non-empty.-oneOf :: [Char] -> PExp env ('MkTy 'False '[]) Char-oneOf []     = error "PEG.Syntax.oneOf: empty character class"-oneOf [c]    = Term c-oneOf (c:cs) = Term c .||. oneOf cs+oneOf :: [Char] -> PExp s env ('MkTy 'False '[]) 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 env ('MkTy 'False '[]) String-stringNE []     = error "PEG.Syntax.stringNE: empty string"-stringNE [c]    = (\x -> [x]) <$>. Term c-stringNE (c:cs) = (:) <$>. Term c <*>. stringNE cs+stringNE :: String -> PExp s env ('MkTy 'False '[]) String+stringNE [] = error "PEG.Syntax.stringNE: empty string"+stringNE s  = Str s

@@ -10,6 +10,30 @@ -- These type families are used internally to compute the FIRST sets and -- nullability of PEG expressions at the kind level, enabling the -- 'PEG.Grammar.Acyclic' constraint to be resolved at compile time.+--+-- == Representation of FIRST sets+--+-- A FIRST set is a @['Symbol']@ kept /strictly sorted/ by 'CmpSymbol'.+-- Sortedness is the whole point: it makes the representation canonical (one+-- set, one type), so 'Union' is a single-pass merge and 'Elem' can stop at+-- the first symbol greater than the one it is looking for.+--+-- == Why the families are written this way+--+-- Every clause below mentions each of its arguments — and in particular each+-- recursive call — /exactly once/ on the right-hand side.  This is not a+-- style choice.  A clause such as+--+-- @+-- ConsIfAbsent x xs = If (Elem x xs) xs (x ': xs)   -- DON'T+-- @+--+-- mentions @xs@ three times, and @xs@ is normally an unreduced application+-- of 'Union'.  GHC therefore has three copies of the pending computation to+-- reduce, each of which triples again one level down: a union of two sets of+-- size @n@ costs @3^n@ reductions rather than @n@.  Dispatching on an+-- already-computed 'Ordering' in a separate family keeps every right-hand+-- side linear in its arguments. module PEG.TyLevel   ( If   , And@@ -45,30 +69,83 @@   IsEQ 'EQ = 'True   IsEQ _   = 'False +-- | Is @x@ a member of the sorted set @xs@?+--+-- Stops as soon as it reaches a symbol greater than @x@, so a miss costs+-- half a scan on average rather than a full one. type family Elem (x :: Symbol) (xs :: [Symbol]) :: Bool where   Elem _ '[]       = 'False-  Elem x (y ': ys) = Or (SymEq x y) (Elem x ys)+  Elem x (y ': ys) = ElemGo (CmpSymbol x y) x ys +type family ElemGo (o :: Ordering) (x :: Symbol) (ys :: [Symbol]) :: Bool where+  ElemGo 'EQ _ _  = 'True+  ElemGo 'LT _ _  = 'False+  ElemGo 'GT x ys = Elem x ys++-- | Insert @x@ into the sorted set @xs@, keeping it sorted and duplicate-free. type family ConsIfAbsent (x :: Symbol) (xs :: [Symbol]) :: [Symbol] where-  ConsIfAbsent x xs = If (Elem x xs) xs (x ': xs)+  ConsIfAbsent x '[]       = '[x]+  ConsIfAbsent x (y ': ys) = InsGo (CmpSymbol x y) x y ys +type family InsGo (o :: Ordering) (x :: Symbol) (y :: Symbol)+                  (ys :: [Symbol]) :: [Symbol] where+  InsGo 'LT x y ys = x ': y ': ys+  InsGo 'EQ _ y ys = y ': ys+  InsGo 'GT x y ys = y ': ConsIfAbsent x ys++-- | Union of two sorted sets: a single merge pass, @O(|xs| + |ys|)@.+--+-- The merge nests one type-family reduction per element of the result, so a+-- FIRST set of more than about a hundred non-terminals runs into GHC's+-- default reduction limit and reports @Reduction stack overflow@.  That is a+-- limit, not a slowdown: @-freduction-depth=0@ lifts it, and a union of two+-- 128-element sets then takes about 0.3 s. type family Union (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where-  Union '[]       ys = ys-  Union (x ': xs) ys = ConsIfAbsent x (Union xs ys)+  Union '[]       ys        = ys+  Union (x ': xs) '[]       = x ': xs+  Union (x ': xs) (y ': ys) = MergeGo (CmpSymbol x y) x xs y ys +type family MergeGo (o :: Ordering) (x :: Symbol) (xs :: [Symbol])+                    (y :: Symbol) (ys :: [Symbol]) :: [Symbol] where+  MergeGo 'LT x xs y ys = x ': Union xs (y ': ys)+  MergeGo 'EQ x xs _ ys = x ': Union xs ys+  MergeGo 'GT x xs y ys = y ': Union (x ': xs) ys++-- | Look up a non-terminal's entry in the environment.+--+-- This is the hot path: there is one lookup per occurrence of every+-- non-terminal in the grammar, so it is written to do as little as possible+-- per entry scanned.+--+-- Two things matter.  The search proper ('LookupMb') carries only the tail it+-- still has to scan — threading the /whole/ environment through it so the+-- not-found case could name the available non-terminals costs a traversal of+-- that environment at every step, and an environment of @n@ rules is itself+-- @O(n^2)@ type nodes because every rule carries a FIRST set.  The+-- environment is therefore named once, in 'Found', which only reduces after+-- the search has finished.+--+-- And the match is on a /non-linear/ pattern — @s@ appears twice in the+-- second clause — rather than on @CmpSymbol s t@ dispatched through a helper+-- family.  GHC decides the clause by syntactic equality and by apartness for+-- the fall-through, which is one type-family reduction per entry instead of+-- two.  (The trick is @Data.Type.Map@'s, from @type-level-sets@.)  It costs+-- nothing here: unlike 'Elem', this search has no sortedness to exploit, so+-- there was never a third case to short-circuit on. type family Lookup (s :: Symbol) (env :: Env) :: EnvEntry where-  Lookup s env = LookupGo s env env+  Lookup s env = Found s env (LookupMb s env) -type family LookupGo (s :: Symbol) (env :: Env) (full :: Env) :: EnvEntry where-  LookupGo s '[] full =-    TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s-         ':$$: 'Text "Available non-terminals: " ':<>: 'ShowType (Names full))-  LookupGo s ('(t, e) ': rest) full = LookupStep (SymEq s t) s e rest full+type family LookupMb (s :: Symbol) (env :: Env) :: Maybe EnvEntry where+  LookupMb _ '[]               = 'Nothing+  LookupMb s ('(s, e) ': rest) = 'Just e+  LookupMb s (_ ': rest)       = LookupMb s rest -type family LookupStep (b :: Bool) (s :: Symbol) (e :: EnvEntry)-                       (rest :: Env) (full :: Env) :: EnvEntry where-  LookupStep 'True  _ e _    _    = e-  LookupStep 'False s _ rest full = LookupGo s rest full+type family Found (s :: Symbol) (env :: Env)+                  (r :: Maybe EnvEntry) :: EnvEntry where+  Found _ _ ('Just e) = e+  Found s env 'Nothing =+    TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s+         ':$$: 'Text "Available non-terminals: " ':<>: 'ShowType (Names env))  type family Names (env :: Env) :: [Symbol] where   Names '[]               = '[]

@@ -1,16 +1,21 @@ cabal-version:      3.0 name:               typed-peg-version:            0.1.0.0+version:            0.2.0.0 synopsis:           Type-safe PEG parser combinators description:-  A library for building PEG (Parsing Expression Grammar) parsers+  A library for building Parsing Expression Grammars parsers   with compile-time safety guarantees. Grammar non-terminals are   indexed by their nullability and FIRST sets at the type level,   making left-recursive grammars a type error.   .-  A quasi-quoter ('PEG.QQ') allows writing grammars in a concrete+  A quasi-quoter (@PEG.QQ@) allows writing grammars in a concrete   DSL syntax. Indentation-sensitive parsing is supported natively-  via 'PEG.Indent'.+  via @PEG.Indent@.+  .+  Parsers run over any @PEG.Stream@ instance: @String@, strict and+  lazy @Text@, and strict and lazy @ByteString@. A character class+  produces a chunk of the input stream, so matching @[a-z]+@ against+  a @Text@ yields a slice rather than a @[Char]@.  license:            BSD-3-Clause license-file:       LICENSE@@ -21,8 +26,10 @@ bug-reports:        https://github.com/rodrigogribeiro/typed-peg/issues build-type:         Simple extra-source-files: README.md-extra-doc-files:    CHANGELOG.md-tested-with:        GHC == 9.6.7+extra-doc-files:+  CHANGELOG.md+  peg-patterns.md+tested-with:        GHC == 9.10.3  source-repository head   type:     git@@ -52,6 +59,7 @@   hs-source-dirs:  src   exposed-modules:     PEG+    PEG.CharSet     PEG.Grammar     PEG.Indent     PEG.Member@@ -59,19 +67,43 @@     PEG.QQ     PEG.QQ.HsExp     PEG.Semantics.Simple+    PEG.Stream     PEG.Syntax     PEG.TyLevel     PEG.Type   build-depends:       base             >= 4.18 && < 5-    , template-haskell >= 2.19 && < 2.22+    , bytestring       >= 0.11 && < 0.13+    , template-haskell >= 2.19 && < 2.24+    , text             >= 2.0  && < 2.2  test-suite typed-peg-examples   import:          common-opts   type:            exitcode-stdio-1.0   hs-source-dirs:  examples   main-is:         Main.hs-  other-modules:   Arith, Layout+  other-modules:   Arith, Layout, Compat, Patterns   build-depends:       base+    , bytestring+    , text     , typed-peg++benchmark typed-peg-bench+  import:          common-opts+  type:            exitcode-stdio-1.0+  hs-source-dirs:  bench+  main-is:         Main.hs+  other-modules:+    Bench.Inputs+    Bench.Peg+    Bench.Mega+  ghc-options:     -O2 -rtsopts "-with-rtsopts=-T"+  build-depends:+      base+    , typed-peg+    , bytestring+    , criterion    >= 1.6 && < 1.7+    , megaparsec   >= 9.5 && < 10+    , deepseq+    , text