packages feed

simple-parser (empty) → 0.2.0

raw patch · 11 files changed

+1275/−0 lines, 11 filesdep +basedep +containersdep +list-tsetup-changed

Dependencies added: base, containers, list-t, mtl, simple-parser, tasty, tasty-hunit, tasty-th, text

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Eric Conlon (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Eric Conlon nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,12 @@+# simple-parser++[![CircleCI](https://circleci.com/gh/ejconlon/simple-parser/tree/master.svg?style=svg)](https://circleci.com/gh/ejconlon/simple-parser/tree/master)++Simple parser combinators following the clever refrain (by Fritz Ruehr?)++    A parser for things+    Is a function from strings+    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).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ simple-parser.cabal view
@@ -0,0 +1,70 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1feb1774e0c1c145443c361947b747f9758ae9ba8257f9a5eae4818871d134d7++name:           simple-parser+version:        0.2.0+synopsis:       Simple parser combinators+description:    Please see the README on GitHub at <https://github.com/ejconlon/simple-parser#readme>+category:       Parsing+homepage:       https://github.com/ejconlon/simple-parser#readme+bug-reports:    https://github.com/ejconlon/simple-parser/issues+author:         Eric Conlon+maintainer:     ejconlon@gmail.com+copyright:      (c) 2020 Eric Conlon+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ejconlon/simple-parser++library+  exposed-modules:+      SimpleParser+      SimpleParser.Examples.Json+      SimpleParser.Input+      SimpleParser.Parser+      SimpleParser.Result+      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+  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+    , containers >=0.6 && <0.7+    , list-t >=1.0 && <1.1+    , mtl >=2.2 && <2.3+    , text >=1.2 && <1.3+  default-language: Haskell2010++test-suite simple-parser-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Paths_simple_parser+  hs-source-dirs:+      test+  default-extensions: BangPatterns 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+    , containers >=0.6 && <0.7+    , list-t >=1.0 && <1.1+    , mtl >=2.2 && <2.3+    , simple-parser+    , tasty+    , tasty-hunit+    , tasty-th+    , text >=1.2 && <1.3+  default-language: Haskell2010
+ src/SimpleParser.hs view
@@ -0,0 +1,14 @@+-- | Re-exports for all modules. See 'SimpleParser.Examples.Json' or the test suit for examples,+-- '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.Parser+  , module SimpleParser.Result+  , module SimpleParser.Stream+  ) where++import SimpleParser.Input+import SimpleParser.Parser+import SimpleParser.Result+import SimpleParser.Stream
+ src/SimpleParser/Examples/Json.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}++module SimpleParser.Examples.Json+  ( Json (..)+  , JsonF (..)+  , parseJson+  ) where++import Control.Applicative (empty)+import Control.Monad (void)+import Data.Char (isSpace)+import Data.Foldable (asum)+import Data.Text (Text)+import Data.Void (Void)+import SimpleParser++-- JSON without numbers...+data JsonF a =+    JsonObject ![(String, a)]+  | JsonArray ![a]+  | JsonString !String+  | JsonBool !Bool+  | 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++jsonSpace :: JsonParser ()+jsonSpace = greedyStarParser_ (void (satisfyToken isSpace))++jsonLexeme :: JsonParser () -> JsonParser a -> JsonParser a+jsonLexeme spaceAfter thing = do+  a <- thing+  spaceAfter+  pure a++jsonBetween :: JsonParser () -> JsonParser () -> JsonParser a -> JsonParser a+jsonBetween start end thing = do+  start+  a <- thing+  end+  pure a++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++jsonCharLexeme :: Char -> JsonParser ()+jsonCharLexeme c = void (jsonLexeme jsonSpace (matchToken c))++jsonWordLexeme :: Text -> JsonParser ()+jsonWordLexeme cs = void (jsonLexeme jsonSpace (matchChunk cs))++openBrace, closeBrace, comma, colon, openBracket, closeBracket, closeQuote :: JsonParser ()+openBrace = jsonCharLexeme '{'+closeBrace = jsonCharLexeme '}'+comma = jsonCharLexeme ','+colon = jsonCharLexeme ':'+openBracket = jsonCharLexeme '['+closeBracket = jsonCharLexeme ']'+closeQuote = jsonCharLexeme '"'++openQuote :: JsonParser ()+openQuote = void (matchToken '"')++nullTok, trueTok, falseTok :: JsonParser ()+nullTok = jsonWordLexeme "null"+trueTok = jsonWordLexeme "true"+falseTok = jsonWordLexeme "false"++nonQuoteChar :: JsonParser Char+nonQuoteChar = satisfyToken (/= '"')++nonQuoteString :: JsonParser String+nonQuoteString = greedyStarParser nonQuoteChar++rawStringParser :: JsonParser String+rawStringParser = jsonBetween openQuote closeQuote nonQuoteString++-- TODO(ejconlon) This does not handle escape codes. Use `foldTokensWhile` for that...+stringParser :: JsonParser (JsonF a)+stringParser = fmap JsonString rawStringParser++nullParser :: JsonParser (JsonF a)+nullParser = JsonNull <$ nullTok++boolParser :: JsonParser (JsonF a)+boolParser = branchParser [JsonBool True <$ trueTok, JsonBool False <$ falseTok]++objectPairParser :: JsonParser a -> JsonParser (String, a)+objectPairParser root = do+  name <- rawStringParser+  colon+  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 = asum opts where+  pairParser = objectPairParser root+  opts =+    [ objectParser pairParser+    , arrayParser root+    , stringParser+    , boolParser+    , nullParser+    ]++jsonParser :: JsonParser Json+jsonParser = let p = fmap Json (rootParser p) in p
+ src/SimpleParser/Input.hs view
@@ -0,0 +1,105 @@+-- | Useful combinators for 'ParserT' and 'Stream'.+module SimpleParser.Input+  ( peekToken+  , popToken+  , peekChunk+  , popChunk+  , dropChunk+  , isEnd+  , matchEnd+  , anyToken+  , anyChunk+  , satisfyToken+  , foldTokensWhile+  , takeTokensWhile+  , dropTokensWhile+  , matchToken+  , 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 (chunkLength), Stream (..))++-- | Return the next token, if any, but don't consume it.+peekToken :: (Stream s, Monad m) => ParserT e s 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))+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))+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))+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)+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++-- | 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)++-- | 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 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++-- | 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++-- | 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+  go !x = do+    m <- peekToken+    case m of+      Nothing -> pure (g x)+      Just c ->+        let (ok, newX) = f 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)+takeTokensWhile = state . streamTakeWhile++-- | 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+dropTokensWhile = state . streamDropWhile++-- | 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 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)
+ src/SimpleParser/Parser.hs view
@@ -0,0 +1,199 @@+-- | 'ParserT' is the core monad transformer for parsing.+module SimpleParser.Parser+  ( ParserT (..)+  , Parser+  , runParser+  , filterParser+  , reflectParser+  , branchParser+  , suppressParser+  , defaultParser+  , optionalParser+  , silenceParser+  , greedyStarParser+  , greedyStarParser_+  , greedyPlusParser+  , greedyPlusParser_+  ) where++import Control.Applicative (Alternative (..), liftA2)+import Control.Monad (MonadPlus (..), ap, (>=>))+import Control.Monad.Except (MonadError (..))+import Control.Monad.Identity (Identity (..))+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 (..))++-- | 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) }+  deriving (Functor)++-- | Use 'Parser' if you have no need for other monadic effects.+type Parser e s a = ParserT e s Identity a++instance Monad m => Applicative (ParserT e s m) where+  pure a = ParserT (pure . ParseResult (ParseSuccess a))+  (<*>) = ap++instance Monad m => Monad (ParserT e s 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++instance Monad m => Alternative (ParserT e s m) where+  empty = ParserT (const empty)+  first <|> second = ParserT (\s -> runParserT first s <|> runParserT second s)++instance Monad m => MonadPlus (ParserT e s 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 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))++instance MonadTrans (ParserT e s) where+  lift ma = ParserT (\s -> lift (fmap (\a -> ParseResult (ParseSuccess a) s) ma))++-- | 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))++-- | 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)))++-- | 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)))++-- | Combines the results of many parsers.+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))++-- | 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.+suppressParser :: Monad m => ParserT e s m a -> ParserT e s m a+suppressParser 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 _ -> pure (Just (r, ListT (filterOk rest)))++  returnErr racc =+    case racc of+      [] -> pure Nothing+      r:rs -> pure (Just (r, ListT (returnErr rs)))++  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))++-- | 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++-- | 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)+optionalParser parser = defaultParser Nothing (fmap Just parser)++-- | Removes all failures from the parse results.+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))++-- | 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+    case res of+      Nothing -> pure (reverse acc)+      Just a -> go (a:acc)++-- | 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+    case res of+      Nothing -> pure ()+      Just _ -> go++-- | 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)++-- | Same as 'greedyPlusParser' but discards the result.+greedyPlusParser_ :: Monad m => ParserT e s m a -> ParserT e s m ()+greedyPlusParser_ parser = parser *> greedyStarParser_ parser
+ src/SimpleParser/Result.hs view
@@ -0,0 +1,31 @@+module SimpleParser.Result+  ( ParseResult (..)+  , ParseValue (..)+  , parseSuccessResult+  , parseErrorResult+  , parseValue+  ) where++-- | Strict 'Either' for parse results.+data ParseValue e a =+    ParseError !e+  | ParseSuccess !a+  deriving (Eq, Show, Functor, Foldable, Traversable)++parseValue :: (e -> r) -> (a -> r) -> ParseValue e a -> r+parseValue onError onSuccess value =+  case value of+    ParseError e -> onError e+    ParseSuccess a -> onSuccess a++-- | 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+  } deriving (Eq, Show, Functor, Foldable, Traversable)++parseSuccessResult :: a -> s -> ParseResult e s a+parseSuccessResult = ParseResult . ParseSuccess++parseErrorResult :: e -> s -> ParseResult e s a+parseErrorResult = ParseResult . ParseError
+ src/SimpleParser/Stream.hs view
@@ -0,0 +1,149 @@+-- | This reworks 'Text.Megaparsec.Stream' to split interfaces.+-- See https://hackage.haskell.org/package/megaparsec-9.0.1/docs/Text-Megaparsec-Stream.html+module SimpleParser.Stream+  ( Chunked (..)+  , Stream (..)+  , defaultStreamDropN+  , defaultStreamDropWhile+  , OffsetStream (..)+  , newOffsetStream+  ) where++import Data.Bifunctor (first, second)+import Data.Foldable (toList)+import Data.Kind (Type)+import Data.List (uncons)+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++-- | '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++  streamTake1 :: s -> Maybe (Token s, s)+  streamTakeN :: Int -> s -> Maybe (Chunk s, s)+  streamTakeWhile :: (Token s -> Bool) -> s -> (Chunk s, s)++  streamDropN :: Int -> s -> Maybe (Int, s)+  streamDropN = defaultStreamDropN++  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++instance Stream [a] where+  type instance Chunk [a] = [a]+  type instance Token [a] = a++  streamTake1 l =+    case l of+      [] -> Nothing+      t:ts -> Just (t, ts)+  streamTakeN n s+    | n <= 0 = Just ([], s)+    | null s = Nothing+    | otherwise = Just (splitAt n s)+  streamTakeWhile = span++instance Stream (Seq a) where+  type instance Chunk (Seq a) = Seq a+  type instance Token (Seq a) = a++  streamTake1 s =+    case s of+      Empty -> Nothing+      t :<| ts -> Just (t, ts)+  streamTakeN n s+    | n <= 0 = Just (Seq.empty, s)+    | Seq.null s = Nothing+    | otherwise = Just (Seq.splitAt n s)+  streamTakeWhile = Seq.spanl++instance Stream Text where+  type instance Chunk Text = Text+  type instance Token Text = Char++  streamTake1 = T.uncons+  streamTakeN n s+    | n <= 0 = Just (T.empty, s)+    | T.null s = Nothing+    | otherwise = Just (T.splitAt n s)+  streamTakeWhile = T.span++data OffsetStream s = OffsetStream+  { osOffset :: !Int+  , 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++  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) =+    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) =+    let (m, b) = streamDropWhile pcate s+    in (m, OffsetStream (o + m) b)++newOffsetStream :: s -> OffsetStream s+newOffsetStream = OffsetStream 0
+ test/Main.hs view
@@ -0,0 +1,529 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Main (main) where++import Control.Applicative (empty)+import Control.Monad.Except (catchError, throwError)+import Data.Foldable (asum)+import Data.Functor (($>))+import Data.Text (Text)+import SimpleParser+import SimpleParser.Examples.Json (Json (..), JsonF (..), parseJson)+import Test.Tasty (TestName, TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, testCase, (@?=))+import Test.Tasty.TH (defaultMainGenerator)++newtype Error = Error { unError :: String } deriving (Eq, Show)++type TestParser a = Parser Error (OffsetStream Text) a++type TestResult a = ParseResult Error (OffsetStream Text) a++data InputOutput a = InputOutput !Text ![TestResult 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++testParserCase :: (Show a, Eq a) => TestName -> TestParser a -> InputOutput a -> TestTree+testParserCase name parser inOut = testCase name (runParserCase parser inOut)++testParserTrees :: (Show a, Eq a) => TestParser a -> [(TestName, InputOutput a)] -> [TestTree]+testParserTrees parser = fmap (\(n, io) -> testParserCase n parser io)++test_empty :: [TestTree]+test_empty =+  let parser = empty :: TestParser Int+      cases =+        [ ("empty", InputOutput "" [])+        , ("non-empty", InputOutput "hi" [])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser cases++test_match_end :: [TestTree]+test_match_end =+  let parser = matchEnd+      cases =+        [ ("empty", InputOutput "" [parseSuccessResult () (OffsetStream 0 "")])+        , ("non-empty", InputOutput "hi" [])+        ]+  in testParserTrees parser cases++test_any_token :: [TestTree]+test_any_token =+  let parser = anyToken+      cases =+        [ ("empty", InputOutput "" [])+        , ("non-empty", InputOutput "hi" [parseSuccessResult 'h' (OffsetStream 1 "i")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser 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" [])+        ]+  in testParserTrees parser 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" [])+        ]+  in testParserTrees parser cases++test_greedy_star :: [TestTree]+test_greedy_star =+  let parser = greedyStarParser (matchToken 'h')+      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")])+        ]+  in testParserTrees parser 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")])+        ]+  in testParserTrees parser cases++test_greedy_plus :: [TestTree]+test_greedy_plus =+  let parser = greedyPlusParser (matchToken 'h')+      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" [])+        ]+  in testParserTrees parser 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" [])+        ]+  in testParserTrees parser cases++test_combine_first :: [TestTree]+test_combine_first =+  let state = OffsetStream 1 "i"+      parser = asum [anyToken $> 'h', matchToken 'x']+      cases =+        [ ("empty", InputOutput "" [])+        , ("first", InputOutput "hi" [parseSuccessResult 'h' state])+        , ("second", InputOutput "xi" [parseSuccessResult 'h' state, parseSuccessResult 'x' state])+        ]+  in testParserTrees parser cases++test_combine_second :: [TestTree]+test_combine_second =+  let state = OffsetStream 1 "i"+      parser = asum [empty, anyToken $> 'x']+      cases =+        [ ("empty", InputOutput "" [])+        , ("first", InputOutput "hi" [parseSuccessResult 'x' state])+        , ("second", InputOutput "xi" [parseSuccessResult 'x' state])+        ]+  in testParserTrees parser cases++test_with_default_empty :: [TestTree]+test_with_default_empty =+  let parser = defaultParser 'z' empty+      cases =+        [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")])+        , ("non-empty", InputOutput "hi" [parseSuccessResult 'z' (OffsetStream 0 "hi")])+        ]+  in testParserTrees parser cases++test_with_default :: [TestTree]+test_with_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")])+        ]+  in testParserTrees parser cases++test_bind_multi_pre :: [TestTree]+test_bind_multi_pre =+  let state = OffsetStream 1 "i"+      parser = asum [anyToken $> 'h', matchToken 'x'] >>= \c -> pure [c, c]+      cases =+        [ ("empty", InputOutput "" [])+        , ("first", InputOutput "hi" [parseSuccessResult "hh" state])+        , ("second", InputOutput "xi" [parseSuccessResult "hh" state, parseSuccessResult "xx" state])+        ]+  in testParserTrees parser 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']+      cases =+        [ ("empty", InputOutput "" [])+        , ("first", InputOutput "hi" [parseSuccessResult 'h' state1, parseSuccessResult 'i' state2])+        , ("second", InputOutput "xi" [parseSuccessResult 'x' state1, parseSuccessResult 'i' state2])+        ]+  in testParserTrees parser cases++test_throw :: [TestTree]+test_throw =+  let err = Error "boo"+      parser = throwError err :: TestParser Int+      cases =+        [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")])+        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")])+        ]+  in testParserTrees parser cases++test_consume_throw :: [TestTree]+test_consume_throw =+  let err = Error "boo"+      parser = anyToken *> throwError err :: TestParser Int+      cases =+        [ ("empty", InputOutput "" [])+        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")])+        ]+  in testParserTrees parser cases++test_with_default_throw :: [TestTree]+test_with_default_throw =+  let err = Error "boo"+      parser = defaultParser 'z' (throwError err)+      cases =+        [ ("empty", InputOutput "" [parseErrorResult err (OffsetStream 0 "")])+        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 0 "hi")])+        ]+  in testParserTrees parser cases++test_with_default_consume_throw :: [TestTree]+test_with_default_consume_throw =+  let err = Error "boo"+      parser = defaultParser 'z' (anyToken *> throwError err)+      cases =+        [ ("empty", InputOutput "" [parseSuccessResult 'z' (OffsetStream 0 "")])+        , ("non-empty", InputOutput "hi" [parseErrorResult err (OffsetStream 1 "i")])+        ]+  in testParserTrees parser cases++test_throw_mixed :: [TestTree]+test_throw_mixed =+  let state = OffsetStream 0 "hi"+      err = Error "boo"+      parser = asum [throwError err, pure 1 :: TestParser Int]+      cases =+        [ ("non-empty", InputOutput "hi" [parseErrorResult err state, parseSuccessResult 1 state])+        ]+  in testParserTrees parser 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+      cases =+        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 state, parseSuccessResult 1 state])+        ]+  in testParserTrees parser 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_silence_success :: [TestTree]+test_silence_success =+  let state = OffsetStream 0 "hi"+      parser = silenceParser (asum [pure 1, pure 2]) :: TestParser Int+      cases =+        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 state, parseSuccessResult 2 state])+        ]+  in testParserTrees parser cases++test_silence_fail_first :: [TestTree]+test_silence_fail_first =+  let err = Error "boo"+      parser = silenceParser (asum [throwError err, pure 2]) :: TestParser Int+      cases =+        [ ("non-empty", InputOutput "hi" [parseSuccessResult 2 (OffsetStream 0 "hi")])+        ]+  in testParserTrees parser cases++test_silence_fail_second :: [TestTree]+test_silence_fail_second =+  let err = Error "boo"+      parser = silenceParser (asum [pure 1, throwError err]) :: TestParser Int+      cases =+        [ ("non-empty", InputOutput "hi" [parseSuccessResult 1 (OffsetStream 0 "hi")])+        ]+  in testParserTrees parser 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+      cases =+        [ ("non-empty", InputOutput "hi" [])+        ]+  in testParserTrees parser 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 "")])+        ]+  in testParserTrees parser 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 "")])+        ]+  in testParserTrees parser cases++testJsonCase :: TestName -> Text -> [Json] -> TestTree+testJsonCase name str expected = testCase ("json " <> name) $ do+  let actual = parseJson str+  actual @?= expected++testJsonTrees :: [(TestName, Text, [Json])] -> [TestTree]+testJsonTrees = fmap (\(n, s, e) -> testJsonCase n s e)++test_json :: [TestTree]+test_json =+  let nullVal = Json JsonNull+      trueVal = Json (JsonBool True)+      falseVal = Json (JsonBool False)+      arrVal = Json . JsonArray+      strVal = Json . JsonString+      objVal = Json . JsonObject+      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)]])+        ]+  in testJsonTrees cases++main :: IO ()+main = $(defaultMainGenerator)