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
|
{-# LANGUAGE FlexibleInstances,FlexibleContexts,MultiParamTypeClasses,CPP #-}
module Data.Encoding.ByteSource where
import Data.Encoding.Exception
import Data.Bits
import Data.Binary.Get
import Data.Char
import Data.Maybe
import Data.Word
import Control.Applicative as A
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT (..), get, gets, put)
import Control.Monad.Identity (Identity)
import Control.Monad.Reader (ReaderT, ask)
import Control.Exception.Extensible
import Control.Throws
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import System.IO
class (Monad m,Throws DecodingException m) => ByteSource m where
sourceEmpty :: m Bool
fetchWord8 :: m Word8
-- 'fetchAhead act' should return the same thing 'act' does, but should
-- only consume input if 'act' returns a 'Just' value
fetchAhead :: m (Maybe a) -> m (Maybe a)
fetchWord16be :: m Word16
fetchWord16be = do
w1 <- fetchWord8
w2 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 8)
.|. (fromIntegral w2)
fetchWord16le :: m Word16
fetchWord16le = do
w1 <- fetchWord8
w2 <- fetchWord8
return $ ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
fetchWord32be :: m Word32
fetchWord32be = do
w1 <- fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 24)
.|. ((fromIntegral w2) `shiftL` 16)
.|. ((fromIntegral w3) `shiftL` 8)
.|. (fromIntegral w4)
fetchWord32le :: m Word32
fetchWord32le = do
w1 <- fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
return $ ((fromIntegral w4) `shiftL` 24)
.|. ((fromIntegral w3) `shiftL` 16)
.|. ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
fetchWord64be :: m Word64
fetchWord64be = do
w1 <- fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
w5 <- fetchWord8
w6 <- fetchWord8
w7 <- fetchWord8
w8 <- fetchWord8
return $ ((fromIntegral w1) `shiftL` 56)
.|. ((fromIntegral w2) `shiftL` 48)
.|. ((fromIntegral w3) `shiftL` 40)
.|. ((fromIntegral w4) `shiftL` 32)
.|. ((fromIntegral w5) `shiftL` 24)
.|. ((fromIntegral w6) `shiftL` 16)
.|. ((fromIntegral w7) `shiftL` 8)
.|. (fromIntegral w8)
fetchWord64le :: m Word64
fetchWord64le = do
w1 <- fetchWord8
w2 <- fetchWord8
w3 <- fetchWord8
w4 <- fetchWord8
w5 <- fetchWord8
w6 <- fetchWord8
w7 <- fetchWord8
w8 <- fetchWord8
return $ ((fromIntegral w8) `shiftL` 56)
.|. ((fromIntegral w7) `shiftL` 48)
.|. ((fromIntegral w6) `shiftL` 40)
.|. ((fromIntegral w5) `shiftL` 32)
.|. ((fromIntegral w4) `shiftL` 24)
.|. ((fromIntegral w3) `shiftL` 16)
.|. ((fromIntegral w2) `shiftL` 8)
.|. (fromIntegral w1)
instance Throws DecodingException Get where
throwException = throw
instance ByteSource Get where
sourceEmpty = isEmpty
fetchWord8 = getWord8
#if MIN_VERSION_binary(0,6,0)
fetchAhead act = (do
res <- act
case res of
Nothing -> A.empty
Just a -> return res
) <|> return Nothing
#else
fetchAhead act = do
res <- lookAhead act
case res of
Nothing -> return Nothing
Just a -> act
#endif
fetchWord16be = getWord16be
fetchWord16le = getWord16le
fetchWord32be = getWord32be
fetchWord32le = getWord32le
fetchWord64be = getWord64be
fetchWord64le = getWord64le
fetchAheadState act = do
chs <- get
res <- act
when (isNothing res) (put chs)
return res
instance ByteSource (StateT [Char] Identity) where
sourceEmpty = gets null
fetchWord8 = do
chs <- get
case chs of
[] -> throwException UnexpectedEnd
c:cs -> do
put cs
return (fromIntegral $ ord c)
fetchAhead = fetchAheadState
#if MIN_VERSION_base(4,3,0)
#else
instance Monad (Either DecodingException) where
return = Right
(Left err) >>= g = Left err
(Right x) >>= g = g x
#endif
instance ByteSource (StateT [Char] (Either DecodingException)) where
sourceEmpty = gets null
fetchWord8 = do
chs <- get
case chs of
[] -> throwException UnexpectedEnd
c:cs -> do
put cs
return (fromIntegral $ ord c)
fetchAhead = fetchAheadState
instance (Monad m,Throws DecodingException m) => ByteSource (StateT BS.ByteString m) where
sourceEmpty = gets BS.null
fetchWord8 = StateT (\str -> case BS.uncons str of
Nothing -> throwException UnexpectedEnd
Just (c,cs) -> return (c,cs))
fetchAhead = fetchAheadState
instance ByteSource (StateT LBS.ByteString (Either DecodingException)) where
sourceEmpty = gets LBS.null
fetchWord8 = StateT (\str -> case LBS.uncons str of
Nothing -> Left UnexpectedEnd
Just ns -> Right ns)
fetchAhead = fetchAheadState
instance ByteSource (ReaderT Handle IO) where
sourceEmpty = do
h <- ask
liftIO (hIsEOF h)
fetchWord8 = do
h <- ask
liftIO $ do
ch <- hGetChar h
return (fromIntegral $ ord ch)
fetchAhead act = do
h <- ask
pos <- liftIO $ hGetPosn h
res <- act
when (isNothing res) (liftIO $ hSetPosn pos)
return res
|
