diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/simple-parser.cabal b/simple-parser.cabal new file mode 100644 --- /dev/null +++ b/simple-parser.cabal @@ -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 +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 diff --git a/src/SimpleParser.hs b/src/SimpleParser.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser.hs @@ -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 diff --git a/src/SimpleParser/Examples/Json.hs b/src/SimpleParser/Examples/Json.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Examples/Json.hs @@ -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 diff --git a/src/SimpleParser/Input.hs b/src/SimpleParser/Input.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Input.hs @@ -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) diff --git a/src/SimpleParser/Parser.hs b/src/SimpleParser/Parser.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Parser.hs @@ -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 diff --git a/src/SimpleParser/Result.hs b/src/SimpleParser/Result.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Result.hs @@ -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 diff --git a/src/SimpleParser/Stream.hs b/src/SimpleParser/Stream.hs new file mode 100644 --- /dev/null +++ b/src/SimpleParser/Stream.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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)