Port to Hugs !
[packages/binary.git] / src / Data / Binary / Get.hs
1 -----------------------------------------------------------------------------
2 -- |
3 -- Module : Data.Binary.Get
4 -- Copyright : Lennart Kolmodin
5 -- License : BSD3-style (see LICENSE)
6 --
7 -- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
8 -- Stability : unstable
9 -- Portability : FFI, flexible instances
10 --
11 -- The Get monad. A monad for efficiently building structures from
12 -- encoded lazy ByteStrings
13 --
14 -----------------------------------------------------------------------------
15
16 module Data.Binary.Get (
17
18 -- * The Get type
19 Get
20 , runGet
21 , skip
22
23 -- * Primitives
24 , getByteString
25 , getLazyByteString
26
27 , getWord8
28 , getWord16be
29 , getWord16le
30 , getWord32be
31 , getWord32le
32 , getWord64be
33 , getWord64le
34 ) where
35
36 import Control.Monad.State
37
38 import qualified Data.ByteString as B
39 import qualified Data.ByteString.Base as B
40 import qualified Data.ByteString.Lazy as L
41
42 import Foreign
43
44 #if defined(__GLASGOW_HASKELL__)
45 import GHC.Base
46 import GHC.Word
47 import GHC.Int
48 #endif
49
50 data S = S L.ByteString -- the rest of the input
51 !Int64 -- bytes read
52
53 -- | The Get monad is just a State monad carrying around the input ByteString
54 newtype Get a = Get { unGet :: State S a }
55
56 instance Monad Get where
57 return a = Get (return a)
58 (Get m) >>= k = Get (m >>= unGet . k)
59 fail = failDesc
60
61 instance MonadState S Get where
62 get = Get get
63 put f = Get (put f)
64
65 instance Functor Get where
66 fmap f (Get m) = Get (fmap f m)
67
68 -- | Run the Get monad applies a 'get'-based parser on the input ByteString
69 runGet :: Get a -> L.ByteString -> a
70 runGet (Get m) str = evalState m (S str 0)
71
72 failDesc :: String -> Get a
73 failDesc err = do
74 S _ bytes <- get
75 fail (err ++ ". Failed reading at byte position " ++ show bytes)
76
77 -- | Skip ahead @n@ bytes
78 skip :: Int -> Get ()
79 skip n = readN n (const ())
80
81 ------------------------------------------------------------------------
82 -- Helpers
83
84 -- Check that there are more bytes left in the input
85 ensureLeft :: Int -> Get ()
86 ensureLeft n = do
87 S (B.LPS strs) _ <- get
88 worker n strs
89 where
90 worker :: Int -> [B.ByteString] -> Get ()
91 worker i _ | i <= 0 = return ()
92 worker _ [] = fail "Data.Binary.Get.ensureLeft: Not enough ByteString left."
93 worker i (x:xs) = worker (i - fromIntegral (B.length x)) xs
94
95 -- Pull n bytes from the input, and apply a parser to those bytes,
96 -- yielding a value
97 readN :: Int -> (L.ByteString -> a) -> Get a
98 readN n f = do
99 ensureLeft n
100 S s bytes <- get
101 let (consuming, rest) = L.splitAt (fromIntegral n) s
102 put $ S rest (bytes + (fromIntegral n))
103 return (f consuming)
104
105 ------------------------------------------------------------------------
106
107 -- | An efficient 'get' method for strict ByteStrings
108 getByteString :: Int -> Get B.ByteString
109 getByteString n = readN (fromIntegral n) (B.concat . L.toChunks)
110
111 -- | An efficient 'get' method for lazy ByteStrings
112 getLazyByteString :: Int -> Get L.ByteString
113 getLazyByteString n = readN n id
114
115 ------------------------------------------------------------------------
116 -- Primtives
117
118 -- | Read a Word8 from the monad state
119 getWord8 :: Get Word8
120 getWord8 = readN 1 L.head
121 {-# INLINE getWord8 #-}
122
123 -- | Read a Word16 in big endian format
124 getWord16be :: Get Word16
125 getWord16be = do
126 w1 <- liftM fromIntegral getWord8
127 w2 <- liftM fromIntegral getWord8
128 return $! w1 `unsafeShiftL_W16` 8 .|. w2
129 {-# INLINE getWord16be #-}
130
131 -- | Read a Word16 in little endian format
132 getWord16le :: Get Word16
133 getWord16le = do
134 w1 <- liftM fromIntegral getWord8
135 w2 <- liftM fromIntegral getWord8
136 return $! w2 `unsafeShiftL_W16` 8 .|. w1
137 {-# INLINE getWord16le #-}
138
139 -- | Read a Word32 in big endian format
140 getWord32be :: Get Word32
141 getWord32be = do
142 w1 <- liftM fromIntegral getWord8
143 w2 <- liftM fromIntegral getWord8
144 w3 <- liftM fromIntegral getWord8
145 w4 <- liftM fromIntegral getWord8
146 return $! (w1 `unsafeShiftL_W32` 24) .|.
147 (w2 `unsafeShiftL_W32` 16) .|.
148 (w3 `unsafeShiftL_W32` 8) .|.
149 (w4)
150 {-# INLINE getWord32be #-}
151
152 -- | Read a Word32 in little endian format
153 getWord32le :: Get Word32
154 getWord32le = do
155 w1 <- liftM fromIntegral getWord8
156 w2 <- liftM fromIntegral getWord8
157 w3 <- liftM fromIntegral getWord8
158 w4 <- liftM fromIntegral getWord8
159 return $! (w4 `unsafeShiftL_W32` 24) .|.
160 (w3 `unsafeShiftL_W32` 16) .|.
161 (w2 `unsafeShiftL_W32` 8) .|.
162 (w1)
163 {-# INLINE getWord32le #-}
164
165 -- | Read a Word64 in big endian format
166 getWord64be :: Get Word64
167 getWord64be = do
168
169 w1 <- liftM fromIntegral getWord8
170 w2 <- liftM fromIntegral getWord8
171 w3 <- liftM fromIntegral getWord8
172 w4 <- liftM fromIntegral getWord8
173 w5 <- liftM fromIntegral getWord8
174 w6 <- liftM fromIntegral getWord8
175 w7 <- liftM fromIntegral getWord8
176 w8 <- liftM fromIntegral getWord8
177 return $! (w1 `shiftL` 56) .|.
178 (w2 `shiftL` 48) .|.
179 (w3 `shiftL` 40) .|.
180 (w4 `shiftL` 32) .|.
181 (w5 `shiftL` 24) .|.
182 (w6 `shiftL` 16) .|.
183 (w7 `shiftL` 8) .|.
184 (w8)
185
186 {-# INLINE getWord64be #-}
187
188 -- | Read a Word64 in little endian format
189 getWord64le :: Get Word64
190 getWord64le = do
191 w1 <- liftM fromIntegral getWord8
192 w2 <- liftM fromIntegral getWord8
193 w3 <- liftM fromIntegral getWord8
194 w4 <- liftM fromIntegral getWord8
195 w5 <- liftM fromIntegral getWord8
196 w6 <- liftM fromIntegral getWord8
197 w7 <- liftM fromIntegral getWord8
198 w8 <- liftM fromIntegral getWord8
199 return $! (w8 `shiftL` 56) .|.
200 (w7 `shiftL` 48) .|.
201 (w6 `shiftL` 40) .|.
202 (w5 `shiftL` 32) .|.
203 (w4 `shiftL` 24) .|.
204 (w3 `shiftL` 16) .|.
205 (w2 `shiftL` 8) .|.
206 (w1)
207 {-# INLINE getWord64le #-}
208
209 --
210 -- Helpers. Should save a bounds check each time (could we inline these
211 -- further? check the core first.
212 --
213 unsafeShiftL_W16 :: Word16 -> Int -> Word16
214 {-# INLINE unsafeShiftL_W16 #-}
215
216 unsafeShiftL_W32 :: Word32 -> Int -> Word32
217 {-# INLINE unsafeShiftL_W32 #-}
218
219 #if defined(__GLASGOW_HASKELL__)
220 unsafeShiftL_W16 (W16# x#) (I# i#) = W16# (narrow16Word# (x# `shiftL#` i#))
221 unsafeShiftL_W32 (W32# x#) (I# i#) = W32# (narrow32Word# (x# `shiftL#` i#))
222 #else
223 unsafeShiftL_W16 = shiftL
224 unsafeShiftL_W32 = shiftL
225 #endif
226
227
228 ------------------------------------------------------------------------
229
230 {-# RULESAREEVIL
231 "ensureLeft/combine" forall a b.
232 ensureLeft a >> ensureLeft b = ensureLeft (max a b)
233 #-}
234
235 {-# *IGNORE* RULES "readN/combine" forall s1 s2 f1 f2 k. readN s1 f1 >>= \w1 -> readN s2 f2 >>= \w2 -> k = readN (s1+s2) (\s -> f1 s >>= \w1 -> f2 (L.drop s1 s)) #-}