comparse (empty) → 0.1.0.0

raw patch · 16 files changed

+996/−0 lines, 16 filesdep +basedep +comparsedep +mtlsetup-changed

Dependencies added: base, comparse, mtl, tasty, tasty-hunit, transformers

Files

CHANGELOG.md +8/−0
Control/Monad/Parser.hs +28/−0
Control/Monad/Parser/Class.hs +160/−0
Control/Monad/Trans/Parser.hs +168/−0
Data/Stream.hs +24/−0
Data/Stream/StringLines.hs +70/−0
LICENSE +30/−0
README.md +86/−0
Setup.hs +2/−0
comparse.cabal +67/−0
test/Json.hs +107/−0
test/Parsing.hs +152/−0
test/Spec.hs +14/−0
test/Stream.hs +7/−0
test/Stream/Generic.hs +52/−0
test/Stream/StringLines.hs +21/−0

+ CHANGELOG.md view

@@ -0,0 +1,8 @@+# Changelog for comparse++## Unreleased changes++- `ParserT` monad transformer+- Basic combinators+- `Data.Stream.StringLines` to parse multi-line `String` input+- `Parser` and `StringParser` type aliases

+ Control/Monad/Parser.hs view

@@ -0,0 +1,28 @@+module Control.Monad.Parser
+  ( module Control.Monad.Parser.Class,
+    ParserT (..),
+    ParseResult (..),
+    ParseError (..),
+    ErrorDesc (..),
+    Parser,
+    StringParser,
+    runParser,
+    runStringParser,
+  )
+where
+
+import Control.Monad.Identity
+import Control.Monad.Parser.Class
+import Control.Monad.Trans.Parser
+import Data.Stream.StringLines (StringLines)
+import qualified Data.Stream.StringLines as StringLines
+
+type Parser s a = ParserT s Identity a
+
+runParser :: Parser s a -> s -> ParseResult a s
+runParser p = runIdentity . runParserT p
+
+type StringParser a = Parser StringLines a
+
+runStringParser :: StringParser a -> String -> ParseResult a StringLines
+runStringParser p s = runIdentity $ runParserT p $ StringLines.fromString s

+ Control/Monad/Parser/Class.hs view

