{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE MagicHash           #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE TypeFamilies        #-}

-- |
-- Module      : Codec.CBOR.ByteArray.Sliced
-- Copyright   : (c) Ben Gamari 2017-2018
-- License     : BSD3-style (see LICENSE.txt)
--
-- Maintainer  : duncan@community.haskell.org
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--
-- A ByteArray with more instances than 'Data.Primitive.ByteArray.ByteArray'.
-- Some day when these instances are reliably available from @primitive@ we can
-- likely replace this with 'Data.Primitive.ByteArray.ByteArray'.
--
module Codec.CBOR.ByteArray.Sliced
  ( SlicedByteArray(..)
    -- * Conversions
  , sizeofSlicedByteArray
  , fromShortByteString
  , fromByteString
  , fromByteArray
  , toByteString
  , toBuilder
  ) where

import GHC.Exts
import Data.Char (chr, ord)
import Data.Word
import Foreign.Ptr
import Control.Monad.ST
import System.IO.Unsafe

import qualified Data.Primitive.ByteArray as Prim
#if !MIN_VERSION_primitive(0,7,0)
import           Data.Primitive.Types (Addr(..))
#endif
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Short as BSS
import qualified Data.ByteString.Short.Internal as BSS
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Builder.Internal as BSB

import Codec.CBOR.ByteArray.Internal

data SlicedByteArray = SBA {SlicedByteArray -> ByteArray
unSBA :: !Prim.ByteArray, SlicedByteArray -> Int
offset :: !Int, SlicedByteArray -> Int
length :: !Int}

fromShortByteString :: BSS.ShortByteString -> SlicedByteArray
fromShortByteString :: ShortByteString -> SlicedByteArray
fromShortByteString (BSS.SBS ByteArray#
ba) = ByteArray -> SlicedByteArray
fromByteArray (ByteArray# -> ByteArray
Prim.ByteArray ByteArray#
ba)

fromByteString :: BS.ByteString -> SlicedByteArray
fromByteString :: ByteString -> SlicedByteArray
fromByteString = ShortByteString -> SlicedByteArray
fromShortByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
BSS.toShort

fromByteArray :: Prim.ByteArray -> SlicedByteArray
fromByteArray :: ByteArray -> SlicedByteArray
fromByteArray ByteArray
ba = ByteArray -> Int -> Int -> SlicedByteArray
SBA ByteArray
ba Int
0 (ByteArray -> Int
Prim.sizeofByteArray ByteArray
ba)

sizeofSlicedByteArray :: SlicedByteArray -> Int
sizeofSlicedByteArray :: SlicedByteArray -> Int
sizeofSlicedByteArray (SBA ByteArray
_ Int
_ Int
len) = Int
len

-- | Note that this may require a copy.
toByteString :: SlicedByteArray -> BS.ByteString
toByteString :: SlicedByteArray -> ByteString
toByteString SlicedByteArray
sba =
    forall a. IO a -> a
unsafePerformIO
    forall a b. (a -> b) -> a -> b
$ Ptr Word8 -> Int -> IO () -> IO ByteString
BS.unsafePackCStringFinalizer Ptr Word8
ptr (SlicedByteArray -> Int
sizeofSlicedByteArray SlicedByteArray
sba) (forall a. a -> IO ()
touch ByteArray
pinned)
  where
    pinned :: ByteArray
pinned = SlicedByteArray -> ByteArray
toPinned SlicedByteArray
sba
#if MIN_VERSION_primitive(0,7,0)
    !(Ptr Addr#
addr#) = ByteArray -> Ptr Word8
Prim.byteArrayContents ByteArray
pinned
#else
    !(Addr addr#) = Prim.byteArrayContents pinned
#endif
    ptr :: Ptr Word8
ptr = forall a. Addr# -> Ptr a
Ptr Addr#
addr#

toPinned :: SlicedByteArray -> Prim.ByteArray
toPinned :: SlicedByteArray -> ByteArray
toPinned (SBA ByteArray
ba Int
off Int
len)
  | ByteArray -> Bool
isByteArrayPinned ByteArray
ba = ByteArray
ba
  | Bool
otherwise = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
        MutableByteArray s
ba' <- forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
Prim.newPinnedByteArray Int
len
        forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m)
-> Int -> ByteArray -> Int -> Int -> m ()
Prim.copyByteArray MutableByteArray s
ba' Int
0 ByteArray
ba Int
off Int
len
        forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
Prim.unsafeFreezeByteArray MutableByteArray s
ba'

toBuilder :: SlicedByteArray -> BSB.Builder
toBuilder :: SlicedByteArray -> Builder
toBuilder = \(SBA ByteArray
ba Int
off Int
len) -> (forall r. BuildStep r -> BuildStep r) -> Builder
BSB.builder (forall {a}.
ByteArray
-> Int
-> Int
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
go ByteArray
ba Int
off (Int
len forall a. Num a => a -> a -> a
+ Int
off))
  where
    go :: ByteArray
-> Int
-> Int
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
go ByteArray
ba !Int
ip !Int
ipe !BufferRange -> IO (BuildSignal a)
k (BSB.BufferRange Ptr Word8
op Ptr Word8
ope)
      | Int
inpRemaining forall a. Ord a => a -> a -> Bool
<= Int
outRemaining = do
          forall a. ByteArray -> Int -> Ptr a -> Int -> IO ()
copyToAddr ByteArray
ba Int
ip Ptr Word8
op Int
inpRemaining
          let !br' :: BufferRange
br' = Ptr Word8 -> Ptr Word8 -> BufferRange
BSB.BufferRange (Ptr Word8
op forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
inpRemaining) Ptr Word8
ope
          BufferRange -> IO (BuildSignal a)
k BufferRange
br'
      | Bool
otherwise = do
          forall a. ByteArray -> Int -> Ptr a -> Int -> IO ()
copyToAddr ByteArray
ba Int
ip Ptr Word8
op Int
outRemaining
          let !ip' :: Int
ip' = Int
ip forall a. Num a => a -> a -> a
+ Int
outRemaining
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> Ptr Word8 -> BuildStep a -> BuildSignal a
BSB.bufferFull Int
1 Ptr Word8
ope (ByteArray
-> Int
-> Int
-> (BufferRange -> IO (BuildSignal a))
-> BufferRange
-> IO (BuildSignal a)
go ByteArray
ba Int
ip' Int
ipe BufferRange -> IO (BuildSignal a)
k)
      where
        outRemaining :: Int
outRemaining = Ptr Word8
ope forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
op
        inpRemaining :: Int
inpRemaining = Int
ipe forall a. Num a => a -> a -> a
- Int
ip

instance IsString SlicedByteArray where
  fromString :: String -> SlicedByteArray
fromString = forall l. IsList l => [Item l] -> l
fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Num a => Char -> a
checkedOrd
    where
      checkedOrd :: Char -> a
checkedOrd Char
c
        | Char
c forall a. Ord a => a -> a -> Bool
> Char
'\xff' = forall a. HasCallStack => String -> a
error String
"IsString(Codec.CBOR.ByteArray.Sliced): Non-ASCII character"
        | Bool
otherwise  = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
c

instance IsList SlicedByteArray where
  type Item SlicedByteArray = Word8
  fromList :: [Item SlicedByteArray] -> SlicedByteArray
fromList [Item SlicedByteArray]
xs = forall l. IsList l => Int -> [Item l] -> l
fromListN (forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Item SlicedByteArray]
xs) [Item SlicedByteArray]
xs
  -- Note that we make no attempt to behave sensibly if @n /= length xs@.
  -- The class definition allows this.
  fromListN :: Int -> [Item SlicedByteArray] -> SlicedByteArray
fromListN Int
n [Item SlicedByteArray]
xs =
      let arr :: ByteArray
arr = Int -> [Word8] -> ByteArray
mkByteArray Int
n [Item SlicedByteArray]
xs
      in ByteArray -> Int -> Int -> SlicedByteArray
SBA ByteArray
arr Int
0 Int
n
  toList :: SlicedByteArray -> [Item SlicedByteArray]
toList (SBA ByteArray
arr Int
off Int
len) =
      forall a. (Word8 -> a -> a) -> a -> Int -> Int -> ByteArray -> a
foldrByteArray (:) [] Int
off Int
len ByteArray
arr

instance Show SlicedByteArray where
  showsPrec :: Int -> SlicedByteArray -> ShowS
showsPrec Int
_ = forall a. Show a => a -> ShowS
shows forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
chr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l. IsList l => l -> [Item l]
toList

instance Eq SlicedByteArray where
  SBA ByteArray
arr1 Int
off1 Int
len1 == :: SlicedByteArray -> SlicedByteArray -> Bool
== SBA ByteArray
arr2 Int
off2 Int
len2
    | Int
len1 forall a. Eq a => a -> a -> Bool
/= Int
len2
    = Bool
False

    | ByteArray -> ByteArray -> Bool
sameByteArray ByteArray
arr1 ByteArray
arr2
    , Int
off1 forall a. Eq a => a -> a -> Bool
== Int
off2
    , Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2
    = Bool
True

    | Bool
otherwise
    = let (!) :: Prim.ByteArray -> Int -> Word8
          ! :: ByteArray -> Int -> Word8
(!) = forall a. Prim a => ByteArray -> Int -> a
Prim.indexByteArray
          -- len1 and len2 are known to be equal at this point
          len1' :: Int
len1' = Int
len1 forall a. Num a => a -> a -> a
+ Int
off1
          go :: Int -> Int -> Bool
go Int
i1 Int
i2
            | Int
i1 forall a. Eq a => a -> a -> Bool
== Int
len1' = Bool
True
            | (ByteArray
arr1 ByteArray -> Int -> Word8
! Int
i1) forall a. Eq a => a -> a -> Bool
== (ByteArray
arr2 ByteArray -> Int -> Word8
! Int
i2) = Int -> Int -> Bool
go (Int
i1forall a. Num a => a -> a -> a
+Int
1) (Int
i2forall a. Num a => a -> a -> a
+Int
1)
            | Bool
otherwise                  = Bool
False
      in Int -> Int -> Bool
go Int
off1 Int
off2

instance Ord SlicedByteArray where
  SBA ByteArray
arr1 Int
off1 Int
len1 compare :: SlicedByteArray -> SlicedByteArray -> Ordering
`compare` SBA ByteArray
arr2 Int
off2 Int
len2
    | ByteArray -> ByteArray -> Bool
sameByteArray ByteArray
arr1 ByteArray
arr2
    , Int
off1 forall a. Eq a => a -> a -> Bool
== Int
off2
    , Int
len1 forall a. Eq a => a -> a -> Bool
== Int
len2
    = Ordering
EQ

    | Bool
otherwise
    = let (!) :: Prim.ByteArray -> Int -> Word8
          ! :: ByteArray -> Int -> Word8
(!) = forall a. Prim a => ByteArray -> Int -> a
Prim.indexByteArray
          len1' :: Int
len1' = Int
len1 forall a. Num a => a -> a -> a
+ Int
off1
          len2' :: Int
len2' = Int
len2 forall a. Num a => a -> a -> a
+ Int
off2
          go :: Int -> Int -> Ordering
go Int
i1 Int
i2
            | Int
i1 forall a. Eq a => a -> a -> Bool
== Int
len1' Bool -> Bool -> Bool
&& Int
i2 forall a. Eq a => a -> a -> Bool
== Int
len2' = Ordering
EQ
            | Int
i1 forall a. Eq a => a -> a -> Bool
== Int
len1' Bool -> Bool -> Bool
|| Int
i2 forall a. Eq a => a -> a -> Bool
== Int
len2' = Int
len1 forall a. Ord a => a -> a -> Ordering
`compare` Int
len2
            | Ordering
EQ <- Ordering
o                    = Int -> Int -> Ordering
go (Int
i1forall a. Num a => a -> a -> a
+Int
1) (Int
i2forall a. Num a => a -> a -> a
+Int
1)
            | Bool
otherwise                  = Ordering
o
            where o :: Ordering
o = (ByteArray
arr1 ByteArray -> Int -> Word8
! Int
i1) forall a. Ord a => a -> a -> Ordering
`compare` (ByteArray
arr2 ByteArray -> Int -> Word8
! Int
i2)
      in Int -> Int -> Ordering
go Int
off1 Int
off2