module Data.Conduit.Parser.Internal where
import Control.Applicative
import Control.Arrow (second)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.Except
import Control.Monad.Trans.State
import Data.Conduit hiding (await, leftover)
import qualified Data.Conduit as Conduit
import qualified Data.Conduit.List as Conduit
import Data.DList
import Data.Maybe (fromMaybe)
import Data.Text as Text (Text, null, pack, unpack)
import Text.Parser.Combinators as Parser
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 Monad (ConduitParser i m)
deriving instance (MonadCatch m) => MonadCatch (ConduitParser i m)
deriving instance (MonadIO m) => MonadIO (ConduitParser i m)
deriving instance (MonadThrow m) => MonadThrow (ConduitParser i m)
instance MonadTrans (ConduitParser i) where
lift = ConduitParser . lift . lift . lift
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
catchError (ConduitParser f) handler = do
buffer <- withBuffer resetBuffer
withBuffer $ setEnabled True
result <- ConduitParser $ (Right <$> f) `catchError` (return . Left)
case result of
Left e -> backtrack >> setBuffer buffer >> handler e
Right a -> withBuffer (prependBuffer buffer) >> return a
instance Alternative (ConduitParser i m) where
empty = ConduitParser $ throwError $ Unexpected "ConduitParser.empty"
parserA <|> parserB = catchError parserA $ \ea ->
catchError parserB $ \eb ->
throwError $ BothFailed ea eb
instance (Monad m) => Parsing (ConduitParser i m) where
try parser = parser
parser <?> name = do
oldName <- getParserName
setParserName $ pack name
a <- parser
setParserName oldName
return a
unexpected = throwError . Unexpected . pack
eof = do
result <- peek
maybe (return ()) (const $ throwError ExpectedEndOfInput) result
notFollowedBy parser = do
result <- optional parser
name <- getParserName
forM_ result $ \_ -> throwError $ UnexpectedFollowedBy name
named :: (Monad m) => Text -> ConduitParser i m a -> ConduitParser i m a
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)
getParserName :: ConduitParser i m Text
getParserName = ConduitParser $ lift $ gets fst
setParserName :: Text -> ConduitParser i m ()
setParserName name = ConduitParser $ lift $ modify $ \(_, b) -> (name, b)
getBuffer :: ConduitParser i m (Buffer i)
getBuffer = ConduitParser $ lift $ gets snd
setBuffer :: Buffer i -> ConduitParser i m (Buffer i)
setBuffer buffer = withBuffer (const buffer)
withBuffer :: (Buffer i -> Buffer i) -> ConduitParser i m (Buffer i)
withBuffer f = do
buffer <- ConduitParser $ lift $ gets snd
ConduitParser $ lift $ modify (second f)
return buffer
backtrack :: ConduitParser i m ()
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
instance Foldable Buffer where
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
prependItem :: i -> Buffer i -> Buffer i
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
resetBuffer :: Buffer i -> Buffer i
resetBuffer (Buffer a) = Buffer $ fmap (const mempty) a
await :: (Monad m) => ConduitParser i m i
await = do
event <- ConduitParser $ lift $ lift Conduit.await
e <- maybe (throwError UnexpectedEndOfInput) return event
withBuffer $ prependItem e
return e
leftover :: i -> ConduitParser i m ()
leftover = ConduitParser . lift . lift . Conduit.leftover
peek :: (Monad m) => ConduitParser i m (Maybe i)
peek = ConduitParser $ lift $ lift Conduit.peek
data ConduitParserException = BothFailed ConduitParserException ConduitParserException
| ExpectedEndOfInput
| NamedParserException Text ConduitParserException
| UnexpectedEndOfInput
| UnexpectedFollowedBy Text
| Unexpected Text
deriving instance Eq ConduitParserException
deriving instance Show ConduitParserException
instance Exception ConduitParserException where
displayException (BothFailed ea eb) = show ea ++ "\n" ++ show eb
displayException ExpectedEndOfInput = "Unexpected input, expected end of input."
displayException (NamedParserException t e) = "While parsing " ++ unpack t ++ ": " ++ show e
displayException UnexpectedEndOfInput = "Unexpected end of input."
displayException (UnexpectedFollowedBy t) = "Should not be followed by " ++ unpack t
displayException (Unexpected t) = unpack t