{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
module Data.ByteString.Base16.Internal
( -- * worker loops
  encodeLoop
, decodeLoop
, lenientLoop
  -- * utils
, c2w
, aix
, reChunk
, withBS
, mkBS
) where


import Data.Bits ((.&.), (.|.), unsafeShiftR)
import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString(..))
import Data.Char (ord)

import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, minusPtr, plusPtr)
import Foreign.Storable (Storable(poke, peek))

import GHC.Word (Word8(..))
import GHC.Exts (Int(I#), Addr#, indexWord8OffAddr#)

#if __GLASGOW_HASKELL__ >= 702
import System.IO.Unsafe (unsafeDupablePerformIO)
#else
import GHC.IO (unsafeDupablePerformIO)
#endif


-- ------------------------------------------------------------------ --
-- Loops

encodeLoop
    :: Ptr Word8
    -> Ptr Word8
    -> Ptr Word8
    -> IO ()
encodeLoop :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO ()
encodeLoop !Ptr Word8
dptr !Ptr Word8
sptr !Ptr Word8
end = Ptr Word8 -> Ptr Word8 -> IO ()
go Ptr Word8
dptr Ptr Word8
sptr
  where
    !hex :: Addr#
hex = Addr#
"0123456789abcdef"#

    go :: Ptr Word8 -> Ptr Word8 -> IO ()
go !Ptr Word8
dst !Ptr Word8
src
      | Ptr Word8
src Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Bool
otherwise = do
        !Word8
t <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
src

        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
dst (Word8 -> Addr# -> Word8
aix (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
unsafeShiftR Word8
t Int
4) Addr#
hex)
        Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Word8 -> Addr# -> Word8
aix (Word8
t Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0f) Addr#
hex)

        Ptr Word8 -> Ptr Word8 -> IO ()
go (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
2) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1)
{-# INLINE encodeLoop #-}

decodeLoop
  :: ForeignPtr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> IO (Either String ByteString)
decodeLoop :: ForeignPtr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> IO (Either String ByteString)
decodeLoop !ForeignPtr Word8
dfp !Ptr Word8
dptr !Ptr Word8
sptr !Ptr Word8
end = Ptr Word8 -> Ptr Word8 -> IO (Either String ByteString)
go Ptr Word8
dptr Ptr Word8
sptr
  where
    err :: Ptr a -> m (Either String b)
err !Ptr a
src = Either String b -> m (Either String b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> (String -> Either String b) -> String -> m (Either String b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String b
forall a b. a -> Either a b
Left
      (String -> m (Either String b)) -> String -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String
"invalid character at offset: "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Ptr a
src Ptr a -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
sptr)

    !lo :: Addr#
lo = 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"#

    !hi :: Addr#
hi = 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"#

    go :: Ptr Word8 -> Ptr Word8 -> IO (Either String ByteString)
go !Ptr Word8
dst !Ptr Word8
src
      | Ptr Word8
src Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = Either String ByteString -> IO (Either String ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp (Ptr Word8
dst Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
dptr)))
      | Bool
otherwise = do
        !Word8
x <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
src
        !Word8
y <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1)

        let !a :: Word8
a = Word8 -> Addr# -> Word8
aix Word8
x Addr#
hi
            !b :: Word8
b = Word8 -> Addr# -> Word8
aix Word8
y Addr#
lo

        if Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff
        then Ptr Word8 -> IO (Either String ByteString)
forall {m :: * -> *} {a} {b}.
Monad m =>
Ptr a -> m (Either String b)
err Ptr Word8
src
        else
          if Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff
          then Ptr Any -> IO (Either String ByteString)
forall {m :: * -> *} {a} {b}.
Monad m =>
Ptr a -> m (Either String b)
err (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1)
          else do
            Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
dst (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
b)
            Ptr Word8 -> Ptr Word8 -> IO (Either String ByteString)
