simple-parser 0.2.2 → 0.3.0

raw patch · 15 files changed

+1597/−775 lines, 15 filesdep +nonempty-containersdep +scientificdep +text-builderPVP ok

version bump matches the API change (PVP)

Dependencies added: nonempty-containers, scientific, text-builder

API changes (from Hackage documentation)

Files

• README.md +5/−1
• simple-parser.cabal +16/−4
• src/SimpleParser.hs +11/−1
• src/SimpleParser/Chunked.hs +84/−0
• src/SimpleParser/Common.hs +199/−0
• src/SimpleParser/Examples/Json.hs +72/−95
• src/SimpleParser/Examples/Sexp.hs +115/−0
• src/SimpleParser/Explain.hs +135/−0
• src/SimpleParser/Input.hs +85/−52
• src/SimpleParser/Interactive.hs +27/−0
• src/SimpleParser/Parser.hs +269/−170
• src/SimpleParser/Result.hs +100/−23
• src/SimpleParser/Stack.hs +38/−0
• src/SimpleParser/Stream.hs +96/−66
• test/Main.hs +345/−363

@@ -9,4 +9,8 @@     To lists of pairs     Of things and strings. -In this case, we subsitute `ListT` for the list and add some error handling. We also swap out strings for any kind of input (streaming or not).+In this case, our lists are are little fancier.++## License++This project is BSD-licenced. Some gnarly functions to parse numbers and such have been adapted from Megaparsec, which is also [BSD-licensed](https://github.com/mrkkrp/megaparsec/blob/master/LICENSE.md).

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 05dbeeb0f7613ae6d38c54b0654472b0b1d48dc401b57a41cae0dc16554fb065+-- hash: 1d43d6b4332cdf22af4c6c459935317446659f1e7a3e9e1ff035e8447b877d50  name:           simple-parser-version:        0.2.2+version:        0.3.0 synopsis:       Simple parser combinators description:    Please see the README on GitHub at <https://github.com/ejconlon/simple-parser#readme> category:       Parsing@@ -29,16 +29,22 @@ library   exposed-modules:       SimpleParser+      SimpleParser.Chunked+      SimpleParser.Common       SimpleParser.Examples.Json+      SimpleParser.Examples.Sexp+      SimpleParser.Explain       SimpleParser.Input+      SimpleParser.Interactive       SimpleParser.Parser       SimpleParser.Result+      SimpleParser.Stack       SimpleParser.Stream   other-modules:       Paths_simple_parser   hs-source-dirs:       src-  default-extensions: BangPatterns DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies+  default-extensions: BangPatterns ConstraintKinds DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds   build-depends:       base >=4.12 && <5@@ -46,7 +52,10 @@     , list-t >=1.0 && <1.1     , mmorph >=1.1 && <1.2     , mtl >=2.2 && <2.3+    , nonempty-containers >=0.3 && <0.4+    , scientific >=0.3 && <0.4     , text >=1.2 && <1.3+    , text-builder >=0.6 && <0.7   default-language: Haskell2010  test-suite simple-parser-test@@ -56,7 +65,7 @@       Paths_simple_parser   hs-source-dirs:       test-  default-extensions: BangPatterns DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies+  default-extensions: BangPatterns ConstraintKinds DeriveFunctor DeriveFoldable DeriveTraversable DerivingStrategies FlexibleContexts FlexibleInstances FunctionalDependencies GeneralizedNewtypeDeriving KindSignatures MultiParamTypeClasses TypeFamilies   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -fno-warn-unused-top-binds -threaded -rtsopts -with-rtsopts=-N   build-depends:       base >=4.12 && <5@@ -64,9 +73,12 @@     , list-t >=1.0 && <1.1     , mmorph >=1.1 && <1.2     , mtl >=2.2 && <2.3+    , nonempty-containers >=0.3 && <0.4+    , scientific >=0.3 && <0.4     , simple-parser     , tasty     , tasty-hunit     , tasty-th     , text >=1.2 && <1.3+    , text-builder >=0.6 && <0.7   default-language: Haskell2010

