module Data.ByteString.Builder.Fixed
( Builder
, fromByteString
, run
, contramapBuilder
, char8
, word8
, word8HexFixedLower
, word8HexFixedUpper
, word12HexFixedLower
, word12HexFixedUpper
) where
import Control.Monad.ST
import Data.Monoid
import Data.Word
import Data.Word.Synthetic (Word12)
import Data.Bits
import Data.Char (ord)
import Text.Printf
import Debug.Trace
import Data.ByteString.Internal (ByteString(..))
import Foreign
import Data.ByteString.Short (ShortByteString)
import System.IO.Unsafe
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Builder as BBuilder
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as LByteString
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Short.Internal as SBS
data Builder a where
BuilderStatic :: !ByteString -> Builder a
BuilderFunction :: !ByteString -> !(Int -> Ptr Word8 -> a -> IO ()) -> Builder a
instance Monoid (Builder a) where
mempty = BuilderStatic ByteString.empty
mappend x y = case x of
BuilderStatic t1@(PS _ _ len1) -> case y of
BuilderStatic t2 -> BuilderStatic (t1 <> t2)
BuilderFunction t2 f -> BuilderFunction (t1 <> t2) (\ix marr a -> f (ix + len1) marr a)
BuilderFunction t1@(PS _ _ len1) f1 -> case y of
BuilderStatic t2 -> BuilderFunction (t1 <> t2) f1
BuilderFunction t2 f2 -> BuilderFunction (t1 <> t2) (\ix marr a -> f1 ix marr a >> f2 (ix + len1) marr a)
contramapBuilder :: (b -> a) -> Builder a -> Builder b
contramapBuilder f x = case x of
BuilderStatic t -> BuilderStatic t
BuilderFunction t g -> BuilderFunction t (\ix marr b -> g ix marr (f b))
fromByteString :: ByteString -> Builder a
fromByteString = BuilderStatic
run :: Builder a -> a -> ByteString
run x a = case x of
BuilderStatic t -> t
BuilderFunction (PS inArr off len) f ->
BI.unsafeCreate len $ \ptr -> withForeignPtr inArr $ \inPtr -> do
copyArray ptr (advancePtr inPtr off) len
f 0 ptr a
word12HexFixedGeneral :: Bool -> Builder Word12
word12HexFixedGeneral upper = BuilderFunction (BC8.pack "---") $ \i marr w -> do
let !wInt = fromIntegral w
!ix = wInt + wInt + wInt
!arr = if upper then hexValuesWord12Upper else hexValuesWord12Lower
pokeByteOff marr i (SBS.unsafeIndex arr ix)
pokeByteOff marr (i + 1) (SBS.unsafeIndex arr (ix + 1))
pokeByteOff marr (i + 2) (SBS.unsafeIndex arr (ix + 2))
word12HexFixedUpper :: Builder Word12
word12HexFixedUpper = word12HexFixedGeneral True
word12HexFixedLower :: Builder Word12
word12HexFixedLower = word12HexFixedGeneral False
hexValuesWord12Upper :: ShortByteString
hexValuesWord12Upper =
SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03X") [0 :: Int ..4095]
hexValuesWord12Lower :: ShortByteString
hexValuesWord12Lower =
SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%03x") [0 :: Int ..4095]
word8HexFixedUpper :: Builder Word8
word8HexFixedUpper = word8HexFixedGeneral True
word8HexFixedLower :: Builder Word8
word8HexFixedLower = word8HexFixedGeneral False
word8HexFixedGeneral :: Bool -> Builder Word8
word8HexFixedGeneral upper = BuilderFunction (BC8.pack "--") $ \i marr w -> do
let !ix = unsafeShiftL (fromIntegral w) 1
!ix2 = ix + 1
!arr = if upper then hexValuesWord8Upper else hexValuesWord8Lower
pokeByteOff marr i (SBS.unsafeIndex arr ix)
pokeByteOff marr (i + 1) (SBS.unsafeIndex arr ix2)
hexValuesWord8Upper :: ShortByteString
hexValuesWord8Upper =
SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02X") [0 :: Int ..255]
hexValuesWord8Lower :: ShortByteString
hexValuesWord8Lower =
SBS.pack $ map (fromIntegral . ord) $ concat $ map (printf "%02x") [0 :: Int ..255]
char8 :: Builder Char
char8 = BuilderFunction (BC8.pack "-") $ \i marr c -> pokeByteOff marr i (c2w c)
word8 :: Builder Word8
word8 = BuilderFunction (BC8.pack "-") $ \i marr w -> pokeByteOff marr i w
word8At :: Int -> Word64 -> Word8
word8At i w = fromIntegral (unsafeShiftR w i)
c2w :: Char -> Word8
c2w = fromIntegral . ord