typed-peg 0.5.0.0 → 0.6.0.0

raw patch · 18 files changed

+1558/−243 lines, 18 filesdep ~basedep ~bytestringdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring, template-haskell, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +109/−0
• README.md +61/−1
• bench/Bench/Peg.hs +6/−6
• examples/Compat.hs +5/−1
• examples/Main.hs +3/−3
• examples/MiniPython.hs +6/−5
• examples/Patterns.hs +51/−4
• peg-patterns.md +157/−25
• src/PEG/CharSet.hs +39/−0
• src/PEG/Location.hs +17/−4
• src/PEG/Parse.hs +507/−170
• src/PEG/QQ.hs +39/−14
• src/PEG/QQ/Syntax.hs +13/−1
• src/PEG/Stream.hs +6/−2
• src/PEG/Syntax.hs +23/−0
• tests/Analysis.hs +6/−6
• tests/Errors.hs +496/−0
• typed-peg.cabal +14/−1

@@ -2,6 +2,115 @@  ## Unreleased +### A failed parse says what it found and what it expected; `%label`++`ParseError` gains two fields, still in 0.6.0.0:++```haskell+data ParseError = ParseError+  { errLine, errColumn, errOffset :: !Int+  , errFound    :: Found        -- FoundToken "print" | FoundEnd+  , errExpected :: [Expected]   -- ExpChar, ExpString, ExpClass, ExpAny,+  }                             -- ExpEnd, ExpLabel+```++and `renderParseError` writes them as+`1:12: unexpected ';', expecting [0-9], '*', '+' or ')'`.  What was found is a+whole word when the error is on a letter, digit or `_`, and a single+character otherwise.++What was expected is everything that failed exactly at the error's offset:+characters, classes and literals as themselves, a class repeated with `*` or+`+` that stops there, and `!.` as the end of the input; nothing inside a+lookahead.  A new directive names rules in that list:++```+%label factor "an operand"   -- listed as "an operand"+%label ws     ""             -- never listed+```++A labelled rule that *starts* at the error contributes its name instead of+what it looked for; one that started before contributes what it looked for.+The splice rejects a `%label` for a rule that does not exist, a rule+labelled twice, and a name that is not a string literal.  For grammars+built with combinators there is a `Label` constructor, `label` and `hidden`.++**Cost: none while parsing.**  The grammar is compiled a second time over a+different failure tracker, and that copy is run only after a parse has+failed, and only if `errExpected` is looked at; while parsing, the tracker is+the `Int` that already tracked the position.  Allocation per input byte on+the benchmarks is unchanged (identical on most rows, +0.4% on `json`).+`Step` and `Res` take the tracker as a parameter, and `compileGrammar` a+`Tracker` constraint.++Time per parse against 0.5, pinned to one core, the three versions+interleaved per grammar (megaparsec, unchanged, varied by -4% to +6% between+runs, which is the noise): within that noise on `arith`, `csv`, `idents`,+`json` and `quoted-class`; +1% to +7% on `nested`, matching its extra+allocation; and 4% to 15% *faster* on `quoted-lookahead`, and on ByteString+generally, from the strict character in the ByteString instances.++Making the compiler generic over the tracker exposed an optimiser hazard: GHC+eta-expanded the function that compiles a node, and then compiled the grammar+again on every step it ran.  Each node is now returned boxed from a+`NOINLINE` function, which a comment in `PEG.Parse` explains.++`typed-peg-errors` now checks the found token and the expected list as+well: cases for each rule above, `%label` errors at the splice, and the+reference interpreter, extended with labels, on 3000 generated grammars.++### Breaking. A failed parse says where: `Fail ParseError`++`Fail` carries the line, column and offset of the error (version 0.6.0.0):++```haskell+data Result s a = OK a s s | Fail !ParseError++data ParseError = ParseError+  { errLine   :: !Int   -- from 1+  , errColumn :: !Int   -- from 1+  , errOffset :: !Int   -- characters before the error+  }+```++With `%start e:expr !.`, so that the whole input has to parse:++```+ghci> parse arith "1+*3"+Fail (ParseError {errLine = 1, errColumn = 3, errOffset = 2, ...})+```++The position is the *furthest* offset at which any part of the grammar failed+during the parse, not where the start expression finally gave up: an ordered+choice backtracks before trying its next alternative, so the latter is nearly+always the start of some rule.  A string literal fails where it starts, the+failure that ends a repetition counts, and nothing inside a lookahead does —+so a `!.` ending the start expression reports the start of the leftover+input.  Columns follow `PEG.Location`: a tab advances the column by one.++Migration: a pattern `Fail` becomes `Fail _`, or `Fail e` to use the+position.++**How it is tracked.**  Every compiled step takes the furthest failure offset+so far and returns it on both branches, as a boxed `Int` that is passed along+unchanged unless the furthest point moves forward; the line and column are+computed only after a parse has failed, from the consumed prefix of the input.+`Step`, `Res` and therefore `compileGrammar` change type.++Allocation per input byte on the benchmark grammars, against 0.5: within 1%+on `arith`, `csv` and `quoted-*`; +1–4% on `json`, and on `idents` over+`String`/`Text`; +5–8% on `nested`, deeply parenthesised input whose+furthest point moves forward on nearly every character.  ByteString parsers+allocate *less* on `json` and `quoted-lookahead`, because the instance now+forces each character it reads rather than handing a predicate a thunk.++`offsetToLineCol` walks the input only up to the offset instead of indexing+all of it; its results are unchanged.++New test suite `typed-peg-errors`: hand-picked cases for each rule above, and+a reference interpreter compared with the compiled parser on 3000 generated+grammars, over `String`, `Text` and `ByteString`, with and without layout.+ ### Source positions in semantic actions: `@` and `PEG.Location`  A new `PExp` constructor, `GetOffset :: PExp s nt Int` (`getOffset`), consumes

@@ -16,6 +16,9 @@ - Indentation-sensitive parsing (`PEG.Indent`) - Quasi-quoter for concrete grammar syntax (`PEG.QQ`) - Source positions in semantic actions (`@`, `PEG.Location`)+- Syntax errors reported with a line and a column — the furthest point the+  parse reached — what was found there and what was expected, with rules+  named by `%label` - Parses any `PEG.Stream`: `String`, strict/lazy `Text`, strict/lazy   `ByteString` @@ -42,6 +45,63 @@ Lines and columns count from 1.  The parser tracks only the offset, so a grammar that does not use `@` pays nothing for it. +## Syntax errors++A parse that fails says where, what it found there, and what it expected:++```haskell+data Result s a = OK a s s | Fail !ParseError++data ParseError = ParseError+  { errLine, errColumn, errOffset :: !Int+  , errFound    :: Found          -- a word, a character, or the end+  , errExpected :: [Expected]     -- 'x', "while", [0-9], end of input, a label+  }++renderParseError :: ParseError -> String+```++`%label` names a rule in that list, and `%label rule ""` keeps it out — which+is what whitespace wants:++```haskell+[pegGrammar|+  %name   prog+  %stream String+  %start  ss:prog !.+  %label  factor "an operand"+  %label  name   "a name"+  %label  ws     ""+  ...+|]+```++`renderParseError` on three inputs that do not parse:++```+x := (1 + 2;                1:12: unexpected ';', expecting [0-9], '*', '+' or ')'+x := 1;                     2:11: unexpected ')', expecting an operand+y := (2 + ) * x;+x := 1;                     2:10: unexpected '@', expecting "print", a name or end of input+print x; @+```++A label replaces what its rule looked for when the rule *starts* at the+error; one that started earlier lists what it looked for, which is more+precise — above, one more digit would have continued the `2`.++The position is the **furthest** point at which any part of the grammar+failed to match — an ordered choice backtracks before it tries its next+alternative, so the point where the start expression finally gave up is+usually the start of a rule, well before the mistake.  A string literal fails+where it starts; nothing inside a lookahead (`!e`, `&e`) counts.  End the start+expression with `!.` to make leftover input an error rather than `rest`.++Only the offset is tracked while parsing; the line and column are computed+once, when the parse has failed.  What was expected is found by running the+grammar a second time, after a failure and only if `errExpected` is looked+at, so a parse that succeeds costs exactly what it did without any of this.+ ## Input streams  A grammar is written once and runs over any stream:@@ -299,7 +359,7 @@ a loop:  ```haskell-myParser :: String -> Result Exp+myParser :: String -> Result String Exp myParser = parse myGrammar ``` 

