{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
-- |
-- Module       : Data.ByteString.Base16.Internal.W16.Loop
-- Copyright 	: (c) 2020 Emily Pillmore
-- License	: BSD-style
--
-- Maintainer	: Emily Pillmore <emilypi@cohomolo.gy>
-- Stability	: Experimental
-- Portability	: portable
--
-- Encoding loop optimized for 'Word16' architectures
--
module Data.ByteString.Base16.Internal.W16.Loop
( innerLoop
, decodeLoop
, lenientLoop
) where


import Data.Bits
import Data.ByteString.Internal
import Data.ByteString.Base16.Internal.Utils
import Data.Text (Text)
import qualified Data.Text as T

import Foreign.ForeignPtr
import Foreign.Ptr
import Foreign.Storable

import GHC.Word


-- | Hex encoding inner loop optimized for 16-bit architectures
--
innerLoop
    :: Ptr Word16
    -> Ptr Word8
    -> Ptr Word8
    -> IO ()
innerLoop :: Ptr Word16 -> Ptr Word8 -> Ptr Word8 -> IO ()
innerLoop !Ptr Word16
dptr !Ptr Word8
sptr !Ptr Word8
end = Ptr Word16 -> Ptr Word8 -> IO ()
forall b.
(Storable b, Num b, Bits b) =>
Ptr b -> Ptr Word8 -> IO ()
go Ptr Word16
dptr Ptr Word8
sptr
  where
    lix :: a -> Word8
lix !a
a = Word8 -> Addr# -> Word8
aix (a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
a Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x0f) Addr#
alphabet
    {-# INLINE lix #-}

    !alphabet :: Addr#
alphabet = "0123456789abcdef"#

    go :: Ptr b -> Ptr Word8 -> IO ()
go !Ptr b
dst !Ptr Word8
src
      | Ptr Word8
src Ptr Word8 -> Ptr Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Word8
end = () -> IO ()
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

        let !a :: b
a = Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8
forall a. Integral a => a -> Word8
lix (Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
unsafeShiftR Word8
t 4))
            !b :: b
b = Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8
forall a. Integral a => a -> Word8
lix Word8
t)

        let !w :: b
w = b
a b -> b -> b
forall a. Bits a => a -> a -> a
.|. (b -> Int -> b
forall a. Bits a => a -> Int -> a
unsafeShiftL b
b 8)

        Ptr b -> b -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr b
dst b
w

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

-- | Hex decoding loop optimized for 16-bit architectures
--
decodeLoop
  :: ForeignPtr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Int
  -> IO (Either Text ByteString)
decodeLoop :: ForeignPtr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Int
-> IO (Either Text ByteString)
decodeLoop !ForeignPtr Word8
dfp !Ptr Word8
hi !Ptr Word8
lo !Ptr Word8
dptr !Ptr Word8
sptr !Ptr Word8
end !Int
nn = Ptr Word8 -> Ptr Word8 -> Int -> IO (Either Text ByteString)
forall b.
(Storable b, Num b, Bits b) =>
Ptr b -> Ptr Word8 -> Int -> IO (Either Text ByteString)
go Ptr Word8
dptr Ptr Word8
sptr Int
nn
  where
    err :: Ptr a -> m (Either Text b)
err !Ptr a
src = Either Text b -> m (Either Text b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text b -> m (Either Text b))
-> (String -> Either Text b) -> String -> m (Either Text b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text b
forall a b. a -> Either a b
Left (Text -> Either Text b)
-> (String -> Text) -> String -> Either Text b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
      (String -> m (Either Text b)) -> String -> m (Either Text b)
forall a b. (a -> b) -> a -> b
$ "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)

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

        !b
a <- Ptr Word8 -> Int -> IO b
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
hi (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)
        !b
b <- Ptr Word8 -> Int -> IO b
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
lo (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y)

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


-- | Lenient lazy hex decoding loop optimized for 16-bit architectures.
-- When the 'Right' case is returned, a byte
--
lenientLoop
  :: ForeignPtr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Ptr Word8
  -> Int
  -> IO ByteString
lenientLoop :: ForeignPtr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Int
-> IO ByteString
lenientLoop !ForeignPtr Word8
dfp !Ptr Word8
hi !Ptr Word8
lo !Ptr Word8
dptr !Ptr Word8
sptr !Ptr Word8
end !Int
nn = Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
forall a.
(Storable a, Num a, Bits a) =>
Ptr a -> Ptr Word8 -> Int -> IO ByteString
goHi Ptr Word8
dptr Ptr Word8
sptr Int
nn
  where
    goHi :: Ptr a -> Ptr Word8 -> Int -> IO ByteString
goHi !Ptr a
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 (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 Int
n)
      | Bool
otherwise = do
        !Word8
x <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek @Word8 Ptr Word8
src
        !a
a <- Ptr Word8 -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
hi (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x)

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

    goLo :: Ptr a -> Ptr Word8 -> a -> Int -> IO ByteString
goLo !Ptr a
dst !Ptr Word8
src !a
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 (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 Int
n)
      | Bool
otherwise = do
        !Word8
y <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek @Word8 Ptr Word8
src
        !a
b <- Ptr Word8 -> Int -> IO a
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Word8
lo (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y)

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