@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FunctionalDependencies #-}
+
+module Control.Monad.Parser.Class
+  ( module Control.Monad.Parser.Class,
+  )
+where
+
+import Control.Applicative ((<**>))
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Stream
+
+infixl 3 <|>
+
+infixl 1 <?>
+
+-- | A monad with parsing capabilities.
+class Monad m => MonadParser s m | m -> s where
+  -- | The current input stream.
+  parseStream :: m s
+
+  -- | Replace the input stream.
+  setParseStream :: s -> m ()
+
+  -- | A parser that always fails.
+  noParse :: m a
+
+  -- | A parser that returns the next item.
+  item :: m (Item s)
+
+  -- | @followedBy p@ is a parser that succeeds if @p@ succeeds, but it does not
+  -- consume any input.
+  followedBy :: m a -> m ()
+
+  -- | @notFollowedBy p@ is a parser that only succeeds if @p@ fails. This
+  -- parser will not consume any input.
+  notFollowedBy :: m a -> m ()
+
+  -- | @try p@ is a parser that does everything like @p@, except it forcefully
+  -- resets the position of any error reported by @p@ to the current position.
+  try :: m a -> m a
+
+  -- | @p <|> q@ is a parser that is equivalent to @p@ when @p@ succeeds and
+  -- @q@ when @p@ fails to parse anything.
+  (<|>) :: m a -> m a -> m a
+
+  -- | @p <?> msg@ is a parser that behaves like @p@, but when @p@ fails, it
+  -- reports an error indicating that @msg@ was the expected input.
+  (<?>) :: m a -> String -> m a
+
+-- | Parser that succeeds if the stream is empty. Does not consume any items.
+eof :: MonadParser s m => m ()
+eof = notFollowedBy item <?> "end of input"
+
+-- | Fail with an "expected" message.
+expected :: MonadParser s m => String -> m a
+expected s = noParse <?> s
+
+-- | Succeeds only if the value parsed by the parser satisfies the predicate.
+satisfy :: MonadParser s m => m a -> (a -> Bool) -> m a
+satisfy p f = try $ do
+  i <- p
+  if f i
+    then return i
+    else noParse
+
+-- | Parse a single item satisfying the given predicate.
+match :: MonadParser s m => (Item s -> Bool) -> m (Item s)
+match = satisfy item
+
+-- | Make a parser optional.
+optional :: MonadParser s m => m a -> m (Maybe a)
+optional p = Just <$> p <|> pure Nothing
+
+-- | Try a series of parsers in order, returning the first one that succeeds.
+choice :: MonadParser s m => [m a] -> m a
+choice = foldr (<|>) noParse
+
+-- | Try to run the given parser as many times as possible.
+many :: MonadParser s m => m a -> m [a]
+many p = ((:) <$> p <*> many p) <|> pure []
+
+-- | Try to run the given parser as many times as possible, but at least once.
+-- The result is returned as a regular list, but is guaranteed to be non-empty.
+many1 :: MonadParser s m => m a -> m [a]
+many1 p = (:) <$> p <*> many p
+
+-- | Try to run the given parser as many times as possible, but at least once.
+some :: MonadParser s m => m a -> m (NonEmpty a)
+some p = (:|) <$> p <*> many p
+
+-- | Parse a non-empty series of @a@ separated by @b@s (without a trailing @b@).
+sepBy1 :: MonadParser s m => m a -> m b -> m (NonEmpty a)
+sepBy1 a b = (:|) <$> a <*> many (b *> a)
+
+-- | Parse a potentially empty series of @a@ separated by @b@s (without a
+-- trailing @b@).
+sepBy :: MonadParser s m => m a -> m b -> m [a]
+sepBy a b = NonEmpty.toList <$> sepBy1 a b <|> pure []
+
+-- | Parse any value equal to @a@.
+like :: (MonadParser s m, Eq (Item s), Show (Item s)) => Item s -> m (Item s)
+like a = item `satisfy` (== a) <?> show a
+
+-- | Parse any value not equal to @a@.
+unlike :: (MonadParser s m, Eq (Item s), Show (Item s)) => Item s -> m (Item s)
+unlike a = item `satisfy` (/= a) <?> "anything but " ++ show a
+
+-- | Parse a continuous sequence of items equal to the given one.
+string ::
+  (MonadParser s m, Eq (Item s), Show (Item s)) =>
+  [Item s] ->
+  m [Item s]
+string [] = return []
+string (x : xs) = like x >> string xs >> return (x : xs)
+
+-- | Parse any value equal to at least one element of the given list.
+oneOf :: (MonadParser s m, Eq (Item s), Show (Item s)) => [Item s] -> m (Item s)
+oneOf l = item `satisfy` (`elem` l) <?> "one of " ++ show l
+
+-- | Parse any value not equivalent to any element of the given list.
+-- For a version that accepts non-Show items, see @noneOf'@.
+noneOf ::
+  (MonadParser s m, Eq (Item s), Show (Item s)) =>
+  [Item s] ->
+  m (Item s)
+noneOf l = item `satisfy` (`notElem` l) <?> "none of " ++ show l
+
+-- | @chainl1 p op@ Parse a chain of *one* or more occurrences of @p@,
+-- separated by @op@. Return a value obtained by a left associative application
+-- of all functions returned by @op@ to the values returned by @p@.
+--
+-- This is particularly useful for parsing left associative infix operators.
+chainl1 :: MonadParser s m => m a -> m (a -> a -> a) -> m a
+chainl1 p op = scan
+  where
+    scan = p <**> rst
+    rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id
+
+-- | @chainr1 p op@ Parse a chain of *one* or more occurrences of @p@,
+-- separated by @op@. Return a value obtained by a right associative application
+-- of all functions returned by @op@ to the values returned by @p@.
+--
+-- This is particularly useful for parsing right associative infix operators.
+chainr1 :: MonadParser s m => m a -> m (a -> a -> a) -> m a
+chainr1 p op = scan
+  where
+    scan = p <**> rst
+    rst = (flip <$> op <*> scan) <|> pure id
+
+-- | Run a parser on a different stream of items.
+withInput :: MonadParser s m => s -> m a -> m (a, s)
+withInput s' p = do
+  s <- parseStream
+  setParseStream s'
+  x <- p
+  s'' <- parseStream
+  setParseStream s
+  return (x, s'')

+ Control/Monad/Trans/Parser.hs view

