1-- |
2-- Module      : Data.Memory.Encoding.Base16
3-- License     : BSD-style
4-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
5-- Stability   : experimental
6-- Portability : unknown
7--
8-- Low-level Base16 encoding and decoding.
9--
10-- If you just want to encode or decode some bytes, you probably want to use
11-- the "Data.ByteArray.Encoding" module.
12--
13{-# LANGUAGE MagicHash #-}
14{-# LANGUAGE UnboxedTuples #-}
15{-# LANGUAGE OverloadedStrings #-}
16{-# LANGUAGE BangPatterns #-}
17{-# LANGUAGE Rank2Types #-}
18module Data.Memory.Encoding.Base16
19    ( showHexadecimal
20    , toHexadecimal
21    , fromHexadecimal
22    ) where
23
24import           Data.Memory.Internal.Compat
25import           Data.Word
26import           Data.Bits ((.|.))
27import           GHC.Prim
28import           GHC.Types
29import           GHC.Word
30import           Control.Monad
31import           Foreign.Storable
32import           Foreign.Ptr (Ptr)
33
34-- | Transform a raw memory to an hexadecimal 'String'
35--
36-- user beware, no checks are made
37showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object
38                -> Int    -- ^ length in bytes
39                -> String
40showHexadecimal withPtr = doChunks 0
41  where
42        doChunks ofs len
43            | len < 4   = doUnique ofs len
44            | otherwise = do
45                let !(W8# a, W8# b, W8# c, W8# d) = unsafeDoIO $ withPtr (read4 ofs)
46                    !(# w1, w2 #) = convertByte a
47                    !(# w3, w4 #) = convertByte b
48                    !(# w5, w6 #) = convertByte c
49                    !(# w7, w8 #) = convertByte d
50                 in wToChar w1 : wToChar w2 : wToChar w3 : wToChar w4
51                  : wToChar w5 : wToChar w6 : wToChar w7 : wToChar w8
52                  : doChunks (ofs + 4) (len - 4)
53
54        doUnique ofs len
55            | len == 0  = []
56            | otherwise =
57                let !(W8# b)      = unsafeDoIO $ withPtr (byteIndex ofs)
58                    !(# w1, w2 #) = convertByte b
59                 in wToChar w1 : wToChar w2 : doUnique (ofs + 1) (len - 1)
60
61        read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
62        read4 ofs p =
63            liftM4 (,,,) (byteIndex ofs     p) (byteIndex (ofs+1) p)
64                         (byteIndex (ofs+2) p) (byteIndex (ofs+3) p)
65
66        wToChar :: Word# -> Char
67        wToChar w = toEnum (I# (word2Int# w))
68
69        byteIndex :: Int -> Ptr Word8 -> IO Word8
70        byteIndex i p = peekByteOff p i
71
72-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst
73--
74-- destination memory need to be of correct size, otherwise it will lead
75-- to really bad things.
76toHexadecimal :: Ptr Word8 -- ^ destination memory
77              -> Ptr Word8 -- ^ source memory
78              -> Int       -- ^ number of bytes
79              -> IO ()
80toHexadecimal bout bin n = loop 0
81  where loop i
82            | i == n  = return ()
83            | otherwise = do
84                (W8# w) <- peekByteOff bin i
85                let !(# w1, w2 #) = convertByte w
86                pokeByteOff bout (i * 2)     (W8# w1)
87                pokeByteOff bout (i * 2 + 1) (W8# w2)
88                loop (i+1)
89
90-- | Convert a value Word# to two Word#s containing
91-- the hexadecimal representation of the Word#
92convertByte :: Word# -> (# Word#, Word# #)
93convertByte b = (# r tableHi b, r tableLo b #)
94  where
95        r :: Addr# -> Word# -> Word#
96        r table index = indexWord8OffAddr# table (word2Int# index)
97
98        !tableLo =
99            "0123456789abcdef0123456789abcdef\
100            \0123456789abcdef0123456789abcdef\
101            \0123456789abcdef0123456789abcdef\
102            \0123456789abcdef0123456789abcdef\
103            \0123456789abcdef0123456789abcdef\
104            \0123456789abcdef0123456789abcdef\
105            \0123456789abcdef0123456789abcdef\
106            \0123456789abcdef0123456789abcdef"#
107        !tableHi =
108            "00000000000000001111111111111111\
109            \22222222222222223333333333333333\
110            \44444444444444445555555555555555\
111            \66666666666666667777777777777777\
112            \88888888888888889999999999999999\
113            \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\
114            \ccccccccccccccccdddddddddddddddd\
115            \eeeeeeeeeeeeeeeeffffffffffffffff"#
116{-# INLINE convertByte #-}
117
118-- | convert a base16 @src in @dst.
119--
120-- n need to even
121fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
122fromHexadecimal dst src n
123    | odd n     = error "fromHexadecimal: invalid odd length."
124    | otherwise = loop 0 0
125  where loop di i
126            | i == n    = return Nothing
127            | otherwise = do
128                a <- rHi `fmap` peekByteOff src i
129                b <- rLo `fmap` peekByteOff src (i+1)
130                if a == 0xff || b == 0xff
131                    then return $ Just i
132                    else pokeByteOff dst di (a .|. b) >> loop (di+1) (i+2)
133
134        rLo (W8# index) = W8# (indexWord8OffAddr# tableLo (word2Int# index))
135        rHi (W8# index) = W8# (indexWord8OffAddr# tableHi (word2Int# index))
136
137        !tableLo =
138                "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
139                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
140                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
141                 \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\xff\xff\xff\xff\xff\xff\
142                 \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\
143                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
144                 \\xff\x0a\x0b\x0c\x0d\x0e\x0f\xff\xff\xff\xff\xff\xff\xff\xff\xff\
145                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
146                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
147                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
148                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
149                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
150                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
151                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
152                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
153                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
154        !tableHi =
155                "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
156                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
157                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
158                 \\x00\x10\x20\x30\x40\x50\x60\x70\x80\x90\xff\xff\xff\xff\xff\xff\
159                 \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\
160                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
161                 \\xff\xa0\xb0\xc0\xd0\xe0\xf0\xff\xff\xff\xff\xff\xff\xff\xff\xff\
162                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
163                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
164                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
165                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
166                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
167                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
168                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
169                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
170                 \\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#
171
172