@@ -240,37 +240,37 @@ 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"+  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"+  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"+  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"+  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"+  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"+  Fail _      -> error "runQuotedCls: parse failed" {-# INLINE runQuotedCls #-}  sizeJ :: JValue -> Int

@@ -33,7 +33,11 @@  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"+showR (Fail e)   = "Fail " ++ showErr e++-- | Where a parse failed, as @line:column@.+showErr :: ParseError -> String+showErr e = show (errLine e) ++ ":" ++ show (errColumn e)  arithCases :: [String] arithCases =

@@ -1,6 +1,6 @@ module Main where -import PEG (parse, parseWith, Result(..))+import PEG (parse, parseWith, Result(..), ParseError(..)) import Arith (arith, evalExp) import Layout (doExp, layoutOpts) import Compat (compatMain)@@ -9,7 +9,7 @@  showResult :: Show a => Result String a -> String showResult (OK a _ _) = "OK " ++ show a-showResult Fail        = "Fail"+showResult (Fail e)    = "Fail at " ++ show (errLine e) ++ ":" ++ show (errColumn e)  main :: IO () main = do@@ -17,7 +17,7 @@   let testArith s =         let r = case parse arith s of                   OK e _ _ -> "OK " ++ show (evalExp e)-                  Fail      -> "Fail"+                  Fail _    -> "Fail"         in putStrLn $ s ++ " => " ++ r   testArith "1+2*3"   testArith "(1+2)*3"

@@ -315,18 +315,19 @@ mpyOpts :: Opts mpyOpts = defaultOpts { optTokenMode = relD geR } -parseMiniPython :: String -> Maybe Program+parseMiniPython :: String -> Either ParseError Program parseMiniPython src = case parseWith mpyOpts miniPython src of-  OK p _ _ -> Just p-  Fail     -> Nothing+  OK p _ _ -> Right p+  Fail e   -> Left e  miniPythonMain :: IO () miniPythonMain = mapM_ run samples   where     run (label, src) = putStrLn $ label ++ " => " ++ case parseMiniPython src of-      Just (Program ss) -> "OK, " ++ show (length ss) ++ " statement(s): "+      Right (Program ss) -> "OK, " ++ show (length ss) ++ " statement(s): "                              ++ take 100 (show ss)-      Nothing           -> "Fail"+      Left e             -> "Fail at " ++ show (errLine e) ++ ":"+                              ++ show (errColumn e)      samples =       [ ("assign", "x: int = 1 + 2 * 3\n")

@@ -218,6 +218,9 @@   %stream String   %param  idx :: LineIndex   %start  prog+  %label  atom "an operand"+  %label  name "a name"+  %label  ws   ""    prog :: [Stmt] <- ws ss:stmt* !.                         { ss }   stmt :: Stmt   <- p:@ "print" ![a-z] ws e:expr ';' ws    { Print (at idx p) e }@@ -243,6 +246,36 @@     uses _   _          = []  --------------------------------------------------------------------------------+-- §4: errors.  A failed parse is reported at the furthest point it reached;+-- an error production turns a failure into a node, so that the parse goes on+-- and every error is reported, each with a message of its own.+--------------------------------------------------------------------------------++-- | 'located', with an alternative that catches a statement it cannot parse.+-- The catch-all comes last and consumes up to the next @;@, which is where+-- parsing resumes.+[pegGrammar|+  %name   recovering+  %stream String+  %param  idx :: LineIndex+  %start  prog++  prog :: [Either String Stmt] <- ws ss:stmt* !.          { ss }+  stmt :: Either String Stmt+       <- p:@ v:name ":=" ws res:(e:expr ';' r:@ ws { Right (e, r) }+                                 / q:@ skip         { Left q })+            { either (\q -> Left (show (at idx q) ++ ": expected an expression"))+                     (\(e, r) -> Right (Assign (at idx p) (at idx r) v e)) res }+        / q:@ skip                     { Left (show (at idx q) ++ ": expected a statement") }+  skip :: ()     <- [^;]* ';' ws                           { () }+  expr :: LExpr  <- t:atom ts:('+' ws u:atom)*             { foldl LAdd t ts }+  atom :: LExpr  <- p:@ ds:[0-9]+ ws                       { LNum (at idx p) (read ds) }+                 /  p:@ v:name                             { LVar (at idx p) v }+  name :: String <- cs:[a-z]+ ws                           { cs }+  ws   :: ()     <- [ \t\n]*                               { () }+|]++-------------------------------------------------------------------------------- -- Statements, to show ordered choice and the lexeme discipline -------------------------------------------------------------------------------- @@ -284,8 +317,12 @@  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"+showR (Fail e)   = "Fail " ++ showErr e +-- | Where a parse failed, as @line:column@.+showErr :: ParseError -> String+showErr e = show (errLine e) ++ ":" ++ show (errColumn e)+ patternsMain :: IO () patternsMain = do   putStrLn "### precedence ladder"@@ -314,7 +351,7 @@   mapM_ (\s -> putStrLn (show s ++ " => " ++           case parse addOp s of             OK f _ _ -> show (f (Num 1) (Num 2))-            Fail     -> "Fail"))+            Fail e   -> "Fail " ++ showErr e))     [ "+", "-", "*" ]    putStrLn "### source positions"@@ -322,8 +359,18 @@   case parse (located (lineIndex src)) src of     OK ss _ _ -> do mapM_ print ss                     mapM_ putStrLn (undefinedVars ss)-    Fail      -> putStrLn "Fail"+    Fail e    -> putStrLn ("Fail " ++ showErr e) +  putStrLn "### syntax errors"+  let bad = "x := 1;\ny := 2 + ;\n42;\nz := y;\n"+  putStrLn (showR (parse (located (lineIndex bad)) bad))+  case parse (located (lineIndex bad)) bad of+    Fail e -> putStrLn (renderParseError e)+    OK{}   -> pure ()+  case parse (recovering (lineIndex bad)) bad of+    OK rs _ _ -> mapM_ (putStrLn . either id show) rs+    Fail e    -> putStrLn ("Fail " ++ showErr e)+   putStrLn "### lexeme discipline: fully (lexeme p)"   let toks = parse (Grammar RNil (fully (lexeme [pegExpr| ds:[0-9]+ |])))                :: String -> Result String String@@ -331,4 +378,4 @@     [ "12", "  12  ", "12 x", "" ]   where     fmap' f (OK a _ _) = Just (f a)-    fmap' _ Fail       = Nothing+    fmap' _ (Fail _)   = Nothing

@@ -36,8 +36,8 @@ | 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-source-positions) — **simpler**: `p:@` instead of deferring |-| 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 |+| 4a Verified Errors | [§4](#4-errors-where-and-then-what) — position, found and expected; own messages via error productions |+| 4b Preventative Errors | [§4](#4-errors-where-and-then-what) — position, found and expected; own messages via error productions |  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@@ -239,8 +239,8 @@ ``` "12"     => OK "12" "  12  " => OK "12"-"12 x"   => Fail-""       => Fail+"12 x"   => Fail 1:4+""       => Fail 1:1 ```  Two typed-peg specifics. `ws` is a character class, so it compiles to a single@@ -298,8 +298,8 @@  ``` "negate"   keyword => OK ()          | bare => OK ()-"negatex"  keyword => Fail           | bare => OK () rest="x"-"negate2"  keyword => Fail           | bare => OK () rest="2"+"negatex"  keyword => Fail 1:7       | bare => OK () rest="x"+"negate2"  keyword => Fail 1:7       | bare => OK () rest="2" "negate x" keyword => OK () rest=" x"| bare => OK () rest=" x" ``` @@ -504,7 +504,7 @@ ``` "+" => Add (Num 1) (Num 2) "-" => Sub (Num 1) (Num 2)-"*" => Fail+"*" => Fail 1:1 ```  The rule's result type is a function, and the chain rule applies it. This is@@ -513,7 +513,7 @@  --- -## 4. Errors: the shape without the message+## 4. Errors: where, and then what  *(Willis & Wu, Patterns 4a Verified Errors and 4b Preventative Errors.)* @@ -521,32 +521,164 @@ 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+typed-peg reports *where* a parse failed, what it found there, and what it+expected. `Result` is  ```haskell-data Result s a = OK a s s | Fail+data Result s a = OK a s s | Fail !ParseError++data ParseError = ParseError+  { errLine, errColumn, errOffset :: !Int     -- line and column from 1+  , errFound    :: Found                      -- a word, a character, the end+  , errExpected :: [Expected]                 -- what would have been accepted+  } ``` -There is no position, no expected set, no label. Both patterns are therefore-unavailable in their stated form.+The messages are the library's, not the grammar author's: there is no+`lookAhead`-then-`fail "..."` to phrase one. What there is, and what can be+built from it, is below. -This is about errors found *while parsing*. Errors found afterwards — an-undefined variable, a type mismatch — can be reported where they occur,-because the AST can record positions with `@` (§3.2).+### 4.1 The furthest failure -The *rejection* half still works, and is worth using. Preventative errors-become preventative failures:+The grammar `located` of §3.2, on  ```+x := 1;+y := 2 + ;+42;+z := y;+```++fails at `2:10`: the `;` where an operand of `+` was expected. That is not+where the start expression gave up. `prog` is `ws ss:stmt* !.`; the star stops+at the start of line 2, where `stmt` fails as a whole, and `!.` then fails at+`2:1`. But on its way to failing, `stmt` got as far as the `;`, and the+position reported is the **furthest** offset at which anything failed. It is+the classic heuristic for PEG error reporting, and for a grammar written in+the lexeme discipline of §2.1 it is usually the token that is wrong.++The rules, which `PEG.Parse` documents in full:++- A character test, a character class, or the first character of `e+` fails at+  that character.+- A string literal fails where it **starts**: `"while"` against `whale` is+  reported at the `w`. It is one token.+- The failure that ends a repetition counts. That is what makes the `;` above+  visible: it was the failure that ended `stmt*`'s last attempt.+- Nothing inside a lookahead counts. `!e` succeeding means that `e` failed,+  which is not an error; `!e` failing fails where it was tried.+- Columns follow `PEG.Location`: a tab advances the column by one.++Two consequences are worth knowing.++- **End the start expression with `!.`.** Without it, a grammar that parses a+  prefix succeeds, and what it could not parse is in `rest`, not in an error.+- **A missing token is reported at the next one.** Every token consumes the+  whitespace after it, so in `if x > 1⏎    pass` — no colon — the colon is+  looked for after the newline and the indentation, and the error is at+  `pass`, not at the end of the first line. Megaparsec, with the same lexeme+  discipline, does the same.++### 4.2 What was found, and what was expected++At the furthest failure, `errFound` is what the input has — a whole word if+it is on a letter, digit or `_`, else one character, or the end of the input+— and `errExpected` is everything that failed exactly there, in the order the+grammar tried it: characters, classes and literals as themselves, a class+repeated with `*` or `+` that stops there, and `!.` as the end of the input.+Nothing inside a lookahead is listed.++Listed raw, that is precise but not always helpful: an operand would be+"`[0-9]`, `[a-z]` or `'('`", and every error would also expect whitespace,+since `ws` stops wherever the error is. `%label` names a rule instead, and an+empty name hides it. `located`, from §3.2, with three labels:++```+%label  atom "an operand"+%label  name "a name"+%label  ws   ""+```++On the input of §4.1, `renderParseError` gives++```+2:10: unexpected ';', expecting an operand+```++The rule for a label is the one that makes it mean something: a labelled rule+that **starts at the error** contributes its name instead of what it looked+for. One that started earlier contributes what it looked for — it consumed+input before failing, and its own terminals say more than its name. In+`x := (1 + 2;` the error is at the `;`, and `[0-9]+` began at the `2`, so the+message is++```+1:12: unexpected ';', expecting [0-9], '*', '+' or ')'+```++— one more digit would have been accepted too.++None of this costs anything while parsing. The list is computed by running+the grammar a second time, after it has failed, collecting only what fails at+the error's offset; a PEG is deterministic, so the second run retraces the+first. It runs only if `errExpected` is looked at.++### 4.3 Error productions++To report more than one error, or to say *what* was expected, turn the failure+into a value. An alternative placed last catches what the others could not+parse, records where with `@`, and consumes up to a point where parsing can+resume:++```+stmt :: Either String Stmt+     <- p:@ v:name ":=" ws res:(e:expr ';' r:@ ws { Right (e, r) }+                               / q:@ skip         { Left q })+          { either (\q -> Left (show (at idx q) ++ ": expected an expression"))+                   (\(e, r) -> Right (Assign (at idx p) (at idx r) v e)) res }+      / q:@ skip                     { Left (show (at idx q) ++ ": expected a statement") }+skip :: ()     <- [^;]* ';' ws                           { () }+```++On the same input this produces++```+Assign 1:1 1:8 "x" (LNum 1:6 1)+2:6: expected an expression+3:1: expected a statement+Assign 4:1 4:8 "z" (LVar 4:6 "y")+```++— both errors, each with a message, and the statements around them. Three+things to keep in mind:++- **The catch-all goes last**, or it takes input a real alternative would have+  parsed (§5.1).+- **It must consume input.** `skip` ends in `';'`; a catch-all that could match+  the empty string would make `stmt*` a repetition that cannot consume, which+  the quasi-quoter rejects.+- **`@` marks where the alternative began, not where the failure was.** The+  error on line 2 is reported at `2:6`, the start of `2 + ;`, not at the `;`:+  the choice that catches it starts there. Place the catch-all deeper — inside+  `expr`, after the `+` — to point closer, at the cost of a result type with+  room for the error.++### 4.4 Preventative failures++The *rejection* half of the paper's patterns works as it is. 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.+rather than half-consumed and rejected somewhere less obvious, and since a+failing `!'<'` fails where it was tried, that is where the error is reported.  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.+4a is expressible as a guard. Neither can attach a message of its own; §4.3+can, and `%label` (§4.2) can name what was expected.  --- @@ -677,11 +809,11 @@  Collected from above, in the order that would most help a user of this library: -1. **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. The offset that `@`-   exposes (§3.2) is the first ingredient: a failure could report the-   furthest offset reached.+1. **Messages of the grammar's own.** A `Fail` says where, what was found+   and what was expected (§4.1, §4.2), and `%label` names what was expected.+   What is missing is Patterns 4a and 4b proper: a grammar cannot fail with a+   message it phrases itself (`fail "…"` in Parsec terms). Error productions+   (§4.3) do it by hand. 2. **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.

@@ -19,9 +19,12 @@   , complementCS   , nullCS   , anyCS+  , csRanges+  , describeCS   ) where  import Data.Bits (setBit, testBit)+import Data.List (sortOn) import Data.Char (chr, ord) import Data.Word (Word64) @@ -103,3 +106,39 @@ nullCS :: CharSet -> Bool nullCS (CharSet False 0 0 0 0 []) = True nullCS _                          = False++-- | The ranges a set was built from, as maximal runs, with its polarity:+-- 'True' when the set is everything /outside/ them.  Used to describe a set+-- in an error message, so it is written for clarity, not speed.+csRanges :: CharSet -> (Bool, [(Char, Char)])+csRanges cs = (csNeg cs, runs [ c | c <- map chr [0 .. 255], rawMember c cs ]+                         ++ sortOn fst (csWide cs))+  where+    runs [] = []+    runs (c : rest) = go c c rest+    go lo hi (c : rest)+      | ord c == ord hi + 1 = go lo c rest+    go lo hi rest         = (lo, hi) : runs rest++-- | A set as the quasi-quoter would write it — @[a-z0-9_]@, @[^\"]@, or @.@+-- for the set of every character — for an error message.  A @-@ is written+-- as it is, so a set containing one does not always read back as itself.+describeCS :: CharSet -> String+describeCS cs = case csRanges cs of+  (True, []) -> "."+  (neg, rs)  -> "[" ++ (if neg then "^" else "") ++ concatMap range rs ++ "]"+  where+    range (lo, hi)+      | lo == hi            = esc lo+      | ord hi == ord lo + 1 = esc lo ++ esc hi+      | otherwise           = esc lo ++ "-" ++ esc hi+    esc c = case c of+      '\n' -> "\\n"+      '\t' -> "\\t"+      '\r' -> "\\r"+      '\0' -> "\\0"+      '\\' -> "\\\\"+      ']'  -> "\\]"+      '['  -> "\\["+      '^'  -> "\\^"+      _    -> [c]

@@ -56,8 +56,21 @@   Just (start, ln) -> (ln, off - start + 1)   Nothing          -> (1, off + 1)   -- a negative offset; not produced by 'parse' --- | @'lineCol' . 'lineIndex'@, for a single lookup.  Indexing costs a pass--- over the input, so build a 'LineIndex' once when there are many offsets to--- convert.+-- | @'lineCol' . 'lineIndex'@, for a single lookup.+--+-- It does not build the index: it walks the input up to the offset and no+-- further, which is what 'PEG.Parse.parseWith' uses to place a+-- 'PEG.Parse.ParseError'.  Each call is still a pass over that prefix, so+-- build a 'LineIndex' once when there are many offsets to convert. offsetToLineCol :: Stream s => s -> Int -> (Int, Int)-offsetToLineCol s = lineCol (lineIndex s)+offsetToLineCol s off+  | off < 0   = (1, off + 1)              -- as 'lineCol' places it+  | otherwise = finish (foldlS' step (LC 1 1) (takeS off s))+  where+    step (LC ln col) c+      | c == '\n' = LC (ln + 1) 1+      | otherwise = LC ln (col + 1)+    finish (LC ln col) = (ln, col)++-- | A line and a column, strict in both, for the fold above.+data LC = LC !Int !Int

@@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns        #-} {-# LANGUAGE DataKinds           #-}-{-# LANGUAGE DataKinds           #-} {-# LANGUAGE GADTs               #-} {-# LANGUAGE KindSignatures      #-} {-# LANGUAGE MagicHash           #-}@@ -17,7 +16,9 @@ -- 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.+-- remaining suffix — or, when the grammar does not match, a 'ParseError'+-- saying where in the input the parse got furthest before it failed, what it+-- found there, and what it expected instead. -- -- The input can be any "PEG.Stream" instance: 'String', strict or lazy -- 'Data.Text.Text', strict or lazy 'Data.ByteString.ByteString'.@@ -41,18 +42,102 @@ -- -- == 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.+-- A compiled step returns @(# t | (# a, 'PState' s, t #) #)@ rather than+-- @'Either' t (a, 'PState' s, t)@, where @t@ is what tracks failures — an+-- 'Int' while parsing; see below.  The two are isomorphic, but the+-- unboxed sum lives in registers: a step that succeeds no longer allocates a+-- constructor /and/ a tuple 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.+--+-- == Where a failed parse is reported+--+-- At the /furthest/ offset at which any step failed, over the whole parse.+-- The offset at which the start expression finally failed would be of little+-- use: an ordered choice backtracks to where its alternative began before+-- trying the next one, so that offset is nearly always the start of some+-- rule, well before whatever was actually wrong.+--+-- The furthest offset has to survive successes as well as failures — in+-- @(a \/ b) c@, @a@ may fail at offset 10, @b@ succeed up to offset 2 and @c@+-- fail at offset 3, and the answer is 10 — so every step takes the furthest+-- offset so far as an argument and returns it, updated, on both branches.+--+-- It is a boxed 'Int', and that is deliberate.  A compiled step is called as+-- an unknown function, and GHC's generic application code has a fast path+-- only for argument lists that are all pointers: a step taking an 'Int#'+-- between two pointers was applied piecemeal, building a partial+-- application on every call, which more than doubled the allocation of+-- some grammars.  A boxed 'Int' is a pointer like the other arguments, and+-- is passed along unchanged — no new box — unless the furthest failure+-- moves forward; see 'noteAt'.+--+-- What counts as a failure:+--+-- * A character test that does not match — 'Term', 'Sat', 'AnyChar', the+--   first character of 'Span1' — fails at the offset of that character.  So+--   does a character the indentation constraints reject.+-- * A string literal fails at the offset where it /starts/, wherever in it the+--   mismatch is: it is one token, and \"expected @while@\" is about the+--   token.+-- * A repetition ends at a failure, and that failure counts: in+--   @(a b)*@ an iteration that matched @a@ and then failed in @b@ is the+--   furthest point reached, even though the repetition itself succeeds.  A+--   'Span' or 'Span1' is a repetition of a character test, and counts the+--   character it stops at in the same way.+-- * Nothing inside a lookahead counts.  @!e@ succeeding means @e@ failed,+--   which is not an error; when @!e@ itself fails, it fails at the offset+--   where it was tried.  That is what makes a @!.@ at the end of a start+--   expression report the start of the trailing input.+--+-- Only the offset is tracked while parsing.  'parseWith' turns it into a line+-- and a column once, after the parse has failed, with one pass over the+-- consumed prefix of the input ("PEG.Location"); a parse that succeeds never+-- pays for it.+--+-- == What was expected: a second pass, on failure only+--+-- A 'ParseError' also lists what the grammar was looking for at the error's+-- offset, @F@.  Collecting that while parsing would cost a list cell on every+-- failed alternative, on every parse.  Instead the grammar is compiled a+-- second time, with a different 'Tracker', and that copy is run only after a+-- parse has failed, from the start, to collect what fails exactly at @F@.  A+-- PEG is deterministic, so the second run retraces the first.  The second+-- copy is compiled the first time it is needed, and 'errExpected' is lazy:+-- a caller that never looks at it never runs it.+--+-- The two passes are the same compiler, 'compileE', over two trackers, so+-- they cannot disagree about the grammar; while parsing, the tracker is the+-- 'Int' above, and everything describing what was expected is dropped+-- unevaluated.+--+-- What is collected at @F@ ('Expected'):+--+-- * A character, a class, any character, or a string literal that fails+--   there, as itself.  A literal fails where it starts, so it is listed when+--   it starts at @F@.+-- * A class repeated by 'Span' or 'Span1' that stops at @F@: one more of it+--   would have been accepted.+-- * @!.@ failing there, as 'ExpEnd'.  No other lookahead contributes, and+--   nothing inside a lookahead does.+-- * A 'Label'led expression that /starts/ at @F@ and collects anything there+--   contributes its name instead.  One that starts before @F@ contributes+--   what it collected, which is more precise.  An expression labelled with+--   the empty name contributes nothing, wherever it starts — that is how+--   whitespace is kept out of the list. module PEG.Parse   ( Result (..)+  , ParseError (..)+  , Found (..)+  , Expected (..)+  , renderParseError+  , showFound+  , showExpected   , parse   , parseWith   , compileGrammar+  , Tracker   , Step   , Res   , Opts (..)@@ -61,14 +146,19 @@   , nextCol   ) where +import Data.Char (isAlphaNum) import Data.Kind (Type)+import Data.List (intercalate) import qualified Data.ByteString as B+import qualified Data.Set        as Set import qualified Data.Text       as T+import GHC.Exts  (Int (I#), isTrue#, (>#)) -import PEG.CharSet (CharSet, memberCS)+import PEG.CharSet (CharSet, csRanges, describeCS, memberCS) import PEG.Grammar import PEG.Indent import PEG.Key+import PEG.Location (offsetToLineCol) import PEG.Member import PEG.Stream import PEG.Syntax@@ -78,12 +168,111 @@ -- -- @'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.+-- remaining input.  @'Fail' e@ means it did not, and @e@ says where and why.+--+-- A grammar that matches a prefix of the input succeeds: end the start+-- expression with @!.@ to demand all of it, and trailing input that does not+-- parse is then reported as a 'Fail' at the furthest point reached. data Result s a   = OK a s s-  | Fail+  | Fail !ParseError   deriving (Show, Eq) +-- | Where a parse failed, what was there, and what the grammar expected+-- instead.  The position is the furthest point in the input at which any+-- part of the grammar failed to match; see the note at the top of this module+-- for exactly what that is, and for what is listed as expected.+--+-- The line and column are those of "PEG.Location", both counted from 1, with+-- a tab advancing the column by one.  On a 'Data.ByteString.ByteString' the+-- offset and the column count bytes.+--+-- 'errFound' and 'errExpected' are lazy: the second pass that computes+-- 'errExpected' runs only if it is looked at.+data ParseError = ParseError+  { errLine     :: !Int         -- ^ Line, from 1.+  , errColumn   :: !Int         -- ^ Column, from 1.+  , errOffset   :: !Int         -- ^ Characters of the input before the failure.+  , errFound    :: Found        -- ^ What the input has there.+  , errExpected :: [Expected]   -- ^ What would have been accepted there, in+                                --   the order the grammar tried it.+  } deriving (Show, Eq)++-- | What the input has at the position of an error.+data Found+  = FoundToken String  -- ^ A word — a run of letters, digits and @_@ — or+                       --   else a single character.+  | FoundEnd           -- ^ The end of the input.+  deriving (Show, Eq, Ord)++-- | Something the grammar would have accepted at the position of an error.+data Expected+  = ExpChar Char       -- ^ A character: @\'x\'@.+  | ExpString String   -- ^ A string literal: @\"while\"@.+  | ExpClass String    -- ^ A character class, written as in the grammar.+  | ExpAny             -- ^ Any character: @.@.+  | ExpEnd             -- ^ The end of the input: a @!.@ failed there.+  | ExpLabel String    -- ^ The name a 'Label' gave an expression.+  deriving (Show, Eq, Ord)++-- | How a 'Found' reads in a message.+showFound :: Found -> String+showFound FoundEnd         = "end of input"+showFound (FoundToken [c]) = show c+showFound (FoundToken w)   = show w++-- | How an 'Expected' reads in a message.+showExpected :: Expected -> String+showExpected e = case e of+  ExpChar c   -> show c+  ExpString w -> show w+  ExpClass d  -> d+  ExpAny      -> "any character"+  ExpEnd      -> "end of input"+  ExpLabel l  -> l++-- | A one-line message, in English:+--+-- @+-- 1:12: unexpected \';\', expecting \'*\', \'+\' or \')\'+-- @+--+-- Build your own from the fields for another language or format.+renderParseError :: ParseError -> String+renderParseError e =+  show (errLine e) ++ ":" ++ show (errColumn e) ++ ": unexpected "+    ++ showFound (errFound e)+    ++ case map showExpected (errExpected e) of+         [] -> ""+         xs -> ", expecting " ++ orList xs+  where+    orList [x] = x+    orList xs  = intercalate ", " (init xs) ++ " or " ++ last xs++-- | The 'ParseError' at an offset of an input, given what was expected there.+parseErrorAt :: Stream s => s -> Int -> [Expected] -> ParseError+parseErrorAt input off expected =+  ParseError ln col off (foundAt input off) expected+  where (ln, col) = offsetToLineCol input off++-- | What an input has at an offset.+foundAt :: Stream s => s -> Int -> Found+foundAt s0 off = case unconsS (dropChars off s0) of+  (# | (# c, rest #) #)+    | isWord c  -> FoundToken (c : word rest)+    | otherwise -> FoundToken [c]+  _             -> FoundEnd+  where+    isWord c = isAlphaNum c || c == '_'+    word s = case unconsS s of+      (# | (# c, rest #) #) | isWord c -> c : word rest+      _                                -> []+    dropChars n s+      | n <= 0    = s+      | otherwise = case unconsS s of+          (# | (# _, rest #) #) -> dropChars (n - 1) rest+          _                     -> s+ -- | Internal parser state. -- -- The column of the character at the head of 'stInput' is carried alongside@@ -97,16 +286,101 @@   , stAlign :: !Bool     -- ^ Whether the next token must be aligned.   } --- | What a compiled step returns: either failure (the left injection, which--- carries nothing) or a value together with the state after it.+-- | What a compiled step returns: either failure, with the failure tracker,+-- or a value together with the state after it and the tracker. ----- This is @'Maybe' (a, 'PState' s)@ with the two boxes removed.-type Res s a = (# (# #) | (# a, PState s #) #)+-- This is @'Either' t (a, 'PState' s, t)@ with the boxes removed.+type Res s t a = (# t | (# a, PState s, t #) #) --- | 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+-- | A compiled parser.  It takes the ambient column relation, because a rule+-- body inherits the relation in force at its call site, and the failure+-- tracker, which it returns updated.+type Step s t a = RelD -> t -> PState s -> Res s t a +-- | What a compiled grammar records about its failures.+--+-- While parsing it is an 'Int', the furthest offset at which anything has+-- failed.  After a parse has failed, the grammar is run again over a tracker+-- that knows that offset and collects what was expected there.  The class is+-- exported only so that 'compileGrammar' can be; its two instances are all+-- there is.+class Tracker t where+  -- | Something described by the 'Expected' failed at an offset.+  failedAt  :: t -> Int -> Expected -> t+  -- | Something that is not worth describing failed at an offset.+  failedAt_ :: t -> Int -> t+  -- | Run a step under a 'Label'.+  labelled  :: String -> Step s t a -> Step s t a++-- | The furthest failure offset.+--+-- When the offset is no further, the box passed in is returned as it is, so+-- a new 'Int' is allocated only when the furthest failure moves forward —+-- at most once per character of input, and in practice far less often.+-- What was expected is never looked at, and never built.+instance Tracker Int where+  failedAt far off _ = noteAt far off+  failedAt_          = noteAt+  labelled _ p       = p+  {-# INLINE failedAt #-}+  {-# INLINE failedAt_ #-}+  {-# INLINE labelled #-}++noteAt :: Int -> Int -> Int+noteAt far@(I# f) (I# o)+  | isTrue# (o ># f) = I# o+  | otherwise        = far+{-# INLINE noteAt #-}++-- | The second pass: the offset of the error, found by the first, and what+-- has been expected there so far, most recent first.+data Diag = Diag !Int [Expected]++instance Tracker Diag where+  failedAt d@(Diag f es) off e+    | off == f  = Diag f (e : es)+    | otherwise = d+  failedAt_ d _ = d+  labelled l p = \tau (Diag f outer) st ->+    let finish (Diag _ inner) = Diag f (own inner ++ outer)+        own inner+          | null l                         = []+          | stOff st == f, not (null inner) = [ExpLabel l]+          | otherwise                      = inner+    in case p tau (Diag f []) st of+         (# d | #)               -> (# finish d | #)+         (# | (# x, s1, d #) #) -> (# | (# x, s1, finish d #) #)++-- | What a 'Diag' collected, in the order it was tried, without repeats.+expectedIn :: Diag -> [Expected]+expectedIn (Diag _ es) = go Set.empty (reverse es)+  where+    go _ [] = []+    go seen (e : rest)+      | Set.member e seen = go seen rest+      | otherwise         = e : go (Set.insert e seen) rest++-- | Fail at an offset.+--+-- The tracker is forced before it goes into the result.  A field of an+-- unboxed sum is lazy, and left alone this would build a thunk on every+-- failure — the one thing a failing step must not do.+failOff :: Tracker t => t -> Int -> Expected -> Res s t a+failOff t off e = case failedAt t off e of !t' -> (# t' | #)+{-# INLINE failOff #-}++failOff_ :: Tracker t => t -> Int -> Res s t a+failOff_ t off = case failedAt_ t off of !t' -> (# t' | #)+{-# INLINE failOff_ #-}++-- | How a set reads as an 'Expected'.+expectCS :: CharSet -> Expected+expectCS cs = case csRanges cs of+  (True, [])         -> ExpAny+  (False, [(a, b)])+    | a == b         -> ExpChar a+  _                  -> ExpClass (describeCS cs)+ -- | Column of the character following @c@, given a column of @c@ and a tab -- width. nextCol :: Int -> Int -> Char -> Int@@ -149,12 +423,21 @@              Stream s => Opts -> Grammar s nt a -> s -> Result s a parseWith opts g = run   where-    step = compileGrammar (optTabWidth opts) g+    step = compileGrammar (optTabWidth opts) g :: Step s Int a+    -- Compiled the first time a parse fails and something asks what was+    -- expected; shared from then on, like 'step'.+    diag = compileGrammar (optTabWidth opts) g :: Step s Diag a     tau0 = optTokenMode opts+    from input = PState input 0 0 (optCands opts) False -    run input = case step tau0 (PState input 0 0 (optCands opts) False) of-      (# (# #) | #)       -> Fail-      (# | (# a, st #) #) -> OK a (takeS (stOff st) input) (stInput st)+    run input = case step tau0 0 (from input) of+      (# far | #)            -> Fail (parseErrorAt input far (expected input far))+      (# | (# a, st, _ #) #) -> OK a (takeS (stOff st) input) (stInput st)++    expected input far = case diag tau0 (Diag far []) (from input) of+      (# d | #)              -> expectedIn d+      -- Cannot happen: the grammar failed on this input a moment ago.+      (# | (# _, _, d #) #) -> expectedIn d {-# INLINABLE parseWith #-} {-# SPECIALIZE parseWith       :: Opts -> Grammar String nt a -> String -> Result String a #-}@@ -171,43 +454,43 @@ -- | 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) (defs :: Env) where-  CNil  :: CRules s '[]-  CCons :: Step s a-        -> CRules s rest-        -> CRules s ('(n, 'EnvEntry a) ': rest)+data CRules (s :: Type) (t :: Type) (defs :: Env) where+  CNil  :: CRules s t '[]+  CCons :: Step s t a+        -> CRules s t rest+        -> CRules s t ('(n, 'EnvEntry a) ': rest) -clookup :: Member n defs a -> CRules s defs -> Step s a+clookup :: Member n defs a -> CRules s t defs -> Step s t a clookup Here      (CCons f _)    = f clookup (There m) (CCons _ rest) = clookup m rest  -- | A compiled rule, wrapped so that 'Step' can be the image of a 'Table'.-newtype CStep s a = CStep { unCStep :: Step s a }+newtype CStep s t a = CStep { unCStep :: Step s t a }  -- | Traverse the grammar once and return a closure that consumes input. -- -- The traversal resolves every non-terminal reference to the corresponding -- compiled rule, so at parse time a non-terminal costs one indirect call -- instead of a walk down the rule list.-compileGrammar :: forall s nt a.-                  Stream s => Int -> Grammar s nt a -> Step s a+compileGrammar :: forall s t nt a. (Stream s, Tracker t)+               => Int -> Grammar s nt a -> Step s t a compileGrammar tw (Grammar rules start) = compileListed tw rules start compileGrammar tw (Keyed rules start)   = compileKeyed tw tabulate rules start  -- | A grammar over a type-level environment: the rules are compiled into a -- list, and a reference is resolved by following its membership proof down -- that list, once, while the grammar is being compiled.-compileListed :: forall s env a. Stream s-              => Int -> Rules s env env -> PExp s (InEnv env) a -> Step s a+compileListed :: forall s t env a. (Stream s, Tracker t)+              => Int -> Rules s env env -> PExp s (InEnv env) a -> Step s t a compileListed tw rules start = compileE tw resolve start   where-    table :: CRules s env+    table :: CRules s t env     table = build rules -    resolve :: forall b. InEnv env b -> Step s b+    resolve :: forall b. InEnv env b -> Step s t b     resolve (InEnv w) = clookup w table -    build :: forall defs. Rules s env defs -> CRules s defs+    build :: forall defs. Rules s env defs -> CRules s t defs     build RNil                = CNil     build (RCons _ body rest) = CCons (compileE tw resolve body) (build rest) {-# INLINABLE compileListed #-}@@ -226,19 +509,20 @@ -- reached this function, and a grammar over keys ran the whole parse through -- the 'Stream' dictionary — on MiniPython, 37% slower and 48% more allocation -- per character than the same grammar over an environment.  With only--- 'Stream' left to specialise on, the two compile to the same code.-compileKeyed :: forall s nt a. Stream s+-- 'Stream' and 'Tracker' left to specialise on, the two compile to the same+-- code.+compileKeyed :: forall s t nt a. (Stream s, Tracker t)              => Int              -> (forall f. (forall b. nt b -> f b) -> Table nt f)              -> (forall b. nt b -> PExp s nt b)              -> PExp s nt a-             -> Step s a+             -> Step s t a compileKeyed tw tab rules start = compileE tw resolve start   where-    table :: Table nt (CStep s)+    table :: Table nt (CStep s t)     table = tab (\k -> CStep (compileE tw resolve (rules k))) -    resolve :: forall b. nt b -> Step s b+    resolve :: forall b. nt b -> Step s t b     resolve k = unCStep (lookupTable table k) {-# INLINABLE compileKeyed #-} @@ -246,13 +530,14 @@ {-# 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.+-- stream should mark their own monomorphic parser bindings INLINABLE.  Only+-- the parsing tracker is listed: the second pass runs once per failed parse. {-# SPECIALIZE compileGrammar-      :: Int -> Grammar String nt a -> Step String a #-}+      :: Int -> Grammar String nt a -> Step String Int a #-} {-# SPECIALIZE compileGrammar-      :: Int -> Grammar T.Text nt a -> Step T.Text a #-}+      :: Int -> Grammar T.Text nt a -> Step T.Text Int a #-} {-# SPECIALIZE compileGrammar-      :: Int -> Grammar B.ByteString nt a -> Step B.ByteString a #-}+      :: Int -> Grammar B.ByteString nt a -> Step B.ByteString Int a #-}  -- | Does this class avoid the two characters whose column advance is not -- simply @+1@?  When it does, the column after a matched run is the column@@ -260,8 +545,13 @@ simpleCS :: CharSet -> Bool simpleCS cs = not (memberCS '\n' cs) && not (memberCS '\t' cs) -compileE :: forall s nt a. Stream s-         => Int -> (forall b. nt b -> Step s b) -> PExp s nt a -> Step s a+-- | A compiled step, in a box the optimiser cannot see through; see @node@ in+-- 'compileE'.  The field is lazy, so that a reference to a rule is not forced+-- while the rule table that it points into is still being built.+data Box a = Box a++compileE :: forall s t nt a. (Stream s, Tracker t)+         => Int -> (forall b. nt b -> Step s t b) -> PExp s nt a -> Step s t a compileE tw resolve = comp   where     -- Select the stream operations once per compiled grammar.  Leaving them@@ -275,109 +565,135 @@     !packS   = packString    :: String -> s     !emptyS  = packS [] -    comp :: forall b. PExp s nt b -> Step s b+    -- Each terminal is compiled with its description as an 'Expected'.  It is+    -- a thunk built once per grammar node, and forced only by the second+    -- pass; while parsing, the 'Int' tracker ignores it.+    comp :: forall b. PExp s nt b -> Step s t b+    comp e = case node e of Box p -> p -    comp (Pure x) = \_ st -> (# | (# x, st #) #)+    -- Every node returns its step in a 'Box'.  A function returning a data+    -- constructor cannot be eta-expanded, and that is the point: without the+    -- box GHC gave the compiler the step's three arguments as well, judged+    -- the partial application @comp e@ cheap, and moved it inside the+    -- step's lambda — so the grammar was walked again on every step taken,+    -- a million times in two hundred parses on the benchmarks.+    node :: forall b. PExp s nt b -> Box (Step s t b)+    -- Inlined into @comp@, the box would be taken apart again by a case of a+    -- known constructor, and the eta-expansion would be back.+    {-# NOINLINE node #-} -    comp (Term c) = satStep (c ==)+    node (Pure x) = Box $ \_ t st -> (# | (# x, st, t #) #) -    comp (Sat cs) = satStep (\c -> memberCS c cs)+    node (Term c) = Box $ satStep (c ==) (ExpChar c) -    comp AnyChar  = satStep (const True)+    node (Sat cs) = Box $ satStep (\c -> memberCS c cs) (expectCS cs) -    comp (Str lit) = litStep lit+    node AnyChar  = Box $ satStep (const True) ExpAny +    node (Str lit) = Box $ litStep lit+     -- Consumes nothing: the offset is already in the state.-    comp GetOffset = \_ st -> (# | (# stOff st, st #) #)+    node GetOffset = Box $ \_ t st -> (# | (# stOff st, st, t #) #)      -- 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+    node (Span  cs) = Box $ spanChunk (\c -> memberCS c cs) (simpleCS cs) False (expectCS cs)+    node (Span1 cs) = Box $ spanChunk (\c -> memberCS c cs) (simpleCS cs) True  (expectCS cs)      -- The key has already been resolved to its compiled rule by whoever     -- built @resolve@; this is one lookup per occurrence, at compile time.-    comp (NT k) = resolve k+    node (NT k) = Box $ resolve k +    -- While parsing, this is @comp e@ itself: the 'Int' tracker's 'labelled'+    -- is the identity, so a label costs nothing until a parse has failed.+    node (Label l e) = Box $ labelled l (comp e)+     -- 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) =+    node (Seq ef ex) = Box $       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 #) #)+      in \tau t st -> case pf tau t st of+           (# f | #)               -> (# f | #)+           (# | (# g, s1, t1 #) #) -> case px tau t1 s1 of+             (# f | #)               -> (# f | #)+             (# | (# x, s2, t2 #) #) -> (# | (# g x, s2, t2 #) #) -    comp (Choice e1 e2) =+    -- The second alternative starts from where the first one got furthest.+    node (Choice e1 e2) = Box $       let p = comp e1           q = comp e2-      in \tau st -> case p tau st of-           (# (# #) | #) -> q tau st-           r             -> r+      in \tau t st -> case p tau t st of+           (# f | #) -> q tau f 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+    node (Star (Sat cs)) = Box $ spanList (\c -> memberCS c cs) (simpleCS cs) (expectCS cs)+    node (Star (Term c)) = Box $ spanList (c ==) (c /= '\n' && c /= '\t') (ExpChar c)+    node (Star AnyChar)  = Box $ spanList (const True) False ExpAny -    comp (Star e) =+    -- The failure that ends the repetition is kept: an iteration that got+    -- some way before failing may be the furthest the parse ever gets.+    node (Star e) = Box $       let p = comp e-          go acc tau st = case p tau st of-            (# (# #) | #)        -> (# | (# reverse acc, st #) #)-            (# | (# x, st' #) #) -> go (x : acc) tau st'+          go acc tau t st = case p tau t st of+            (# f | #)                -> (# | (# reverse acc, st, f #) #)+            (# | (# x, st', f #) #)  -> go (x : acc) tau f 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)+    -- A negative lookahead at a single character only needs to peek.  Only+    -- @!.@ says what it wanted: the end of the input.+    node (Not (Sat cs))   = Box $ notCharStep (\c -> memberCS c cs) Nothing+    node (Not (Term c))   = Box $ notCharStep (c ==) Nothing+    node (Not AnyChar)    = Box $ notCharStep (const True) (Just ExpEnd)     -- @!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)+    node (Not (Span1 cs)) = Box $ notCharStep (\c -> memberCS c cs) Nothing     -- @!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 _))   = \_ _ -> (# (# #) | #)+    node (Not (Span _))   = Box $ \_ t st -> failOff_ t (stOff st) -    comp (Not e) =+    -- What fails inside a lookahead is not an error, so whatever it recorded+    -- is dropped either way.+    node (Not e) = Box $       let p = comp e-      in \tau st -> case p tau st of-           (# (# #) | #) -> (# | (# (), st #) #)-           _             -> (# (# #) | #)+      in \tau t st -> case p tau t st of+           (# _ | #) -> (# | (# (), st, t #) #)+           _         -> failOff_ t (stOff st) -    comp (Map f e) =+    node (Map f e) = Box $       let p = comp e-      in \tau st -> case p tau st of-           (# (# #) | #)       -> (# (# #) | #)-           (# | (# x, s1 #) #) -> (# | (# f x, s1 #) #)+      in \tau t st -> case p tau t st of+           (# r | #)               -> (# r | #)+           (# | (# x, s1, t1 #) #) -> (# | (# f x, s1, t1 #) #) -    comp (Indent rho e) =+    node (Indent rho e) = Box $       let p  = comp e           !rd = relD rho-      in \tau st ->-           case p tau st { stCands = preimage rd (stCands st) } of-             (# (# #) | #)       -> (# (# #) | #)-             (# | (# x, s1 #) #) ->+      in \tau t st ->+           case p tau t st { stCands = preimage rd (stCands st) } of+             (# f | #)               -> (# f | #)+             (# | (# x, s1, t1 #) #) ->                (# | (# x                      , s1 { stCands = interI (stCands st)-                                             (image rd (stCands s1)) } #) #)+                                             (image rd (stCands s1)) }+                     , t1 #) #) -    comp (Position sigma e) =+    node (Position sigma e) = Box $       let p  = comp e           !rd = relD sigma-      in \_ st -> p rd st+      in \_ t st -> p rd t st -    comp (Align e) =+    node (Align e) = Box $       let p = comp e-      in \tau st -> case p tau st { stAlign = True } of-           (# (# #) | #)       -> (# (# #) | #)-           (# | (# x, s1 #) #) ->-             (# | (# x, s1 { stAlign = stAlign st && stAlign s1 } #) #)+      in \tau t st -> case p tau t st { stAlign = True } of+           (# f | #)               -> (# f | #)+           (# | (# x, s1, t1 #) #) ->+             (# | (# x, s1 { stAlign = stAlign st && stAlign s1 }, t1 #) #)      ------------------------------------------------------------------------     -- Terminals.  These live here rather than at the top level so that they@@ -387,133 +703,154 @@     -- | 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-      _                         -> (# (# #) | #)+    satStep :: (Char -> Bool) -> Expected -> Step s t Char+    satStep p e = \tau t st -> case uncons (stInput st) of+      (# | (# x, xs #) #) | p x -> advance tw tau t st x xs e+      _                         -> failOff t (stOff st) e+    -- Inlined so that each use sees its predicate.  Shared, it is a worker+    -- that calls the predicate as an unknown function, and allocates on every+    -- character for the privilege.+    {-# INLINE satStep #-}      -- | 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-        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-          _          -> (# (# #) | #)+    -- The result is the literal itself, so no chunk is built.  A literal+    -- fails where it starts, wherever the mismatch is: it is one token.+    litStep :: String -> Step s t String+    litStep lit = \tau t st0 ->+      let fast rest [] !col !off cands =+            (# | (# lit, PState rest col off cands False, t #) #)+          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+            _          -> failOff t (stOff st0) e -        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'-          _          -> (# (# #) | #)+          slow []       st = (# | (# lit, st, t #) #)+          slow (c : cs) st = case uncons (stInput st) of+            (# | (# x, xs #) #)+              | x == c -> case advance tw tau t st x xs e of+                            (# _ | #)               -> failOff t (stOff st0) e+                            (# | (# _, st', _ #) #) -> slow cs st'+            _          -> failOff t (stOff st0) e+      in if plainly tau st0+           then fast (stInput st0) lit (stCol st0) (stOff st0) (stCands st0)+           else slow lit st0+      where e = ExpString lit      -- | 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+    -- fold to find the resulting column.  The character the run stops at+    -- counts as a failure there, as it would for the equivalent 'Star'.+    spanChunk :: (Char -> Bool) -> Bool -> Bool -> Expected -> Step s t s+    spanChunk p simple atLeastOne e = go       where-        go tau st+        go tau t 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+              (# | (# c, _ #) #) | p c -> chunk t st+              _ | atLeastOne -> failOff t (stOff st) e+                | otherwise  -> case failedAt t (stOff st) e of+                    !f -> (# | (# emptyS, st, f #) #)+          | otherwise = loop [] tau t st -        chunk _ st = case spanS' p (stInput st) of+        chunk t 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 #) #)+                !off' = stOff st + n+                !f    = failedAt t off' e+            in (# | (# pre, PState rest col' off' (stCands st) False, f #) #)          -- 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 #) #)+        loop acc tau t st = case satStep p e tau t st of+          (# | (# x, st', f #) #) -> loop (x : acc) tau f st'+          (# f | #)+            | atLeastOne && null acc -> (# f | #)+            | otherwise -> (# | (# packS (reverse acc), st, f #) #)      -- | 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+    spanList :: (Char -> Bool) -> Bool -> Expected -> Step s t String+    spanList p simple e = go       where-        go tau st+        go tau t 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+                      !off' = stOff st + n+                      !f    = failedAt t off' e                   in (# | (# toStr pre-                           , PState rest col' (stOff st + n)-                                    (stCands st) False #) #)-              _ -> (# | (# [], st #) #)-          | otherwise = loop [] tau st+                           , PState rest col' off' (stCands st) False+                           , f #) #)+              _ -> case failedAt t (stOff st) e of+                     !f -> (# | (# [], st, f #) #)+          | otherwise = loop [] tau t st -        loop acc tau st = case satStep p tau st of-          (# | (# x, st' #) #) -> loop (x : acc) tau st'-          (# (# #) | #)        -> (# | (# reverse acc, st #) #)+        loop acc tau t st = case satStep p e tau t st of+          (# | (# x, st', f #) #) -> loop (x : acc) tau f st'+          (# f | #)               -> (# | (# reverse acc, st, f #) #)      -- | Negative lookahead at a single character: a peek, with no state built.-    notCharStep :: (Char -> Bool) -> Step s ()-    notCharStep p = go+    -- It fails, when the character is there, as @wanted@ says.+    notCharStep :: (Char -> Bool) -> Maybe Expected -> Step s t ()+    notCharStep p wanted = go       where-        go tau st+        failHere t st = case wanted of+          Just e  -> failOff t (stOff st) e+          Nothing -> failOff_ t (stOff st)++        go tau t st           | plainly tau st = case uncons (stInput st) of-              (# | (# x, _ #) #) | p x -> (# (# #) | #)-              _                        -> (# | (# (), st #) #)-          | otherwise = case satStep p tau st of-              (# (# #) | #) -> (# | (# (), st #) #)-              _             -> (# (# #) | #)+              (# | (# x, _ #) #) | p x -> failHere t st+              _                        -> (# | (# (), st, t #) #)+          | otherwise = case satStep p ExpAny tau t st of+              (# _ | #) -> (# | (# (), st, t #) #)+              _         -> failHere t st  -------------------------------------------------------------------------------- -- Column bookkeeping --------------------------------------------------------------------------------  -- | Consume the head character, updating column, offset and the candidate--- interval.+-- interval.  A character the indentation constraints reject fails at its own+-- offset, like one that does not match, and is described the same way. -- -- 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+advance :: Tracker t+        => Int -> RelD -> t -> PState s -> Char -> s -> Expected -> Res s t Char+-- The state is taken apart rather than bound whole: failing needs only its+-- offset, and holding on to the whole state made GHC rebuild it, inside the+-- worker it unpacks it into, on every call.+advance tw tau t (PState _ col off cands aligned) x xs e   | aligned =       if memberI col cands-        then (# | (# x, PState xs col' off' (singletonI col) False #) #)-        else (# (# #) | #)+        then (# | (# x, PState xs col' off' (singletonI col) False, t #) #)+        else failOff t off e   | rdTotal tau =       if nullI cands-        then (# (# #) | #)-        else (# | (# x, PState xs col' off' cands False #) #)+        then failOff t off e+        else (# | (# x, PState xs col' off' cands False, t #) #)   | memberI col (preimage tau cands) =       (# | (# x, PState xs col' off'-                        (interI cands (image tau (singletonI col))) False #) #)-  | otherwise = (# (# #) | #)+                        (interI cands (image tau (singletonI col))) False+           , t #) #)+  | otherwise = failOff t off e   where     !col' = nextCol tw col x     !off' = off + 1

@@ -51,7 +51,7 @@ import PEG.QQ.HsExp  (parseHsExp, parseHsType) import PEG.QQ.Syntax (Def (..), Directive (..), Item (..), PExpr (..),                       RelS (..), parseDirectives, parseExpr, parseGrammar,-                      spaces)+                      parseLabel, spaces)  -- | Translate a DSL expression, given a way to emit a reference to a -- non-terminal.@@ -262,11 +262,11 @@      duplicates xs = [ x | x <- nub xs, length (filter (== x) xs) > 1 ] -translateRules :: (String -> Q Exp) -> [Def] -> Q Exp-translateRules _ [] = [| RNil |]-translateRules ntRef (Def name _ expr : rest) = do-  body  <- translateExprWith ntRef expr-  rest' <- translateRules ntRef rest+translateRules :: [(String, String)] -> (String -> Q Exp) -> [Def] -> Q Exp+translateRules _ _ [] = [| RNil |]+translateRules labels ntRef (Def name _ expr : rest) = do+  body  <- withLabel labels name <$> translateExprWith ntRef expr+  rest' <- translateRules labels ntRef rest   let nameProxy = TH.AppTypeE (TH.ConE 'Name) (TH.LitT (TH.StrTyLit name))   [| RCons $(pure nameProxy) $(pure body) $(pure rest') |] @@ -329,7 +329,7 @@                          -- six spaces, so the body lines up under the bullet                          -- GHC puts in front of the first line                          [ "      " ++ l | d <- ds, l <- lines (renderDiagnostic d) ])-      Right _ -> translateRules ntByName defs+      Right _ -> translateRules [] ntByName defs  -------------------------------------------------------------------------------- -- pegGrammar: a whole grammar, environment included@@ -412,6 +412,12 @@ -- [@%param@] @%param name :: Type@, in declaration position: the grammar and --            every rule take an argument @name@, in scope in every semantic --            action.  May be repeated; the arguments are taken in order.+-- [@%label@] @%label rule "name"@: when the parse fails, and @rule@ failed+--            at the error's position without consuming anything, the list of+--            what was expected says @name@ instead of what @rule@ was looking+--            for.  @%label rule ""@ keeps @rule@ out of that list altogether,+--            which is what whitespace wants.  May be repeated, once per rule;+--            see 'PEG.Parse.ParseError' and 'PEG.Syntax.Label'. pegGrammar :: QuasiQuoter pegGrammar = QuasiQuoter   { quoteExp  = pegGrammarExp@@ -420,6 +426,12 @@   , quoteType = \_ -> fail "pegGrammar: cannot be used as a type"   } +-- | Wrap a rule's body in its @%label@, if it has one.+withLabel :: [(String, String)] -> String -> Exp -> Exp+withLabel labels name body = case lookup name labels of+  Nothing -> body+  Just l  -> TH.AppE (TH.AppE (TH.ConE 'Label) (TH.LitE (TH.StringL l))) body+ -- | A grammar that has been parsed and checked: the pieces both forms need. -- -- The analysis's own result is not among them.  It used to be — the FIRST@@ -428,9 +440,10 @@ -- diagnostics it raises.  It is still run, and it is now the only thing that -- rejects a left-recursive grammar; see "PEG.Grammar". data GrammarSrc = GrammarSrc-  { gsDirs  :: [Directive]-  , gsDefs  :: [Def]-  , gsStart :: PExpr+  { gsDirs   :: [Directive]+  , gsDefs   :: [Def]+  , gsStart  :: PExpr+  , gsLabels :: [(String, String)]  -- ^ @%label@: rule, name   }  gsNames :: GrammarSrc -> [String]@@ -468,8 +481,20 @@                         [ "      " ++ l                         | d <- ds, l <- lines (renderDiagnostic (unstart d)) ])     Right _  -> pure ()-  pure (GrammarSrc dirs defs start)+  labels <- mapM (orFailIn "%label" . parseLabel) (directives "label" dirs)+  let ruleNames = [ n | Def n _ _ <- defs ]+  case [ r | (r, _) <- labels, r `notElem` ruleNames ] of+    []    -> pure ()+    (r:_) -> fail ("pegGrammar: %label names " ++ r ++ ", which is not a rule;\n\+                   \      the grammar defines " ++ unwords ruleNames)+  case dupsOf (map fst labels) of+    []    -> pure ()+    (r:_) -> fail ("pegGrammar: the rule " ++ r ++ " has two %label directives")+  pure (GrammarSrc dirs defs start labels)   where+    orFailIn d = either (\e -> fail ("pegGrammar: in " ++ d ++ ": " ++ e)) pure+    dupsOf xs = [ x | (i, x) <- zip [0 :: Int ..] xs, x `elem` take i xs ]+     orFail = either (\e -> fail ("pegGrammar: parse error: " ++ e)) pure      -- The start expression is not a rule, so it should not be named as one.@@ -493,7 +518,7 @@ normaliseStart e                               = e  knownDirectives :: [String]-knownDirectives = ["start", "name", "env", "stream", "result", "param"]+knownDirectives = ["start", "name", "env", "stream", "result", "param", "label"]  directive :: String -> [Directive] -> Maybe String directive k ds = case directives k ds of@@ -521,7 +546,7 @@     fail "pegGrammar: %param is only meaningful in declaration position;\n\          \      an expression can use the variables in scope around it"   let ntRef = ntByWitness (gsNames gs)-  rules <- translateRules ntRef (gsDefs gs)+  rules <- translateRules (gsLabels gs) ntRef (gsDefs gs)   start <- translateExprWith ntRef (gsStart gs)   [| Grammar $(pure rules) $(pure start) |] @@ -635,7 +660,7 @@   -- One binding per rule, with the declared type as its signature.   ruleDecls <- fmap concat $ mapM     (\(Def n _ e, (_, ty)) -> do-        body <- translateExprWith ntRef e+        body <- withLabel (gsLabels gs) n <$> translateExprWith ntRef e         pure [ TH.SigD (ruleVar n)                  (signature (foldl TH.AppT (TH.ConT ''PExp) [streamT, ntT, ty]))              , TH.FunD (ruleVar n)

@@ -14,6 +14,7 @@   , P   , parseGrammar   , parseDirectives+  , parseLabel   , parseExpr   , spaces   ) where@@ -29,7 +30,8 @@   deriving Show  -- | A @%key value@ line in the header of a grammar: @%start@, @%name@,--- @%env@, @%stream@, @%result@.  The value is the rest of the line.+-- @%env@, @%stream@, @%result@, @%param@, @%label@.  The value is the rest of+-- the line. data Directive = Directive String String   deriving Show @@ -382,3 +384,13 @@     isKeyChar c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')     trim = dropWhile isSpaceC . reverse . dropWhile isSpaceC . reverse     isSpaceC c = c == ' ' || c == '\t' || c == '\r'++-- | The value of a @%label rule "name"@ directive: the rule and the name, in+-- the syntax of a string literal of the grammar.  The name may be empty.+parseLabel :: String -> Either String (String, String)+parseLabel src = do+  (rule, r1) <- ident src+  (name, r2) <- strLit r1+  case spaces r2 of+    [] -> Right (rule, name)+    r  -> errorAt "unexpected text after the name" r

@@ -215,8 +215,10 @@ {-# INLINE w2c #-}  instance Stream B.ByteString where+  -- The character is forced here: a predicate the parser calls on it may not+  -- be strict, and a lazy one would be a thunk per byte.   unconsS b = case B.uncons b of-    Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #)+    Just (w, b') -> let !c = w2c (fromIntegral w) in (# | (# c, b' #) #)     Nothing      -> (# (# #) | #)   {-# INLINE unconsS #-} @@ -237,8 +239,10 @@   {-# INLINE nullS #-}  instance Stream BL.ByteString where+  -- The character is forced here: a predicate the parser calls on it may not+  -- be strict, and a lazy one would be a thunk per byte.   unconsS b = case BL.uncons b of-    Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #)+    Just (w, b') -> let !c = w2c (fromIntegral w) in (# | (# c, b' #) #)     Nothing      -> (# (# #) | #)   {-# INLINE unconsS #-} 

@@ -67,6 +67,8 @@   , position   , align   , getOffset+  , label+  , hidden   , (<$>.)   , (<*>.)   , (.>>.)@@ -112,6 +114,7 @@ -- * 'Position'— set the column relation for tokens inside the sub-expression -- * 'Align'  — require the next token to be aligned with the current position -- * 'GetOffset' — consume nothing, return the offset of the current position+-- * 'Label'  — name the sub-expression in the \"expected\" list of an error data PExp (s :: Type) (nt :: Type -> Type) (a :: Type) where   Pure     :: a -> PExp s nt a   Term     :: Char -> PExp s nt Char@@ -164,6 +167,14 @@   -- semantic action learns where a node starts or ends; "PEG.Location" turns   -- an offset into a line and a column.  Written @\@@ in the quasi-quoter.   GetOffset :: PExp s nt Int+  -- | Report the sub-expression, in the list of what was expected at a parse+  -- error, by a name instead of by what is inside it.  It changes nothing+  -- about what the sub-expression matches, and costs nothing unless a parse+  -- fails.  The empty name hides the sub-expression from that list.  Written+  -- @%label rule "name"@ in the quasi-quoter; see 'PEG.Parse.ParseError'.+  Label    :: String+           -> PExp s nt a+           -> PExp s nt a  instance Functor (PExp s nt) where   fmap = Map@@ -225,6 +236,18 @@ -- so far.  Consumes nothing and never fails. getOffset :: PExp s nt Int getOffset = GetOffset++-- | Name an expression in the \"expected\" list of a parse error: when it+-- fails at the error's position without having consumed anything, the list+-- says the name instead of what the expression was looking for.+label :: String -> PExp s nt a -> PExp s nt a+label = Label++-- | Keep an expression out of the \"expected\" list of a parse error+-- altogether: @'label' \"\"@.  Meant for whitespace and comments, which+-- could otherwise continue at almost any error.+hidden :: PExp s nt a -> PExp s nt a+hidden = Label ""  -- | Infix synonym for 'fmapP'. (<$>.) :: (a -> b) -> PExp s nt a -> PExp s nt b

@@ -483,11 +483,11 @@   , ("a generated grammar parses",       case parse tiny "12,345" of         OK r _ rest -> r == (2, 3) && rest == ""-        Fail        -> False)+        Fail _        -> False)   , ("%param and %stream: a result type of s becomes the stream",       case parse (scaled 10) "123" of         OK r _ rest -> r == 30 && rest == ""-        Fail        -> False)+        Fail _        -> False)   ]   where     table :: Table (TinyEnv String) (Const String)@@ -542,12 +542,12 @@                  , "bare h", "xyz", "bare xq", "i", "5", "first" ])   , ("factoring keeps a failure a failure",       case parse shared "a+=;" of-        Fail -> True+        Fail _ -> True         _    -> False)   ]   where     okWith (OK r _ rest) want = r == want && rest == ""-    okWith Fail          _    = False+    okWith (Fail _)      _    = False  -- Every level of this grammar would parse its operand twice without -- factoring — once by the alternative that fails at '+', once by the one@@ -569,7 +569,7 @@       input = replicate depth '(' ++ "1+22" ++ replicate depth ')'   r <- timeout 5000000 (evaluate (case parse nest input of                                     OK n _ rest -> n == 3 && rest == ""-                                    Fail        -> False))+                                    Fail _        -> False))   pure ("a shared prefix is parsed once, not once per alternative",         r == Just True) @@ -578,7 +578,7 @@   ( "ntw parses through the witness it was given"   , case parse ntwGrammar "12,345" of       OK r _ rest -> r == (2, 3) && rest == ""-      Fail        -> False )+      Fail _        -> False )  -------------------------------------------------------------------------------- -- Extracting the grammars from an example's source

