{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -Wall -funbox-strict-fields #-}

{-| For concatenating fixed-width strings that are only a few
    characters each, this can be six times faster than the builder
    that ships with @bytestring@.
-}
module Data.ByteString.Builder.Fixed
  ( Builder
  , fromByteString
  , run
  , contramapBuilder
  , char8
  , word8
  , word8HexFixedLower
  , word8HexFixedUpper
  , word12HexFixedLower
  , word12HexFixedUpper
  ) where

#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import Data.Word
import Data.Word.Synthetic.Word12 (Word12)
import Data.Bits
import Data.Char (ord)
import Text.Printf
import Data.ByteString.Internal (ByteString(..))
import Foreign
import Data.ByteString.Short (ShortByteString)

import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Short.Internal as SBS
import qualified Data.Primitive as PM
import qualified Data.Semigroup as Semigroup

data Builder a where
  BuilderStatic :: !ByteString -> Builder a
  BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a

{-# INLINE appendBuilder #-}
appendBuilder :: Builder a -> Builder a -> Builder a
appendBuilder :: forall a. Builder a -> Builder a -> Builder a
appendBuilder Builder a
x Builder a
y = case Builder a
x of
  BuilderStatic t1 :: ByteString
t1@(PS ForeignPtr Word8
_ Int
_ Int
len1) -> case Builder a
y of
    BuilderStatic ByteString
t2 -> forall a. ByteString -> Builder a
BuilderStatic (ByteString
t1 forall a. Semigroup a => a -> a -> a
<> ByteString
t2)
    BuilderFunction ByteString
t2 Int -> Ptr Word8 -> a -> IO ()
f -> forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction (ByteString
t1 forall a. Semigroup a => a -> a -> a
<> ByteString
t2) (\Int
ix Ptr Word8
marr a
a -> Int -> Ptr Word8 -> a -> IO ()
f (Int
ix forall a. Num a => a -> a -> a
+ Int
len1) Ptr Word8
marr a
a)
  BuilderFunction t1 :: ByteString
t1@(PS ForeignPtr Word8
_ Int
_ Int
len1) Int -> Ptr Word8 -> a -> IO ()
f1 -> case Builder a
y of
    BuilderStatic ByteString
t2 -> forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction (ByteString
t1 forall a. Semigroup a => a -> a -> a
<> ByteString
t2) Int -> Ptr Word8 -> a -> IO ()
f1
    BuilderFunction ByteString
t2 Int -> Ptr Word8 -> a -> IO ()
f2 -> forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction (ByteString
t1 forall a. Semigroup a => a -> a -> a
<> ByteString
t2) (\Int
ix Ptr Word8
marr a
a -> Int -> Ptr Word8 -> a -> IO ()
f1 Int
ix Ptr Word8
marr a
a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Ptr Word8 -> a -> IO ()
f2 (Int
ix forall a. Num a => a -> a -> a
+ Int
len1) Ptr Word8
marr a
a)

instance Semigroup.Semigroup (Builder a) where
  {-# INLINE (<>) #-}
  <> :: Builder a -> Builder a -> Builder a
(<>) = forall a. Builder a -> Builder a -> Builder a
appendBuilder

instance Monoid (Builder a) where
  {-# INLINE mempty #-}
  mempty :: Builder a
mempty = forall a. ByteString -> Builder a
BuilderStatic ByteString
ByteString.empty
  {-# INLINE mappend #-}
  mappend :: Builder a -> Builder a -> Builder a
mappend = forall a. Semigroup a => a -> a -> a
(Semigroup.<>)

contramapBuilder :: (b -> a) -> Builder a -> Builder b
contramapBuilder :: forall b a. (b -> a) -> Builder a -> Builder b
contramapBuilder b -> a
f Builder a
x = case Builder a
x of
  BuilderStatic ByteString
t -> forall a. ByteString -> Builder a
BuilderStatic ByteString
t
  BuilderFunction ByteString
t Int -> Ptr Word8 -> a -> IO ()
g -> forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction ByteString
t (\Int
ix Ptr Word8
marr b
b -> Int -> Ptr Word8 -> a -> IO ()
g Int
ix Ptr Word8
marr (b -> a
f b
b))
{-# INLINE contramapBuilder #-}

fromByteString :: ByteString -> Builder a
fromByteString :: forall a. ByteString -> Builder a
fromByteString = forall a. ByteString -> Builder a
BuilderStatic
{-# INLINE fromByteString #-}

unsafeIndexShortByteString :: ShortByteString -> Int -> Word8
unsafeIndexShortByteString :: ShortByteString -> Int -> Word8
unsafeIndexShortByteString (SBS.SBS ByteArray#
x) Int
i = forall a. Prim a => ByteArray -> Int -> a
PM.indexByteArray (ByteArray# -> ByteArray
PM.ByteArray ByteArray#
x) Int
i
{-# INLINE unsafeIndexShortByteString #-}

run :: Builder a -> a -> ByteString
run :: forall a. Builder a -> a -> ByteString
run Builder a
x a
a = case Builder a
x of
  BuilderStatic ByteString
t -> ByteString
t
  BuilderFunction (PS ForeignPtr Word8
inArr Int
off Int
len) Int -> Ptr Word8 -> a -> IO ()
f ->
    Int -> (Ptr Word8 -> IO ()) -> ByteString
BI.unsafeCreate Int
len forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
inArr forall a b. (a -> b) -> a -> b
$ \Ptr Word8
inPtr -> do
      forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray Ptr Word8
ptr (forall a. Storable a => Ptr a -> Int -> Ptr a
advancePtr Ptr Word8
inPtr Int
off) Int
len
      Int -> Ptr Word8 -> a -> IO ()
f Int
0 Ptr Word8
ptr a
a

word12HexFixedGeneral :: Bool -> Builder Word12
word12HexFixedGeneral :: Bool -> Builder Word12
word12HexFixedGeneral Bool
upper = forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction ([Char] -> ByteString
BC8.pack [Char]
"---") forall a b. (a -> b) -> a -> b
$ \Int
i Ptr Word8
marr Word12
w -> do
  let !wInt :: Int
wInt = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word12
w
      !ix :: Int
ix = Int
wInt forall a. Num a => a -> a -> a
+ Int
wInt forall a. Num a => a -> a -> a
+ Int
wInt
      !arr :: ShortByteString
arr = if Bool
upper then ShortByteString
hexValuesWord12Upper else ShortByteString
hexValuesWord12Lower
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr Int
i (ShortByteString -> Int -> Word8
unsafeIndexShortByteString ShortByteString
arr Int
ix)
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr (Int
i forall a. Num a => a -> a -> a
+ Int
1) (ShortByteString -> Int -> Word8
unsafeIndexShortByteString ShortByteString
arr (Int
ix forall a. Num a => a -> a -> a
+ Int
1))
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr (Int
i forall a. Num a => a -> a -> a
+ Int
2) (ShortByteString -> Int -> Word8
unsafeIndexShortByteString ShortByteString
arr (Int
ix forall a. Num a => a -> a -> a
+ Int
2))
{-# INLINE word12HexFixedGeneral #-}

word12HexFixedUpper :: Builder Word12
word12HexFixedUpper :: Builder Word12
word12HexFixedUpper = Bool -> Builder Word12
word12HexFixedGeneral Bool
True
{-# INLINE word12HexFixedUpper #-}

word12HexFixedLower :: Builder Word12
word12HexFixedLower :: Builder Word12
word12HexFixedLower = Bool -> Builder Word12
word12HexFixedGeneral Bool
False
{-# INLINE word12HexFixedLower #-}

hexValuesWord12Upper :: ShortByteString
hexValuesWord12Upper :: ShortByteString
hexValuesWord12Upper =
  [Word8] -> ShortByteString
SBS.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall r. PrintfType r => [Char] -> r
printf [Char]
"%03X") [Int
0 :: Int ..Int
4095]
{-# NOINLINE hexValuesWord12Upper #-}

hexValuesWord12Lower :: ShortByteString
hexValuesWord12Lower :: ShortByteString
hexValuesWord12Lower =
  [Word8] -> ShortByteString
SBS.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall r. PrintfType r => [Char] -> r
printf [Char]
"%03x") [Int
0 :: Int ..Int
4095]
{-# NOINLINE hexValuesWord12Lower #-}

word8HexFixedUpper :: Builder Word8
word8HexFixedUpper :: Builder Word8
word8HexFixedUpper = Bool -> Builder Word8
word8HexFixedGeneral Bool
True
{-# INLINE word8HexFixedUpper #-}

word8HexFixedLower :: Builder Word8
word8HexFixedLower :: Builder Word8
word8HexFixedLower = Bool -> Builder Word8
word8HexFixedGeneral Bool
False
{-# INLINE word8HexFixedLower #-}

-- The Bool is True if the hex digits are upper case.
word8HexFixedGeneral :: Bool -> Builder Word8
word8HexFixedGeneral :: Bool -> Builder Word8
word8HexFixedGeneral Bool
upper = forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction ([Char] -> ByteString
BC8.pack [Char]
"--") forall a b. (a -> b) -> a -> b
$ \Int
i Ptr Word8
marr Word8
w -> do
  let !ix :: Int
ix = forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w) Int
1
      !ix2 :: Int
ix2 = Int
ix forall a. Num a => a -> a -> a
+ Int
1
      !arr :: ShortByteString
arr = if Bool
upper then ShortByteString
hexValuesWord8Upper else ShortByteString
hexValuesWord8Lower
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr Int
i (ShortByteString -> Int -> Word8
unsafeIndexShortByteString ShortByteString
arr Int
ix)
  forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr (Int
i forall a. Num a => a -> a -> a
+ Int
1) (ShortByteString -> Int -> Word8
unsafeIndexShortByteString ShortByteString
arr Int
ix2)
{-# INLINE word8HexFixedGeneral #-}

hexValuesWord8Upper :: ShortByteString
hexValuesWord8Upper :: ShortByteString
hexValuesWord8Upper =
  [Word8] -> ShortByteString
SBS.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall r. PrintfType r => [Char] -> r
printf [Char]
"%02X") [Int
0 :: Int ..Int
255]
{-# NOINLINE hexValuesWord8Upper #-}

hexValuesWord8Lower :: ShortByteString
hexValuesWord8Lower :: ShortByteString
hexValuesWord8Lower =
  [Word8] -> ShortByteString
SBS.pack forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall r. PrintfType r => [Char] -> r
printf [Char]
"%02x") [Int
0 :: Int ..Int
255]
{-# NOINLINE hexValuesWord8Lower #-}

char8 :: Builder Char
char8 :: Builder Char
char8 = forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction ([Char] -> ByteString
BC8.pack [Char]
"-") forall a b. (a -> b) -> a -> b
$ \Int
i Ptr Word8
marr Char
c -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr Int
i (Char -> Word8
c2w Char
c)
{-# INLINE char8 #-}

word8 :: Builder Word8
word8 :: Builder Word8
word8 = forall a.
ByteString -> (Int -> Ptr Word8 -> a -> IO ()) -> Builder a
BuilderFunction ([Char] -> ByteString
BC8.pack [Char]
"-") forall a b. (a -> b) -> a -> b
$ \Int
i Ptr Word8
marr Word8
w -> forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Word8
marr Int
i Word8
w
{-# INLINE word8 #-}

-- | Taken from @Data.ByteString.Internal@. The same warnings
--   apply here.
c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
{-# INLINE c2w #-}

-- macBuilder :: Builder Word64
-- macBuilder =
--      contramapBuilder (word8At 40) twoDigitWord8Hex
--   <> BuilderStatic ":"
--   <> contramapBuilder (word8At 32) twoDigitWord8Hex
--   <> BuilderStatic ":"
--   <> contramapBuilder (word8At 24) twoDigitWord8Hex
--   <> BuilderStatic ":"
--   <> contramapBuilder (word8At 16) twoDigitWord8Hex
--   <> BuilderStatic ":"
--   <> contramapBuilder (word8At 8) twoDigitWord8Hex
--   <> BuilderStatic ":"
--   <> contramapBuilder (word8At 0) twoDigitWord8Hex