grammatical-parsers 0.3 → 0.3.1
raw patch · 16 files changed
+350/−213 lines, 16 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
+ Text.Grampa: showFailure :: TextualMonoid s => s -> ParseFailure -> Int -> String
+ Text.Grampa.Combinators: concatMany :: (MonoidParsing m, Monoid a) => m s a -> m s a
+ Text.Grampa.Combinators: concatSome :: (Monoid x, Applicative (p s), MonoidParsing p) => p s x -> p s x
+ Text.Grampa.Combinators: count :: Applicative m => Int -> m a -> m [a]
+ Text.Grampa.Combinators: delimiter :: (Show s, FactorialMonoid s, LeftReductiveMonoid s, Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s
+ Text.Grampa.Combinators: flag :: Alternative p => p a -> p Bool
+ Text.Grampa.Combinators: keyword :: (Lexical g, LexicalConstraint m g s) => s -> m g s ()
+ Text.Grampa.Combinators: moptional :: (Monoid x, Alternative p) => p x -> p x
+ Text.Grampa.Combinators: operator :: (Show s, FactorialMonoid s, LeftReductiveMonoid s, Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s
+ Text.Grampa.Combinators: upto :: Alternative p => Int -> p a -> p [a]
- Text.Grampa: concatMany :: (MonoidParsing m, Monoid a) => m s a -> m s a
+ Text.Grampa: concatMany :: (MonoidParsing m, Monoid a, Alternative (m s)) => m s a -> m s a
- Text.Grampa: identifier :: (Lexical g, LexicalConstraint m g s, Monad (m g s), Alternative (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s
+ Text.Grampa: identifier :: (Lexical g, LexicalConstraint m g s, Monad (m g s), Alternative (m g s), Parsing (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s
- Text.Grampa.ContextFree.Memoizing: FailureInfo :: !Int -> Word64 -> [String] -> FailureInfo
+ Text.Grampa.ContextFree.Memoizing: FailureInfo :: Word64 -> [String] -> FailureInfo
- Text.Grampa.ContextFree.Parallel: FailureInfo :: !Int -> Int -> [String] -> FailureInfo
+ Text.Grampa.ContextFree.Parallel: FailureInfo :: Int -> [String] -> FailureInfo
- Text.Grampa.ContextFree.SortedMemoizing: FailureInfo :: !Int -> Word64 -> [String] -> FailureInfo
+ Text.Grampa.ContextFree.SortedMemoizing: FailureInfo :: Word64 -> [String] -> FailureInfo
Files
- README.md +7/−7
- grammatical-parsers.cabal +3/−2
- src/Text/Grampa.hs +28/−1
- src/Text/Grampa/Class.hs +8/−6
- src/Text/Grampa/Combinators.hs +41/−0
- src/Text/Grampa/ContextFree/Continued.hs +26/−16
- src/Text/Grampa/ContextFree/Continued/Measured.hs +25/−16
- src/Text/Grampa/ContextFree/Memoizing.hs +28/−25
- src/Text/Grampa/ContextFree/Parallel.hs +27/−24
- src/Text/Grampa/ContextFree/SortedMemoizing.hs +27/−24
- src/Text/Grampa/Internal.hs +4/−7
- src/Text/Grampa/PEG/Backtrack.hs +24/−16
- src/Text/Grampa/PEG/Backtrack/Measured.hs +24/−16
- src/Text/Grampa/PEG/Continued.hs +25/−16
- src/Text/Grampa/PEG/Continued/Measured.hs +25/−16
- src/Text/Grampa/PEG/Packrat.hs +28/−21
README.md view
@@ -92,12 +92,12 @@ -- product=Compose (Left (ParseFailure 1 ["endOfInput"])), -- factor=Compose (Left (ParseFailure 1 ["endOfInput"])), -- number=Compose (Left (ParseFailure 1 ["endOfInput"]))}--- >>> parsePrefix grammar "1+2*3"+-- >>> parsePrefix grammar "1+2*3 apples" -- Arithmetic{--- sum=Compose (Compose (Right [("+2*3",1),("*3",3),("",7)])),--- product=Compose (Compose (Right [("+2*3",1)])),--- factor=Compose (Compose (Right [("+2*3",1)])),--- number=Compose (Compose (Right [("+2*3","1")]))}+-- sum=Compose (Compose (Right [("+2*3 apples",1),("*3 apples",3),(" apples",7)])),+-- product=Compose (Compose (Right [("+2*3 apples",1)])),+-- factor=Compose (Compose (Right [("+2*3 apples",1)])),+-- number=Compose (Compose (Right [("+2*3 apples","1")]))} ~~~ To see more grammar examples, go straight to the@@ -105,5 +105,5 @@ smaller grammars and combines them all together in the [Combined](https://github.com/blamario/grampa/blob/master/grammatical-parsers/examples/Combined.hs) module. -For more conventional tastes there is a monolithic-[Lua grammar](https://github.com/blamario/language-lua2/blob/master/src/Language/Lua/Grammar.hs) example as well.+For more conventional tastes there are monolithic examples of+[Lua](https://github.com/blamario/language-lua2/blob/master/src/Language/Lua/Grammar.hs) and [Oberon](http://hackage.haskell.org/package/language-oberon) grammars as well.
grammatical-parsers.cabal view
@@ -1,6 +1,6 @@ name: grammatical-parsers-version: 0.3-synopsis: parsers that can combine into grammars+version: 0.3.1+synopsis: parsers that combine into grammars description: /Gram/matical-/pa/rsers, or Grampa for short, is a library of parser types whose values are meant to be assigned to grammar record fields. All parser types support the same set of parser combinators, but have different semantics@@ -24,6 +24,7 @@ library hs-source-dirs: src exposed-modules: Text.Grampa,+ Text.Grampa.Combinators, Text.Grampa.PEG.Backtrack, Text.Grampa.PEG.Packrat, Text.Grampa.ContextFree.Continued, Text.Grampa.ContextFree.Parallel, Text.Grampa.ContextFree.Memoizing, Text.Grampa.ContextFree.SortedMemoizing,
src/Text/Grampa.hs view
@@ -4,7 +4,7 @@ module Text.Grampa ( -- * Parsing methods MultiParsing(..),- simply,+ showFailure, simply, -- * Types Grammar, GrammarBuilder, ParseResults, ParseFailure(..), Ambiguous(..), -- * Parser combinators and primitives@@ -14,6 +14,9 @@ module Text.Parser.LookAhead) where +import Data.List (intercalate)+import Data.Monoid ((<>))+import Data.Monoid.Textual (TextualMonoid, toString) import Text.Parser.Char (CharParsing(char, notChar, anyChar)) import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected)) import Text.Parser.LookAhead (LookAheadParsing(lookAhead))@@ -36,3 +39,27 @@ -- | Apply the given 'parse' function to the given grammar-free parser and its input. simply :: (Rank2.Only r (p (Rank2.Only r) s) -> s -> Rank2.Only r f) -> p (Rank2.Only r) s r -> s -> f r simply parseGrammar p input = Rank2.fromOnly (parseGrammar (Rank2.Only p) input)++-- | Given the textual parse input, the parse failure on the input, and the number of lines preceding the failure to+-- show, produce a human-readable failure description.+showFailure :: TextualMonoid s => s -> ParseFailure -> Int -> String+showFailure input (ParseFailure pos expected) preceding =+ unlines prevLines <> replicate column ' ' <> "^\n"+ <> "at line " <> show (length allPrevLines) <> ", column " <> show column <> "\n"+ <> "expected " <> oxfordComma expected+ where oxfordComma [] = []+ oxfordComma [x] = x+ oxfordComma [x, y] = x <> " or " <> y+ oxfordComma (x:y:rest) = intercalate ", " (x : y : onLast ("or " <>) rest)+ onLast _ [] = []+ onLast f [x] = [f x]+ onLast f (x:xs) = x : onLast f xs+ (allPrevLines, column) = context [] pos (lines $ toString (const mempty) input)+ prevLines = reverse (take (succ preceding) allPrevLines)+ context revLines restCount []+ | restCount > 0 = (["Error: the failure position is beyond the input length"], -1)+ | otherwise = (revLines, restCount)+ context revLines restCount (next:rest)+ | restCount < nextLength = (next:revLines, restCount)+ | otherwise = context (next:revLines) (restCount - nextLength - 1) rest+ where nextLength = length next
src/Text/Grampa/Class.hs view
@@ -4,7 +4,6 @@ ParseResults, ParseFailure(..), Ambiguous(..), completeParser) where import Control.Applicative (Alternative(empty), liftA2, (<|>))-import Control.Monad (guard) import Data.Char (isAlphaNum, isLetter, isSpace) import Data.Functor.Classes (Show1(..)) import Data.Functor.Compose (Compose(..))@@ -17,9 +16,9 @@ import Data.Monoid.Null (MonoidNull) import Data.Monoid.Factorial (FactorialMonoid) import Data.Monoid.Textual (TextualMonoid)-import Text.Parser.Combinators (Parsing(notFollowedBy), skipMany, skipSome)+import Text.Parser.Combinators (Parsing(notFollowedBy, (<?>)), skipMany) import Text.Parser.Char (CharParsing(char))-import Text.Parser.Token (TokenParsing, IdentifierStyle)+import Text.Parser.Token (TokenParsing) import GHC.Exts (Constraint) import qualified Rank2@@ -131,6 +130,9 @@ takeCharsWhile1 :: TextualMonoid s => (Char -> Bool) -> m s s -- | Zero or more argument occurrences like 'many', with concatenated monoidal results. concatMany :: Monoid a => m s a -> m s a+ default concatMany :: (Monoid a, Alternative (m s)) => m s a -> m s a+ concatMany p = go+ where go = mappend <$> p <*> go <|> pure mempty -- | Parsers that can produce alternative parses and collect them into an 'Ambiguous' node class AmbiguousParsing m where@@ -181,7 +183,7 @@ default identifierToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s -> m g s s default identifier :: (LexicalConstraint m g s, Monad (m g s), Alternative (m g s),- MonoidParsing (m g), TextualMonoid s) => m g s s+ Parsing (m g s), MonoidParsing (m g), TextualMonoid s) => m g s s default keyword :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), Show s, TextualMonoid s) => s -> m g s () lexicalWhiteSpace = takeCharsWhile isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace)@@ -193,6 +195,6 @@ isIdentifierStartChar c = isLetter c || c == '_' isIdentifierFollowChar c = isAlphaNum c || c == '_' identifier = identifierToken (liftA2 (<>) (satisfyCharInput (isIdentifierStartChar @g))- (takeCharsWhile (isIdentifierFollowChar @g)))+ (takeCharsWhile (isIdentifierFollowChar @g))) <?> "an identifier" identifierToken = lexicalToken- keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g))+ keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g)) <?> ("keyword " <> show s)
+ src/Text/Grampa/Combinators.hs view
@@ -0,0 +1,41 @@+module Text.Grampa.Combinators (moptional, concatMany, concatSome,+ flag, count, upto,+ delimiter, operator, keyword) where++import Control.Applicative(Applicative(..), Alternative(..))+import Data.Monoid.Cancellative (LeftReductiveMonoid)+import Data.Monoid (Monoid, (<>))+import Data.Monoid.Factorial (FactorialMonoid)++import Text.Grampa.Class (MonoidParsing(concatMany, string), + Lexical(LexicalConstraint, lexicalToken, keyword))+import Text.Parser.Combinators (Parsing((<?>)), count)++-- | Attempts to parse a monoidal value, if the argument parser fails returns 'mempty'.+moptional :: (Monoid x, Alternative p) => p x -> p x+moptional p = p <|> pure mempty++-- | One or more argument occurrences like 'some', with concatenated monoidal results.+concatSome :: (Monoid x, Applicative (p s), MonoidParsing p) => p s x -> p s x+concatSome p = (<>) <$> p <*> concatMany p++-- | Returns 'True' if the argument parser succeeds and 'False' otherwise.+flag :: Alternative p => p a -> p Bool+flag p = True <$ p <|> pure False++-- | Parses between 0 and N occurrences of the argument parser in sequence and returns the list of results.+upto :: Alternative p => Int -> p a -> p [a]+upto n p+ | n > 0 = (:) <$> p <*> upto (pred n) p + <|> pure []+ | otherwise = pure []++-- | Parses the given delimiter, such as a comma or a brace+delimiter :: (Show s, FactorialMonoid s, LeftReductiveMonoid s,+ Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s+delimiter s = lexicalToken (string s) <?> ("delimiter " <> show s)++-- | Parses the given operator symbol+operator :: (Show s, FactorialMonoid s, LeftReductiveMonoid s,+ Parsing (p g s), MonoidParsing (p g), Lexical g, LexicalConstraint p g s) => s -> p g s s+operator s = lexicalToken (string s) <?> ("operator " <> show s)
src/Text/Grampa/ContextFree/Continued.hs view
@@ -60,7 +60,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest _ failure-> failure $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest _ failure-> failure $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -90,14 +90,24 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try :: forall a. Parser g s a -> Parser g s a+ try (Parser p) = Parser q+ where q :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . rewindFailure)+ where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (fromIntegral $ Factorial.length input) []+ (<?>) :: forall a. Parser g s a -> String -> Parser g s a+ Parser p <?> msg = Parser q+ where q :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . replaceFailure)+ where replaceFailure (FailureInfo pos msgs) =+ FailureInfo pos (if pos == fromIntegral (Factorial.length input) then [msg] else msgs)+ eof = endOfInput- unexpected msg = Parser (\t _ failure -> failure $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser q where q :: forall x. s -> (() -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x q input success failure = p input success' failure'- where success' _ _ _ = failure (FailureInfo 1 (fromIntegral $ Factorial.length input) ["notFollowedBy"])+ where success' _ _ _ = failure (FailureInfo (fromIntegral $ Factorial.length input) ["notFollowedBy"]) failure' _ = success () input failure instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -125,42 +135,42 @@ endOfInput = Parser p where p rest success failure | Null.null rest = success () rest failure- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest success failure = success rest mempty failure anyToken = Parser p where p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> success first suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s satisfy predicate = Parser p where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> success first suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char satisfyChar predicate = Parser p where p :: forall x. s -> (Char -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success first suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s satisfyCharInput predicate = Parser p where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s () notSatisfy predicate = Parser p where p :: forall x. s -> (() -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, _)- | predicate first -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfy"])+ | predicate first -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfy"]) _ -> success () rest failure notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s () notSatisfyChar predicate = Parser p@@ -168,7 +178,7 @@ p rest success failure = case Textual.characterPrefix rest of Just first | predicate first- -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfyChar"])+ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfyChar"]) _ -> success () rest failure scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t scan s0 f = Parser (p s0)@@ -190,7 +200,7 @@ p rest success failure | (prefix, suffix) <- Factorial.span predicate rest = if Null.null prefix- then failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else success prefix suffix failure takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s takeCharsWhile predicate = Parser p@@ -201,7 +211,7 @@ takeCharsWhile1 predicate = Parser p where p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure- | Null.null prefix = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ | Null.null prefix = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) | otherwise = success prefix suffix failure where (prefix, suffix) = Textual.span_ False predicate rest string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s@@ -209,7 +219,7 @@ p :: forall x. s -> (s -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p s' success failure | Just suffix <- Cancellative.stripPrefix s s' = success s suffix failure- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a concatMany (Parser p) = Parser q where q :: forall x. s -> (a -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x@@ -232,4 +242,4 @@ (Rank2.fmap (<* endOfInput) g) fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure-fromFailure s (FailureInfo _ pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)+fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)
src/Text/Grampa/ContextFree/Continued/Measured.hs view
@@ -60,7 +60,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest _ failure-> failure $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest _ failure-> failure $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -92,14 +92,23 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try :: forall a. Parser g s a -> Parser g s a+ try (Parser p) = Parser q+ where q :: forall x. s -> (a -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . rewindFailure)+ where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (fromIntegral $ Factorial.length input) []+ (<?>) :: forall a. Parser g s a -> String -> Parser g s a+ Parser p <?> msg = Parser q+ where q :: forall x. s -> (a -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . replaceFailure)+ where replaceFailure (FailureInfo pos msgs) =+ FailureInfo pos (if pos == fromIntegral (Factorial.length input) then [msg] else msgs) eof = endOfInput- unexpected msg = Parser (\t _ failure -> failure $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser q where q :: forall x. s -> (() -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x q input success failure = p input success' failure'- where success' _ _ _ _ = failure (FailureInfo 1 (fromIntegral $ Factorial.length input) + where success' _ _ _ _ = failure (FailureInfo (fromIntegral $ Factorial.length input) ["notFollowedBy"]) failure' _ = success () 0 input failure @@ -128,7 +137,7 @@ endOfInput = Parser p where p rest success failure | Null.null rest = success () 0 rest failure- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest success failure = success rest len mempty failure where !len = Factorial.length rest@@ -136,35 +145,35 @@ where p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> success first 1 suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s satisfy predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> success first 1 suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char satisfyChar predicate = Parser p where p :: forall x. s -> (Char -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success first 1 suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s satisfyCharInput predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) 1 suffix failure- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s () notSatisfy predicate = Parser p where p :: forall x. s -> (() -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, _)- | predicate first -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfy"])+ | predicate first -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfy"]) _ -> success () 0 rest failure notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s () notSatisfyChar predicate = Parser p@@ -172,7 +181,7 @@ p rest success failure = case Textual.characterPrefix rest of Just first | predicate first- -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfyChar"])+ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfyChar"]) _ -> success () 0 rest failure scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t scan s0 f = Parser (p s0)@@ -200,7 +209,7 @@ | (prefix, suffix) <- Factorial.span predicate rest, !len <- Factorial.length prefix = if len == 0- then failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else success prefix len suffix failure takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s takeCharsWhile predicate = Parser p@@ -212,7 +221,7 @@ takeCharsWhile1 predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p rest success failure- | Null.null prefix = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ | Null.null prefix = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) | otherwise = len `seq` success prefix len suffix failure where (prefix, suffix) = Textual.span_ False predicate rest len = Factorial.length prefix@@ -221,7 +230,7 @@ p :: forall x. s -> (s -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x p s' success failure | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix failure- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a concatMany (Parser p) = Parser q where q :: forall x. s -> (a -> Int -> s -> (FailureInfo -> x) -> x) -> (FailureInfo -> x) -> x@@ -251,4 +260,4 @@ (Rank2.fmap (<* endOfInput) g) fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure-fromFailure s (FailureInfo _ pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)+fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)
src/Text/Grampa/ContextFree/Memoizing.hs view
@@ -83,7 +83,7 @@ {-# INLINABLE (<*>) #-} instance Alternative (Parser g i) where- empty = Parser (\rest-> ResultList mempty $ FailureInfo 0 (genericLength rest) ["empty"])+ empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) ["empty"]) Parser p <|> Parser q = Parser r where r rest = p rest <> q rest {-# INLINABLE (<|>) #-}@@ -119,7 +119,7 @@ type GrammarFunctor Parser = ResultList nonTerminal f = Parser p where p ((_, d) : _) = f d- p _ = ResultList mempty (FailureInfo 1 0 ["NonTerminal at endOfInput"])+ p _ = ResultList mempty (FailureInfo 0 ["NonTerminal at endOfInput"]) {-# INLINE nonTerminal #-} -- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left@@ -158,26 +158,26 @@ anyToken = Parser p where p rest@((s, _):t) = case splitPrimePrefix s of Just (first, _) -> ResultList (Leaf $ ResultInfo 1 t first) mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["anyToken"])- p [] = ResultList mempty (FailureInfo 1 0 ["anyToken"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["anyToken"])+ p [] = ResultList mempty (FailureInfo 0 ["anyToken"]) satisfy predicate = Parser p where p rest@((s, _):t) = case splitPrimePrefix s of Just (first, _) | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfy"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfy"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfy"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfy"]) satisfyChar predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t first) mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyChar"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfyChar"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfyChar"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfyChar"]) satisfyCharInput predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> ResultList (Leaf $ ResultInfo 1 t $ Factorial.primePrefix s) mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyCharInput"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfyCharInput"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfyCharInput"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfyCharInput"]) scan s0 f = Parser (p s0) where p s rest@((i, _) : _) = ResultList (Leaf $ ResultInfo l (drop l rest) prefix) mempty where (prefix, _, _) = Factorial.spanMaybe' s f i@@ -197,7 +197,7 @@ where p rest@((s, _) : _) | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 = ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeWhile1"])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["takeWhile1"]) takeCharsWhile predicate = Parser p where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =@@ -207,41 +207,44 @@ where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 = ResultList (Leaf $ ResultInfo l (drop l rest) x) mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["takeCharsWhile1"]) string s = Parser p where p rest@((s', _) : _) | s `isPrefixOf` s' = ResultList (Leaf $ ResultInfo l (Factorial.drop l rest) s) mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["string " ++ show s])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["string " ++ show s]) l = Factorial.length s- concatMany p = go- where go = mempty <|> mappend <$> p <*> go notSatisfy predicate = Parser p where p rest@((s, _):_) | Just (first, _) <- splitPrimePrefix s, - predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfy"])+ predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfy"]) p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty notSatisfyChar predicate = Parser p where p rest@((s, _):_) | Just first <- Textual.characterPrefix s, - predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+ predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfyChar"]) p rest = ResultList (Leaf $ ResultInfo 0 rest ()) mempty {-# INLINABLE string #-} instance MonoidNull s => Parsing (Parser g s) where- try (Parser p) = Parser (weakenResults . p)- where weakenResults (ResultList rl (FailureInfo s pos msgs)) = ResultList rl (FailureInfo (pred s) pos msgs)- Parser p <?> msg = Parser (strengthenResults . p)- where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =+ ResultList rl (FailureInfo (genericLength rest) [])+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (ResultList EmptyTree (FailureInfo pos msgs)) =+ ResultList EmptyTree (FailureInfo pos $ if pos == genericLength rest then [msg] else msgs)+ replaceFailure rl = rl notFollowedBy (Parser p) = Parser (\input-> rewind input (p input)) where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo 0 t ()) mempty- rewind t ResultList{} = ResultList mempty (FailureInfo 1 (genericLength t) ["notFollowedBy"])+ rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) ["notFollowedBy"]) skipMany p = go where go = pure () <|> p *> go- unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (genericLength t) [msg])+ unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [msg]) eof = Parser f where f rest@((s, _):_) | null s = ResultList (Leaf $ ResultInfo 0 rest ()) mempty- | otherwise = ResultList mempty (FailureInfo 1 (genericLength rest) ["endOfInput"])+ | otherwise = ResultList mempty (FailureInfo (genericLength rest) ["endOfInput"]) f [] = ResultList (Leaf $ ResultInfo 0 [] ()) mempty instance MonoidNull s => LookAheadParsing (Parser g s) where@@ -263,7 +266,7 @@ token = lexicalToken fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]-fromResultList s (ResultList EmptyTree (FailureInfo _ pos msgs)) =+fromResultList s (ResultList EmptyTree (FailureInfo pos msgs)) = Left (ParseFailure (length s - fromIntegral pos + 1) (nub msgs)) fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl) where f (ResultInfo _ ((s, _):_) r) = (s, r)
src/Text/Grampa/ContextFree/Parallel.hs view
@@ -40,7 +40,7 @@ data ResultList s r = ResultList !(BinTree (ResultInfo s r)) {-# UNPACK #-} !FailureInfo data ResultInfo s r = ResultInfo !s !r-data FailureInfo = FailureInfo !Int Int [String] deriving (Eq, Show)+data FailureInfo = FailureInfo Int [String] deriving (Eq, Show) instance (Show s, Show r) => Show (ResultList s r) where show (ResultList l f) = "ResultList (" ++ shows l (") (" ++ shows f ")")@@ -66,16 +66,13 @@ mappend = (<>) instance Semigroup FailureInfo where- f1@(FailureInfo s1 pos1 exp1) <> f2@(FailureInfo s2 pos2 exp2)- | s1 < s2 = f2- | s1 > s2 = f1- | otherwise = FailureInfo s1 pos' exp'+ FailureInfo pos1 exp1 <> FailureInfo pos2 exp2 = FailureInfo pos' exp' where (pos', exp') | pos1 < pos2 = (pos1, exp1) | pos1 > pos2 = (pos2, exp2) | otherwise = (pos1, exp1 <> exp2) instance Monoid FailureInfo where- mempty = FailureInfo 0 maxBound []+ mempty = FailureInfo maxBound [] mappend = (<>) instance Functor (Parser g s) where@@ -90,7 +87,7 @@ instance FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\s-> ResultList mempty $ FailureInfo 0 (Factorial.length s) ["empty"])+ empty = Parser (\s-> ResultList mempty $ FailureInfo (Factorial.length s) ["empty"]) Parser p <|> Parser q = Parser r where r rest = p rest <> q rest @@ -130,36 +127,36 @@ instance MonoidParsing (Parser g) where endOfInput = Parser f where f s | null s = ResultList (Leaf $ ResultInfo s ()) mempty- | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s) ["endOfInput"])+ | otherwise = ResultList mempty (FailureInfo (Factorial.length s) ["endOfInput"]) getInput = Parser p where p s = ResultList (Leaf $ ResultInfo mempty s) mempty anyToken = Parser p where p s = case Factorial.splitPrimePrefix s of Just (first, rest) -> ResultList (Leaf $ ResultInfo rest first) mempty- _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["anyToken"])+ _ -> ResultList mempty (FailureInfo (Factorial.length s) ["anyToken"]) satisfy predicate = Parser p where p s = case Factorial.splitPrimePrefix s of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty- _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfy"])+ _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfy"]) satisfyChar predicate = Parser p where p s = case Textual.splitCharacterPrefix s of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest first) mempty- _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+ _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfyChar"]) satisfyCharInput predicate = Parser p where p s = case Textual.splitCharacterPrefix s of Just (first, rest) | predicate first -> ResultList (Leaf $ ResultInfo rest $ Factorial.primePrefix s) mempty- _ -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["satisfyChar"])+ _ -> ResultList mempty (FailureInfo (Factorial.length s) ["satisfyChar"]) notSatisfy predicate = Parser p where p s = case Factorial.splitPrimePrefix s of Just (first, _) - | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfy"])+ | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) ["notSatisfy"]) _ -> ResultList (Leaf $ ResultInfo s ()) mempty notSatisfyChar predicate = Parser p where p s = case Textual.characterPrefix s of Just first - | predicate first -> ResultList mempty (FailureInfo 1 (Factorial.length s) ["notSatisfyChar"])+ | predicate first -> ResultList mempty (FailureInfo (Factorial.length s) ["notSatisfyChar"]) _ -> ResultList (Leaf $ ResultInfo s ()) mempty scan s0 f = Parser (p s0) where p s i = ResultList (Leaf $ ResultInfo suffix prefix) mempty@@ -172,7 +169,7 @@ takeWhile1 predicate = Parser p where p s | (prefix, suffix) <- Factorial.span predicate s = if Null.null prefix- then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeWhile1"])+ then ResultList mempty (FailureInfo (Factorial.length s) ["takeWhile1"]) else ResultList (Leaf $ ResultInfo suffix prefix) mempty takeCharsWhile predicate = Parser p where p s | (prefix, suffix) <- Textual.span_ False predicate s = @@ -180,27 +177,33 @@ takeCharsWhile1 predicate = Parser p where p s | (prefix, suffix) <- Textual.span_ False predicate s = if null prefix- then ResultList mempty (FailureInfo 1 (Factorial.length s) ["takeCharsWhile1"])+ then ResultList mempty (FailureInfo (Factorial.length s) ["takeCharsWhile1"]) else ResultList (Leaf $ ResultInfo suffix prefix) mempty string s = Parser p where p s' | Just suffix <- Cancellative.stripPrefix s s' = ResultList (Leaf $ ResultInfo suffix s) mempty- | otherwise = ResultList mempty (FailureInfo 1 (Factorial.length s') ["string " ++ show s])+ | otherwise = ResultList mempty (FailureInfo (Factorial.length s') ["string " ++ show s]) concatMany (Parser p) = Parser q where q s = ResultList (Leaf $ ResultInfo s mempty) failure <> foldMap continue rs where ResultList rs failure = p s continue (ResultInfo suffix prefix) = mappend prefix <$> q suffix instance FactorialMonoid s => Parsing (Parser g s) where- try (Parser p) = Parser (weakenResults . p)- where weakenResults (ResultList rl (FailureInfo s pos msgs)) = ResultList rl (FailureInfo (pred s) pos msgs)- Parser p <?> msg = Parser (strengthenResults . p)- where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =+ ResultList rl (FailureInfo (fromIntegral $ Factorial.length rest) [])+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (ResultList EmptyTree (FailureInfo pos msgs)) =+ ResultList EmptyTree (FailureInfo pos $+ if pos == fromIntegral (Factorial.length rest) then [msg] else msgs)+ replaceFailure rl = rl notFollowedBy (Parser p) = Parser (\input-> rewind input (p input)) where rewind t (ResultList EmptyTree _) = ResultList (Leaf $ ResultInfo t ()) mempty- rewind t ResultList{} = ResultList mempty (FailureInfo 1 (Factorial.length t) ["notFollowedBy"])+ rewind t ResultList{} = ResultList mempty (FailureInfo (Factorial.length t) ["notFollowedBy"]) skipMany p = go where go = pure () <|> p *> go- unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (Factorial.length t) [msg])+ unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (Factorial.length t) [msg]) eof = endOfInput instance FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -222,7 +225,7 @@ token = lexicalToken fromResultList :: FactorialMonoid s => s -> ResultList s r -> ParseResults [(s, r)]-fromResultList s (ResultList EmptyTree (FailureInfo _ pos msgs)) = +fromResultList s (ResultList EmptyTree (FailureInfo pos msgs)) = Left (ParseFailure (Factorial.length s - pos) (nub msgs)) fromResultList _ (ResultList rl _failure) = Right (f <$> toList rl) where f (ResultInfo s r) = (s, r)
src/Text/Grampa/ContextFree/SortedMemoizing.hs view
@@ -57,7 +57,7 @@ {-# INLINABLE (<*>) #-} instance Alternative (Parser g i) where- empty = Parser (\rest-> ResultList mempty $ FailureInfo 0 (genericLength rest) ["empty"])+ empty = Parser (\rest-> ResultList mempty $ FailureInfo (genericLength rest) ["empty"]) Parser p <|> Parser q = Parser r where r rest = p rest <> q rest {-# INLINABLE (<|>) #-}@@ -94,7 +94,7 @@ type GrammarFunctor Parser = ResultList nonTerminal f = Parser p where p ((_, d) : _) = f d- p _ = ResultList mempty (FailureInfo 1 0 ["NonTerminal at endOfInput"])+ p _ = ResultList mempty (FailureInfo 0 ["NonTerminal at endOfInput"]) {-# INLINE nonTerminal #-} -- | Memoizing parser guarantees O(n²) performance for grammars with unambiguous productions, but provides no left@@ -133,26 +133,26 @@ anyToken = Parser p where p rest@((s, _):t) = case splitPrimePrefix s of Just (first, _) -> ResultList [ResultsOfLength 1 t (first:|[])] mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["anyToken"])- p [] = ResultList mempty (FailureInfo 1 0 ["anyToken"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["anyToken"])+ p [] = ResultList mempty (FailureInfo 0 ["anyToken"]) satisfy predicate = Parser p where p rest@((s, _):t) = case splitPrimePrefix s of Just (first, _) | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfy"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfy"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfy"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfy"]) satisfyChar predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> ResultList [ResultsOfLength 1 t (first:|[])] mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyChar"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfyChar"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfyChar"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfyChar"]) satisfyCharInput predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> ResultList [ResultsOfLength 1 t (Factorial.primePrefix s:|[])] mempty- _ -> ResultList mempty (FailureInfo 1 (genericLength rest) ["satisfyCharInput"])- p [] = ResultList mempty (FailureInfo 1 0 ["satisfyCharInput"])+ _ -> ResultList mempty (FailureInfo (genericLength rest) ["satisfyCharInput"])+ p [] = ResultList mempty (FailureInfo 0 ["satisfyCharInput"]) scan s0 f = Parser (p s0) where p s rest@((i, _) : _) = ResultList [ResultsOfLength l (drop l rest) (prefix:|[])] mempty where (prefix, _, _) = Factorial.spanMaybe' s f i@@ -172,7 +172,7 @@ where p rest@((s, _) : _) | x <- Factorial.takeWhile predicate s, l <- Factorial.length x, l > 0 = ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeWhile1"])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["takeWhile1"]) takeCharsWhile predicate = Parser p where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x =@@ -182,41 +182,44 @@ where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s, l <- Factorial.length x, l > 0 = ResultList [ResultsOfLength l (drop l rest) (x:|[])] mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["takeCharsWhile1"]) string s = Parser p where p rest@((s', _) : _) | s `isPrefixOf` s' = ResultList [ResultsOfLength l (Factorial.drop l rest) (s:|[])] mempty- p rest = ResultList mempty (FailureInfo 1 (genericLength rest) ["string " ++ show s])+ p rest = ResultList mempty (FailureInfo (genericLength rest) ["string " ++ show s]) l = Factorial.length s- concatMany p = go- where go = mempty <|> mappend <$> p <*> go notSatisfy predicate = Parser p where p rest@((s, _):_) | Just (first, _) <- splitPrimePrefix s, - predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfy"])+ predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfy"]) p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty notSatisfyChar predicate = Parser p where p rest@((s, _):_) | Just first <- Textual.characterPrefix s, - predicate first = ResultList mempty (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+ predicate first = ResultList mempty (FailureInfo (genericLength rest) ["notSatisfyChar"]) p rest = ResultList [ResultsOfLength 0 rest (():|[])] mempty {-# INLINABLE string #-} instance MonoidNull s => Parsing (Parser g s) where- try (Parser p) = Parser (weakenResults . p)- where weakenResults (ResultList rl (FailureInfo s pos msgs)) = ResultList rl (FailureInfo (pred s) pos msgs)- Parser p <?> msg = Parser (strengthenResults . p)- where strengthenResults (ResultList rl (FailureInfo s pos _msgs)) = ResultList rl (FailureInfo (succ s) pos [msg])+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (ResultList rl (FailureInfo _pos _msgs)) =+ ResultList rl (FailureInfo (genericLength rest) [])+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (ResultList [] (FailureInfo pos msgs)) =+ ResultList [] (FailureInfo pos $ if pos == genericLength rest then [msg] else msgs)+ replaceFailure rl = rl notFollowedBy (Parser p) = Parser (\input-> rewind input (p input)) where rewind t (ResultList [] _) = ResultList [ResultsOfLength 0 t (():|[])] mempty- rewind t ResultList{} = ResultList mempty (FailureInfo 1 (genericLength t) ["notFollowedBy"])+ rewind t ResultList{} = ResultList mempty (FailureInfo (genericLength t) ["notFollowedBy"]) skipMany p = go where go = pure () <|> p *> go- unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo 0 (genericLength t) [msg])+ unexpected msg = Parser (\t-> ResultList mempty $ FailureInfo (genericLength t) [msg]) eof = Parser f where f rest@((s, _):_) | null s = ResultList [ResultsOfLength 0 rest (():|[])] mempty- | otherwise = ResultList mempty (FailureInfo 1 (genericLength rest) ["endOfInput"])+ | otherwise = ResultList mempty (FailureInfo (genericLength rest) ["endOfInput"]) f [] = ResultList [ResultsOfLength 0 [] (():|[])] mempty instance MonoidNull s => LookAheadParsing (Parser g s) where
src/Text/Grampa/Internal.hs view
@@ -14,7 +14,7 @@ import Prelude hiding (length, showList) -data FailureInfo = FailureInfo !Int Word64 [String] deriving (Eq, Show)+data FailureInfo = FailureInfo Word64 [String] deriving (Eq, Show) data ResultsOfLength g s r = ResultsOfLength !Int ![(s, g (ResultList g s))] !(NonEmpty r) @@ -26,23 +26,20 @@ deriving (Show) fromResultList :: FactorialMonoid s => s -> ResultList g s r -> ParseResults [(s, r)]-fromResultList s (ResultList [] (FailureInfo _ pos msgs)) =+fromResultList s (ResultList [] (FailureInfo pos msgs)) = Left (ParseFailure (length s - fromIntegral pos + 1) (nub msgs)) fromResultList _ (ResultList rl _failure) = Right (foldMap f rl) where f (ResultsOfLength _ ((s, _):_) r) = (,) s <$> toList r f (ResultsOfLength _ [] r) = (,) mempty <$> toList r instance Semigroup FailureInfo where- f1@(FailureInfo s1 pos1 exp1) <> f2@(FailureInfo s2 pos2 exp2)- | s1 < s2 = f2- | s1 > s2 = f1- | otherwise = FailureInfo s1 pos' exp'+ f1@(FailureInfo pos1 exp1) <> f2@(FailureInfo pos2 exp2) = FailureInfo pos' exp' where (pos', exp') | pos1 < pos2 = (pos1, exp1) | pos1 > pos2 = (pos2, exp2) | otherwise = (pos1, exp1 <> exp2) instance Monoid FailureInfo where- mempty = FailureInfo 0 maxBound []+ mempty = FailureInfo maxBound [] mappend = (<>) instance Show r => Show (ResultList g s r) where
src/Text/Grampa/PEG/Backtrack.hs view
@@ -59,7 +59,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest-> NoParse $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -88,12 +88,20 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (NoParse (FailureInfo _pos _msgs)) =+ NoParse (FailureInfo (fromIntegral $ Factorial.length rest) [])+ rewindFailure parsed = parsed+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (NoParse (FailureInfo pos msgs)) =+ NoParse (FailureInfo pos $ if pos == fromIntegral (Factorial.length rest) then [msg] else msgs)+ replaceFailure parsed = parsed eof = endOfInput- unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t-> NoParse $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))- where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])+ where rewind t Parsed{} = NoParse (FailureInfo (fromIntegral $ Factorial.length t) ["notFollowedBy"]) rewind t NoParse{} = Parsed () t instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -118,37 +126,37 @@ endOfInput = Parser p where p rest | Null.null rest = Parsed () rest- | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest = Parsed rest mempty anyToken = Parser p where p rest = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> Parsed first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy predicate = Parser p where p rest = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> Parsed first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar predicate = Parser p where p rest = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> Parsed first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput predicate = Parser p where p rest = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> Parsed (Factorial.primePrefix rest) suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy predicate = Parser p where p s = case Factorial.splitPrimePrefix s of Just (first, _) - | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])+ | predicate first -> NoParse (FailureInfo (fromIntegral $ Factorial.length s) ["notSatisfy"]) _ -> Parsed () s notSatisfyChar predicate = Parser p where p s = case Textual.characterPrefix s of Just first | predicate first - -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])+ -> NoParse (FailureInfo (fromIntegral $ Factorial.length s) ["notSatisfyChar"]) _ -> Parsed () s scan s0 f = Parser (p s0) where p s rest = Parsed prefix suffix@@ -161,18 +169,18 @@ takeWhile1 predicate = Parser p where p rest | (prefix, suffix) <- Factorial.span predicate rest = if Null.null prefix- then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else Parsed prefix suffix takeCharsWhile predicate = Parser p where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = Parsed prefix suffix takeCharsWhile1 predicate = Parser p where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = if Null.null prefix- then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ then NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) else Parsed prefix suffix string s = Parser p where p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed s suffix- | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = NoParse (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) concatMany (Parser p) = Parser q where q rest = case p rest of Parsed prefix suffix -> let Parsed prefix' suffix' = q suffix@@ -195,6 +203,6 @@ (Rank2.fmap (<* endOfInput) g) fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)-fromResult s (NoParse (FailureInfo _ pos msgs)) =+fromResult s (NoParse (FailureInfo pos msgs)) = Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)) fromResult _ (Parsed prefix suffix) = Right (suffix, prefix)
src/Text/Grampa/PEG/Backtrack/Measured.hs view
@@ -62,7 +62,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest-> NoParse $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -93,12 +93,20 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (NoParse (FailureInfo _pos _msgs)) =+ NoParse (FailureInfo (fromIntegral $ Factorial.length rest) [])+ rewindFailure parsed = parsed+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (NoParse (FailureInfo pos msgs)) =+ NoParse (FailureInfo pos $ if pos == fromIntegral (Factorial.length rest) then [msg] else msgs)+ replaceFailure parsed = parsed eof = endOfInput- unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t-> NoParse $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))- where rewind t Parsed{} = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length t) ["notFollowedBy"])+ where rewind t Parsed{} = NoParse (FailureInfo (fromIntegral $ Factorial.length t) ["notFollowedBy"]) rewind t NoParse{} = Parsed 0 () t instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -123,37 +131,37 @@ endOfInput = Parser p where p rest | Null.null rest = Parsed 0 () rest- | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest = Parsed (Factorial.length rest) rest mempty anyToken = Parser p where p rest = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> Parsed 1 first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy predicate = Parser p where p rest = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> Parsed 1 first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar predicate = Parser p where p rest = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> Parsed 1 first suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput predicate = Parser p where p rest = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> Parsed 1 (Factorial.primePrefix rest) suffix- _ -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy predicate = Parser p where p s = case Factorial.splitPrimePrefix s of Just (first, _) - | predicate first -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfy"])+ | predicate first -> NoParse (FailureInfo (fromIntegral $ Factorial.length s) ["notSatisfy"]) _ -> Parsed 0 () s notSatisfyChar predicate = Parser p where p s = case Textual.characterPrefix s of Just first | predicate first - -> NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s) ["notSatisfyChar"])+ -> NoParse (FailureInfo (fromIntegral $ Factorial.length s) ["notSatisfyChar"]) _ -> Parsed 0 () s scan s0 f = Parser (p s0) where p s rest = Parsed (Factorial.length prefix) prefix suffix@@ -167,7 +175,7 @@ takeWhile1 predicate = Parser p where p rest | (prefix, suffix) <- Factorial.span predicate rest = if Null.null prefix- then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else Parsed (Factorial.length prefix) prefix suffix takeCharsWhile predicate = Parser p where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = @@ -175,11 +183,11 @@ takeCharsWhile1 predicate = Parser p where p rest | (prefix, suffix) <- Textual.span_ False predicate rest = if Null.null prefix- then NoParse (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ then NoParse (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) else Parsed (Factorial.length prefix) prefix suffix string s = Parser p where p s' | Just suffix <- Cancellative.stripPrefix s s' = Parsed l s suffix- | otherwise = NoParse (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = NoParse (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) l = Factorial.length s concatMany (Parser p) = Parser q where q rest = case p rest@@ -203,6 +211,6 @@ (Rank2.fmap (<* endOfInput) g) fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)-fromResult s (NoParse (FailureInfo _ pos msgs)) =+fromResult s (NoParse (FailureInfo pos msgs)) = Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)) fromResult _ (Parsed _ prefix suffix) = Right (suffix, prefix)
src/Text/Grampa/PEG/Continued.hs view
@@ -60,7 +60,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest _ failure-> failure $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest _ failure-> failure $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -88,14 +88,23 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try :: forall a. Parser g s a -> Parser g s a+ try (Parser p) = Parser q+ where q :: forall x. s -> (a -> s -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . rewindFailure)+ where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (fromIntegral $ Factorial.length input) []+ (<?>) :: forall a. Parser g s a -> String -> Parser g s a+ Parser p <?> msg = Parser q+ where q :: forall x. s -> (a -> s -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . replaceFailure)+ where replaceFailure (FailureInfo pos msgs) =+ FailureInfo pos (if pos == fromIntegral (Factorial.length input) then [msg] else msgs) eof = endOfInput- unexpected msg = Parser (\t _ failure -> failure $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser q where q :: forall x. s -> (() -> s -> x) -> (FailureInfo -> x) -> x q input success failure = p input success' failure'- where success' _ _ = failure (FailureInfo 1 (fromIntegral $ Factorial.length input) ["notFollowedBy"])+ where success' _ _ = failure (FailureInfo (fromIntegral $ Factorial.length input) ["notFollowedBy"]) failure' _ = success () input instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -123,42 +132,42 @@ endOfInput = Parser p where p rest success failure | Null.null rest = success () rest- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest success _ = success rest mempty anyToken = Parser p where p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> success first suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s satisfy predicate = Parser p where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> success first suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char satisfyChar predicate = Parser p where p :: forall x. s -> (Char -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success first suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s satisfyCharInput predicate = Parser p where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s () notSatisfy predicate = Parser p where p :: forall x. s -> (() -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, _)- | predicate first -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfy"])+ | predicate first -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfy"]) _ -> success () rest notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s () notSatisfyChar predicate = Parser p@@ -166,7 +175,7 @@ p rest success failure = case Textual.characterPrefix rest of Just first | predicate first- -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfyChar"])+ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfyChar"]) _ -> success () rest scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t scan s0 f = Parser (p s0)@@ -188,7 +197,7 @@ p rest success failure | (prefix, suffix) <- Factorial.span predicate rest = if Null.null prefix- then failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else success prefix suffix takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s takeCharsWhile predicate = Parser p@@ -198,7 +207,7 @@ takeCharsWhile1 predicate = Parser p where p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x p rest success failure- | Null.null prefix = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ | Null.null prefix = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) | otherwise = success prefix suffix where (prefix, suffix) = Textual.span_ False predicate rest string :: forall s. (Cancellative.LeftReductiveMonoid s, FactorialMonoid s, Show s) => s -> Parser g s s@@ -206,7 +215,7 @@ p :: forall x. s -> (s -> s -> x) -> (FailureInfo -> x) -> x p s' success failure | Just suffix <- Cancellative.stripPrefix s s' = success s suffix- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a concatMany (Parser p) = Parser q where q :: forall x. s -> (a -> s -> x) -> (FailureInfo -> x) -> x@@ -229,4 +238,4 @@ (Rank2.fmap (<* endOfInput) g) fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure-fromFailure s (FailureInfo _ pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)+fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)
src/Text/Grampa/PEG/Continued/Measured.hs view
@@ -61,7 +61,7 @@ {-# INLINABLE (<*>) #-} instance Factorial.FactorialMonoid s => Alternative (Parser g s) where- empty = Parser (\rest _ failure-> failure $ FailureInfo 0 (fromIntegral $ Factorial.length rest) ["empty"])+ empty = Parser (\rest _ failure-> failure $ FailureInfo (fromIntegral $ Factorial.length rest) ["empty"]) (<|>) = alt -- | A named and unconstrained version of the '<|>' operator@@ -91,14 +91,23 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try :: forall a. Parser g s a -> Parser g s a+ try (Parser p) = Parser q+ where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . rewindFailure)+ where rewindFailure (FailureInfo _pos _msgs) = FailureInfo (fromIntegral $ Factorial.length input) []+ (<?>) :: forall a. Parser g s a -> String -> Parser g s a+ Parser p <?> msg = Parser q+ where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo -> x) -> x+ q input success failure = p input success (failure . replaceFailure)+ where replaceFailure (FailureInfo pos msgs) =+ FailureInfo pos (if pos == fromIntegral (Factorial.length input) then [msg] else msgs) eof = endOfInput- unexpected msg = Parser (\t _ failure -> failure $ FailureInfo 0 (fromIntegral $ Factorial.length t) [msg])+ unexpected msg = Parser (\t _ failure -> failure $ FailureInfo (fromIntegral $ Factorial.length t) [msg]) notFollowedBy (Parser p) = Parser q where q :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo -> x) -> x q input success failure = p input success' failure'- where success' _ _ _ = failure (FailureInfo 1 (fromIntegral $ Factorial.length input) ["notFollowedBy"])+ where success' _ _ _ = failure (FailureInfo (fromIntegral $ Factorial.length input) ["notFollowedBy"]) failure' _ = success () 0 input instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -126,7 +135,7 @@ endOfInput = Parser p where p rest success failure | Null.null rest = success () 0 rest- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["endOfInput"])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["endOfInput"]) getInput = Parser p where p rest success _ = success rest len mempty where !len = Factorial.length rest@@ -134,35 +143,35 @@ where p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) -> success first 1 suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["anyToken"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["anyToken"]) satisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s s satisfy predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, suffix) | predicate first -> success first 1 suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfy"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfy"]) satisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s Char satisfyChar predicate = Parser p where p :: forall x. s -> (Char -> Int -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success first 1 suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) satisfyCharInput :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s satisfyCharInput predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Textual.splitCharacterPrefix rest of Just (first, suffix) | predicate first -> success (Factorial.primePrefix rest) 1 suffix- _ -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["satisfyChar"])+ _ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["satisfyChar"]) notSatisfy :: forall s. FactorialMonoid s => (s -> Bool) -> Parser g s () notSatisfy predicate = Parser p where p :: forall x. s -> (() -> Int -> s -> x) -> (FailureInfo -> x) -> x p rest success failure = case Factorial.splitPrimePrefix rest of Just (first, _)- | predicate first -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfy"])+ | predicate first -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfy"]) _ -> success () 0 rest notSatisfyChar :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s () notSatisfyChar predicate = Parser p@@ -170,7 +179,7 @@ p rest success failure = case Textual.characterPrefix rest of Just first | predicate first- -> failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["notSatisfyChar"])+ -> failure (FailureInfo (fromIntegral $ Factorial.length rest) ["notSatisfyChar"]) _ -> success () 0 rest scan :: forall t s. FactorialMonoid t => s -> (s -> t -> Maybe s) -> Parser g t t scan s0 f = Parser (p s0)@@ -197,7 +206,7 @@ | (prefix, suffix) <- Factorial.span predicate rest, !len <- Factorial.length prefix = if len == 0- then failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeWhile1"])+ then failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeWhile1"]) else success prefix len suffix takeCharsWhile :: forall s. TextualMonoid s => (Char -> Bool) -> Parser g s s takeCharsWhile predicate = Parser p@@ -209,7 +218,7 @@ takeCharsWhile1 predicate = Parser p where p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x p rest success failure- | Null.null prefix = failure (FailureInfo 1 (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"])+ | Null.null prefix = failure (FailureInfo (fromIntegral $ Factorial.length rest) ["takeCharsWhile1"]) | otherwise = success prefix len suffix where (prefix, suffix) = Textual.span_ False predicate rest !len = Factorial.length prefix@@ -218,7 +227,7 @@ p :: forall x. s -> (s -> Int -> s -> x) -> (FailureInfo -> x) -> x p s' success failure | Just suffix <- Cancellative.stripPrefix s s', !len <- Factorial.length s = success s len suffix- | otherwise = failure (FailureInfo 1 (fromIntegral $ Factorial.length s') ["string " ++ show s])+ | otherwise = failure (FailureInfo (fromIntegral $ Factorial.length s') ["string " ++ show s]) concatMany :: forall s a. Monoid a => Parser g s a -> Parser g s a concatMany (Parser p) = Parser q where q :: forall x. s -> (a -> Int -> s -> x) -> (FailureInfo -> x) -> x@@ -244,4 +253,4 @@ (Rank2.fmap (<* endOfInput) g) fromFailure :: FactorialMonoid s => s -> FailureInfo -> ParseFailure-fromFailure s (FailureInfo _ pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)+fromFailure s (FailureInfo pos msgs) = ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)
src/Text/Grampa/PEG/Packrat.hs view
@@ -60,7 +60,7 @@ NoParse failure -> NoParse failure instance Alternative (Parser g s) where- empty = Parser (\rest-> NoParse $ FailureInfo 0 (genericLength rest) ["empty"])+ empty = Parser (\rest-> NoParse $ FailureInfo (genericLength rest) ["empty"]) Parser p <|> Parser q = Parser r where r rest = case p rest of x@Parsed{} -> x@@ -85,12 +85,19 @@ mappend = liftA2 mappend instance Factorial.FactorialMonoid s => Parsing (Parser g s) where- try = id- (<?>) = const+ try (Parser p) = Parser q+ where q rest = rewindFailure (p rest)+ where rewindFailure (NoParse (FailureInfo _pos _msgs)) = NoParse (FailureInfo (genericLength rest) [])+ rewindFailure parsed = parsed+ Parser p <?> msg = Parser q+ where q rest = replaceFailure (p rest)+ where replaceFailure (NoParse (FailureInfo pos msgs)) =+ NoParse (FailureInfo pos $ if pos == genericLength rest then [msg] else msgs)+ replaceFailure parsed = parsed eof = endOfInput- unexpected msg = Parser (\t-> NoParse $ FailureInfo 0 (genericLength t) [msg])+ unexpected msg = Parser (\t-> NoParse $ FailureInfo (genericLength t) [msg]) notFollowedBy (Parser p) = Parser (\input-> rewind input (p input))- where rewind t Parsed{} = NoParse (FailureInfo 1 (genericLength t) ["notFollowedBy"])+ where rewind t Parsed{} = NoParse (FailureInfo (genericLength t) ["notFollowedBy"]) rewind t NoParse{} = Parsed () t instance Factorial.FactorialMonoid s => LookAheadParsing (Parser g s) where@@ -115,12 +122,12 @@ type GrammarFunctor Parser = Result nonTerminal f = Parser p where p ((_, d) : _) = f d- p _ = NoParse (FailureInfo 1 0 ["NonTerminal at endOfInput"])+ p _ = NoParse (FailureInfo 0 ["NonTerminal at endOfInput"]) instance MonoidParsing (Parser g) where endOfInput = Parser p where p rest@((s, _) : _)- | not (Null.null s) = NoParse (FailureInfo 1 (genericLength rest) ["endOfInput"])+ | not (Null.null s) = NoParse (FailureInfo (genericLength rest) ["endOfInput"]) p rest = Parsed () rest getInput = Parser p where p rest@((s, _):_) = Parsed s [last rest]@@ -128,35 +135,35 @@ anyToken = Parser p where p rest@((s, _):t) = case Factorial.splitPrimePrefix s of Just (first, _) -> Parsed first t- _ -> NoParse (FailureInfo 1 (genericLength rest) ["anyToken"])- p [] = NoParse (FailureInfo 1 0 ["anyToken"])+ _ -> NoParse (FailureInfo (genericLength rest) ["anyToken"])+ p [] = NoParse (FailureInfo 0 ["anyToken"]) satisfy predicate = Parser p where p rest@((s, _):t) = case Factorial.splitPrimePrefix s of Just (first, _) | predicate first -> Parsed first t- _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfy"])- p [] = NoParse (FailureInfo 1 0 ["satisfy"])+ _ -> NoParse (FailureInfo (genericLength rest) ["satisfy"])+ p [] = NoParse (FailureInfo 0 ["satisfy"]) satisfyChar predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> Parsed first t- _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])- p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])+ _ -> NoParse (FailureInfo (genericLength rest) ["satisfyChar"])+ p [] = NoParse (FailureInfo 0 ["satisfyChar"]) satisfyCharInput predicate = Parser p where p rest@((s, _):t) = case Textual.characterPrefix s of Just first | predicate first -> Parsed (Factorial.primePrefix s) t- _ -> NoParse (FailureInfo 1 (genericLength rest) ["satisfyChar"])- p [] = NoParse (FailureInfo 1 0 ["satisfyChar"])+ _ -> NoParse (FailureInfo (genericLength rest) ["satisfyChar"])+ p [] = NoParse (FailureInfo 0 ["satisfyChar"]) notSatisfy predicate = Parser p where p rest@((s, _):_) | Just (first, _) <- Factorial.splitPrimePrefix s, - predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfy"])+ predicate first = NoParse (FailureInfo (genericLength rest) ["notSatisfy"]) p rest = Parsed () rest notSatisfyChar predicate = Parser p where p rest@((s, _):_) | Just first <- Textual.characterPrefix s, - predicate first = NoParse (FailureInfo 1 (genericLength rest) ["notSatisfyChar"])+ predicate first = NoParse (FailureInfo (genericLength rest) ["notSatisfyChar"]) p rest = Parsed () rest scan s0 f = Parser (p s0) where p s ((i, _):t) = Parsed prefix (drop (Factorial.length prefix - 1) t)@@ -174,7 +181,7 @@ where p rest@((s, _) : _) | x <- Factorial.takeWhile predicate s, not (Null.null x) = Parsed x (Factorial.drop (Factorial.length x) rest)- p rest = NoParse (FailureInfo 1 (genericLength rest) ["takeWhile1"])+ p rest = NoParse (FailureInfo (genericLength rest) ["takeWhile1"]) takeCharsWhile predicate = Parser p where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s =@@ -184,11 +191,11 @@ where p rest@((s, _) : _) | x <- Textual.takeWhile_ False predicate s, not (Null.null x) = Parsed x (drop (Factorial.length x) rest)- p rest = NoParse (FailureInfo 1 (genericLength rest) ["takeCharsWhile1"])+ p rest = NoParse (FailureInfo (genericLength rest) ["takeCharsWhile1"]) string s = Parser p where p rest@((s', _) : _) | Cancellative.isPrefixOf s s' = Parsed s (Factorial.drop (Factorial.length s) rest)- p rest = NoParse (FailureInfo 1 (genericLength rest) ["string " ++ show s])+ p rest = NoParse (FailureInfo (genericLength rest) ["string " ++ show s]) concatMany p = go where go = mappend <$> p <*> go <|> mempty @@ -219,7 +226,7 @@ where gd = Rank2.fmap (`applyParser` parsed) final fromResult :: FactorialMonoid s => s -> Result g s r -> ParseResults (s, r)-fromResult s (NoParse (FailureInfo _ pos msgs)) =+fromResult s (NoParse (FailureInfo pos msgs)) = Left (ParseFailure (Factorial.length s - fromIntegral pos + 1) (nub msgs)) fromResult _ (Parsed prefix []) = Right (mempty, prefix) fromResult _ (Parsed prefix ((s, _):_)) = Right (s, prefix)