{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
module Data.Aeson.Internal.ByteString (
    mkBS, 
    withBS,
    liftSBS,
) where

import Data.ByteString.Internal (ByteString (..))
import Data.Word (Word8)
import Foreign.ForeignPtr (ForeignPtr)
import Data.ByteString.Short (ShortByteString, fromShort)
import GHC.Exts (Addr#, Ptr (Ptr))
import Data.ByteString.Short.Internal (createFromPtr)
import System.IO.Unsafe (unsafeDupablePerformIO)

import qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Syntax as TH

#if !MIN_VERSION_bytestring(0,11,0)
#if MIN_VERSION_base(4,10,0)
import GHC.ForeignPtr (plusForeignPtr)
#else
import GHC.ForeignPtr (ForeignPtr(ForeignPtr))
import GHC.Types (Int (..))
import GHC.Prim (plusAddr#)
#endif
#endif

#if !MIN_VERSION_template_haskell(2,16,0)
import qualified Data.ByteString as BS
#endif

mkBS :: ForeignPtr Word8 -> Int -> ByteString
#if MIN_VERSION_bytestring(0,11,0)
mkBS :: ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n = ForeignPtr Word8 -> Int -> ByteString
BS ForeignPtr Word8
dfp Int
n
#else
mkBS dfp n = PS dfp 0 n
#endif
{-# INLINE mkBS #-}

withBS :: ByteString -> (ForeignPtr Word8 -> Int -> r) -> r
#if MIN_VERSION_bytestring(0,11,0)
withBS :: forall r. ByteString -> (ForeignPtr Word8 -> Int -> r) -> r
withBS (BS !ForeignPtr Word8
sfp !Int
slen)       ForeignPtr Word8 -> Int -> r
kont = ForeignPtr Word8 -> Int -> r
kont ForeignPtr Word8
sfp Int
slen
#else
withBS (PS !sfp !soff !slen) kont = kont (plusForeignPtr sfp soff) slen
#endif
{-# INLINE withBS #-}

#if !MIN_VERSION_bytestring(0,11,0)
#if !MIN_VERSION_base(4,10,0)
-- |Advances the given address by the given offset in bytes.
--
-- The new 'ForeignPtr' shares the finalizer of the original,
-- equivalent from a finalization standpoint to just creating another
-- reference to the original. That is, the finalizer will not be
-- called before the new 'ForeignPtr' is unreachable, nor will it be
-- called an additional time due to this call, and the finalizer will
-- be called with the same address that it would have had this call
-- not happened, *not* the new address.
plusForeignPtr :: ForeignPtr a -> Int -> ForeignPtr b
plusForeignPtr (ForeignPtr addr guts) (I# offset) = ForeignPtr (plusAddr# addr offset) guts
{-# INLINE [0] plusForeignPtr #-}
{-# RULES "ByteString plusForeignPtr/0" forall fp .  plusForeignPtr fp 0 = fp #-}
#endif
#endif

liftSBS :: ShortByteString -> TH.ExpQ
#if MIN_VERSION_template_haskell(2,16,0)
liftSBS :: ShortByteString -> ExpQ
liftSBS ShortByteString
sbs = ByteString -> (ForeignPtr Word8 -> Int -> ExpQ) -> ExpQ
forall r. ByteString -> (ForeignPtr Word8 -> Int -> r) -> r
withBS ByteString
bs ((ForeignPtr Word8 -> Int -> ExpQ) -> ExpQ)
-> (ForeignPtr Word8 -> Int -> ExpQ) -> ExpQ
forall a b. (a -> b) -> a -> b
$ \ForeignPtr Word8
ptr Int
len -> [| unsafePackLenLiteral |]
    ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
TH.litE (Integer -> Lit
TH.integerL (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))
    ExpQ -> ExpQ -> ExpQ
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`TH.appE` Lit -> ExpQ
forall (m :: * -> *). Quote m => Lit -> m Exp
TH.litE (Bytes -> Lit
TH.BytesPrimL (Bytes -> Lit) -> Bytes -> Lit
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Word -> Word -> Bytes
TH.Bytes ForeignPtr Word8
ptr Word
0 (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len))
    where
      bs :: ByteString
bs = ShortByteString -> ByteString
fromShort ShortByteString
sbs
#else
liftSBS sbs = withBS bs $ \_ len -> [| unsafePackLenLiteral |]
    `TH.appE` TH.litE (TH.integerL (fromIntegral len))
    `TH.appE` TH.litE (TH.StringPrimL $ BS.unpack bs)
    where
      bs = fromShort sbs
#endif

-- this is copied verbatim from @bytestring@, but only in recent versions.
unsafePackLenLiteral :: Int -> Addr# -> ShortByteString
unsafePackLenLiteral :: Int -> Addr# -> ShortByteString
unsafePackLenLiteral Int
len Addr#
addr# =
    IO ShortByteString -> ShortByteString
forall a. IO a -> a
unsafeDupablePerformIO (IO ShortByteString -> ShortByteString)
-> IO ShortByteString -> ShortByteString
forall a b. (a -> b) -> a -> b
$ Ptr Any -> Int -> IO ShortByteString
forall a. Ptr a -> Int -> IO ShortByteString
createFromPtr (Addr# -> Ptr Any
forall a. Addr# -> Ptr a
Ptr Addr#
addr#) Int
len