summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorkoral <>2016-08-23 11:42:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-08-23 11:42:00 (GMT)
commit4335d9b175b0654930db1d5df204eafb63894f40 (patch)
tree176d97619d6bff1218bd96662360bc0d96ca9f8a
parentdf019a14a88048de47970e27866f040eaf753f84 (diff)
version 0.1.2.00.1.2.0
-rw-r--r--Data/Conduit/Parser.hs3
-rw-r--r--Data/Conduit/Parser/Internal.hs49
-rw-r--r--conduit-parse.cabal7
-rw-r--r--test/Main.hs12
4 files changed, 41 insertions, 30 deletions
diff --git a/Data/Conduit/Parser.hs b/Data/Conduit/Parser.hs
index 0b232bf..995507b 100644
--- a/Data/Conduit/Parser.hs
+++ b/Data/Conduit/Parser.hs
@@ -9,6 +9,7 @@ module Data.Conduit.Parser
-- * Primitives
, await
, leftover
+ , getParserNames
, getParserName
-- * Utility
, peek
@@ -16,4 +17,4 @@ module Data.Conduit.Parser
, ConduitParserException(..)
) where
-import Data.Conduit.Parser.Internal
+import Data.Conduit.Parser.Internal
diff --git a/Data/Conduit/Parser/Internal.hs b/Data/Conduit/Parser/Internal.hs
index ca93cef..e476db7 100644
--- a/Data/Conduit/Parser/Internal.hs
+++ b/Data/Conduit/Parser/Internal.hs
@@ -8,25 +8,27 @@ module Data.Conduit.Parser.Internal where
-- {{{ Imports
import Control.Applicative
-import Control.Arrow (second)
+import Control.Exception.Safe
import Control.Monad
-import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.Except
import Control.Monad.Trans.State
+import Data.Bifunctor
import Data.Conduit hiding (await, leftover)
import qualified Data.Conduit as Conduit
import qualified Data.Conduit.List as Conduit
-import Data.DList
+import Data.DList (DList (..), append, cons)
import Data.Maybe (fromMaybe)
-import Data.Text as Text (Text, null, pack, unpack)
+import Data.Text as Text (Text, pack, unpack)
+
+import Safe
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)
+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)
@@ -46,10 +48,9 @@ instance MonadTrans (ConduitParser i) where
-- which means the consumer no longer uses constant memory.
instance MonadError ConduitParserException (ConduitParser i m) where
throwError e = do
- name <- getParserName
- if Text.null name
- then ConduitParser $ throwError e
- else ConduitParser . throwError $ NamedParserException name e
+ names <- getParserNames
+ ConduitParser . throwError $ foldr NamedParserException e $ reverse names
+
catchError (ConduitParser f) handler = do
buffer <- withBuffer resetBuffer
withBuffer $ setEnabled True
@@ -57,7 +58,7 @@ instance MonadError ConduitParserException (ConduitParser i m) where
result <- ConduitParser $ (Right <$> f) `catchError` (return . Left)
case result of
- Left e -> backtrack >> setBuffer buffer >> handler e
+ Left e -> backtrack >> setBuffer buffer >> handler e
Right a -> withBuffer (prependBuffer buffer) >> return a
-- | Parsers can be combined with ('<|>'), 'some', 'many', 'optional', 'choice'.
@@ -76,10 +77,9 @@ instance (Monad m) => Parsing (ConduitParser i m) where
try parser = parser
parser <?> name = do
- oldName <- getParserName
- setParserName $ pack name
+ pushParserName $ pack name
a <- parser
- setParserName oldName
+ popParserName
return a
unexpected = throwError . Unexpected . pack
@@ -103,12 +103,19 @@ named name = flip (<?>) (unpack name)
runConduitParser :: (MonadThrow m) => ConduitParser i m a -> Sink i m a
runConduitParser (ConduitParser p) = either throwM return . fst =<< runStateT (runExceptT p) (mempty, mempty)
--- | Return the name of the parser (assigned through ('<?>')), or 'mempty' if has none.
+-- | Return the ordered list of names (assigned through ('<?>')) for the current parser stack. First element is the most nested parser.
+getParserNames :: ConduitParser i m [Text]
+getParserNames = ConduitParser $ lift $ gets fst
+
+-- | Return the name (assigned through ('<?>')) of the current parser (most nested), or 'mempty' if it has none.
getParserName :: ConduitParser i m Text
-getParserName = ConduitParser $ lift $ gets fst
+getParserName = ConduitParser $ lift $ gets (headDef "" . fst)
+
+pushParserName :: Text -> ConduitParser i m ()
+pushParserName name = ConduitParser $ lift $ modify $ first (name :)
-setParserName :: Text -> ConduitParser i m ()
-setParserName name = ConduitParser $ lift $ modify $ \(_, b) -> (name, b)
+popParserName :: ConduitParser i m ()
+popParserName = ConduitParser $ lift $ modify $ first tailSafe
getBuffer :: ConduitParser i m (Buffer i)
getBuffer = ConduitParser $ lift $ gets snd
@@ -131,17 +138,17 @@ 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 _ (Buffer Nothing) = Buffer mempty
fmap f (Buffer (Just a)) = Buffer $ Just $ fmap f a
instance Foldable Buffer where
- foldMap _ (Buffer Nothing) = mempty
+ foldMap _ (Buffer Nothing) = mempty
foldMap f (Buffer (Just a)) = foldMap f a
setEnabled :: Bool -> Buffer i -> Buffer i
setEnabled True (Buffer a) = Buffer (a <|> Just mempty)
-setEnabled _ (Buffer _) = Buffer mempty
+setEnabled _ (Buffer _) = Buffer mempty
prependItem :: i -> Buffer i -> Buffer i
prependItem new (Buffer a) = Buffer $ fmap (cons new) a
@@ -150,7 +157,7 @@ prependItem new (Buffer a) = Buffer $ fmap (cons new) a
prependBuffer :: Buffer i -> Buffer i -> Buffer i
prependBuffer (Buffer a) (Buffer b) = case a of
Just a' -> Buffer $ Just (fromMaybe mempty b `append` a')
- _ -> Buffer a
+ _ -> Buffer a
resetBuffer :: Buffer i -> Buffer i
resetBuffer (Buffer a) = Buffer $ fmap (const mempty) a
diff --git a/conduit-parse.cabal b/conduit-parse.cabal
index cd7448a..55080e7 100644
--- a/conduit-parse.cabal
+++ b/conduit-parse.cabal
@@ -1,5 +1,5 @@
name: conduit-parse
-version: 0.1.1.1
+version: 0.1.2.0
synopsis: Parsing framework based on conduit.
description: Please refer to README.
homepage: https://github.com/k0ral/conduit-parse
@@ -25,9 +25,10 @@ library
base >= 4.8 && < 5
, conduit
, dlist
- , exceptions
+ , safe-exceptions
, mtl
, parsers
+ , safe
, text
, transformers
default-language: Haskell2010
@@ -41,7 +42,7 @@ test-suite tests
base >= 4.8 && < 5
, conduit
, conduit-parse
- , exceptions
+ , safe-exceptions
, hlint
, mtl
, parsers
diff --git a/test/Main.hs b/test/Main.hs
index 5c44da8..4877934 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative
-import Control.Monad.Catch as Exception
+import Control.Exception.Safe as Exception
import Control.Monad.Error.Class
import Control.Monad.Trans.Resource
@@ -65,10 +65,12 @@ leftoverCase = testCase "leftover" $ do
errorCase :: TestTree
errorCase = testCase "error" $ do
- result1 <- Exception.try . runResourceT . runConduit $ sourceList [] =$= runConduitParser (parser <?> "Unexpected error")
- result2 <- Exception.try . runResourceT . runConduit $ sourceList [] =$= runConduitParser parser
- result1 @=? Left (NamedParserException "Unexpected error" $ Unexpected "ERROR")
- result2 @=? Left (Unexpected "ERROR")
+ 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")
where parser = unexpected "ERROR" >> return (1 :: Int)