diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,229 @@ # Changelog +## Unreleased — compile time of large grammars + +Checking a grammar was **exponential in the size of its FIRST sets**. On a +chain of `n` mutually referring rules, GHC needed 0.7 s at `n = 8`, 12 s at +`n = 12`, and more than five minutes at `n = 15`; anything the size of a real +language front end never finished. The same grammars now check in +milliseconds-to-seconds and the curve is polynomial: `n = 12` takes 0.5 s, +`n = 30` 1.7 s, `n = 60` 14 s. + +One limit is new rather than fixed: the union of two FIRST sets nests one +type-family reduction per element of the result, so a FIRST set of more than +about a hundred non-terminals now reports `Reduction stack overflow` instead +of being slow. `-freduction-depth=0` lifts it, and a union of two 128-element +sets then takes about 0.3 s. + +### Fixed + +- **`Union` and `ConsIfAbsent` were exponential.** `ConsIfAbsent x xs` + expanded to `If (Elem x xs) xs (x ': xs)`, naming `xs` three times. In + `Union (x ': xs) ys = ConsIfAbsent x (Union xs ys)` that `xs` is an + unreduced `Union`, so each step left GHC three copies of the pending + computation to reduce and each of those tripled again: `3^n` reductions for + a union of two `n`-element sets. Both families now dispatch on an + already-computed `Ordering` in a helper whose every right-hand side names + each argument — and in particular the recursive call — exactly once. +- **`Lookup` threaded the whole environment through its recursion** so that + the not-found case could list the available non-terminals. An environment + of `n` rules is `O(n^2)` type nodes, because every entry carries a FIRST + set, and there is one lookup per occurrence of every non-terminal. The + search now carries only the tail it has still to scan; the environment is + named once, in the branch that reports the error. +- **`Lookup` matched through `CmpSymbol` and a dispatch family**, two + type-family reductions per entry scanned. It now matches on a non-linear + pattern — the name appears twice in the clause — so GHC decides each entry + by syntactic equality and apartness, in one reduction. The trick is + `Data.Type.Map`'s, from `type-level-sets`. Worth 1.4x-1.6x on a large + grammar, since the search runs once per occurrence of every non-terminal. +- **`nt` and `PExp`'s `NT` made GHC search the environment several times per + occurrence.** Their constraint was + `KnownMember n env (TyOf (Lookup n env)) (ResOf (Lookup n env))`, and + resolving `KnownMember` walks `env` one instance at a time, re-normalising + every index at each step. Both now name the entry once, through a + `Lookup n env ~ 'EnvEntry ty a` equality, and pass the resulting rigid + types to `KnownMember`. + +### Changed + +- **Breaking. A FIRST set is now written in alphabetical order**, and a + declared environment that lists one in any other order is a type error + naming the first position that disagrees. Sortedness is what makes a set + have a single spelling, which is what lets `Union` be one merge pass. + Migration is mechanical: sort each `'[...]` in your `Env`, so + `'["term", "factor", "number"]` becomes `'["factor", "number", "term"]`. +- **Breaking.** `Member` and `KnownMember` lose their `Ty` index: + `Member s env a` and `KnownMember s env a`. Every index of a class is + carried along and re-normalised at each step of the instance chain that + walks the environment, and a `Ty` carries a FIRST set — so an index for it + made each step cost `O(|env|)`. Nothing needed it; `Here` binds the + entry's `ty` existentially, which is enough to pull a rule out of a rule + table. +- `PEG.Syntax` exports `NTGo`, the `Ty` of a reference to a non-terminal + whose own `Ty` is already known. `NTTy n env` is now defined as + `NTGo n (TyOf (Lookup n env))` and keeps working in signatures. + +`SeqTy` and `ChoiceTy` are deliberately **unchanged**. They duplicate their +operands across their right-hand sides too, but measurement says that costs +nothing here, and writing them as type synonyms is what makes them reduce to a +`'MkTy` head while their operands are still abstract — which is what lets a +polymorphic combinator such as `lexeme` compose without its caller having to +get the nesting of `SeqTy` exactly right. + +## 0.2.0.0 — 2026-09-04 + +This release is **not source-compatible with 0.1.0.0**: `PExp`, `Rules`, +`Grammar`, `Result` and `PState` all gain a leading stream type parameter, and +a rule whose result is a character-class repetition changes result type. See +*Changed* below for the migration. + +### Added — parsing any stream, not just `String` + +`PEG.Stream` introduces a `Stream` class, with instances for `String`, strict +and lazy `Data.Text.Text`, and strict and lazy `Data.ByteString.ByteString`. +A grammar written once runs over any of them. + +The genericity reaches the *results*, not just the input: a character-class +repetition such as `cs:[a-zA-Z0-9_]+` now produces a **chunk of the input +stream** — a real `Text` slice — instead of unpacking into a `[Char]`. Two new +`PExp` constructors, `Span` and `Span1`, carry this; the quasi-quoter emits +them for `[...]*`, `[...]+`, `'c'*`, `'c'+`, `.*` and `.+`. + +`ByteString` is read as Latin-1, exactly as `Data.ByteString.Char8` does: fast, +correct for ASCII, and wrong for multi-byte UTF-8. `PEG.Stream`'s Haddock +states this as a law rather than a footnote. + +Only `unconsS` has no default, so a user instance is one method. It returns an +unboxed sum rather than `Maybe (Char, s)` on purpose — behind a class +dictionary the boxed version would allocate a `Just` and a pair for every +character, losing the zero-allocation terminal path. + +### Changed + +- **Breaking.** `PExp`, `Rules` and `Grammar` take a leading stream parameter: + `PExp s env ty a`, `Rules s env defs`, `Grammar s env ty a`. `Result` and + `PState` likewise: `Result s a`, `PState s`. +- **Breaking.** A rule whose result is a character-class repetition now has + result type `s`, so its `Env` synonym takes a parameter. Semantic actions + that fed such a result to something expecting a `String` need + `chunkToString`: `number <- ds:[0-9]+ { Lit (read (chunkToString ds)) }`. +- **Breaking.** The symbol variable in `PExp`'s `NT`, in `nt`, and in + `Rules`'s `RCons` is now named `n`; `s` is the stream. `nt @"name"` is + unaffected — the name is deliberately still the first quantified variable. +- `PEG.Semantics.Simple`'s unrelated `Stream` class is renamed + `SimpleStream`, to leave the name to `PEG.Stream`. +- `PState`'s input field is now strict. + +A `Grammar` is monomorphic in its stream. Reusing one across stream types +needs a `forall s. Stream s => Grammar s env ty a` signature, which turns the +value into a function of a dictionary and so stops the compiled parser being +shared between calls. Give parsers a monomorphic top-level binding where that +matters; `PEG.Parse`'s Haddock spells this out. + +### Performance + +Measured on the benchmark suite, bytes allocated per input byte, against the +previous release of the evaluator: + +| grammar | before (String) | String | Text | ByteString | megaparsec | +|---|---|---|---|---|---| +| arith | 990 | 943 | 1127 | 969 | 1239 | +| csv | 834 | 787 | 951 | 805 | 1035 | +| json | 459 | 404 | 583 | 452 | 782 | +| nested | 265 | 312 | 481 | 336 | 1283 | +| quoted `(!'"' .)*` | 162 | 209 | 320 | 250 | 128 | + +`ByteString` is the cheapest column on five of the seven grammars and beats +megaparsec on six. `Text` costs more than `String` throughout — the same +result the earlier study found for megaparsec, and worth knowing before +reaching for it. + +Two grammars regressed on `String` (`nested` +18%, the `(!'"' .)*` idiom ++29%). Both are dominated by single-character steps rather than bulk scans, +where `unconsS` is one indirect call that the previous direct cons-cell match +did not need. The five grammars that do any bulk scanning improved by 5-12%. + +The `idents` and `quoted [^"]*` groups are not in the table because their +grammars changed: `ident` moved from `c:[a-zA-Z_] cs:[a-zA-Z0-9_]*` to +`&[a-zA-Z_] cs:[a-zA-Z0-9_]+` so that it returns a chunk rather than consing a +character onto one, and `Bench.Mega`'s `identP` moved to `takeWhile1P` to keep +the comparison like-for-like. On the new grammars typed-peg allocates 100 +B/byte over `String` and 84 over `ByteString`, against megaparsec's 179. + +### Performance + +The evaluator was rewritten twice: once around a compilation step, once around +an unboxed step result. On the benchmark suite in `bench/` (see `cabal bench`), +measured against megaparsec 9.8 in the same run, typed-peg went from taking +2.1x-58x the time megaparsec takes to taking 0.95x-1.17x of it — and it now +allocates less than megaparsec on six of the seven grammars. The one grammar +where it still loses is the `(!'"' .)*` idiom, which scans every character +twice by construction; written as `[^"]*` it costs 1.23x-1.35x. + +- A compiled step returns an unboxed sum, `(# (# #) | (# a, PState #) #)`, + rather than `Maybe (a, PState)`. The two are isomorphic, but the unboxed + sum travels in registers, so a step that succeeds no longer allocates a + `Just` *and* a pair on top of the new state, and a step that fails + allocates nothing at all. This makes `Seq` and `Map` — the two + constructors the quasi-quoter emits for every grammar item — completely + allocation-free, and cuts total allocation by a further 9–53%. +- String literals match in a single loop that builds one `PState`, rather + than one per character, whenever the grammar does not use layout. +- `PEG.Parse` now *compiles* a `Grammar` into a closure once, instead of + walking the `PExp` GADT and the rule list on every step. Resolving a + non-terminal is now one indirect call rather than a linear scan of the rule + environment. `parseWith opts g` is written so that partially applying it + yields the compiled parser; bind it to a name to reuse it. +- Character classes compile to a single `Sat` node holding a `PEG.CharSet` + (a 256-bit bitmap), instead of expanding into a chain of ordered choices. + Matching one character of `[a-zA-Z0-9_]` used to cost 63 parser steps. +- String literals compile to a single `Str` node instead of a chain of + `Seq`/`Map`/`Term`. +- The parser no longer builds a `[(Char, Int)]` copy of the input; the column + of the current character is carried in the state and updated incrementally. +- Terminals take a fast path that skips all interval arithmetic when the + ambient column relation is total (`anyR`), which is the case for every + grammar that does not use layout. The new `rdTotal` field of `RelD` records + this. +- `parse` returns the unconsumed suffix in `O(1)` instead of recomputing it + with two `length` calls and a `drop`. +- `Star` no longer builds a chain of selector thunks. + +### Added + +- Negated character classes in the quasi-quoter: `[^"]` matches any character + other than a quote. Previously the only way to write this was + `(!'"' .)`, which scans every character twice — once for the lookahead and + once for the dot. On the `quoted` benchmark the class form halves the + allocation. +- `PEG.CharSet`: compact character sets, re-exported from `PEG`. +- `PEG.Syntax.Sat` / `PEG.Syntax.Str` constructors, and the `sat`, + `charClass` and `notCharClass` smart constructors. +- `PEG.Parse.compileGrammar` and the `Step` and `Res` types, for callers that + want the compiled parser directly. +- `PEG.Indent.rdTotal`. +- A criterion benchmark suite comparing typed-peg with megaparsec + (`bench/`, run with `cabal bench`). +- `examples/Compat.hs`: a differential battery used to check that the + optimisation work did not change any observable behaviour. + +### Changed + +- **Breaking.** `PState` now holds the remaining input as a `String` plus the + current column and offset (`stInput`, `stCol`, `stOff`), rather than a + precomputed `[(Char, Int)]`. `PEG.Parse.Input`, `PEG.Parse.columns` and + `PEG.Parse.eval` are gone; use `compileGrammar` instead of `eval`. +- **Breaking.** `RelD` has a new `rdTotal` field. +- **Breaking.** `PEG.Parse.Step` now returns the unboxed sum `Res a` instead + of `Maybe (a, PState)`. This only affects code that called + `compileGrammar` directly; `parse` and `parseWith` are unchanged. +- **Breaking.** In a quasi-quoted grammar, a `^` immediately after `[` now + negates the class instead of standing for itself; write `[\^]` for a class + containing a caret. +- The `template-haskell` upper bound now admits the version shipped with + GHC 9.10 (`< 2.24`). + ## 0.1.0.0 — 2026-08-28 ### Added diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -12,7 +12,46 @@ - Compile-time left-recursion detection (type error) - Indentation-sensitive parsing (`PEG.Indent`) - Quasi-quoter for concrete grammar syntax (`PEG.QQ`) +- Parses any `PEG.Stream`: `String`, strict/lazy `Text`, strict/lazy + `ByteString` +## Input streams + +A grammar is written once and runs over any stream: + +```haskell +import qualified Data.Text as T + +parse arith "1+2*3" -- Result String Exp +parse arith (T.pack "1+2*3") -- Result Text Exp +``` + +Character classes produce a **chunk of the stream**, not a `[Char]`: matching +`[a-z]+` against a `Text` yields a `Text` slice and copies nothing. Semantic +actions that want a `String` ask for one: + +```haskell +number <- ds:[0-9]+ { Lit (read (chunkToString ds)) } +strlit <- '"' cs:[^"]* '"' { cs } -- :: s, no copy +``` + +Only `unconsS` has no default, so adding a stream is one method. + +`ByteString` is read as Latin-1, like `Data.ByteString.Char8`: fast and +correct for ASCII, wrong for multi-byte UTF-8. Decode to `Text` if that +matters. + +A `Grammar` is monomorphic in its stream. To reuse one across several, give +it a `forall s. Stream s => Grammar s Env _ A` signature — but note that makes +it a function of a dictionary, so the compiled parser is no longer shared +between calls. Bind a monomorphic parser where that matters: + +```haskell +arithString :: String -> Result String Exp +arithString = parse arith +{-# NOINLINE arithString #-} +``` + ## Quick start ```haskell @@ -22,6 +61,42 @@ -- See examples/Arith.hs for a complete arithmetic expression parser ``` +## Grammar size + +The nullability and FIRST set of every rule are computed by GHC while it +type-checks the grammar, so a grammar's size shows up as compile time. A +FIRST set is a type-level list of non-terminal names kept in **alphabetical +order**: + +```haskell +type CalcEnv = + '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr) + , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"]) Expr) + , '("unary", 'EnvEntry ('MkTy 'False '["atom"]) Expr) + , '("atom" , 'EnvEntry ('MkTy 'False '[]) Expr) + ] +``` + +The order is not cosmetic. It gives a set exactly one spelling, which is what +lets the union of two FIRST sets be a single merge pass; listing one in some +other order is a type error naming the first position that disagrees. + +That merge nests one type-family reduction per element of the result, so a +grammar with a FIRST set of more than about a hundred non-terminals hits GHC's +default reduction limit and reports `Reduction stack overflow`. Add +`-freduction-depth=0` to `ghc-options` if you get there; it is a limit rather +than a slowdown, and a union of two 128-element sets takes about 0.3 s once it +is lifted. + +## Patterns + +[`peg-patterns.md`](peg-patterns.md) works through patterns for specifying +languages with PEGs and this library, following Willis and Wu's *Design +Patterns for Parser Combinators* (Haskell 2021) and noting where a PEG differs +— committed choice, left recursion as a type error, keywords as negative +lookahead — and where typed-peg cannot yet follow. Every fragment in it +compiles, in [`examples/Patterns.hs`](examples/Patterns.hs). + ## Building ```bash @@ -32,6 +107,63 @@ ```bash cabal test typed-peg-examples +``` + +## Benchmarks + +`bench/` holds a criterion suite that measures typed-peg against +[megaparsec](https://hackage.haskell.org/package/megaparsec) on seven grammars +(arithmetic expressions, CSV, identifier lists, a mini JSON, deeply nested +parentheses, and quoted strings spelled two ways) written twice, rule for +rule. Both libraries consume byte-identical inputs, and the suite +cross-checks that they produce the same result before timing anything. + +```bash +cabal bench +``` + +`cabal bench --benchmark-options=--alloc` prints bytes allocated per parse +instead of running criterion; allocation is the number that separates the two +libraries most clearly once the algorithmic differences are gone. + +On GHC 9.10.3 against megaparsec 9.8.1, bytes allocated per input byte on the +largest input of each group: + +| grammar | typed-peg `String` | `Text` | `ByteString` | megaparsec `String` | +|---|---|---|---|---| +| arithmetic | 943 | 1127 | 969 | 1239 | +| CSV | 787 | 951 | 805 | 1035 | +| identifiers | 100 | 190 | 84 | 179 | +| JSON | 404 | 583 | 452 | 782 | +| nested parens | 312 | 481 | 336 | 1283 | +| `'"' [^"]* '"'` | 90 | 167 | 65 | 128 | +| `'"' (!'"' .)* '"'` | 209 | 320 | 250 | 128 | + +`ByteString` is the cheapest column on five of the seven grammars and beats +megaparsec on six. `Text` costs more than `String` throughout — the same +result the study found for megaparsec, so reach for it for interoperability +rather than for speed. + +Allocation is deterministic and reproduces exactly. Time is the noisier +measurement: on a machine with heterogeneous cores, unpinned runs of the +*same* megaparsec binary varied by up to 1.8x, so only the ratio taken within +one run is meaningful. + +The reference implementation is `Bench.Peg`; its megaparsec twin is +`Bench.Mega`. Since PEG ordered choice backtracks unconditionally while +megaparsec's `<|>` does not, every megaparsec alternative that can consume +input before failing is wrapped in `try`, so the two are recognising the same +language. + +### Parsing many inputs + +`parseWith opts grammar` traverses the grammar and returns a compiled closure. +Bind it once and reuse it, rather than calling `parse grammar input` inline in +a loop: + +```haskell +myParser :: String -> Result Exp +myParser = parse myGrammar ``` ## License diff --git a/bench/Bench/Inputs.hs b/bench/Bench/Inputs.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Inputs.hs @@ -0,0 +1,92 @@ +-- | Deterministic input generators shared by the typed-peg and megaparsec +-- benchmark groups. Everything is pure and reproducible (a small LCG), so +-- both libraries are always measured on byte-identical inputs. +module Bench.Inputs + ( arithInput + , csvInput + , identInput + , jsonInput + , nestedInput + , quotedInput + ) where + +-- | A tiny linear congruential generator (glibc constants) so the benchmark +-- inputs do not depend on @random@. +lcg :: Int -> Int +lcg s = (1103515245 * s + 12345) `mod` 2147483648 + +randoms :: Int -> [Int] +randoms = drop 1 . iterate lcg + +-- | @arithInput n@ builds an arithmetic expression with @n@ operands, mixing +-- binary operators, parentheses and unary minus. +arithInput :: Int -> String +arithInput n = go n (randoms 7) + where + go k rs + | k <= 1 = operand rs + | otherwise = case drop 2 rs of + (r : rs') -> operand rs ++ ["+-*/" !! (r `mod` 4)] ++ go (k - 1) rs' + [] -> operand rs + + operand (r : s : _) = case r `mod` 8 of + 0 -> "(" ++ show (s `mod` 1000) ++ "+" ++ show (s `mod` 97) ++ ")" + 1 -> "-" ++ show (s `mod` 1000) + _ -> show (s `mod` 100000) + operand _ = "0" + +-- | @csvInput rows cols@ builds @rows@ lines of @cols@ comma-separated +-- integers. +csvInput :: Int -> Int -> String +csvInput rows cols = + intercalate' "\n" + [ intercalate' "," [ show (v `mod` 1000000) | v <- take cols (drop (r * cols) vs) ] + | r <- [0 .. rows - 1] + ] + where + vs = randoms 42 + +-- | @identInput n@ builds @n@ space-separated identifiers. Identifiers use a +-- wide character class (@[a-zA-Z0-9_]@), which is the worst case for a parser +-- that expands classes into a chain of ordered choices. +identInput :: Int -> String +identInput n = unwords' [ ident v | v <- take n (randoms 3) ] + where + alphabet = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_" + ident v = 'z' : [ alphabet !! ((v `div` (7 ^ k)) `mod` length alphabet) + | k <- [1 .. 6 :: Int] ] + +-- | @jsonInput n@ builds a JSON array of @n@ small objects. +jsonInput :: Int -> String +jsonInput n = + "[" ++ intercalate' ",\n " [ obj v | v <- take n (randoms 11) ] ++ "]" + where + obj v = "{\"id\": " ++ show (v `mod` 100000) + ++ ", \"name\": \"item" ++ show (v `mod` 997) ++ "\"" + ++ ", \"tags\": [" ++ intercalate' ", " [ show (t :: Int) | t <- [1 .. 3] ] ++ "]" + ++ ", \"ok\": " ++ (if even v then "true" else "false") + ++ ", \"extra\": null}" + +-- | @quotedInput n@ builds @n@ space-separated double-quoted strings. Used to +-- compare the two ways of spelling \"any character but a quote\": the PEG +-- idiom @(!'\"' .)*@, which scans every character twice, against the negated +-- character class @[^\"]*@. +quotedInput :: Int -> String +quotedInput n = unwords' [ "\"" ++ body v ++ "\"" | v <- take n (randoms 23) ] + where + body v = [ alphabet !! ((v `div` (5 ^ k)) `mod` length alphabet) + | k <- [1 .. 12 :: Int] ] + alphabet = ['a' .. 'z'] ++ ['A' .. 'Z'] ++ " ,.;:!?-" + +-- | @nestedInput d@ builds @d@ nested parentheses around a literal. This is +-- the deep-recursion / backtracking stress case for the arithmetic grammar. +nestedInput :: Int -> String +nestedInput d = replicate d '(' ++ "1" ++ replicate d ')' + +intercalate' :: String -> [String] -> String +intercalate' _ [] = [] +intercalate' _ [x] = x +intercalate' sep (x : xs) = x ++ sep ++ intercalate' sep xs + +unwords' :: [String] -> String +unwords' = intercalate' " " diff --git a/bench/Bench/Mega.hs b/bench/Bench/Mega.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Mega.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +-- | The megaparsec side of the benchmark suite. +-- +-- The grammars mirror "Bench.Peg" rule-for-rule. Because PEG ordered choice +-- backtracks unconditionally while megaparsec's '<|>' only backtracks when the +-- left branch consumed nothing, every alternative that can consume input +-- before failing is wrapped in 'try'. Without that the two libraries would +-- not be recognising the same language. +-- +-- Parsers are polymorphic in the stream so the same code can be measured over +-- 'String' (the input type typed-peg supports) and over 'Data.Text.Text' (what +-- a megaparsec user would actually reach for). +module Bench.Mega + ( runArith + , runCsv + , runIdents + , runJson + , runQuoted + ) where + +import Data.Char (isAlphaNum, isAlpha, isDigit) +import Data.Proxy (Proxy (..)) +import Data.String (IsString) +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char (char, string) + +import Bench.Peg (Exp (..), JValue (..), evalExp) + +type Str s = ( Stream s, VisualStream s, TraversableStream s + , Token s ~ Char, IsString (Tokens s), Ord (Token s) ) + +type P s = Parsec Void s + +-------------------------------------------------------------------------------- +-- Arithmetic expressions +-------------------------------------------------------------------------------- + +addOp :: Exp -> (Char, Exp) -> Exp +addOp l ('+', r) = Add l r +addOp l ('-', r) = Sub l r +addOp l ('*', r) = Mul l r +addOp l ('/', r) = Div l r +addOp _ (c , _) = error ("addOp: unexpected operator " ++ show c) + +exprP :: Str s => P s Exp +exprP = foldl addOp <$> termP <*> many (try ((,) <$> satisfy addSym <*> termP)) + where addSym c = c == '+' || c == '-' + +termP :: Str s => P s Exp +termP = foldl addOp <$> factorP <*> many (try ((,) <$> satisfy mulSym <*> factorP)) + where mulSym c = c == '*' || c == '/' + +factorP :: Str s => P s Exp +factorP = + try numberP + <|> try (char '(' *> exprP <* char ')') + <|> (Neg <$> (char '-' *> factorP)) + +numberP :: Str s => P s Exp +numberP = (Lit . read) <$> some (satisfy isDigit) + +-------------------------------------------------------------------------------- +-- CSV of integers +-------------------------------------------------------------------------------- + +csvP :: Str s => P s [[Int]] +csvP = (:) <$> rowP <*> many (try (char '\n' *> rowP)) + +rowP :: Str s => P s [Int] +rowP = (:) <$> natP <*> many (try (char ',' *> natP)) + +natP :: Str s => P s Int +natP = read <$> some (satisfy isDigit) + +-------------------------------------------------------------------------------- +-- Identifier list +-------------------------------------------------------------------------------- + +identsP :: Str s => P s [Tokens s] +identsP = (:) <$> identP <*> many (try (char ' ' *> identP)) + +-- Both sides use their bulk primitive: typed-peg spans the class into a chunk +-- of the stream, megaparsec into a 'Tokens'. A lookahead pins the first +-- character to the narrower class without consuming it, exactly as +-- @&[a-zA-Z_] [a-zA-Z0-9_]+@ does on the typed-peg side. +identP :: Str s => P s (Tokens s) +identP = lookAhead (satisfy startC) *> takeWhile1P Nothing contC + where + startC c = isAlpha c || c == '_' + contC c = isAlphaNum c || c == '_' + +-------------------------------------------------------------------------------- +-- Mini JSON +-------------------------------------------------------------------------------- + +wsP :: Str s => P s () +wsP = () <$ takeWhileP Nothing isSpace' + where isSpace' c = c == ' ' || c == '\t' || c == '\r' || c == '\n' + +jsonP :: Str s => P s JValue +jsonP = wsP *> valueP <* wsP + +valueP :: Str s => P s JValue +valueP = + try objectP + <|> try arrayP + <|> try (JStr <$> strP) + <|> try numberJP + <|> try (JBool True <$ string "true") + <|> try (JBool False <$ string "false") + <|> (JNull <$ string "null") + +objectP :: Str s => P s JValue +objectP = + JObj . orEmpty + <$> (char '{' *> wsP *> optional (try membersP) <* wsP <* char '}') + +membersP :: Str s => P s [(String, JValue)] +membersP = (:) <$> pairP <*> many (try (wsP *> char ',' *> wsP *> pairP)) + +pairP :: Str s => P s (String, JValue) +pairP = (,) <$> strP <*> (wsP *> char ':' *> wsP *> valueP) + +arrayP :: Str s => P s JValue +arrayP = + JArr . orEmpty + <$> (char '[' *> wsP *> optional (try elemsP) <* wsP <* char ']') + +elemsP :: Str s => P s [JValue] +elemsP = (:) <$> valueP <*> many (try (wsP *> char ',' *> wsP *> valueP)) + +strP :: Str s => P s String +strP = char '"' *> many (satisfy (/= '"')) <* char '"' + +numberJP :: Str s => P s JValue +numberJP = mk <$> optional (char '-') <*> some (satisfy isDigit) + where + mk Nothing ds = JNum (read ds) + mk (Just _) ds = JNum (negate (read ds)) + +orEmpty :: Maybe [a] -> [a] +orEmpty Nothing = [] +orEmpty (Just xs) = xs + +-------------------------------------------------------------------------------- +-- Quoted strings +-------------------------------------------------------------------------------- + +quotedP :: Str s => P s [String] +quotedP = (:) <$> qP <*> many (try (char ' ' *> qP)) + +qP :: Str s => P s String +qP = char '"' *> many (satisfy (/= '"')) <* char '"' + +-------------------------------------------------------------------------------- +-- Runners +-------------------------------------------------------------------------------- + +run :: Str s => P s a -> (a -> Int) -> String -> s -> Int +run p k what s = case runParser p "" s of + Left e -> error (what ++ ": " ++ errorBundlePretty e) + Right a -> k a + +runArith :: Str s => s -> Int +runArith = run exprP evalExp "runArith" + +runCsv :: Str s => s -> Int +runCsv = run csvP (sum . map sum) "runCsv" + +runIdents :: forall s. Str s => s -> Int +runIdents = run identsP (sum . map (chunkLength (Proxy :: Proxy s))) "runIdents" + +runJson :: Str s => s -> Int +runJson = run jsonP sizeJ "runJson" + +runQuoted :: Str s => s -> Int +runQuoted = run quotedP (sum . map length) "runQuoted" + +sizeJ :: JValue -> Int +sizeJ JNull = 1 +sizeJ (JBool _) = 1 +sizeJ (JNum n) = n +sizeJ (JStr t) = length t +sizeJ (JArr xs) = 1 + sum (map sizeJ xs) +sizeJ (JObj ps) = 1 + sum [ length k + sizeJ v | (k, v) <- ps ] diff --git a/bench/Bench/Peg.hs b/bench/Bench/Peg.hs new file mode 100644 --- /dev/null +++ b/bench/Bench/Peg.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} + +-- | The typed-peg side of the benchmark suite. Every grammar here has a +-- structurally identical megaparsec counterpart in "Bench.Mega". +module Bench.Peg + ( Exp (..) + , evalExp + , arith + , csv + , idents + , JValue (..) + , json + , arithS, csvS, identsS, jsonS, quotedNotS, quotedClsS + , arithT, csvT, identsT, jsonT, quotedNotT, quotedClsT + , arithB, csvB, identsB, jsonB, quotedNotB, quotedClsB + ) where + +import qualified Data.ByteString as B +import qualified Data.Text as T + +import PEG +import PEG.QQ (pegRules) + +-------------------------------------------------------------------------------- +-- Arithmetic expressions +-------------------------------------------------------------------------------- + +data Exp + = Lit Int + | Neg Exp + | Add Exp Exp + | Sub Exp Exp + | Mul Exp Exp + | Div Exp Exp + deriving (Eq, Show) + +evalExp :: Exp -> Int +evalExp (Lit n) = n +evalExp (Neg e) = negate (evalExp e) +evalExp (Add a b) = evalExp a + evalExp b +evalExp (Sub a b) = evalExp a - evalExp b +evalExp (Mul a b) = evalExp a * evalExp b +evalExp (Div a b) = let d = evalExp b in if d == 0 then 0 else evalExp a `div` d + +addOp :: Exp -> (Char, Exp) -> Exp +addOp l ('+', r) = Add l r +addOp l ('-', r) = Sub l r +addOp l ('*', r) = Mul l r +addOp l ('/', r) = Div l r +addOp _ (c , _) = error ("addOp: unexpected operator " ++ show c) + +foldOps :: Exp -> [(Char, Exp)] -> Exp +foldOps = foldl addOp + +readInt :: Stream s => s -> Exp +readInt ds = Lit (read (chunkToString ds)) + +type ArithEnv = + '[ '("expr" , 'EnvEntry ('MkTy 'False '["factor", "number", "term"]) Exp) + , '("term" , 'EnvEntry ('MkTy 'False '["factor", "number"]) Exp) + , '("factor", 'EnvEntry ('MkTy 'False '["number"]) Exp) + , '("number", 'EnvEntry ('MkTy 'False '[]) Exp) + ] + +{-# INLINABLE arith #-} +arith :: Stream s => Grammar s ArithEnv _ Exp +arith = + Grammar + [pegRules| + expr <- t:term ts:(o:[+-] u:term)* { foldOps t ts } + term <- f:factor fs:(o:[*/] g:factor)* { foldOps f fs } + factor <- n:number + / '(' e:expr ')' + / '-' f:factor { Neg f } + number <- ds:[0-9]+ { readInt ds } + |] + (nt @"expr") + +-------------------------------------------------------------------------------- +-- CSV of integers +-------------------------------------------------------------------------------- + +type CsvEnv = + '[ '("csv", 'EnvEntry ('MkTy 'False '["num", "row"]) [[Int]]) + , '("row", 'EnvEntry ('MkTy 'False '["num"]) [Int]) + , '("num", 'EnvEntry ('MkTy 'False '[]) Int) + ] + +{-# INLINABLE csv #-} +csv :: Stream s => Grammar s CsvEnv _ [[Int]] +csv = + Grammar + [pegRules| + csv <- r:row rs:('\n' t:row)* { r : rs } + row <- n:num ns:(',' m:num)* { n : ns } + num <- ds:[0-9]+ { readNat ds } + |] + (nt @"csv") + +readNat :: Stream s => s -> Int +readNat = read . chunkToString + +-------------------------------------------------------------------------------- +-- Identifier list (wide character classes) +-------------------------------------------------------------------------------- + +-- The environment is parameterised by the stream: @ident@ is a character +-- class, so its result is a chunk of the input. +type IdentEnv s = + '[ '("idents", 'EnvEntry ('MkTy 'False '["ident"]) [s]) + , '("ident" , 'EnvEntry ('MkTy 'False '[]) s) + ] + +{-# INLINABLE idents #-} +idents :: Stream s => Grammar s (IdentEnv s) _ [s] +idents = + Grammar + [pegRules| + idents <- i:ident is:(' ' j:ident)* { i : is } + ident <- &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { cs } + |] + (nt @"idents") + +-------------------------------------------------------------------------------- +-- Mini JSON +-------------------------------------------------------------------------------- + +data JValue + = JNull + | JBool Bool + | JNum Int + | JStr String + | JArr [JValue] + | JObj [(String, JValue)] + deriving (Eq, Show) + +mkNum :: Stream s => Maybe Char -> s -> JValue +mkNum Nothing ds = JNum (read (chunkToString ds)) +mkNum (Just _) ds = JNum (negate (read (chunkToString ds))) + +orEmpty :: Maybe [a] -> [a] +orEmpty Nothing = [] +orEmpty (Just xs) = xs + +type JsonEnv = + '[ '("json" , 'EnvEntry ('MkTy 'False '["array","number","object","strlit","value","ws"]) JValue) + , '("value" , 'EnvEntry ('MkTy 'False '["array","number","object","strlit"]) JValue) + , '("object" , 'EnvEntry ('MkTy 'False '[]) JValue) + , '("members", 'EnvEntry ('MkTy 'False '["pair","strlit"]) [(String, JValue)]) + , '("pair" , 'EnvEntry ('MkTy 'False '["strlit"]) (String, JValue)) + , '("array" , 'EnvEntry ('MkTy 'False '[]) JValue) + , '("elems" , 'EnvEntry ('MkTy 'False '["array","number","object","strlit","value"]) [JValue]) + , '("strlit" , 'EnvEntry ('MkTy 'False '[]) String) + , '("number" , 'EnvEntry ('MkTy 'False '[]) JValue) + , '("ws" , 'EnvEntry ('MkTy 'True '[]) ()) + ] + +{-# INLINABLE json #-} +json :: Stream s => Grammar s JsonEnv _ JValue +json = + Grammar + [pegRules| + json <- ws v:value ws { v } + value <- o:object { o } + / a:array { a } + / s:strlit { JStr s } + / n:number { n } + / "true" { JBool True } + / "false" { JBool False } + / "null" { JNull } + object <- '{' ws ms:members? ws '}' { JObj (orEmpty ms) } + members <- p:pair ps:(ws ',' ws q:pair)* { p : ps } + pair <- k:strlit ws ':' ws v:value { (k, v) } + array <- '[' ws es:elems? ws ']' { JArr (orEmpty es) } + elems <- e:value es:(ws ',' ws f:value)* { e : es } + strlit <- '"' cs:(!'"' c:.)* '"' { cs } + number <- s:'-'? ds:[0-9]+ { mkNum s ds } + ws <- [ \t\r\n]* + |] + (nt @"json") + +-------------------------------------------------------------------------------- +-- Quoted strings: negative lookahead vs. negated character class +-- +-- Two grammars that accept exactly the same language. The first spells +-- \"any character but a quote\" the way a PEG traditionally does, with a +-- negative lookahead; the second uses a negated character class, which +-- compiles to one 'Sat' node. +-------------------------------------------------------------------------------- + +-- @(!'"' .)*@ is a compound repetition, so it still yields a @['Char']@ ... +type QuotedNotEnv = + '[ '("qs", 'EnvEntry ('MkTy 'False '["q"]) [String]) + , '("q" , 'EnvEntry ('MkTy 'False '[]) String) + ] + +-- ... whereas @[^"]*@ is a character class and yields a chunk. +type QuotedClsEnv s = + '[ '("qs", 'EnvEntry ('MkTy 'False '["q"]) [s]) + , '("q" , 'EnvEntry ('MkTy 'False '[]) s) + ] + +{-# INLINABLE quotedNot #-} +quotedNot :: Stream s => Grammar s QuotedNotEnv _ [String] +quotedNot = + Grammar + [pegRules| + qs <- s:q ss:(' ' t:q)* { s : ss } + q <- '"' cs:(!'"' c:.)* '"' { cs } + |] + (nt @"qs") + +{-# INLINABLE quotedCls #-} +quotedCls :: Stream s => Grammar s (QuotedClsEnv s) _ [s] +quotedCls = + Grammar + [pegRules| + qs <- s:q ss:(' ' t:q)* { s : ss } + q <- '"' cs:[^"]* '"' { cs } + |] + (nt @"qs") + +-------------------------------------------------------------------------------- +-- Runners (force the result so criterion measures the whole parse) +-- +-- Each parser is bound monomorphically at each stream type. That matters: a +-- grammar left polymorphic in its stream is a function of a 'Stream' +-- dictionary rather than a constant, so the compiled parser would be rebuilt +-- on every call. NOINLINE keeps each one a shared CAF, so the measurement is +-- of parsing rather than of re-traversing the grammar. +-------------------------------------------------------------------------------- + +runArith :: Stream s => (s -> Result s Exp) -> s -> Int +runArith p s = case p s of + OK e _ _ -> evalExp e + Fail -> error "runArith: parse failed" +{-# INLINE runArith #-} + +runCsv :: Stream s => (s -> Result s [[Int]]) -> s -> Int +runCsv p s = case p s of + OK rs _ _ -> sum (map sum rs) + Fail -> error "runCsv: parse failed" +{-# INLINE runCsv #-} + +runIdents :: Stream s => (s -> Result s [s]) -> s -> Int +runIdents p s = case p s of + OK is _ _ -> sum (map lengthS is) + Fail -> error "runIdents: parse failed" +{-# INLINE runIdents #-} + +runJson :: Stream s => (s -> Result s JValue) -> s -> Int +runJson p s = case p s of + OK v _ _ -> sizeJ v + Fail -> error "runJson: parse failed" +{-# INLINE runJson #-} + +runQuotedNot :: Stream s => (s -> Result s [String]) -> s -> Int +runQuotedNot p s = case p s of + OK xs _ _ -> sum (map length xs) + Fail -> error "runQuotedNot: parse failed" +{-# INLINE runQuotedNot #-} + +runQuotedCls :: Stream s => (s -> Result s [s]) -> s -> Int +runQuotedCls p s = case p s of + OK xs _ _ -> sum (map lengthS xs) + Fail -> error "runQuotedCls: parse failed" +{-# INLINE runQuotedCls #-} + +sizeJ :: JValue -> Int +sizeJ JNull = 1 +sizeJ (JBool _) = 1 +sizeJ (JNum n) = n +sizeJ (JStr t) = length t +sizeJ (JArr xs) = 1 + sum (map sizeJ xs) +sizeJ (JObj ps) = 1 + sum [ length k + sizeJ v | (k, v) <- ps ] + +-------------------------------------------------------------------------------- +-- Monomorphic entry points, one set per stream. +-- +-- The parser must be bound as its own CAF. Writing @arithS = runArith (parse +-- arith)@ instead lets GHC eta-expand to @\s -> case parse arith s of ...@, +-- which rebuilds the compiled parser on every single call -- a 2.5x slowdown +-- that no amount of specialisation recovers. +-------------------------------------------------------------------------------- + +pArithS :: String -> Result String Exp +pArithS = parse arith +{-# NOINLINE pArithS #-} + +arithS :: String -> Int +arithS = runArith pArithS + +pCsvS :: String -> Result String [[Int]] +pCsvS = parse csv +{-# NOINLINE pCsvS #-} + +csvS :: String -> Int +csvS = runCsv pCsvS + +pJsonS :: String -> Result String JValue +pJsonS = parse json +{-# NOINLINE pJsonS #-} + +jsonS :: String -> Int +jsonS = runJson pJsonS + +pQuotedNotS :: String -> Result String [String] +pQuotedNotS = parse quotedNot +{-# NOINLINE pQuotedNotS #-} + +quotedNotS :: String -> Int +quotedNotS = runQuotedNot pQuotedNotS + +pIdentsS :: String -> Result String [String] +pIdentsS = parse idents +{-# NOINLINE pIdentsS #-} + +identsS :: String -> Int +identsS = runIdents pIdentsS + +pQuotedClsS :: String -> Result String [String] +pQuotedClsS = parse quotedCls +{-# NOINLINE pQuotedClsS #-} + +quotedClsS :: String -> Int +quotedClsS = runQuotedCls pQuotedClsS + +pArithT :: T.Text -> Result T.Text Exp +pArithT = parse arith +{-# NOINLINE pArithT #-} + +arithT :: T.Text -> Int +arithT = runArith pArithT + +pCsvT :: T.Text -> Result T.Text [[Int]] +pCsvT = parse csv +{-# NOINLINE pCsvT #-} + +csvT :: T.Text -> Int +csvT = runCsv pCsvT + +pJsonT :: T.Text -> Result T.Text JValue +pJsonT = parse json +{-# NOINLINE pJsonT #-} + +jsonT :: T.Text -> Int +jsonT = runJson pJsonT + +pQuotedNotT :: T.Text -> Result T.Text [String] +pQuotedNotT = parse quotedNot +{-# NOINLINE pQuotedNotT #-} + +quotedNotT :: T.Text -> Int +quotedNotT = runQuotedNot pQuotedNotT + +pIdentsT :: T.Text -> Result T.Text [T.Text] +pIdentsT = parse idents +{-# NOINLINE pIdentsT #-} + +identsT :: T.Text -> Int +identsT = runIdents pIdentsT + +pQuotedClsT :: T.Text -> Result T.Text [T.Text] +pQuotedClsT = parse quotedCls +{-# NOINLINE pQuotedClsT #-} + +quotedClsT :: T.Text -> Int +quotedClsT = runQuotedCls pQuotedClsT + +pArithB :: B.ByteString -> Result B.ByteString Exp +pArithB = parse arith +{-# NOINLINE pArithB #-} + +arithB :: B.ByteString -> Int +arithB = runArith pArithB + +pCsvB :: B.ByteString -> Result B.ByteString [[Int]] +pCsvB = parse csv +{-# NOINLINE pCsvB #-} + +csvB :: B.ByteString -> Int +csvB = runCsv pCsvB + +pJsonB :: B.ByteString -> Result B.ByteString JValue +pJsonB = parse json +{-# NOINLINE pJsonB #-} + +jsonB :: B.ByteString -> Int +jsonB = runJson pJsonB + +pQuotedNotB :: B.ByteString -> Result B.ByteString [String] +pQuotedNotB = parse quotedNot +{-# NOINLINE pQuotedNotB #-} + +quotedNotB :: B.ByteString -> Int +quotedNotB = runQuotedNot pQuotedNotB + +pIdentsB :: B.ByteString -> Result B.ByteString [B.ByteString] +pIdentsB = parse idents +{-# NOINLINE pIdentsB #-} + +identsB :: B.ByteString -> Int +identsB = runIdents pIdentsB + +pQuotedClsB :: B.ByteString -> Result B.ByteString [B.ByteString] +pQuotedClsB = parse quotedCls +{-# NOINLINE pQuotedClsB #-} + +quotedClsB :: B.ByteString -> Int +quotedClsB = runQuotedCls pQuotedClsB diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | criterion driver comparing typed-peg against megaparsec. +-- +-- Each grammar is written twice, rule for rule (see "Bench.Peg" and +-- "Bench.Mega"), and both libraries consume the exact same input. +-- +-- typed-peg is measured over 'String', 'Data.Text.Text' and +-- 'Data.ByteString.ByteString'; megaparsec over 'String' and +-- 'Data.Text.Text' only, because its @Token ByteString@ is 'Data.Word.Word8' +-- rather than 'Char', so the same grammars do not typecheck over it. +module Main (main) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Criterion.Main +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString as B +import qualified Data.Text as T +import GHC.Stats (RTSStats (..), getRTSStats) +import System.Environment (getArgs) +import System.Mem (performGC) + +import qualified Bench.Inputs as I +import qualified Bench.Mega as M +import qualified Bench.Peg as P + +-- | Everything needed to measure one grammar on every library and stream. +data Group = Group + { gName :: String + , gPegS :: String -> Int + , gPegT :: T.Text -> Int + , gPegB :: B.ByteString -> Int + , gMegaS :: String -> Int + , gMegaT :: T.Text -> Int + } + +groups :: [(Group, [String])] +groups = + [ ( Group "arith" P.arithS P.arithT P.arithB M.runArith M.runArith + , map I.arithInput [50, 200, 800] ) + , ( Group "csv" P.csvS P.csvT P.csvB M.runCsv M.runCsv + , map (`I.csvInput` 8) [20, 100, 400] ) + , ( Group "idents" P.identsS P.identsT P.identsB M.runIdents M.runIdents + , map I.identInput [100, 500, 2000] ) + , ( Group "json" P.jsonS P.jsonT P.jsonB M.runJson M.runJson + , map I.jsonInput [10, 50, 200] ) + , ( Group "nested" P.arithS P.arithT P.arithB M.runArith M.runArith + , map I.nestedInput [50, 200] ) + -- The same language spelled two ways in typed-peg, against one megaparsec + -- parser: this isolates the cost of the negative-lookahead idiom. + , ( Group "quoted-lookahead" P.quotedNotS P.quotedNotT P.quotedNotB + M.runQuoted M.runQuoted + , map I.quotedInput [50, 200] ) + , ( Group "quoted-class" P.quotedClsS P.quotedClsT P.quotedClsB + M.runQuoted M.runQuoted + , map I.quotedInput [50, 200] ) + ] + +label :: Group -> String -> String +label g input = gName g ++ " [" ++ show (length input) ++ "B]" + +-------------------------------------------------------------------------------- +-- Cross-check: every library and every stream must agree before anything is +-- timed, otherwise the measurements compare different amounts of work. +-------------------------------------------------------------------------------- + +verify :: Group -> String -> IO () +verify g input = do + let ps = gPegS g input + pt = gPegT g (T.pack input) + pb = gPegB g (BC.pack input) + ms = gMegaS g input + mt = gMegaT g (T.pack input) + if all (== ps) [pt, pb, ms, mt] + then putStrLn (" ok " ++ label g input ++ " -> " ++ show ps) + else error ("MISMATCH in " ++ label g input + ++ ": peg(String)=" ++ show ps + ++ " peg(Text)=" ++ show pt + ++ " peg(BS)=" ++ show pb + ++ " mega(String)=" ++ show ms + ++ " mega(Text)=" ++ show mt) + +verifyAll :: IO () +verifyAll = do + putStrLn "== cross-checking typed-peg against megaparsec, on every stream ==" + sequence_ [ verify g i | (g, is) <- groups, i <- is ] + putStrLn "" + +-------------------------------------------------------------------------------- +-- Allocation report +-- +-- @cabal bench --benchmark-options=--alloc@ prints bytes allocated per parse +-- instead of running criterion. Allocation is deterministic, so it is the +-- measurement to trust when the timings are noisy. +-------------------------------------------------------------------------------- + +allocFor :: (a -> Int) -> a -> IO Integer +allocFor f x = do + performGC + before <- getRTSStats + n <- evaluate (f x) + n `seq` performGC + after <- getRTSStats + pure (fromIntegral (allocated_bytes after - allocated_bytes before)) + +allocRow :: Group -> String -> IO () +allocRow g input = do + s <- evaluate (force input) + t <- evaluate (force (T.pack input)) + b <- evaluate (force (BC.pack input)) + aps <- allocFor (gPegS g) s + apt <- allocFor (gPegT g) t + apb <- allocFor (gPegB g) b + ams <- allocFor (gMegaS g) s + amt <- allocFor (gMegaT g) t + let n = fromIntegral (length input) :: Double + per v = rjust 9 (showF (fromIntegral v / n)) + putStrLn (concat + [ pad 24 (label g input) + , per aps, per apt, per apb, per ams, per amt ]) + where + pad k x = x ++ replicate (k - length x) ' ' + rjust k x = replicate (k - length x) ' ' ++ x + showF v = show (fromIntegral (round (v * 10) :: Int) / 10 :: Double) + +allocReport :: IO () +allocReport = do + putStrLn "bytes allocated per input byte" + putStrLn (concat [ replicate 24 ' ' + , " peg/Str", " peg/Txt", " peg/BS" + , " mega/Str", " mega/Txt" ]) + sequence_ [ allocRow g i | (g, is) <- groups, i <- is ] + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + args <- getArgs + if "--alloc" `elem` args + then allocReport + else verifyAll >> defaultMain benchmarks + +benchmarks :: [Benchmark] +benchmarks = + [ bgroup (gName g) + [ env (prepare input) $ \ ~(s, t, b) -> + bgroup (label g input) + [ bench "typed-peg (String)" $ whnf (gPegS g) s + , bench "typed-peg (Text)" $ whnf (gPegT g) t + , bench "typed-peg (ByteString)" $ whnf (gPegB g) b + , bench "megaparsec (String)" $ whnf (gMegaS g) s + , bench "megaparsec (Text)" $ whnf (gMegaT g) t + ] + | input <- is + ] + | (g, is) <- groups + ] + +prepare :: String -> IO (String, T.Text, B.ByteString) +prepare s = do + s' <- evaluate (force s) + t' <- evaluate (force (T.pack s)) + b' <- evaluate (force (BC.pack s)) + pure (s', t', b') diff --git a/examples/Arith.hs b/examples/Arith.hs --- a/examples/Arith.hs +++ b/examples/Arith.hs @@ -52,13 +52,19 @@ addOp _ (c , _) = error ("addOp: unexpected operator " ++ show c) type ArithEnv = - '[ '("expr" , 'EnvEntry ('MkTy 'False '["term", "factor", "number"]) Exp) + '[ '("expr" , 'EnvEntry ('MkTy 'False '["factor", "number", "term"]) Exp) , '("term" , 'EnvEntry ('MkTy 'False '["factor", "number"]) Exp) , '("factor", 'EnvEntry ('MkTy 'False '["number"]) Exp) , '("number", 'EnvEntry ('MkTy 'False '[]) Exp) ] -arith :: Grammar ArithEnv _ Exp +-- | Polymorphic in the stream, so the same grammar can be run over 'String', +-- 'Data.Text.Text' and 'Data.ByteString.ByteString'. Note the cost: this is +-- a function of a 'Stream' dictionary rather than a constant, so the compiled +-- parser is not shared between calls. Bind a monomorphic parser +-- (@arithString = parse arith :: String -> Result String Exp@) where that +-- matters. +arith :: Stream s => Grammar s ArithEnv _ Exp arith = Grammar [pegRules| @@ -68,6 +74,6 @@ factor <- n:number / '(' e:expr ')' / '-' f:factor { Neg f } - number <- ds:[0-9]+ { Lit (read ds :: Int) } + number <- ds:[0-9]+ { Lit (read (chunkToString ds) :: Int) } |] (nt @"expr") diff --git a/examples/Compat.hs b/examples/Compat.hs new file mode 100644 --- /dev/null +++ b/examples/Compat.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | A differential test: it renders the complete 'Result' (value, consumed +-- prefix and remaining suffix) for a fixed battery of inputs. +-- +-- It serves two purposes. +-- +-- * The output is compared byte-for-byte between successive versions of the +-- evaluator, which is how the optimisation work was checked for behavioural +-- drift — including the layout-sensitive paths that the other examples do +-- not exercise. +-- +-- * The same battery is run over 'String', 'Data.Text.Text' and +-- 'Data.ByteString.ByteString', and the three renderings must agree. That +-- is what pins the "PEG.Stream" instances to each other: a stream whose +-- @spanS@ or column bookkeeping is wrong shows up here as a diff. +-- +-- The renderings can be compared directly because 'Show' for 'Data.Text.Text' +-- and 'Data.ByteString.ByteString' agrees with 'Show' for 'String' on the +-- Latin-1 range, which is all these inputs use. +module Compat (compatMain) where + +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T + +import PEG +import PEG.QQ (pegExpr, pegRules) +import Arith (arith, Exp) +import Layout (DoStmt, doExp, layoutOpts) + +showR :: (Show s, Show a) => Result s a -> String +showR (OK a c r) = "OK " ++ show a ++ " consumed=" ++ show c ++ " rest=" ++ show r +showR Fail = "Fail" + +arithCases :: [String] +arithCases = + [ "1+2*3", "(1+2)*3", "42", "-7", "1+", "", "((((1))))" + , "1+2)rest", "12*34/5-6", "9" + , "1+2*3+4*5+6/7-8", "(((1+2)*(3+4))-(5*6))" + , "0000123", "1--2", "-(1+2)" + ] + +layoutCases :: [String] +layoutCases = + [ "do\n foo\n bar" + , "do\n foo\n bar\nbaz" + , "do { foo ; bar }" + , "do\n foo\n do\n bar\n baz" + , "do\n foo\n bar" + , "do\n\tfoo\n\tbar" + , "do foo bar" + , "do" + , " do\n a\n b" + , "do\n a\n b" + , "do { a }" + , "do\n do\n x" + ] + +-- Several option sets, so tab expansion and the token relation are covered. +optSets :: [(String, Opts)] +optSets = + [ ("layout(ge,tab8)" , layoutOpts) + , ("layout(ge,tab4)" , layoutOpts { optTabWidth = 4 }) + , ("layout(ge,tab1)" , layoutOpts { optTabWidth = 1 }) + , ("layout(gt)" , layoutOpts { optTokenMode = relD gtR }) + , ("layout(eq)" , layoutOpts { optTokenMode = relD eqR }) + , ("layout(any)" , defaultOpts) + , ("layout(off2)" , layoutOpts { optTokenMode = relD (offsetR 2) }) + , ("layout(cands)" , layoutOpts { optCands = Interval 1 (Fin 20) }) + ] + +-- | Chunk primitives and the lookaheads over them. +-- +-- @Span@ and @Span1@ are what a character-class repetition compiles to, and +-- @!c+@ / @!c*@ have dedicated compile cases; nothing else in the battery +-- reaches them. @!c*@ can never succeed, because the star matches the empty +-- run. +type SpanEnv s = + '[ '("digits", 'EnvEntry ('MkTy 'True '[]) s) + , '("digits1", 'EnvEntry ('MkTy 'False '[]) s) + ] + +spanG :: Stream s => Grammar s (SpanEnv s) _ (s, s) +spanG = + Grammar + [pegRules| + digits <- ds:[0-9]* { ds } + digits1 <- ds:[0-9]+ { ds } + |] + [pegExpr| a:digits '/' b:digits1 |] + +-- @!'x'+ .@ accepts any character that is not an @x@; @!'x'* .@ accepts +-- nothing at all. +notSpan1G :: Stream s => Grammar s '[] _ Char +notSpan1G = Grammar RNil [pegExpr| !'x'+ c:. |] + +notSpanG :: Stream s => Grammar s '[] _ Char +notSpanG = Grammar RNil [pegExpr| !'x'* c:. |] + +spanCases :: [String] +spanCases = ["/1", "12/34", "/", "12/", "abc", "", "007/8"] + +notCases :: [String] +notCases = ["y", "x", "", "yx"] + +-- | The whole battery, rendered as lines, for one stream type. +-- +-- @pack@ is the only stream-specific part; everything else is the same code +-- running at a different instance. +battery :: forall s. (Stream s, Show s) => (String -> s) -> [String] +battery pack = + [ "### arith (defaultOpts)" ] + ++ [ show s ++ " => " ++ showR (parse arith (pack s) :: Result s Exp) + | s <- arithCases ] + ++ [ "### arith (varying Opts)" ] + ++ [ nm ++ " " ++ show s ++ " => " + ++ showR (parseWith o arith (pack s) :: Result s Exp) + | (nm, o) <- optSets, s <- arithCases ] + ++ [ "### span primitives" ] + ++ [ show c ++ " => " ++ showR (parse spanG (pack c) :: Result s (s, s)) + | c <- spanCases ] + ++ [ "### !c+ (peek) and !c* (never succeeds)" ] + ++ [ show c ++ " => " ++ showR (parse notSpan1G (pack c) :: Result s Char) + ++ " | " ++ showR (parse notSpanG (pack c) :: Result s Char) + | c <- notCases ] + ++ [ "### layout" ] + ++ [ nm ++ " " ++ show s ++ " => " + ++ showR (parseWith o doExp (pack s) :: Result s [DoStmt]) + | (nm, o) <- optSets, s <- layoutCases ] + +-- | Print the 'String' rendering — this is the output compared against +-- previous versions of the evaluator — then check the other two streams +-- against it. +compatMain :: IO () +compatMain = do + let reference = battery id + mapM_ putStrLn reference + + putStrLn "### stream agreement" + agree "Data.Text.Text" reference (battery T.pack) + agree "Data.ByteString.ByteString" reference (battery BC.pack) + +-- | Report the first disagreement, if any. A count alone would say that +-- something is wrong without saying what, and these are 234 dense lines. +agree :: String -> [String] -> [String] -> IO () +agree name reference actual = + case [ (i, r, a) + | (i, r, a) <- zip3 [1 :: Int ..] reference actual, r /= a ] of + [] | length reference == length actual -> + putStrLn (name ++ ": agrees with String on all " + ++ show (length reference) ++ " lines") + | otherwise -> + putStrLn (name ++ ": MISMATCH in length, " ++ show (length reference) + ++ " vs " ++ show (length actual)) + ((i, r, a) : rest) -> do + putStrLn (name ++ ": MISMATCH on " ++ show (length rest + 1) + ++ " line(s), first at line " ++ show i) + putStrLn (" String: " ++ r) + putStrLn (" " ++ name ++ ": " ++ a) diff --git a/examples/Layout.hs b/examples/Layout.hs --- a/examples/Layout.hs +++ b/examples/Layout.hs @@ -20,16 +20,20 @@ | Nested [DoStmt] deriving (Eq, Show) -type DoEnv = +-- | The environment is parameterised by the stream, because @name@ is a +-- character class and so produces a chunk of the input rather than a +-- 'String'. Any rule whose result is a chunk pushes @s@ into the +-- environment this way. +type DoEnv s = '[ '("doexp" , 'EnvEntry ('MkTy 'False '[]) [DoStmt]) - , '("istmts", 'EnvEntry ('MkTy 'False '["ws", "stmt", "doexp", "name"]) [DoStmt]) + , '("istmts", 'EnvEntry ('MkTy 'False '["doexp", "name", "stmt", "ws"]) [DoStmt]) , '("stmts" , 'EnvEntry ('MkTy 'False '["ws"]) [DoStmt]) , '("stmt" , 'EnvEntry ('MkTy 'False '["doexp", "name"]) DoStmt) - , '("name" , 'EnvEntry ('MkTy 'False '[]) String) + , '("name" , 'EnvEntry ('MkTy 'False '[]) s) , '("ws" , 'EnvEntry ('MkTy 'True '[]) ()) ] -doExp :: Grammar DoEnv _ [DoStmt] +doExp :: Stream s => Grammar s (DoEnv s) _ [DoStmt] doExp = Grammar [pegRules| @@ -39,7 +43,7 @@ stmts <- r:(ws '{' ws s:stmt ss:(ws ';' ws t:stmt)* ws '}' { s : ss })^~ - stmt <- d:doexp { Nested d } / n:name { Atom n } + stmt <- d:doexp { Nested d } / n:name { Atom (chunkToString n) } name <- cs:[a-z]+ diff --git a/examples/Main.hs b/examples/Main.hs --- a/examples/Main.hs +++ b/examples/Main.hs @@ -3,8 +3,10 @@ import PEG (parse, parseWith, Result(..)) import Arith (arith, evalExp) import Layout (doExp, layoutOpts) +import Compat (compatMain) +import Patterns (patternsMain) -showResult :: Show a => Result a -> String +showResult :: Show a => Result String a -> String showResult (OK a _ _) = "OK " ++ show a showResult Fail = "Fail" @@ -23,3 +25,9 @@ putStrLn "\n=== Layout (do-notation) ===" let testLayout s = putStrLn $ showResult (parseWith layoutOpts doExp s) testLayout "foo\n bar\n baz\nqux" + + putStrLn "\n=== Patterns (see peg-patterns.md) ===" + patternsMain + + putStrLn "\n=== Differential battery ===" + compatMain diff --git a/examples/Patterns.hs b/examples/Patterns.hs new file mode 100644 --- /dev/null +++ b/examples/Patterns.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Worked examples for @peg-patterns.md@. +-- +-- Every snippet quoted in that document appears here, so the document cannot +-- drift away from code that compiles. 'patternsMain' exercises each one. +module Patterns + ( Expr (..) + , Asgn (..) + , evalE + , ws, lexeme, keyword, eof, fully + , calc + , addOp + , kwG + , prog + , patternsMain + ) where + +import PEG +import PEG.QQ (pegExpr, pegRules) + +-------------------------------------------------------------------------------- +-- Pattern 2a/2bi: whitespace and token combinators, at the PExp level +-------------------------------------------------------------------------------- + +-- | Zero or more layout characters. A character class, so this compiles to a +-- single 'Span' node and returns a chunk of the input. +ws :: PExp s env ('MkTy 'True '[]) s +ws = spanOf (fromRanges [(' ', ' '), ('\t', '\t'), ('\r', '\r'), ('\n', '\n')]) + +-- | Run @p@, then consume /trailing/ whitespace only. +lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a +lexeme p = (\x _ -> x) <$>. p <*>. ws + +-- | End of input: nothing can follow. +eof :: PExp s env ('MkTy 'True '[]) () +eof = Not AnyChar + +-- | Leading whitespace, then @p@, then end of input. +fully :: PExp s env ty a + -> PExp s env (SeqTy ('MkTy 'True '[]) + (SeqTy ty ('MkTy 'True '[]))) a +fully p = (\_ x _ -> x) <$>. ws <*>. p <*>. eof + +-------------------------------------------------------------------------------- +-- Pattern 2bii: keyword combinator +-------------------------------------------------------------------------------- + +identCont :: CharSet +identCont = fromRanges [('a', 'z'), ('A', 'Z'), ('0', '9'), ('_', '_')] + +-- | Match a keyword that is not a prefix of a longer identifier. +-- +-- The negative lookahead is the whole pattern: @keyword "negate"@ fails on +-- @negatex@ because an identifier character follows. In a backtracking +-- combinator library this needs @try@; in a PEG it is just @!@. +keyword :: String -> PExp s env ('MkTy 'False '[]) () +keyword k = (\_ _ -> ()) <$>. stringNE k <*>. Not (sat identCont) + +-------------------------------------------------------------------------------- +-- The AST, one layer per precedence level (Pattern 1b) +-------------------------------------------------------------------------------- + +data Expr + = Add Expr Expr + | Sub Expr Expr + | Mul Expr Expr + | Div Expr Expr + | Neg Expr + | Num Int + | Var String + deriving (Eq, Show) + +data Asgn = Asgn String Expr + deriving (Eq, Show) + +evalE :: [(String, Int)] -> Expr -> Int +evalE g (Add a b) = evalE g a + evalE g b +evalE g (Sub a b) = evalE g a - evalE g b +evalE g (Mul a b) = evalE g a * evalE g b +evalE g (Div a b) = let d = evalE g b in if d == 0 then 0 else evalE g a `div` d +evalE g (Neg a) = negate (evalE g a) +evalE _ (Num n) = n +evalE g (Var v) = maybe 0 id (lookup v g) + +-------------------------------------------------------------------------------- +-- Pattern 3a: lifted constructors +-- +-- The semantic actions stay one application wide; the dispatch on which +-- constructor an operator denotes lives in ordinary Haskell. +-------------------------------------------------------------------------------- + +-- | Fold a left-associative chain: an operand followed by @(op, operand)@ +-- pairs. This is what @chainl1@ buys in a combinator library, written out. +chainl :: Expr -> [(Char, Expr)] -> Expr +chainl = foldl step + where + step l ('+', r) = Add l r + step l ('-', r) = Sub l r + step l ('*', r) = Mul l r + step l ('/', r) = Div l r + step _ (c , _) = error ("chainl: unexpected operator " ++ show c) + +mkNum :: Stream s => s -> Expr +mkNum = Num . read . chunkToString + +mkVar :: Stream s => s -> Expr +mkVar = Var . chunkToString + +mkAsgn :: Stream s => s -> Expr -> Asgn +mkAsgn v e = Asgn (chunkToString v) e + +-------------------------------------------------------------------------------- +-- Pattern 1a/1c: a precedence ladder, one rule per level +-------------------------------------------------------------------------------- + +type CalcEnv s = + '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr) + , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"]) Expr) + , '("unary", 'EnvEntry ('MkTy 'False '["atom"]) Expr) + , '("atom" , 'EnvEntry ('MkTy 'False '[]) Expr) + ] + +-- | The classic expression language. +-- +-- Note what is /not/ here: no @try@, no left recursion, and no rule that can +-- loop. @expr <- expr '+' term@ would be rejected by 'PEG.Grammar.Acyclic' +-- at compile time with a type error naming @expr@. +calc :: Stream s => Grammar s (CalcEnv s) _ Expr +calc = + Grammar + [pegRules| + expr <- t:term ts:(o:[+-] u:term)* { chainl t ts } + term <- f:unary fs:(o:[*/] g:unary)* { chainl f fs } + unary <- '-' e:unary { Neg e } + / a:atom + atom <- '(' e:expr ')' + / ds:[0-9]+ { mkNum ds } + / &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { mkVar cs } + |] + (nt @"expr") + +-- | The same pattern inside a quasi-quoted grammar: a string literal followed +-- by a negative lookahead on the identifier-continuation class. +type KwEnv = '[ '("kw", 'EnvEntry ('MkTy 'False '[]) String) ] + +kwG :: Stream s => Grammar s KwEnv _ String +kwG = Grammar [pegRules| kw <- k:"negate" ![a-zA-Z0-9_] { k } |] (nt @"kw") + +-------------------------------------------------------------------------------- +-- Pattern 3b: deferred constructors +-- +-- A rule may return a *function*, so the choice of constructor is made where +-- the operator is read and applied where the operands are known. This is the +-- defunctionalised chain the paper describes, and it removes the partial +-- 'error' case from 'chainl' above. +-------------------------------------------------------------------------------- + +type OpEnv = + '[ '("op", 'EnvEntry ('MkTy 'False '[]) (Expr -> Expr -> Expr)) ] + +addOp :: Stream s => Grammar s OpEnv _ (Expr -> Expr -> Expr) +addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op") + +-------------------------------------------------------------------------------- +-- Statements, to show ordered choice and the lexeme discipline +-------------------------------------------------------------------------------- + +type ProgEnv s = + '[ '("prog" , 'EnvEntry ('MkTy 'False '["asgn"]) [Asgn]) + , '("asgn" , 'EnvEntry ('MkTy 'False '[]) Asgn) + , '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr) + , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"]) Expr) + , '("unary", 'EnvEntry ('MkTy 'False '["atom"]) Expr) + , '("atom" , 'EnvEntry ('MkTy 'False '[]) Expr) + ] + +-- | @a := 1; b := a * 2@ +-- +-- @':='@ comes before @':'@ nowhere in this grammar, but the ordering rule it +-- illustrates is the one PEG newcomers get wrong: in an ordered choice the +-- longer alternative must come first, because the first success wins and +-- there is no backtracking into a committed branch. +prog :: Stream s => Grammar s (ProgEnv s) _ [Asgn] +prog = + Grammar + [pegRules| + prog <- a:asgn as:(';' b:asgn)* { a : as } + asgn <- &[a-zA-Z_] v:[a-zA-Z0-9_]+ ":=" e:expr { mkAsgn v e } + + expr <- t:term ts:(o:[+-] u:term)* { chainl t ts } + term <- f:unary fs:(o:[*/] g:unary)* { chainl f fs } + unary <- '-' e:unary { Neg e } + / a:atom + atom <- '(' e:expr ')' + / ds:[0-9]+ { mkNum ds } + / &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { mkVar cs } + |] + (nt @"prog") + +-------------------------------------------------------------------------------- +-- Demonstration +-------------------------------------------------------------------------------- + +showR :: Show a => Result String a -> String +showR (OK a _ r) = "OK " ++ show a ++ (if null r then "" else " rest=" ++ show r) +showR Fail = "Fail" + +patternsMain :: IO () +patternsMain = do + putStrLn "### precedence ladder" + mapM_ (\s -> putStrLn (show s ++ " => " ++ show (fmap' (evalE []) (parse calc s)))) + [ "1+2*3", "(1+2)*3", "2*3+4", "-3+4", "10/2/5", "1-2-3", "x" ] + + putStrLn "### ordered choice / statements" + mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (parse prog s))) + [ "a:=1", "a:=1;b:=a*2", "a:=", "a:=1;" ] + + putStrLn "### keyword vs bare literal" + -- No 'fully' here: the point is what each one leaves behind. + let kw = parse (Grammar RNil (keyword "negate")) + :: String -> Result String () + bare = parse (Grammar RNil (const () <$>. stringNE "negate")) + :: String -> Result String () + mapM_ (\s -> putStrLn (show s ++ " keyword => " ++ showR (kw s) + ++ " | bare => " ++ showR (bare s))) + [ "negate", "negatex", "negate2", "negate x" ] + + putStrLn "### keyword, in quasi-quoter syntax" + mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (parse kwG s))) + [ "negate", "negatex", "negate x" ] + + putStrLn "### deferred constructor: a rule returning a function" + mapM_ (\s -> putStrLn (show s ++ " => " ++ + case parse addOp s of + OK f _ _ -> show (f (Num 1) (Num 2)) + Fail -> "Fail")) + [ "+", "-", "*" ] + + putStrLn "### lexeme discipline: fully (lexeme p)" + let toks = parse (Grammar RNil (fully (lexeme [pegExpr| ds:[0-9]+ |]))) + :: String -> Result String String + mapM_ (\s -> putStrLn (show s ++ " => " ++ showR (toks s))) + [ "12", " 12 ", "12 x", "" ] + where + fmap' f (OK a _ _) = Just (f a) + fmap' _ Fail = Nothing diff --git a/peg-patterns.md b/peg-patterns.md new file mode 100644 --- /dev/null +++ b/peg-patterns.md @@ -0,0 +1,573 @@ +# PEG patterns for typed-peg + +A companion to Jamie Willis and Nicolas Wu, *Design Patterns for Parser +Combinators (Functional Pearl)*, Haskell 2021 +([10.1145/3471874.3472984](https://doi.org/10.1145/3471874.3472984)). + +That paper collects eleven patterns for writing parsers with a backtracking +combinator library of the `parsec` family. Most of them transfer to typed-peg, +but three things change the picture: + +- **Ordered choice is committed.** Once an alternative succeeds, a PEG never + reconsiders it. There is no `try`, because there is nothing to undo — but the + order in which you write alternatives becomes part of the specification. +- **Left recursion is a type error**, not a discipline to remember. The + `Acyclic` constraint is checked when you construct a `Grammar`. +- **The grammar's shape is written down in a type.** The `Env` records every + rule's nullability, FIRST set and result type. Several of the paper's + patterns become things the compiler enforces rather than things you adopt. + +Every code fragment below is compiled: it lives in +[`examples/Patterns.hs`](examples/Patterns.hs) and runs as part of +`cabal test`. + +## The patterns at a glance + +| Willis & Wu | In typed-peg | +|---|---| +| 1a Homogeneous Chains | [§1.2](#12-chains-fold-a-starred-tail) — write the fold out; no `chainl1` | +| 1b Heterogeneous Chains | [§1.3](#13-one-rule-per-precedence-level) — one rule per level, types declared in the `Env` | +| 1c Precedence Tables | [§1.4](#14-precedence-tables-absent-but-not-impossible) — absent; what it would take | +| 2a Whitespace Combinators | [§2.1](#21-consume-trailing-whitespace-only) — `lexeme` / `fully`, same discipline | +| 2bi Tokenizing Combinators | [§2.2](#22-tokens) — same | +| 2bii Keyword Combinators | [§2.3](#23-keywords-are-negative-lookahead) — **simpler**: `!` instead of `try` | +| 2c Overloaded Strings | [§2.4](#24-the-quasi-quoter-is-the-facade) — subsumed by the quasi-quoter | +| 3a Lifted Constructors | [§3.1](#31-lifted-constructors) — same | +| 3b Deferred Constructors | [§3.2](#32-deferred-constructors-and-the-position-gap) — **partly**; no source positions | +| 4a Verified Errors | [§4](#4-errors-the-shape-without-the-message) — shape only; no messages | +| 4b Preventative Errors | [§4](#4-errors-the-shape-without-the-message) — shape only; no messages | + +Sections [§5](#5-patterns-that-are-specific-to-pegs) and +[§6](#6-what-typed-peg-cannot-do-yet) add patterns the paper has no reason to +cover, and summarise the gaps. + +--- + +## 1. Expressions + +### 1.1 Left recursion is a type error + +The paper opens by writing the textbook grammar directly: + +```haskell +expr = Add <$> expr <*> (char '+' *> term) <|> ... <|> term +``` + +and observing that it loops. Section 2 is then about the rewrite that fixes it. + +In typed-peg you cannot write it in the first place. Each rule's type carries +its FIRST set, and `Grammar` demands `Acyclic env`: + +``` +expr <- e:expr '+' t:term { Add e t } +``` + +``` +Left-recursive non-terminal: "expr" +Its head set already contains itself: ["expr", "term"] +Violates the acyclicity condition i `notElem` Gamma(i).F. +``` + +reported at the `Grammar` constructor, before anything runs. + +**Pattern.** Do not treat left-recursion removal as a step you perform. Write +the grammar; if it compiles, no rule can loop on its own head. The rewrite +below is then the *only* shape available, which is why it is worth having a +name for. + +### 1.2 Chains: fold a starred tail + +*(Willis & Wu, Pattern 1a: Homogeneous Chains.)* + +Their advice is to reach for `chainl1`/`chainr1` rather than hand-rolling +associativity. typed-peg has no chain combinator, so the pattern is the shape +you write instead: **an operand, then a starred tail of (operator, operand) +pairs, folded in the semantic action.** + +``` +expr <- t:term ts:(o:[+-] u:term)* { chainl t ts } +``` + +Left association comes from `foldl`, right association from `foldr`. Keep the +fold itself in Haskell, out of the grammar: + +```haskell +chainl :: Expr -> [(Char, Expr)] -> Expr +chainl = foldl step + where + step l ('+', r) = Add l r + step l ('-', r) = Sub l r + step l ('*', r) = Mul l r + step l ('/', r) = Div l r + step _ (c , _) = error ("chainl: unexpected operator " ++ show c) +``` + +The `error` case is the price of a homogeneous chain: the operator is a `Char`, +so nothing stops a mismatched table. The paper makes exactly this observation, +and its answer is the next pattern. + +### 1.3 One rule per precedence level + +*(Willis & Wu, Pattern 1b: Heterogeneous Chains.)* + +Their fix is to give each precedence level its own AST layer so the types rule +out a mismatched chain. In typed-peg the level structure is *already* forced on +you — a PEG expresses precedence by descent — and the `Env` makes you declare +what each level produces: + +```haskell +type CalcEnv s = + '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr) + , '("term" , 'EnvEntry ('MkTy 'False '["atom", "unary"]) Expr) + , '("unary", 'EnvEntry ('MkTy 'False '["atom"]) Expr) + , '("atom" , 'EnvEntry ('MkTy 'False '[]) Expr) + ] +``` + +``` +expr <- t:term ts:(o:[+-] u:term)* { chainl t ts } +term <- f:unary fs:(o:[*/] g:unary)* { chainl f fs } +unary <- '-' e:unary { Neg e } + / a:atom +atom <- '(' e:expr ')' + / ds:[0-9]+ { mkNum ds } + / &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { mkVar cs } +``` + +**Pattern.** Give each level a distinct result type in the `Env` when you want +the paper's type safety. Above, every level produces `Expr`, which is the +homogeneous choice; changing `term` to produce a `Term` and `expr` an `Expr` +makes a misplaced operator a type error, exactly as in the paper — at the cost +of an AST with one constructor per layer. + +Note the FIRST set columns. They are not decoration: `'["atom", "term", "unary"]` says that entering `expr` can immediately enter any of those, and it +is what the acyclicity check consumes. Getting them wrong is a compile error, +so they double as a checked comment. + +A FIRST set is written in **alphabetical order**, and with no repeats. The +order is not a matter of taste: it is what makes a set have exactly one +spelling, which in turn lets the compiler take the union of two FIRST sets in +one merge pass instead of re-scanning one of them for every element of the +other. Write `'["atom", "term", "unary"]`, not `'["term", "unary", "atom"]`; +the latter is a type error naming the first position that disagrees. + +### 1.4 Precedence tables: absent, but not impossible + +*(Willis & Wu, Pattern 1c: Precedence Tables.)* + +Their `precedence` combinator folds a table of levels into the ladder: + +```haskell +expr = precedence $ + sops InfixL [Add <$ char '+', Sub <$ char '-'] +< + sops InfixL [Mul <$ char '*'] +< + sops Prefix [Neg <$ string "negate"] +< + Atom atom +``` + +**typed-peg does not provide this**, and adding it is more than a convenience +wrapper — but less than impossible, so it is worth being precise about what it +would take. + +`Prec` in the paper is already a type-indexed structure: each `Op a b` +connects a layer producing `a` to one producing `b`, which is what makes +adding or removing a level a type error. A typed-peg version would have to +carry the `Ty` index as well, since every `PExp` is indexed by its nullability +and FIRST set: + +```haskell +data Prec s env ty a where ... -- sketch, not implemented +``` + +The good news is that the `Ty` arithmetic is tractable. Precedence layers are +anonymous `PExp` values rather than named non-terminals, and FIRST sets track +only non-terminal names — so every layer built from operators and a starred +tail has an empty FIRST set, and its nullability follows from `SeqTy`. What is +needed is a GADT whose indices compose the way `SeqTy` and `ChoiceTy` do, plus +`infixl1`/`infixr1`/`prefix`/`postfix` at the `PExp` level. + +Until then, write the levels out as in §1.3. For four or five levels that is +barely longer than the table, and it keeps each level visible in the `Env`. + +--- + +## 2. Lexing + +### 2.1 Consume trailing whitespace only + +*(Willis & Wu, Pattern 2a: Whitespace Combinators.)* + +Their rule, which transfers unchanged: **every lexeme consumes the whitespace +*after* it, never before; one `fully` at the top consumes leading whitespace +and demands end of input.** Consuming leading whitespace inside a lexeme breaks +position reporting and makes it ambiguous who is responsible for a given space. + +```haskell +ws :: PExp s env ('MkTy 'True '[]) s +ws = spanOf (fromRanges [(' ', ' '), ('\t', '\t'), ('\r', '\r'), ('\n', '\n')]) + +lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a +lexeme p = (\x _ -> x) <$>. p <*>. ws + +eof :: PExp s env ('MkTy 'True '[]) () +eof = Not AnyChar + +fully :: PExp s env ty a + -> PExp s env (SeqTy ('MkTy 'True '[]) + (SeqTy ty ('MkTy 'True '[]))) a +fully p = (\_ x _ -> x) <$>. ws <*>. p <*>. eof +``` + +``` +"12" => OK "12" +" 12 " => OK "12" +"12 x" => Fail +"" => Fail +``` + +Two typed-peg specifics. `ws` is a character class, so it compiles to a single +`Span` node and returns a chunk of the input — over `Text` that is a slice, and +when the item is unlabelled in a quasi-quoted rule the chunk is discarded +anyway. And `eof` is `Not AnyChar`, written `!.` in the quasi-quoter: a PEG +gets end-of-input from negative lookahead rather than from a primitive. + +**`fully` matters more in a PEG than in `parsec`.** A PEG parser is happy to +succeed on a prefix: + +``` +"a:=1;" => OK [Asgn "a" (Num 1)] rest=";" +``` + +Nothing is wrong here — the grammar matched what it could. If you want the +whole input consumed you must say so, and `fully` is where you say it. + +### 2.2 Tokens + +*(Willis & Wu, Pattern 2bi: Tokenizing Combinators.)* + +Same pattern: annotate terminals with `lexeme`, not the composite rules. Their +`token = lexeme . try` loses its `try` here, since ordered choice needs no +backtracking marker. + +In a quasi-quoted grammar the usual spelling is a `ws` rule invoked after each +terminal, as `examples/Layout.hs` and the JSON benchmark do: + +``` +pair <- k:strlit ws ':' ws v:value { (k, v) } +``` + +**Keep the `ws` calls at terminal boundaries and nowhere else.** A `ws` in the +middle of a composite rule is the same mistake as leading whitespace in a +lexeme: it makes two rules disagree about who owns the space between them. + +### 2.3 Keywords are negative lookahead + +*(Willis & Wu, Pattern 2bii: Keyword Combinators.)* + +This is the pattern a PEG expresses best. The problem is that `string "negate"` +happily matches the prefix of `negatex`. Their answer is a `keyword` combinator +that checks no identifier character follows — which in `parsec` needs `try` to +undo the partial match. + +In a PEG it is just `!`: + +```haskell +keyword :: String -> PExp s env ('MkTy 'False '[]) () +keyword k = (\_ _ -> ()) <$>. stringNE k <*>. Not (sat identCont) +``` + +or, in the quasi-quoter, `"negate" ![a-zA-Z0-9_]`. + +``` +"negate" keyword => OK () | bare => OK () +"negatex" keyword => Fail | bare => OK () rest="x" +"negate2" keyword => Fail | bare => OK () rest="2" +"negate x" keyword => OK () rest=" x"| bare => OK () rest=" x" +``` + +The `bare` column is the bug the pattern prevents: without the lookahead, +`negatex` parses as the keyword `negate` followed by the variable `x`. + +**The same shape covers every longest-match ambiguity**, not only keywords: +`'<' !'='` is "less-than, but not the start of `<=`". See §5.1 for the +alternative spelling. + +### 2.4 The quasi-quoter is the facade + +*(Willis & Wu, Pattern 2c: Overloaded Strings.)* + +Their goal is to write `"if" *> expr` and have the string literal quietly +become a tokenizing parser, via `IsString`. The quasi-quoter already provides +this, and more directly: inside `[pegRules| ... |]`, `"do"` *is* a string +literal in grammar syntax, `[a-z]` is a character class, and `/` is ordered +choice. There is no Haskell-level plumbing to hide. + +The residue of the pattern still applies: **keep token definitions in one +place.** A rule named `ident` or `number` used everywhere beats the same +character class copy-pasted into five rules — not for concision, but because +the `Env` then names it, and a change happens once. + +--- + +## 3. Building the AST + +### 3.1 Lifted constructors + +*(Willis & Wu, Pattern 3a: Lifted Constructors.)* + +Their advice — put bookkeeping in a smart constructor so the parser reads like +the grammar — transfers unchanged, and typed-peg gives it an extra job. Because +a character class produces a chunk of the stream rather than a `String`, the +conversion belongs in the smart constructor rather than smeared through the +actions: + +```haskell +mkNum :: Stream s => s -> Expr +mkNum = Num . read . chunkToString + +mkVar :: Stream s => s -> Expr +mkVar = Var . chunkToString +``` + +``` +atom <- '(' e:expr ')' + / ds:[0-9]+ { mkNum ds } + / &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { mkVar cs } +``` + +**Keep semantic actions one application wide.** An action is Haskell spliced +unhygienically into the generated code; a long one is hard to read in grammar +syntax and hard to debug when it fails to typecheck, because the error points +at the quasi-quote. + +### 3.2 Deferred constructors, and the position gap + +*(Willis & Wu, Pattern 3b: Deferred Constructors.)* + +Their motivating example is source positions: a node needs the position from +*before* its first token, so the constructor is returned by a parser and +applied later. + +**typed-peg cannot do this**, because no combinator exposes the current +position to a semantic action. `PState` tracks `stCol` and `stOff`, and +`PEG.Indent` uses columns for layout, but neither is reachable from `{ ... }`. +A grammar cannot annotate its AST with source locations. + +What does transfer is the general form — returning a function to be applied +later, so that bookkeeping is decoupled from the parser. In typed-peg this is +just a rule whose result type is a function: + +```haskell +type OpEnv = '[ '("op", 'EnvEntry ('MkTy 'False '[]) (Expr -> Expr -> Expr)) ] + +addOp :: Stream s => Grammar s OpEnv _ (Expr -> Expr -> Expr) +addOp = Grammar [pegRules| op <- '+' { Add } / '-' { Sub } |] (nt @"op") +``` + +``` +"+" => Add (Num 1) (Num 2) +"-" => Sub (Num 1) (Num 2) +"*" => Fail +``` + +The rule's result type is a function, and the chain rule applies it. This is the same defunctionalisation the paper describes, and it +removes the partial `error` case from §1.2's `chainl`. + +See §6: exposing position is the single change that would unlock the most of +this paper. + +--- + +## 4. Errors: the shape without the message + +*(Willis & Wu, Patterns 4a Verified Errors and 4b Preventative Errors.)* + +Their patterns are about *messages*: use `lookAhead` to check that an error is +warranted before raising it, and `notFollowedBy` to rule out input that would +otherwise produce a confusing failure further along. + +**typed-peg has no error messages at all.** `Result` is + +```haskell +data Result s a = OK a s s | Fail +``` + +There is no position, no expected set, no label. Both patterns are therefore +unavailable in their stated form. + +The *rejection* half still works, and is worth using. Preventative errors +become preventative failures: + +``` +asgn <- &[a-zA-Z_] v:[a-zA-Z0-9_]+ ":=" e:expr !'<' { mkAsgn v e } +``` + +— an assignment whose right-hand side is followed by `<` is rejected here +rather than half-consumed and rejected somewhere less obvious. You lose the +message; you keep the locality. + +Positive lookahead `&e` is `Not (Not e)`, so the verification half of Pattern +4a is expressible as a guard even though nothing can be reported. + +--- + +## 5. Patterns that are specific to PEGs + +### 5.1 In an ordered choice, the longest alternative goes first + +Nothing in the paper needs this, because `<|>` with `try` reconsiders. A PEG +commits to the first success: + +``` +op <- '<' / '<=' -- WRONG: '<=' is never reached +op <- '<=' / '<' -- right +``` + +The first line silently parses `a <= b` as `a < (= b)` and then fails +somewhere else entirely. There is no warning: both grammars typecheck, and both +have the same FIRST set. + +**Pattern.** When two alternatives share a prefix, order them longest-first. +When that is awkward — because the alternatives are non-terminals whose lengths +are not obvious — use the §2.3 lookahead spelling instead, which states the +constraint locally rather than relying on the order of a list. + +This is the one place where typed-peg's type-level machinery does *not* help, +and it is worth knowing that the acyclicity check is not a substitute for +thinking about the order. + +### 5.2 Prefer a negated class to the `!c .` idiom + +The traditional PEG spelling of "any character except a quote" is +`(!'"' .)*` — a negative lookahead followed by a wildcard, which inspects +every character twice. typed-peg's quasi-quoter accepts a negated class: + +``` +q <- '"' cs:[^"]* '"' -- one bit test per character +q <- '"' cs:(!'"' c:.)* '"' -- two passes per character, and a cons list +``` + +The two describe the same language. On the benchmark suite the class form +allocates **90 bytes per input byte against 209**, and runs about **1.5× +faster**. It also returns a chunk of the stream rather than a `[Char]`. + +**Pattern.** Reach for `[^...]` whenever the lookahead is a single character. +Keep `!e` for the cases a class cannot express — a keyword boundary, a +multi-character sentinel, a non-terminal. + +### 5.3 A starred character class returns a chunk + +`[a-z]*` and `[a-z]+` compile to `Span`/`Span1` and produce a slice of the +input stream, not a `[Char]`. That has a consequence for a very common idiom: + +``` +ident <- c:[a-zA-Z_] cs:[a-zA-Z0-9_]* { c : cs } +``` + +`c` is a `Char` and `cs` is a chunk. This still compiles if the grammar is +fixed to `String` — where a chunk *is* a `[Char]` — but a stream-polymorphic +grammar is rejected: + +``` +Couldn't match expected type 's' with actual type '[Char]' + 's' is a rigid type variable bound by the inferred type of + identG :: Stream s => Grammar s (IdEnv s) (MkTy False '["ident"]) s +``` + +So the idiom quietly ties a grammar to one stream. The fix is also faster, +because it scans once instead of twice and copies nothing: + +``` +ident <- &[a-zA-Z_] cs:[a-zA-Z0-9_]+ { cs } +``` + +The positive lookahead pins the first character to the narrower class without +consuming it, then one span takes the whole identifier. + +**Pattern.** When a token is "one character from class A, then characters from +class B" and A is a subset of B, write it as `&A B+`. + +### 5.4 The `Env` is a specification, so write it first + +The environment is not boilerplate to be derived from the rules — it is the +grammar's interface, and it is checked: + +```haskell +type CalcEnv s = + '[ '("expr" , 'EnvEntry ('MkTy 'False '["atom", "term", "unary"]) Expr) + , ... + ] +``` + +Each entry states three things: whether the rule can match the empty string, +which non-terminals it can enter first, and what it produces. All three are +verified against the rule bodies. + +**Pattern.** Write the `Env` before the rules, as you would write a signature +before a function. When a rule's FIRST set surprises you, that is usually the +grammar telling you something — a rule that is unexpectedly nullable is often a +`*` that should have been a `+`. + +Two practical notes. A rule whose result is a character-class repetition has +result type `s`, so its `Env` synonym takes the stream as a parameter +(`CalcEnv s`). And GHC's error when an entry is wrong points at the whole +quasi-quote, not at the offending rule — so add rules a few at a time. + +### 5.5 Layout is a grammar concern, not a lexer concern + +`PEG.Indent` gives rules a column relation, so indentation-sensitive syntax +stays in the grammar instead of being pushed into a layout-inserting lexer: + +``` +istmts <- ss:(ws st:|s:stmt|)+^> -- each statement strictly indented +stmts <- r:(ws '{' ... ws '}')^~ -- braces: any column +``` + +`^>`, `^~`, `^=` and `_~` attach a relation to a sub-expression. This has no +counterpart in the paper, whose language is layout-insensitive. + +**Pattern.** Give the brace form and the layout form as two alternatives of one +rule, with the relation attached to each, rather than deciding between them +before parsing. + +--- + +## 6. What typed-peg cannot do yet + +Collected from above, in the order that would most help a user of this library: + +1. **Source positions in semantic actions.** Blocks Pattern 3b's motivating + use and any AST that records where its nodes came from. `PState` already + carries `stOff` and `stCol`; what is missing is a `PExp` constructor that + hands them to an action. +2. **Error messages.** `Result` is `OK` or `Fail`. Patterns 4a and 4b are + about phrasing good errors, and neither can be expressed. This is the + largest single gap between typed-peg and the paper. +3. **A `precedence` combinator.** Needs a `Ty`-indexed `Prec` GADT and + `infixl1`/`infixr1`/`prefix`/`postfix` at the `PExp` level (§1.4). Real + work, but the index arithmetic is tractable. +4. **Chain combinators.** `chainl1`/`chainr1` are a small, unblocked + convenience: they would remove the hand-written `foldl` from every + expression grammar. +5. **A token/lexeme vocabulary in the quasi-quoter.** `lexeme`, `keyword` and + `fully` are ten lines each (§2.1, §2.3) but every user writes them again. + +None of 1, 2, 4 or 5 is blocked by the type-level design; they are absent +rather than impossible. + +--- + +## Reading the examples + +```bash +cabal test typed-peg-examples +``` + +runs `examples/Patterns.hs` along with the rest, printing the output quoted +throughout this document. The grammars are in: + +- [`examples/Patterns.hs`](examples/Patterns.hs) — every fragment above +- [`examples/Arith.hs`](examples/Arith.hs) — the minimal precedence ladder +- [`examples/Layout.hs`](examples/Layout.hs) — indentation-sensitive `do` +- [`bench/Bench/Peg.hs`](bench/Bench/Peg.hs) — JSON, CSV, and the two + quoted-string spellings of §5.2 diff --git a/src/PEG.hs b/src/PEG.hs --- a/src/PEG.hs +++ b/src/PEG.hs @@ -19,7 +19,9 @@ -- -- See the @examples/@ directory for complete working grammars. module PEG - ( module PEG.Type + ( module PEG.CharSet + , module PEG.Stream + , module PEG.Type , module PEG.TyLevel , module PEG.Member , module PEG.Indent @@ -28,7 +30,9 @@ , module PEG.Parse ) where +import PEG.CharSet import PEG.Grammar +import PEG.Stream import PEG.Indent import PEG.Member import PEG.Parse diff --git a/src/PEG/CharSet.hs b/src/PEG/CharSet.hs new file mode 100644 --- /dev/null +++ b/src/PEG/CharSet.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Compact character sets used by the 'PEG.Syntax.Sat' combinator. +-- +-- A character class such as @[a-zA-Z0-9_]@ used to be compiled into a chain of +-- 63 ordered choices, so matching a single character could cost 63 parser +-- steps. A 'CharSet' answers the same question with one bit test. +-- +-- The Latin-1 range (@\\0@ .. @\\255@), which covers essentially every class +-- that appears in a practical grammar, is stored as a 256-bit bitmap held in +-- four 'Word64's. Characters above that range fall back to a list of ranges. +module PEG.CharSet + ( CharSet (..) + , memberCS + , fromRanges + , notInRanges + , fromList + , singletonCS + , complementCS + , nullCS + , anyCS + ) where + +import Data.Bits (setBit, testBit) +import Data.Char (chr, ord) +import Data.Word (Word64) + +-- | A set of characters. The four 'Word64' fields form a bitmap of the +-- Latin-1 range; 'csWide' holds any ranges that reach beyond it. +-- +-- Negation is a flag rather than an actual complement, so a negated class is +-- exactly as cheap to test as a positive one and stays exact for the whole of +-- 'Char' (complementing the ranges above Latin-1 explicitly would not). +data CharSet = CharSet + { csNeg :: !Bool + , csB0 :: !Word64 + , csB1 :: !Word64 + , csB2 :: !Word64 + , csB3 :: !Word64 + , csWide :: ![(Char, Char)] + } + deriving (Eq, Show) + +-- | Is the character a member of the set? @O(1)@ for Latin-1 characters. +memberCS :: Char -> CharSet -> Bool +memberCS c cs = csNeg cs /= rawMember c cs +{-# INLINE memberCS #-} + +-- | Membership ignoring the negation flag. +rawMember :: Char -> CharSet -> Bool +rawMember c (CharSet _ b0 b1 b2 b3 wide) + | n < 64 = testBit b0 n + | n < 128 = testBit b1 (n - 64) + | n < 192 = testBit b2 (n - 128) + | n < 256 = testBit b3 (n - 192) + | otherwise = inWide wide + where + !n = ord c + inWide [] = False + inWide ((lo, hi) : rs) = (n >= ord lo && n <= ord hi) || inWide rs +{-# INLINE rawMember #-} + +-- | Build a set from a list of inclusive character ranges. +fromRanges :: [(Char, Char)] -> CharSet +fromRanges = mkRanges False + +-- | The complement of 'fromRanges': every character /outside/ the given +-- ranges. This is what the quasi-quoter emits for @[^\"]@. +notInRanges :: [(Char, Char)] -> CharSet +notInRanges = mkRanges True + +-- | Flip a set\'s polarity. +complementCS :: CharSet -> CharSet +complementCS cs = cs { csNeg = not (csNeg cs) } + +mkRanges :: Bool -> [(Char, Char)] -> CharSet +mkRanges neg rs = CharSet neg (word 0) (word 64) (word 128) (word 192) wide + where + lows = [ n | (lo, hi) <- rs, n <- [ord lo .. min 255 (ord hi)] ] + + word base = go 0 lows + where + go !w [] = w + go !w (n : ns) + | n >= base && n < base + 64 = go (setBit w (n - base)) ns + | otherwise = go w ns + + wide = [ (max lo (chr 256), hi) | (lo, hi) <- rs, ord hi > 255 ] + +-- | Build a set from an explicit list of characters. +fromList :: [Char] -> CharSet +fromList cs = fromRanges [ (c, c) | c <- cs ] + +-- | The set containing exactly one character. +singletonCS :: Char -> CharSet +singletonCS c = fromRanges [(c, c)] + +-- | The set of every character. This is what @.*@ compiles to. +anyCS :: CharSet +anyCS = notInRanges [] + +-- | Is the set empty? +nullCS :: CharSet -> Bool +nullCS (CharSet False 0 0 0 0 []) = True +nullCS _ = False diff --git a/src/PEG/Grammar.hs b/src/PEG/Grammar.hs --- a/src/PEG/Grammar.hs +++ b/src/PEG/Grammar.hs @@ -29,35 +29,44 @@ -- | A typed, heterogeneous list of named grammar rules. -- --- @'Rules' env defs@ is a list of rules whose bodies reference non-terminals --- in @env@ and whose definitions together form @defs@. -data Rules (env :: Env) (defs :: Env) where - RNil :: Rules env '[] - RCons :: Name s - -> PExp env ty a - -> Rules env rest - -> Rules env ('(s, 'EnvEntry ty a) ': rest) +-- @'Rules' s env defs@ is a list of rules over the stream @s@ whose bodies +-- reference non-terminals in @env@ and whose definitions together form +-- @defs@. +data Rules (s :: Type) (env :: Env) (defs :: Env) where + RNil :: Rules s env '[] + RCons :: Name n + -> PExp s env ty a + -> Rules s env rest + -> Rules s env ('(n, 'EnvEntry ty a) ': rest) type family Acyclic (env :: Env) :: Constraint where - Acyclic '[] = () - Acyclic ('(s, 'EnvEntry ty _) ': rest) = - (NotLeftRec s (Elem s (First ty)) ty, Acyclic rest) + Acyclic '[] = () + Acyclic ('(s, 'EnvEntry ('MkTy _ f) _) ': rest) = + (NotLeftRec s (Elem s f) f, Acyclic rest) -type family NotLeftRec (s :: Symbol) (b :: Bool) (ty :: Ty) :: Constraint where - NotLeftRec _ 'False _ = () - NotLeftRec s 'True ty = +type family NotLeftRec (s :: Symbol) (b :: Bool) + (f :: [Symbol]) :: Constraint where + NotLeftRec _ 'False _ = () + NotLeftRec s 'True f = TypeError ('Text "Left-recursive non-terminal: " ':<>: 'ShowType s ':$$: 'Text "Its head set already contains itself: " - ':<>: 'ShowType (First ty) + ':<>: 'ShowType f ':$$: 'Text "Violates the acyclicity condition i `notElem` Gamma(i).F.") --- | A complete PEG grammar: a set of mutually recursive rules and a start --- expression. +-- | A complete PEG grammar over the stream @s@: a set of mutually recursive +-- rules and a start expression. -- +-- A 'Grammar' is monomorphic in its stream. To reuse one grammar across +-- several stream types, give it a signature of the form +-- @forall s. 'PEG.Stream.Stream' s => Grammar s Env ty a@ — but note that +-- doing so turns the value into a function of a dictionary, so the compiled +-- parser is no longer shared between calls. Prefer a monomorphic top-level +-- signature. +-- -- Constructing a 'Grammar' value discharges the 'Acyclic' constraint, so -- any left-recursion in @env@ becomes a compile-time type error. -data Grammar (env :: Env) (startTy :: Ty) (startA :: Type) where +data Grammar (s :: Type) (env :: Env) (startTy :: Ty) (startA :: Type) where Grammar :: Acyclic env - => Rules env env - -> PExp env startTy startA - -> Grammar env startTy startA + => Rules s env env + -> PExp s env startTy startA + -> Grammar s env startTy startA diff --git a/src/PEG/Indent.hs b/src/PEG/Indent.hs --- a/src/PEG/Indent.hs +++ b/src/PEG/Indent.hs @@ -76,6 +76,13 @@ data RelD = RelD { rdName :: String + , rdTotal :: !Bool + -- ^ 'True' when the relation places no constraint at all on columns, i.e. + -- when @'preimage' rd i == 'fullI'@ and @'image' rd j@ leaves the + -- candidate interval untouched, for every non-empty @i@ and every @j@. + -- Only 'anyR' satisfies this. The parser uses the flag to skip all + -- interval arithmetic on grammars that do not use layout, which is the + -- overwhelmingly common case. , rdDom :: Interval , rdLo :: Int -> Int , rdHi :: Int -> Bound @@ -126,6 +133,7 @@ eqR :: Rel "=" eqR = Rel RelD { rdName = "=" + , rdTotal = False , rdDom = fullI , rdLo = id , rdHi = Fin @@ -143,6 +151,7 @@ gapD :: String -> Int -> RelD gapD name k = RelD { rdName = name + , rdTotal = False , rdDom = Interval k Inf , rdLo = const 0 , rdHi = \i -> Fin (i - k) @@ -163,6 +172,7 @@ anyR :: Rel "~" anyR = Rel RelD { rdName = "~" + , rdTotal = True , rdDom = fullI , rdLo = const 0 , rdHi = const Inf @@ -177,6 +187,7 @@ constR :: Int -> Rel "const" constR c = Rel RelD { rdName = "const " ++ show c + , rdTotal = False , rdDom = singletonI c , rdLo = const 0 , rdHi = const Inf @@ -191,6 +202,7 @@ offsetR :: Int -> Rel "offset" offsetR k = Rel RelD { rdName = "+" ++ show k + , rdTotal = False , rdDom = Interval k Inf , rdLo = \i -> i - k , rdHi = \i -> Fin (i - k) diff --git a/src/PEG/Member.hs b/src/PEG/Member.hs --- a/src/PEG/Member.hs +++ b/src/PEG/Member.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -5,16 +6,27 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | Membership witnesses for heterogeneous type-level environments. -- --- 'Member' is a proof that a name @s@ with type @ty@ and result @a@ is --- present in the environment @env@. 'KnownMember' is the class that allows --- the proof to be materialised from type information at runtime, enabling --- non-terminal lookup during parsing. +-- 'Member' is a proof that a name @s@ with result type @a@ is present in the +-- environment @env@. 'KnownMember' is the class that allows the proof to be +-- materialised from type information at runtime, enabling non-terminal lookup +-- during parsing. +-- +-- == Why the 'PEG.Type.Ty' is not an index +-- +-- The witness deliberately does /not/ record the non-terminal's +-- 'PEG.Type.Ty'. Resolving @KnownMember s env a@ walks @env@ one instance at +-- a time, and every index of the class is carried along — and re-normalised — +-- at each of those steps. A 'PEG.Type.Ty' carries a FIRST set, so an index +-- for it makes each step cost @O(|env|)@ instead of @O(1)@. Nothing needs +-- it: 'Here' binds the entry's @ty@ existentially, which is enough to pull +-- the matching rule out of a rule table. module PEG.Member ( Member (..) , KnownMember (..) @@ -22,35 +34,41 @@ import Data.Kind (Type) import Data.Proxy (Proxy (..)) -import GHC.TypeLits (ErrorMessage (..), Symbol, TypeError) +import GHC.TypeLits (CmpSymbol, ErrorMessage (..), Symbol, TypeError) import PEG.Type -import PEG.TyLevel (SymEq) -data Member (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where - Here :: Member s ('(s, 'EnvEntry ty a) ': rest) ty a - There :: Member s rest ty a -> Member s (e ': rest) ty a +-- | @'Member' s env a@ witnesses that @env@ binds the name @s@ to a rule +-- returning @a@, and records /where/ in @env@ that binding is. +data Member (s :: Symbol) (env :: Env) (a :: Type) where + Here :: Member s ('(s, 'EnvEntry ty a) ': rest) a + There :: Member s rest a -> Member s (e ': rest) a -class KnownMember (s :: Symbol) (env :: Env) (ty :: Ty) (a :: Type) where - member :: Member s env ty a +class KnownMember (s :: Symbol) (env :: Env) (a :: Type) where + member :: Member s env a instance TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s ':$$: 'Text "The grammar has no rule for this name.") - => KnownMember s '[] ty a where + => KnownMember s '[] a where member = error "PEG.Member: unreachable" -instance KnownMember' (SymEq s t) s ('(t, e) ': rest) ty a - => KnownMember s ('(t, e) ': rest) ty a where - member = member' (Proxy :: Proxy (SymEq s t)) +-- Dispatch on 'CmpSymbol' directly rather than through a @SymEq@ wrapper: +-- that is one fewer type-family application to reduce per entry scanned, and +-- an environment is scanned once per occurrence of every non-terminal. +instance KnownMemberStep (CmpSymbol s t) s ('(t, e) ': rest) a + => KnownMember s ('(t, e) ': rest) a where + member = memberStep (Proxy :: Proxy (CmpSymbol s t)) -class KnownMember' (b :: Bool) (s :: Symbol) (env :: Env) - (ty :: Ty) (a :: Type) where - member' :: Proxy b -> Member s env ty a +class KnownMemberStep (o :: Ordering) (s :: Symbol) (env :: Env) (a :: Type) where + memberStep :: Proxy o -> Member s env a -instance (s ~ t, e ~ 'EnvEntry ty a) - => KnownMember' 'True s ('(t, e) ': rest) ty a where - member' _ = Here +-- The entry is taken apart in the instance head, so @ty@ is bound by +-- matching and never has to be threaded through the class. +instance (s ~ t) => KnownMemberStep 'EQ s ('(t, 'EnvEntry ty a) ': rest) a where + memberStep _ = Here -instance KnownMember s rest ty a - => KnownMember' 'False s ('(t, e) ': rest) ty a where - member' _ = There member +instance KnownMember s rest a => KnownMemberStep 'LT s ('(t, e) ': rest) a where + memberStep _ = There member + +instance KnownMember s rest a => KnownMemberStep 'GT s ('(t, e) ': rest) a where + memberStep _ = There member diff --git a/src/PEG/Parse.hs b/src/PEG/Parse.hs --- a/src/PEG/Parse.hs +++ b/src/PEG/Parse.hs @@ -1,70 +1,121 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} --- | Running a 'Grammar' against a 'String'. +-- | Running a 'Grammar' against an input stream. -- -- The top-level entry points are 'parse' (uses 'defaultOpts') and 'parseWith' -- (accepts custom 'Opts' for indentation-sensitive parsing). Both return a -- 'Result' that records the matched value, the consumed prefix, and the -- remaining suffix. +-- +-- The input can be any "PEG.Stream" instance: 'String', strict or lazy +-- 'Data.Text.Text', strict or lazy 'Data.ByteString.ByteString'. +-- +-- == Compiling once, parsing many times +-- +-- 'parseWith' is written so that @'parseWith' opts g@ is a /closure/ that has +-- already traversed the grammar: every non-terminal reference has been +-- resolved to a function, and no 'PExp' constructor is examined again while +-- input is being consumed. Bind it once and reuse it: +-- +-- @ +-- myParser :: String -> Result String Exp +-- myParser = parse myGrammar -- compiled once, at first use +-- @ +-- +-- Writing @'parse' myGrammar input@ inline inside a loop instead re-does the +-- traversal on every call. Give the binding a /monomorphic/ signature: a +-- grammar left polymorphic in its stream is a function of a 'Stream' +-- dictionary rather than a constant, so nothing is shared between calls. +-- +-- == Why the result of a step is an unboxed sum +-- +-- A compiled step returns @(# (# #) | (# a, 'PState' s #) #)@ rather than +-- @'Maybe' (a, 'PState' s)@. The two are isomorphic, but the unboxed sum +-- lives in registers: a step that succeeds no longer allocates a @Just@ /and/ +-- a pair on top of the new state, and a step that fails allocates nothing at +-- all. Because the intermediate results of 'Seq' and 'Map' never escape, +-- this makes those two constructors — the ones the quasi-quoter emits for +-- every single grammar item — allocation-free. module PEG.Parse ( Result (..) , parse , parseWith - , eval + , compileGrammar + , Step + , Res , Opts (..) , defaultOpts - , Input , PState (..) - , columns + , nextCol ) where +import Data.Kind (Type) +import qualified Data.ByteString as B +import qualified Data.Text as T + +import PEG.CharSet (CharSet, memberCS) import PEG.Grammar import PEG.Indent import PEG.Member +import PEG.Stream import PEG.Syntax import PEG.Type -import PEG.TyLevel (Lookup) -- | The result of running a grammar. -- -- @'OK' a consumed rest@ means the grammar matched, producing value @a@. -- @consumed@ is the prefix of the input that was consumed; @rest@ is the -- remaining input. -data Result a - = OK a String String +data Result s a + = OK a s s | Fail deriving (Show, Eq) --- | A string annotated with column positions, as produced by 'columns'. -type Input = [(Char, Int)] - -- | Internal parser state. -data PState = PState - { stInput :: Input -- ^ Remaining input with column positions. +-- +-- The column of the character at the head of 'stInput' is carried alongside +-- the input rather than being precomputed for the whole stream, so nothing +-- proportional to the input is ever allocated up front. +data PState s = PState + { stInput :: !s -- ^ Remaining input. + , stCol :: !Int -- ^ Column of the head of 'stInput'. + , stOff :: !Int -- ^ Characters consumed so far. , stCands :: !Interval -- ^ Current candidate column interval. , stAlign :: !Bool -- ^ Whether the next token must be aligned. } --- | Annotate every character in a string with its column position. --- Tab stops are expanded according to @tabWidth@. -columns :: Int -> String -> Input -columns tabWidth = go 0 - where - go _ [] = [] - go c (x:xs) = (x, c) : go (next c x) xs +-- | What a compiled step returns: either failure (the left injection, which +-- carries nothing) or a value together with the state after it. +-- +-- This is @'Maybe' (a, 'PState' s)@ with the two boxes removed. +type Res s a = (# (# #) | (# a, PState s #) #) - next _ '\n' = 0 - next c '\t' - | tabWidth > 1 = ((c `div` tabWidth) + 1) * tabWidth - | otherwise = c + 1 - next c _ = c + 1 +-- | A compiled parser: it still takes the ambient column relation, because a +-- rule body inherits the relation in force at its call site. +type Step s a = RelD -> PState s -> Res s a +-- | Column of the character following @c@, given a column of @c@ and a tab +-- width. +nextCol :: Int -> Int -> Char -> Int +nextCol _ _ '\n' = 0 +nextCol tw c '\t' + | tw > 1 = ((c `div` tw) + 1) * tw + | otherwise = c + 1 +nextCol _ c _ = c + 1 +{-# INLINE nextCol #-} + -- | Parser configuration. data Opts = Opts { optTokenMode :: RelD -- ^ Default column relation between tokens. @@ -81,102 +132,348 @@ } -- | Run a grammar with 'defaultOpts'. -parse :: Grammar env ty a -> String -> Result a +parse :: Stream s => Grammar s env ty a -> s -> Result s a parse = parseWith defaultOpts +{-# INLINABLE parse #-} +{-# SPECIALIZE parse :: Grammar String env ty a -> String -> Result String a #-} +{-# SPECIALIZE parse :: Grammar T.Text env ty a -> T.Text -> Result T.Text a #-} +{-# SPECIALIZE parse + :: Grammar B.ByteString env ty a -> B.ByteString -> Result B.ByteString a #-} -- | Run a grammar with custom 'Opts'. -parseWith :: Opts -> Grammar env ty a -> String -> Result a -parseWith opts (Grammar rules start) input = - case eval rules start (optTokenMode opts) st0 of - Nothing -> Fail - Just (a, st) -> - let n = length input - length (stInput st) - in OK a (take n input) (drop n input) +-- +-- Partially applying this to the options and the grammar yields a compiled +-- parser; see the note at the top of this module. +parseWith :: forall s env ty a. + Stream s => Opts -> Grammar s env ty a -> s -> Result s a +parseWith opts g = run where - st0 = PState - { stInput = columns (optTabWidth opts) input - , stCands = optCands opts - , stAlign = False - } + step = compileGrammar (optTabWidth opts) g + tau0 = optTokenMode opts --- | Low-level evaluator: run a 'PExp' against a 'PState' under a given column --- relation. Exposed for advanced use; most callers should use 'parse' or --- 'parseWith'. -eval :: forall env ty a - . Rules env env - -> PExp env ty a - -> RelD - -> PState - -> Maybe (a, PState) -eval rules = go + run input = case step tau0 (PState input 0 0 (optCands opts) False) of + (# (# #) | #) -> Fail + (# | (# a, st #) #) -> OK a (takeS (stOff st) input) (stInput st) +{-# INLINABLE parseWith #-} +{-# SPECIALIZE parseWith + :: Opts -> Grammar String env ty a -> String -> Result String a #-} +{-# SPECIALIZE parseWith + :: Opts -> Grammar T.Text env ty a -> T.Text -> Result T.Text a #-} +{-# SPECIALIZE parseWith + :: Opts -> Grammar B.ByteString env ty a + -> B.ByteString -> Result B.ByteString a #-} + +-------------------------------------------------------------------------------- +-- Compilation +-------------------------------------------------------------------------------- + +-- | A rule table in which every body has already been compiled to a 'Step'. +-- Built with a knot so that mutually recursive rules resolve to each other's +-- closures. +data CRules (s :: Type) (env :: Env) (defs :: Env) where + CNil :: CRules s env '[] + CCons :: Step s a + -> CRules s env rest + -> CRules s env ('(n, 'EnvEntry ty a) ': rest) + +clookup :: Member n defs a -> CRules s env defs -> Step s a +clookup Here (CCons f _) = f +clookup (There m) (CCons _ rest) = clookup m rest + +-- | Traverse the grammar once and return a closure that consumes input. +-- +-- The traversal resolves every non-terminal reference to the corresponding +-- compiled rule, so at parse time a non-terminal costs one indirect call +-- instead of a walk down the rule list. +compileGrammar :: forall s env ty a. + Stream s => Int -> Grammar s env ty a -> Step s a +compileGrammar tw (Grammar rules start) = compileE tw table start where - go :: forall t b. PExp env t b -> RelD -> PState -> Maybe (b, PState) - go (Pure x) _ st = Just (x, st) + table :: CRules s env env + table = build rules - go (Term c) tau st = do - (x, st') <- terminal tau st - if x == c then Just (c, st') else Nothing + build :: forall defs. Rules s env defs -> CRules s env defs + build RNil = CNil + build (RCons _ body rest) = CCons (compileE tw table body) (build rest) +{-# INLINABLE compileGrammar #-} +{-# INLINABLE compileE #-} +-- Without these the whole parse runs through a 'Stream' dictionary, and the +-- per-character path stops being allocation-free. Callers using another +-- stream should mark their own monomorphic parser bindings INLINABLE. +{-# SPECIALIZE compileGrammar + :: Int -> Grammar String env ty a -> Step String a #-} +{-# SPECIALIZE compileGrammar + :: Int -> Grammar T.Text env ty a -> Step T.Text a #-} +{-# SPECIALIZE compileGrammar + :: Int -> Grammar B.ByteString env ty a -> Step B.ByteString a #-} - go AnyChar tau st = terminal tau st +-- | Does this class avoid the two characters whose column advance is not +-- simply @+1@? When it does, the column after a matched run is the column +-- before it plus the run's length, and no fold is needed. +simpleCS :: CharSet -> Bool +simpleCS cs = not (memberCS '\n' cs) && not (memberCS '\t' cs) - go (NT (_ :: Name s)) tau st = - go (ruleFor (member :: Member s env (TyOf (Lookup s env)) - (ResOf (Lookup s env))) - rules) - tau st +compileE :: forall s env ty a. + Stream s => Int -> CRules s env env -> PExp s env ty a -> Step s a +compileE tw table = comp + where + -- Select the stream operations once per compiled grammar. Leaving them + -- as class-method applications would repeat the dictionary lookup on + -- every character. + !uncons = unconsS :: s -> (# (# #) | (# Char, s #) #) + !spanS' = spanS :: (Char -> Bool) -> s -> (s, s) + !lenS' = lengthS :: s -> Int + !foldS' = foldlS' :: (Int -> Char -> Int) -> Int -> s -> Int + !toStr = chunkToString :: s -> String + !packS = packString :: String -> s + !emptyS = packS [] - go (Seq ef ex) tau st = do - (f, st') <- go ef tau st - (x, st'') <- go ex tau st' - pure (f x, st'') + comp :: forall t b. PExp s env t b -> Step s b - go (Choice e1 e2) tau st = case go e1 tau st of - Just r -> Just r - Nothing -> go e2 tau st + comp (Pure x) = \_ st -> (# | (# x, st #) #) - go (Star e) tau st = Just (starLoop (go e tau) st) + comp (Term c) = satStep (c ==) - go (Not e) tau st = case go e tau st of - Just _ -> Nothing - Nothing -> Just ((), st) + comp (Sat cs) = satStep (\c -> memberCS c cs) - go (Map f e) tau st = do - (x, st') <- go e tau st - pure (f x, st') + comp AnyChar = satStep (const True) - go (Indent rho e) tau st = do - (x, st') <- go e tau st { stCands = preimage rd (stCands st) } - pure ( x - , st' { stCands = interI (stCands st) (image rd (stCands st')) } ) + comp (Str lit) = litStep lit + + -- A run of a character class, returned as a chunk of the stream. On + -- 'Data.Text.Text' this is a slice: no copy, no cons cells. + comp (Span cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) False + comp (Span1 cs) = spanChunk (\c -> memberCS c cs) (simpleCS cs) True + + -- 'ty' and 'a' come from the constructor's own equality + -- @Lookup n env ~ 'EnvEntry ty a@, so no type family has to be reduced + -- here at all. + comp (NT @n _) = clookup (member @n @env) table + + -- Neither this nor 'Map' below allocates: the intermediate results travel + -- in registers, so a quasi-quoted rule of @n@ items costs @n@ calls and + -- nothing else. + comp (Seq ef ex) = + let pf = comp ef + px = comp ex + in \tau st -> case pf tau st of + (# (# #) | #) -> (# (# #) | #) + (# | (# f, s1 #) #) -> case px tau s1 of + (# (# #) | #) -> (# (# #) | #) + (# | (# x, s2 #) #) -> (# | (# f x, s2 #) #) + + comp (Choice e1 e2) = + let p = comp e1 + q = comp e2 + in \tau st -> case p tau st of + (# (# #) | #) -> q tau st + r -> r + + -- A hand-written @'Star' ('Sat' cs)@ still produces a @['Char']@ rather + -- than a chunk, so it needs its own scanner. The quasi-quoter emits + -- 'Span' instead, but 'PExp' values built by hand can be either. + comp (Star (Sat cs)) = spanList (\c -> memberCS c cs) (simpleCS cs) + comp (Star (Term c)) = spanList (c ==) (c /= '\n' && c /= '\t') + comp (Star AnyChar) = spanList (const True) False + + comp (Star e) = + let p = comp e + go acc tau st = case p tau st of + (# (# #) | #) -> (# | (# reverse acc, st #) #) + (# | (# x, st' #) #) -> go (x : acc) tau st' + in go [] + + -- A negative lookahead at a single character only needs to peek. + comp (Not (Sat cs)) = notCharStep (\c -> memberCS c cs) + comp (Not (Term c)) = notCharStep (c ==) + comp (Not AnyChar) = notCharStep (const True) + -- @!e+@ succeeds exactly when the next character is not in the class, so + -- it is the same peek. Without this case the generic 'Not' below would + -- run the whole scan to answer a one-character question. + comp (Not (Span1 cs)) = notCharStep (\c -> memberCS c cs) + -- @!e*@ can never succeed: the star always matches, if only the empty + -- run. Say so directly rather than scanning the input to find out. + comp (Not (Span _)) = \_ _ -> (# (# #) | #) + + comp (Not e) = + let p = comp e + in \tau st -> case p tau st of + (# (# #) | #) -> (# | (# (), st #) #) + _ -> (# (# #) | #) + + comp (Map f e) = + let p = comp e + in \tau st -> case p tau st of + (# (# #) | #) -> (# (# #) | #) + (# | (# x, s1 #) #) -> (# | (# f x, s1 #) #) + + comp (Indent rho e) = + let p = comp e + !rd = relD rho + in \tau st -> + case p tau st { stCands = preimage rd (stCands st) } of + (# (# #) | #) -> (# (# #) | #) + (# | (# x, s1 #) #) -> + (# | (# x + , s1 { stCands = interI (stCands st) + (image rd (stCands s1)) } #) #) + + comp (Position sigma e) = + let p = comp e + !rd = relD sigma + in \_ st -> p rd st + + comp (Align e) = + let p = comp e + in \tau st -> case p tau st { stAlign = True } of + (# (# #) | #) -> (# (# #) | #) + (# | (# x, s1 #) #) -> + (# | (# x, s1 { stAlign = stAlign st && stAlign s1 } #) #) + + ------------------------------------------------------------------------ + -- Terminals. These live here rather than at the top level so that they + -- close over the hoisted stream operations above. + ------------------------------------------------------------------------ + + -- | Match one character satisfying a predicate. The predicate is tested + -- /before/ any column bookkeeping, so a failing alternative costs one + -- comparison and nothing else. + satStep :: (Char -> Bool) -> Step s Char + satStep p = \tau st -> case uncons (stInput st) of + (# | (# x, xs #) #) | p x -> advance tw tau st x xs + _ -> (# (# #) | #) + + -- | Match a literal string. On the fast path the whole literal is + -- matched with a single loop and a single new 'PState'; otherwise it goes + -- character by character so that column bookkeeping stays exactly as it + -- would be for the equivalent chain of 'Term's. + -- + -- The result is the literal itself, so no chunk is built. + litStep :: String -> Step s String + litStep lit = \tau st -> + if plainly tau st + then fast (stInput st) lit (stCol st) (stOff st) (stCands st) + else slow lit tau st where - rd = relD rho + fast rest [] !col !off cands = + (# | (# lit, PState rest col off cands False #) #) + fast rest (c : cs) !col !off cands = case uncons rest of + (# | (# x, xs #) #) + | x == c -> fast xs cs (nextCol tw col x) (off + 1) cands + _ -> (# (# #) | #) - go (Position sigma e) _ st = go e (relD sigma) st + slow [] _ st = (# | (# lit, st #) #) + slow (c : cs) tau st = case uncons (stInput st) of + (# | (# x, xs #) #) + | x == c -> case advance tw tau st x xs of + (# (# #) | #) -> (# (# #) | #) + (# | (# _, st' #) #) -> slow cs tau st' + _ -> (# (# #) | #) - go (Align e) tau st = do - (x, st') <- go e tau st { stAlign = True } - pure (x, st' { stAlign = stAlign st && stAlign st' }) + -- | A run of a character class, returned as a chunk. + -- + -- On the fast path this is one native @span@ — a slice for 'Text' and + -- 'ByteString' — plus, when the class can contain a newline or a tab, one + -- fold to find the resulting column. + spanChunk :: (Char -> Bool) -> Bool -> Bool -> Step s s + spanChunk p simple atLeastOne = go + where + go tau st + | plainly tau st = case uncons (stInput st) of + -- Peek before spanning. A class that cannot match the very + -- next character is the common case in an ordered choice, and + -- calling 'spanS' just to be handed an empty prefix would + -- allocate a pair on every failed alternative. + (# | (# c, _ #) #) | p c -> chunk tau st + _ | atLeastOne -> (# (# #) | #) + | otherwise -> (# | (# emptyS, st #) #) + | otherwise = loop [] tau st -terminal :: RelD -> PState -> Maybe (Char, PState) -terminal tau (PState input cands aligned) = case input of - [] -> Nothing - ((x, i) : xs) - | aligned -> - if memberI i cands - then Just (x, PState xs (singletonI i) False) - else Nothing - | otherwise -> - if memberI i (preimage tau cands) - then Just (x, PState xs (interI cands (image tau (singletonI i))) False) - else Nothing + chunk _ st = case spanS' p (stInput st) of + (pre, rest) -> + let !n = lenS' pre + !col' = if simple then stCol st + n + else foldS' (nextCol tw) (stCol st) pre + in (# | (# pre + , PState rest col' (stOff st + n) + (stCands st) False #) #) -starLoop :: (PState -> Maybe (a, PState)) -> PState -> ([a], PState) -starLoop step = loop + -- The layout-sensitive path: every character has to go through the + -- interval arithmetic, so the chunk is rebuilt from the characters. + loop acc tau st = case satStep p tau st of + (# | (# x, st' #) #) -> loop (x : acc) tau st' + (# (# #) | #) + | atLeastOne && null acc -> (# (# #) | #) + | otherwise -> (# | (# packS (reverse acc), st #) #) + + -- | A run of a character class, returned as a @['Char']@. Only reachable + -- from a hand-written @'Star' ('Sat' _)@; the quasi-quoter emits 'Span'. + spanList :: (Char -> Bool) -> Bool -> Step s String + spanList p simple = go + where + go tau st + | plainly tau st = case uncons (stInput st) of + (# | (# c, _ #) #) | p c -> case spanS' p (stInput st) of + (pre, rest) -> + let !n = lenS' pre + !col' = if simple then stCol st + n + else foldS' (nextCol tw) (stCol st) pre + in (# | (# toStr pre + , PState rest col' (stOff st + n) + (stCands st) False #) #) + _ -> (# | (# [], st #) #) + | otherwise = loop [] tau st + + loop acc tau st = case satStep p tau st of + (# | (# x, st' #) #) -> loop (x : acc) tau st' + (# (# #) | #) -> (# | (# reverse acc, st #) #) + + -- | Negative lookahead at a single character: a peek, with no state built. + notCharStep :: (Char -> Bool) -> Step s () + notCharStep p = go + where + go tau st + | plainly tau st = case uncons (stInput st) of + (# | (# x, _ #) #) | p x -> (# (# #) | #) + _ -> (# | (# (), st #) #) + | otherwise = case satStep p tau st of + (# (# #) | #) -> (# | (# (), st #) #) + _ -> (# (# #) | #) + +-------------------------------------------------------------------------------- +-- Column bookkeeping +-------------------------------------------------------------------------------- + +-- | Consume the head character, updating column, offset and the candidate +-- interval. +-- +-- When the ambient relation is total ('rdTotal', i.e. 'anyR') and no +-- alignment is pending, the candidate interval is provably unchanged, so the +-- whole interval computation is skipped. Grammars that do not use layout +-- take this branch for every single character. +advance :: Int -> RelD -> PState s -> Char -> s -> Res s Char +advance tw tau (PState _ col off cands aligned) x xs + | aligned = + if memberI col cands + then (# | (# x, PState xs col' off' (singletonI col) False #) #) + else (# (# #) | #) + | rdTotal tau = + if nullI cands + then (# (# #) | #) + else (# | (# x, PState xs col' off' cands False #) #) + | memberI col (preimage tau cands) = + (# | (# x, PState xs col' off' + (interI cands (image tau (singletonI col))) False #) #) + | otherwise = (# (# #) | #) where - loop st = case step st of - Nothing -> ([], st) - Just (x, st') -> let (xs, rest) = loop st' in (x : xs, rest) + !col' = nextCol tw col x + !off' = off + 1 +{-# INLINE advance #-} -ruleFor :: Member s defs ty a -> Rules env defs -> PExp env ty a -ruleFor Here (RCons _ body _) = body -ruleFor (There m) (RCons _ _ rest) = ruleFor m rest +-- | Does the cheap path apply? It does when the ambient relation constrains +-- nothing, no alignment is pending, and the candidate interval is inhabited: +-- under those conditions 'advance' provably leaves the interval alone, so a +-- run of characters can be consumed without touching it once. +plainly :: RelD -> PState s -> Bool +plainly tau st = rdTotal tau && not (stAlign st) && not (nullI (stCands st)) +{-# INLINE plainly #-} diff --git a/src/PEG/QQ.hs b/src/PEG/QQ.hs --- a/src/PEG/QQ.hs +++ b/src/PEG/QQ.hs @@ -15,8 +15,13 @@ -- a Haskell action in braces: @{ haskellExpr }@. -- Ordered choice is written with @\/@; Kleene star with @*@; plus with @+@; -- optional with @?@; negation with @!@. --- Character classes use @[...]@ syntax. -- +-- Character classes use @[...]@ syntax and may contain ranges: @[a-zA-Z0-9_]@. +-- A leading @^@ negates the class, so @[^\"]@ matches any character other than +-- a double quote; write @[\\^]@ for a class containing a caret. Prefer a +-- negated class over the @(!c .)@ idiom: the class is one bit test, whereas +-- the lookahead scans every character twice. +-- -- The 'pegExpr' quasi-quoter produces a single 'PEG.Syntax.PExp' value, -- while 'pegRules' produces a complete set of named rules (a -- 'PEG.Grammar.Rules' value) to be passed to 'PEG.Grammar.Grammar'. @@ -50,7 +55,7 @@ | EPlus PExpr | EChar Char | EString String - | EClass [(Char,Char)] + | EClass Bool [(Char,Char)] -- ^ 'True' when the class is negated. | EDot | ENT String | EIndent RelS PExpr @@ -127,16 +132,26 @@ '[' -> Right ('[', xs) ']' -> Right (']', xs) '0' -> Right ('\0', xs) + '^' -> Right ('^', xs) _ -> errorAt ("unknown escape \\" ++ [e]) xs escChar stopC (c:xs) | c == stopC = errorAt "unexpected close quote" (c:xs) | otherwise = Right (c, xs) escChar _ [] = Left "unexpected end of input in literal" -classLit :: P [(Char, Char)] +-- | A character class. A leading @^@ negates it, as in POSIX; write +-- @[\\^]@ for a class containing the caret itself. +classLit :: P (Bool, [(Char, Char)]) classLit s0 = case spaces s0 of - ('[':xs) -> loop xs - s -> errorAt "expected character class" s + ('[':'^':xs) -> do + (rs, r) <- loop xs + if null rs + then errorAt "empty negated character class" s0 + else Right ((True, rs), r) + ('[':xs) -> do + (rs, r) <- loop xs + Right ((False, rs), r) + s -> errorAt "expected character class" s where loop (']':r) = Right ([], r) loop [] = Left "unterminated character class" @@ -302,7 +317,7 @@ Left _ -> case strLit s of Right (cs, s1) -> Right (EString cs, s1) Left _ -> case classLit s of - Right (rs, s1) -> Right (EClass rs, s1) + Right ((neg, rs), s1) -> Right (EClass neg rs, s1) Left _ -> case ident s of Right (name, s1) -> case tok "<-" s1 of @@ -344,9 +359,13 @@ translateExpr (EString s) | null s = [| pureP "" |] | otherwise = [| stringNE s |] -translateExpr (EClass rs) = - let allChars = concat [ [lo..hi] | (lo, hi) <- rs ] - in [| oneOf allChars |] +translateExpr (EClass neg rs) + -- A character class becomes a single 'Sat' node holding a compact + -- 'PEG.CharSet.CharSet'. Expanding it into a chain of ordered choices, as + -- an earlier version did, made matching one character of @[a-zA-Z0-9_]@ + -- cost 63 parser steps. + | neg = [| notCharClass rs |] + | otherwise = [| charClass rs |] translateExpr (EAnd e) = do e' <- translateExpr e [| Not (Not $(pure e')) |] @@ -356,6 +375,21 @@ translateExpr (EOpt e) = do e' <- translateExpr e [| opt $(pure e') |] +-- A repetition of a single character -- @[a-z]*@, @','+@, @.*@ -- compiles to +-- one 'PEG.Syntax.Span' node and produces a /chunk of the input stream/: a +-- 'Data.Text.Text' slice rather than a @['Char']@. Only a bare class, literal +-- or dot qualifies; a wrapper such as @[a-z]^>*@ changes the meaning of each +-- iteration, so those keep the generic 'Star'. +translateExpr (EStar (EClass neg rs)) + | neg = [| spanOf (notInRanges rs) |] + | otherwise = [| spanOf (fromRanges rs) |] +translateExpr (EStar (EChar c)) = [| spanOf (singletonCS c) |] +translateExpr (EStar EDot) = [| spanOf anyCS |] +translateExpr (EPlus (EClass neg rs)) + | neg = [| spanOf1 (notInRanges rs) |] + | otherwise = [| spanOf1 (fromRanges rs) |] +translateExpr (EPlus (EChar c)) = [| spanOf1 (singletonCS c) |] +translateExpr (EPlus EDot) = [| spanOf1 anyCS |] translateExpr (EStar e) = do e' <- translateExpr e [| Star $(pure e') |] diff --git a/src/PEG/Semantics/Simple.hs b/src/PEG/Semantics/Simple.hs --- a/src/PEG/Semantics/Simple.hs +++ b/src/PEG/Semantics/Simple.hs @@ -73,17 +73,19 @@ p q = try p <|> q -class Stream d where +-- | Unrelated to "PEG.Stream": this is the reference semantics' own +-- token-polymorphic input class, used only inside this module. +class SimpleStream d where type Elem d anyChar :: PExp d (Elem d) -instance Stream [a] where +instance SimpleStream [a] where type Elem [a] = a anyChar = PExp $ \s -> case s of (x:xs) -> Commit xs x [] -> Fail "EOF" False -satisfy :: Stream d => (Elem d -> Bool) -> PExp d (Elem d) +satisfy :: SimpleStream d => (Elem d -> Bool) -> PExp d (Elem d) satisfy p = try $ do x <- anyChar x <$ guard (p x) @@ -101,10 +103,10 @@ Fail{} -> Pure () _ -> Fail "unexpected" False -eof :: Stream d => PExp d () +eof :: SimpleStream d => PExp d () eof = not anyChar -char :: Eq (Elem d) => Stream d => Elem d -> PExp d (Elem d) +char :: Eq (Elem d) => SimpleStream d => Elem d -> PExp d (Elem d) char c = satisfy (c ==) lexeme :: PExp String a -> PExp String a diff --git a/src/PEG/Stream.hs b/src/PEG/Stream.hs new file mode 100644 --- /dev/null +++ b/src/PEG/Stream.hs @@ -0,0 +1,263 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedSums #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | Input streams the parser can consume. +-- +-- A 'Stream' is anything the parser can read one 'Char' at a time and slice +-- chunks out of. Instances are provided for 'String', strict and lazy +-- 'Data.Text.Text', and strict and lazy 'Data.ByteString.ByteString'. +-- +-- == ByteString is Latin-1 +-- +-- The 'ByteString' instances read each byte as the 'Char' with that code +-- point, exactly as "Data.ByteString.Char8" does. This is what makes them +-- fast — every character lands in the Latin-1 range that +-- "PEG.CharSet" answers with a single bit test — and it is correct for +-- grammars over ASCII or Latin-1 text. It is /wrong/ for UTF-8: a +-- multi-byte character arrives as its individual bytes, and columns and +-- offsets count bytes rather than characters. Decode to 'Data.Text.Text' +-- first if that matters. +-- +-- Two laws follow, and only the 'ByteString' instances need the caveat: +-- +-- * @'chunkToString' . 'packString' == 'id'@, for arguments in the range the +-- stream can represent (all of 'Char' except for 'ByteString', where it is +-- @\'\\0\'@ .. @\'\\255\'@). +-- * A 'PEG.CharSet.CharSet' containing only characters above @\'\\255\'@ +-- never matches a 'ByteString', with no diagnostic. +-- +-- == Writing an instance +-- +-- Only 'unconsS' has no default. Everything else is derived from it, so a +-- minimal instance is one method — but a type with native slicing should +-- override 'spanS', 'takeS', 'lengthS' and 'foldlS'' , which is where the +-- performance of 'Text' and 'ByteString' comes from. +module PEG.Stream + ( Stream (..) + ) where + +import Data.Char (chr, ord) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- | A sequence of characters the parser can consume. +-- +-- The chunk type is the stream type itself: slicing a 'Data.Text.Text' +-- yields a 'Data.Text.Text', so a character class such as @[a-z]+@ produces +-- a real slice rather than unpacking into a @['Char']@. +class Stream s where + -- | Split off the first character. + -- + -- This returns an unboxed sum rather than @'Maybe' ('Char', s)@ on + -- purpose. It is called once per character of input, and the boxed + -- version would allocate a @Just@ and a pair every time — behind a class + -- dictionary GHC cannot cancel them, so the parser's zero-allocation + -- terminal path would be lost. + unconsS :: s -> (# (# #) | (# Char, s #) #) + + -- | @'spanS' p s@ splits @s@ into the longest prefix all of whose + -- characters satisfy @p@, and the rest. + spanS :: (Char -> Bool) -> s -> (s, s) + + -- | Strict left fold over the characters. Used to advance the column + -- across a chunk that has already been matched in bulk. + foldlS' :: (b -> Char -> b) -> b -> s -> b + + -- | Prepend a character. @O(1)@ for 'String' and the lazy types; the + -- strict types must copy. + consS :: Char -> s -> s + + -- | @'takeS' n s@ is the first @n@ characters of @s@. + takeS :: Int -> s -> s + + -- | Number of characters. + lengthS :: s -> Int + + -- | Is the stream empty? + nullS :: s -> Bool + + -- | Convert a chunk to a 'String'. Semantic actions need this whenever a + -- character class feeds something that expects a 'String', such as 'read'. + chunkToString :: s -> String + + -- | Build a chunk from a 'String'. + packString :: String -> s + + -- Defaults, all in terms of 'unconsS'. + + spanS p s0 = go id s0 + where + go acc s = case unconsS s of + (# | (# c, s' #) #) | p c -> go (acc . (c :)) s' + _ -> (packString (acc []), s) + + foldlS' f = go + where + go !acc s = case unconsS s of + (# | (# c, s' #) #) -> go (f acc c) s' + _ -> acc + + consS c s = packString (c : chunkToString s) + + takeS n0 s0 = packString (go n0 s0) + where + go n s + | n <= 0 = [] + | otherwise = case unconsS s of + (# | (# c, s' #) #) -> c : go (n - 1) s' + _ -> [] + + lengthS = foldlS' (\ !n _ -> n + 1) 0 + + nullS s = case unconsS s of + (# (# #) | #) -> True + _ -> False + + chunkToString s = case unconsS s of + (# | (# c, s' #) #) -> c : chunkToString s' + _ -> [] + + {-# MINIMAL unconsS, packString #-} + +-------------------------------------------------------------------------------- +-- String +-------------------------------------------------------------------------------- + +instance Stream [Char] where + unconsS (c : cs) = (# | (# c, cs #) #) + unconsS [] = (# (# #) | #) + {-# INLINE unconsS #-} + + -- NOT 'Data.List.span': that one is lazy in its pair, so it allocates a + -- tuple and two selector thunks for every character it accepts. Finding + -- the split point first and slicing costs one tuple in total. + spanS p s0 = go (0 :: Int) s0 + where + go !n s = case s of + (c : cs) | p c -> go (n + 1) cs + _ -> (take n s0, s) + foldlS' f = go + where + go !acc (c : cs) = go (f acc c) cs + go !acc [] = acc + consS = (:) + takeS = take + lengthS = length + nullS = null + chunkToString = id + packString = id + {-# INLINE spanS #-} + {-# INLINE foldlS' #-} + {-# INLINE consS #-} + {-# INLINE takeS #-} + {-# INLINE lengthS #-} + {-# INLINE nullS #-} + {-# INLINE chunkToString #-} + {-# INLINE packString #-} + +-------------------------------------------------------------------------------- +-- Text +-------------------------------------------------------------------------------- + +instance Stream T.Text where + unconsS t = case T.uncons t of + Just (c, t') -> (# | (# c, t' #) #) + Nothing -> (# (# #) | #) + {-# INLINE unconsS #-} + + spanS = T.span + foldlS' = T.foldl' + consS = T.cons + takeS = T.take + lengthS = T.length + nullS = T.null + chunkToString = T.unpack + packString = T.pack + {-# INLINE spanS #-} + {-# INLINE foldlS' #-} + {-# INLINE takeS #-} + {-# INLINE lengthS #-} + {-# INLINE nullS #-} + +instance Stream TL.Text where + unconsS t = case TL.uncons t of + Just (c, t') -> (# | (# c, t' #) #) + Nothing -> (# (# #) | #) + {-# INLINE unconsS #-} + + spanS = TL.span + foldlS' = TL.foldl' + consS = TL.cons + takeS n = TL.take (fromIntegral n) + lengthS = fromIntegral . TL.length + nullS = TL.null + chunkToString = TL.unpack + packString = TL.pack + {-# INLINE spanS #-} + {-# INLINE foldlS' #-} + {-# INLINE nullS #-} + +-------------------------------------------------------------------------------- +-- ByteString (Latin-1) +-------------------------------------------------------------------------------- + +-- | Byte to character, Latin-1. +w2c :: Int -> Char +w2c = chr +{-# INLINE w2c #-} + +instance Stream B.ByteString where + unconsS b = case B.uncons b of + Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #) + Nothing -> (# (# #) | #) + {-# INLINE unconsS #-} + + spanS = BC.span + foldlS' = BC.foldl' + consS = BC.cons + takeS = B.take + lengthS = B.length + nullS = B.null + chunkToString = BC.unpack + -- 'BC.pack' truncates characters above '\255'; clamp explicitly so the + -- behaviour is the documented one rather than whatever pack happens to do. + packString = BC.pack . map clampLatin1 + {-# INLINE spanS #-} + {-# INLINE foldlS' #-} + {-# INLINE takeS #-} + {-# INLINE lengthS #-} + {-# INLINE nullS #-} + +instance Stream BL.ByteString where + unconsS b = case BL.uncons b of + Just (w, b') -> (# | (# w2c (fromIntegral w), b' #) #) + Nothing -> (# (# #) | #) + {-# INLINE unconsS #-} + + spanS = BLC.span + foldlS' = BLC.foldl' + consS = BLC.cons + takeS n = BL.take (fromIntegral n) + lengthS = fromIntegral . BL.length + nullS = BL.null + chunkToString = BLC.unpack + packString = BLC.pack . map clampLatin1 + {-# INLINE spanS #-} + {-# INLINE foldlS' #-} + {-# INLINE nullS #-} + +-- | Characters a 'ByteString' cannot represent become @\'\\255\'@ rather +-- than silently wrapping around modulo 256. +clampLatin1 :: Char -> Char +clampLatin1 c + | ord c > 255 = '\255' + | otherwise = c +{-# INLINE clampLatin1 #-} diff --git a/src/PEG/Syntax.hs b/src/PEG/Syntax.hs --- a/src/PEG/Syntax.hs +++ b/src/PEG/Syntax.hs @@ -11,18 +11,28 @@ -- | The PEG expression GADT and combinator API. -- --- 'PExp' is the core type: a GADT indexed by the grammar environment, --- the 'PEG.Type.Ty' of the expression (nullability + FIRST set), and the --- Haskell result type. Combinators like '<*>.' and '.||.' propagate type --- information at the kind level so that 'PEG.Grammar.Acyclic' can be checked --- without running the parser. +-- 'PExp' is the core type: a GADT indexed by the input stream, the grammar +-- environment, the 'PEG.Type.Ty' of the expression (nullability + FIRST set), +-- and the Haskell result type. Combinators like '<*>.' and '.||.' propagate +-- type information at the kind level so that 'PEG.Grammar.Acyclic' can be +-- checked without running the parser. -- +-- The first parameter, @s@, is the stream the expression consumes; see +-- "PEG.Stream". It appears in the type because a character class produces a +-- /chunk of that stream/ — matching @[a-z]+@ against a 'Data.Text.Text' +-- yields a 'Data.Text.Text' slice, not a @['Char']@. +-- -- Most users will not build 'PExp' values directly; instead they use the -- quasi-quoter in "PEG.QQ". module PEG.Syntax ( Name (..) , PExp (..) , nt + , sat + , charClass + , notCharClass + , spanOf + , spanOf1 , pureP , fmapP , indent @@ -39,20 +49,36 @@ , SeqTy , ChoiceTy , NTTy + , NTGo ) where import Data.Kind (Type) import GHC.TypeLits (Symbol, KnownSymbol) +import PEG.CharSet (CharSet) +import qualified PEG.CharSet as CS import PEG.Indent (Rel) import PEG.Type import PEG.TyLevel import PEG.Member --- | A singleton witness for a non-terminal name @s@. -data Name (s :: Symbol) = Name +-- | A singleton witness for a non-terminal name @n@. +data Name (n :: Symbol) = Name -- | The 'Ty' of a sequence @e1 e2@. +-- +-- Written as a projective type synonym rather than a type family so that it +-- reduces to a @'MkTy'@ head even when its operands are still abstract. That +-- is what lets a polymorphic combinator such as +-- +-- @ +-- lexeme :: PExp s env ty a -> PExp s env (SeqTy ty ('MkTy 'True '[])) a +-- @ +-- +-- compose without the caller having to get the nesting of 'SeqTy' exactly +-- right. The cost it used to carry — an exponential blow-up as the operands +-- get duplicated across the right-hand side — came from 'Union' and +-- 'ConsIfAbsent', not from here; see "PEG.TyLevel". type SeqTy t1 t2 = 'MkTy (And (Nullable t1) (Nullable t2)) (Union (First t1) (If (Nullable t1) (First t2) '[])) @@ -62,17 +88,30 @@ 'MkTy (Or (Nullable t1) (Nullable t2)) (Union (First t1) (First t2)) --- | The 'Ty' of a non-terminal reference @s@ looked up in @env@. -type NTTy s env = - 'MkTy (Nullable (TyOf (Lookup s env))) - (ConsIfAbsent s (First (TyOf (Lookup s env)))) +-- | The 'Ty' of a non-terminal reference @n@ looked up in @env@. +type NTTy n env = NTGo n (TyOf (Lookup n env)) --- | A typed PEG expression. +-- | The 'Ty' of a reference to a non-terminal named @n@ whose own 'Ty' is +-- @t@. -- +-- 'NT' and 'nt' are stated in terms of this rather than 'NTTy' so that the +-- environment is searched /once/ per occurrence, by the constructor's +-- @Lookup n env ~ 'EnvEntry ty a@ equality. Naming @Lookup n env@ twice, as +-- an expansion of 'NTTy' does, doubles the cost of what profiling shows to be +-- the dominant term in checking a large grammar. +type family NTGo (n :: Symbol) (t :: Ty) :: Ty where + NTGo n ('MkTy nu f) = 'MkTy nu (ConsIfAbsent n f) + +-- | A typed PEG expression over the stream @s@. +-- -- Constructors correspond to the standard PEG operators: -- -- * 'Pure' — succeed without consuming input, return a value -- * 'Term' — match a specific character +-- * 'Sat' — match any character of a 'CharSet' (a character class) +-- * 'Str' — match a non-empty string literal +-- * 'Span' — match a run of characters of a 'CharSet', possibly empty +-- * 'Span1' — match a non-empty run of characters of a 'CharSet' -- * 'AnyChar'— match any character -- * 'NT' — invoke a named non-terminal -- * 'Seq' — sequential composition (@e1 e2@) @@ -83,111 +122,165 @@ -- * 'Indent' — require the next token to satisfy an indentation relation -- * 'Position'— set the column relation for tokens inside the sub-expression -- * 'Align' — require the next token to be aligned with the current position -data PExp (env :: Env) (ty :: Ty) (a :: Type) where - Pure :: a -> PExp env ('MkTy 'True '[]) a - Term :: Char -> PExp env ('MkTy 'False '[]) Char - AnyChar :: PExp env ('MkTy 'False '[]) Char - NT :: ( KnownSymbol s - , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env)) +data PExp (s :: Type) (env :: Env) (ty :: Ty) (a :: Type) where + Pure :: a -> PExp s env ('MkTy 'True '[]) a + Term :: Char -> PExp s env ('MkTy 'False '[]) Char + -- | Match one character of a class. This is what a character class such as + -- @[a-zA-Z0-9_]@ compiles to: a single bit test instead of a chain of + -- ordered choices. + Sat :: !CharSet -> PExp s env ('MkTy 'False '[]) Char + -- | Match a string literal. The string must be non-empty (the 'Ty' index + -- claims the expression is not nullable); use 'pureP' @""@ otherwise. + -- + -- The result is the literal itself, so it is shared rather than sliced out + -- of the input. + Str :: String -> PExp s env ('MkTy 'False '[]) String + -- | Match the longest run of characters belonging to a class, possibly + -- empty — what @[a-z]*@ compiles to. The result is a chunk of the input + -- stream, so on 'Data.Text.Text' this is a slice and costs no copy. + Span :: !CharSet -> PExp s env ('MkTy 'True '[]) s + -- | As 'Span', but the run must be non-empty: @[a-z]+@. + Span1 :: !CharSet -> PExp s env ('MkTy 'False '[]) s + AnyChar :: PExp s env ('MkTy 'False '[]) Char + -- The environment is looked up /once/, by the equality below, and the + -- result is bound to the rigid variables @ty@ and @a@. Passing + -- @TyOf (Lookup n env)@ straight to 'KnownMember' instead makes GHC + -- re-reduce the lookup at every step of the instance chain that walks + -- @env@, which costs @O(|env|^2)@ per non-terminal occurrence. + NT :: forall n ty s env a. + ( KnownSymbol n + , Lookup n env ~ 'EnvEntry ty a + , KnownMember n env a ) - => Name s - -> PExp env (NTTy s env) (ResOf (Lookup s env)) - Seq :: PExp env t1 (a -> b) - -> PExp env t2 a - -> PExp env (SeqTy t1 t2) b - Choice :: PExp env t1 a - -> PExp env t2 a - -> PExp env (ChoiceTy t1 t2) a - Star :: PExp env ('MkTy 'False f) a - -> PExp env ('MkTy 'True f) [a] - Not :: PExp env ('MkTy n f) a - -> PExp env ('MkTy 'True f) () + => Name n + -> PExp s env (NTGo n ty) a + Seq :: PExp s env t1 (a -> b) + -> PExp s env t2 a + -> PExp s env (SeqTy t1 t2) b + Choice :: PExp s env t1 a + -> PExp s env t2 a + -> PExp s env (ChoiceTy t1 t2) a + Star :: PExp s env ('MkTy 'False f) a + -> PExp s env ('MkTy 'True f) [a] + Not :: PExp s env ('MkTy n f) a + -> PExp s env ('MkTy 'True f) () Map :: (a -> b) - -> PExp env ty a - -> PExp env ty b + -> PExp s env ty a + -> PExp s env ty b Indent :: Rel n - -> PExp env ty a - -> PExp env ty a + -> PExp s env ty a + -> PExp s env ty a Position :: Rel n - -> PExp env ty a - -> PExp env ty a - Align :: PExp env ty a - -> PExp env ty a + -> PExp s env ty a + -> PExp s env ty a + Align :: PExp s env ty a + -> PExp s env ty a -instance Functor (PExp env ty) where +instance Functor (PExp s env ty) where fmap = Map -- | Reference a non-terminal by name using a type application: -- @nt \@\"ruleName\"@. -nt :: forall s env. - ( KnownSymbol s - , KnownMember s env (TyOf (Lookup s env)) (ResOf (Lookup s env)) +-- +-- The name is deliberately the /first/ quantified variable, so that +-- @nt \@\"expr\"@ keeps working: the stream and environment are recovered by +-- unification. +nt :: forall n env s ty a. + ( KnownSymbol n + , Lookup n env ~ 'EnvEntry ty a + , KnownMember n env a ) - => PExp env (NTTy s env) (ResOf (Lookup s env)) -nt = NT (Name :: Name s) + => PExp s env (NTGo n ty) a +nt = NT (Name :: Name n) -- | Succeed without consuming any input. -pureP :: a -> PExp env ('MkTy 'True '[]) a +pureP :: a -> PExp s env ('MkTy 'True '[]) a pureP = Pure -- | Apply a function to the result of an expression. -fmapP :: (a -> b) -> PExp env ty a -> PExp env ty b +fmapP :: (a -> b) -> PExp s env ty a -> PExp s env ty b fmapP = Map -- | Require the sub-expression to satisfy the given column relation. -indent :: Rel n -> PExp env ty a -> PExp env ty a +indent :: Rel n -> PExp s env ty a -> PExp s env ty a indent = Indent -- | Override the token mode for the sub-expression. -position :: Rel n -> PExp env ty a -> PExp env ty a +position :: Rel n -> PExp s env ty a -> PExp s env ty a position = Position -- | Require the sub-expression to start at the current alignment column. -align :: PExp env ty a -> PExp env ty a +align :: PExp s env ty a -> PExp s env ty a align = Align -- | Infix synonym for 'fmapP'. -(<$>.) :: (a -> b) -> PExp env ty a -> PExp env ty b +(<$>.) :: (a -> b) -> PExp s env ty a -> PExp s env ty b (<$>.) = Map infixl 4 <$>. -- | Infix sequential composition. -(<*>.) :: PExp env t1 (a -> b) - -> PExp env t2 a - -> PExp env (SeqTy t1 t2) b +(<*>.) :: PExp s env t1 (a -> b) + -> PExp s env t2 a + -> PExp s env (SeqTy t1 t2) b (<*>.) = Seq infixl 4 <*>. -- | Sequence two expressions, discarding the result of the first. -(.>>.) :: PExp env t1 a - -> PExp env t2 b - -> PExp env (SeqTy t1 t2) b +(.>>.) :: PExp s env t1 a + -> PExp s env t2 b + -> PExp s env (SeqTy t1 t2) b e1 .>>. e2 = Map (\_ b -> b) e1 <*>. e2 infixl 6 .>>. -- | Infix ordered choice (@e1 \/ e2@): try @e1@; if it fails, try @e2@. -(.||.) :: PExp env t1 a -> PExp env t2 a -> PExp env (ChoiceTy t1 t2) a +(.||.) :: PExp s env t1 a -> PExp s env t2 a -> PExp s env (ChoiceTy t1 t2) a (.||.) = Choice infixl 5 .||. -- | Optional match: @opt e = (Just \<$\>. e) .||. pureP Nothing@. -opt :: PExp env t a - -> PExp env (ChoiceTy t ('MkTy 'True '[])) (Maybe a) +opt :: PExp s env t a + -> PExp s env (ChoiceTy t ('MkTy 'True '[])) (Maybe a) opt e = (Just <$>. e) .||. pureP Nothing -- | One-or-more: @plus e = (:) \<$\>. e \<*\>. Star e@. -plus :: PExp env ('MkTy 'False f) a - -> PExp env (SeqTy ('MkTy 'False f) ('MkTy 'True f)) [a] +-- +-- For a single character class, prefer 'spanOf1': it matches the whole run in +-- one scan and returns a chunk of the stream instead of a list. +plus :: PExp s env ('MkTy 'False f) a + -> PExp s env (SeqTy ('MkTy 'False f) ('MkTy 'True f)) [a] plus e = (:) <$>. e <*>. Star e +-- | Match any character of the given set. +sat :: CharSet -> PExp s env ('MkTy 'False '[]) Char +sat = Sat + +-- | Match any character inside one of the given inclusive ranges. +-- This is the representation the quasi-quoter emits for @[a-z0-9]@ and +-- friends. +charClass :: [(Char, Char)] -> PExp s env ('MkTy 'False '[]) Char +charClass = Sat . CS.fromRanges + +-- | Match any character /outside/ the given inclusive ranges. +-- The quasi-quoter emits this for @[^\"]@. +notCharClass :: [(Char, Char)] -> PExp s env ('MkTy 'False '[]) Char +notCharClass = Sat . CS.notInRanges + +-- | Match the longest run of characters of the set, possibly empty. The +-- result is a chunk of the input stream. +spanOf :: CharSet -> PExp s env ('MkTy 'True '[]) s +spanOf = Span + +-- | Match a non-empty run of characters of the set. +spanOf1 :: CharSet -> PExp s env ('MkTy 'False '[]) s +spanOf1 = Span1 + -- | Match any character in the given list. The list must be non-empty. -oneOf :: [Char] -> PExp env ('MkTy 'False '[]) Char -oneOf [] = error "PEG.Syntax.oneOf: empty character class" -oneOf [c] = Term c -oneOf (c:cs) = Term c .||. oneOf cs +oneOf :: [Char] -> PExp s env ('MkTy 'False '[]) Char +oneOf [] = error "PEG.Syntax.oneOf: empty character class" +oneOf [c] = Term c +oneOf cs = Sat (CS.fromList cs) -- | Match an exact string literal. The string must be non-empty. -stringNE :: String -> PExp env ('MkTy 'False '[]) String -stringNE [] = error "PEG.Syntax.stringNE: empty string" -stringNE [c] = (\x -> [x]) <$>. Term c -stringNE (c:cs) = (:) <$>. Term c <*>. stringNE cs +stringNE :: String -> PExp s env ('MkTy 'False '[]) String +stringNE [] = error "PEG.Syntax.stringNE: empty string" +stringNE s = Str s diff --git a/src/PEG/TyLevel.hs b/src/PEG/TyLevel.hs --- a/src/PEG/TyLevel.hs +++ b/src/PEG/TyLevel.hs @@ -10,6 +10,30 @@ -- These type families are used internally to compute the FIRST sets and -- nullability of PEG expressions at the kind level, enabling the -- 'PEG.Grammar.Acyclic' constraint to be resolved at compile time. +-- +-- == Representation of FIRST sets +-- +-- A FIRST set is a @['Symbol']@ kept /strictly sorted/ by 'CmpSymbol'. +-- Sortedness is the whole point: it makes the representation canonical (one +-- set, one type), so 'Union' is a single-pass merge and 'Elem' can stop at +-- the first symbol greater than the one it is looking for. +-- +-- == Why the families are written this way +-- +-- Every clause below mentions each of its arguments — and in particular each +-- recursive call — /exactly once/ on the right-hand side. This is not a +-- style choice. A clause such as +-- +-- @ +-- ConsIfAbsent x xs = If (Elem x xs) xs (x ': xs) -- DON'T +-- @ +-- +-- mentions @xs@ three times, and @xs@ is normally an unreduced application +-- of 'Union'. GHC therefore has three copies of the pending computation to +-- reduce, each of which triples again one level down: a union of two sets of +-- size @n@ costs @3^n@ reductions rather than @n@. Dispatching on an +-- already-computed 'Ordering' in a separate family keeps every right-hand +-- side linear in its arguments. module PEG.TyLevel ( If , And @@ -45,30 +69,83 @@ IsEQ 'EQ = 'True IsEQ _ = 'False +-- | Is @x@ a member of the sorted set @xs@? +-- +-- Stops as soon as it reaches a symbol greater than @x@, so a miss costs +-- half a scan on average rather than a full one. type family Elem (x :: Symbol) (xs :: [Symbol]) :: Bool where Elem _ '[] = 'False - Elem x (y ': ys) = Or (SymEq x y) (Elem x ys) + Elem x (y ': ys) = ElemGo (CmpSymbol x y) x ys +type family ElemGo (o :: Ordering) (x :: Symbol) (ys :: [Symbol]) :: Bool where + ElemGo 'EQ _ _ = 'True + ElemGo 'LT _ _ = 'False + ElemGo 'GT x ys = Elem x ys + +-- | Insert @x@ into the sorted set @xs@, keeping it sorted and duplicate-free. type family ConsIfAbsent (x :: Symbol) (xs :: [Symbol]) :: [Symbol] where - ConsIfAbsent x xs = If (Elem x xs) xs (x ': xs) + ConsIfAbsent x '[] = '[x] + ConsIfAbsent x (y ': ys) = InsGo (CmpSymbol x y) x y ys +type family InsGo (o :: Ordering) (x :: Symbol) (y :: Symbol) + (ys :: [Symbol]) :: [Symbol] where + InsGo 'LT x y ys = x ': y ': ys + InsGo 'EQ _ y ys = y ': ys + InsGo 'GT x y ys = y ': ConsIfAbsent x ys + +-- | Union of two sorted sets: a single merge pass, @O(|xs| + |ys|)@. +-- +-- The merge nests one type-family reduction per element of the result, so a +-- FIRST set of more than about a hundred non-terminals runs into GHC's +-- default reduction limit and reports @Reduction stack overflow@. That is a +-- limit, not a slowdown: @-freduction-depth=0@ lifts it, and a union of two +-- 128-element sets then takes about 0.3 s. type family Union (xs :: [Symbol]) (ys :: [Symbol]) :: [Symbol] where - Union '[] ys = ys - Union (x ': xs) ys = ConsIfAbsent x (Union xs ys) + Union '[] ys = ys + Union (x ': xs) '[] = x ': xs + Union (x ': xs) (y ': ys) = MergeGo (CmpSymbol x y) x xs y ys +type family MergeGo (o :: Ordering) (x :: Symbol) (xs :: [Symbol]) + (y :: Symbol) (ys :: [Symbol]) :: [Symbol] where + MergeGo 'LT x xs y ys = x ': Union xs (y ': ys) + MergeGo 'EQ x xs _ ys = x ': Union xs ys + MergeGo 'GT x xs y ys = y ': Union (x ': xs) ys + +-- | Look up a non-terminal's entry in the environment. +-- +-- This is the hot path: there is one lookup per occurrence of every +-- non-terminal in the grammar, so it is written to do as little as possible +-- per entry scanned. +-- +-- Two things matter. The search proper ('LookupMb') carries only the tail it +-- still has to scan — threading the /whole/ environment through it so the +-- not-found case could name the available non-terminals costs a traversal of +-- that environment at every step, and an environment of @n@ rules is itself +-- @O(n^2)@ type nodes because every rule carries a FIRST set. The +-- environment is therefore named once, in 'Found', which only reduces after +-- the search has finished. +-- +-- And the match is on a /non-linear/ pattern — @s@ appears twice in the +-- second clause — rather than on @CmpSymbol s t@ dispatched through a helper +-- family. GHC decides the clause by syntactic equality and by apartness for +-- the fall-through, which is one type-family reduction per entry instead of +-- two. (The trick is @Data.Type.Map@'s, from @type-level-sets@.) It costs +-- nothing here: unlike 'Elem', this search has no sortedness to exploit, so +-- there was never a third case to short-circuit on. type family Lookup (s :: Symbol) (env :: Env) :: EnvEntry where - Lookup s env = LookupGo s env env + Lookup s env = Found s env (LookupMb s env) -type family LookupGo (s :: Symbol) (env :: Env) (full :: Env) :: EnvEntry where - LookupGo s '[] full = - TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s - ':$$: 'Text "Available non-terminals: " ':<>: 'ShowType (Names full)) - LookupGo s ('(t, e) ': rest) full = LookupStep (SymEq s t) s e rest full +type family LookupMb (s :: Symbol) (env :: Env) :: Maybe EnvEntry where + LookupMb _ '[] = 'Nothing + LookupMb s ('(s, e) ': rest) = 'Just e + LookupMb s (_ ': rest) = LookupMb s rest -type family LookupStep (b :: Bool) (s :: Symbol) (e :: EnvEntry) - (rest :: Env) (full :: Env) :: EnvEntry where - LookupStep 'True _ e _ _ = e - LookupStep 'False s _ rest full = LookupGo s rest full +type family Found (s :: Symbol) (env :: Env) + (r :: Maybe EnvEntry) :: EnvEntry where + Found _ _ ('Just e) = e + Found s env 'Nothing = + TypeError ('Text "Undefined non-terminal: " ':<>: 'ShowType s + ':$$: 'Text "Available non-terminals: " ':<>: 'ShowType (Names env)) type family Names (env :: Env) :: [Symbol] where Names '[] = '[] diff --git a/typed-peg.cabal b/typed-peg.cabal --- a/typed-peg.cabal +++ b/typed-peg.cabal @@ -1,16 +1,21 @@ cabal-version: 3.0 name: typed-peg -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Type-safe PEG parser combinators description: - A library for building PEG (Parsing Expression Grammar) parsers + A library for building Parsing Expression Grammars parsers with compile-time safety guarantees. Grammar non-terminals are indexed by their nullability and FIRST sets at the type level, making left-recursive grammars a type error. . - A quasi-quoter ('PEG.QQ') allows writing grammars in a concrete + A quasi-quoter (@PEG.QQ@) allows writing grammars in a concrete DSL syntax. Indentation-sensitive parsing is supported natively - via 'PEG.Indent'. + via @PEG.Indent@. + . + Parsers run over any @PEG.Stream@ instance: @String@, strict and + lazy @Text@, and strict and lazy @ByteString@. A character class + produces a chunk of the input stream, so matching @[a-z]+@ against + a @Text@ yields a slice rather than a @[Char]@. license: BSD-3-Clause license-file: LICENSE @@ -21,8 +26,10 @@ bug-reports: https://github.com/rodrigogribeiro/typed-peg/issues build-type: Simple extra-source-files: README.md -extra-doc-files: CHANGELOG.md -tested-with: GHC == 9.6.7 +extra-doc-files: + CHANGELOG.md + peg-patterns.md +tested-with: GHC == 9.10.3 source-repository head type: git @@ -52,6 +59,7 @@ hs-source-dirs: src exposed-modules: PEG + PEG.CharSet PEG.Grammar PEG.Indent PEG.Member @@ -59,19 +67,43 @@ PEG.QQ PEG.QQ.HsExp PEG.Semantics.Simple + PEG.Stream PEG.Syntax PEG.TyLevel PEG.Type build-depends: base >= 4.18 && < 5 - , template-haskell >= 2.19 && < 2.22 + , bytestring >= 0.11 && < 0.13 + , template-haskell >= 2.19 && < 2.24 + , text >= 2.0 && < 2.2 test-suite typed-peg-examples import: common-opts type: exitcode-stdio-1.0 hs-source-dirs: examples main-is: Main.hs - other-modules: Arith, Layout + other-modules: Arith, Layout, Compat, Patterns build-depends: base + , bytestring + , text , typed-peg + +benchmark typed-peg-bench + import: common-opts + type: exitcode-stdio-1.0 + hs-source-dirs: bench + main-is: Main.hs + other-modules: + Bench.Inputs + Bench.Peg + Bench.Mega + ghc-options: -O2 -rtsopts "-with-rtsopts=-T" + build-depends: + base + , typed-peg + , bytestring + , criterion >= 1.6 && < 1.7 + , megaparsec >= 9.5 && < 10 + , deepseq + , text