-- |
-- Module      : Data.Memory.Encoding.Base16
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
-- Low-level Base16 encoding and decoding.
--
-- If you just want to encode or decode some bytes, you probably want to use
-- the "Data.ByteArray.Encoding" module.
--
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE Rank2Types #-}
module Data.Memory.Encoding.Base16
    ( showHexadecimal
    , toHexadecimal
    , fromHexadecimal
    ) where

import           Data.Memory.Internal.Compat
import           Data.Word
import           Data.Bits ((.|.))
import           GHC.Prim
import           GHC.Types
import           GHC.Word
import           Control.Monad
import           Foreign.Storable
import           Foreign.Ptr (Ptr)

-- | Transform a raw memory to an hexadecimal 'String'
-- 
-- user beware, no checks are made
showHexadecimal :: (forall a . (Ptr Word8 -> IO a) -> IO a) -- ^ a 'with' type of function to hold reference to the object
                -> Int    -- ^ length in bytes
                -> String
showHexadecimal :: (forall a. (Ptr Word8 -> IO a) -> IO a) -> Int -> String
showHexadecimal forall a. (Ptr Word8 -> IO a) -> IO a
withPtr = Int -> Int -> String
forall t. (Ord t, Num t) => Int -> t -> String
doChunks Int
0
  where
        doChunks :: Int -> t -> String
doChunks Int
ofs t
len
            | t
len t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
4   = Int -> t -> String
forall t. (Eq t, Num t) => Int -> t -> String
doUnique Int
ofs t
len
            | Bool
