1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
|
{-# LANGUAGE FlexibleInstances,FlexibleContexts,MultiParamTypeClasses,CPP #-}
module Data.Encoding.ByteSink where
import Data.Encoding.Exception
import Data.Binary.Put
import Data.Bits
import Data.Char
import Data.Sequence
import Data.Word
import Data.Foldable (toList)
import Control.Throws
import Control.Exception.Extensible
import Control.Applicative
import Control.Monad (ap, liftM)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, modify)
import Control.Monad.Reader (ReaderT, ask)
import Foreign.Ptr (Ptr,plusPtr,minusPtr)
import Foreign.Marshal.Alloc (mallocBytes,reallocBytes,free)
import Foreign.Storable (poke)
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe (unsafePackCStringFinalizer)
class (Monad m,Throws EncodingException m) => ByteSink m where
pushWord8 :: Word8 -> m ()
pushWord16be :: Word16 -> m ()
pushWord16be w = do
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord8 (fromIntegral $ w)
pushWord16le :: Word16 -> m ()
pushWord16le w = do
pushWord8 (fromIntegral $ w)
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord32be :: Word32 -> m ()
pushWord32be w = do
pushWord8 (fromIntegral $ w `shiftR` 24)
pushWord8 (fromIntegral $ w `shiftR` 16)
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord8 (fromIntegral $ w)
pushWord32le :: Word32 -> m ()
pushWord32le w = do
pushWord8 (fromIntegral $ w)
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord8 (fromIntegral $ w `shiftR` 16)
pushWord8 (fromIntegral $ w `shiftR` 24)
pushWord64be :: Word64 -> m ()
pushWord64be w = do
pushWord8 (fromIntegral $ w `shiftR` 56)
pushWord8 (fromIntegral $ w `shiftR` 48)
pushWord8 (fromIntegral $ w `shiftR` 40)
pushWord8 (fromIntegral $ w `shiftR` 32)
pushWord8 (fromIntegral $ w `shiftR` 24)
pushWord8 (fromIntegral $ w `shiftR` 16)
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord8 (fromIntegral $ w)
pushWord64le :: Word64 -> m ()
pushWord64le w = do
pushWord8 (fromIntegral $ w)
pushWord8 (fromIntegral $ w `shiftR` 8)
pushWord8 (fromIntegral $ w `shiftR` 16)
pushWord8 (fromIntegral $ w `shiftR` 24)
pushWord8 (fromIntegral $ w `shiftR` 32)
pushWord8 (fromIntegral $ w `shiftR` 40)
pushWord8 (fromIntegral $ w `shiftR` 48)
pushWord8 (fromIntegral $ w `shiftR` 56)
instance Throws EncodingException PutM where
throwException = throw
instance ByteSink PutM where
pushWord8 = putWord8
pushWord16be = putWord16be
pushWord16le = putWord16le
pushWord32be = putWord32be
pushWord32le = putWord32le
pushWord64be = putWord64be
pushWord64le = putWord64le
newtype PutME a = PutME (Either EncodingException (PutM (),a))
instance Functor PutME where
fmap = liftM
instance Applicative PutME where
pure x = PutME $ Right (pure (),x)
(<*>) = ap
instance Monad PutME where
return = pure
(PutME x) >>= g = PutME $ do
(m,r) <- x
let (PutME ng) = g r
case ng of
Left err -> Left err
Right (m',nr) -> Right (m>>m',nr)
instance Throws EncodingException PutME where
throwException = PutME . Left
instance ByteSink PutME where
pushWord8 w = PutME $ Right (putWord8 w,())
pushWord16be w = PutME $ Right (putWord16be w,())
pushWord16le w = PutME $ Right (putWord16le w,())
pushWord32be w = PutME $ Right (putWord32be w,())
pushWord32le w = PutME $ Right (putWord32le w,())
pushWord64be w = PutME $ Right (putWord64be w,())
pushWord64le w = PutME $ Right (putWord64le w,())
#if MIN_VERSION_base(4,3,0)
#else
instance Monad (Either EncodingException) where
return x = Right x
Left err >>= g = Left err
Right x >>= g = g x
#endif
instance (Monad m,Throws EncodingException m) => ByteSink (StateT (Seq Char) m) where
pushWord8 x = modify (|> (chr $ fromIntegral x))
newtype StrictSink a = StrictS (Ptr Word8 -> Int -> Int -> IO (a,Ptr Word8,Int,Int))
instance Functor StrictSink where
fmap = liftM
instance Applicative StrictSink where
pure x = StrictS $ \cstr pos max -> return (x,cstr,pos,max)
(<*>) = ap
instance Monad StrictSink where
return = pure
(StrictS f) >>= g = StrictS (\cstr pos max -> do
(res,ncstr,npos,nmax) <- f cstr pos max
let StrictS g' = g res
g' ncstr npos nmax
)
instance Throws EncodingException StrictSink where
throwException = throw
instance ByteSink StrictSink where
pushWord8 x = StrictS (\cstr pos max -> do
(ncstr,nmax) <- if pos < max
then return (cstr,max)
else (do
let nmax = max + 32
nptr <- reallocBytes cstr nmax
return (nptr,nmax)
)
poke (ncstr `plusPtr` pos) x
return ((),ncstr,pos+1,nmax)
)
newtype StrictSinkE a = StrictSinkE (StrictSink (Either EncodingException a))
instance Functor StrictSinkE where
fmap = liftM
instance Applicative StrictSinkE where
pure = StrictSinkE . return . Right
(<*>) = ap
instance Monad StrictSinkE where
return = pure
(StrictSinkE s) >>= g = StrictSinkE $ do
res <- s
case res of
Left err -> return $ Left err
Right res' -> let StrictSinkE g' = g res'
in g'
instance Throws EncodingException StrictSinkE where
throwException = StrictSinkE . return . Left
instance ByteSink StrictSinkE where
pushWord8 x = StrictSinkE $ pushWord8 x >>= return . Right
createStrictWithLen :: StrictSink a -> Int -> (a,BS.ByteString)
createStrictWithLen (StrictS f) max = unsafePerformIO $ do
ptr <- mallocBytes max
(r,nptr,len,_) <- f ptr 0 max
str <- unsafePackCStringFinalizer nptr len (free nptr)
return (r,str)
createStrict :: StrictSink a -> (a,BS.ByteString)
createStrict sink = createStrictWithLen sink 32
newtype StrictSinkExplicit a = StrictSinkExplicit (StrictSink (Either EncodingException a))
instance Functor StrictSinkExplicit where
fmap = liftM
instance Applicative StrictSinkExplicit where
pure = (StrictSinkExplicit).return.Right
(<*>) = ap
instance Monad StrictSinkExplicit where
return = pure
(StrictSinkExplicit sink) >>= f
= StrictSinkExplicit (do
res <- sink
case res of
Left err -> return $ Left err
Right x -> let StrictSinkExplicit sink2 = f x
in sink2)
instance Throws EncodingException StrictSinkExplicit where
throwException = StrictSinkExplicit . return . Left
instance ByteSink StrictSinkExplicit where
pushWord8 x = StrictSinkExplicit $ do
pushWord8 x
return $ Right ()
instance ByteSink (ReaderT Handle IO) where
pushWord8 x = do
h <- ask
liftIO $ do
hPutChar h (chr $ fromIntegral x)
|
