module Data.Conduit.Parsers.PutS
( EncodingState (..)
, VoidEncodingState (..)
, Encoding
, encodingWrote
, runEncoding
, startEncoding
, PutS
, runPutS
, putS
, PutM
) where
import Control.Monad.Fix
import Control.Monad.Trans.State.Strict
import Data.Conduit
import Data.Semigroup
import Data.String
import qualified Data.Text as S (Text)
class EncodingState s where
type EncodingToken s :: *
encoded :: EncodingToken s -> s -> s
data VoidEncodingState = VoidEncodingState
instance EncodingState VoidEncodingState where
type EncodingToken VoidEncodingState = ()
encoded () = id
{-# INLINE encoded #-}
data Encoding s m = Encoding
{ encodingWrote :: !s
, runEncoding :: !(m ())
}
instance (EncodingState s, Monad m) => EncodingState (Encoding s m) where
type EncodingToken (Encoding s m) = (m (), EncodingToken s)
encoded (!producer, !bytes_count) !s = Encoding
{ encodingWrote = encoded bytes_count (encodingWrote s)
, runEncoding = runEncoding s >> producer
}
{-# INLINE encoded #-}
startEncoding :: Applicative m => s -> Encoding s m
startEncoding !bytes_wrote_before = Encoding
{ encodingWrote = bytes_wrote_before
, runEncoding = pure ()
}
{-# INLINE startEncoding #-}
newtype PutS s m a = S { runS :: State (Encoding s m) a }
deriving instance Monad (PutS s m)
deriving instance Functor (PutS s m)
deriving instance MonadFix (PutS s m)
deriving instance Applicative (PutS s m)
instance Monad m => Semigroup (PutS s m ()) where
a <> b = a >> b
{-# INLINE (<>) #-}
type PutM s i o m a = PutS s (ConduitT i o m) a
instance (EncodingState s, EncodingToken s ~ (), Monad m) => IsString (PutM s i S.Text m ()) where
fromString x = putS $ \ !t -> ((), encoded (yield (fromString x), ()) t)
{-# INLINE fromString #-}
runPutS :: PutS s m a -> Encoding s m -> (a, Encoding s m)
runPutS = runState . runS
{-# INLINE runPutS #-}
putS :: (Encoding s m -> (a, Encoding s m)) -> PutS s m a
putS = S . state
{-# INLINE putS #-}