otherwise = do
                let !(W8# Word#
a, W8# Word#
b, W8# Word#
c, W8# Word#
d) = IO (Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8)
forall a. IO a -> a
unsafeDoIO (IO (Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8))
-> IO (Word8, Word8, Word8, Word8) -> (Word8, Word8, Word8, Word8)
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO (Word8, Word8, Word8, Word8))
-> IO (Word8, Word8, Word8, Word8)
forall a. (Ptr Word8 -> IO a) -> IO a
withPtr (Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
read4 Int
ofs)
                    !(# Word#
w1, Word#
w2 #) = Word# -> (# Word#, Word# #)
convertByte Word#
a
                    !(# Word#
w3, Word#
w4 #) = Word# -> (# Word#, Word# #)
convertByte Word#
b
                    !(# Word#
w5, Word#
w6 #) = Word# -> (# Word#, Word# #)
convertByte Word#
c
                    !(# Word#
w7, Word#
w8 #) = Word# -> (# Word#, Word# #)
convertByte Word#
d
                 in Word# -> Char
wToChar Word#
w1 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w2 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w3 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w4
                  Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w5 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w6 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w7 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w8
                  Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> t -> String
doChunks (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
4)

        doUnique :: Int -> t -> String
doUnique Int
ofs t
len
            | t
len t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0  = []
            | Bool
otherwise =
                let !(W8# Word#
b)      = IO Word8 -> Word8
forall a. IO a -> a
unsafeDoIO (IO Word8 -> Word8) -> IO Word8 -> Word8
forall a b. (a -> b) -> a -> b
$ (Ptr Word8 -> IO Word8) -> IO Word8
forall a. (Ptr Word8 -> IO a) -> IO a
withPtr (Int -> Ptr Word8 -> IO Word8
byteIndex Int
ofs)
                    !(# Word#
w1, Word#
w2 #) = Word# -> (# Word#, Word# #)
convertByte Word#
b
                 in Word# -> Char
wToChar Word#
w1 Char -> String -> String
forall a. a -> [a] -> [a]
: Word# -> Char
wToChar Word#
w2 Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> t -> String
doUnique (Int
ofs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (t
len t -> t -> t
forall a. Num a => a -> a -> a
- t
1)

        read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
        read4 :: Int -> Ptr Word8 -> IO (Word8, Word8, Word8, Word8)
read4 Int
ofs Ptr Word8
p =
            (Word8 -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
-> IO Word8
-> IO Word8
-> IO Word8
-> IO Word8
-> IO (Word8, Word8, Word8, Word8)
forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (Int -> Ptr Word8 -> IO Word8
byteIndex Int
ofs     Ptr Word8
p) (Int -> Ptr Word8 -> IO Word8
byteIndex (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Ptr Word8
p)
                         (Int -> Ptr Word8 -> IO Word8
byteIndex (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Ptr Word8
p) (Int -> Ptr Word8 -> IO Word8
byteIndex (Int
ofsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3) Ptr Word8
p)

        wToChar :: Word# -> Char
        wToChar :: Word# -> Char
wToChar Word#
w = Int -> Char
forall a. Enum a => Int -> a
toEnum (Int# -> Int
I# (Word# -> Int#
word2Int# Word#
w))

        byteIndex :: Int -> Ptr Word8 -> IO Word8
        byteIndex :: Int -> Ptr Word8 -> IO Word8
byteIndex Int
i Ptr Word8
p = Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
p Int
i

-- | Transform a number of bytes pointed by.@src in the hexadecimal binary representation in @dst
--
-- destination memory need to be of correct size, otherwise it will lead
-- to really bad things.
toHexadecimal :: Ptr Word8 -- ^ destination memory
              -> Ptr Word8 -- ^ source memory
              -> Int       -- ^ number of bytes
              -> IO ()
toHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()
toHexadecimal Ptr Word8
bout Ptr Word8
bin Int
n = Int -> IO ()
loop Int
0
  where loop :: Int -> IO ()
loop Int
i
            | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n  = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise = do
                (W8# Word#
w) <- Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
bin Int
i
                let !(# Word#
w1, Word#
w2 #) = Word# -> (# Word#, Word# #)
convertByte Word#
w
                Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
bout (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)     (Word# -> Word8
W8# Word#
w1)
                Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
bout (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Word# -> Word8
W8# Word#
w2)
                Int -> IO ()
loop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)

-- | Convert a value Word# to two Word#s containing
-- the hexadecimal representation of the Word#
convertByte :: Word# -> (# Word#, Word# #)
convertByte :: Word# -> (# Word#, Word# #)
convertByte Word#
b = (# Addr# -> Word# -> Word#
r Addr#
tableHi Word#
b, Addr# -> Word# -> Word#
r Addr#
tableLo Word#
b #)
  where
        r :: Addr# -> Word# -> Word#
        r :: Addr# -> Word# -> Word#
r Addr#
table Word#
index = Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
table (Word# -> Int#
word2Int# Word#
index)

        !tableLo :: Addr#
tableLo =
            Addr#
"0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef\
            \0123456789abcdef0123456789abcdef"#
        !tableHi :: Addr#
tableHi =
            Addr#
"00000000000000001111111111111111\
            \22222222222222223333333333333333\
            \44444444444444445555555555555555\
            \66666666666666667777777777777777\
            \88888888888888889999999999999999\
            \aaaaaaaaaaaaaaaabbbbbbbbbbbbbbbb\
            \ccccccccccccccccdddddddddddddddd\
            \eeeeeeeeeeeeeeeeffffffffffffffff"#
{-# INLINE convertByte #-}

-- | convert a base16 @src in @dst.
--
-- n need to even
fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromHexadecimal :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Maybe Int)
fromHexadecimal Ptr Word8
dst Ptr Word8
src Int
n
    | Int -> Bool
forall a. Integral a => a -> Bool
odd Int
n     = String -> IO (Maybe Int)
forall a. HasCallStack => String -> a
error String
"fromHexadecimal: invalid odd length."
    | Bool
otherwise = Int -> Int -> IO (Maybe Int)
loop Int
0 Int
0
  where loop :: Int -> Int -> IO (Maybe Int)
loop Int
di Int
i
            | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n    = Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
            | Bool
otherwise = do
                Word8
a <- Word8 -> Word8
rHi (Word8 -> Word8) -> IO Word8 -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
src Int
i
                Word8
b <- Word8 -> Word8
rLo (Word8 -> Word8) -> IO Word8 -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr Word8 -> Int -> IO Word8
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
src (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
                if Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff Bool -> Bool -> Bool
|| Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff
                    then Maybe Int -> IO (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> IO (Maybe Int)) -> Maybe Int -> IO (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just Int
i
                    else Ptr Word8 -> Int -> Word8 -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
dst Int
di (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
b) IO () -> IO (Maybe Int) -> IO (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Int -> IO (Maybe Int)
loop (Int
diInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)

        rLo :: Word8 -> Word8
rLo (W8# Word#
index) = Word# -> Word8
W8# (Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
tableLo (Word# -> Int#
word2Int# Word#
index))
        rHi :: Word8 -> Word8
rHi (W8# Word#
index) = Word# -> Word8
W8# (Addr# -> Int# -> Word#
indexWord8OffAddr# Addr#
tableHi (Word# -> Int#
word2Int# Word#
index))
        
        !tableLo :: Addr#
tableLo =
                Addr#
"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
                 \\xff\xff\xff\xff\xff\xff\xff\xff\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"#
        !tableHi :: Addr#
tableHi =
                Addr#
"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
                 \\xff\xff\xff\xff\xff\xff\xff\xff\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"#