diff --git a/Data/Conduit/Parser.hs b/Data/Conduit/Parser.hs --- a/Data/Conduit/Parser.hs +++ b/Data/Conduit/Parser.hs @@ -9,6 +9,7 @@ -- * Primitives , await , leftover + , getParserNames , getParserName -- * Utility , peek @@ -16,4 +17,4 @@ , 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 --- a/Data/Conduit/Parser/Internal.hs +++ b/Data/Conduit/Parser/Internal.hs @@ -8,25 +8,27 @@ -- {{{ 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 @@ -- 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 @@ 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 @@ 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,13 +103,20 @@ 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) -setParserName :: Text -> ConduitParser i m () -setParserName name = ConduitParser $ lift $ modify $ \(_, b) -> (name, b) +pushParserName :: Text -> ConduitParser i m () +pushParserName name = ConduitParser $ lift $ modify $ first (name :) +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 @@ 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 @@ 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 --- 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 @@ base >= 4.8 && < 5 , conduit , dlist - , exceptions + , safe-exceptions , mtl , parsers + , safe , text , transformers default-language: Haskell2010 @@ -41,7 +42,7 @@ base >= 4.8 && < 5 , conduit , conduit-parse - , exceptions + , safe-exceptions , hlint , mtl , parsers diff --git a/test/Main.hs b/test/Main.hs --- 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 @@ 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)