@@ -4,13 +4,23 @@ -- "SimpleParser.Parser" for the core transformer, "SimpleParser.Stream" for the source abstraction, -- or "SimpleParser.Input" for useful combinators. module SimpleParser-  ( module SimpleParser.Input+  ( module SimpleParser.Chunked+  , module SimpleParser.Common+  , module SimpleParser.Explain+  , module SimpleParser.Input+  , module SimpleParser.Interactive   , module SimpleParser.Parser   , module SimpleParser.Result+  , module SimpleParser.Stack   , module SimpleParser.Stream   ) where +import SimpleParser.Chunked+import SimpleParser.Common+import SimpleParser.Explain import SimpleParser.Input+import SimpleParser.Interactive import SimpleParser.Parser import SimpleParser.Result+import SimpleParser.Stack import SimpleParser.Stream

@@ -0,0 +1,84 @@+module SimpleParser.Chunked+  ( Chunked (..)+  , TextualChunked (..)+  ) where++import Data.Foldable (toList)+import Data.List (uncons)+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Text as T+import Text.Builder (Builder)+import qualified Text.Builder as TB++-- | 'Chunked' captures the basic relationship between tokens and chunks of them.+-- Basically, these things behave like lists, sequences, text, etc.+class Monoid chunk => Chunked chunk token | chunk -> token where+  consChunk :: token -> chunk -> chunk+  unconsChunk :: chunk -> Maybe (token, chunk)+  tokenToChunk :: token -> chunk+  tokensToChunk :: [token] -> chunk+  chunkToTokens :: chunk -> [token]+  chunkLength :: chunk -> Int+  chunkEmpty :: chunk -> Bool++  -- | Some datatypes (like 'Seq') may admit a "better" implementation+  -- for building a chunk in reverse.+  revTokensToChunk :: [token] -> chunk+  revTokensToChunk = tokensToChunk . reverse++-- | Captures textual streams.+class Chunked chunk Char => TextualChunked chunk where+  buildChunk :: chunk -> Builder+  packChunk :: chunk -> Text+  packChunk = TB.run . buildChunk+  unpackChunk :: Text -> chunk++-- TODO(ejconlon) Add instances for Strict BS, Lazy BS, and Lazy Text++instance Chunked [a] a where+  consChunk = (:)+  unconsChunk = uncons+  tokenToChunk a = [a]+  tokensToChunk = id+  chunkToTokens = id+  chunkLength = length+  chunkEmpty = null++instance (a ~ Char) => TextualChunked [a] where+  buildChunk = TB.string+  packChunk = T.pack+  unpackChunk = T.unpack++instance Chunked (Seq a) a where+  consChunk = (:<|)+  unconsChunk s =+    case s of+      Empty -> Nothing+      a :<| b -> Just (a, b)+  tokenToChunk = Seq.singleton+  tokensToChunk = Seq.fromList+  chunkToTokens = toList+  chunkLength = Seq.length+  chunkEmpty = Seq.null+  revTokensToChunk = foldr (flip (:|>)) Empty++instance (a ~ Char) => TextualChunked (Seq a) where+  buildChunk = TB.string . toList+  packChunk = T.pack . toList+  unpackChunk = Seq.fromList . T.unpack++instance Chunked Text Char where+  consChunk = T.cons+  unconsChunk = T.uncons+  tokenToChunk = T.singleton+  tokensToChunk = T.pack+  chunkToTokens = T.unpack+  chunkLength = T.length+  chunkEmpty = T.null++instance TextualChunked Text where+  buildChunk = TB.text+  packChunk = id+  unpackChunk = id

@@ -0,0 +1,199 @@+-- | Common parsers.+-- See <https://hackage.haskell.org/package/megaparsec-9.0.1/docs/Text-Megaparsec-Char-Lexer.html Text.Megaparsec.Char.Lexer>.+module SimpleParser.Common+  ( TextLabel (..)+  , EmbedTextLabel (..)+  , CompoundTextLabel (..)+  , sepByParser+  , betweenParser+  , lexemeParser+  , newlineParser+  , spaceParser+  , hspaceParser+  , spaceParser1+  , hspaceParser1+  , decimalParser+  , signedNumStartPred+  , scientificParser+  , signedParser+  , escapedStringParser+  , spanParser+  , getStreamPos+  ) where++import Control.Monad (void)+import Control.Monad.State (get, gets)+import Data.Char (digitToInt, isDigit, isSpace)+import Data.List (foldl')+import Data.Scientific (Scientific)+import qualified Data.Scientific as Sci+import SimpleParser.Chunked (Chunked (..))+import SimpleParser.Input (dropTokensWhile, dropTokensWhile1, foldTokensWhile, matchToken, takeTokensWhile1)+import SimpleParser.Parser (ParserT, defaultParser, greedyStarParser, optionalParser, orParser)+import SimpleParser.Stream (Span (..), Stream (..))++-- | Enumeration of common labels in textual parsing.+data TextLabel =+    TextLabelSpace+  | TextLabelHSpace+  | TextLabelDigit+  deriving (Eq, Show)++class EmbedTextLabel l where+  embedTextLabel :: TextLabel -> l++instance EmbedTextLabel TextLabel where+  embedTextLabel = id++-- | Union of text and custom labels+data CompoundTextLabel l =+    CompoundTextLabelText !TextLabel+  | CompoundTextLabelCustom !l+  deriving (Eq, Show, Functor, Foldable, Traversable)++instance EmbedTextLabel (CompoundTextLabel l) where+  embedTextLabel = CompoundTextLabelText++-- | Yields the maximal list of separated items. May return an empty list.+sepByParser :: (Chunked seq elem, Monad m) =>+  -- | How to parse item+  ParserT l s e m elem ->+  -- | How to parse separator+  ParserT l s e m () ->+  ParserT l s e m seq+sepByParser thing sep = do+  ma <- optionalParser thing+  case ma of+    Nothing -> pure mempty+    Just a -> do+      as <- greedyStarParser (sep *> thing)+      pure (consChunk a as)++-- | Parses between start and end markers.+betweenParser :: Monad m =>+  -- | How to parse start+  ParserT l s e m () ->+  -- | How to parse end+  ParserT l s e m () ->+  -- | How to parse inside+  ParserT l s e m a ->+  ParserT l s e m a+betweenParser start end thing = do+  start+  a <- thing+  end+  pure a++-- | A wrapper for lexemes (equivalent to Megaparsec's 'lexeme').+lexemeParser :: Monad m =>+  -- | How to consume white space after lexeme+  ParserT l s e m () ->+  -- | How to parse actual lexeme+  ParserT l s e m a ->+  ParserT l s e m a+lexemeParser spc p = p <* spc++-- | Consumes a newline character.+newlineParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()+newlineParser = void (matchToken '\n')++-- | Consumes 0 or more space characters.+spaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()+spaceParser = void (dropTokensWhile isSpace)++isHSpace :: Char -> Bool+isHSpace c = isSpace c && c /= '\n' && c /= '\r'++-- | Consumes 0 or more non-line-break space characters+hspaceParser :: (Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()+hspaceParser = void (dropTokensWhile isHSpace)++-- | Consumes 1 or more space characters.+spaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()+spaceParser1 = void (dropTokensWhile1 (Just (embedTextLabel TextLabelSpace)) isSpace)++-- | Consumes 1 or more non-line-break space characters+hspaceParser1 :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m ()+hspaceParser1 = void (dropTokensWhile1 (Just (embedTextLabel TextLabelHSpace)) isHSpace)++-- | Parses an integer in decimal representation (equivalent to Megaparsec's 'decimal').+decimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m, Num a) => ParserT l s e m a+decimalParser = fmap mkNum (takeTokensWhile1 (Just (embedTextLabel TextLabelDigit)) isDigit) where+  mkNum = foldl' step 0 . chunkToTokens+  step a c = a * 10 + fromIntegral (digitToInt c)++data SP = SP !Integer !Int++dotDecimalParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Integer -> ParserT l s e m SP+dotDecimalParser c' = do+  void (matchToken '.')+  let mkNum = foldl' step (SP c' 0) . chunkToTokens+      step (SP a e') c = SP (a * 10 + fromIntegral (digitToInt c)) (e' - 1)+  fmap mkNum (takeTokensWhile1 (Just (embedTextLabel TextLabelDigit)) isDigit)++exponentParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => Int -> ParserT l s e m Int+exponentParser e' = do+  void (orParser (matchToken 'e') (matchToken 'E'))+  fmap (+ e') (signedParser (pure ()) decimalParser)++-- | Predicate for satisfying the start of signed numbers+signedNumStartPred :: Char -> Bool+signedNumStartPred c = isDigit c || c == '+' || c == '-'++-- | Parses a floating point value as a 'Scientific' number (equivalent to Megaparsec's 'scientific').+scientificParser :: (EmbedTextLabel l, Stream s, Token s ~ Char, Monad m) => ParserT l s e m Scientific+scientificParser = do+  c' <- decimalParser+  SP c e' <- defaultParser (SP c' 0) (dotDecimalParser c')+  e <- defaultParser e' (exponentParser e')+  pure (Sci.scientific c e)++-- | Parses an optional sign character followed by a number and yields a correctly-signed+-- number (equivalend to Megaparsec's 'signed').+signedParser :: (Stream s, Token s ~ Char, Monad m, Num a) =>+  -- | How to consume white space after the sign+  ParserT l s e m () ->+  -- | How to parse the number itself+  ParserT l s e m a ->+  -- | Parser for signed numbers+  ParserT l s e m a+signedParser spc p = defaultParser id (lexemeParser spc sign) <*> p where+  sign = orParser (id <$ matchToken '+') (negate <$ matchToken '-')++data Pair = Pair ![Char] !Bool++-- | Given a quote charcter (like a single or double quote), yields the contents of the+-- string bounded by those quotes. The contents may contain backslash-escaped quotes.+-- Returns nothing if outside quotes are missing or the stream ends before unquote.+escapedStringParser :: (Stream s, Token s ~ Char, Monad m) => Char -> ParserT l s e m (Chunk s)+escapedStringParser quoteChar =+  let quoteParser = void (matchToken quoteChar)+      accParser = foldTokensWhile go (Pair [] False)+      innerParser = fmap (\(Pair acc _) -> revTokensToChunk acc) accParser+      escChar = '\\'+      go c (Pair acc esc)+        | c == escChar =+          if esc+            then (True, Pair (escChar:acc) False) -- Was escaped escape, append one+            else (True, Pair acc True) -- Skip appending this esc+        | c == quoteChar =+          if esc+            then (True, Pair (c:acc) False) -- Escaped quote+            else (False, Pair acc False) -- End of quote+        | otherwise =+          if esc+            then (True, Pair (c:escChar:acc) False) -- Was a non-quote esc, append both+            else (True, Pair (c:acc) False) -- Just consume char+  in betweenParser quoteParser quoteParser innerParser++-- | Adds span information to parsed values.+spanParser :: (Stream s, Monad m) => (Span (Pos s) -> a -> b) -> ParserT l s e m a -> ParserT l s e m b+spanParser f p = do+  start <- get+  val <- p+  end <- get+  pure (f (Span (streamViewPos start) (streamViewPos end)) val)++-- | Gets the current stream position+getStreamPos :: (Stream s, Monad m) => ParserT l s e m (Pos s)+getStreamPos = gets streamViewPos

@@ -3,131 +3,108 @@ module SimpleParser.Examples.Json   ( Json (..)   , JsonF (..)-  , parseJson+  , JsonParserC+  , JsonParserM+  , jsonParser+  , recJsonParser   ) where -import Control.Applicative (empty) import Control.Monad (void)-import Data.Char (isSpace)+import Data.Foldable (asum)+import Data.Scientific (Scientific)+import Data.Sequence (Seq) import Data.Text (Text) import Data.Void (Void)-import SimpleParser+import SimpleParser.Chunked (TextualChunked (..))+import SimpleParser.Common (TextLabel, betweenParser, escapedStringParser, lexemeParser, scientificParser, sepByParser,+                            signedNumStartPred, spaceParser)+import SimpleParser.Input (matchChunk, matchToken, satisfyToken)+import SimpleParser.Parser (Parser, commitParser, onEmptyParser, orParser)+import SimpleParser.Stream (Stream (..), TextualStream) --- JSON without numbers... data JsonF a =-    JsonObject ![(String, a)]-  | JsonArray ![a]-  | JsonString !String+    JsonObject !(Seq (Text, a))+  | JsonArray !(Seq a)+  | JsonString !Text   | JsonBool !Bool+  | JsonNum !Scientific   | JsonNull   deriving (Eq, Show, Functor, Foldable, Traversable)  newtype Json = Json { unJson :: JsonF Json } deriving (Eq, Show) -type JsonParser a = Parser Void Text a--parseJson :: Text -> [Json]-parseJson str = do-  ParseResult v _ <- runParser (jsonParser <* matchEnd) str-  case v of-    ParseSuccess a -> pure a+type JsonParserC s = (TextualStream s, Eq (Chunk s)) -jsonSpace :: JsonParser ()-jsonSpace = greedyStarParser_ (void (satisfyToken isSpace))+type JsonParserM s a = Parser TextLabel s Void a -jsonLexeme :: JsonParser () -> JsonParser a -> JsonParser a-jsonLexeme spaceAfter thing = do-  a <- thing-  spaceAfter-  pure a+jsonParser :: JsonParserC s => JsonParserM s Json+jsonParser = let p = fmap Json (recJsonParser p) in p -jsonBetween :: JsonParser () -> JsonParser () -> JsonParser a -> JsonParser a-jsonBetween start end thing = do-  start-  a <- thing-  end-  pure a+isBoolStartPred :: Char -> Bool+isBoolStartPred c = c == 't' || c == 'f' -jsonSepBy :: JsonParser a -> JsonParser () -> JsonParser [a]-jsonSepBy thing sep = go [] where-  optThing = optionalParser thing-  optSep = optionalParser sep-  go !acc = do-    ma <- optThing-    case ma of-      Nothing -> if null acc then pure [] else empty-      Just a -> do-        let newAcc = a:acc-        ms <- optSep-        case ms of-          Nothing -> pure (reverse newAcc)-          Just () -> go newAcc+recJsonParser :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)+recJsonParser root = onEmptyParser (asum opts) (fail "failed to parse json document") where+  pairP = objectPairP root+  opts =+    [ commitParser openBraceP (objectP pairP)+    , commitParser openBracketP (arrayP root)+    , commitParser openQuoteP stringP+    , commitParser (void (satisfyToken Nothing signedNumStartPred)) numP+    , commitParser (void (satisfyToken Nothing isBoolStartPred)) boolP+    , commitParser (void (matchToken 'n')) nullP+    ] -jsonCharLexeme :: Char -> JsonParser ()-jsonCharLexeme c = void (jsonLexeme jsonSpace (matchToken c))+spaceP :: JsonParserC s => JsonParserM s ()+spaceP = spaceParser -jsonWordLexeme :: Text -> JsonParser ()-jsonWordLexeme cs = void (jsonLexeme jsonSpace (matchChunk cs))+tokL :: JsonParserC s => Char -> JsonParserM s ()+tokL c = lexemeParser spaceP (void (matchToken c)) -openBrace, closeBrace, comma, colon, openBracket, closeBracket, closeQuote :: JsonParser ()-openBrace = jsonCharLexeme '{'-closeBrace = jsonCharLexeme '}'-comma = jsonCharLexeme ','-colon = jsonCharLexeme ':'-openBracket = jsonCharLexeme '['-closeBracket = jsonCharLexeme ']'-closeQuote = jsonCharLexeme '"'+chunkL :: JsonParserC s => Text -> JsonParserM s ()+chunkL cs = lexemeParser spaceP (void (matchChunk (unpackChunk cs))) -openQuote :: JsonParser ()-openQuote = void (matchToken '"')+openBraceP, closeBraceP, commaP, colonP, openBracketP, closeBracketP, closeQuoteP :: JsonParserC s => JsonParserM s ()+openBraceP = tokL '{'+closeBraceP = tokL '}'+commaP = tokL ','+colonP = tokL ':'+openBracketP = tokL '['+closeBracketP = tokL ']'+closeQuoteP = tokL '"' -nullTok, trueTok, falseTok :: JsonParser ()-nullTok = jsonWordLexeme "null"-trueTok = jsonWordLexeme "true"-falseTok = jsonWordLexeme "false"+openQuoteP :: JsonParserC s => JsonParserM s ()+openQuoteP = void (matchToken '"') -nonQuoteChar :: JsonParser Char-nonQuoteChar = satisfyToken (/= '"')+nullTokP, trueTokP, falseTokP :: JsonParserC s => JsonParserM s ()+nullTokP = chunkL "null"+trueTokP = chunkL "true"+falseTokP = chunkL "false" -nonQuoteString :: JsonParser String-nonQuoteString = greedyStarParser nonQuoteChar+rawStringP :: JsonParserC s => JsonParserM s Text+rawStringP = fmap packChunk (escapedStringParser '"') -rawStringParser :: JsonParser String-rawStringParser = jsonBetween openQuote closeQuote nonQuoteString+stringP :: JsonParserC s => JsonParserM s (JsonF a)+stringP = fmap JsonString rawStringP --- TODO(ejconlon) This does not handle escape codes. Use `foldTokensWhile` for that...-stringParser :: JsonParser (JsonF a)-stringParser = fmap JsonString rawStringParser+nullP :: JsonParserC s => JsonParserM s (JsonF a)+nullP = JsonNull <$ nullTokP -nullParser :: JsonParser (JsonF a)-nullParser = JsonNull <$ nullTok+boolP :: JsonParserC s => JsonParserM s (JsonF a)+boolP = orParser (JsonBool True <$ trueTokP) (JsonBool False <$ falseTokP) -boolParser :: JsonParser (JsonF a)-boolParser = isolateParser (branchParser [JsonBool True <$ trueTok, JsonBool False <$ falseTok])+numP :: JsonParserC s => JsonParserM s (JsonF a)+numP = fmap JsonNum scientificParser -objectPairParser :: JsonParser a -> JsonParser (String, a)-objectPairParser root = do-  name <- rawStringParser-  colon+objectPairP :: JsonParserC s => JsonParserM s a -> JsonParserM s (Text, a)+objectPairP root = do+  name <- rawStringP+  colonP   value <- root   pure (name, value) -objectParser :: JsonParser (String, a) -> JsonParser (JsonF a)-objectParser pairParser = jsonBetween openBrace closeBrace (fmap JsonObject (jsonSepBy pairParser comma))--arrayParser :: JsonParser a -> JsonParser (JsonF a)-arrayParser root = jsonBetween openBracket closeBracket (fmap JsonArray (jsonSepBy root comma))--rootParser :: JsonParser a -> JsonParser (JsonF a)-rootParser root = isolateParser (branchParser opts) where-  pairParser = objectPairParser root-  opts =-    [ objectParser pairParser-    , arrayParser root-    , stringParser-    , boolParser-    , nullParser-    ]+objectP :: JsonParserC s => JsonParserM s (Text, a) -> JsonParserM s (JsonF a)+objectP pairP = betweenParser openBraceP closeBraceP (fmap JsonObject (sepByParser pairP commaP)) -jsonParser :: JsonParser Json-jsonParser = let p = fmap Json (rootParser p) in p+arrayP :: JsonParserC s => JsonParserM s a -> JsonParserM s (JsonF a)+arrayP root = betweenParser openBracketP closeBracketP (fmap JsonArray (sepByParser root commaP))

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++module SimpleParser.Examples.Sexp+  ( Sexp (..)+  , SexpF (..)+  , Atom (..)+  , SexpLabel (..)+  , SexpParserC+  , SexpParserM+  , sexpParser+  , recSexpParser+  ) where++import Control.Monad (void)+import Data.Char (isDigit, isSpace)+import Data.Foldable (asum)+import Data.Scientific (Scientific)+import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Void (Void)+import SimpleParser.Chunked (Chunked (..), packChunk)+import SimpleParser.Common (EmbedTextLabel (..), TextLabel, betweenParser, decimalParser, escapedStringParser,+                            lexemeParser, scientificParser, sepByParser, signedNumStartPred, signedParser, spaceParser)+import SimpleParser.Explain (ExplainLabel (..))+import SimpleParser.Input (matchToken, satisfyToken, takeTokensWhile)+import SimpleParser.Parser (Parser, commitParser, onEmptyParser, orParser)+import SimpleParser.Stream (TextualStream)++data Atom =+    AtomIdent !Text+  | AtomString !Text+  | AtomInt !Integer+  | AtomFloat !Scientific+  deriving (Eq, Show)++data SexpF a =+    SexpAtom !Atom+  | SexpList !(Seq a)+  deriving (Eq, Show, Functor, Foldable, Traversable)++data SexpLabel =+    SexpLabelIdentStart+  | SexpLabelEmbedText !TextLabel+  deriving (Eq, Show)++instance ExplainLabel SexpLabel where+  explainLabel sl =+    case sl of+      SexpLabelIdentStart -> "start of identifier"+      SexpLabelEmbedText tl -> explainLabel tl++instance EmbedTextLabel SexpLabel where+  embedTextLabel = SexpLabelEmbedText++newtype Sexp = Sexp { unSexp :: SexpF Sexp }+  deriving (Eq, Show)++type SexpParserC s = TextualStream s++type SexpParserM s a = Parser SexpLabel s Void a++sexpParser :: SexpParserC s => SexpParserM s Sexp+sexpParser = let p = fmap Sexp (recSexpParser p) in p++recSexpParser :: SexpParserC s => SexpParserM s a -> SexpParserM s (SexpF a)+recSexpParser root = onEmptyParser (orParser lp ap) (fail "failed to parse sexp document") where+  lp = commitParser openParenP (fmap SexpList (listP root))+  ap = fmap SexpAtom atomP++nonDelimPred :: Char -> Bool+nonDelimPred c = c /= '(' && c /= ')' && not (isSpace c)++identStartPred :: Char -> Bool+identStartPred c = not (isDigit c) && identContPred c++identContPred :: Char -> Bool+identContPred c = c /= '"' && nonDelimPred c++stringP :: SexpParserC s => SexpParserM s Text+stringP = fmap packChunk (escapedStringParser '"')++identifierP :: SexpParserC s => SexpParserM s Text+identifierP = do+  x <- satisfyToken (Just SexpLabelIdentStart) identStartPred+  xs <- takeTokensWhile identContPred+  pure (packChunk (consChunk x xs))++spaceP :: SexpParserC s => SexpParserM s ()+spaceP = spaceParser++lexP :: SexpParserC s => SexpParserM s a -> SexpParserM s a+lexP = lexemeParser spaceP++openParenP :: SexpParserC s => SexpParserM s ()+openParenP = lexP (void (matchToken '('))++closeParenP :: SexpParserC s => SexpParserM s ()+closeParenP = lexP (void (matchToken ')'))++intP :: SexpParserC s => SexpParserM s Integer+intP = signedParser (pure ()) decimalParser++floatP :: SexpParserC s => SexpParserM s Scientific+floatP = signedParser (pure ()) scientificParser++atomP :: SexpParserC s => SexpParserM s Atom+atomP = lexP $ asum+  [ commitParser (void (matchToken '"')) (fmap AtomString stringP)+  , commitParser (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomInt intP)+  , commitParser (void (satisfyToken Nothing signedNumStartPred)) (fmap AtomFloat floatP)+  , commitParser (void (satisfyToken Nothing identStartPred)) (fmap AtomIdent identifierP)+  ]++listP :: SexpParserC s => SexpParserM s a -> SexpParserM s (Seq a)+listP root = lexP (betweenParser openParenP closeParenP (sepByParser root spaceP))

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE UndecidableInstances #-}++module SimpleParser.Explain where++import Control.Monad (join)+import Data.Foldable (toList)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Text (Text)+import Data.Void (Void, absurd)+import SimpleParser.Chunked (TextualChunked (..))+import SimpleParser.Common (CompoundTextLabel (..), TextLabel (..))+import SimpleParser.Result (CompoundError (..), ParseError (..), RawError (..), StreamError (..),+                            parseErrorEnclosingLabels, parseErrorNarrowestSpan)+import SimpleParser.Stream (LinePos (..), Span (..), Stream (..), TextualStream)+import Text.Builder (Builder)+import qualified Text.Builder as TB++class ExplainLabel l where+  explainLabel :: l -> Builder++  explainLabelText :: l -> Text+  explainLabelText = TB.run . explainLabel++instance ExplainLabel Void where+  explainLabel = absurd++instance ExplainLabel TextLabel where+  explainLabel l =+    case l of+      TextLabelSpace -> "space"+      TextLabelHSpace -> "non-line-breaking space"+      TextLabelDigit -> "digit"++instance ExplainLabel l => ExplainLabel (CompoundTextLabel l) where+  explainLabel c =+    case c of+      CompoundTextLabelText l -> explainLabel l+      CompoundTextLabelCustom l -> explainLabel l++data ErrorExplanation = ErrorExplanation+  { eeReason :: !Builder+  , eeExpected :: !(Maybe Builder)+  , eeActual :: !(Maybe Builder)+  }++class ExplainError e where+  explainError :: e -> ErrorExplanation++instance ExplainError Void where+  explainError = absurd++endMsg :: Builder+endMsg = "end of stream"++tokB :: Char -> Builder+tokB t = "token '" <> TB.char t <> "'"++mayTokB :: Maybe Char -> Builder+mayTokB = maybe endMsg tokB++chunkB :: TextualChunked chunk => chunk -> Builder+chunkB k = "chunk \"" <> buildChunk k <> "\""++mayChunkB :: TextualChunked chunk => Maybe chunk -> Builder+mayChunkB = maybe endMsg chunkB++instance (Token s ~ Char, TextualChunked (Chunk s)) => ExplainError (StreamError s) where+  explainError (StreamError re) =+    case re of+      RawErrorMatchEnd actTok ->+        ErrorExplanation "failed to match end of stream" (Just endMsg) (Just (tokB actTok))+      RawErrorAnyToken ->+        ErrorExplanation "failed to match any token" (Just "any token") (Just endMsg)+      RawErrorAnyChunk ->+        ErrorExplanation "failed to match any chunk" (Just "any chunk") (Just endMsg)+      RawErrorSatisfyToken mayActTok ->+        ErrorExplanation "failed to satisfy token predicate" Nothing (Just (mayTokB mayActTok))+      RawErrorMatchToken expTok mayActTok ->+        ErrorExplanation "failed to match token" (Just (tokB expTok)) (Just (mayTokB mayActTok))+      RawErrorMatchChunk expChunk mayActChunk ->+        ErrorExplanation "failed to match chunk" (Just (chunkB expChunk)) (Just (mayChunkB mayActChunk))+      RawErrorTakeTokensWhile1 mayActTok ->+        ErrorExplanation "failed to take 1 or more tokens" Nothing (Just (mayTokB mayActTok))+      RawErrorDropTokensWhile1 mayActTok ->+        ErrorExplanation "failed to drop 1 or more tokens" Nothing (Just (mayTokB mayActTok))++instance (Token s ~ Char, TextualChunked (Chunk s), ExplainError e) => ExplainError (CompoundError s e) where+  explainError ce =+    case ce of+      CompoundErrorStream se -> explainError se+      CompoundErrorFail msg -> ErrorExplanation (TB.text msg) Nothing Nothing+      CompoundErrorCustom e -> explainError e++type Explainable l s e = (TextualStream s, ExplainLabel l, ExplainError e)++data ParseErrorExplanation p = ParseErrorExplanation+  { peeSpan :: !(Span p)+  , peeContext :: !(Seq Builder)+  , peeDetails :: !(Maybe Builder)+  , peeErrExp :: !ErrorExplanation+  }++explainParseError :: Explainable l s e => ParseError l s e -> ParseErrorExplanation (Pos s)+explainParseError pe =+  let (mayLab, sp) = parseErrorNarrowestSpan pe+      context = fmap explainLabel (parseErrorEnclosingLabels pe)+      mayDetails = fmap explainLabel mayLab+      errExp = explainError (peError pe)+  in ParseErrorExplanation sp context mayDetails errExp++buildSpan :: Span LinePos -> Builder+buildSpan (Span (LinePos _ sl sc) (LinePos _ el ec)) =+  TB.decimal (succ sl) <> ":" <> TB.decimal (succ sc) <> "-" <> TB.decimal (succ el) <> ":" <> TB.decimal (succ ec)++buildErrorExplanation :: Maybe Builder -> ErrorExplanation -> [Builder]+buildErrorExplanation mayDetails (ErrorExplanation reason mayExpected mayActual) = join+  [ ["[Reason  ] " <> reason]+  , maybe [] (\de -> ["[Details ] " <> de]) mayDetails+  , maybe [] (\ex -> ["[Expected] " <> ex]) mayExpected+  , maybe [] (\ac -> ["[Actual  ] " <> ac]) mayActual+  ]++buildParseErrorExplanation :: ParseErrorExplanation LinePos -> Builder+buildParseErrorExplanation (ParseErrorExplanation sp context mayDetails errExp) =+  let hd = join+        [ ["[Pos       ] " <> buildSpan sp]+        , ["[Context   ] || " <> TB.intercalate " |> " context | not (Seq.null context)]+        ]+      tl = buildErrorExplanation mayDetails errExp+  in TB.intercalate "\n" (hd ++ tl)++buildAllParseErrorExplanations :: Foldable f => f (ParseErrorExplanation LinePos) -> Builder+buildAllParseErrorExplanations = TB.intercalate "\n\n" . fmap buildParseErrorExplanation . toList

