content: {-# LANGUAGE ScopedTypeVariables, CPP, BangPatterns #-}
  #if __GLASGOW_HASKELL__ >= 703
  {-# LANGUAGE Unsafe #-}
  #endif
  {-# 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 saftey 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
    , boudedPrim
    , sizeBound
    , runB
  
    , emptyB
    , contramapB
    , pairB
    , eitherB
    , condB
  
    -- , liftIOB
  
    , toB
    , liftFixedToBounded
  
    -- , withSizeFB
    -- , withSizeBB
  
    -- * Shared operators
    , (>$<)
    , (>*<)
  
    ) where
  
  import Foreign
  import Prelude hiding (maxBound)
  
  #if !(__GLASGOW_HASKELL__ >= 612)
  -- ghc-6.10 and older do not support {-# INLINE CONLIKE #-}
  #define CONLIKE
  #endif
  
  ------------------------------------------------------------------------------
  -- 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.
  --
  -- >showEncoding ((\x -> ('\'', (x, '\''))) >$< fixed3) 'x' = "'x'"
  -- >  where
  -- >    fixed3 = char7 >*< char7 >*< 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
  (>$<) = contramap
  
  
  instance Contravariant FixedPrim where
      contramap = contramapF
  
  instance Contravariant BoundedPrim where
      contramap = 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 = pairF
  
  instance Monoidal BoundedPrim where
      pair = 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)
  (>*<) = 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 = FP
  
  -- | The size of the sequences of bytes generated by this 'FixedPrim'.
  {-# INLINE CONLIKE size #-}
  size :: FixedPrim a -> Int
  size (FP l _) = l
  
  {-# INLINE CONLIKE runF #-}
  runF :: FixedPrim a -> a -> Ptr Word8 -> IO ()
  runF (FP _ io) = io
  
  -- | The 'FixedPrim' that always results in the zero-length sequence.
  {-# INLINE CONLIKE emptyF #-}
  emptyF :: FixedPrim a
  emptyF = FP 0 (\_ _ -> 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 (FP l1 io1) (FP l2 io2) =
      FP (l1 + l2) (\(x1,x2) op -> io1 x1 op >> io2 x2 (op `plusPtr` l1))
  
  -- | Change a primitives such that it first applies a function to the value
  -- to be encoded.
  --
  -- Note that primitives are 'Contrafunctors'
  -- <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 f (FP l io) = FP l (\x op -> io (f x) op)
  
  -- | Convert a 'FixedPrim' to a 'BoundedPrim'.
  {-# INLINE CONLIKE toB #-}
  toB :: FixedPrim a -> BoundedPrim a
  toB (FP l io) = BP l (\x op -> io x op >> (return $! op `plusPtr` l))
  
  -- | Lift a 'FixedPrim' to a 'BoundedPrim'.
  {-# INLINE CONLIKE liftFixedToBounded #-}
  liftFixedToBounded :: FixedPrim a -> BoundedPrim a
  liftFixedToBounded = toB
  
  {-# INLINE CONLIKE storableToF #-}
  storableToF :: forall a. Storable a => FixedPrim a
  storableToF = FP (sizeOf (undefined :: a)) (\x op -> poke (castPtr op) x)
  
  {-
  {-# 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 (BP b _) = b
  
  boudedPrim :: Int -> (a -> Ptr Word8 -> IO (Ptr Word8)) -> BoundedPrim a
  boudedPrim = BP
  
  {-# INLINE CONLIKE runB #-}
  runB :: BoundedPrim a -> a -> Ptr Word8 -> IO (Ptr Word8)
  runB (BP _ io) = io
  
  -- | Change a 'BoundedPrim' such that it first applies a function to the
  -- value to be encoded.
  --
  -- Note that 'BoundedPrim's are 'Contrafunctors'
  -- <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 f (BP b io) = BP b (\x op -> io (f x) op)
  
  -- | The 'BoundedPrim' that always results in the zero-length sequence.
  {-# INLINE CONLIKE emptyB #-}
  emptyB :: BoundedPrim a
  emptyB = BP 0 (\_ op -> return 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 (BP b1 io1) (BP b2 io2) =
      BP (b1 + b2) (\(x1,x2) op -> io1 x1 op >>= io2 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 (BP b1 io1) (BP b2 io2) =
      BP (max b1 b2)
          (\x op -> case x of Left x1 -> io1 x1 op; Right x2 -> io2 x2 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\') ('fromF' 'char7') 'emptyB'
  -- @
  {-# INLINE CONLIKE condB #-}
  condB :: (a -> Bool) -> BoundedPrim a -> BoundedPrim a -> BoundedPrim a
  condB p be1 be2 =
      contramapB (\x -> if p x then Left x else Right x) (eitherB be1 be2)
  