go (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
2)
{-# INLINE decodeLoop #-}

lenientLoop
  :: ForeignPtr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> IO ByteString
lenientLoop :: ForeignPtr Word8
-> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO ByteString
lenientLoop !ForeignPtr Word8
dfp !Ptr Word8
dptr !Ptr Word8
sptr !Ptr Word8
end = Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
goHi Ptr Word8
dptr Ptr Word8
sptr Int
0
  where
    !lo :: Addr#
lo = 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"#

    !hi :: Addr#
hi = 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"#

    goHi :: Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
goHi !Ptr Word8
dst !Ptr Word8
src !Int
n
      | Ptr Word8
src Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n)
      | Bool
otherwise = do
        !Word8
x <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
src

        let !a :: Word8
a = Word8 -> Addr# -> Word8
aix Word8
x Addr#
hi

        if Word8
a Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff
        then Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
goHi Ptr Word8
dst (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1) Int
n
        else Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> IO ByteString
goLo Ptr Word8
dst (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1) Word8
a Int
n

    goLo :: Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> IO ByteString
goLo !Ptr Word8
dst !Ptr Word8
src !Word8
a !Int
n
      | Ptr Word8
src Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n)
      | Bool
otherwise = do
        !Word8
y <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
src

        let !b :: Word8
b = Word8 -> Addr# -> Word8
aix Word8
y Addr#
lo

        if Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0xff
        then Ptr Word8 -> Ptr Word8 -> Word8 -> Int -> IO ByteString
goLo Ptr Word8
dst (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1) Word8
a Int
n
        else do
          Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word8
dst (Word8
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
b)
          Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
goHi (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
{-# INLINE lenientLoop #-}


-- ------------------------------------------------------------------ --
-- Utils

aix :: Word8 -> Addr# -> Word8
aix :: Word8 -> Addr# -> Word8
aix Word8
w Addr#
table = Word8# -> Word8
W8# (Addr# -> Int# -> Word8#
indexWord8OffAddr# Addr#
table Int#
i)
  where
    !(I# Int#
i) = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w
{-# INLINE aix #-}

-- | Form a list of chunks, and rechunk the list of bytestrings
-- into length multiples of 2
--
reChunk :: [ByteString] -> [ByteString]
reChunk :: [ByteString] -> [ByteString]
reChunk [] = []
reChunk (ByteString
c:[ByteString]
cs) = case ByteString -> Int
B.length ByteString
c Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2 of
    (Int
_, Int
0) -> ByteString
c ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
reChunk [ByteString]
cs
    (Int
n, Int
_) -> case Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2) ByteString
c of
      ~(ByteString
m, ByteString
q) -> ByteString
m ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString] -> [ByteString]
cont_ ByteString
q [ByteString]
cs
  where
    cont_ :: ByteString -> [ByteString] -> [ByteString]
cont_ ByteString
q [] = [ByteString
q]
    cont_ ByteString
q (ByteString
a:[ByteString]
as) = case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
1 ByteString
a of
      ~(ByteString
x, ByteString
y) -> let q' :: ByteString
q' = ByteString -> ByteString -> ByteString
B.append ByteString
q ByteString
x
        in if ByteString -> Int
B.length ByteString
q' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2
          then
            let as' :: [ByteString]
as' = if ByteString -> Bool
B.null ByteString
y then [ByteString]
as else ByteString
yByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
as
            in ByteString
q' ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
reChunk [ByteString]
as'
          else ByteString -> [ByteString] -> [ByteString]
cont_ ByteString
q' [ByteString]
as

c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
{-# INLINE c2w #-}

mkBS :: ForeignPtr Word8 -> Int -> ByteString
#if MIN_VERSION_bytestring(0,11,0)
mkBS :: ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n = ForeignPtr Word8 -> Int -> ByteString
BS ForeignPtr Word8
dfp Int
n
#else
mkBS dfp n = PS dfp 0 n
#endif
{-# INLINE mkBS #-}

withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a
#if MIN_VERSION_bytestring(0,11,0)
withBS :: forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (BS !ForeignPtr Word8
sfp !Int
slen) Ptr Word8 -> Int -> IO a
f = IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$
  ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO a
f Ptr Word8
p Int
slen
#else
withBS (PS !sfp !soff !slen) f = unsafeDupablePerformIO $
  withForeignPtr sfp $ \p -> f (plusPtr p soff) slen
#endif
{-# INLINE withBS #-}