@@ -0,0 +1,496 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE GADTs           #-}+{-# LANGUAGE QuasiQuotes     #-}+{-# LANGUAGE TemplateHaskell #-}+-- | Checks where a failed parse is reported.+--+-- A 'Fail' carries the furthest offset at which any part of the grammar+-- failed, and its line and column.  That offset is threaded through every+-- compiled step, including the fast paths that match a literal or a run of a+-- class in one go and the slow paths taken under indentation constraints, so+-- it is easy to get right in one place and wrong in another.  It is checked+-- two ways:+--+-- * Hand-picked cases, each stating where the error is and why: the rules+--   'PEG.Parse' documents — a literal fails where it starts, a repetition's+--   last failure counts, nothing inside a lookahead counts — and the line and+--   column arithmetic.+-- * A reference interpreter, written to be obvious rather than fast, against+--   which the compiled parser is compared on a few thousand generated+--   grammars and inputs, over every stream and with and without layout.+--+-- What was found and expected at the error is checked the same two ways: by+-- cases for each rule 'PEG.Parse' states, and by the reference interpreter,+-- which computes the expected list straight from its definition.+module Main (main) where++import Control.Exception (SomeException, evaluate, try)+import Control.Monad (unless)+import Data.Char     (isAlphaNum)+import Data.List     (isPrefixOf, nub)+import System.Exit   (exitFailure)+import Language.Haskell.TH        (runQ)+import Language.Haskell.TH.Quote  (quoteExp)++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text             as T++import PEG+import PEG.QQ (pegGrammar)++--------------------------------------------------------------------------------+-- Hand-picked cases+--------------------------------------------------------------------------------++-- | An expression with no rules, run on a 'String'.+run :: PExp String (InEnv '[]) a -> String -> Result String a+run e = parse (Grammar RNil e)++-- | @e@ then @f@, keeping neither result.+(~>) :: PExp s nt a -> PExp s nt b -> PExp s nt ()+e ~> f = (\_ _ -> ()) <$>. e <*>. f+infixr 4 ~>++ch :: Char -> PExp s nt ()+ch c = () <$ Term c++eof :: PExp s nt ()+eof = Not AnyChar++-- | Where the expression is expected to fail: line, column, offset.+data Want = Want Int Int Int++failsAt :: Result s a -> Want -> Bool+failsAt (Fail e) (Want l c o) = (errLine e, errColumn e, errOffset e) == (l, c, o)+failsAt _        _            = False++cases :: [(String, Bool)]+cases =+  [ ("a literal fails where it starts",+      run (ch 'x' ~> Str "while") "xwhale" `failsAt` Want 1 2 1)+  , ("an alternative that got further is remembered past a later success",+      -- (abc / a) z on "abd": the first alternative fails at the d, the+      -- second succeeds, and z fails earlier than the d.+      run (((ch 'a' ~> ch 'b' ~> ch 'c') .||. ch 'a') ~> ch 'z') "abd"+        `failsAt` Want 1 3 2)+  , ("nothing inside a negative lookahead counts",+      run (Not (ch 'a' ~> ch 'b' ~> ch 'c') ~> ch 'q') "abx" `failsAt` Want 1 1 0)+  , ("a failing negative lookahead fails where it was tried",+      run (ch 'a' ~> Not (ch 'b')) "ab" `failsAt` Want 1 2 1)+  , ("nothing inside a positive lookahead counts",+      run (Not (Not (ch 'a' ~> ch 'b')) ~> ch 'q') "ax" `failsAt` Want 1 1 0)+  , ("the iteration that ends a repetition counts",+      run (Star (ch 'a' ~> ch 'b') ~> eof) "abac" `failsAt` Want 1 4 3)+  , ("a trailing !. reports the leftover input",+      run (ch 'a' ~> eof) "ax" `failsAt` Want 1 2 1)+  , ("lines are counted from 1, and a newline starts a line at column 1",+      run (Star (ch 'a' ~> ch '\n') ~> eof) "a\na\nab" `failsAt` Want 3 2 5)+  , ("the end of an input that ends in a newline is on the next line",+      run (ch 'a' ~> ch '\n' ~> ch 'b') "a\n" `failsAt` Want 2 1 2)+  , ("a tab advances the column by one",+      run (ch '\t' ~> ch 'y') "\tx" `failsAt` Want 1 2 1)+  , ("a run of a class reports the character after it",+      run (spanOf1 (fromRanges [('a', 'z')]) ~> ch ';') "abc1" `failsAt` Want 1 4 3)+  , ("an empty input fails at 1:1",+      run (ch 'a') "" `failsAt` Want 1 1 0)+  , ("a character the layout rejects fails at its own offset",+      -- Under =, every token must be in the same column; the 7 is not.+      case parseWith defaultOpts { optTokenMode = relD eqR }+                     (Grammar RNil (ch '-' ~> ch '7')) "-7" of+        r -> r `failsAt` Want 1 2 1+               && okIs (run (ch '-' ~> ch '7') "-7"))+  , ("a literal under layout still fails where it starts",+      parseWith defaultOpts { optTokenMode = relD geR }+                (Grammar RNil (ch 'x' ~> Str "while")) "xwhale"+        `failsAt` Want 1 2 1)+  , ("every stream reports the same place",+      and [ errOf (parse g s) == errOf (parse g (T.pack s))+              && errOf (parse g s) == errOf (parse g (BC.pack s))+          | s <- ["a\na\nab", "abd", "x\twhale", ""] ])+  , ("a quasi-quoted grammar points at the token that is wrong",+      -- The ';' on line 2 is where an operand was expected.+      let src = "x := 1;\ny := 2 + ;\n"+      in parse stmts src `failsAt` Want 2 10 17)+  , ("a quasi-quoted grammar that succeeds is unaffected",+      okIs (parse stmts "x := 1;\ny := 2 + 3;\n"))++    -- What was found, and what was expected.  'calc' labels factor and name,+    -- and hides ws.+  , ("a label replaces what a rule that starts at the error looked for",+      says calc "x := 1;\ny := (2 + ) * x;\nprint y;\n"+        (2, 11) (FoundToken ")") [ExpLabel "an operand"])+  , ("a rule that started before the error lists what it looked for",+      -- factor began at the 2, so its label does not apply; one more digit+      -- would have been accepted, and so would '*', '+' or ')'.+      says calc "x := (1 + 2;\n"+        (1, 12) (FoundToken ";")+        [ExpClass "[0-9]", ExpChar '*', ExpChar '+', ExpChar ')'])+  , ("a hidden rule is never listed, and a word is found whole",+      says calc "x := 1\nprint x;\n"+        (2, 1) (FoundToken "print") [ExpChar '*', ExpChar '+', ExpChar ';'])+  , ("a literal, a label and the end of the input",+      says calc "x := 1;\nprint x; @\n"+        (2, 10) (FoundToken "@") [ExpString "print", ExpLabel "a name", ExpEnd])+  , ("the end of the input is found at the end",+      says calc "x := 1 +\n" (2, 1) FoundEnd [ExpLabel "an operand"])+  , ("a negated class is described as it is written",+      says quoted "\"abc" (1, 5) FoundEnd [ExpClass "[^\"]", ExpChar '"'])+  , ("the message reads well",+      case parse calc "x := (1 + 2;\n" of+        Fail e -> renderParseError e+                    == "1:12: unexpected ';', expecting [0-9], '*', '+' or ')'"+        _      -> False)+  , ("every stream finds and expects the same",+      and [ errOf (parse calc s) == errOf (parse calc (T.pack s))+              && errOf (parse calc s) == errOf (parse calc (BC.pack s))+          | s <- [ "x := 1;\ny := (2 + ) * x;\n", "x := (1 + 2;\n"+                 , "x := 1\nprint x;\n", "x := 1 +\n" ] ])+  ]+  where+    okIs (OK _ _ _) = True+    okIs _          = False++    says :: Grammar String nt a -> String -> (Int, Int) -> Found -> [Expected]+         -> Bool+    says gr src (l, c) found expect = case parse gr src of+      Fail e -> (errLine e, errColumn e) == (l, c)+                  && errFound e == found && errExpected e == expect+      _      -> False++    g :: Stream s => Grammar s (InEnv '[]) ()+    g = Grammar RNil ((Star (ch 'a' ~> ch '\n') ~> ch 'a' ~> ch 'b' ~> ch 'c')+                       .||. (() <$ Str "x\twhile"))++    errOf :: Result s a -> Maybe ParseError+    errOf (Fail e) = Just e+    errOf _        = Nothing++[pegGrammar|+  %name   stmts+  %stream String+  %start  prog++  prog :: Int    <- ws ss:stmt* !.             { length ss }+  stmt :: ()     <- name ":=" ws expr ';' ws     { () }+  expr :: ()     <- atom ('+' ws atom)*         { () }+  atom :: ()     <- [0-9]+ ws { () } / name { () }+  name :: String <- cs:[a-z]+ ws               { cs }+  ws   :: ()     <- [ \t\n]*                   { () }+|]++-- | The grammar of the example in the documentation: factor and name are+-- labelled, and ws is hidden.+[pegGrammar|+  %name   calc+  %start  ss:prog !.+  %label  factor "an operand"+  %label  name   "a name"+  %label  ws     ""++  prog   :: Int    <- ws ss:stmt*                       { length ss }+  stmt   :: ()     <- "print" ![a-z] ws expr ';' ws     { () }+                   /  name ":=" ws expr ';' ws          { () }+  expr   :: ()     <- term ('+' ws term)*               { () }+  term   :: ()     <- factor ('*' ws factor)*           { () }+  factor :: ()     <- [0-9]+ ws { () } / name { () } / '(' ws expr ')' ws { () }+  name   :: ()     <- [a-z]+ ws                         { () }+  ws     :: ()     <- [ \t\n]*                          { () }+|]++[pegGrammar|+  %name   quoted+  %start  q:str !.+  str :: () <- '"' [^"]* '"'  { () }+|]++-- | A @%label@ the splice must refuse.  Run in 'IO', a failing quasi-quoter+-- prints its message and throws one that only says it failed, so what is+-- checked here is the refusal; the messages are on the test's output.+labelErrors :: IO [String]+labelErrors = concat <$> mapM refused+  [ "%start a\n%label b \"x\"\na :: () <- 'a' { () }"               -- not a rule+  , "%start a\n%label a \"x\"\n%label a \"y\"\na :: () <- 'a' { () }" -- twice+  , "%start a\n%label a x\na :: () <- 'a' { () }" ]                  -- not a string+  where+    refused src = do+      r <- try (runQ (quoteExp pegGrammar src)+                  >>= \e -> evaluate (length (show e)))+             :: IO (Either SomeException Int)+      pure $ case r of+        Left _  -> []+        Right _ -> ["%label: accepted " ++ show src]++--------------------------------------------------------------------------------+-- The reference interpreter+--------------------------------------------------------------------------------++-- | A grammar to generate: untyped, so that it can be both interpreted below+-- and translated to a 'PExp'.+data G+  = GChar Char+  | GSat [Char]+  | GAny+  | GStr String+  | GSpan [Char]+  | GSpan1 [Char]+  | GSeq G G+  | GCh G G+  | GStar G          -- ^ Only ever over something that consumes input.+  | GNot G+  | GOff+  | GLabel String G  -- ^ The empty string hides.+  deriving Show++-- | What 'PEG.Parse' documents, stated directly: run @g@ from @off@ with the+-- furthest failure so far @far@, and return either the new furthest failure,+-- or the offset reached and the furthest failure.+ref :: G -> Int -> Int -> String -> Either Int (Int, Int, String)+ref g far off inp = case g of+  GChar c      -> char (== c)+  GSat cs   -> char (`elem` cs)+  GAny      -> char (const True)+  GStr lit+    | lit `isPrefixOf` inp -> Right (far, off + length lit, drop (length lit) inp)+    | otherwise            -> Left (max far off)+  GSpan cs  -> let n = length (takeWhile (`elem` cs) inp)+               in Right (max far (off + n), off + n, drop n inp)+  GSpan1 cs -> let n = length (takeWhile (`elem` cs) inp)+               in if n == 0 then Left (max far off)+                            else Right (max far (off + n), off + n, drop n inp)+  GSeq a b  -> case ref a far off inp of+                 Left f              -> Left f+                 Right (f, off', r)  -> ref b f off' r+  GCh a b   -> case ref a far off inp of+                 Left f -> ref b f off inp+                 r      -> r+  GStar a   -> let go f o r = case ref a f o r of+                                Left f'            -> Right (f', o, r)+                                Right (f', o', r') -> go f' o' r'+               in go far off inp+  GNot a    -> case ref a far off inp of+                 Left _  -> Right (far, off, inp)+                 Right _ -> Left (max far off)+  GOff      -> Right (far, off, inp)+  GLabel _ a -> ref a far off inp+  where+    char p = case inp of+      (c : r) | p c -> Right (far, off + 1, r)+      _             -> Left (max far off)++-- | What 'PEG.Parse' documents as expected at the error's offset @f@, stated+-- directly: run @g@ from @off@, and return whether it matched (and where it+-- got to) together with what it listed, in the order it was tried.+refExp :: Int -> G -> Int -> String -> (Maybe (Int, String), [Expected])+refExp f g off inp = case g of+  GChar c   -> char (== c) (ExpChar c)+  GSat cs   -> char (`elem` cs) (classOf cs)+  GAny      -> char (const True) ExpAny+  GStr lit+    | lit `isPrefixOf` inp -> (Just (off + length lit, drop (length lit) inp), [])+    | otherwise            -> (Nothing, here off (ExpString lit))+  GSpan cs  -> let n = length (takeWhile (`elem` cs) inp)+               in (Just (off + n, drop n inp), here (off + n) (classOf cs))+  GSpan1 cs -> let n = length (takeWhile (`elem` cs) inp)+               in if n == 0 then (Nothing, here off (classOf cs))+                  else (Just (off + n, drop n inp), here (off + n) (classOf cs))+  GSeq a b  -> case refExp f a off inp of+                 (Nothing, ia)       -> (Nothing, ia)+                 (Just (o, r), ia)   -> let (rb, ib) = refExp f b o r+                                        in (rb, ia ++ ib)+  GCh a b   -> case refExp f a off inp of+                 (Nothing, ia) -> let (rb, ib) = refExp f b off inp+                                  in (rb, ia ++ ib)+                 r             -> r+  GStar a   -> let go o r acc = case refExp f a o r of+                                  (Nothing, ia)      -> (Just (o, r), acc ++ ia)+                                  (Just (o', r'), ia) -> go o' r' (acc ++ ia)+               in go off inp []+  -- Nothing inside a lookahead is listed; only !. says what it wanted.+  GNot a    -> case refExp f a off inp of+                 (Nothing, _) -> (Just (off, inp), [])+                 _            -> (Nothing, case a of+                                             GAny -> here off ExpEnd+                                             _    -> [])+  GOff      -> (Just (off, inp), [])+  GLabel l a -> let (ra, ia) = refExp f a off inp+                    own | null l                  = []+                        | off == f && not (null ia) = [ExpLabel l]+                        | otherwise               = ia+                in (ra, own)+  where+    here o e = [ e | o == f ]+    char p e = case inp of+      (c : r) | p c -> (Just (off + 1, r), [])+      _             -> (Nothing, here off e)+    classOf cs = case nub cs of+      [c] -> ExpChar c+      _   -> ExpClass (describeCS (fromList cs))++-- | What the input has at an offset, stated directly.+refFound :: String -> Int -> Found+refFound s off = case drop off s of+  []                      -> FoundEnd+  (c : rest) | isWord c   -> FoundToken (c : takeWhile isWord rest)+             | otherwise  -> FoundToken [c]+  where isWord c = isAlphaNum c || c == '_'++-- | Line and column of an offset, stated directly.+refLineCol :: String -> Int -> (Int, Int)+refLineCol s off = (1 + length nls, off - lineStart + 1)+  where+    nls       = [ i | (i, c) <- zip [0 :: Int ..] (take off s), c == '\n' ]+    lineStart = if null nls then 0 else last nls + 1++-- | The same grammar as a 'PExp'.  Each construct is built the way a user or+-- the quasi-quoter would build it, so the specialised cases of the compiler —+-- @'Star' ('Sat' _)@, @'Not' ('Term' _)@ and the rest — are all reached.+toP :: G -> PExp s nt ()+toP g = case g of+  GChar c      -> () <$ Term c+  GSat cs   -> () <$ Sat (fromList cs)+  GAny      -> () <$ AnyChar+  GStr s    -> () <$ Str s+  GSpan cs  -> () <$ Span (fromList cs)+  GSpan1 cs -> () <$ Span1 (fromList cs)+  GSeq a b  -> toP a ~> toP b+  GCh a b   -> toP a .||. toP b+  GStar a   -> () <$ starOf a+  GNot a    -> notOf a+  GOff      -> () <$ GetOffset+  GLabel l a -> Label l (toP a)+  where+    -- Keep the operand bare where the compiler has a case for it.+    starOf (GChar c)    = () <$ Star (Term c)+    starOf (GSat cs) = () <$ Star (Sat (fromList cs))+    starOf GAny      = () <$ Star AnyChar+    starOf a         = () <$ Star (toP a)+    notOf (GChar c)      = Not (Term c)+    notOf (GSat cs)   = Not (Sat (fromList cs))+    notOf GAny        = Not AnyChar+    notOf (GSpan cs)  = Not (Span (fromList cs))+    notOf (GSpan1 cs) = Not (Span1 (fromList cs))+    notOf a           = Not (toP a)++--------------------------------------------------------------------------------+-- Generation+--------------------------------------------------------------------------------++-- | A linear congruential generator: enough to vary the shapes, and the+-- same shapes on every run.+newtype Gen a = Gen { unGen :: Int -> (a, Int) }++instance Functor Gen where+  fmap f (Gen g) = Gen (\s -> let (a, s') = g s in (f a, s'))+instance Applicative Gen where+  pure a = Gen (\s -> (a, s))+  Gen f <*> Gen g = Gen (\s -> let (h, s1) = f s; (a, s2) = g s1 in (h a, s2))+instance Monad Gen where+  Gen g >>= k = Gen (\s -> let (a, s1) = g s in unGen (k a) s1)++choose :: Int -> Gen Int+choose n = Gen (\s -> let s' = (s * 1103515245 + 12345) `mod` 2147483648+                      in ((s' `div` 65536) `mod` n, s'))++pick :: [a] -> Gen a+pick xs = (xs !!) <$> choose (length xs)++alphabet :: [Char]+alphabet = "ab\n\t"++klass :: Gen [Char]+klass = do+  n <- (+ 1) <$> choose 2+  mapM (const (pick alphabet)) [1 .. n]++-- | A grammar of at most the given depth.  @consuming@ asks for one that+-- cannot match the empty string, which is what a repetition needs.+grammar :: Bool -> Int -> Gen G+grammar consuming d+  | d <= 0    = leaf+  | otherwise = do+      k <- choose 10+      case k of+        0 -> GSeq <$> grammar consuming (d - 1) <*> grammar False (d - 1)+        1 -> GSeq <$> grammar False (d - 1) <*> grammar consuming (d - 1)+        2 -> GCh <$> grammar consuming (d - 1) <*> grammar consuming (d - 1)+        3 | not consuming -> GStar <$> grammar True (d - 1)+        4 | not consuming -> GNot <$> grammar False (d - 1)+        5 | not consuming -> pure GOff+        6 -> GLabel <$> pick ["", "L1", "L2"] <*> grammar consuming (d - 1)+        _ -> leaf+  where+    leaf = do+      k <- choose (if consuming then 5 else 6)+      case k of+        0 -> GChar <$> pick alphabet+        1 -> GSat <$> klass+        2 -> pure GAny+        3 -> do n <- (+ 1) <$> choose 3+                GStr <$> mapM (const (pick alphabet)) [1 .. n]+        4 -> GSpan1 <$> klass+        _ -> GSpan <$> klass++input :: Gen String+input = do+  n <- choose 9+  mapM (const (pick alphabet)) [1 .. n]++-- | What the reference says a parse of the whole grammar returns.+expected :: G -> String -> Result String ()+expected g s = case ref g 0 0 s of+  Left f           -> let (l, c) = refLineCol s f+                      in Fail (ParseError l c f (refFound s f)+                                          (nub (snd (refExp f g 0 s))))+  Right (_, o, r)  -> OK () (take o s) r++-- | One generated grammar and input, over every stream, with and without+-- layout.  Under @>=@ from the full candidate interval every column is+-- acceptable, so the answer is the same, but the slow paths are taken.+agrees :: G -> String -> [String]+agrees g s =+  [ name ++ ": " ++ show g ++ " on " ++ show s ++ ": expected "+      ++ show want ++ ", got " ++ got+  | (name, got) <- runs+  , got /= show want ]+  where+    want   = expected g s+    gr     :: Stream s => Grammar s (InEnv '[]) ()+    gr     = Grammar RNil (toP g)+    layout = defaultOpts { optTokenMode = relD geR }+    shown :: Result String () -> String+    shown = show+    runs =+      [ ("String",          shown (parse gr s))+      , ("String/layout",   shown (parseWith layout gr s))+      , ("Text",            textAsString (parse gr (T.pack s)))+      , ("Text/layout",     textAsString (parseWith layout gr (T.pack s)))+      , ("ByteString",      bsAsString (parse gr (BC.pack s)))+      , ("ByteString/layout", bsAsString (parseWith layout gr (BC.pack s)))+      ]+    textAsString (OK a c r) = shown (OK a (T.unpack c) (T.unpack r))+    textAsString (Fail e)   = shown (Fail e)+    bsAsString (OK a c r)   = shown (OK a (BC.unpack c) (BC.unpack r))+    bsAsString (Fail e)     = shown (Fail e)++main :: IO ()+main = do+  let bad = [ n | (n, ok) <- cases, not ok ]+  mapM_ (putStrLn . ("FAILED: " ++)) bad+  putStrLn ("hand-picked: " ++ show (length cases - length bad) ++ " of "+              ++ show (length cases) ++ " pass")++  let samples = fst (unGen (mapM (const ((,) <$> grammar False 4 <*> input))+                                  [1 .. 3000 :: Int]) 42)+      problems = concatMap (uncurry agrees) samples+      fails    = length [ () | (g, s) <- samples+                             , Fail _ <- [expected g s] ]+  mapM_ putStrLn (take 5 problems)+  labelBad <- labelErrors+  mapM_ putStrLn labelBad+  putStrLn ("%label errors at the splice: " ++ show (3 - length labelBad)+              ++ " of 3 reported")+  putStrLn ("generated: " ++ show (length samples) ++ " grammars ("+              ++ show fails ++ " failing parses), "+              ++ show (length problems) ++ " disagreements with the reference")++  unless (null bad && null problems && null labelBad) exitFailure

@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               typed-peg-version:            0.5.0.0+version:            0.6.0.0 synopsis:           Type-safe PEG parser combinators description:   A library for building Parsing Expression Grammars parsers@@ -107,6 +107,19 @@   other-extensions: TemplateHaskell, QuasiQuotes   build-depends:       base+    , typed-peg++test-suite typed-peg-errors+  import:          common-opts+  type:            exitcode-stdio-1.0+  hs-source-dirs:  tests+  main-is:         Errors.hs+  other-extensions: TemplateHaskell, QuasiQuotes+  build-depends:+      base+    , bytestring+    , template-haskell+    , text     , typed-peg  benchmark typed-peg-bench