1{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE MagicHash #-}
4module Data.ByteString.Base16.Internal
5( -- * worker loops
6  encodeLoop
7, decodeLoop
8, lenientLoop
9  -- * utils
10, c2w
11, aix
12, reChunk
13, unsafeShiftR
14, withBS
15, mkBS
16) where
17
18
19import Data.Bits ((.&.), (.|.))
20import qualified Data.ByteString as B
21import Data.ByteString.Internal (ByteString(..))
22import Data.Char (ord)
23
24import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
25import Foreign.Ptr (Ptr, minusPtr, plusPtr)
26import Foreign.Storable (Storable(poke, peek))
27
28import GHC.Word (Word8(..))
29import GHC.Exts (Int(I#), Addr#, indexWord8OffAddr#, word2Int#, uncheckedShiftRL#)
30
31#if __GLASGOW_HASKELL__ >= 702
32import System.IO.Unsafe (unsafeDupablePerformIO)
33#else
34import GHC.IO (unsafeDupablePerformIO)
35#endif
36
37
38-- ------------------------------------------------------------------ --
39-- Loops
40
41encodeLoop
42    :: Ptr Word8
43    -> Ptr Word8
44    -> Ptr Word8
45    -> IO ()
46encodeLoop !dptr !sptr !end = go dptr sptr
47  where
48    !hex = "0123456789abcdef"#
49
50    go !dst !src
51      | src == end = return ()
52      | otherwise = do
53        !t <- peek src
54
55        poke dst (aix (unsafeShiftR t 4) hex)
56        poke (plusPtr dst 1) (aix (t .&. 0x0f) hex)
57
58        go (plusPtr dst 2) (plusPtr src 1)
59{-# INLINE encodeLoop #-}
60
61decodeLoop
62  :: ForeignPtr Word8
63  -> Ptr Word8
64  -> Ptr Word8
65  -> Ptr Word8
66  -> IO (Either String ByteString)
67decodeLoop !dfp !dptr !sptr !end = go dptr sptr
68  where
69    err !src = return . Left
70      $ "invalid character at offset: "
71      ++ show (src `minusPtr` sptr)
72
73    !lo = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
74
75    !hi = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
76
77    go !dst !src
78      | src == end = return (Right (mkBS dfp (dst `minusPtr` dptr)))
79      | otherwise = do
80        !x <- peek src
81        !y <- peek (plusPtr src 1)
82
83        let !a = aix x hi
84            !b = aix y lo
85
86        if a == 0xff
87        then err src
88        else
89          if b == 0xff
90          then err (plusPtr src 1)
91          else do
92            poke dst (a .|. b)
93            go (plusPtr dst 1) (plusPtr src 2)
94{-# INLINE decodeLoop #-}
95
96lenientLoop
97  :: ForeignPtr Word8
98  -> Ptr Word8
99  -> Ptr Word8
100  -> Ptr Word8
101  -> IO ByteString
102lenientLoop !dfp !dptr !sptr !end = goHi dptr sptr 0
103  where
104    !lo = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
105
106    !hi = "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
107
108    goHi !dst !src !n
109      | src == end = return (mkBS dfp n)
110      | otherwise = do
111        !x <- peek src
112
113        let !a = aix x hi
114
115        if a == 0xff
116        then goHi dst (plusPtr src 1) n
117        else goLo dst (plusPtr src 1) a n
118
119    goLo !dst !src !a !n
120      | src == end = return (mkBS dfp n)
121      | otherwise = do
122        !y <- peek src
123
124        let !b = aix y lo
125
126        if b == 0xff
127        then goLo dst (plusPtr src 1) a n
128        else do
129          poke dst (a .|. b)
130          goHi (plusPtr dst 1) (plusPtr src 1) (n + 1)
131{-# INLINE lenientLoop #-}
132
133
134-- ------------------------------------------------------------------ --
135-- Utils
136
137aix :: Word8 -> Addr# -> Word8
138aix (W8# w) table = W8# (indexWord8OffAddr# table (word2Int# w))
139{-# INLINE aix #-}
140
141-- | Form a list of chunks, and rechunk the list of bytestrings
142-- into length multiples of 2
143--
144reChunk :: [ByteString] -> [ByteString]
145reChunk [] = []
146reChunk (c:cs) = case B.length c `divMod` 2 of
147    (_, 0) -> c : reChunk cs
148    (n, _) -> case B.splitAt (n * 2) c of
149      ~(m, q) -> m : cont_ q cs
150  where
151    cont_ q [] = [q]
152    cont_ q (a:as) = case B.splitAt 1 a of
153      ~(x, y) -> let q' = B.append q x
154        in if B.length q' == 2
155          then
156            let as' = if B.null y then as else y:as
157            in q' : reChunk as'
158          else cont_ q' as
159
160unsafeShiftR :: Word8 -> Int -> Word8
161unsafeShiftR (W8# x#) (I# i#) = W8# (x# `uncheckedShiftRL#` i#)
162{-# INLINE unsafeShiftR #-}
163
164c2w :: Char -> Word8
165c2w = fromIntegral . ord
166{-# INLINE c2w #-}
167
168mkBS :: ForeignPtr Word8 -> Int -> ByteString
169#if MIN_VERSION_bytestring(0,11,0)
170mkBS dfp n = BS dfp n
171#else
172mkBS dfp n = PS dfp 0 n
173#endif
174{-# INLINE mkBS #-}
175
176withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a
177#if MIN_VERSION_bytestring(0,11,0)
178withBS (BS !sfp !slen) f = unsafeDupablePerformIO $
179  withForeignPtr sfp $ \p -> f p slen
180#else
181withBS (PS !sfp !soff !slen) f = unsafeDupablePerformIO $
182  withForeignPtr sfp $ \p -> f (plusPtr p soff) slen
183#endif
184{-# INLINE withBS #-}
185