diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ``` diff --git a/bench/Bench/Peg.hs b/bench/Bench/Peg.hs --- a/bench/Bench/Peg.hs +++ b/bench/Bench/Peg.hs @@ -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 diff --git a/examples/Compat.hs b/examples/Compat.hs --- a/examples/Compat.hs +++ b/examples/Compat.hs @@ -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 = diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -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" diff --git a/examples/MiniPython.hs b/examples/MiniPython.hs --- a/examples/MiniPython.hs +++ b/examples/MiniPython.hs @@ -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") diff --git a/examples/Patterns.hs b/examples/Patterns.hs --- a/examples/Patterns.hs +++ b/examples/Patterns.hs @@ -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 diff --git a/peg-patterns.md b/peg-patterns.md --- a/peg-patterns.md +++ b/peg-patterns.md @@ -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. diff --git a/src/PEG/CharSet.hs b/src/PEG/CharSet.hs --- a/src/PEG/CharSet.hs +++ b/src/PEG/CharSet.hs @@ -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] diff --git a/src/PEG/Location.hs b/src/PEG/Location.hs --- a/src/PEG/Location.hs +++ b/src/PEG/Location.hs @@ -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 diff --git a/src/PEG/Parse.hs b/src/PEG/Parse.hs --- a/src/PEG/Parse.hs +++ b/src/PEG/Parse.hs @@ -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 diff --git a/src/PEG/QQ.hs b/src/PEG/QQ.hs --- a/src/PEG/QQ.hs +++ b/src/PEG/QQ.hs @@ -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) diff --git a/src/PEG/QQ/Syntax.hs b/src/PEG/QQ/Syntax.hs --- a/src/PEG/QQ/Syntax.hs +++ b/src/PEG/QQ/Syntax.hs @@ -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 diff --git a/src/PEG/Stream.hs b/src/PEG/Stream.hs --- a/src/PEG/Stream.hs +++ b/src/PEG/Stream.hs @@ -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 #-} diff --git a/src/PEG/Syntax.hs b/src/PEG/Syntax.hs --- a/src/PEG/Syntax.hs +++ b/src/PEG/Syntax.hs @@ -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 diff --git a/tests/Analysis.hs b/tests/Analysis.hs --- a/tests/Analysis.hs +++ b/tests/Analysis.hs @@ -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 diff --git a/tests/Errors.hs b/tests/Errors.hs new file mode 100644 --- /dev/null +++ b/tests/Errors.hs @@ -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 diff --git a/typed-peg.cabal b/typed-peg.cabal --- a/typed-peg.cabal +++ b/typed-peg.cabal @@ -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