summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorkoral <>2017-06-16 06:04:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-06-16 06:04:00 (GMT)
commit0dfbdc20dd5ce9fb85dda6f40c58c56fbeec5426 (patch)
tree353eb0ea69a6aa137beb0b8d21802268efaa13de
parent4335d9b175b0654930db1d5df204eafb63894f40 (diff)
version 0.1.2.10.1.2.1
-rw-r--r--Data/Conduit/Parser.hs9
-rw-r--r--Data/Conduit/Parser/Internal.hs68
-rw-r--r--conduit-parse.cabal5
-rw-r--r--test/Main.hs39
4 files changed, 104 insertions, 17 deletions
diff --git a/Data/Conduit/Parser.hs b/Data/Conduit/Parser.hs
index 995507b..9a5c1ee 100644
--- a/Data/Conduit/Parser.hs
+++ b/Data/Conduit/Parser.hs
@@ -3,11 +3,12 @@
-- You probably want to import the "Text.Parser.Combinators" module together with this module.
module Data.Conduit.Parser
( -- * Conduit parser monad
- ConduitParser()
+ ConduitParser(..)
, runConduitParser
, named
-- * Primitives
, await
+ , anyOne
, leftover
, getParserNames
, getParserName
@@ -15,6 +16,12 @@ module Data.Conduit.Parser
, peek
-- * Exception
, ConduitParserException(..)
+ -- * Utilities
+ , parseC
+ , parseOrSkipC
+ , lastRequired
+ , lastDef
+ , embed
) where
import Data.Conduit.Parser.Internal
diff --git a/Data/Conduit/Parser/Internal.hs b/Data/Conduit/Parser/Internal.hs
index e476db7..d50ab76 100644
--- a/Data/Conduit/Parser/Internal.hs
+++ b/Data/Conduit/Parser/Internal.hs
@@ -1,14 +1,19 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
-module Data.Conduit.Parser.Internal where
+module Data.Conduit.Parser.Internal (module Data.Conduit.Parser.Internal) where
-- {{{ Imports
+import qualified Conduit
+
import Control.Applicative
-import Control.Exception.Safe
+import Control.Exception.Safe as Exception
import Control.Monad
import Control.Monad.Error.Class
import Control.Monad.Except
@@ -20,18 +25,20 @@ import qualified Data.Conduit as Conduit
import qualified Data.Conduit.List as Conduit
import Data.DList (DList (..), append, cons)
import Data.Maybe (fromMaybe)
+import Data.Monoid
import Data.Text as Text (Text, pack, unpack)
import Safe
+import Text.Parser.Char
import Text.Parser.Combinators as Parser
-- }}}
-- | Core type of the package. This is basically a 'Sink' with a parsing state.
newtype ConduitParser i m a = ConduitParser (ExceptT ConduitParserException (StateT ([Text], Buffer i) (Sink i m)) a)
-deriving instance Applicative (ConduitParser i m)
deriving instance Functor (ConduitParser i m)
+deriving instance Applicative (ConduitParser i m)
deriving instance Monad (ConduitParser i m)
deriving instance (MonadCatch m) => MonadCatch (ConduitParser i m)
deriving instance (MonadIO m) => MonadIO (ConduitParser i m)
@@ -93,6 +100,18 @@ instance (Monad m) => Parsing (ConduitParser i m) where
name <- getParserName
forM_ result $ \_ -> throwError $ UnexpectedFollowedBy name
+-- instance LookAheadParsing (ConduitParser i m) where
+-- lookAhead parser = do
+
+
+instance (Monad m) => CharParsing (ConduitParser Char m) where
+ satisfy f = do
+ c <- await
+ if f c
+ then return c
+ else unexpected $ "Unexpected character '" <> [c] <> "'"
+
+
-- | Flipped version of ('<?>').
named :: (Monad m) => Text -> ConduitParser i m a -> ConduitParser i m a
named name = flip (<?>) (unpack name)
@@ -136,10 +155,7 @@ backtrack = mapM_ leftover =<< withBuffer resetBuffer
newtype Buffer i = Buffer (Maybe (DList i)) deriving(Monoid)
deriving instance (Show i) => Show (Buffer i)
-
-instance Functor Buffer where
- fmap _ (Buffer Nothing) = Buffer mempty
- fmap f (Buffer (Just a)) = Buffer $ Just $ fmap f a
+deriving instance Functor Buffer
instance Foldable Buffer where
foldMap _ (Buffer Nothing) = mempty
@@ -172,6 +188,10 @@ await = do
withBuffer $ prependItem e
return e
+-- | Synonym for 'await'
+anyOne :: (Monad m) => ConduitParser i m i
+anyOne = await
+
-- | 'Conduit.leftover' wrapped as a 'ConduitParser'.
leftover :: i -> ConduitParser i m ()
leftover = ConduitParser . lift . lift . Conduit.leftover
@@ -198,3 +218,37 @@ instance Exception ConduitParserException where
displayException UnexpectedEndOfInput = "Unexpected end of input."
displayException (UnexpectedFollowedBy t) = "Should not be followed by " ++ unpack t
displayException (Unexpected t) = unpack t
+
+
+data Result a = Parsed a | Skipped | Invalid | EndOfInput
+
+-- | Turn a parser into a regular 'Conduit' that yields parsed items as long as the parser succeeds.
+-- Once the parser fails, the conduit stops consuming input and won't yield any more.
+parseC :: (MonadThrow m) => ConduitParser i m a -> Conduit i m a
+parseC parser = fix $ \recurse -> do
+ result <- toConsumer $ runConduitParser $ (Parsed <$> parser) <|> (EndOfInput <$ eof) <|> pure Invalid
+
+ case result of
+ Parsed item -> yield item >> recurse
+ _ -> return ()
+
+parseOrSkipC :: (MonadThrow m) => ConduitParser i m a -> ConduitParser i m b -> Conduit i m a
+parseOrSkipC parser skip = fix $ \recurse -> do
+ result <- toConsumer $ runConduitParser $ (Parsed <$> parser) <|> (EndOfInput <$ eof) <|> (Skipped <$ skip) <|> pure Invalid
+
+ case result of
+ Parsed item -> yield item >> recurse
+ Skipped -> recurse
+ _ -> return ()
+
+
+lastRequired :: MonadThrow m => Text -> Consumer a m a
+lastRequired name = maybe (throw $ Unexpected $ "Missing element: " <> name) return =<< Conduit.lastC
+
+lastDef :: MonadThrow m => a -> Consumer a m a
+lastDef value = fromMaybe value <$> Conduit.lastC
+
+embed :: (MonadCatch m) => Sink i m a -> ConduitParser i m a
+embed sink = do
+ e <- await
+ ConduitParser $ lift $ lift $ yield e =$= sink
diff --git a/conduit-parse.cabal b/conduit-parse.cabal
index 55080e7..3be52e2 100644
--- a/conduit-parse.cabal
+++ b/conduit-parse.cabal
@@ -1,9 +1,9 @@
name: conduit-parse
-version: 0.1.2.0
+version: 0.1.2.1
synopsis: Parsing framework based on conduit.
description: Please refer to README.
homepage: https://github.com/k0ral/conduit-parse
-license: OtherLicense
+license: PublicDomain
license-file: LICENSE
author: koral <koral@mailoo.org>
maintainer: koral <koral@mailoo.org>
@@ -24,6 +24,7 @@ library
build-depends:
base >= 4.8 && < 5
, conduit
+ , conduit-combinators
, dlist
, safe-exceptions
, mtl
diff --git a/test/Main.hs b/test/Main.hs
index 4877934..50c17e8 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -35,6 +35,9 @@ unitTests = testGroup "Unit tests"
, alternativeCase
, catchCase
, parsingCase
+ , parseConduitCase
+ , parseConduitErrorCase
+ -- , parseOrSkipCase
]
hlint :: TestTree
@@ -57,7 +60,7 @@ peekCase = testCase "peek" $ do
leftoverCase :: TestTree
leftoverCase = testCase "leftover" $ do
result <- runResourceT . runConduit $ sourceList [1 :: Int, 2, 3] =$= runConduitParser parser
- result @=? (3, 2, 1)
+ result @?= (3, 2, 1)
where parser = do
(a, b, c) <- (,,) <$> await <*> await <*> await
leftover a >> leftover b >> leftover c
@@ -68,16 +71,16 @@ errorCase = testCase "error" $ do
result1 <- Exception.try . runResourceT . runConduit $ sourceList [] =$= runConduitParser parser
result2 <- Exception.try . runResourceT . runConduit $ sourceList [] =$= runConduitParser (parser <?> "Name1")
result3 <- Exception.try . runResourceT . runConduit $ sourceList [] =$= runConduitParser ((parser <?> "Name1") <?> "Name2")
- result1 @=? Left (Unexpected "ERROR")
- result2 @=? Left (NamedParserException "Name1" $ Unexpected "ERROR")
- result3 @=? Left (NamedParserException "Name2" $ NamedParserException "Name1" $ Unexpected "ERROR")
+ result1 @?= Left (Unexpected "ERROR")
+ result2 @?= Left (NamedParserException "Name1" $ Unexpected "ERROR")
+ result3 @?= Left (NamedParserException "Name2" $ NamedParserException "Name1" $ Unexpected "ERROR")
where parser = unexpected "ERROR" >> return (1 :: Int)
alternativeCase :: TestTree
alternativeCase = testCase "alternative" $ do
result <- runResourceT . runConduit $ sourceList [1 :: Int, 2, 3] =$= runConduitParser parser
- result @=? (1, 2, Nothing)
+ result @?= (1, 2, Nothing)
where parser = do
a <- parseInt 1 <|> parseInt 2
b <- parseInt 1 <|> parseInt 2
@@ -93,11 +96,33 @@ alternativeCase = testCase "alternative" $ do
catchCase :: TestTree
catchCase = testCase "catch" $ do
result <- runResourceT . runConduit $ sourceList [1 :: Int, 2] =$= runConduitParser parser
- result @=? (1, 2)
+ result @?= (1, 2)
where parser = catchError (await >> await >> throwError (Unexpected "ERROR")) . const $ (,) <$> await <*> await
parsingCase :: TestTree
parsingCase = testCase "parsing" $ do
result <- runResourceT . runConduit $ sourceList [1 :: Int, 2] =$= runConduitParser parser
- result @=? (1, 2)
+ result @?= (1, 2)
where parser = (,) <$> await <*> await <* notFollowedBy await <* eof
+
+-- parseOrSkipCase :: TestTree
+-- parseOrSkipCase = testCase "parseOrSkip" $ do
+-- result <- runResourceT . runConduit $ sourceList [1 :: Int, 10, 2, 9, 3, 8, 4, 7, 5, 6] =$= parser `parseOrSkip` anyOne =$= consume
+-- result @?= [10, 9, 8, 7, 6]
+-- where parser = do
+-- integer <- await
+-- if integer >= 6 then return integer else unexpected "Invalid integer"
+
+parseConduitCase :: TestTree
+parseConduitCase = testCase "parseConduit" $ do
+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2, 3, 4, 5, 6, 7, 8, 9, 10] =$= parseC parser =$= consume
+ result @?= [Left 1, Right 2, Left 3, Right 4, Left 5, Right 6, Left 7, Right 8, Left 9, Right 10]
+ where parser = do
+ integer <- await
+ return $ (if odd integer then Left else Right) integer
+
+parseConduitErrorCase :: TestTree
+parseConduitErrorCase = testCase "parseConduitError" $ do
+ result <- Exception.try . runResourceT . runConduit $ sourceList [1 :: Int, 2, 3, 4, 5, 6, 7, 8, 9, 10] =$= parseC parser =$= consume
+ result @?= (Left (Unexpected "Wrong integer") :: Either ConduitParserException [Int])
+ where parser = await >> throw (Unexpected "Wrong integer")