module Blaze.ByteString.Builder.Internal.Types where
#ifdef APPLICATIVE_IN_BASE
import Control.Applicative
#endif
import Data.Monoid
import qualified Data.ByteString as S
import Foreign
data BufRange = BufRange !(Ptr Word8) !(Ptr Word8)
data BuildSignal a =
Done !(Ptr Word8) a
| BufferFull
!Int
!(Ptr Word8)
!(BuildStep a)
| InsertByteString
!(Ptr Word8)
!S.ByteString
!(BuildStep a)
newtype BuildStep a =
BuildStep { runBuildStep :: BufRange -> IO (BuildSignal a) }
done :: Ptr Word8 -> a -> BuildSignal a
done = Done
bufferFull :: Int -> Ptr Word8 -> (BufRange -> IO (BuildSignal a)) -> BuildSignal a
bufferFull size op step = BufferFull size op (buildStep step)
insertByteString :: Ptr Word8 -> S.ByteString -> (BufRange -> IO (BuildSignal a)) -> BuildSignal a
insertByteString op bs step = InsertByteString op bs (buildStep step)
buildStep :: (BufRange -> IO (BuildSignal a)) -> BuildStep a
buildStep = BuildStep
newtype Builder = Builder {
unBuilder :: forall r. BuildStep r -> BuildStep r
}
instance Monoid Builder where
mempty = Builder id
(Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2
mconcat = foldr mappend mempty
newtype Put a = Put {
unPut :: forall r. (a -> BuildStep r) -> BuildStep r
}
instance Functor Put where
fmap f (Put put) = Put $ \k -> put (\x -> k (f x))
#ifdef APPLICATIVE_IN_BASE
instance Applicative Put where
pure x = Put $ \k -> k x
f <*> a = Put $ \k -> unPut f (\f' -> unPut a (\a' -> k (f' a')))
a <* b = Put $ \k -> unPut a (\a' -> unPut b (\_ -> k a'))
a *> b = Put $ \k -> unPut a (\_ -> unPut b k)
#endif
instance Monad Put where
return x = Put $ \k -> k x
m >>= f = Put $ \k -> unPut m (\m' -> unPut (f m') k)
m >> n = Put $ \k -> unPut m (\_ -> unPut n k)
putBuildStepCont :: (forall r. (a -> BufRange -> IO (BuildSignal r)) ->
( BufRange -> IO (BuildSignal r))
) -> Put a
putBuildStepCont step = Put step'
where
step' k = BuildStep $ step (\x -> runBuildStep (k x))
fromBuildStepCont :: (forall r. (BufRange -> IO (BuildSignal r)) ->
(BufRange -> IO (BuildSignal r))
) -> Builder
fromBuildStepCont step = Builder step'
where
step' k = BuildStep $ step (runBuildStep k)
putBuilder :: Builder -> Put ()
putBuilder (Builder build) = Put $ \k -> build (k ())
fromPut :: Put a -> Builder
fromPut (Put put) = Builder $ \k -> put (\_ -> k)
putLiftIO :: IO a -> Put a
putLiftIO io = putBuildStepCont $ \k br -> io >>= (`k` br)