{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE UnboxedTuples       #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Codec.CBOR.ByteArray.Internal
-- Copyright   : (c) Ben Gamari 2017-2018
-- License     : BSD3-style (see LICENSE.txt)
--
-- Maintainer  : duncan@community.haskell.org
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- Various bytearray utilities
--
module Codec.CBOR.ByteArray.Internal
  ( foldrByteArray
  , copyToAddr
  , isTrue#
  , sameByteArray
  , mkByteArray
  , isByteArrayPinned
  , touch
  ) where

import Control.Monad.ST
import Control.Monad
import GHC.IO (IO(..))
import GHC.Exts
import GHC.Word

import qualified Data.Primitive.ByteArray as Prim

foldrByteArray :: (Word8 -> a -> a) -> a
               -> Int             -- ^ offset
               -> Int             -- ^ length
               -> Prim.ByteArray  -- ^ array
               -> a
foldrByteArray :: forall a. (Word8 -> a -> a) -> a -> Int -> Int -> ByteArray -> a
foldrByteArray Word8 -> a -> a
f a
z Int
off0 Int
len ByteArray
ba = Int -> a
go Int
off0
  where
    len' :: Int
len' = Int
len forall a. Num a => a -> a -> a
+ Int
off0
    go :: Int -> a
go !Int
off
      | Int
off forall a. Ord a => a -> a -> Bool
>= Int
len' = a
z
      | Bool
otherwise   =
        let x :: Word8
x = forall a. Prim a => ByteArray -> Int -> a
Prim.indexByteArray ByteArray
ba Int
off
        in Word8 -> a -> a
f Word8
x (Int -> a
go (Int
offforall a. Num a => a -> a -> a
+Int
1))

copyToAddr :: Prim.ByteArray -> Int -> Ptr a -> Int -> IO ()
copyToAddr :: forall a. ByteArray -> Int -> Ptr a -> Int -> IO ()
copyToAddr (Prim.ByteArray ByteArray#
ba) (I# Int#
off) (Ptr Addr#
addr) (I# Int#
len) =
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO (\State# RealWorld
s -> case forall d.
ByteArray# -> Int# -> Addr# -> Int# -> State# d -> State# d
copyByteArrayToAddr# ByteArray#
ba Int#
off Addr#
addr Int#
len State# RealWorld
s of
                State# RealWorld
s' -> (# State# RealWorld
s', () #))

sameByteArray :: Prim.ByteArray -> Prim.ByteArray -> Bool
sameByteArray :: ByteArray -> ByteArray -> Bool
sameByteArray (Prim.ByteArray ByteArray#
ba1#) (Prim.ByteArray ByteArray#
ba2#) =
    case forall a. a -> a -> Int#
reallyUnsafePtrEquality# (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# ByteArray#
ba1# :: ()) (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# ByteArray#
ba2# :: ()) of
      Int#
r -> Int# -> Bool
isTrue# Int#
r

-- | @mkByteArray n xs@ forms a 'Prim.ByteArray' with contents @xs@. Note that
-- @n@ must be the precise length of @xs@.
mkByteArray :: Int -> [Word8] -> Prim.ByteArray
mkByteArray :: Int -> [Word8] -> ByteArray
mkByteArray Int
n [Word8]
xs = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
    MutableByteArray s
arr <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
Prim.newByteArray Int
n
    forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
Prim.writeByteArray MutableByteArray s
arr) [Int
0..Int
nforall a. Num a => a -> a -> a
-Int
1] (forall a. Int -> [a] -> [a]
take Int
n forall a b. (a -> b) -> a -> b
$ [Word8]
xs forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Word8
0)
    forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
Prim.unsafeFreezeByteArray MutableByteArray s
arr

-- | A conservative estimate of pinned-ness.
isByteArrayPinned :: Prim.ByteArray -> Bool
isByteArrayPinned :: ByteArray -> Bool
isByteArrayPinned (Prim.ByteArray ByteArray#
_ba) =
#if __GLASGOW_HASKELL__ > 800
    case ByteArray# -> Int#
isByteArrayPinned# ByteArray#
_ba of
      Int#
0# -> Bool
False
      Int#
_  -> Bool
True
#else
    False
#endif

touch :: a -> IO ()
touch :: forall a. a -> IO ()
touch a
x = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# a
x State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)