{-# LANGUAGE CPP, BangPatterns, Rank2Types #-} #ifdef USE_MONO_PAT_BINDS {-# LANGUAGE MonoPatBinds #-} #endif -- | -- Module : Blaze.ByteString.Builder.Internal.Types -- Copyright : (c) 2010 Simon Meier -- License : BSD3-style (see LICENSE) -- -- Maintainer : Simon Meier <iridcode@gmail.com> -- Stability : experimental -- Portability : tested on GHC only -- -- Core types and functions for the 'Builder' monoid and the 'Put' monad based -- based on the 'blaze-builder' library by Jasper van der Jeugt and Simon -- Meier. -- 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 ------------------------------------------------------------------------------ -- The core: BuildSteps ------------------------------------------------------------------------------ data BufRange = BufRange {-# UNPACK #-} !(Ptr Word8) {-# UNPACK #-} !(Ptr Word8) data BuildSignal a = Done {-# UNPACK #-} !(Ptr Word8) a | BufferFull {-# UNPACK #-} !Int {-# UNPACK #-} !(Ptr Word8) !(BuildStep a) | InsertByteString {-# UNPACK #-} !(Ptr Word8) !S.ByteString !(BuildStep a) newtype BuildStep a = BuildStep { runBuildStep :: BufRange -> IO (BuildSignal a) } -- Hiding the implementation of 'BuildStep's 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 ------------------------------------------------------------------------------ -- The 'Builder' Monoid and the 'Put' Monad ------------------------------------------------------------------------------ newtype Builder = Builder { unBuilder :: forall r. BuildStep r -> BuildStep r } instance Monoid Builder where mempty = Builder id {-# INLINE mempty #-} (Builder b1) `mappend` (Builder b2) = Builder $ b1 . b2 {-# INLINE mappend #-} mconcat = foldr mappend mempty {-# INLINE mconcat #-} 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)) {-# INLINE fmap #-} #ifdef APPLICATIVE_IN_BASE instance Applicative Put where pure x = Put $ \k -> k x {-# INLINE pure #-} f <*> a = Put $ \k -> unPut f (\f' -> unPut a (\a' -> k (f' a'))) {-# INLINE (<*>) #-} a <* b = Put $ \k -> unPut a (\a' -> unPut b (\_ -> k a')) {-# INLINE (<*) #-} a *> b = Put $ \k -> unPut a (\_ -> unPut b k) {-# INLINE (*>) #-} #endif instance Monad Put where return x = Put $ \k -> k x {-# INLINE return #-} m >>= f = Put $ \k -> unPut m (\m' -> unPut (f m') k) {-# INLINE (>>=) #-} m >> n = Put $ \k -> unPut m (\_ -> unPut n k) {-# INLINE (>>) #-} -- Creation from concrete 'BuildStep's ------------------------------------------------------------------------------ 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) -- Conversion between Put and Builder ------------------------------------------------------------------------------ -- | Put the given builder. putBuilder :: Builder -> Put () putBuilder (Builder build) = Put $ \k -> build (k ()) -- | Ignore the value of a put and only exploit its output side effect. fromPut :: Put a -> Builder fromPut (Put put) = Builder $ \k -> put (\_ -> k) -- Lifting IO actions --------------------- -- | Lift the given IO action. {-# INLINE putLiftIO #-} putLiftIO :: IO a -> Put a putLiftIO io = putBuildStepCont $ \k br -> io >>= (`k` br)