@@ -1,6 +1,9 @@ -- | Useful combinators for 'ParserT' and 'Stream'.+-- Classified as SAFE or UNSAFE. SAFE always return a value. UNSAFE throw. module SimpleParser.Input-  ( peekToken+  ( withToken+  , withChunk+  , peekToken   , popToken   , peekChunk   , popChunk@@ -19,99 +22,129 @@   , matchChunk   ) where -import Control.Applicative (empty) import Control.Monad.State (gets, state) import Data.Bifunctor (first) import Data.Maybe (isNothing)-import SimpleParser.Parser (ParserT)-import SimpleParser.Stream (Chunked (..), Stream (..))+import SimpleParser.Chunked (Chunked (..))+import SimpleParser.Parser (ParserT (..), markWithOptStateParser, markWithStateParser)+import SimpleParser.Result (CompoundError (..), ParseError (..), ParseResult (..), RawError (..), StreamError (..))+import SimpleParser.Stack (emptyStack)+import SimpleParser.Stream (Stream (..)) --- | Return the next token, if any, but don't consume it.-peekToken :: (Stream s, Monad m) => ParserT e s m (Maybe (Token s))+throwStreamError :: Monad m => RawError (Chunk s) (Token s) -> ParserT l s e m a+throwStreamError re = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorStream (StreamError re)))))))++-- | Fetches the next token from the stream and runs the callback.+withToken :: (Stream s, Monad m) => Maybe l -> (Maybe (Token s) -> ParserT l s e m a) -> ParserT l s e m a+withToken ml = markWithOptStateParser ml streamTake1++-- | Fetches the next chunk from the stream and runs the callback.+withChunk :: (Stream s, Monad m) => Maybe l -> Int -> (Maybe (Chunk s) -> ParserT l s e m a) -> ParserT l s e m a+withChunk ml n = markWithOptStateParser ml (streamTakeN n)++-- | Return the next token, if any, but don't consume it. (SAFE)+peekToken :: (Stream s, Monad m) => ParserT l s e m (Maybe (Token s)) peekToken = gets (fmap fst . streamTake1) --- | Return the next token, if any, and consume it.-popToken :: (Stream s, Monad m) => ParserT e s m (Maybe (Token s))+-- | Return the next token, if any, and consume it. (SAFE)+popToken :: (Stream s, Monad m) => ParserT l s e m (Maybe (Token s)) popToken = state (\stream -> maybe (Nothing, stream) (first Just) (streamTake1 stream))  -- | Return the next chunk of the given size, if any, but don't consume it.--- May return a smaller chunk at end of stream, but never returns an empty chunk.-peekChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe (Chunk s))+-- May return a smaller chunk at end of stream, but never returns an empty chunk. (SAFE)+peekChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe (Chunk s)) peekChunk n = gets (fmap fst . streamTakeN n)  -- | Return the next chunk of the given size, if any, and consume it.--- May return a smaller chunk at end of stream, but never returns an empty chunk.-popChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe (Chunk s))+-- May return a smaller chunk at end of stream, but never returns an empty chunk. (SAFE)+popChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe (Chunk s)) popChunk n = state (\stream -> maybe (Nothing, stream) (first Just) (streamTakeN n stream))  -- | Drop the next chunk of the given size, if any, and consume it.--- May return a smaller size at end of stream, but never returns size 0.-dropChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Maybe Int)+-- May return a smaller size at end of stream, but never returns size 0. (SAFE)+dropChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Maybe Int) dropChunk n = state (\stream -> maybe (Nothing, stream) (first Just) (streamDropN n stream)) --- | Is this the end of the stream?-isEnd :: (Stream s, Monad m) => ParserT e s m Bool-isEnd = isNothing <$> peekToken+-- | Is this the end of the stream? (SAFE)+isEnd :: (Stream s, Monad m) => ParserT l s e m Bool+isEnd = fmap isNothing peekToken --- | Match the end of the stream or terminate the parser.-matchEnd :: (Stream s, Monad m) => ParserT e s m ()-matchEnd = peekToken >>= maybe (pure ()) (const empty)+-- | Match the end of the stream or terminate the parser. (UNSAFE)+matchEnd :: (Stream s, Monad m) => ParserT l s e m ()+matchEnd = withToken Nothing (maybe (pure ()) (throwStreamError . RawErrorMatchEnd)) --- | Return the next token or terminate the parser at end of stream.-anyToken :: (Stream s, Monad m) => ParserT e s m (Token s)-anyToken = popToken >>= maybe empty pure+-- | Return the next token or terminate the parser at end of stream. (UNSAFE)+anyToken :: (Stream s, Monad m) => ParserT l s e m (Token s)+anyToken = withToken Nothing (maybe (throwStreamError RawErrorAnyToken) pure)  -- | Return the next chunk of the given size or terminate the parser at end of stream.--- May return a smaller chunk at end of stream, but never returns an empty chunk.-anyChunk :: (Stream s, Monad m) => Int -> ParserT e s m (Chunk s)-anyChunk n = popChunk n >>= maybe empty pure+-- May return a smaller chunk at end of stream, but never returns an empty chunk. (UNSAFE)+anyChunk :: (Stream s, Monad m) => Int -> ParserT l s e m (Chunk s)+anyChunk n = withChunk Nothing n (maybe (throwStreamError RawErrorAnyChunk) pure) --- | Match the next token with the given predicate or terminate the parser at predicate false or end of stream.-satisfyToken :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Token s)-satisfyToken p = do-  m <- popToken-  case m of-    Just c | p c -> pure c-    _ -> empty+-- | Match the next token with the given predicate or terminate the parser at predicate false or end of stream. (UNSAFE)+satisfyToken :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m (Token s)+satisfyToken ml pcate = withToken ml $ \mu ->+  case mu of+    Just u | pcate u -> pure u+    _ -> throwStreamError (RawErrorSatisfyToken mu)  -- | Folds over a stream of tokens while the boolean value is true.--- Always succeeds, even at end of stream.-foldTokensWhile :: (Stream s, Monad m) => (Token s -> x -> (Bool, x)) -> (x -> x) -> x -> ParserT e s m x-foldTokensWhile f g = go where+-- Always succeeds, even at end of stream. Only consumes greediest match. (SAFE)+foldTokensWhile :: (Stream s, Monad m) => (Token s -> x -> (Bool, x)) -> x -> ParserT l s e m x+foldTokensWhile processNext = go where   go !x = do     m <- peekToken     case m of-      Nothing -> pure (g x)+      Nothing -> pure x       Just c ->-        let (ok, newX) = f c x+        let (ok, newX) = processNext c x         in if ok           then popToken *> go newX           else pure x  -- | Take tokens into a chunk while they satisfy the given predicate.--- Always succeeds, even at end of stream. May return an empty chunk.-takeTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Chunk s)+-- Always succeeds, even at end of stream. May return an empty chunk. Only yields greediest match. (SAFE)+takeTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT l s e m (Chunk s) takeTokensWhile = state . streamTakeWhile  -- | Take tokens into a chunk while they satisfy the given predicate. -- Only succeeds if 1 or more tokens are taken, so it never returns an empty chunk.-takeTokensWhile1 :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m (Chunk s)-takeTokensWhile1 pcate = takeTokensWhile pcate >>= \c -> if chunkEmpty c then empty else pure c+-- Also takes an optional label to describe the predicate. (UNSAFE)+takeTokensWhile1 :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m (Chunk s)+takeTokensWhile1 ml pcate = markWithStateParser ml (streamTakeWhile pcate) $ \j ->+  if chunkEmpty j+    then do+      mu <- peekToken+      throwStreamError (RawErrorTakeTokensWhile1 mu)+    else pure j  -- | Drop tokens and return chunk size while they satisfy the given predicate.--- Always succeeds, even at end of stream. May return empty chunk size 0.-dropTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m Int+-- Always succeeds, even at end of stream. May return empty chunk size 0. Only drops greediest match. (SAFE)+dropTokensWhile :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT l s e m Int dropTokensWhile = state . streamDropWhile  -- | Drop tokens and return chunk size while they satisfy the given predicate. -- Only succeeds if 1 or more tokens are dropped.-dropTokensWhile1 :: (Stream s, Monad m) => (Token s -> Bool) -> ParserT e s m Int-dropTokensWhile1 pcate = dropTokensWhile pcate >>= \s -> if s == 0 then empty else pure s+-- Also takes an optional label to describe the predicate. (UNSAFE)+dropTokensWhile1 :: (Stream s, Monad m) => Maybe l -> (Token s -> Bool) -> ParserT l s e m Int+dropTokensWhile1 ml pcate = markWithStateParser ml (streamDropWhile pcate) $ \s ->+  if s == 0+    then do+      mu <- peekToken+      throwStreamError (RawErrorDropTokensWhile1 mu)+    else pure s --- | Match token with equality or terminate the parser at inequality or end of stream.-matchToken :: (Stream s, Monad m, Eq (Token s)) => Token s -> ParserT e s m (Token s)-matchToken = satisfyToken . (==)+-- | Match token with equality or terminate the parser at inequality or end of stream. (UNSAFE)+matchToken :: (Stream s, Monad m, Eq (Token s)) => Token s -> ParserT l s e m (Token s)+matchToken t = withToken Nothing $ \mu ->+  case mu of+    Just u | t == u -> pure u+    _ -> throwStreamError (RawErrorMatchToken t mu) --- | Match chunk with equality or terminate the parser at inequality or end of stream.-matchChunk :: (Stream s, Monad m, Eq (Chunk s)) => Chunk s -> ParserT e s m (Chunk s)-matchChunk k = popChunk (chunkLength k) >>= maybe empty (\j -> if k == j then pure j else empty)+-- | Match chunk with equality or terminate the parser at inequality or end of stream. (UNSAFE)+matchChunk :: (Stream s, Monad m, Eq (Chunk s)) => Chunk s -> ParserT l s e m (Chunk s)+matchChunk k = withChunk Nothing (chunkLength k) $ \mj ->+  case mj of+    Just j | k == j -> pure j+    _ -> throwStreamError (RawErrorMatchChunk k mj)

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module SimpleParser.Interactive+  ( parseInteractive+  ) where++import Data.Foldable (toList)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import SimpleParser.Explain (Explainable, buildAllParseErrorExplanations, explainParseError)+import SimpleParser.Input (matchEnd)+import SimpleParser.Parser (Parser, runParser)+import SimpleParser.Result (ParseResult (..), ParseSuccess (..))+import SimpleParser.Stream (LinePosStream, newLinePosStream)+import qualified Text.Builder as TB++parseInteractive :: (s ~ LinePosStream Text, Explainable l s e, Show a) => Parser l s e a -> String -> IO ()+parseInteractive parser input =+  case runParser (parser <* matchEnd) (newLinePosStream (T.pack input)) of+    Nothing ->+      putStrLn "No result."+    Just (ParseResultError es) ->+      let b = buildAllParseErrorExplanations (fmap explainParseError (toList es))+      in TIO.putStrLn (TB.run ("Errors:\n" <> b))+    Just (ParseResultSuccess (ParseSuccess _ a)) ->+      putStrLn "Success:" *> print a

@@ -1,21 +1,34 @@+{-# LANGUAGE Rank2Types #-}+ -- | 'ParserT' is the core monad transformer for parsing. module SimpleParser.Parser   ( ParserT (..)   , Parser   , runParser-  , filterParser-  , reflectParser-  , branchParser-  , suppressParser-  , isolateParser-  , defaultParser-  , optionalParser-  , silenceParser+  , pureParser+  , bindParser+  , failParser+  , liftParser+  , hoistParser+  , catchJustParser+  , throwParser+  , catchParser+  , emptyParser+  , orParser   , greedyStarParser   , greedyStarParser_   , greedyPlusParser   , greedyPlusParser_+  , defaultParser+  , optionalParser+  , silenceParser   , lookAheadParser+  , markParser+  , markWithStateParser+  , markWithOptStateParser+  , unmarkParser+  , commitParser+  , onEmptyParser   ) where  import Control.Applicative (Alternative (..), liftA2)@@ -25,205 +38,291 @@ import Control.Monad.Morph (MFunctor (..)) import Control.Monad.State (MonadState (..)) import Control.Monad.Trans (MonadTrans (..))-import Data.Foldable (toList)-import ListT (ListT (..))-import qualified ListT-import SimpleParser.Result (ParseResult (..), ParseValue (..))+import Data.Bifunctor (first)+import Data.Sequence (Seq (..))+import Data.Sequence.NonEmpty ((><|))+import qualified Data.Sequence.NonEmpty as NESeq+import Data.Text (Text)+import qualified Data.Text as T+import SimpleParser.Chunked (Chunked (..))+import SimpleParser.Result (CompoundError (..), Mark (..), ParseError (..), ParseResult (..), ParseSuccess (..),+                            markParseError, parseErrorResume, unmarkParseError)+import SimpleParser.Stack (emptyStack)  -- | A 'ParserT' is a state/error/list transformer useful for parsing. -- All MTL instances are for this transformer only. If, for example, your effect -- has its own 'MonadState' instance, you'll have to use 'lift get' instead of 'get'.-newtype ParserT e s m a = ParserT { runParserT :: s -> ListT m (ParseResult e s a) }+newtype ParserT l s e m a = ParserT { runParserT :: s -> m (Maybe (ParseResult l s e a)) }   deriving (Functor)  -- | Use 'Parser' if you have no need for other monadic effects.-type Parser e s a = ParserT e s Identity a+type Parser l s e a = ParserT l s e Identity a -instance Monad m => Applicative (ParserT e s m) where-  pure a = ParserT (pure . ParseResult (ParseSuccess a))+-- | Runs a non-effectful parser from an inital state and collects all results.+runParser :: Parser l s e a -> s -> Maybe (ParseResult l s e a)+runParser parser s = runIdentity (runParserT parser s)++-- | Applicative pure+pureParser :: Monad m => a -> ParserT l s e m a+pureParser a = ParserT (\s -> pure (Just (ParseResultSuccess (ParseSuccess s a))))++instance Monad m => Applicative (ParserT l s e m) where+  pure = pureParser   (<*>) = ap -instance Monad m => Monad (ParserT e s m) where+-- | Monadic bind+bindParser :: Monad m => ParserT l s e m a -> (a -> ParserT l s e m b) -> ParserT l s e m b+bindParser parser f = ParserT (runParserT parser >=> go) where+  go mres =+    case mres of+      Nothing -> pure Nothing+      Just res ->+          case res of+            ParseResultError errs -> pure (Just (ParseResultError errs))+            ParseResultSuccess (ParseSuccess t a) -> runParserT (f a) t++instance Monad m => Monad (ParserT l s e m) where   return = pure-  parser >>= f = ParserT (runParserT parser >=> go) where-    go (ParseResult v t) =-      case v of-        ParseError e -> pure (ParseResult (ParseError e) t)-        ParseSuccess a -> runParserT (f a) t+  (>>=) = bindParser -instance Monad m => Alternative (ParserT e s m) where-  empty = ParserT (const empty)-  first <|> second = ParserT (\s -> runParserT first s <|> runParserT second s)+-- | The empty parser+emptyParser :: Monad m => ParserT l s e m a+emptyParser = ParserT (const (pure Nothing)) -instance Monad m => MonadPlus (ParserT e s m) where+-- | Yields from the first parser of the two that returns a successfull result.+-- Otherwise will merge and yield all errors.+orParser :: Monad m => ParserT l s e m a -> ParserT l s e m a -> ParserT l s e m a+orParser one two = ParserT (\s -> runParserT one s >>= go1 s) where+  go1 s mres1 =+    case mres1 of+      Nothing -> runParserT two s >>= go2 empty+      Just res1 ->+        case res1 of+          ParseResultSuccess _ -> pure mres1+          ParseResultError es1 -> runParserT two s >>= go2 (NESeq.toSeq es1)++  go2 es1 mres2 =+    case mres2 of+      Nothing -> pure (fmap ParseResultError (NESeq.nonEmptySeq es1))+      Just res2 ->+        case res2 of+          ParseResultSuccess _ -> pure mres2+          ParseResultError es2 -> pure (Just (ParseResultError (es1 ><| es2)))++-- | Yields the LONGEST string of 0 or more successes of the given parser.+-- Failures will be silenced.+greedyStarParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq+greedyStarParser parser = go [] where+  opt = optionalParser parser+  go !acc = do+    res <- opt+    case res of+      Nothing -> pure (revTokensToChunk acc)+      Just a -> go (consChunk a acc)++-- | Same as 'greedyStarParser' but discards the result.+greedyStarParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m ()+greedyStarParser_ parser = go where+  opt = optionalParser parser+  go = do+    res <- opt+    case res of+      Nothing -> pure ()+      Just _ -> go++-- | Yields the LONGEST string of 1 or more successes of the given parser.+-- Failures in the tail will be silenced, but those in the head will be returned.+greedyPlusParser :: (Chunked seq elem, Monad m) => ParserT l s e m elem -> ParserT l s e m seq+greedyPlusParser parser = liftA2 consChunk parser (greedyStarParser parser)++-- | Same as 'greedyPlusParser' but discards the result.+greedyPlusParser_ :: Monad m => ParserT l s e m a -> ParserT l s e m ()+greedyPlusParser_ parser = parser *> greedyStarParser_ parser++instance Monad m => Alternative (ParserT l s e m) where+  empty = emptyParser+  (<|>) = orParser+  some = greedyPlusParser+  many = greedyStarParser++instance Monad m => MonadPlus (ParserT l s e m) where   mzero = empty   mplus = (<|>) -instance Monad m => MonadError e (ParserT e s m) where-  throwError e = ParserT (pure . ParseResult (ParseError e))-  -- TODO(ejconlon) Implement directly by unwrapping?-  catchError parser handler = do-    r <- reflectParser parser-    case r of-      ParseError e -> handler e-      ParseSuccess a -> pure a+instance Monad m => MonadState s (ParserT l s e m) where+  get = ParserT (\s -> pure (Just (ParseResultSuccess (ParseSuccess s s))))+  put t = ParserT (\_ -> pure (Just (ParseResultSuccess (ParseSuccess t ()))))+  state f = ParserT (\s -> let (!a, !t) = f s in pure (Just (ParseResultSuccess (ParseSuccess t a)))) -instance Monad m => MonadState s (ParserT e s m) where-  get = ParserT (\s -> pure (ParseResult (ParseSuccess s) s))-  put t = ParserT (const (pure (ParseResult (ParseSuccess ()) t)))-  state f = ParserT (\s -> let (a, t) = f s in pure (ParseResult (ParseSuccess a) t))+-- | Catch only a subset of custom errors. This preserves label information vs rethrowing.+catchJustParser :: Monad m => (e -> Maybe b) -> ParserT l s e m a -> (b -> ParserT l s e m a) -> ParserT l s e m a+catchJustParser filterer parser handler = ParserT (runParserT parser >=> go) where+    go mres =+      case mres of+        Nothing -> pure Nothing+        Just res ->+          case res of+            ParseResultSuccess _ ->+              -- Nothing to catch, yield existing success+              pure mres+            ParseResultError es ->+              -- Find first custom error to handle+              goSplit Empty (NESeq.toSeq es) -instance MonadTrans (ParserT e s) where-  lift ma = ParserT (\s -> lift (fmap (\a -> ParseResult (ParseSuccess a) s) ma))+    goSplit beforeEs afterEs =+      case seqPartition extractCustomError afterEs of+        Nothing ->+          -- No next custom error, finally yield all other errors+          pure (maybe empty (pure . ParseResultError) (NESeq.nonEmptySeq (beforeEs <> afterEs)))+        Just sep ->+          -- Found custom error - handle it+          goHandle beforeEs sep -instance MFunctor (ParserT e s) where-  hoist trans (ParserT f) = ParserT (hoist trans . f)+    goHandle beforeEs (SeqPartition nextBeforeEs targetE (s, e) afterEs) =+      case filterer e of+        Nothing ->+          -- Not handling error;  - find next custom error+          goSplit (beforeEs <> (targetE :<| nextBeforeEs)) afterEs+        Just b -> do+          mres <- runParserT (handler b) s+          case mres of+            Nothing ->+              -- No results from handled error - find next custom error+              goSplit (beforeEs <> nextBeforeEs) afterEs+            Just res ->+              case res of+                ParseResultSuccess _ -> pure mres+                ParseResultError es ->+                  -- Add to list of errors and find next custom error+                  goSplit (beforeEs <> nextBeforeEs <> NESeq.toSeq es) afterEs --- | Runs a non-effectful parser from an inital state and collects all results.-runParser :: Parser e s a -> s -> [ParseResult e s a]-runParser m s = runIdentity (ListT.toList (runParserT m s))+-- | Throws a custom error+throwParser :: Monad m => e -> ParserT l s e m a+throwParser e = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorCustom e)))))) --- | Filters parse results-filterParser :: Monad m => (a -> Bool) -> ParserT e s m a -> ParserT e s m a-filterParser f parser = ParserT (ListT . go . runParserT parser) where-  go listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> pure Nothing-      Just (r@(ParseResult v _), rest) ->-        case v of-          ParseSuccess a | not (f a) -> go rest-          _ -> pure (Just (r, ListT (go rest)))+-- | Catches a custom error+catchParser :: Monad m => ParserT l s e m a -> (e -> ParserT l s e m a) -> ParserT l s e m a+catchParser = catchJustParser Just --- | A kind of "catch" that returns all results, success and failure.-reflectParser :: Monad m => ParserT e s m a -> ParserT e s m (ParseValue e a)-reflectParser parser = ParserT (ListT . go . runParserT parser) where-  go listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> pure Nothing-      Just (ParseResult v t, rest) ->-        pure (Just (ParseResult (ParseSuccess v) t, ListT (go rest)))+instance Monad m => MonadError e (ParserT l s e m) where+  throwError = throwParser+  catchError = catchJustParser Just --- | Combines the results of many parsers.--- Equvalent to 'asum'.-branchParser :: (Foldable f, Monad m) => f (ParserT e s m a) -> ParserT e s m a-branchParser = start . toList where-  start ps =-    case ps of-      [] -> empty-      q:qs -> ParserT (\s -> ListT (run s q qs))-  run s q qs = do-    m <- ListT.uncons (runParserT q s)-    case m of-      Nothing ->-        case qs of-          [] -> pure Nothing-          r:rs -> run s r rs-      Just (a, rest) -> pure (Just (a, rest))+-- | A simple failing parser+failParser :: Monad m => Text -> ParserT l s e m a+failParser msg = ParserT (\s -> pure (Just (ParseResultError (pure (ParseError emptyStack s (CompoundErrorFail msg)))))) -gatherParser :: Monad m => Bool -> ParserT e s m a -> ParserT e s m a-gatherParser single parser = ParserT (ListT . go [] . runParserT parser) where-  go !acc listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> returnErr (reverse acc)-      Just (r@(ParseResult v _), rest) ->-        case v of-          ParseError _ -> go (r:acc) rest-          ParseSuccess _ ->-            let t = if single then empty else ListT (filterOk rest)-            in pure (Just (r, t))+instance Monad m => MonadFail (ParserT l s e m) where+  fail = failParser . T.pack -  returnErr racc =-    case racc of-      [] -> pure Nothing-      r:rs -> pure (Just (r, ListT (returnErr rs)))+liftParser :: Monad m => m a -> ParserT l s e m a+liftParser ma = ParserT (\s -> fmap (Just . ParseResultSuccess . ParseSuccess s) ma) -  filterOk listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> pure Nothing-      Just (r@(ParseResult v _), rest) ->-        let nextListt = filterOk rest-        in case v of-          ParseError _ -> nextListt-          ParseSuccess _ -> pure (Just (r, ListT nextListt))+instance MonadTrans (ParserT l s e) where+  lift = liftParser --- | If the parse results in ANY successes, keep only those. Otherwise return all failures.--- This may block indefinitely as it awaits either the end of the parser or its first success.--- See 'isolateParser' if you want only one success.-suppressParser :: Monad m => ParserT e s m a -> ParserT e s m a-suppressParser = gatherParser False+hoistParser :: (forall x. m x -> n x) -> ParserT l s e m a -> ParserT l s e n a+hoistParser trans (ParserT f) = ParserT (trans . f) --- | If the parse results in ANY successes, keep only THE FIRST. Otherwise return all failures.--- This may block indefinitely as it awaits either the end of the parser or its first success.--- See 'suppressParser' if you want all successes.-isolateParser :: Monad m => ParserT e s m a -> ParserT e s m a-isolateParser = gatherParser True+instance MFunctor (ParserT l s e) where+  hoist = hoistParser --- | If the parser yields no results (success or failure), yield a given value.-defaultParser :: Monad m => a -> ParserT e s m a -> ParserT e s m a-defaultParser def parser = ParserT (\s -> ListT (go s (runParserT parser s))) where-  go s listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> pure (Just (ParseResult (ParseSuccess def) s, empty))-      Just _ -> pure m+-- | If the parser does not succeed, yield the given value.+defaultParser :: Monad m => a -> ParserT l s e m a -> ParserT l s e m a+defaultParser val parser = orParser parser (pure val) --- | A parser that yields 'Nothing' if there are no results (success or failure),--- otherwise wrapping successes in 'Just'.-optionalParser :: Monad m => ParserT e s m a -> ParserT e s m (Maybe a)+-- | A parser that yields 'Nothing' if the parser does not succeed, otherwise+-- wraps success in 'Just'.+optionalParser :: Monad m => ParserT l s e m a -> ParserT l s e m (Maybe a) optionalParser parser = defaultParser Nothing (fmap Just parser) --- | Removes all failures from the parse results.--- Equivalent to 'catchError (const empty)'.-silenceParser :: Monad m => ParserT e s m a -> ParserT e s m a-silenceParser parser = ParserT (ListT . go . runParserT parser) where-  go listt = do-    m <- ListT.uncons listt-    case m of-      Nothing -> pure Nothing-      Just (r@(ParseResult v _), rest) ->-        let nextListt = go rest-        in case v of-          ParseError _ -> nextListt-          ParseSuccess _ -> pure (Just (r, ListT nextListt))+-- | Removes all failures from the parse results. Catches more errors than 'catchError (const empty)'+-- because this includes stream errors, not just custom errors.+-- If you want more fine-grained control, use 'reflectParser' and map over the results.+silenceParser :: Monad m => ParserT l s e m a -> ParserT l s e m a+silenceParser parser = ParserT (fmap (>>= go) . runParserT parser) where+  go res =+    case res of+      ParseResultError _ -> Nothing+      ParseResultSuccess _ -> Just res --- | Yields the LONGEST string of 0 or more successes of the given parser (and passes through failures).-greedyStarParser :: Monad m => ParserT e s m a -> ParserT e s m [a]-greedyStarParser parser = go [] where-  opt = optionalParser parser-  go !acc = do-    res <- opt+-- | Yield the results of the given parser, but rewind back to the starting state in ALL cases (success and error).+-- Note that these results may contain errors, so you may want to stifle them with 'silenceParser', for example.+lookAheadParser :: Monad m => Maybe l -> ParserT l s e m a -> ParserT l s e m a+lookAheadParser ml parser = ParserT (\s -> fmap (fmap (go s)) (runParserT parser s)) where+  go s res =     case res of-      Nothing -> pure (reverse acc)-      Just a -> go (a:acc)+      ParseResultError es -> ParseResultError (fmap (markParseError (Mark ml s)) es)+      ParseResultSuccess (ParseSuccess _ a) -> ParseResultSuccess (ParseSuccess s a) --- | Same as 'greedyStarParser' but discards the result.-greedyStarParser_ :: Monad m => ParserT e s m a -> ParserT e s m ()-greedyStarParser_ parser = go where-  opt = optionalParser parser-  go = do-    res <- opt+-- | Yield the results of the given parser, but rewind back to the starting state on error ONLY.+markParser :: Monad m => Maybe l -> ParserT l s e m a -> ParserT l s e m a+markParser ml parser = ParserT (\s -> fmap (fmap (go s)) (runParserT parser s)) where+  go s res =     case res of-      Nothing -> pure ()-      Just _ -> go+      ParseResultError es -> ParseResultError (fmap (markParseError (Mark ml s)) es)+      ParseResultSuccess _ -> res --- | Yields the LONGEST string of 1 or more successes of the given parser (and passes through failures).-greedyPlusParser :: Monad m => ParserT e s m a -> ParserT e s m [a]-greedyPlusParser parser = liftA2 (:) parser (greedyStarParser parser)+-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'.+markWithStateParser :: Monad m => Maybe l -> (s -> (b, s)) -> (b -> ParserT l s e m a) -> ParserT l s e m a+markWithStateParser ml g f = markParser ml (state g >>= f) --- | Same as 'greedyPlusParser' but discards the result.-greedyPlusParser_ :: Monad m => ParserT e s m a -> ParserT e s m ()-greedyPlusParser_ parser = parser *> greedyStarParser_ parser+-- | Like 'markParser' but allows you to mutate state. See 'withToken' and 'withChunk'.+markWithOptStateParser :: Monad m => Maybe l -> (s -> Maybe (b, s)) -> (Maybe b -> ParserT l s e m a) -> ParserT l s e m a+markWithOptStateParser ml g = markWithStateParser ml (\s -> maybe (Nothing, s) (first Just) (g s)) --- | Yield the results of the given parser, but rewind back to the starting state.--- Note that these results may contain errors, so you may want to stifle them with 'silenceParser', for example.-lookAheadParser :: Monad m => ParserT e s m a -> ParserT e s m a-lookAheadParser parser = do+-- | Clear marks from parse errors. You can mark immediately after to widen the narrowest+-- marked span to the range you want to report.+unmarkParser :: Monad m => ParserT l s e m a -> ParserT l s e m a+unmarkParser parser = ParserT (fmap (fmap go) . runParserT parser) where+  go res =+    case res of+      ParseResultError es -> ParseResultError (fmap unmarkParseError es)+      ParseResultSuccess _ -> res++-- | If the first parser succeeds in the given state, yield results from the second parser in the given+-- state. This is likely the look-ahead you want. Use the first parser to check a prefix of input,+-- and use the second to consume that input.+commitParser :: Monad m => ParserT l s e m () -> ParserT l s e m a -> ParserT l s e m a+commitParser checker parser = do   s <- get-  flip catchError (\e -> put s *> throwError e) $ do-    v <- parser-    put s-    pure v+  o <- optionalParser checker+  case o of+    Nothing -> empty+    Just _ -> put s *> parser++-- | If the first parser yields NO results (success or failure), yield from the second.+-- Note that this is different from 'orParser' in that it does not try the second if there+-- are errors in the first. You might use this on the outside of a complex parser with+-- a fallback to 'fail' to indicate that there are no matches.+onEmptyParser :: Parser l s e a -> Parser l s e a -> Parser l s e a+onEmptyParser parser fallback = ParserT (\s -> runParserT parser s >>= go s) where+  go s mres =+    case mres of+      Nothing -> runParserT fallback s+      Just _ -> pure mres++-- Private utility functions++data SeqPartition a b = SeqPartition+  { spBefore :: !(Seq a)+  , spKey :: !a+  , spValue :: !b+  , spAfter :: !(Seq a)+  } deriving (Eq, Show)++seqPartition :: (a -> Maybe b) -> Seq a -> Maybe (SeqPartition a b)+seqPartition f = go Empty where+  go before after =+    case after of+      Empty -> Nothing+      (x :<| xs) ->+        case f x of+          Nothing -> go (before :|> x) xs+          Just y -> Just (SeqPartition before x y xs)++extractCustomError :: ParseError l s e -> Maybe (s, e)+extractCustomError pe@(ParseError _ _ ce) =+  case ce of+    CompoundErrorCustom e -> Just (parseErrorResume pe, e)+    _ -> Nothing

@@ -1,31 +1,108 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+ module SimpleParser.Result-  ( ParseResult (..)-  , ParseValue (..)-  , parseSuccessResult-  , parseErrorResult-  , parseValue+  ( RawError (..)+  , StreamError (..)+  , CompoundError (..)+  , Mark (..)+  , ParseError (..)+  , parseErrorResume+  , markParseError+  , unmarkParseError+  , parseErrorEnclosingLabels+  , parseErrorNarrowestSpan+  , ParseSuccess (..)+  , ParseResult (..)   ) where --- | Strict 'Either' for parse results.-data ParseValue e a =-    ParseError !e-  | ParseSuccess !a-  deriving (Eq, Show, Functor, Foldable, Traversable)+import Data.Sequence (Seq (..))+import qualified Data.Sequence as Seq+import Data.Sequence.NonEmpty (NESeq)+import Data.Text (Text)+import SimpleParser.Stack (Stack (..), bottomStack, emptyStack, pushStack, topStack)+import SimpleParser.Stream (Span (..), Stream (..)) -parseValue :: (e -> r) -> (a -> r) -> ParseValue e a -> r-parseValue onError onSuccess value =-  case value of-    ParseError e -> onError e-    ParseSuccess a -> onSuccess a+data RawError chunk token =+    RawErrorMatchEnd !token+  | RawErrorAnyToken+  | RawErrorAnyChunk+  | RawErrorSatisfyToken !(Maybe token)+  | RawErrorMatchToken !token !(Maybe token)+  | RawErrorMatchChunk !chunk !(Maybe chunk)+  | RawErrorTakeTokensWhile1 !(Maybe token)+  | RawErrorDropTokensWhile1 !(Maybe token)+  deriving (Eq, Show) --- | Strict pair of parse result and state at the time it was yielded.-data ParseResult e s a = ParseResult-  { prValue :: !(ParseValue e a)-  , prState :: !s+-- | 'RawStreamError' specialized to 'Stream' types - newtyped to allow GHC+-- to derive eq/show in the absense of type families.+newtype StreamError s = StreamError+  { unStreamError :: RawError (Chunk s) (Token s)+  }++deriving instance (Eq (Token s), Eq (Chunk s)) => Eq (StreamError s)+deriving instance (Show (Token s), Show (Chunk s)) => Show (StreamError s)++data CompoundError s e =+    CompoundErrorStream !(StreamError s)+  | CompoundErrorFail !Text+  | CompoundErrorCustom !e+  deriving (Functor, Foldable, Traversable)++deriving instance (Eq (Token s), Eq (Chunk s), Eq e) => Eq (CompoundError s e)+deriving instance (Show (Token s), Show (Chunk s), Show e) => Show (CompoundError s e)++data Mark l s = Mark+  { markLabel :: !(Maybe l)+  , markState :: !s+  } deriving (Eq, Show)++type MarkStack l s = Stack (Mark l s)++data ParseError l s e = ParseError+  { peMarkStack :: !(MarkStack l s)+  , peEndState :: !s+  , peError :: !(CompoundError s e)+  }++-- | Returns the resumption point of the 'ParseError'.+-- If it has been marked, we use that, otherwise we assume it starts at the exact error point.+parseErrorResume :: ParseError l s e -> s+parseErrorResume pe = maybe (peEndState pe) markState (topStack (peMarkStack pe))++-- | Updates a 'ParseError' with a resumption point.+markParseError :: Mark l s -> ParseError l s e -> ParseError l s e+markParseError s pe = pe { peMarkStack = pushStack s (peMarkStack pe) }++-- | Clears marks from a 'ParseError'.+unmarkParseError :: ParseError l s e -> ParseError l s e+unmarkParseError pe = pe { peMarkStack = emptyStack }++-- | Returns the narrowest span+parseErrorNarrowestSpan :: Stream s => ParseError l s e -> (Maybe l, Span (Pos s))+parseErrorNarrowestSpan pe = (ml, Span startPos endPos) where+  endPos = streamViewPos (peEndState pe)+  (ml, startPos) = maybe (Nothing, endPos) (\(Mark mx s) -> (mx, streamViewPos s)) (bottomStack (peMarkStack pe))++-- | Returns labels enclosing the narrowest span, from coarsest to finest+parseErrorEnclosingLabels :: ParseError l s e -> Seq l+parseErrorEnclosingLabels pe =+  case unStack (peMarkStack pe) of+    Empty -> Empty+    _ :<| s -> s >>= \(Mark ml _) -> maybe Seq.empty Seq.singleton ml++deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e) => Eq (ParseError l s e)+deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e) => Show (ParseError l s e)++data ParseSuccess s a = ParseSuccess+  { psEndState :: !s+  , psValue :: !a   } deriving (Eq, Show, Functor, Foldable, Traversable) -parseSuccessResult :: a -> s -> ParseResult e s a-parseSuccessResult = ParseResult . ParseSuccess+data ParseResult l s e a =+    ParseResultError !(NESeq (ParseError l s e))+  | ParseResultSuccess !(ParseSuccess s a)+  deriving (Functor, Foldable, Traversable) -parseErrorResult :: e -> s -> ParseResult e s a-parseErrorResult = ParseResult . ParseError+deriving instance (Eq l, Eq s, Eq (Token s), Eq (Chunk s), Eq e, Eq a) => Eq (ParseResult l s e a)+deriving instance (Show l, Show s, Show (Token s), Show (Chunk s), Show e, Show a) => Show (ParseResult l s e a)

@@ -0,0 +1,38 @@+module SimpleParser.Stack+  ( Stack (..)+  , emptyStack+  , pushStack+  , topStack+  , bottomStack+  ) where++import Data.Sequence (Seq (..))++-- | A stack supporting O(1) push, top, and bottom.+-- Behind the newtype, a "push" onto the stack is implemented as "snoc", therefore+-- fold/traverse goes from bottom of stack (most generic label) to top (most specific label).+newtype Stack a = Stack+  { unStack :: Seq a+  } deriving (Eq, Show, Functor, Foldable, Traversable)++-- | Easy constructor for the empty stack+emptyStack :: Stack a+emptyStack = Stack Empty++-- | Pushes a an element onto a 'Stack'+pushStack :: a -> Stack a -> Stack a+pushStack a = Stack . (:|> a) . unStack++-- | Returns the top element of the stack (most recently pushed).+topStack :: Stack a -> Maybe a+topStack (Stack s) =+  case s of+    Empty -> Nothing+    _ :|> a -> Just a++-- | Returns the bottom element of the stack (least recently pushed).+bottomStack :: Stack a -> Maybe a+bottomStack (Stack s) =+  case s of+    Empty -> Nothing+    a :<| _ -> Just a

@@ -1,72 +1,39 @@ -- | This reworks 'Text.Megaparsec.Stream' to split interfaces. -- See <https://hackage.haskell.org/package/megaparsec-9.0.1/docs/Text-Megaparsec-Stream.html Text.Megaparsec.Stream>. module SimpleParser.Stream-  ( Chunked (..)-  , Stream (..)+  ( Stream (..)+  , TextualStream   , defaultStreamDropN   , defaultStreamDropWhile+  , Offset (..)   , OffsetStream (..)   , newOffsetStream+  , Line (..)+  , Col (..)+  , LinePos (..)+  , LinePosStream (..)+  , newLinePosStream+  , Span (..)   ) where  import Data.Bifunctor (first, second)-import Data.Foldable (toList) import Data.Kind (Type)-import Data.List (uncons)+import Data.List (foldl') import Data.Sequence (Seq (..)) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as T---- | 'Chunked' captures the basic relationship between tokens and chunks of them.--- Basically, these things behave like lists, sequences, text, etc.-class Monoid chunk => Chunked chunk token | chunk -> token where-  consChunk :: token -> chunk -> chunk-  unconsChunk :: chunk -> Maybe (token, chunk)-  tokenToChunk :: token -> chunk-  tokensToChunk :: [token] -> chunk-  chunkToTokens :: chunk -> [token]-  chunkLength :: chunk -> Int-  chunkEmpty :: chunk -> Bool---- TODO(ejconlon) Add instances for Strict BS, Lazy BS, and Lazy Text--instance Chunked [a] a where-  consChunk = (:)-  unconsChunk = uncons-  tokenToChunk a = [a]-  tokensToChunk = id-  chunkToTokens = id-  chunkLength = length-  chunkEmpty = null--instance Chunked (Seq a) a where-  consChunk = (:<|)-  unconsChunk s =-    case s of-      Empty -> Nothing-      a :<| b -> Just (a, b)-  tokenToChunk = Seq.singleton-  tokensToChunk = Seq.fromList-  chunkToTokens = toList-  chunkLength = Seq.length-  chunkEmpty = Seq.null--instance Chunked Text Char where-  consChunk = T.cons-  unconsChunk = T.uncons-  tokenToChunk = T.singleton-  tokensToChunk = T.pack-  chunkToTokens = T.unpack-  chunkLength = T.length-  chunkEmpty = T.null+import SimpleParser.Chunked (Chunked (..), TextualChunked (..))  -- | 'Stream' lets us peel off tokens and chunks for parsing -- with explicit state passing. class Chunked (Chunk s) (Token s) => Stream s where   type family Chunk s :: Type   type family Token s :: Type+  type family Pos s :: Type +  streamViewPos :: s -> Pos s+   streamTake1 :: s -> Maybe (Token s, s)   streamTakeN :: Int -> s -> Maybe (Chunk s, s)   streamTakeWhile :: (Token s -> Bool) -> s -> (Chunk s, s)@@ -77,22 +44,21 @@   streamDropWhile :: (Token s -> Bool) -> s -> (Int, s)   streamDropWhile = defaultStreamDropWhile --- TODO(ejconlon) Specialize drops- defaultStreamDropN :: Stream s => Int -> s -> Maybe (Int, s) defaultStreamDropN n = fmap (first chunkLength) . streamTakeN n  defaultStreamDropWhile :: Stream s => (Token s -> Bool) -> s -> (Int, s) defaultStreamDropWhile pcate = first chunkLength . streamTakeWhile pcate +type TextualStream s = (Stream s, Token s ~ Char, TextualChunked (Chunk s))+ instance Stream [a] where   type instance Chunk [a] = [a]   type instance Token [a] = a+  type instance Pos [a] = () -  streamTake1 l =-    case l of-      [] -> Nothing-      t:ts -> Just (t, ts)+  streamViewPos = const ()+  streamTake1 = unconsChunk   streamTakeN n s     | n <= 0 = Just ([], s)     | null s = Nothing@@ -102,21 +68,24 @@ instance Stream (Seq a) where   type instance Chunk (Seq a) = Seq a   type instance Token (Seq a) = a+  type instance Pos (Seq a) = () -  streamTake1 s =-    case s of-      Empty -> Nothing-      t :<| ts -> Just (t, ts)+  streamViewPos = const ()+  streamTake1 = unconsChunk   streamTakeN n s     | n <= 0 = Just (Seq.empty, s)     | Seq.null s = Nothing     | otherwise = Just (Seq.splitAt n s)   streamTakeWhile = Seq.spanl +  -- TODO(ejconlon) Specialize drops+ instance Stream Text where   type instance Chunk Text = Text   type instance Token Text = Char+  type instance Pos Text = () +  streamViewPos = const ()   streamTake1 = T.uncons   streamTakeN n s     | n <= 0 = Just (T.empty, s)@@ -124,26 +93,87 @@     | otherwise = Just (T.splitAt n s)   streamTakeWhile = T.span +newtype Offset = Offset { unOffset :: Int }+  deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral)++-- | Stream wrapper that maintains an offset position. data OffsetStream s = OffsetStream-  { osOffset :: !Int+  { osOffset :: !Offset   , osState :: !s   } deriving (Eq, Show, Functor, Foldable, Traversable)  instance Stream s => Stream (OffsetStream s) where   type instance Chunk (OffsetStream s) = Chunk s   type instance Token (OffsetStream s) = Token s+  type instance Pos (OffsetStream s) = Offset +  streamViewPos (OffsetStream o _) = o   streamTake1 (OffsetStream o s) = fmap (second (OffsetStream (succ o))) (streamTake1 s)-  streamTakeN n (OffsetStream o s) = fmap go (streamTakeN n s) where-    go (a, b) = (a, OffsetStream (o + chunkLength a) b)-  streamTakeWhile pcate (OffsetStream o s) =+  streamTakeN n (OffsetStream (Offset x) s) = fmap go (streamTakeN n s) where+    go (a, b) = (a, OffsetStream (Offset (x + chunkLength a)) b)+  streamTakeWhile pcate (OffsetStream (Offset x) s) =     let (a, b) = streamTakeWhile pcate s-    in (a, OffsetStream (o + chunkLength a) b)-  streamDropN n (OffsetStream o s) = fmap go (streamDropN n s) where-    go (m, b) = (m, OffsetStream (o + m) b)-  streamDropWhile pcate (OffsetStream o s) =+    in (a, OffsetStream (Offset (x + chunkLength a)) b)+  streamDropN n (OffsetStream (Offset x) s) = fmap go (streamDropN n s) where+    go (m, b) = (m, OffsetStream (Offset (x + m)) b)+  streamDropWhile pcate (OffsetStream (Offset x) s) =     let (m, b) = streamDropWhile pcate s-    in (m, OffsetStream (o + m) b)+    in (m, OffsetStream (Offset (x + m)) b)  newOffsetStream :: s -> OffsetStream s newOffsetStream = OffsetStream 0++newtype Line = Line { unLine :: Int }+  deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral)++newtype Col = Col { unCol :: Int }+  deriving newtype (Eq, Show, Ord, Enum, Num, Real, Integral)++-- | A 0-based line/col position in a character-based stream.+data LinePos = LinePos+  { lpOffset :: !Offset+  , lpLine :: !Line+  , lpCol :: !Col+  } deriving (Eq, Show, Ord)++-- | The canonical initial position.+initLinePos :: LinePos+initLinePos = LinePos 0 0 0++incrLinePosToken :: LinePos -> Char -> LinePos+incrLinePosToken (LinePos o l c) z+  | z == '\n' = LinePos (succ o) (succ l) 0+  | otherwise = LinePos (succ o) l (succ c)++incrLinePosChunk :: LinePos -> [Char] -> LinePos+incrLinePosChunk = foldl' incrLinePosToken++-- | Stream wrapper that maintains a line/col position.+data LinePosStream s = LinePosStream+  { lpsLinePos :: !LinePos+  , lpsState :: !s+  } deriving (Eq, Show, Functor, Foldable, Traversable)++instance (Stream s, Token s ~ Char) => Stream (LinePosStream s) where+  type instance Chunk (LinePosStream s) = Chunk s+  type instance Token (LinePosStream s) = Token s+  type instance Pos (LinePosStream s) = LinePos++  streamViewPos (LinePosStream p _) = p+  streamTake1 (LinePosStream p s) = fmap (\(a, b) -> (a, LinePosStream (incrLinePosToken p a) b)) (streamTake1 s)+  streamTakeN n (LinePosStream p s) = fmap go (streamTakeN n s) where+    go (a, b) = (a, LinePosStream (incrLinePosChunk p (chunkToTokens a)) b)+  streamTakeWhile pcate (LinePosStream p s) =+    let (a, b) = streamTakeWhile pcate s+    in (a, LinePosStream (incrLinePosChunk p (chunkToTokens a)) b)++  -- Drops can't be specialized because we need to examine each character for newlines.++newLinePosStream :: s -> LinePosStream s+newLinePosStream = LinePosStream initLinePos++-- | A range between two positions.+data Span p = Span+  { spanStart :: !p+  , spanEnd :: !p+  } deriving (Eq, Show, Ord)

@@ -3,606 +3,588 @@  module Main (main) where -import Control.Applicative (empty)-import Control.Monad.Except (catchError, throwError)+import Control.Monad (void) import Data.Foldable (asum)-import Data.Functor (($>))+import qualified Data.Sequence as Seq+import qualified Data.Sequence.NonEmpty as NESeq+import Data.String (IsString) import Data.Text (Text)+import qualified Data.Text as T import SimpleParser-import SimpleParser.Examples.Json (Json (..), JsonF (..), parseJson)+import SimpleParser.Examples.Json (Json (..), JsonF (..), jsonParser) import Test.Tasty (TestName, TestTree, testGroup)-import Test.Tasty.HUnit (Assertion, testCase, (@?=))+import Test.Tasty.HUnit (testCase, (@?=)) import Test.Tasty.TH (defaultMainGenerator) -newtype Error = Error { unError :: String } deriving (Eq, Show)+newtype Label = Label { unLabel :: String } deriving (Eq, Show, IsString) -type TestParser a = Parser Error (OffsetStream Text) a+newtype Error = Error { unError :: String } deriving (Eq, Show, IsString) -type TestResult a = ParseResult Error (OffsetStream Text) a+type TestState = OffsetStream Text -data InputOutput a = InputOutput !Text ![TestResult a]+type TestParser a = Parser Label TestState Error a -runParserCase :: (Show a, Eq a) => TestParser a -> InputOutput a -> Assertion-runParserCase parser (InputOutput input expected) = do-  let actual = runParser parser (newOffsetStream input)-  actual @?= expected+type TestResult a = ParseResult Label TestState Error a -testParserCase :: (Show a, Eq a) => TestName -> TestParser a -> InputOutput a -> TestTree-testParserCase name parser inOut = testCase name (runParserCase parser inOut)+type TestRawError = RawError Text Char -testParserTrees :: (Show a, Eq a) => TestParser a -> [(TestName, InputOutput a)] -> [TestTree]-testParserTrees parser = fmap (\(n, io) -> testParserCase n parser io)+type TestParseError = ParseError Label TestState Error +data ParserCase a = ParserCase !TestName !(TestParser a) !Text !(Maybe (TestResult a))++fwd :: Int -> TestState -> TestState+fwd n (OffsetStream (Offset i) t) =+  let m = min n (T.length t)+  in OffsetStream (Offset (i + m)) (T.drop m t)++sucRes :: TestState -> a -> Maybe (TestResult a)+sucRes st = Just . ParseResultSuccess . ParseSuccess st++errRes :: [TestParseError] -> Maybe (TestResult a)+errRes es = Just (ParseResultError (NESeq.unsafeFromSeq (Seq.fromList es)))++custErr :: TestState -> Error -> TestParseError+custErr endSt = ParseError emptyStack endSt . CompoundErrorCustom++stmErr :: TestState -> TestRawError -> TestParseError+stmErr endSt = ParseError emptyStack endSt . CompoundErrorStream . StreamError++failErr :: TestState -> Text -> TestParseError+failErr endSt = ParseError emptyStack endSt . CompoundErrorFail++markWith :: TestState -> TestParseError -> TestParseError+markWith s = markParseError (Mark Nothing s)++anyTokErr :: TestState -> TestParseError+anyTokErr s = markWith s (stmErr s RawErrorAnyToken)++anyChunkErr :: TestState -> TestParseError+anyChunkErr s = markWith s (stmErr s RawErrorAnyChunk)++matchTokErr :: TestState -> Char -> Maybe Char -> TestParseError+matchTokErr s x my = markWith s (stmErr (fwd 1 s) (RawErrorMatchToken x my))++matchChunkErr :: TestState -> Text -> Maybe Text -> TestParseError+matchChunkErr s x my = markWith s (stmErr (fwd (T.length x) s) (RawErrorMatchChunk x my))++matchEndErr :: TestState -> Char -> TestParseError+matchEndErr s x = markWith s (stmErr (fwd 1 s) (RawErrorMatchEnd x))++takeTokErr :: TestState -> Int -> Maybe Char -> TestParseError+takeTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorTakeTokensWhile1 my))++dropTokErr :: TestState -> Int -> Maybe Char -> TestParseError+dropTokErr s n my = markWith s (stmErr (fwd n s) (RawErrorDropTokensWhile1 my))++testParserCase :: (Show a, Eq a) => ParserCase a -> TestTree+testParserCase (ParserCase name parser input expected) = testCase name $ do+  let actual = runParser parser (newOffsetStream input)+  actual @?= expected+ test_empty :: [TestTree] test_empty =-  let parser = empty :: TestParser Int+  let parser = emptyParser :: TestParser Int       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [])+        [ ParserCase "empty" parser "" Nothing+        , ParserCase "non-empty" parser "hi" Nothing         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_pure :: [TestTree] test_pure =   let parser = pure (1 :: Int)       cases =-        [ ("empty", InputOutput "" [parseSuccessResult 1 (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1)+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases +test_fail :: [TestTree]+test_fail =+  let parser = fail "i give up" :: TestParser Int+      cases =+        [ ParserCase "empty" parser "" (errRes [(failErr (OffsetStream 0 "") "i give up")])+        , ParserCase "non-empty" parser "hi" (errRes [(failErr (OffsetStream 0 "hi") "i give up")])+        ]+  in fmap testParserCase cases+ test_peek_token :: [TestTree] test_peek_token =   let parser = peekToken       cases =-        [ ("empty", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")])-        , ("match", InputOutput "hi" [parseSuccessResult (Just 'h') (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing)+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 0 "hi") (Just 'h'))         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_pop_token :: [TestTree] test_pop_token =   let parser = popToken       cases =-        [ ("empty", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")])-        , ("match", InputOutput "hi" [parseSuccessResult (Just 'h') (OffsetStream 1 "i")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") Nothing)+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") (Just 'h'))         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_peek_chunk :: [TestTree] test_peek_chunk =   let parser = peekChunk 2       cases =-        [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")])-        , ("len 1", InputOutput "h" [parseSuccessResult (Just "h") (OffsetStream 0 "h")])-        , ("len 2", InputOutput "hi" [parseSuccessResult (Just "hi") (OffsetStream 0 "hi")])-        , ("len 3", InputOutput "hii" [parseSuccessResult (Just "hi") (OffsetStream 0 "hii")])+        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)+        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 0 "h") (Just "h"))+        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 0 "hi") (Just "hi"))+        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 0 "hii") (Just "hi"))         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_pop_chunk :: [TestTree] test_pop_chunk =   let parser = popChunk 2       cases =-        [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")])-        , ("len 1", InputOutput "h" [parseSuccessResult (Just "h") (OffsetStream 1 "")])-        , ("len 2", InputOutput "hi" [parseSuccessResult (Just "hi") (OffsetStream 2 "")])-        , ("len 3", InputOutput "hii" [parseSuccessResult (Just "hi") (OffsetStream 2 "i")])+        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)+        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just "h"))+        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just "hi"))+        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just "hi"))         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_drop_chunk :: [TestTree] test_drop_chunk =   let parser = dropChunk 2       cases =-        [ ("len 0", InputOutput "" [parseSuccessResult Nothing (OffsetStream 0 "")])-        , ("len 1", InputOutput "h" [parseSuccessResult (Just 1) (OffsetStream 1 "")])-        , ("len 2", InputOutput "hi" [parseSuccessResult (Just 2) (OffsetStream 2 "")])-        , ("len 3", InputOutput "hii" [parseSuccessResult (Just 2) (OffsetStream 2 "i")])+        [ ParserCase "len 0" parser "" (sucRes (OffsetStream 0 "") Nothing)+        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") (Just 1))+        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") (Just 2))+        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") (Just 2))         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_is_end :: [TestTree] test_is_end =   let parser = isEnd       cases =-        [ ("empty", InputOutput "" [parseSuccessResult True (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseSuccessResult False (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") True)+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") False)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_match_end :: [TestTree] test_match_end =   let parser = matchEnd       cases =-        [ ("empty", InputOutput "" [parseSuccessResult () (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ())+        , ParserCase "non-empty" parser "hi" (errRes [matchEndErr (OffsetStream 0 "hi") 'h'])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_any_token :: [TestTree] test_any_token =   let parser = anyToken       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])+        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_any_chunk :: [TestTree] test_any_chunk =   let parser = anyChunk 2 :: TestParser Text       cases =-        [ ("len 0", InputOutput "" [])-        , ("len 1", InputOutput "h" [parseSuccessResult "h" (OffsetStream 1 "")])-        , ("len 2", InputOutput "hi" [parseSuccessResult "hi" (OffsetStream 2 "")])-        , ("len 3", InputOutput "hii" [parseSuccessResult "hi" (OffsetStream 2 "i")])+        [ ParserCase "len 0" parser "" (errRes [anyChunkErr (OffsetStream 0 "")])+        , ParserCase "len 1" parser "h" (sucRes (OffsetStream 1 "") "h")+        , ParserCase "len 2" parser "hi" (sucRes (OffsetStream 2 "") "hi")+        , ParserCase "len 3" parser "hii" (sucRes (OffsetStream 2 "i") "hi")         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_match_token :: [TestTree] test_match_token =   let parser = matchToken 'h'       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        , ("non-match", InputOutput "bye" [])+        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") 'h')+        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_match_chunk :: [TestTree] test_match_chunk =   let parser = matchChunk "hi"       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult "hi" (OffsetStream 2 "")])-        , ("prefix", InputOutput "hiya" [parseSuccessResult "hi" (OffsetStream 2 "ya")])-        , ("partial", InputOutput "hey" [])-        , ("non-match", InputOutput "bye" [])+        [ ParserCase "empty" parser "" (errRes [matchChunkErr (OffsetStream 0 "") "hi" Nothing])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 2 "") "hi")+        , ParserCase "prefix" parser "hiya" (sucRes (OffsetStream 2 "ya") "hi")+        , ParserCase "partial" parser "hey" (errRes [matchChunkErr (OffsetStream 0 "hey") "hi" (Just "he")])+        , ParserCase "non-match" parser "bye" (errRes [matchChunkErr (OffsetStream 0 "bye") "hi" (Just "by")])+        , ParserCase "short" parser "h" (errRes [matchChunkErr (OffsetStream 0 "h") "hi" (Just "h")])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_greedy_star :: [TestTree] test_greedy_star =-  let parser = greedyStarParser (matchToken 'h')+  let parser = greedyStarParser (matchToken 'h') :: TestParser String       cases =-        [ ("empty", InputOutput "" [parseSuccessResult "" (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")])-        , ("repeat", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")])-        , ("full", InputOutput "hhh" [parseSuccessResult "hhh" (OffsetStream 3 "")])-        , ("non-match", InputOutput "bye" [parseSuccessResult "" (OffsetStream 0 "bye")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "")+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h")+        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")+        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh")+        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") "")         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_greedy_star_unit :: [TestTree] test_greedy_star_unit =   let parser = greedyStarParser_ (matchToken 'h')       cases =-        [ ("empty", InputOutput "" [parseSuccessResult () (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseSuccessResult () (OffsetStream 1 "i")])-        , ("repeat", InputOutput "hhi" [parseSuccessResult () (OffsetStream 2 "i")])-        , ("full", InputOutput "hhh" [parseSuccessResult () (OffsetStream 3 "")])-        , ("non-match", InputOutput "bye" [parseSuccessResult () (OffsetStream 0 "bye")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") ())+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ())+        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ())+        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ())+        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") ())         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_greedy_plus :: [TestTree] test_greedy_plus =-  let parser = greedyPlusParser (matchToken 'h')+  let parser = greedyPlusParser (matchToken 'h') :: TestParser String       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")])-        , ("repeat", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")])-        , ("full", InputOutput "hhh" [parseSuccessResult "hhh" (OffsetStream 3 "")])-        , ("non-match", InputOutput "bye" [])+        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") "h")+        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")+        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") "hhh")+        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_greedy_plus_unit :: [TestTree] test_greedy_plus_unit =   let parser = greedyPlusParser_ (matchToken 'h')       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult () (OffsetStream 1 "i")])-        , ("repeat", InputOutput "hhi" [parseSuccessResult () (OffsetStream 2 "i")])-        , ("full", InputOutput "hhh" [parseSuccessResult () (OffsetStream 3 "")])-        , ("non-match", InputOutput "bye" [])-        ]-  in testParserTrees parser cases--test_branch :: [TestTree]-test_branch =-  let parser = branchParser [matchToken 'h', matchToken 'x']-      cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")])-        , ("non-match", InputOutput "bye" [])-        ]-  in testParserTrees parser cases--test_branch_first :: [TestTree]-test_branch_first =-  let parser = branchParser [anyToken $> 'h', matchToken 'x']-      cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        , ("second", InputOutput "xi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        ]-  in testParserTrees parser cases--test_branch_second :: [TestTree]-test_branch_second =-  let parser = branchParser [empty, anyToken $> 'x']-      cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'x' (OffsetStream 1 "i")])-        , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")])-        ]-  in testParserTrees parser cases--test_combine :: [TestTree]-test_combine =-  let parser = asum [matchToken 'h', matchToken 'x']-      cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        , ("second", InputOutput "xi" [parseSuccessResult 'x' (OffsetStream 1 "i")])-        , ("non-match", InputOutput "bye" [])+        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'h' Nothing])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 1 "i") ())+        , ParserCase "repeat" parser "hhi" (sucRes (OffsetStream 2 "i") ())+        , ParserCase "full" parser "hhh" (sucRes (OffsetStream 3 "") ())+        , ParserCase "non-match" parser "bye" (errRes [matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_combine_first :: [TestTree]-test_combine_first =-  let state = OffsetStream 1 "i"-      parser = asum [anyToken $> 'h', matchToken 'x']+test_or :: [TestTree]+test_or =+  let parser = orParser (matchToken 'h') (matchToken 'x')       cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'h' state])-        , ("second", InputOutput "xi" [parseSuccessResult 'h' state, parseSuccessResult 'x' state])+        [ ParserCase "empty" parser "" $ errRes+            [ matchTokErr (OffsetStream 0 "") 'h' Nothing+            , matchTokErr (OffsetStream 0 "") 'x' Nothing+            ]+        , ParserCase "first" parser "hi" (sucRes (OffsetStream 1 "i") 'h')+        , ParserCase "second" parser "xi" (sucRes (OffsetStream 1 "i") 'x')+        , ParserCase "non-match" parser "bye" $ errRes+            [ matchTokErr (OffsetStream 0 "bye") 'h' (Just 'b')+            , matchTokErr (OffsetStream 0 "bye") 'x' (Just 'b')+            ]         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_combine_second :: [TestTree]-test_combine_second =+test_asum :: [TestTree]+test_asum =   let state = OffsetStream 1 "i"-      parser = asum [empty, anyToken $> 'x']+      parser = asum [matchToken 'h', 'y' <$ anyToken, matchToken 'x']       cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'x' state])-        , ("second", InputOutput "xi" [parseSuccessResult 'x' state])+        [ ParserCase "empty" parser "" $ errRes+            [ matchTokErr (OffsetStream 0 "") 'h' Nothing+            , anyTokErr (OffsetStream 0 "")+            , matchTokErr (OffsetStream 0 "") 'x' Nothing+            ]+        , ParserCase "first" parser "hi" (sucRes state 'h')+        , ParserCase "middle" parser "zi" (sucRes state 'y')+        , ParserCase "last" parser "xi" (sucRes state 'y')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_with_default_empty :: [TestTree]-test_with_default_empty =-  let parser = defaultParser 'z' empty+test_default_empty :: [TestTree]+test_default_empty =+  let parser = defaultParser 'z' emptyParser       cases =-        [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseSuccessResult 'z' (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_with_default :: [TestTree]-test_with_default =+test_default :: [TestTree]+test_default =   let parser = defaultParser 'z' (matchToken 'h')       cases =-        [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")])-        , ("match", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])-        , ("non-match", InputOutput "bye" [parseSuccessResult 'z' (OffsetStream 0 "bye")])+        [ ParserCase "non-match empty" parser "" (sucRes (OffsetStream 0 "") 'z')+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 'h')+        , ParserCase "non-match" parser "bye" (sucRes (OffsetStream 0 "bye") 'z')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_bind_multi_pre :: [TestTree]-test_bind_multi_pre =+test_bind_1 :: [TestTree]+test_bind_1 =   let state = OffsetStream 1 "i"-      parser = asum [anyToken $> 'h', matchToken 'x'] >>= \c -> pure [c, c]+      parser = matchToken 'x' >>= \c -> pure [c, c]       cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult "hh" state])-        , ("second", InputOutput "xi" [parseSuccessResult "hh" state, parseSuccessResult "xx" state])+        [ ParserCase "empty" parser "" (errRes [matchTokErr (OffsetStream 0 "") 'x' Nothing])+        , ParserCase "first" parser "hi" (errRes [matchTokErr (OffsetStream 0 "hi") 'x' (Just 'h')])+        , ParserCase "second" parser "xi" (sucRes state "xx")         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_bind_multi_post :: [TestTree]-test_bind_multi_post =-  let state1 = OffsetStream 1 "i"-      state2 = OffsetStream 2 ""-      parser = anyToken >>= \x -> asum [pure x, matchToken 'i']+test_bind_2 :: [TestTree]+test_bind_2 =+  let state = OffsetStream 1 "i"+      parser = anyToken >>= \x -> if x == 'x' then pure 'y' else emptyParser       cases =-        [ ("empty", InputOutput "" [])-        , ("first", InputOutput "hi" [parseSuccessResult 'h' state1, parseSuccessResult 'i' state2])-        , ("second", InputOutput "xi" [parseSuccessResult 'x' state1, parseSuccessResult 'i' state2])+        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])+        , ParserCase "first" parser "hi" Nothing+        , ParserCase "second" parser "xi" (sucRes state 'y')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_throw :: [TestTree] test_throw =   let err = Error "boo"-      parser = throwError err :: TestParser Int+      parser = throwParser err :: TestParser Int       cases =-        [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (errRes [custErr (OffsetStream 0 "") err])+        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 0 "hi") err])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_consume_throw :: [TestTree] test_consume_throw =   let err = Error "boo"-      parser = anyToken *> throwError err :: TestParser Int+      parser = anyToken *> throwParser err :: TestParser Int       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")])+        [ ParserCase "empty" parser "" (errRes [anyTokErr (OffsetStream 0 "")])+        , ParserCase "non-empty" parser "hi" (errRes [custErr (OffsetStream 1 "i") err])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_with_default_throw :: [TestTree]-test_with_default_throw =+test_default_throw :: [TestTree]+test_default_throw =   let err = Error "boo"-      parser = defaultParser 'z' (throwError err)+      parser = defaultParser 'z' (throwParser err)       cases =-        [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_with_default_consume_throw :: [TestTree]-test_with_default_consume_throw =+test_default_consume_throw :: [TestTree]+test_default_consume_throw =   let err = Error "boo"-      parser = defaultParser 'z' (anyToken *> throwError err)+      parser = defaultParser 'z' (anyToken *> throwParser err)       cases =-        [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")])-        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 'z')+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'z')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_throw_mixed :: [TestTree] test_throw_mixed =   let state = OffsetStream 0 "hi"       err = Error "boo"-      parser = asum [throwError err, pure 1 :: TestParser Int]+      parser = orParser (throwParser err) (pure 1) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseErrorResult err state, parseSuccessResult 1 state])+        [ ParserCase "non-empty" parser "hi" (sucRes state 1)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases +test_throw_mixed_flip :: [TestTree]+test_throw_mixed_flip =+  let state = OffsetStream 0 "hi"+      err = Error "boo"+      parser = orParser (pure 1) (throwParser err) :: TestParser Int+      cases =+        [ ParserCase "non-empty" parser "hi" (sucRes state 1)+        ]+  in fmap testParserCase cases+ test_catch :: [TestTree] test_catch =   let state = OffsetStream 0 "hi"       err = Error "boo"-      parser = catchError (asum [throwError err, pure 1]) (\(Error m) -> pure (if m == "boo" then 2 else 3)) :: TestParser Int+      parser = catchParser (throwParser err) (\(Error m) -> pure (if m == "boo" then 2 else 3)) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 state, parseSuccessResult 1 state])+        [ ParserCase "non-empty" parser "hi" (sucRes state 2)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_catch_recur :: [TestTree] test_catch_recur =   let state = OffsetStream 0 "hi"       err1 = Error "boo"       err2 = Error "two"-      parser = catchError (throwError err1) (const (throwError err2)) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseErrorResult err2 state])-        ]-  in testParserTrees parser cases--test_suppress_success :: [TestTree]-test_suppress_success =-  let state = OffsetStream 0 "hi"-      parser = suppressParser (asum [pure 1, pure 2]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state, parseSuccessResult 2 state])-        ]-  in testParserTrees parser cases--test_suppress_fail_first :: [TestTree]-test_suppress_fail_first =-  let err = Error "boo"-      parser = suppressParser (asum [throwError err, pure 2]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")])-        ]-  in testParserTrees parser cases--test_suppress_fail_second :: [TestTree]-test_suppress_fail_second =-  let err = Error "boo"-      parser = suppressParser (asum [pure 1, throwError err]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")])-        ]-  in testParserTrees parser cases--test_suppress_fail_both :: [TestTree]-test_suppress_fail_both =-  let state = OffsetStream 0 "hi"-      err1 = Error "boo1"-      err2 = Error "boo2"-      parser = suppressParser (asum [throwError err1, throwError err2]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseErrorResult err1 state, parseErrorResult err2 state])-        ]-  in testParserTrees parser cases--test_isolate_success :: [TestTree]-test_isolate_success =-  let state = OffsetStream 0 "hi"-      parser = isolateParser (asum [pure 1, pure 2]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state])-        ]-  in testParserTrees parser cases--test_isolate_fail_first :: [TestTree]-test_isolate_fail_first =-  let err = Error "boo"-      parser = isolateParser (asum [throwError err, pure 2]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")])-        ]-  in testParserTrees parser cases--test_isolate_fail_second :: [TestTree]-test_isolate_fail_second =-  let err = Error "boo"-      parser = isolateParser (asum [pure 1, throwError err]) :: TestParser Int-      cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")])-        ]-  in testParserTrees parser cases--test_isolate_fail_both :: [TestTree]-test_isolate_fail_both =-  let state = OffsetStream 0 "hi"-      err1 = Error "boo1"-      err2 = Error "boo2"-      parser = isolateParser (asum [throwError err1, throwError err2]) :: TestParser Int+      parser = catchParser (throwParser err1) (const (throwParser err2)) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseErrorResult err1 state, parseErrorResult err2 state])+        [ ParserCase "non-empty" parser "hi" (errRes [custErr state err2])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_silence_success :: [TestTree] test_silence_success =   let state = OffsetStream 0 "hi"-      parser = silenceParser (asum [pure 1, pure 2]) :: TestParser Int+      parser = silenceParser (pure 1) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state, parseSuccessResult 2 state])+        [ ParserCase "non-empty" parser "hi" (sucRes state 1)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_silence_fail_first :: [TestTree]-test_silence_fail_first =+test_silence_fail :: [TestTree]+test_silence_fail =   let err = Error "boo"-      parser = silenceParser (asum [throwError err, pure 2]) :: TestParser Int+      parser = silenceParser (throwParser err) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")])+        [ ParserCase "non-empty" parser "hi" Nothing         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_silence_fail_second :: [TestTree]-test_silence_fail_second =-  let err = Error "boo"-      parser = silenceParser (asum [pure 1, throwError err]) :: TestParser Int+test_silence_empty :: [TestTree]+test_silence_empty =+  let parser = silenceParser emptyParser :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")])+        [ ParserCase "non-empty" parser "hi" Nothing         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -test_silence_fail_both :: [TestTree]-test_silence_fail_both =-  let err1 = Error "boo1"-      err2 = Error "boo2"-      parser = silenceParser (asum [throwError err1, throwError err2]) :: TestParser Int+test_look_ahead_pure :: [TestTree]+test_look_ahead_pure =+  let parser = lookAheadParser Nothing (pure 1) :: TestParser Int       cases =-        [ ("non-empty", InputOutput "hi" [])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 1)+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 1)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_look_ahead_success :: [TestTree] test_look_ahead_success =-  let parser = lookAheadParser anyToken+  let parser = lookAheadParser Nothing anyToken       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 0 "hi")])+        [ ParserCase "non-match empty" parser "" (errRes [markWith (OffsetStream 0 "") (anyTokErr (OffsetStream 0 ""))])+        , ParserCase "non-empty" parser "hi" (sucRes (OffsetStream 0 "hi") 'h')         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_look_ahead_failure :: [TestTree] test_look_ahead_failure =   let err = Error "boo"-      parser = lookAheadParser (anyToken *> throwError err) :: TestParser Char+      parser = lookAheadParser Nothing (anyToken *> throwParser err) :: TestParser Char       cases =-        [ ("empty", InputOutput "" [])-        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")])+        [ ParserCase "non-match empty" parser "" (errRes [markWith (OffsetStream 0 "") (anyTokErr (OffsetStream 0 ""))])+        , ParserCase "non-empty" parser "hi" (errRes [markWith (OffsetStream 0 "hi") (custErr (OffsetStream 1 "i") err)])         ]-  in testParserTrees parser cases+  in fmap testParserCase cases +test_commit :: [TestTree]+test_commit =+  let parser = commitParser (void (matchToken 'h')) (matchChunk "hi") :: TestParser Text+      cases =+        [ ParserCase "non-match empty" parser "" Nothing+        , ParserCase "non-match non-empty" parser "ho" (errRes [matchChunkErr (OffsetStream 0 "ho") "hi" (Just "ho")])+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 2 "") "hi")+        ]+  in fmap testParserCase cases+ test_take_while :: [TestTree] test_take_while =   let parser = takeTokensWhile (=='h') :: TestParser Text       cases =-        [ ("empty", InputOutput "" [parseSuccessResult "" (OffsetStream 0 "")])-        , ("non-match", InputOutput "i" [parseSuccessResult "" (OffsetStream 0 "i")])-        , ("match", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")])-        , ("match 2", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")])-        , ("match end", InputOutput "hh" [parseSuccessResult "hh" (OffsetStream 2 "")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") "")+        , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") "")+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h")+        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")+        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh")         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_take_while_1 :: [TestTree] test_take_while_1 =-  let parser = takeTokensWhile1 (=='h') :: TestParser Text+  let parser = takeTokensWhile1 Nothing (=='h') :: TestParser Text       cases =-        [ ("empty", InputOutput "" [])-        , ("non-match", InputOutput "i" [])-        , ("match", InputOutput "hi" [parseSuccessResult "h" (OffsetStream 1 "i")])-        , ("match 2", InputOutput "hhi" [parseSuccessResult "hh" (OffsetStream 2 "i")])-        , ("match end", InputOutput "hh" [parseSuccessResult "hh" (OffsetStream 2 "")])+        [ ParserCase "empty" parser "" (errRes [takeTokErr(OffsetStream 0 "") 0 Nothing])+        , ParserCase "non-match" parser "i" (errRes [takeTokErr (OffsetStream 0 "i") 0 (Just 'i')])+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") "h")+        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") "hh")+        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") "hh")         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_drop_while :: [TestTree] test_drop_while =   let parser = dropTokensWhile (=='h') :: TestParser Int       cases =-        [ ("empty", InputOutput "" [parseSuccessResult 0 (OffsetStream 0 "")])-        , ("non-match", InputOutput "i" [parseSuccessResult 0 (OffsetStream 0 "i")])-        , ("match", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 1 "i")])-        , ("match 2", InputOutput "hhi" [parseSuccessResult 2 (OffsetStream 2 "i")])-        , ("match end", InputOutput "hh" [parseSuccessResult 2 (OffsetStream 2 "")])+        [ ParserCase "empty" parser "" (sucRes (OffsetStream 0 "") 0)+        , ParserCase "non-match" parser "i" (sucRes (OffsetStream 0 "i") 0)+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1)+        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2)+        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases  test_drop_while_1 :: [TestTree] test_drop_while_1 =-  let parser = dropTokensWhile1 (=='h') :: TestParser Int+  let parser = dropTokensWhile1 Nothing (=='h') :: TestParser Int       cases =-        [ ("empty", InputOutput "" [])-        , ("non-match", InputOutput "i" [])-        , ("match", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 1 "i")])-        , ("match 2", InputOutput "hhi" [parseSuccessResult 2 (OffsetStream 2 "i")])-        , ("match end", InputOutput "hh" [parseSuccessResult 2 (OffsetStream 2 "")])+        [ ParserCase "empty" parser "" (errRes [dropTokErr (OffsetStream 0 "") 0 Nothing])+        , ParserCase "non-match" parser "i" (errRes [dropTokErr (OffsetStream 0 "i") 0 (Just 'i')])+        , ParserCase "match" parser "hi" (sucRes (OffsetStream 1 "i") 1)+        , ParserCase "match 2" parser "hhi" (sucRes (OffsetStream 2 "i") 2)+        , ParserCase "match end" parser "hh" (sucRes (OffsetStream 2 "") 2)         ]-  in testParserTrees parser cases+  in fmap testParserCase cases -testJsonCase :: TestName -> Text -> [Json] -> TestTree+type JsonResult = Maybe Json++testJsonCase :: TestName -> Text -> JsonResult -> TestTree testJsonCase name str expected = testCase ("json " <> name) $ do   let actual = parseJson str   actual @?= expected -testJsonTrees :: [(TestName, Text, [Json])] -> [TestTree]+testJsonTrees :: [(TestName, Text, JsonResult)] -> [TestTree] testJsonTrees = fmap (\(n, s, e) -> testJsonCase n s e) +parseJson :: Text -> JsonResult+parseJson str =+  let p = jsonParser <* matchEnd+  in case runParser p str of+    Just (ParseResultSuccess (ParseSuccess _ a)) -> Just a+    _ -> Nothing+ test_json :: [TestTree] test_json =   let nullVal = Json JsonNull       trueVal = Json (JsonBool True)       falseVal = Json (JsonBool False)-      arrVal = Json . JsonArray+      arrVal = Json . JsonArray . Seq.fromList       strVal = Json . JsonString-      objVal = Json . JsonObject+      objVal = Json . JsonObject . Seq.fromList+      numVal = Json . JsonNum       cases =-        [ ("empty", "", [])-        , ("bad", "bad", [])-        , ("null", "null", [nullVal])-        , ("true", "true", [trueVal])-        , ("false", "false", [falseVal])-        , ("arr0", "[]", [arrVal []])-        , ("arr1", "[null]", [arrVal [nullVal]])-        , ("arr2", "[null, false]", [arrVal [nullVal, falseVal]])-        , ("arr3", "[null, false, true]", [arrVal [nullVal, falseVal, trueVal]])-        , ("arrx", "[null,]", [])-        , ("str0", "\"\"", [strVal ""])-        , ("str1", "\"x\"", [strVal "x"])-        , ("str2", "\"xy\"", [strVal "xy"])-        , ("str3", "\"xyz\"", [strVal "xyz"])-        -- TODO(ejconlon) Refine parser to make this pass-        -- , ("str4", "\"xy\\\"z\"", [strVal "xy\"z"])-        , ("obj0", "{}", [objVal []])-        , ("obj1", "{\"x\": true}", [objVal [("x", trueVal)]])-        , ("obj2", "{\"x\": true, \"y\": false}", [objVal [("x", trueVal), ("y", falseVal)]])+        [ ("empty", "", Nothing)+        , ("bad", "bad", Nothing)+        , ("null", "null", Just nullVal)+        , ("true", "true", Just trueVal)+        , ("false", "false", Just falseVal)+        , ("arr0", "[]", Just (arrVal []))+        , ("arr1", "[null]", Just (arrVal [nullVal]))+        , ("arr2", "[null, false]", Just (arrVal [nullVal, falseVal]))+        , ("arr3", "[null, false, true]", Just (arrVal [nullVal, falseVal, trueVal]))+        , ("arrx", "[null,]", Nothing)+        , ("str0", "\"\"", Just (strVal ""))+        , ("str1", "\"x\"", Just (strVal "x"))+        , ("str2", "\"xy\"", Just (strVal "xy"))+        , ("str3", "\"xyz\"", Just (strVal "xyz"))+        , ("str4", "\"xy\\\"z\"", Just (strVal "xy\"z"))+        , ("obj0", "{}", Just (objVal []))+        , ("obj1", "{\"x\": true}", Just (objVal [("x", trueVal)]))+        , ("obj2", "{\"x\": true, \"y\": false}", Just (objVal [("x", trueVal), ("y", falseVal)]))+        , ("num0", "0", Just (numVal (read "0")))+        , ("num1", "123", Just (numVal (read "123")))+        , ("num2", "123.45", Just (numVal (read "123.45")))+        , ("num3", "1e100", Just (numVal (read "1e100")))+        , ("num4", "{\"x\": 1e100, \"y\": 123.45}", Just (objVal [("x", numVal (read "1e100")), ("y", numVal (read "123.45"))]))         ]   in testJsonTrees cases