{-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, CPP #-}
module Codec.Archive.Tar.Index.Utils where

import Data.ByteString as BS
import Control.Exception (assert)

import Data.ByteString.Internal (ByteString(..), unsafeWithForeignPtr, accursedUnutterablePerformIO)
import GHC.Int (Int(..), Int32)
import GHC.Word (Word32(..), byteSwap32)
import Foreign.Storable (peek)
import GHC.Ptr (castPtr, plusPtr, Ptr)
import GHC.Exts
import GHC.IO (IO(..), unsafePerformIO)
import Data.Array.Base
import Data.Array.IO.Internals (unsafeFreezeIOUArray)
import Control.DeepSeq (NFData(..))
import GHC.Storable
import GHC.ByteOrder

#include <MachDeps.h>

-- | Construct a `UArray Word32 Word32` from a ByteString of 32bit big endian
-- words.
--
-- Note: If using `unsafePerformIO`, be sure to force the result of running the
-- IO action right away... (e.g. see calls to beToLe in StringTable)
beToLe :: (Integral i, Num i) => i
       -- ^ The total array length (the number of 32bit words in the array)
       -> BS.ByteString
       -- ^ The bytestring from which the UArray is constructed.
       -- The content must start in the first byte! (i.e. the meta-data words
       -- that shouldn't be part of the array, must have been dropped already)
       -> IO (UArray i Word32)
beToLe :: forall i.
(Integral i, Num i) =>
i -> ByteString -> IO (UArray i Word32)
beToLe i
lenArr (BS ForeignPtr Word8
fptr Int
_) = do
  ForeignPtr Word8
-> (Ptr Word8 -> IO (UArray i Word32)) -> IO (UArray i Word32)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO (UArray i Word32)) -> IO (UArray i Word32))
-> (Ptr Word8 -> IO (UArray i Word32)) -> IO (UArray i Word32)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
    let ptr' :: Ptr Word32
ptr' = Ptr Word8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr :: Ptr Word32
        !(I# Int#
lenBytes#) = i -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (i
lenArr i -> i -> i
forall a. Num a => a -> a -> a
* i
4)

    -- In spirit, the following does this, but we can't use `newGenArray`
    -- because it only has been introduced in later versions of array:
    -- @@
    -- unsafeFreezeIOUArray =<<
    --   newGenArray (0, lenArr - 1) (\offset -> do
    --     byteSwap32 <$> peek (ptr' `plusPtr` (fromIntegral offset * 4)))
    -- @@
    (State# RealWorld -> (# State# RealWorld, UArray i Word32 #))
-> IO (UArray i Word32)
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, UArray i Word32 #))
 -> IO (UArray i Word32))
-> (State# RealWorld -> (# State# RealWorld, UArray i Word32 #))
-> IO (UArray i Word32)
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
rw0 ->
      case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
lenBytes# State# RealWorld
rw0 of
        (# State# RealWorld
rw1, MutableByteArray# RealWorld
mba# #) ->

          let loop :: Int -> State# RealWorld -> State# RealWorld
              loop :: Int -> State# RealWorld -> State# RealWorld
loop !Int
offset State# RealWorld
st
                | Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< i -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
lenArr
                = let IO State# RealWorld -> (# State# RealWorld, Word32 #)
getV = Ptr Word32 -> Int -> IO Word32
readWord32OffPtrBE Ptr Word32
ptr' Int
offset
                      !(I# Int#
o#) = Int
offset
                   in case State# RealWorld -> (# State# RealWorld, Word32 #)
getV State# RealWorld
st of
                    (# State# RealWorld
st', W32# Word32#
v# #) ->
                      Int -> State# RealWorld -> State# RealWorld
loop (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (MutableByteArray# RealWorld
-> Int# -> Word32# -> State# RealWorld -> State# RealWorld
forall d.
MutableByteArray# d -> Int# -> Word32# -> State# d -> State# d
writeWord32Array# MutableByteArray# RealWorld
mba# Int#
o# Word32#
v# State# RealWorld
st')
                | Bool
otherwise = State# RealWorld
st

           in case MutableByteArray# RealWorld
-> State# RealWorld -> (# State# RealWorld, ByteArray# #)
forall d.
MutableByteArray# d -> State# d -> (# State# d, ByteArray# #)
unsafeFreezeByteArray# MutableByteArray# RealWorld
mba# (Int -> State# RealWorld -> State# RealWorld
loop Int
0 State# RealWorld
rw1) of
             (# State# RealWorld
rw2, ByteArray#
ba# #) -> (# State# RealWorld
rw2, i -> i -> Int -> ByteArray# -> UArray i Word32
forall i e. i -> i -> Int -> ByteArray# -> UArray i e
UArray i
0 (i
lenArr i -> i -> i
forall a. Num a => a -> a -> a
- i
1) (i -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
lenArr) ByteArray#
ba# #)

{-# SPECIALISE beToLe :: Word32 -> BS.ByteString -> IO (UArray Word32 Word32) #-}
{-# SPECIALISE beToLe :: Int32 -> BS.ByteString -> IO (UArray Int32 Word32) #-}

readInt32BE :: BS.ByteString -> Int -> Int32
readInt32BE :: ByteString -> Int -> Int32
readInt32BE ByteString
bs Int
i = Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int -> Word32
readWord32BE ByteString
bs Int
i)
{-# INLINE readInt32BE #-}

readWord32OffPtrBE :: Ptr Word32 -> Int -> IO Word32
readWord32OffPtrBE :: Ptr Word32 -> Int -> IO Word32
readWord32OffPtrBE Ptr Word32
ptr Int
i = do
#if defined(WORDS_BIGENDIAN)
  readWord32OffPtr ptr i
#else
  Word32 -> Word32
byteSwap32 (Word32 -> Word32) -> IO Word32 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr Word32 -> Int -> IO Word32
readWord32OffPtr Ptr Word32
ptr Int
i
#endif

readWord32BE :: BS.ByteString -> Int -> Word32
readWord32BE :: ByteString -> Int -> Word32
readWord32BE (BS ForeignPtr Word8
fptr Int
len) Int
i =
    Bool -> Word32 -> Word32
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Word32 -> Word32) -> Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
    IO Word32 -> Word32
forall a. IO a -> a
accursedUnutterablePerformIO (IO Word32 -> Word32) -> IO Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
      ForeignPtr Word8 -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr Word8
fptr ((Ptr Word8 -> IO Word32) -> IO Word32)
-> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
ptr -> do
        Ptr Word32 -> Int -> IO Word32
readWord32OffPtrBE (Ptr Word8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) Int
i
{-# INLINE readWord32BE #-}