-- |
-- Copyright:   (c) 2022 Andrew Lelechenko
-- Licence:     BSD3
-- Maintainer:  Andrew Lelechenko <andrew.lelechenko@gmail.com>
module Data.Text.Builder.Linear.Hex (
  (|>&),
  (&<|),
) where

import Data.Bits (Bits (..), FiniteBits (..))
import Data.Text.Array qualified as A
import Data.Word (Word16, Word32, Word64, Word8)
import GHC.Exts (Int (..), (>#))
import GHC.ST (ST)

import Data.Text.Builder.Linear.Core

-- | Append the lower-case hexadecimal represensation of a number.
--
-- Negative numbers are interpreted as their corresponding unsigned number, e.g.
--
-- >>> :set -XOverloadedStrings -XLinearTypes
-- >>> import Data.Int (Int8, Int16)
-- >>> runBuffer (\b -> b |>& (-1 :: Int8)) == "ff"
-- True
-- >>> runBuffer (\b -> b |>& (-1 :: Int16)) == "ffff"
-- True
(|>&) ∷ (Integral a, FiniteBits a) ⇒ Buffer ⊸ a → Buffer

infixl 6 |>&
Buffer
buffer |>& :: forall a. (Integral a, FiniteBits a) => Buffer %1 -> a -> Buffer
|>& a
n =
  Int
-> (forall s. MArray s -> Int -> ST s Int) -> Buffer %1 -> Buffer
appendBounded
    (forall a. (Integral a, FiniteBits a) => a -> Int
maxHexLen a
n)
    (\MArray s
dst Int
dstOff → forall a s.
(Integral a, FiniteBits a) =>
MArray s -> Int -> a -> ST s Int
unsafeAppendHex MArray s
dst Int
dstOff a
n)
    Buffer
buffer
{-# INLINEABLE (|>&) #-}

-- | Prepend the lower-case hexadecimal representation of a number.
--
-- Negative numbers are interpreted as their corresponding unsigned number, e.g.
--
-- >>> :set -XOverloadedStrings -XLinearTypes
-- >>> import Data.Int (Int8, Int16)
-- >>> runBuffer (\b -> (-1 :: Int8) &<| b) == "ff"
-- True
-- >>> runBuffer (\b -> (-1 :: Int16) &<| b) == "ffff"
-- True
(&<|) ∷ (Integral a, FiniteBits a) ⇒ a → Buffer ⊸ Buffer

infixr 6 &<|
a
n &<| :: forall a. (Integral a, FiniteBits a) => a -> Buffer %1 -> Buffer
&<| Buffer
buffer =
  Int
-> (forall s. MArray s -> Int -> ST s Int)
-> (forall s. MArray s -> Int -> ST s Int)
-> Buffer
%1 -> Buffer
prependBounded
    (forall a. (Integral a, FiniteBits a) => a -> Int
maxHexLen a
n)
    (\MArray s
dst Int
dstOff → forall a s.
(Integral a, FiniteBits a) =>
MArray s -> Int -> a -> ST s Int
unsafePrependHex MArray s
dst Int
dstOff a
n)
    (\MArray s
dst Int
dstOff → forall a s.
(Integral a, FiniteBits a) =>
MArray s -> Int -> a -> ST s Int
unsafeAppendHex MArray s
dst Int
dstOff a
n)
    Buffer
buffer
{-# INLINEABLE (&<|) #-}

-- | Compute the number of nibbles that an integral type can hold, rounded up.
maxHexLen ∷ (Integral a, FiniteBits a) ⇒ a → Int
maxHexLen :: forall a. (Integral a, FiniteBits a) => a -> Int
maxHexLen a
n = Int
1 forall a. Num a => a -> a -> a
+ ((forall b. FiniteBits b => b -> Int
finiteBitSize a
n forall a. Num a => a -> a -> a
- Int
1) forall a. Bits a => a -> Int -> a
`shiftR` Int
2)
{-# INLINEABLE maxHexLen #-}

unsafeAppendHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int
unsafeAppendHex :: forall a s.
(Integral a, FiniteBits a) =>
MArray s -> Int -> a -> ST s Int
unsafeAppendHex MArray s
marr !Int
off a
0 =
  forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr Int
off Word8
0x30 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
unsafeAppendHex MArray s
marr !Int
off a
n = forall {t}. (Integral t, FiniteBits t) => Int -> t -> ST s Int
go (Int
off forall a. Num a => a -> a -> a
+ Int
len forall a. Num a => a -> a -> a
- Int
1) a
n
  where
    len :: Int
len = forall b. FiniteBits b => b -> Int
lengthAsHex a
n

    go :: Int -> t -> ST s Int
go !Int
_ t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
len
    go !Int
o t
m = do
      let nibble :: t
nibble = t
m forall a. Bits a => a -> a -> a
.&. t
0x0f
      forall s. MArray s -> Int -> Int -> ST s ()
writeNibbleAsHex MArray s
marr Int
o (forall a b. (Integral a, Num b) => a -> b
fromIntegral t
nibble)
      Int -> t -> ST s Int
go (Int
o forall a. Num a => a -> a -> a
- Int
1) (forall a. (Integral a, FiniteBits a) => a -> a
dropNibble t
m)
{-# INLINEABLE unsafeAppendHex #-}

unsafePrependHex ∷ (Integral a, FiniteBits a) ⇒ A.MArray s → Int → a → ST s Int
unsafePrependHex :: forall a s.
(Integral a, FiniteBits a) =>
MArray s -> Int -> a -> ST s Int
unsafePrependHex MArray s
marr !Int
off a
0 =
  forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr (Int
off forall a. Num a => a -> a -> a
- Int
1) Word8
0x30 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
unsafePrependHex MArray s
marr !Int
off a
n = forall {t}. (Integral t, FiniteBits t) => Int -> t -> ST s Int
go (Int
off forall a. Num a => a -> a -> a
- Int
1) a
n
  where
    go :: Int -> t -> ST s Int
go !Int
o t
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
off forall a. Num a => a -> a -> a
- Int
1 forall a. Num a => a -> a -> a
- Int
o)
    go !Int
o t
m = do
      let nibble :: t
nibble = t
m forall a. Bits a => a -> a -> a
.&. t
0x0f
      forall s. MArray s -> Int -> Int -> ST s ()
writeNibbleAsHex MArray s
marr Int
o (forall a b. (Integral a, Num b) => a -> b
fromIntegral t
nibble)
      Int -> t -> ST s Int
go (Int
o forall a. Num a => a -> a -> a
- Int
1) (forall a. (Integral a, FiniteBits a) => a -> a
dropNibble t
m)
{-# INLINEABLE unsafePrependHex #-}

-- | The usual 'shiftR' performs sign extension on signed number types,
-- filling the top bits with 1 if the argument is negative.
-- We don't want this behaviour here.
--
-- It would suffice to clean the sign bit only once
-- instead of doing it on every iteration of unsafe{Ap,Pre}pernHex.go,
-- but the performance impact is likely negligible.
dropNibble ∷ (Integral a, FiniteBits a) ⇒ a → a
dropNibble :: forall a. (Integral a, FiniteBits a) => a -> a
dropNibble a
x = case (forall a. Bits a => a -> Bool
isSigned a
x, forall b. FiniteBits b => b -> Int
finiteBitSize a
x) of
  -- This is morally 'iShiftRL#', 'uncheckedIShiftRA64#', etc.,
  -- but there is no polymorphic interface to access them.
  (Bool
True, Int
8) → forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 (forall a. Bits a => a -> Int -> a
shiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x) Int
4)
  (Bool
True, Int
16) → forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 (forall a. Bits a => a -> Int -> a
shiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x) Int
4)
  (Bool
True, Int
32) → forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 (forall a. Bits a => a -> Int -> a
shiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x) Int
4)
  (Bool
True, Int
64) → forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word64 (forall a. Bits a => a -> Int -> a
shiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x) Int
4)
  (Bool
True, Int
_) → forall a. Bits a => a -> Int -> a
shiftR a
x Int
4 forall a. Bits a => a -> a -> a
.&. ((a
1 forall a. Bits a => a -> Int -> a
`shiftL` (forall b. FiniteBits b => b -> Int
finiteBitSize a
x forall a. Num a => a -> a -> a
- Int
4)) forall a. Num a => a -> a -> a
- a
1)
  (Bool, Int)
_ → forall a. Bits a => a -> Int -> a
shiftR a
x Int
4
{-# INLINE dropNibble #-}

-- | This assumes n /= 0. Round the number of nibbles up, as in 'maxHexLen'.
lengthAsHex ∷ FiniteBits a ⇒ a → Int
lengthAsHex :: forall b. FiniteBits b => b -> Int
lengthAsHex a
n = Int
1 forall a. Num a => a -> a -> a
+ forall a. Bits a => a -> Int -> a
shiftR (forall b. FiniteBits b => b -> Int
finiteBitSize a
n forall a. Num a => a -> a -> a
- forall b. FiniteBits b => b -> Int
countLeadingZeros a
n forall a. Num a => a -> a -> a
- Int
1) Int
2
{-# INLINEABLE lengthAsHex #-}

writeNibbleAsHex ∷ A.MArray s → Int → Int → ST s ()
writeNibbleAsHex :: forall s. MArray s -> Int -> Int -> ST s ()
writeNibbleAsHex MArray s
marr Int
off n :: Int
n@(I# Int#
n#) = forall s. MArray s -> Int -> Word8 -> ST s ()
A.unsafeWrite MArray s
marr Int
off (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hex)
  where
    hex :: Int
hex = Int
0x30 forall a. Num a => a -> a -> a
+ Int
n forall a. Num a => a -> a -> a
+ Int# -> Int
I# (Int#
n# Int# -> Int# -> Int#
># Int#
9#) forall a. Num a => a -> a -> a
* (Int
0x60 forall a. Num a => a -> a -> a
- Int
0x39)