module Data.Conduit.Parsers.GetC
( DecodingState (..)
, Decoding
, startDecoding
, continueDecoding
, decodingRead
, GetC
, GetT
, runGetC
, getC
, trackP
, tryP
, maybeG
, runMaybeG
, exceptG
, runExceptG
, catchExceptG
, readerG
, runReaderG
, stateLG
, runStateLG
, evalStateLG
, execStateLG
, stateG
, runStateG
, evalStateG
, execStateG
, writerLG
, runWriterLG
, execWriterLG
, writerG
, runWriterG
, execWriterG
, rwsLG
, runRWSLG
, evalRWSLG
, execRWSLG
, rwsG
, runRWSG
, evalRWSG
, execRWSG
) where
import Control.Applicative
import Control.Monad hiding (fail)
import Control.Monad.Base
import Control.Monad.Error.Class
import Control.Monad.Error.Map
import Control.Monad.Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Control.Monad.Trans.RWS.Strict
import qualified Control.Monad.Trans.RWS.Lazy as L
import Control.Monad.Trans.State.Strict
import qualified Control.Monad.Trans.State.Lazy as L
import Control.Monad.Trans.Writer.Strict
import qualified Control.Monad.Trans.Writer.Lazy as L
import Data.Conduit hiding (ConduitM)
import Data.Conduit.Lift
import Data.Maybe hiding (fromJust)
class DecodingState s where
type DecodingToken s :: *
decoded :: DecodingToken s -> s -> s
data Decoding s i = Decoding
{ decodingRead :: !s
, tracking :: !(Maybe [i])
}
startDecoding :: s -> Decoding s i
startDecoding !bytes_read_before = Decoding { decodingRead = bytes_read_before, tracking = Nothing }
{-# INLINE startDecoding #-}
continueDecoding :: s -> [i] -> Decoding s i -> Decoding s i
continueDecoding new delta old = Decoding { decodingRead = new, tracking = (delta ++) <$> tracking old }
{-# INLINE continueDecoding #-}
instance (DecodingState s, DecodingToken s ~ i) => DecodingState (Decoding s i) where
type DecodingToken (Decoding s i) = DecodingToken s
decoded !inp !s = Decoding
{ decodingRead = decoded inp (decodingRead s)
, tracking = (inp :) <$> tracking s
}
{-# INLINE decoded #-}
newtype GetC s i e m a = C { runC :: ExceptT e (StateT (Decoding s i) m) a }
instance MonadTrans (GetC s i e) where
lift = C . lift . lift
{-# INLINE lift #-}
deriving instance Monad m => Monad (GetC s i e m)
deriving instance Functor m => Functor (GetC s i e m)
deriving instance MonadFix m => MonadFix (GetC s i e m)
deriving instance MonadFail m => MonadFail (GetC s i e m)
deriving instance (Functor m, Monad m) => Applicative (GetC s i e m)
deriving instance MonadIO m => MonadIO (GetC s i e m)
deriving instance (Functor m, Monad m, Monoid e) => Alternative (GetC s i e m)
deriving instance (Monad m, Monoid e) => MonadPlus (GetC s i e m)
deriving instance Monad m => MonadError e (GetC s i e m)
instance MonadTransControl (GetC s i e) where
type StT (GetC s i e) a = StT (StateT (Decoding s i)) (StT (ExceptT e) a)
liftWith = defaultLiftWith2 C runC
{-# INLINE liftWith #-}
restoreT = defaultRestoreT2 C
{-# INLINE restoreT #-}
instance MonadBase b m => MonadBase b (GetC s i e m) where
liftBase = liftBaseDefault
{-# INLINE liftBase #-}
instance MonadBaseControl b m => MonadBaseControl b (GetC s i e m) where
type StM (GetC s i e m) a = ComposeSt (GetC s i e) m a
liftBaseWith = defaultLiftBaseWith
{-# INLINE liftBaseWith #-}
restoreM = defaultRestoreM
{-# INLINE restoreM #-}
instance Monad m => MonadMapError e (GetC s i e m) e' (GetC s i e' m) where
mapError f = C . mapError f . runC
type GetT s i o e m = ConduitT i o (GetC s i e m)
instance (Monoid e, Monad m) => Alternative (GetT s i o e m) where
empty = throwError mempty
{-# INLINE empty #-}
a <|> b = catchError (tryP a) $ \ !ea -> catchError (tryP b) $ \ !eb -> throwError (ea `mappend` eb)
{-# INLINE (<|>) #-}
instance (Monoid e, Monad m) => MonadPlus (GetT s i o e m) where
mzero = empty
{-# INLINE mzero #-}
mplus a b = a <|> b
{-# INLINE mplus #-}
tryP :: Monad m => GetT s i o e m a -> GetT s i o e m a
tryP !g = getC $ \ !c -> do
(!t, !d) <- runGetC (startDecoding $ decodingRead c) $ trackP g
case t of
Right (!f, !r) -> return (Right r, continueDecoding (decodingRead d) f c)
Left (!f, !e) -> forM_ f leftover >> return (Left e, c)
{-# INLINE tryP #-}
trackP :: Monad m => GetT s i o e m a -> GetT s i o ([i], e) m ([i], a)
trackP !g = getC $ \ !c -> do
(!r, !f) <- runGetC (Decoding { decodingRead = decodingRead c, tracking = Just [] }) g
let !tracking_f = fromMaybe (error "Data.Conduit.Parsers.GetC.track") $ tracking f
return (either (Left . (tracking_f,)) (Right . (tracking_f,)) r, Decoding { decodingRead = decodingRead f, tracking = (tracking_f ++) <$> tracking c })
{-# INLINE trackP #-}
runGetC :: Monad m => Decoding s i -> GetT s i o e m a -> ConduitT i o m (Either e a, Decoding s i)
runGetC !decoding = runStateC decoding . runExceptC . transPipe runC
{-# INLINE runGetC #-}
getC :: Monad m => (Decoding s i -> ConduitT i o m (Either e a, Decoding s i)) -> GetT s i o e m a
getC = transPipe C . exceptC . stateC
{-# INLINE getC #-}
exceptG :: Monad m => GetT s i o e' m (Either e a) -> GetT s i o e' (ExceptT (e, Decoding s i) m) a
exceptG g =
getC $ \ !x -> exceptC $ ee <$> runGetC x g
where
ee :: (Either e' (Either e a), Decoding s i) -> Either (e, Decoding s i) (Either e' a, Decoding s i)
ee (Right (Right a), b) = Right (Right a, b)
ee (Right (Left x), b) = Left (x, b)
ee (Left x, b) = Right (Left x, b)
{-# INLINE exceptG #-}
runExceptG :: Monad m => GetT s i o e' (ExceptT (e, Decoding s i) m) a -> GetT s i o e' m (Either e a)
runExceptG g =
getC $ \ !x -> (ee <$>) $ runExceptC $ runGetC x g
where
ee :: Either (e, Decoding s i) (Either e' a, Decoding s i) -> (Either e' (Either e a), Decoding s i)
ee (Right (Right a, b)) = (Right (Right a), b)
ee (Right (Left x, b)) = (Left x, b)
ee (Left (x, b)) = (Right (Left x), b)
{-# INLINE runExceptG #-}
catchExceptG :: Monad m => GetT s i o e' (ExceptT (e, Decoding s i) m) r -> (e -> GetT s i o e' (ExceptT (e, Decoding s i) m) r) -> GetT s i o e' (ExceptT (e, Decoding s i) m) r
catchExceptG g c =
getC $ \ !x -> catchExceptC (runGetC x g) (\(e, b) -> runGetC b (c e))
{-# INLINE catchExceptG #-}
maybeG :: Monad m => GetT s i o e m (Maybe a) -> GetT s i o e (ExceptT (Decoding s i) m) a
maybeG g =
getC $ \ !x -> exceptC $ em <$> runGetC x g
where
em :: (Either e (Maybe a), Decoding s i) -> Either (Decoding s i) (Either e a, Decoding s i)
em (Right (Just a), b) = Right (Right a, b)
em (Right Nothing, b) = Left b
em (Left e, b) = Right (Left e, b)
{-# INLINE maybeG #-}
runMaybeG :: Monad m => GetT s i o e (ExceptT (Decoding s i) m) a -> GetT s i o e m (Maybe a)
runMaybeG g =
getC $ \ !x -> (me <$>) $ runExceptC $ runGetC x g
where
me :: Either (Decoding s i) (Either e a, Decoding s i) -> (Either e (Maybe a), Decoding s i)
me (Right (Right a, b)) = (Right (Just a), b)
me (Right (Left e, b)) = (Left e, b)
me (Left b) = (Right Nothing, b)
{-# INLINE runMaybeG #-}
readerG :: Monad m => (r -> GetT s i o e m a) -> GetT s i o e (ReaderT r m) a
readerG g = getC $ \ !x -> readerC $ \r -> runGetC x (g r)
{-# INLINE readerG #-}
runReaderG :: Monad m => r -> GetT s i o e (ReaderT r m) a -> GetT s i o e m a
runReaderG r g = getC $ \ !x -> runReaderC r $ runGetC x g
{-# INLINE runReaderG #-}
stateLG :: Monad m => (t -> GetT s i o e m (a, t)) -> GetT s i o e (L.StateT t m) a
stateLG g =
getC $ \ !x -> stateLC $ \t -> st <$> runGetC x (g t)
where
st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t)
st (Right (a, t), b) = ((Right a, b), t)
st (Left e, b) = ((Left e, b), error "stateLG")
{-# INLINE stateLG #-}
runStateLG :: Monad m => t -> GetT s i o e (L.StateT t m) a -> GetT s i o e m (a, t)
runStateLG t g =
getC $ \ !x -> (ts <$>) $ runStateLC t $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i)
ts ((Right a, b), r) = (Right (a, r), b)
ts ((Left e, b), _) = (Left e, b)
{-# INLINE runStateLG #-}
evalStateLG :: Monad m => t -> GetT s i o e (L.StateT t m) a -> GetT s i o e m a
evalStateLG t = (fst <$>) . runStateLG t
{-# INLINE evalStateLG #-}
execStateLG :: Monad m => t -> GetT s i o e (L.StateT t m) a -> GetT s i o e m t
execStateLG t = (snd <$>) . runStateLG t
{-# INLINE execStateLG #-}
stateG :: Monad m => (t -> GetT s i o e m (a, t)) -> GetT s i o e (StateT t m) a
stateG g =
getC $ \ !x -> stateC $ \t -> st <$> runGetC x (g t)
where
st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t)
st (Right (a, t), b) = ((Right a, b), t)
st (Left e, b) = ((Left e, b), error "stateLG")
{-# INLINE stateG #-}
runStateG :: Monad m => t -> GetT s i o e (StateT t m) a -> GetT s i o e m (a, t)
runStateG t g =
getC $ \ !x -> (ts <$>) $ runStateC t $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i)
ts ((Right a, b), r) = (Right (a, r), b)
ts ((Left e, b), _) = (Left e, b)
{-# INLINE runStateG #-}
evalStateG :: Monad m => t -> GetT s i o e (StateT t m) a -> GetT s i o e m a
evalStateG t = (fst <$>) . runStateG t
{-# INLINE evalStateG #-}
execStateG :: Monad m => t -> GetT s i o e (StateT t m) a -> GetT s i o e m t
execStateG t = (snd <$>) . runStateG t
{-# INLINE execStateG #-}
writerLG :: (Monad m, Monoid t) => GetT s i o e m (a, t) -> GetT s i o e (L.WriterT t m) a
writerLG g =
getC $ \ !x -> writerLC $ st <$> runGetC x g
where
st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t)
st (Right (a, t), b) = ((Right a, b), t)
st (Left e, b) = ((Left e, b), error "writerLG")
{-# INLINE writerLG #-}
runWriterLG :: (Monad m, Monoid t) => GetT s i o e (L.WriterT t m) a -> GetT s i o e m (a, t)
runWriterLG g =
getC $ \ !x -> (ts <$>) $ runWriterLC $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i)
ts ((Right a, b), r) = (Right (a, r), b)
ts ((Left e, b), _) = (Left e, b)
{-# INLINE runWriterLG #-}
execWriterLG :: (Monad m, Monoid t) => GetT s i o e (L.WriterT t m) a -> GetT s i o e m t
execWriterLG = (snd <$>) . runWriterLG
{-# INLINE execWriterLG #-}
writerG :: (Monad m, Monoid t) => GetT s i o e m (a, t) -> GetT s i o e (WriterT t m) a
writerG g =
getC $ \ !x -> writerC $ st <$> runGetC x g
where
st :: (Either e (a, t), Decoding s i) -> ((Either e a, Decoding s i), t)
st (Right (a, t), b) = ((Right a, b), t)
st (Left e, b) = ((Left e, b), error "writerG")
{-# INLINE writerG #-}
runWriterG :: (Monad m, Monoid t) => GetT s i o e (WriterT t m) a -> GetT s i o e m (a, t)
runWriterG g =
getC $ \ !x -> (ts <$>) $ runWriterC $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t) -> (Either e (a, t), Decoding s i)
ts ((Right a, b), r) = (Right (a, r), b)
ts ((Left e, b), _) = (Left e, b)
{-# INLINE runWriterG #-}
execWriterG :: (Monad m, Monoid t) => GetT s i o e (WriterT t m) a -> GetT s i o e m t
execWriterG = (snd <$>) . runWriterG
{-# INLINE execWriterG #-}
rwsLG :: (Monad m, Monoid w) => (r -> t -> GetT s i o e m (a, t, w)) -> GetT s i o e (L.RWST r w t m) a
rwsLG g =
getC $ \ !x -> rwsLC $ \r t -> st <$> runGetC x (g r t)
where
st :: (Either e (a, t, w), Decoding s i) -> ((Either e a, Decoding s i), t, w)
st (Right (a, t, w), b) = ((Right a, b), t, w)
st (Left e, b) = ((Left e, b), error "rwsLG.s", error "rwsLG.w")
{-# INLINE rwsLG #-}
runRWSLG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (L.RWST r w t m) a -> GetT s i o e m (a, t, w)
runRWSLG r t g =
getC $ \ !x -> (ts <$>) $ runRWSLC r t $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t, w) -> (Either e (a, t, w), Decoding s i)
ts ((Right a, b), x, w) = (Right (a, x, w), b)
ts ((Left e, b), _, _) = (Left e, b)
{-# INLINE runRWSLG #-}
evalRWSLG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (L.RWST r w t m) a -> GetT s i o e m (a, w)
evalRWSLG r t =
(res <$>) . runRWSLG r t
where
res (a, _, b) = (a, b)
{-# INLINE evalRWSLG #-}
execRWSLG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (L.RWST r w t m) a -> GetT s i o e m (t, w)
execRWSLG r t =
(res <$>) . runRWSLG r t
where
res (_, a, b) = (a, b)
{-# INLINE execRWSLG #-}
rwsG :: (Monad m, Monoid w) => (r -> t -> GetT s i o e m (a, t, w)) -> GetT s i o e (RWST r w t m) a
rwsG g =
getC $ \ !x -> rwsC $ \r t -> st <$> runGetC x (g r t)
where
st :: (Either e (a, t, w), Decoding s i) -> ((Either e a, Decoding s i), t, w)
st (Right (a, t, w), b) = ((Right a, b), t, w)
st (Left e, b) = ((Left e, b), error "rwsG.s", error "rwsG.w")
{-# INLINE rwsG #-}
runRWSG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (RWST r w t m) a -> GetT s i o e m (a, t, w)
runRWSG r t g =
getC $ \ !x -> (ts <$>) $ runRWSC r t $ runGetC x g
where
ts :: ((Either e a, Decoding s i), t, w) -> (Either e (a, t, w), Decoding s i)
ts ((Right a, b), x, w) = (Right (a, x, w), b)
ts ((Left e, b), _, _) = (Left e, b)
{-# INLINE runRWSG #-}
evalRWSG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (RWST r w t m) a -> GetT s i o e m (a, w)
evalRWSG r t =
(res <$>) . runRWSG r t
where
res (a, _, b) = (a, b)
{-# INLINE evalRWSG #-}
execRWSG :: (Monad m, Monoid w) => r -> t -> GetT s i o e (RWST r w t m) a -> GetT s i o e m (t, w)
execRWSG r t =
(res <$>) . runRWSG r t
where
res (_, a, b) = (a, b)
{-# INLINE execRWSG #-}