{-# LANGUAGE ScopedTypeVariables, CPP #-}
{-# LANGUAGE Unsafe #-}
{-# OPTIONS_HADDOCK not-home #-}
-- |
-- Copyright   : 2010-2011 Simon Meier, 2010 Jasper van der Jeugt
-- License     : BSD3-style (see LICENSE)
--
-- Maintainer  : Simon Meier <iridcode@gmail.com>
-- Stability   : unstable, private
-- Portability : GHC
--
-- *Warning:* this module is internal. If you find that you need it please
-- contact the maintainers and explain what you are trying to do and discuss
-- what you would need in the public API. It is important that you do this as
-- the module may not be exposed at all in future releases.
--
-- The maintainers are glad to accept patches for further
-- standard encodings of standard Haskell values.
--
-- If you need to write your own builder primitives, then be aware that you are
-- writing code with /all safety belts off/; i.e.,
-- *this is the code that might make your application vulnerable to buffer-overflow attacks!*
-- The "Data.ByteString.Builder.Prim.Tests" module provides you with
-- utilities for testing your encodings thoroughly.
--
module Data.ByteString.Builder.Prim.Internal (
  -- * Fixed-size builder primitives
    Size
  , FixedPrim
  , fixedPrim
  , size
  , runF

  , emptyF
  , contramapF
  , pairF
  -- , liftIOF

  , storableToF

  -- * Bounded-size builder primitives
  , BoundedPrim
  , boundedPrim
  , sizeBound
  , runB

  , emptyB
  , contramapB
  , pairB
  , eitherB
  , condB

  -- , liftIOB

  , toB
  , liftFixedToBounded

  -- , withSizeFB
  -- , withSizeBB

  -- * Shared operators
  , (>$<)
  , (>*<)

  -- * Helpers
  , caseWordSize_32_64

  -- * Deprecated
  , boudedPrim
  ) where

import Foreign
import Prelude hiding (maxBound)

#include "MachDeps.h"

------------------------------------------------------------------------------
-- Supporting infrastructure
------------------------------------------------------------------------------

-- | Contravariant functors as in the @contravariant@ package.
class Contravariant f where
    contramap :: (b -> a) -> f a -> f b

infixl 4 >$<

-- | A fmap-like operator for builder primitives, both bounded and fixed size.
--
-- Builder primitives are contravariant so it's like the normal fmap, but
-- backwards (look at the type). (If it helps to remember, the operator symbol
-- is like (<$>) but backwards.)
--
-- We can use it for example to prepend and/or append fixed values to an
-- primitive.
--
-- > import Data.ByteString.Builder.Prim as P
-- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'"
-- >  where
-- >    fixed3 = P.char7 >*< P.char7 >*< P.char7
--
-- Note that the rather verbose syntax for composition stems from the
-- requirement to be able to compute the size / size bound at compile time.
--
(>$<) :: Contravariant f => (b -> a) -> f a -> f b
>$< :: forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
(>$<) = (b -> a) -> f a -> f b
forall (f :: * -> *) b a. Contravariant f => (b -> a) -> f a -> f b
contramap


instance Contravariant FixedPrim where
    contramap :: forall b a. (b -> a) -> FixedPrim a -> FixedPrim b
contramap = (b -> a) -> FixedPrim a -> FixedPrim b
forall b a. (b -> a) -> FixedPrim a -> FixedPrim b
contramapF

instance Contravariant BoundedPrim where
    contramap :: forall b a. (b -> a) -> BoundedPrim a -> BoundedPrim b
contramap = (b -> a) -> BoundedPrim a -> BoundedPrim b
forall b a. (b -> a) -> BoundedPrim a -> BoundedPrim b
contramapB


-- | Type-constructors supporting lifting of type-products.
class Monoidal f where
    pair :: f a -> f b -> f (a, b)

instance Monoidal FixedPrim where
    pair :: forall a b. FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
pair = FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
forall a b. FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
pairF

instance Monoidal BoundedPrim where
    pair :: forall a b. BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
pair = BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
forall a b. BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
pairB

infixr 5 >*<

-- | A pairing/concatenation operator for builder primitives, both bounded and
-- fixed size.
--
-- For example,
--
-- > toLazyByteString (primFixed (char7 >*< char7) ('x','y')) = "xy"
--
-- We can combine multiple primitives using '>*<' multiple times.
--
-- > toLazyByteString (primFixed (char7 >*< char7 >*< char7) ('x',('y','z'))) = "xyz"
--
(>*<) :: Monoidal f => f a -> f b -> f (a, b)
>*< :: forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
(>*<) = f a -> f b -> f (a, b)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
pair


-- | The type used for sizes and sizeBounds of sizes.
type Size = Int


------------------------------------------------------------------------------
-- Fixed-size builder primitives
------------------------------------------------------------------------------

-- | A builder primitive that always results in a sequence of bytes of a
-- pre-determined, fixed size.
data FixedPrim a = FP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO ())

fixedPrim :: Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim :: forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
fixedPrim = Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
FP

-- | The size of the sequences of bytes generated by this 'FixedPrim'.
{-# INLINE CONLIKE size #-}
size :: FixedPrim a -> Int
size :: forall a. FixedPrim a -> Int
size (FP Int
l a -> Ptr Word8 -> IO ()
_) = Int
l

{-# INLINE CONLIKE runF #-}
runF :: FixedPrim a -> a -> Ptr Word8 -> IO ()
runF :: forall a. FixedPrim a -> a -> Ptr Word8 -> IO ()
runF (FP Int
_ a -> Ptr Word8 -> IO ()
io) = a -> Ptr Word8 -> IO ()
io

-- | The 'FixedPrim' that always results in the zero-length sequence.
{-# INLINE CONLIKE emptyF #-}
emptyF :: FixedPrim a
emptyF :: forall a. FixedPrim a
emptyF = Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
FP Int
0 (\a
_ Ptr Word8
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | Encode a pair by encoding its first component and then its second component.
{-# INLINE CONLIKE pairF #-}
pairF :: FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
pairF :: forall a b. FixedPrim a -> FixedPrim b -> FixedPrim (a, b)
pairF (FP Int
l1 a -> Ptr Word8 -> IO ()
io1) (FP Int
l2 b -> Ptr Word8 -> IO ()
io2) =
    Int -> ((a, b) -> Ptr Word8 -> IO ()) -> FixedPrim (a, b)
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
FP (Int
l1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l2) (\(a
x1,b
x2) Ptr Word8
op -> a -> Ptr Word8 -> IO ()
io1 a
x1 Ptr Word8
op IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Ptr Word8 -> IO ()
io2 b
x2 (Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
l1))

-- | Change a primitives such that it first applies a function to the value
-- to be encoded.
--
-- Note that primitives are 'Contravariant'
-- <http://hackage.haskell.org/package/contravariant>. Hence, the following
-- laws hold.
--
-- >contramapF id = id
-- >contramapF f . contramapF g = contramapF (g . f)
{-# INLINE CONLIKE contramapF #-}
contramapF :: (b -> a) -> FixedPrim a -> FixedPrim b
contramapF :: forall b a. (b -> a) -> FixedPrim a -> FixedPrim b
contramapF b -> a
f (FP Int
l a -> Ptr Word8 -> IO ()
io) = Int -> (b -> Ptr Word8 -> IO ()) -> FixedPrim b
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
FP Int
l (a -> Ptr Word8 -> IO ()
io (a -> Ptr Word8 -> IO ()) -> (b -> a) -> b -> Ptr Word8 -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f)

-- | Convert a 'FixedPrim' to a 'BoundedPrim'.
{-# INLINE CONLIKE toB #-}
toB :: FixedPrim a -> BoundedPrim a
toB :: forall a. FixedPrim a -> BoundedPrim a
toB (FP Int
l a -> Ptr Word8 -> IO ()
io) = Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP Int
l (\a
x Ptr Word8
op -> a -> Ptr Word8 -> IO ()
io a
x Ptr Word8
op IO () -> IO (Ptr Word8) -> IO (Ptr Word8)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr Word8 -> IO (Ptr Word8)) -> Ptr Word8 -> IO (Ptr Word8)
forall a b. (a -> b) -> a -> b
$! Ptr Word8
op Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
l))

-- | Lift a 'FixedPrim' to a 'BoundedPrim'.
{-# INLINE CONLIKE liftFixedToBounded #-}
liftFixedToBounded :: FixedPrim a -> BoundedPrim a
liftFixedToBounded :: forall a. FixedPrim a -> BoundedPrim a
liftFixedToBounded = FixedPrim a -> BoundedPrim a
forall a. FixedPrim a -> BoundedPrim a
toB

{-# INLINE CONLIKE storableToF #-}
storableToF :: forall a. Storable a => FixedPrim a
-- Not all architectures are forgiving of unaligned accesses; whitelist ones
-- which are known not to trap (either to the kernel for emulation, or crash).
#if defined(i386_HOST_ARCH) || defined(x86_64_HOST_ARCH) \
    || ((defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)) \
        && defined(__ARM_FEATURE_UNALIGNED)) \
    || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) \
    || defined(powerpc64le_HOST_ARCH)
storableToF :: forall a. Storable a => FixedPrim a
storableToF = Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
forall a. Int -> (a -> Ptr Word8 -> IO ()) -> FixedPrim a
FP (a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a)) (\a
x Ptr Word8
op -> Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8 -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
op) a
x)
#else
storableToF = FP (sizeOf (undefined :: a)) $ \x op ->
    if ptrToWordPtr op `mod` fromIntegral (alignment (undefined :: a)) == 0 then poke (castPtr op) x
    else with x $ \tp -> copyBytes op (castPtr tp) (sizeOf (undefined :: a))
#endif

{-
{-# INLINE CONLIKE liftIOF #-}
liftIOF :: FixedPrim a -> FixedPrim (IO a)
liftIOF (FP l io) = FP l (\xWrapped op -> do x <- xWrapped; io x op)
-}

------------------------------------------------------------------------------
-- Bounded-size builder primitives
------------------------------------------------------------------------------

-- | A builder primitive that always results in sequence of bytes that is no longer
-- than a pre-determined bound.
data BoundedPrim a = BP {-# UNPACK #-} !Int (a -> Ptr Word8 -> IO (Ptr Word8))

-- | The bound on the size of sequences of bytes generated by this 'BoundedPrim'.
{-# INLINE CONLIKE sizeBound #-}
sizeBound :: BoundedPrim a -> Int
sizeBound :: forall a. BoundedPrim a -> Int
sizeBound (BP Int
b a -> Ptr Word8 -> IO (Ptr Word8)
_) = Int
b

-- | @since 0.10.12.0
boundedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boundedPrim :: forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boundedPrim = Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP

{-# DEPRECATED boudedPrim "Use 'boundedPrim' instead" #-}
boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boudedPrim :: forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
boudedPrim = Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP

{-# INLINE CONLIKE runB #-}
runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
runB :: forall a. BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
runB (BP Int
_ a -> Ptr Word8 -> IO (Ptr Word8)
io) = a -> Ptr Word8 -> IO (Ptr Word8)
io

-- | Change a 'BoundedPrim' such that it first applies a function to the
-- value to be encoded.
--
-- Note that 'BoundedPrim's are 'Contravariant'
-- <http://hackage.haskell.org/package/contravariant>. Hence, the following
-- laws hold.
--
-- >contramapB id = id
-- >contramapB f . contramapB g = contramapB (g . f)
{-# INLINE CONLIKE contramapB #-}
contramapB :: (b -> a) -> BoundedPrim a -> BoundedPrim b
contramapB :: forall b a. (b -> a) -> BoundedPrim a -> BoundedPrim b
contramapB b -> a
f (BP Int
b a -> Ptr Word8 -> IO (Ptr Word8)
io) = Int -> (b -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim b
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP Int
b (a -> Ptr Word8 -> IO (Ptr Word8)
io (a -> Ptr Word8 -> IO (Ptr Word8))
-> (b -> a) -> b -> Ptr Word8 -> IO (Ptr Word8)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f)

-- | The 'BoundedPrim' that always results in the zero-length sequence.
{-# INLINE CONLIKE emptyB #-}
emptyB :: BoundedPrim a
emptyB :: forall a. BoundedPrim a
emptyB = Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP Int
0 (\a
_ Ptr Word8
op -> Ptr Word8 -> IO (Ptr Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr Word8
op)

-- | Encode a pair by encoding its first component and then its second component.
{-# INLINE CONLIKE pairB #-}
pairB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
pairB :: forall a b. BoundedPrim a -> BoundedPrim b -> BoundedPrim (a, b)
pairB (BP Int
b1 a -> Ptr Word8 -> IO (Ptr Word8)
io1) (BP Int
b2 b -> Ptr Word8 -> IO (Ptr Word8)
io2) =
    Int
-> ((a, b) -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim (a, b)
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP (Int
b1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b2) (\(a
x1,b
x2) Ptr Word8
op -> a -> Ptr Word8 -> IO (Ptr Word8)
io1 a
x1 Ptr Word8
op IO (Ptr Word8) -> (Ptr Word8 -> IO (Ptr Word8)) -> IO (Ptr Word8)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> Ptr Word8 -> IO (Ptr Word8)
io2 b
x2)

-- | Encode an 'Either' value using the first 'BoundedPrim' for 'Left'
-- values and the second 'BoundedPrim' for 'Right' values.
--
-- Note that the functions 'eitherB', 'pairB', and 'contramapB' (written below
-- using '>$<') suffice to construct 'BoundedPrim's for all non-recursive
-- algebraic datatypes. For example,
--
-- @
--maybeB :: BoundedPrim () -> BoundedPrim a -> BoundedPrim (Maybe a)
--maybeB nothing just = 'maybe' (Left ()) Right '>$<' eitherB nothing just
-- @
{-# INLINE CONLIKE eitherB #-}
eitherB :: BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b)
eitherB :: forall a b.
BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b)
eitherB (BP Int
b1 a -> Ptr Word8 -> IO (Ptr Word8)
io1) (BP Int
b2 b -> Ptr Word8 -> IO (Ptr Word8)
io2) =
    Int
-> (Either a b -> Ptr Word8 -> IO (Ptr Word8))
-> BoundedPrim (Either a b)
forall a.
Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
BP (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
b1 Int
b2)
        (\Either a b
x Ptr Word8
op -> case Either a b
x of Left a
x1 -> a -> Ptr Word8 -> IO (Ptr Word8)
io1 a
x1 Ptr Word8
op; Right b
x2 -> b -> Ptr Word8 -> IO (Ptr Word8)
io2 b
x2 Ptr Word8
op)

-- | Conditionally select a 'BoundedPrim'.
-- For example, we can implement the ASCII primitive that drops characters with
-- Unicode codepoints above 127 as follows.
--
-- @
--charASCIIDrop = 'condB' (< \'\\128\') ('liftFixedToBounded' 'Data.ByteString.Builder.Prim.char7') 'emptyB'
-- @
{-# INLINE CONLIKE condB #-}
condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB :: forall a.
(a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
condB a -> Bool
p BoundedPrim a
be1 BoundedPrim a
be2 =
    (a -> Either a a) -> BoundedPrim (Either a a) -> BoundedPrim a
forall b a. (b -> a) -> BoundedPrim a -> BoundedPrim b
contramapB (\a
x -> if a -> Bool
p a
x then a -> Either a a
forall a b. a -> Either a b
Left a
x else a -> Either a a
forall a b. b -> Either a b
Right a
x) (BoundedPrim a -> BoundedPrim a -> BoundedPrim (Either a a)
forall a b.
BoundedPrim a -> BoundedPrim b -> BoundedPrim (Either a b)
eitherB BoundedPrim a
be1 BoundedPrim a
be2)

-- | Select an implementation depending on bitness.
-- Throw a compile time error if bitness is neither 32 nor 64.
{-# INLINE caseWordSize_32_64 #-}
caseWordSize_32_64
  :: a -- Value for 32-bit architecture
  -> a -- Value for 64-bit architecture
  -> a
#if WORD_SIZE_IN_BITS == 32
caseWordSize_32_64 = const
#endif
#if WORD_SIZE_IN_BITS == 64
caseWordSize_32_64 :: forall a. a -> a -> a
caseWordSize_32_64 = (a -> a) -> a -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id
#endif