@@ -0,0 +1,168 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Control.Monad.Trans.Parser
+  ( ParserT (..),
+    ParseResult (..),
+    ParseError (..),
+    ErrorDesc (..),
+  )
+where
+
+import Control.Monad
+import Control.Monad.Cont.Class
+import Control.Monad.Except
+import Control.Monad.Parser.Class
+import Control.Monad.Reader.Class
+import Control.Monad.State.Class
+import Data.List (union)
+import Data.Stream (Stream (..))
+
+data ErrorDesc = Expected String | Note String deriving (Eq)
+
+data ParseError p = ParseError p [ErrorDesc]
+
+makeOrList :: [String] -> String
+makeOrList [] = ""
+makeOrList [x] = x
+makeOrList [a, b] = a ++ ", or " ++ b
+makeOrList (x : xs) = x ++ ", " ++ makeOrList xs
+
+instance Show p => Show (ParseError p) where
+  show (ParseError p d) =
+    show p ++ "\n" ++ showExpects expects ++ showNotes notes
+    where
+      expects = [e | Expected e <- d]
+      notes = [n | Note n <- d]
+      showExpects [] = ""
+      showExpects es = "expected " ++ makeOrList es ++ "\n"
+      showNotes [] = ""
+      showNotes (n : ns) = "note: " ++ n ++ "\n" ++ showNotes ns
+
+joinErrors :: Ord p => ParseError p -> ParseError p -> ParseError p
+joinErrors e1@(ParseError p1 d1) e2@(ParseError p2 d2)
+  | null d1 && not (null d2) = e2
+  | null d2 && not (null d1) = e1
+  | p1 > p2 = e1
+  | p1 < p2 = e2
+  | otherwise = ParseError p1 (d1 `union` d2)
+
+emptyError :: Stream s => s -> ParseError (Pos s)
+emptyError s = ParseError (getPos s) []
+
+data ParseResult v s
+  = Parsed v s (ParseError (Pos s))
+  | NoParse (ParseError (Pos s))
+
+instance (Show v, Show (Pos s)) => Show (ParseResult v s) where
+  show (Parsed v _ _) = show v
+  show (NoParse e) = show e
+
+-- | Parser monad transformer.
+newtype ParserT s m a = ParserT {runParserT :: s -> m (ParseResult a s)}
+
+instance Functor m => Functor (ParserT s m) where
+  fmap f p = ParserT (fmap t . runParserT p)
+    where
+      t (NoParse e) = NoParse e
+      t (Parsed a s e) = Parsed (f a) s e
+
+instance (Stream s, Applicative m, Monad m) => Applicative (ParserT s m) where
+  pure a = ParserT $ \s -> pure (Parsed a s $ emptyError s)
+  mf <*> mx = ParserT $ runParserT mf >=> pmf
+    where
+      pmf (NoParse e) = pure $ NoParse e
+      pmf (Parsed f s e1) = pmx f e1 <$> runParserT mx s
+      pmx _ e1 (NoParse e2) = NoParse $ joinErrors e1 e2
+      pmx f e1 (Parsed x s' e2) = Parsed (f x) s' $ joinErrors e1 e2
+
+instance (Stream s, Monad m) => Monad (ParserT s m) where
+  return = pure
+  m >>= f = ParserT $ runParserT m >=> first
+    where
+      first (NoParse e) = pure $ NoParse e
+      first (Parsed r s e) = second e <$> runParserT (f r) s
+      second e1 (NoParse e2) = NoParse $ joinErrors e1 e2
+      second e1 (Parsed r s e2) = Parsed r s $ joinErrors e1 e2
+
+instance (Applicative m, Monad m, Stream s) => MonadFail (ParserT s m) where
+  fail msg = ParserT $ \s -> pure $ NoParse $ ParseError (getPos s) [Note msg]
+
+instance (Monad m, Stream s) => MonadParser s (ParserT s m) where
+  parseStream = ParserT $ \s -> pure $ Parsed s s $ emptyError s
+
+  setParseStream s = ParserT $ \_ -> pure $ Parsed () s $ emptyError s
+
+  noParse = ParserT $ \s -> pure $ NoParse $ emptyError s
+
+  item = ParserT $ pure . eat
+    where
+      eat s = case next s of
+        Nothing -> NoParse $ emptyError s
+        Just (x, s') -> Parsed x s' $ emptyError s'
+
+  notFollowedBy p = ParserT $ \s -> go s <$> runParserT p s
+    where
+      go s (NoParse _) = Parsed () s $ emptyError s
+      go s _ = NoParse $ emptyError s
+
+  followedBy p = ParserT $ \s -> do
+    r <- runParserT p s
+    pure $ case r of
+      (NoParse e) -> NoParse e
+      _ -> Parsed () s $ emptyError s
+
+  try p = ParserT $ \s -> do
+    r <- runParserT p s
+    pure $ case r of
+      NoParse _ -> NoParse $ emptyError s
+      _ -> r
+
+  p <|> q = ParserT $ \s -> runParserT p s >>= first s
+    where
+      first _ (Parsed a s' e) = pure $ Parsed a s' e
+      first s (NoParse e) = runParserT q s >>= second e
+      second e1 (Parsed a s' e2) = pure $ Parsed a s' $ joinErrors e1 e2
+      second e1 (NoParse e2) = pure $ NoParse $ joinErrors e1 e2
+
+  p <?> n = ParserT $ \s -> labelize (getPos s) <$> runParserT p s
+    where
+      labelize here (Parsed a s e) = Parsed a s $ name here e
+      labelize here (NoParse e) = NoParse $ name here e
+      name here e@(ParseError pos _)
+        | pos > here = e
+        | otherwise = ParseError here [Expected n]
+
+instance Stream s => MonadTrans (ParserT s) where
+  lift m = ParserT $ \s -> do
+    a <- m
+    pure $ Parsed a s $ emptyError s
+
+instance (Stream s, MonadIO m) => MonadIO (ParserT s m) where
+  liftIO = lift . liftIO
+
+instance (Stream s, MonadState s' m) => MonadState s' (ParserT s m) where
+  get = lift get
+  put s = lift $ put s
+
+instance (Stream s, MonadError e m) => MonadError e (ParserT s m) where
+  throwError e = ParserT $ const $ throwError e
+  catchError m f = ParserT $ \s -> do
+    runParserT m s `catchError` \e -> runParserT (f e) s
+
+instance (Stream s, MonadReader r m) => MonadReader r (ParserT s m) where
+  ask = lift ask
+  local f st = ParserT $ \s -> local f (runParserT st s)
+
+instance (Stream s, MonadCont m) => MonadCont (ParserT s m) where
+  callCC f =
+    ParserT $
+      \s -> callCC $
+        \k ->
+          runParserT
+            ( f $
+                \a -> ParserT $ \s' -> k $ Parsed a s' $ emptyError s'
+            )
+            s

+ Data/Stream.hs view

@@ -0,0 +1,24 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Stream
+  ( Stream (..),
+  )
+where
+
+import Data.Data (Proxy (..))
+import Data.Kind (Type)
+
+class Ord (Pos s) => Stream s where
+  type Item s :: Type
+  type Chunk s :: Type
+  type Pos s :: Type
+
+  next :: s -> Maybe (Item s, s)
+  nextWhile :: (Item s -> Bool) -> s -> (Chunk s, s)
+  nextN :: Int -> s -> (Chunk s, s)
+
+  makeChunk :: Proxy s -> [Item s] -> Chunk s
+  unmakeChunk :: Proxy s -> Chunk s -> [Item s]
+
+  getPos :: s -> Pos s

+ Data/Stream/StringLines.hs view

@@ -0,0 +1,70 @@+{-# LANGUAGE TypeFamilies #-}
+
+module Data.Stream.StringLines
+  ( StringPos (..),
+    StringLines (..),
+    fromString,
+  )
+where
+
+import Data.Stream (Stream (..))
+
+data StringPos = StringPos Int Int String
+
+instance Show StringPos where
+  show (StringPos l c ls) =
+    lnum ++ ":" ++ cnum ++ ":\n" ++ snippet
+    where
+      lnum = show (l + 1)
+      cnum = show (c + 1)
+      gut = replicate (length lnum) ' ' ++ " | "
+      ngut = lnum ++ " | "
+      snippet = gut ++ "\n" ++ ngut ++ ls ++ "\n" ++ gut ++ cursor
+      cursor = replicate c ' ' ++ "^"
+
+instance Eq StringPos where
+  (StringPos l1 c1 _) == (StringPos l2 c2 _) = l1 == l2 && c1 == c2
+
+instance Ord StringPos where
+  compare (StringPos l1 c1 _) (StringPos l2 c2 _) =
+    case compare l1 l2 of
+      EQ -> compare c1 c2
+      x -> x
+
+start :: String -> StringPos
+start s = StringPos 0 0 $ takeWhile (/= '\n') s
+
+adv :: StringPos -> StringPos
+adv (StringPos l c s) = StringPos l (c + 1) s
+
+nextl :: StringPos -> String -> StringPos
+nextl (StringPos l _ _) s = StringPos (l + 1) 0 (takeWhile (/= '\n') s)
+
+data StringLines = StringLines String StringPos deriving (Eq, Show)
+
+instance Stream StringLines where
+  type Item StringLines = Char
+  type Chunk StringLines = String
+  type Pos StringLines = StringPos
+
+  next (StringLines [] _) = Nothing
+  next (StringLines ('\n' : xs) p) = Just ('\n', StringLines xs (nextl p xs))
+  next (StringLines (x : xs) p) = Just (x, StringLines xs (adv p))
+
+  nextWhile f s = case next s of
+    Nothing -> ([], s)
+    Just (x, s') | f x -> (x : xs, s'') where (xs, s'') = nextWhile f s'
+    _ -> ([], s)
+
+  nextN 0 s = ([], s)
+  nextN n s = case next s of
+    Nothing -> ([], s)
+    Just (x, s') -> (x : xs, s'') where (xs, s'') = nextN (n - 1) s'
+
+  makeChunk _ = id
+  unmakeChunk _ = id
+
+  getPos (StringLines _ p) = p
+
+fromString :: String -> StringLines
+fromString s = StringLines s (start s)

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright nasso (c) 2021++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 nasso 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,86 @@+# comparse++[![Tests](https://github.com/nasso/comparse/actions/workflows/tests.yml/badge.svg)](https://github.com/nasso/comparse/actions/workflows/tests.yml)++`comparse` is a parser combinator library supporting arbitrary input types.+Combinators do not care about the exact type of the input stream, allowing you+to use them on your own data source, as long as it supports a specific set of+operations. The `ParserT` monad transformer can wrap around another monad,+allowing you to easily implement features such as tracing, context-sensitive+parsing, state machines, and so on. `comparse` does its best to provide+meaningful error messages without sacrificing performances or the developer+experience when writing parsers.++## Example++The following example shows how to use the `comparse` library to parse a subset+of the [JSON](https://en.wikipedia.org/wiki/JSON) data format:++```hs+import Control.Monad (void)+import Control.Monad.Parser+import Data.Char (isAlpha, isDigit)+import Data.Stream.StringLines++data JValue+  = JString String+  | JNumber Int+  | JBool Bool+  | JNull+  | JObject [(String, JValue)]+  | JArray [JValue]+  deriving (Show)++main :: IO ()+main = interact $ show . parseJValue++parseJValue :: String -> Maybe JValue+parseJValue s =+  case runStringParser (json <* eof) s of+    Parsed v (StringLines "" _) _ -> Just v+    _ -> Nothing++lexeme :: StringParser a -> StringParser a+lexeme p = spaces *> p <* spaces+  where+    spaces = void $ many $ oneOf " \n\r\t"++symbol :: String -> StringParser String+symbol = lexeme . string++json :: StringParser JValue+json =+  JString <$> stringLiteral+    <|> JNumber <$> number+    <|> JBool <$> bool+    <|> JNull <$ symbol "null"+    <|> JObject <$> object+    <|> JArray <$> array++stringLiteral :: StringParser String+stringLiteral = lexeme $ like '"' *> many (unlike '\"') <* like '"'++number :: StringParser Int+number =+  lexeme+    ( read <$> ((:) <$> like '-' <*> many1 digit)+        <|> read <$> (optional (like '+') *> many1 digit)+    )+    <* notFollowedBy (match isAlpha)+  where+    digit = match isDigit++bool :: StringParser Bool+bool = True <$ symbol "true" <|> False <$ symbol "false"++object :: StringParser [(String, JValue)]+object =+  symbol "{"+    *> sepBy ((,) <$> (stringLiteral <* symbol ":") <*> json) (symbol ",")+    <* symbol "}"++array :: StringParser [JValue]+array = symbol "[" *> sepBy json (symbol ",") <* symbol "]"+```++For more examples, please refer to the [tests](test/Parsing.hs).

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ comparse.cabal view

@@ -0,0 +1,67 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           comparse+version:        0.1.0.0+synopsis:       An unopiniated parser combinators library.+description:    Please see the README on GitHub at <https://github.com/nasso/comparse#readme>+category:       Parsing+homepage:       https://github.com/nasso/comparse#readme+bug-reports:    https://github.com/nasso/comparse/issues+author:         nasso+maintainer:     nasso <nassomails@gmail.com>+copyright:      2021 nasso+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    CHANGELOG.md+    LICENSE+    README.md++source-repository head+  type: git+  location: https://github.com/nasso/comparse++library+  exposed-modules:+      Control.Monad.Parser+      Control.Monad.Parser.Class+      Control.Monad.Trans.Parser+      Data.Stream+      Data.Stream.StringLines+  other-modules:+      Paths_comparse+  hs-source-dirs:+      ./+  ghc-options: -Wall+  build-depends:+      base ==4.14.*+    , mtl ==2.2.*+    , transformers ==0.5.*+  default-language: Haskell2010++test-suite comparse-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Json+      Parsing+      Stream+      Stream.Generic+      Stream.StringLines+      Paths_comparse+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      base ==4.14.*+    , comparse+    , mtl ==2.2.*+    , tasty ==1.4.*+    , tasty-hunit ==0.10.*+    , transformers ==0.5.*+  default-language: Haskell2010

+ test/Json.hs view

@@ -0,0 +1,107 @@+module Json (jsonTests) where++import Control.Monad (void)+import Control.Monad.Parser+import Data.Char (isAlpha, isDigit)+import Data.Stream.StringLines+import Test.Tasty+import Test.Tasty.HUnit++data JValue+  = JString String+  | JNumber Int+  | JBool Bool+  | JNull+  | JObject [(String, JValue)]+  | JArray [JValue]+  deriving (Eq, Show)++jsonTests :: [TestTree]+jsonTests =+  [ testCase "string" $ parseJValue "\"foo\"" @?= Just (JString "foo"),+    testCase "empty string" $ parseJValue "\"\"" @?= Just (JString ""),+    testCase "number" $ parseJValue "123" @?= Just (JNumber 123),+    testCase "negative number" $ parseJValue "-123" @?= Just (JNumber (-123)),+    testCase "positive number" $ parseJValue "+123" @?= Just (JNumber 123),+    testCase "bool true" $ parseJValue "true" @?= Just (JBool True),+    testCase "bool false" $ parseJValue "false" @?= Just (JBool False),+    testCase "null" $ parseJValue "null" @?= Just JNull,+    testCase "object" $+      parseJValue "{\"foo\": \"bar\"}"+        @?= Just (JObject [("foo", JString "bar")]),+    testCase "empty object" $ parseJValue "{}" @?= Just (JObject []),+    testCase "array" $+      parseJValue "[1, 2, 3]"+        @?= Just (JArray [JNumber 1, JNumber 2, JNumber 3]),+    testCase "empty array" $ parseJValue "[]" @?= Just (JArray []),+    testCase "nested array" $+      parseJValue "[1, [2, 3], 4]"+        @?= Just (JArray [JNumber 1, JArray [JNumber 2, JNumber 3], JNumber 4]),+    testCase "nested object" $+      parseJValue "{\"foo\": {\"bar\": \"baz\"}}"+        @?= Just (JObject [("foo", JObject [("bar", JString "baz")])]),+    testCase "nested object with array" $+      parseJValue "{\"foo\": {\"bar\": [1, 2, 3]}}"+        @?= Just+          ( JObject+              [ ( "foo",+                  JObject+                    [ ("bar", JArray [JNumber 1, JNumber 2, JNumber 3])+                    ]+                )+              ]+          ),+    testCase "invalid input" $ parseJValue "foo" @?= Nothing,+    testCase "weird spacing" $+      parseJValue "   {\t  \n\"foo\"\r \t: \"bar\"\n }  \t"+        @?= Just (JObject [("foo", JString "bar")]),+    testCase "number followed by letter" $ parseJValue "123a" @?= Nothing+  ]++parseJValue :: String -> Maybe JValue+parseJValue s =+  case runStringParser (json <* eof) s of+    Parsed v (StringLines "" _) _ -> Just v+    _ -> Nothing++lexeme :: StringParser a -> StringParser a+lexeme p = spaces *> p <* spaces+  where+    spaces = void $ many $ oneOf " \n\r\t"++symbol :: String -> StringParser String+symbol = lexeme . string++json :: StringParser JValue+json =+  JString <$> stringLiteral+    <|> JNumber <$> number+    <|> JBool <$> bool+    <|> JNull <$ symbol "null"+    <|> JObject <$> object+    <|> JArray <$> array++stringLiteral :: StringParser String+stringLiteral = lexeme $ like '"' *> many (unlike '\"') <* like '"'++number :: StringParser Int+number =+  lexeme+    ( read <$> ((:) <$> like '-' <*> many1 digit)+        <|> read <$> (optional (like '+') *> many1 digit)+    )+    <* notFollowedBy (match isAlpha)+  where+    digit = match isDigit++bool :: StringParser Bool+bool = True <$ symbol "true" <|> False <$ symbol "false"++object :: StringParser [(String, JValue)]+object =+  symbol "{"+    *> sepBy ((,) <$> (stringLiteral <* symbol ":") <*> json) (symbol ",")+    <* symbol "}"++array :: StringParser [JValue]+array = symbol "[" *> sepBy json (symbol ",") <* symbol "]"

+ test/Parsing.hs view

@@ -0,0 +1,152 @@+module Parsing where
+
+import Control.Monad.Parser
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Stream.StringLines
+import Test.Tasty
+import Test.Tasty.HUnit
+
+parse :: StringParser a -> String -> Maybe (a, String)
+parse p s =
+    case runStringParser p s of
+        Parsed v (StringLines rest _) _ -> Just (v, rest)
+        _ -> Nothing
+
+parserTests :: [TestTree]
+parserTests =
+    [ coreParserTests
+    , coreCombinatorsTests
+    , derivedParserTests
+    , derivedCombinatorsTests
+    ]
+
+coreParserTests :: TestTree
+coreParserTests =
+    testGroup
+        "Core parsers"
+        [ testCase "item returns next char" $
+            parse item "hi" @?= Just ('h', "i")
+        , testCase "item fails on eof" $
+            parse item "" @?= Nothing
+        , testCase "eof succeeds on eof" $
+            parse eof "" @?= Just ((), "")
+        , testCase "eof fails on non-eof" $
+            parse eof "hi" @?= Nothing
+        , testCase "noParse fails with non-empty input" $
+            parse (noParse :: StringParser ()) "hi" @?= Nothing
+        , testCase "noParse fails with empty input" $
+            parse (noParse :: StringParser ()) "" @?= Nothing
+        ]
+
+coreCombinatorsTests :: TestTree
+coreCombinatorsTests =
+    testGroup
+        "Core combinators"
+        [ testCase "followedBy fails when parser fails" $
+            parse (followedBy $ like 'h') "ello" @?= Nothing
+        , testCase "followedBy succeeds without consuming input" $
+            parse (followedBy $ like 'h') "hi" @?= Just ((), "hi")
+        , testCase "notFollowedBy fails when parser succeeds" $
+            parse (notFollowedBy $ like 'h') "hi" @?= Nothing
+        , testCase "notFollowedBy succeeds without consuming input" $
+            parse (notFollowedBy $ like 'g') "hi" @?= Just ((), "hi")
+        , testCase "`a <|> b` returns a when it succeeds" $
+            parse (like 'h' <|> like 'g') "hi" @?= Just ('h', "i")
+        , testCase "`a <|> b` returns b when a fails" $
+            parse (like 'g' <|> like 'h') "hi" @?= Just ('h', "i")
+        , testCase "`a <|> b` fails when both fail" $
+            parse (like 'g' <|> like 'i') "hi" @?= Nothing
+        ]
+
+derivedParserTests :: TestTree
+derivedParserTests =
+    testGroup
+        "Derived parsers"
+        [ testCase "like succeeds on matching item" $
+            parse (like 'h') "hi" @?= Just ('h', "i")
+        , testCase "like fails on non-matching item" $
+            parse (like 'h') "pi" @?= Nothing
+        , testCase "like fails on eof" $
+            parse (like 'h') "" @?= Nothing
+        , testCase "unlike succeeds on non-matching item" $
+            parse (unlike 'g') "hi" @?= Just ('h', "i")
+        , testCase "unlike fails on matching item" $
+            parse (unlike 'h') "hi" @?= Nothing
+        , testCase "string succeeds on matching string" $
+            parse (string "hell") "hello" @?= Just ("hell", "o")
+        , testCase "string fails on non-matching string" $
+            parse (string "hello") "hi" @?= Nothing
+        , testCase "`string \"\"` succeeds on arbitrary input" $
+            parse (string "") "hi" @?= Just ("", "hi")
+        , testCase "`string \"\"` succeeds on empty input" $
+            parse (string "") "" @?= Just ("", "")
+        ]
+
+derivedCombinatorsTests :: TestTree
+derivedCombinatorsTests =
+    testGroup
+        "Derived combinators"
+        [ testCase "satisfy succeeds on matching char" $
+            parse (satisfy item (== 'h')) "hi" @?= Just ('h', "i")
+        , testCase "satisfy fails on non-matching char" $
+            parse (satisfy item (== 'g')) "hi" @?= Nothing
+        , testCase "optional returns Nothing on eof" $
+            parse (optional item) "" @?= Just (Nothing, "")
+        , testCase "optional returns Nothing on failure" $
+            parse (optional $ like 'g') "hi" @?= Just (Nothing, "hi")
+        , testCase "optional returns Just on success" $
+            parse (optional item) "hi" @?= Just (Just 'h', "i")
+        , testCase "many returns empty list on eof" $
+            parse (many item) "" @?= Just ([], "")
+        , testCase "many returns list of items" $
+            parse (many item) "hi" @?= Just ("hi", "")
+        , testCase "many1 fails on eof" $
+            parse (many1 item) "" @?= Nothing
+        , testCase "many1 returns non-empty list of items" $
+            parse (many1 item) "hi" @?= Just ("hi", "")
+        , testCase "some fails on eof" $
+            parse (some item) "" @?= Nothing
+        , testCase "some returns NonEmpty list of items" $
+            parse (some item) "hi" @?= Just (NonEmpty.fromList "hi", "")
+        , testCase "choice takes first successful parser" $
+            parse (choice [like 'h', like 'g']) "hi" @?= Just ('h', "i")
+        , testCase "choice with empty parser list fails" $
+            parse (choice [] :: StringParser ()) "hi" @?= Nothing
+        , testCase "choice with no matching parser fails" $
+            parse (choice [like 'g', like 'j']) "hi" @?= Nothing
+        , testCase "sepBy matches empty list" $
+            parse (sepBy item $ like ',') "" @?= Just ([], "")
+        , testCase "sepBy matches list of one item" $
+            parse (sepBy item $ like ',') "hi" @?= Just ("h", "i")
+        , testCase "sepBy matches list of many items" $
+            parse (sepBy item $ like ',') "h,e,llo" @?= Just ("hel", "lo")
+        , testCase "sepBy doesn't consume trailing separator" $
+            parse (sepBy item $ like ',') "h,i," @?= Just ("hi", ",")
+        , testCase "sepBy1 doesn't match empty list" $
+            parse (sepBy1 item $ like ',') "" @?= Nothing
+        , testCase "sepBy1 matches list of one item" $
+            parse (sepBy1 item $ like ',') "hi"
+                @?= Just (NonEmpty.fromList "h", "i")
+        , testCase "sepBy1 matches list of many items" $
+            parse (sepBy1 item $ like ',') "h,e,llo"
+                @?= Just (NonEmpty.fromList "hel", "lo")
+        , testCase "sepBy1 doesn't consume trailing separator" $
+            parse (sepBy1 item $ like ',') "h,i,"
+                @?= Just (NonEmpty.fromList "hi", ",")
+        , testCase "oneOf fails when item doesn't match any" $
+            parse (oneOf "gj") "hi" @?= Nothing
+        , testCase "oneOf succeeds when item matches one" $
+            parse (oneOf "gh") "hi" @?= Just ('h', "i")
+        , testCase "oneOf succeeds when item matches many" $
+            parse (oneOf "ghh") "hi" @?= Just ('h', "i")
+        , testCase "oneOf fails with empty class" $
+            parse (oneOf "") "hi" @?= Nothing
+        , testCase "noneOf succeeds when item doesn't match any" $
+            parse (noneOf "gj") "hi" @?= Just ('h', "i")
+        , testCase "noneOf fails when item matches one" $
+            parse (noneOf "gh") "hi" @?= Nothing
+        , testCase "noneOf fails when item matches many" $
+            parse (noneOf "ghh") "hi" @?= Nothing
+        , testCase "noneOf succeeds with empty class" $
+            parse (noneOf "") "hi" @?= Just ('h', "i")
+        ]

+ test/Spec.hs view

@@ -0,0 +1,14 @@+import Json
+import Parsing
+import Stream
+import Test.Tasty
+
+main :: IO ()
+main =
+  defaultMain $
+    testGroup
+      "Tests"
+      [ testGroup "Streams" streamTests,
+        testGroup "Parsers" parserTests,
+        testGroup "Json" jsonTests
+      ]

+ test/Stream.hs view

@@ -0,0 +1,7 @@+module Stream (streamTests) where
+
+import Stream.StringLines (stringStreamTests)
+import Test.Tasty
+
+streamTests :: [TestTree]
+streamTests = [stringStreamTests]

+ test/Stream/Generic.hs view

@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Stream.Generic (genericStreamTests) where
+
+import Data.Stream
+import Data.String (IsString, fromString)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+genericStreamTests ::
+  ( Stream s
+  , Show s
+  , Eq s
+  , Item s ~ Char
+  , IsString (Chunk s)
+  , Eq (Chunk s)
+  , Show (Chunk s)
+  ) =>
+  (Int -> Int -> String -> s) ->
+  [TestTree]
+genericStreamTests makeAt =
+  [ testCase "next on same line gives next character" $
+      next (make "foo\nbar\nbaz") @?= Just ('f', makeAt 0 1 "oo\nbar\nbaz")
+  , testCase "next at end of line gives linefeed" $
+      next (make "\nbar\nbaz") @?= Just ('\n', makeAt 1 0 "bar\nbaz")
+  , testCase "next before end of line stops before linefeed" $
+      next (make "o\nbar\nbaz") @?= Just ('o', makeAt 0 1 "\nbar\nbaz")
+  , testCase "next at end of file gives Nothing" $
+      next (make "") @?= Nothing
+  , testCase "nextWhile gives empty chunk when nothing matches" $
+      nextWhile (== 'x') (make "foo") @?= (fromString "", makeAt 0 0 "foo")
+  , testCase "nextWhile gives matching chunk" $
+      nextWhile (== 'o') (make "oof") @?= (fromString "oo", makeAt 0 2 "f")
+  , testCase "nextWhile can consume all stream" $
+      nextWhile (const True) (make "foo") @?= (fromString "foo", makeAt 0 3 "")
+  , testCase "nextWhile can consume multiple lines" $
+      nextWhile (const True) (make "foo\nbar\nbaz")
+        @?= (fromString "foo\nbar\nbaz", makeAt 2 3 "")
+  , testCase "nextN consume nothing when N=0" $
+      nextN 0 (make "foo") @?= (fromString "", makeAt 0 0 "foo")
+  , testCase "nextN consume one character when N=1" $
+      nextN 1 (make "foo") @?= (fromString "f", makeAt 0 1 "oo")
+  , testCase "nextN consume multiple characters when N>1" $
+      nextN 3 (make "foo") @?= (fromString "foo", makeAt 0 3 "")
+  , testCase "nextN stops at end of file" $
+      nextN 3 (make "") @?= (fromString "", makeAt 0 0 "")
+  , testCase "nextN counts linefeeds" $
+      nextN 2 (make "\nfoo\nbar") @?= (fromString "\nf", makeAt 1 1 "oo\nbar")
+  ]
+ where
+  make = makeAt 0 0

+ test/Stream/StringLines.hs view

@@ -0,0 +1,21 @@+module Stream.StringLines (stringStreamTests) where
+
+import Data.Stream
+import Data.Stream.StringLines (StringLines (..), StringPos (StringPos))
+import qualified Data.Stream.StringLines as StringLines
+import Stream.Generic (genericStreamTests)
+import Test.Tasty
+import Test.Tasty.HUnit
+
+stringStreamTests :: TestTree
+stringStreamTests =
+  testGroup "String" $
+    [ testCase "fromString" $
+        StringLines.fromString "foo\nbar\nbaz"
+          @?= StringLines "foo\nbar\nbaz" (StringPos 0 0 "foo")
+    , testCase "getPos returns current position" $
+        getPos (makeAt 3 5 "foo\nbar") @?= StringPos 3 5 "foo"
+    ]
+      ++ genericStreamTests makeAt
+ where
+  makeAt l c s = StringLines s $ StringPos l c $ takeWhile (/= '\n') s