1{-# LANGUAGE CPP #-}
2-----------------------------------------------------------------------------
3-- |
4-- Module      : Data.Binary.Put
5-- Copyright   : Lennart Kolmodin
6-- License     : BSD3-style (see LICENSE)
7--
8-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
9-- Stability   : stable
10-- Portability : Portable to Hugs and GHC. Requires MPTCs
11--
12-- The Put monad. A monad for efficiently constructing lazy bytestrings using
13-- the Builder developed for blaze-html.
14--
15-----------------------------------------------------------------------------
16
17module Throughput.BlazePutMonad (
18
19    -- * The Put type
20      Put
21    , PutM(..)
22    , runPut
23    , runPutM
24    , putBuilder
25    , execPut
26
27    -- * Flushing the implicit parse state
28    , flush
29
30    -- * Primitives
31    , putWrite
32    , putWord8
33    , putByteString
34    , putLazyByteString
35
36    -- * Big-endian primitives
37    , putWord16be
38    , putWord32be
39    , putWord64be
40
41    -- * Little-endian primitives
42    , putWord16le
43    , putWord32le
44    , putWord64le
45
46    -- * Host-endian, unaligned writes
47    , putWordhost           -- :: Word   -> Put
48    , putWord16host         -- :: Word16 -> Put
49    , putWord32host         -- :: Word32 -> Put
50    , putWord64host         -- :: Word64 -> Put
51
52  ) where
53
54import Data.Monoid
55import Blaze.ByteString.Builder (Builder, toLazyByteString)
56import qualified Blaze.ByteString.Builder as B
57
58import Data.Word
59import qualified Data.ByteString      as S
60import qualified Data.ByteString.Lazy as L
61
62import Control.Applicative
63
64
65------------------------------------------------------------------------
66
67-- XXX Strict in buffer only.
68data PairS a = PairS a {-# UNPACK #-}!Builder
69
70sndS :: PairS a -> Builder
71sndS (PairS _ b) = b
72
73-- | The PutM type. A Writer monad over the efficient Builder monoid.
74newtype PutM a = Put { unPut :: PairS a }
75
76-- | Put merely lifts Builder into a Writer monad, applied to ().
77type Put = PutM ()
78
79instance Functor PutM where
80        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
81        {-# INLINE fmap #-}
82
83instance Applicative PutM where
84        pure    = return
85        m <*> k = Put $
86            let PairS f w  = unPut m
87                PairS x w' = unPut k
88            in PairS (f x) (w `mappend` w')
89
90-- Standard Writer monad, with aggressive inlining
91instance Monad PutM where
92    return a = Put $ PairS a mempty
93    {-# INLINE return #-}
94
95    m >>= k  = Put $
96        let PairS a w  = unPut m
97            PairS b w' = unPut (k a)
98        in PairS b (w `mappend` w')
99    {-# INLINE (>>=) #-}
100
101    m >> k  = Put $
102        let PairS _ w  = unPut m
103            PairS b w' = unPut k
104        in PairS b (w `mappend` w')
105    {-# INLINE (>>) #-}
106
107tell :: Builder -> Put
108tell b = Put $ PairS () b
109{-# INLINE tell #-}
110
111putBuilder :: Builder -> Put
112putBuilder = tell
113{-# INLINE putBuilder #-}
114
115-- | Run the 'Put' monad
116execPut :: PutM a -> Builder
117execPut = sndS . unPut
118{-# INLINE execPut #-}
119
120-- | Run the 'Put' monad with a serialiser
121runPut :: Put -> L.ByteString
122runPut = toLazyByteString . sndS . unPut
123{-# INLINE runPut #-}
124
125-- | Run the 'Put' monad with a serialiser and get its result
126runPutM :: PutM a -> (a, L.ByteString)
127runPutM (Put (PairS f s)) = (f, toLazyByteString s)
128{-# INLINE runPutM #-}
129
130------------------------------------------------------------------------
131
132-- | Pop the ByteString we have constructed so far, if any, yielding a
133-- new chunk in the result ByteString.
134flush               :: Put
135flush               = tell B.flush
136{-# INLINE flush #-}
137
138-- | Efficiently write a byte into the output buffer
139putWord8            :: Word8 -> Put
140putWord8            = tell . B.fromWord8
141{-# INLINE putWord8 #-}
142
143-- | Execute a write on the output buffer.
144putWrite            :: B.Write -> Put
145putWrite            = tell . B.fromWrite
146
147-- | An efficient primitive to write a strict ByteString into the output buffer.
148-- It flushes the current buffer, and writes the argument into a new chunk.
149putByteString       :: S.ByteString -> Put
150putByteString       = tell . B.fromByteString
151{-# INLINE putByteString #-}
152
153-- | Write a lazy ByteString efficiently, simply appending the lazy
154-- ByteString chunks to the output buffer
155putLazyByteString   :: L.ByteString -> Put
156putLazyByteString   = tell . B.fromLazyByteString
157{-# INLINE putLazyByteString #-}
158
159-- | Write a Word16 in big endian format
160putWord16be         :: Word16 -> Put
161putWord16be         = tell . B.fromWord16be
162{-# INLINE putWord16be #-}
163
164-- | Write a Word16 in little endian format
165putWord16le         :: Word16 -> Put
166putWord16le         = tell . B.fromWord16le
167{-# INLINE putWord16le #-}
168
169-- | Write a Word32 in big endian format
170putWord32be         :: Word32 -> Put
171putWord32be         = tell . B.fromWord32be
172{-# INLINE putWord32be #-}
173
174-- | Write a Word32 in little endian format
175putWord32le         :: Word32 -> Put
176putWord32le         = tell . B.fromWord32le
177{-# INLINE putWord32le #-}
178
179-- | Write a Word64 in big endian format
180putWord64be         :: Word64 -> Put
181putWord64be         = tell . B.fromWord64be
182{-# INLINE putWord64be #-}
183
184-- | Write a Word64 in little endian format
185putWord64le         :: Word64 -> Put
186putWord64le         = tell . B.fromWord64le
187{-# INLINE putWord64le #-}
188
189------------------------------------------------------------------------
190
191-- | /O(1)./ Write a single native machine word. The word is
192-- written in host order, host endian form, for the machine you're on.
193-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine,
194-- 4 bytes. Values written this way are not portable to
195-- different endian or word sized machines, without conversion.
196--
197putWordhost         :: Word -> Put
198putWordhost         = tell . B.fromWordhost
199{-# INLINE putWordhost #-}
200
201-- | /O(1)./ Write a Word16 in native host order and host endianness.
202-- For portability issues see @putWordhost@.
203putWord16host       :: Word16 -> Put
204putWord16host       = tell . B.fromWord16host
205{-# INLINE putWord16host #-}
206
207-- | /O(1)./ Write a Word32 in native host order and host endianness.
208-- For portability issues see @putWordhost@.
209putWord32host       :: Word32 -> Put
210putWord32host       = tell . B.fromWord32host
211{-# INLINE putWord32host #-}
212
213-- | /O(1)./ Write a Word64 in native host order
214-- On a 32 bit machine we write two host order Word32s, in big endian form.
215-- For portability issues see @putWordhost@.
216putWord64host       :: Word64 -> Put
217putWord64host       = tell . B.fromWord64host
218{-# INLINE putWord64host #-}
219