{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

-- | TODO: Implement TH based instance derivation for better performance.

module Streamly.Internal.Data.Unboxed
    ( Unbox(..)
    , peekWith
    , pokeWith
    , MutableByteArray(..)
    , touch
    , getMutableByteArray#
    , pin
    , unpin
    , newUnpinnedBytes
    , newPinnedBytes
    , newAlignedPinnedBytes
    , nil

    -- * Type Parser and Builder
    , BoundedPtr (..)

    , Peeker (..)
    , read
    , readUnsafe
    , skipByte
    , runPeeker

    , pokeBoundedPtrUnsafe
    , pokeBoundedPtr

    -- * Generic Unbox instances
    , genericSizeOf
    , genericPeekByteIndex
    , genericPokeByteIndex

    -- Classess used for generic deriving.
    , PeekRep(..)
    , PokeRep(..)
    , SizeOfRep(..)
    ) where

#include "MachDeps.h"
#include "ArrayMacros.h"

import Control.Monad (void, when)
import Data.Complex (Complex((:+)))
import Data.Functor ((<&>))
import Data.Functor.Const (Const(..))
import Data.Functor.Identity (Identity(..))
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Foreign.Ptr (IntPtr(..), WordPtr(..))
import GHC.Base (IO(..))
import GHC.Fingerprint.Type (Fingerprint(..))
import GHC.Int (Int16(..), Int32(..), Int64(..), Int8(..))
import GHC.Real (Ratio(..))
import GHC.Stable (StablePtr(..))
import GHC.Word (Word16(..), Word32(..), Word64(..), Word8(..))
#if MIN_VERSION_base(4,15,0)
import GHC.RTS.Flags (IoSubSystem(..))
#endif
import Streamly.Internal.Data.Builder (Builder (..))
import System.IO.Unsafe (unsafePerformIO)

import GHC.Generics
import GHC.Exts
import GHC.TypeLits
import Prelude hiding (read)

--------------------------------------------------------------------------------
-- The ArrayContents type
--------------------------------------------------------------------------------

-- XXX can use UnliftedNewtypes
data MutableByteArray = MutableByteArray (MutableByteArray# RealWorld)

{-# INLINE getMutableByteArray# #-}
getMutableByteArray# :: MutableByteArray -> MutableByteArray# RealWorld
getMutableByteArray# :: MutableByteArray -> MutableByteArray# RealWorld
getMutableByteArray# (MutableByteArray MutableByteArray# RealWorld
mbarr) = MutableByteArray# RealWorld
mbarr

{-# INLINE touch #-}
touch :: MutableByteArray -> IO ()
touch :: MutableByteArray -> IO ()
touch (MutableByteArray MutableByteArray# RealWorld
contents) =
    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# MutableByteArray# RealWorld
contents State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)

-- | Return the size of the array in bytes.
{-# INLINE sizeOfMutableByteArray #-}
sizeOfMutableByteArray :: MutableByteArray -> IO Int
sizeOfMutableByteArray :: MutableByteArray -> IO Int
sizeOfMutableByteArray (MutableByteArray MutableByteArray# RealWorld
arr) =
    forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
        case forall d. MutableByteArray# d -> State# d -> (# State# d, Int# #)
getSizeofMutableByteArray# MutableByteArray# RealWorld
arr State# RealWorld
s of
            (# State# RealWorld
s1, Int#
i #) -> (# State# RealWorld
s1, Int# -> Int
I# Int#
i #)

--------------------------------------------------------------------------------
-- Creation
--------------------------------------------------------------------------------

{-# NOINLINE nil #-}
nil :: MutableByteArray
nil :: MutableByteArray
nil = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ Int -> IO MutableByteArray
newUnpinnedBytes Int
0

{-# INLINE newUnpinnedBytes #-}
newUnpinnedBytes :: Int -> IO MutableByteArray
newUnpinnedBytes :: Int -> IO MutableByteArray
newUnpinnedBytes Int
nbytes | Int
nbytes forall a. Ord a => a -> a -> Bool
< Int
0 =
  forall a. [Char] -> a
errorWithoutStackTrace [Char]
"newUnpinnedBytes: size must be >= 0"
newUnpinnedBytes (I# Int#
nbytes) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# Int#
nbytes State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutableByteArray
c = MutableByteArray# RealWorld -> MutableByteArray
MutableByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutableByteArray
c #)

{-# INLINE newPinnedBytes #-}
newPinnedBytes :: Int -> IO MutableByteArray
newPinnedBytes :: Int -> IO MutableByteArray
newPinnedBytes Int
nbytes | Int
nbytes forall a. Ord a => a -> a -> Bool
< Int
0 =
  forall a. [Char] -> a
errorWithoutStackTrace [Char]
"newPinnedBytes: size must be >= 0"
newPinnedBytes (I# Int#
nbytes) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# Int#
nbytes State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutableByteArray
c = MutableByteArray# RealWorld -> MutableByteArray
MutableByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutableByteArray
c #)

{-# INLINE newAlignedPinnedBytes #-}
newAlignedPinnedBytes :: Int -> Int -> IO MutableByteArray
newAlignedPinnedBytes :: Int -> Int -> IO MutableByteArray
newAlignedPinnedBytes Int
nbytes Int
_align | Int
nbytes forall a. Ord a => a -> a -> Bool
< Int
0 =
  forall a. [Char] -> a
errorWithoutStackTrace [Char]
"newAlignedPinnedBytes: size must be >= 0"
newAlignedPinnedBytes (I# Int#
nbytes) (I# Int#
align) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
    case forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
nbytes Int#
align State# RealWorld
s of
        (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr# #) ->
           let c :: MutableByteArray
c = MutableByteArray# RealWorld -> MutableByteArray
MutableByteArray MutableByteArray# RealWorld
mbarr#
            in (# State# RealWorld
s', MutableByteArray
c #)

-------------------------------------------------------------------------------
-- Pinning & Unpinning
-------------------------------------------------------------------------------

{-# INLINE isPinned #-}
isPinned :: MutableByteArray -> Bool
isPinned :: MutableByteArray -> Bool
isPinned (MutableByteArray MutableByteArray# RealWorld
arr#) =
    let pinnedInt :: Int
pinnedInt = Int# -> Int
I# (forall d. MutableByteArray# d -> Int#
isMutableByteArrayPinned# MutableByteArray# RealWorld
arr#)
     in Int
pinnedInt forall a. Eq a => a -> a -> Bool
== Int
1


{-# INLINE cloneMutableArrayWith# #-}
cloneMutableArrayWith#
    :: (Int# -> State# RealWorld -> (# State# RealWorld
                                     , MutableByteArray# RealWorld #))
    -> MutableByteArray# RealWorld
    -> State# RealWorld
    -> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# :: (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
alloc# MutableByteArray# RealWorld
arr# State# RealWorld
s# =
    case forall d. MutableByteArray# d -> State# d -> (# State# d, Int# #)
getSizeofMutableByteArray# MutableByteArray# RealWorld
arr# State# RealWorld
s# of
        (# State# RealWorld
s1#, Int#
i# #) ->
            case Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
alloc# Int#
i# State# RealWorld
s1# of
                (# State# RealWorld
s2#, MutableByteArray# RealWorld
arr1# #) ->
                    case forall d.
MutableByteArray# d
-> Int#
-> MutableByteArray# d
-> Int#
-> Int#
-> State# d
-> State# d
copyMutableByteArray# MutableByteArray# RealWorld
arr# Int#
0# MutableByteArray# RealWorld
arr1# Int#
0# Int#
i# State# RealWorld
s2# of
                        State# RealWorld
s3# -> (# State# RealWorld
s3#, MutableByteArray# RealWorld
arr1# #)

{-# INLINE pin #-}
pin :: MutableByteArray -> IO MutableByteArray
pin :: MutableByteArray -> IO MutableByteArray
pin arr :: MutableByteArray
arr@(MutableByteArray MutableByteArray# RealWorld
marr#) =
    if MutableByteArray -> Bool
isPinned MutableByteArray
arr
    then forall (m :: * -> *) a. Monad m => a -> m a
return MutableByteArray
arr
    else forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
             forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# ->
                   case (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newPinnedByteArray# MutableByteArray# RealWorld
marr# State# RealWorld
s# of
                       (# State# RealWorld
s1#, MutableByteArray# RealWorld
marr1# #) -> (# State# RealWorld
s1#, MutableByteArray# RealWorld -> MutableByteArray
MutableByteArray MutableByteArray# RealWorld
marr1# #)

{-# INLINE unpin #-}
unpin :: MutableByteArray -> IO MutableByteArray
unpin :: MutableByteArray -> IO MutableByteArray
unpin arr :: MutableByteArray
arr@(MutableByteArray MutableByteArray# RealWorld
marr#) =
    if Bool -> Bool
not (MutableByteArray -> Bool
isPinned MutableByteArray
arr)
    then forall (m :: * -> *) a. Monad m => a -> m a
return MutableByteArray
arr
    else forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO
             forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s# ->
                   case (Int#
 -> State# RealWorld
 -> (# State# RealWorld, MutableByteArray# RealWorld #))
-> MutableByteArray# RealWorld
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
cloneMutableArrayWith# forall d. Int# -> State# d -> (# State# d, MutableByteArray# d #)
newByteArray# MutableByteArray# RealWorld
marr# State# RealWorld
s# of
                       (# State# RealWorld
s1#, MutableByteArray# RealWorld
marr1# #) -> (# State# RealWorld
s1#, MutableByteArray# RealWorld -> MutableByteArray
MutableByteArray MutableByteArray# RealWorld
marr1# #)

--------------------------------------------------------------------------------
-- The Unbox type class
--------------------------------------------------------------------------------

-- XXX generate error if the size is < 1

-- In theory we could convert a type to and from a byte stream and use that
-- to implement boxing, unboxing. But that would be inefficient. This type
-- class allows each primitive type to have its own specific efficient
-- implementation to read and write the type to memory.
--
-- This is a typeclass that uses MutableByteArray but could use ForeignPtr or
-- any other representation of memory. We could make this a multiparameter type
-- class if necessary.
--
-- If the type class would have to support reading and writing to a Ptr as well,
-- basically what Storable does. We will also need to touch the anchoring ptr at
-- the right points which is prone to errors. However, it should be simple to
-- implement unmanaged/read-only memory arrays by allowing a Ptr type in
-- ArrayContents, though it would require all instances to support reading from
-- a Ptr.
--
-- There is a reason for using byte offset instead of element index in read and
-- write operations in the type class. If we use element index slicing of the
-- array becomes rigid. We can only slice the array at addresses that are
-- aligned with the type, therefore, we cannot slice at misaligned location and
-- then cast the slice into another type which does not ncessarily align with
-- the original type.
--
-- As a side note, there seem to be no performance advantage of alignment
-- anymore, see
-- https://lemire.me/blog/2012/05/31/data-alignment-for-speed-myth-or-reality/
--

-- The main goal of the Unbox type class is to be used in arrays. Invariants
-- for the sizeOf value required for use in arrays:
--
-- * size is independent of the value, it is determined by the type only. So
-- that we can store values of the same type in fixed length array cells.
-- * size cannot be zero. So that the length of an array storing the element
-- and the number of elements can be related.
--
-- Note, for general serializable types the size cannot be fixed e.g. we may
-- want to serialize a list. This type class can be considered a special case
-- of a more general serialization type class.

-- | A type implementing the 'Unbox' interface supplies operations for reading
-- and writing the type from and to a mutable byte array (an unboxed
-- representation of the type) in memory. The read operation 'peekByteIndex'
-- deserializes the boxed type from the mutable byte array. The write operation
-- 'pokeByteIndex' serializes the boxed type to the mutable byte array.
--
-- Instances can be derived via 'Generic'. Note that the data type must be
-- non-recursive. Here is an example, for deriving an instance of this type
-- class.
--
-- >>> import GHC.Generics (Generic)
-- >>> :{
-- data Object = Object
--     { _int0 :: Int
--     , _int1 :: Int
--     } deriving Generic
-- :}
--
-- WARNING! Generic deriving hangs for recursive data types.
--
-- >>> import Streamly.Data.Array (Unbox(..))
-- >>> instance Unbox Object
--
-- If you want to write the instance manually:
--
-- >>> :{
-- instance Unbox Object where
--     sizeOf _ = 16
--     peekByteIndex i arr = do
--         x0 <- peekByteIndex i arr
--         x1 <- peekByteIndex (i + 8) arr
--         return $ Object x0 x1
--     pokeByteIndex i arr (Object x0 x1) = do
--         pokeByteIndex i arr x0
--         pokeByteIndex (i + 8) arr x1
-- :}
--
class Unbox a where
    -- | Get the size. Size cannot be zero.
    sizeOf :: Proxy a -> Int

    default sizeOf :: (SizeOfRep (Rep a)) => Proxy a -> Int
    sizeOf = forall a. SizeOfRep (Rep a) => Proxy a -> Int
genericSizeOf

    -- | Read an element of type "a" from a MutableByteArray given the byte
    -- index.
    --
    -- IMPORTANT: The implementation of this interface may not check the bounds
    -- of the array, the caller must not assume that.
    peekByteIndex :: Int -> MutableByteArray -> IO a

    default peekByteIndex :: (Generic a, PeekRep (Rep a)) =>
         Int -> MutableByteArray -> IO a
    peekByteIndex Int
i MutableByteArray
arr = forall a.
(Generic a, PeekRep (Rep a)) =>
MutableByteArray -> Int -> IO a
genericPeekByteIndex MutableByteArray
arr Int
i

    -- | Write an element of type "a" to a MutableByteArray given the byte
    -- index.
    --
    -- IMPORTANT: The implementation of this interface may not check the bounds
    -- of the array, the caller must not assume that.
    pokeByteIndex :: Int -> MutableByteArray -> a -> IO ()

    default pokeByteIndex :: (Generic a, PokeRep (Rep a)) =>
        Int -> MutableByteArray -> a -> IO ()
    pokeByteIndex Int
i MutableByteArray
arr = forall a.
(Generic a, PokeRep (Rep a)) =>
MutableByteArray -> Int -> a -> IO ()
genericPokeByteIndex MutableByteArray
arr Int
i

#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray, _sizeOf) \
instance Unbox _type where {                                         \
; {-# INLINE peekByteIndex #-}                                       \
; peekByteIndex (I# n) (MutableByteArray mbarr) = IO $ \s ->         \
      case _readArray mbarr n s of                                   \
          { (# s1, i #) -> (# s1, _constructor i #) }                \
; {-# INLINE pokeByteIndex #-}                                       \
; pokeByteIndex (I# n) (MutableByteArray mbarr) (_constructor val) = \
        IO $ \s -> (# _writeArray mbarr n val s, () #)               \
; {-# INLINE sizeOf #-}                                              \
; sizeOf _ = _sizeOf                                                 \
}

#define DERIVE_WRAPPED_UNBOX(_constraint, _type, _constructor, _innerType)    \
instance _constraint Unbox _type where                                        \
; {-# INLINE peekByteIndex #-}                                                \
; peekByteIndex i arr = _constructor <$> peekByteIndex i arr                  \
; {-# INLINE pokeByteIndex #-}                                                \
; pokeByteIndex i arr (_constructor a) = pokeByteIndex i arr a                \
; {-# INLINE sizeOf #-}                                                       \
; sizeOf _ = SIZE_OF(_innerType)

#define DERIVE_BINARY_UNBOX(_constraint, _type, _constructor, _innerType) \
instance _constraint Unbox _type where {                                  \
; {-# INLINE peekByteIndex #-}                                            \
; peekByteIndex i arr =                                                   \
      peekByteIndex i arr >>=                                             \
        (\p1 -> peekByteIndex (i + SIZE_OF(_innerType)) arr               \
            <&> _constructor p1)                                          \
; {-# INLINE pokeByteIndex #-}                                            \
; pokeByteIndex i arr (_constructor p1 p2) =                              \
      pokeByteIndex i arr p1 >>                                           \
        pokeByteIndex (i + SIZE_OF(_innerType)) arr p2                    \
; {-# INLINE sizeOf #-}                                                   \
; sizeOf _ = 2 * SIZE_OF(_innerType)                                      \
}

-------------------------------------------------------------------------------
-- Unbox instances for primitive types
-------------------------------------------------------------------------------

DERIVE_UNBOXED( Char
              , C#
              , readWord8ArrayAsWideChar#
              , writeWord8ArrayAsWideChar#
              , SIZEOF_HSCHAR)

DERIVE_UNBOXED( Int8
              , I8#
              , readInt8Array#
              , writeInt8Array#
              , 1)

DERIVE_UNBOXED( Int16
              , I16#
              , readWord8ArrayAsInt16#
              , writeWord8ArrayAsInt16#
              , 2)

DERIVE_UNBOXED( Int32
              , I32#
              , readWord8ArrayAsInt32#
              , writeWord8ArrayAsInt32#
              , 4)

DERIVE_UNBOXED( Int
              , I#
              , readWord8ArrayAsInt#
              , writeWord8ArrayAsInt#
              , SIZEOF_HSINT)

DERIVE_UNBOXED( Int64
              , I64#
              , readWord8ArrayAsInt64#
              , writeWord8ArrayAsInt64#
              , 8)

DERIVE_UNBOXED( Word
              , W#
              , readWord8ArrayAsWord#
              , writeWord8ArrayAsWord#
              , SIZEOF_HSWORD)

DERIVE_UNBOXED( Word8
              , W8#
              , readWord8Array#
              , writeWord8Array#
              , 1)

DERIVE_UNBOXED( Word16
              , W16#
              , readWord8ArrayAsWord16#
              , writeWord8ArrayAsWord16#
              , 2)

DERIVE_UNBOXED( Word32
              , W32#
              , readWord8ArrayAsWord32#
              , writeWord8ArrayAsWord32#
              , 4)

DERIVE_UNBOXED( Word64
              , W64#
              , readWord8ArrayAsWord64#
              , writeWord8ArrayAsWord64#
              , 8)

DERIVE_UNBOXED( Double
              , D#
              , readWord8ArrayAsDouble#
              , writeWord8ArrayAsDouble#
              , SIZEOF_HSDOUBLE)

DERIVE_UNBOXED( Float
              , F#
              , readWord8ArrayAsFloat#
              , writeWord8ArrayAsFloat#
              , SIZEOF_HSFLOAT)

-------------------------------------------------------------------------------
-- Unbox instances for derived types
-------------------------------------------------------------------------------

DERIVE_UNBOXED( (StablePtr a)
              , StablePtr
              , readWord8ArrayAsStablePtr#
              , writeWord8ArrayAsStablePtr#
              , SIZEOF_HSSTABLEPTR)

DERIVE_UNBOXED( (Ptr a)
              , Ptr
              , readWord8ArrayAsAddr#
              , writeWord8ArrayAsAddr#
              , SIZEOF_HSPTR)

DERIVE_UNBOXED( (FunPtr a)
              , FunPtr
              , readWord8ArrayAsAddr#
              , writeWord8ArrayAsAddr#
              , SIZEOF_HSFUNPTR)

DERIVE_WRAPPED_UNBOX(,IntPtr,IntPtr,Int)
DERIVE_WRAPPED_UNBOX(,WordPtr,WordPtr,Word)
DERIVE_WRAPPED_UNBOX(Unbox a =>,(Identity a),Identity,a)
#if MIN_VERSION_base(4,14,0)
DERIVE_WRAPPED_UNBOX(Unbox a =>,(Down a),Down,a)
#endif
DERIVE_WRAPPED_UNBOX(Unbox a =>,(Const a b),Const,a)
DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Complex a),(:+),a)
DERIVE_BINARY_UNBOX(forall a. Unbox a =>,(Ratio a),(:%),a)
DERIVE_BINARY_UNBOX(,Fingerprint,Fingerprint,Word64)

instance Unbox () where

    {-# INLINE peekByteIndex #-}
    peekByteIndex :: Int -> MutableByteArray -> IO ()
peekByteIndex Int
_ MutableByteArray
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    {-# INLINE pokeByteIndex #-}
    pokeByteIndex :: Int -> MutableByteArray -> () -> IO ()
pokeByteIndex Int
_ MutableByteArray
_ ()
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    {-# INLINE sizeOf #-}
    sizeOf :: Proxy () -> Int
sizeOf Proxy ()
_ = Int
1

#if MIN_VERSION_base(4,15,0)
instance Unbox IoSubSystem where

    {-# INLINE peekByteIndex #-}
    peekByteIndex :: Int -> MutableByteArray -> IO IoSubSystem
peekByteIndex Int
i MutableByteArray
arr = forall a. Enum a => Int -> a
toEnum forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Unbox a => Int -> MutableByteArray -> IO a
peekByteIndex Int
i MutableByteArray
arr

    {-# INLINE pokeByteIndex #-}
    pokeByteIndex :: Int -> MutableByteArray -> IoSubSystem -> IO ()
pokeByteIndex Int
i MutableByteArray
arr IoSubSystem
a = forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
i MutableByteArray
arr (forall a. Enum a => a -> Int
fromEnum IoSubSystem
a)

    {-# INLINE sizeOf #-}
    sizeOf :: Proxy IoSubSystem -> Int
sizeOf Proxy IoSubSystem
_ = forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy Int)
#endif

instance Unbox Bool where

    {-# INLINE peekByteIndex #-}
    peekByteIndex :: Int -> MutableByteArray -> IO Bool
peekByteIndex Int
i MutableByteArray
arr = do
        Int8
res <- forall a. Unbox a => Int -> MutableByteArray -> IO a
peekByteIndex Int
i MutableByteArray
arr
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int8
res forall a. Eq a => a -> a -> Bool
/= (Int8
0 :: Int8)

    {-# INLINE pokeByteIndex #-}
    pokeByteIndex :: Int -> MutableByteArray -> Bool -> IO ()
pokeByteIndex Int
i MutableByteArray
arr Bool
a =
        if Bool
a
        then forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
i MutableByteArray
arr (Int8
1 :: Int8)
        else forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
i MutableByteArray
arr (Int8
0 :: Int8)

    {-# INLINE sizeOf #-}
    sizeOf :: Proxy Bool -> Int
sizeOf Proxy Bool
_ = Int
1

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

{-# INLINE peekWith #-}
peekWith :: Unbox a => MutableByteArray -> Int -> IO a
peekWith :: forall a. Unbox a => MutableByteArray -> Int -> IO a
peekWith MutableByteArray
arr Int
i = forall a. Unbox a => Int -> MutableByteArray -> IO a
peekByteIndex Int
i MutableByteArray
arr

{-# INLINE pokeWith #-}
pokeWith :: Unbox a => MutableByteArray -> Int -> a -> IO ()
pokeWith :: forall a. Unbox a => MutableByteArray -> Int -> a -> IO ()
pokeWith MutableByteArray
arr Int
i = forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
i MutableByteArray
arr

--------------------------------------------------------------------------------
-- Generic deriving
--------------------------------------------------------------------------------

-- Utilities to build or parse a type safely and easily.

-- | A location inside a mutable byte array with the bound of the array. Is it
-- cheaper to just get the bound using the size of the array whenever needed?
data BoundedPtr =
    BoundedPtr
        MutableByteArray          -- byte array
        Int                       -- current pos
        Int                       -- position after end

--------------------------------------------------------------------------------
-- Peeker monad
--------------------------------------------------------------------------------

-- | Chains peek functions that pass the current position to the next function
newtype Peeker a = Peeker (Builder BoundedPtr IO a)
    deriving (forall a b. a -> Peeker b -> Peeker a
forall a b. (a -> b) -> Peeker a -> Peeker b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Peeker b -> Peeker a
$c<$ :: forall a b. a -> Peeker b -> Peeker a
fmap :: forall a b. (a -> b) -> Peeker a -> Peeker b
$cfmap :: forall a b. (a -> b) -> Peeker a -> Peeker b
Functor, Functor Peeker
forall a. a -> Peeker a
forall a b. Peeker a -> Peeker b -> Peeker a
forall a b. Peeker a -> Peeker b -> Peeker b
forall a b. Peeker (a -> b) -> Peeker a -> Peeker b
forall a b c. (a -> b -> c) -> Peeker a -> Peeker b -> Peeker c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Peeker a -> Peeker b -> Peeker a
$c<* :: forall a b. Peeker a -> Peeker b -> Peeker a
*> :: forall a b. Peeker a -> Peeker b -> Peeker b
$c*> :: forall a b. Peeker a -> Peeker b -> Peeker b
liftA2 :: forall a b c. (a -> b -> c) -> Peeker a -> Peeker b -> Peeker c
$cliftA2 :: forall a b c. (a -> b -> c) -> Peeker a -> Peeker b -> Peeker c
<*> :: forall a b. Peeker (a -> b) -> Peeker a -> Peeker b
$c<*> :: forall a b. Peeker (a -> b) -> Peeker a -> Peeker b
pure :: forall a. a -> Peeker a
$cpure :: forall a. a -> Peeker a
Applicative, Applicative Peeker
forall a. a -> Peeker a
forall a b. Peeker a -> Peeker b -> Peeker b
forall a b. Peeker a -> (a -> Peeker b) -> Peeker b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Peeker a
$creturn :: forall a. a -> Peeker a
>> :: forall a b. Peeker a -> Peeker b -> Peeker b
$c>> :: forall a b. Peeker a -> Peeker b -> Peeker b
>>= :: forall a b. Peeker a -> (a -> Peeker b) -> Peeker b
$c>>= :: forall a b. Peeker a -> (a -> Peeker b) -> Peeker b
Monad)

{-# INLINE readUnsafe #-}
readUnsafe :: Unbox a => Peeker a
readUnsafe :: forall a. Unbox a => Peeker a
readUnsafe = forall a. Builder BoundedPtr IO a -> Peeker a
Peeker (forall s (m :: * -> *) a. (s -> m (s, a)) -> Builder s m a
Builder forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
step)

    where

    {-# INLINE step #-}
    step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
    step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
step (BoundedPtr MutableByteArray
arr Int
pos Int
end) = do
        let next :: Int
next = Int
pos forall a. Num a => a -> a -> a
+ forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
        a
r <- forall a. Unbox a => Int -> MutableByteArray -> IO a
peekByteIndex Int
pos MutableByteArray
arr
        forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
next Int
end, a
r)

{-# INLINE read #-}
read :: Unbox a => Peeker a
read :: forall a. Unbox a => Peeker a
read = forall a. Builder BoundedPtr IO a -> Peeker a
Peeker (forall s (m :: * -> *) a. (s -> m (s, a)) -> Builder s m a
Builder forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
step)

    where

    {-# INLINE step #-}
    step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
    step :: forall a. Unbox a => BoundedPtr -> IO (BoundedPtr, a)
step (BoundedPtr MutableByteArray
arr Int
pos Int
end) = do
        let next :: Int
next = Int
pos forall a. Num a => a -> a -> a
+ forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
next forall a. Ord a => a -> a -> Bool
> Int
end) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"peekObject reading beyond limit"
        a
r <- forall a. Unbox a => Int -> MutableByteArray -> IO a
peekByteIndex Int
pos MutableByteArray
arr
        forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
next Int
end, a
r)

{-# INLINE skipByte #-}
skipByte :: Peeker ()
skipByte :: Peeker ()
skipByte = forall a. Builder BoundedPtr IO a -> Peeker a
Peeker (forall s (m :: * -> *) a. (s -> m (s, a)) -> Builder s m a
Builder BoundedPtr -> IO (BoundedPtr, ())
step)

    where

    {-# INLINE step #-}
    step :: BoundedPtr -> IO (BoundedPtr, ())
    step :: BoundedPtr -> IO (BoundedPtr, ())
step (BoundedPtr MutableByteArray
arr Int
pos Int
end) = do
        let next :: Int
next = Int
pos forall a. Num a => a -> a -> a
+ Int
1
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
next forall a. Ord a => a -> a -> Bool
> Int
end)
            forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"skipByte: reading beyond limit. next = "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
next
                forall a. [a] -> [a] -> [a]
++ [Char]
" end = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
end
        forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
next Int
end, ())

{-# INLINE runPeeker #-}
runPeeker :: Peeker a -> BoundedPtr -> IO a
runPeeker :: forall a. Peeker a -> BoundedPtr -> IO a
runPeeker (Peeker (Builder BoundedPtr -> IO (BoundedPtr, a)
f)) BoundedPtr
ptr = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd (BoundedPtr -> IO (BoundedPtr, a)
f BoundedPtr
ptr)

--------------------------------------------------------------------------------
-- Poke utilities
--------------------------------------------------------------------------------

-- XXX Using a Poker monad may be useful when we have to compute the size to be
-- poked as we go and then poke the size at a previous location. For variable
-- sized object serialization we may also want to reallocate the array and
-- return the newly allocated array in the output.

-- Does not check writing beyond bound.
{-# INLINE pokeBoundedPtrUnsafe #-}
pokeBoundedPtrUnsafe :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtrUnsafe :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtrUnsafe a
a (BoundedPtr MutableByteArray
arr Int
pos Int
end) = do
    let next :: Int
next = Int
pos forall a. Num a => a -> a -> a
+ forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
pos MutableByteArray
arr a
a
    forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
next Int
end)

{-# INLINE pokeBoundedPtr #-}
pokeBoundedPtr :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtr :: forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtr a
a (BoundedPtr MutableByteArray
arr Int
pos Int
end) = do
    let next :: Int
next = Int
pos forall a. Num a => a -> a -> a
+ forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
next forall a. Ord a => a -> a -> Bool
> Int
end) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => [Char] -> a
error [Char]
"pokeBoundedPtr writing beyond limit"
    forall a. Unbox a => Int -> MutableByteArray -> a -> IO ()
pokeByteIndex Int
pos MutableByteArray
arr a
a
    forall (m :: * -> *) a. Monad m => a -> m a
return (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
next Int
end)

--------------------------------------------------------------------------------
-- Check the number of constructors in a sum type
--------------------------------------------------------------------------------

-- Count the constructors of a sum type.
type family SumArity (a :: Type -> Type) :: Nat where
    SumArity (C1 _ _) = 1
    -- Requires UndecidableInstances
    SumArity (f :+: g) = SumArity f + SumArity g

type family TypeErrorMessage (a :: Symbol) :: Constraint where
    TypeErrorMessage a = TypeError ('Text a)

type family ArityCheck (b :: Bool) :: Constraint where
    ArityCheck 'True = ()
    ArityCheck 'False = TypeErrorMessage
        "Generic Unbox deriving does not support > 256 constructors."

-- Type constraint to restrict the sum type arity so that the constructor tag
-- can fit in a single byte.
type MaxArity256 n = ArityCheck (n <=? 255)

--------------------------------------------------------------------------------
-- Generic Deriving of Unbox instance
--------------------------------------------------------------------------------

-- Unbox uses fixed size encoding, therefore, when a (sum) type has multiple
-- constructors, the size of the type is computed as the maximum required by
-- any constructor. Therefore, size is independent of the value, it can be
-- determined solely by the type.

-- | Implementation of sizeOf that works on the generic representation of an
-- ADT.
class SizeOfRep (f :: Type -> Type) where
    sizeOfRep :: f x -> Int

-- Meta information wrapper, go inside
instance SizeOfRep f => SizeOfRep (M1 i c f) where
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. M1 i c f x -> Int
sizeOfRep M1 i c f x
_ = forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall a. HasCallStack => a
undefined :: f x)

-- Primitive type "a".
instance Unbox a => SizeOfRep (K1 i a) where
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. K1 i a x -> Int
sizeOfRep K1 i a x
_ = forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy a)

-- Void: data type without constructors. Values of this type cannot exist,
-- therefore the size is undefined. We should never be serializing structures
-- with elements of this type.
instance SizeOfRep V1 where
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. V1 x -> Int
sizeOfRep = forall a. HasCallStack => [Char] -> a
error [Char]
"sizeOfRep: a value of a Void type must not exist"

-- Note that when a sum type has many unit constructors only a single byte is
-- required to encode the type as only the constructor tag is stored.
instance SizeOfRep U1 where
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. U1 x -> Int
sizeOfRep U1 x
_ = Int
0

-- Product type
instance (SizeOfRep f, SizeOfRep g) => SizeOfRep (f :*: g) where
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. (:*:) f g x -> Int
sizeOfRep (:*:) f g x
_ = forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall a. HasCallStack => a
undefined :: f x) forall a. Num a => a -> a -> a
+ forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall a. HasCallStack => a
undefined :: g x)

-------------------------------------------------------------------------------

class SizeOfRepSum (f :: Type -> Type) where
    sizeOfRepSum :: f x -> Int

-- Constructor
instance SizeOfRep a => SizeOfRepSum (C1 c a) where
    {-# INLINE sizeOfRepSum #-}
    sizeOfRepSum :: forall x. C1 c a x -> Int
sizeOfRepSum = forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep

instance (SizeOfRepSum f, SizeOfRepSum g) => SizeOfRepSum (f :+: g) where
    {-# INLINE sizeOfRepSum #-}
    sizeOfRepSum :: forall x. (:+:) f g x -> Int
sizeOfRepSum (:+:) f g x
_ =
        forall a. Ord a => a -> a -> a
max (forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall a. HasCallStack => a
undefined :: f x)) (forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall a. HasCallStack => a
undefined :: g x))

-------------------------------------------------------------------------------

instance (MaxArity256 (SumArity (f :+: g)), SizeOfRepSum f, SizeOfRepSum g) =>
    SizeOfRep (f :+: g) where

    -- The size of a sum type is the max of any of the constructor size.
    -- sizeOfRepSum type class operation is used here instead of sizeOfRep so
    -- that we add the constructor index byte only for the first time and avoid
    -- including it for the subsequent sum constructors.
    {-# INLINE sizeOfRep #-}
    sizeOfRep :: forall x. (:+:) f g x -> Int
sizeOfRep (:+:) f g x
_ =
        -- One byte for the constructor id and then the constructor value.
        forall a. Unbox a => Proxy a -> Int
sizeOf (forall {k} (t :: k). Proxy t
Proxy :: Proxy Word8) forall a. Num a => a -> a -> a
+
            forall a. Ord a => a -> a -> a
max (forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall a. HasCallStack => a
undefined :: f x))
                (forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall a. HasCallStack => a
undefined :: g x))

-- Unit: constructors without arguments.
-- Theoretically the size can be 0, but we use 1 to simplify the implementation
-- of an array of unit type elements. With a non-zero size we can count the number
-- of elements in the array based on the size of the array. Otherwise we will
-- have to store a virtual length in the array, but keep the physical size of
-- the array as 0. Or we will have to make a special handling for zero sized
-- elements to make the size as 1. Or we can disallow arrays with elements
-- having size 0.
--
{-# INLINE genericSizeOf #-}
genericSizeOf :: forall a. (SizeOfRep (Rep a)) => Proxy a -> Int
genericSizeOf :: forall a. SizeOfRep (Rep a) => Proxy a -> Int
genericSizeOf Proxy a
_ =
    let s :: Int
s = forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall a. HasCallStack => a
undefined :: Rep a x)
      in if Int
s forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
s

--------------------------------------------------------------------------------
-- Generic poke
--------------------------------------------------------------------------------

class PokeRep (f :: Type -> Type) where
    pokeRep :: f a -> BoundedPtr -> IO BoundedPtr

instance PokeRep f => PokeRep (M1 i c f) where
    {-# INLINE pokeRep #-}
    pokeRep :: forall a. M1 i c f a -> BoundedPtr -> IO BoundedPtr
pokeRep M1 i c f a
f = forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep (forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 i c f a
f)

instance Unbox a => PokeRep (K1 i a) where
    {-# INLINE pokeRep #-}
    pokeRep :: forall a. K1 i a a -> BoundedPtr -> IO BoundedPtr
pokeRep K1 i a a
a = forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtr (forall k i c (p :: k). K1 i c p -> c
unK1 K1 i a a
a)

instance PokeRep V1 where
    {-# INLINE pokeRep #-}
    pokeRep :: forall a. V1 a -> BoundedPtr -> IO BoundedPtr
pokeRep = forall a. HasCallStack => [Char] -> a
error [Char]
"pokeRep: a value of a Void type should not exist"

instance PokeRep U1 where
    {-# INLINE pokeRep #-}
    pokeRep :: forall a. U1 a -> BoundedPtr -> IO BoundedPtr
pokeRep U1 a
_ BoundedPtr
x = forall (f :: * -> *) a. Applicative f => a -> f a
pure BoundedPtr
x

instance (PokeRep f, PokeRep g) => PokeRep (f :*: g) where
    {-# INLINE pokeRep #-}
    pokeRep :: forall a. (:*:) f g a -> BoundedPtr -> IO BoundedPtr
pokeRep (f a
f :*: g a
g) BoundedPtr
ptr = forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep f a
f BoundedPtr
ptr forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep g a
g

-------------------------------------------------------------------------------

class KnownNat n => PokeRepSum (n :: Nat) (f :: Type -> Type) where
    -- "n" is the constructor tag to be poked.
    pokeRepSum :: Proxy n -> f a -> BoundedPtr -> IO BoundedPtr

instance (KnownNat n, PokeRep a) => PokeRepSum n (C1 c a) where
    {-# INLINE pokeRepSum #-}
    pokeRepSum :: forall a. Proxy n -> C1 c a a -> BoundedPtr -> IO BoundedPtr
pokeRepSum Proxy n
_ C1 c a a
x BoundedPtr
ptr = do
        forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtr (forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n)) :: Word8) BoundedPtr
ptr
            forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep C1 c a a
x

instance (KnownNat n, PokeRepSum n f, PokeRepSum (n + SumArity f) g)
         => PokeRepSum n (f :+: g) where
    {-# INLINE pokeRepSum #-}
    pokeRepSum :: forall a. Proxy n -> (:+:) f g a -> BoundedPtr -> IO BoundedPtr
pokeRepSum Proxy n
_ (L1 f a
x) BoundedPtr
ptr =
        forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (forall {k} (t :: k). Proxy t
Proxy :: Proxy n) f a
x BoundedPtr
ptr
    pokeRepSum Proxy n
_ (R1 g a
x) BoundedPtr
ptr =
        forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity f)) g a
x BoundedPtr
ptr

-------------------------------------------------------------------------------

instance (MaxArity256 (SumArity (f :+: g)), PokeRepSum 0 (f :+: g)) =>
    PokeRep (f :+: g) where

    {-# INLINE pokeRep #-}
    pokeRep :: forall a. (:+:) f g a -> BoundedPtr -> IO BoundedPtr
pokeRep = forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (forall {k} (t :: k). Proxy t
Proxy :: Proxy 0)

{-# INLINE genericPokeObject #-}
genericPokeObject :: (Generic a, PokeRep (Rep a)) =>
    a -> BoundedPtr -> IO BoundedPtr
genericPokeObject :: forall a.
(Generic a, PokeRep (Rep a)) =>
a -> BoundedPtr -> IO BoundedPtr
genericPokeObject a
a = forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep (forall a x. Generic a => a -> Rep a x
from a
a)

genericPokeObj :: (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO ()
genericPokeObj :: forall a. (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO ()
genericPokeObj a
a BoundedPtr
ptr = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a.
(Generic a, PokeRep (Rep a)) =>
a -> BoundedPtr -> IO BoundedPtr
genericPokeObject a
a BoundedPtr
ptr

{-# INLINE genericPokeByteIndex #-}
genericPokeByteIndex :: (Generic a, PokeRep (Rep a)) =>
    MutableByteArray -> Int -> a -> IO ()
genericPokeByteIndex :: forall a.
(Generic a, PokeRep (Rep a)) =>
MutableByteArray -> Int -> a -> IO ()
genericPokeByteIndex MutableByteArray
arr Int
index a
x = do
    -- XXX Should we use unsafe poke?
    Int
end <- MutableByteArray -> IO Int
sizeOfMutableByteArray MutableByteArray
arr
    forall a. (Generic a, PokeRep (Rep a)) => a -> BoundedPtr -> IO ()
genericPokeObj a
x (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
index Int
end)

--------------------------------------------------------------------------------
-- Generic peek
--------------------------------------------------------------------------------

class PeekRep (f :: Type -> Type) where
    peekRep :: Peeker (f x)

instance PeekRep f => PeekRep (M1 i c f) where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker (M1 i c f x)
peekRep = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep

instance Unbox a => PeekRep (K1 i a) where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker (K1 i a x)
peekRep = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k i c (p :: k). c -> K1 i c p
K1 forall a. Unbox a => Peeker a
read

instance PeekRep V1 where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker (V1 x)
peekRep = forall a. HasCallStack => [Char] -> a
error [Char]
"peekRep: a value of a Void type should not exist"

instance PeekRep U1 where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker (U1 x)
peekRep = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall k (p :: k). U1 p
U1

instance (PeekRep f, PeekRep g) => PeekRep (f :*: g) where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker ((:*:) f g x)
peekRep = forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep

-------------------------------------------------------------------------------

class KnownNat n => PeekRepSum (n :: Nat) (f :: Type -> Type) where
    -- "n" is the constructor tag to be matched.
    peekRepSum :: Proxy n -> Word8 -> Peeker (f a)

instance (KnownNat n, PeekRep a) => PeekRepSum n (C1 c a) where
    {-# INLINE peekRepSum #-}
    peekRepSum :: forall a. Proxy n -> Word8 -> Peeker (C1 c a a)
peekRepSum Proxy n
_ Word8
tag
        | Word8
tag forall a. Eq a => a -> a -> Bool
== Word8
curTag = forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep
        | Word8
tag forall a. Ord a => a -> a -> Bool
> Word8
curTag =
            forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unbox instance peek: Constructor tag index "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word8
tag forall a. [a] -> [a] -> [a]
++ [Char]
" out of range, max tag index is "
                forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Word8
curTag
        | Bool
otherwise = forall a. HasCallStack => [Char] -> a
error [Char]
"peekRepSum: bug"

        where

        curTag :: Word8
curTag = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy n))

instance (KnownNat n, PeekRepSum n f, PeekRepSum (n + SumArity f) g)
         => PeekRepSum n (f :+: g) where
    {-# INLINE peekRepSum #-}
    peekRepSum :: forall a. Proxy n -> Word8 -> Peeker ((:+:) f g a)
peekRepSum Proxy n
curProxy Word8
tag
        | Word8
tag forall a. Ord a => a -> a -> Bool
< Word8
firstRightTag =
            forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (f :: * -> *) a.
PeekRepSum n f =>
Proxy n -> Word8 -> Peeker (f a)
peekRepSum Proxy n
curProxy Word8
tag
        | Bool
otherwise =
            forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (n :: Nat) (f :: * -> *) a.
PeekRepSum n f =>
Proxy n -> Word8 -> Peeker (f a)
peekRepSum (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity f)) Word8
tag

        where

        firstRightTag :: Word8
firstRightTag = forall a. Num a => Integer -> a
fromInteger (forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy :: Proxy (n + SumArity f)))

-------------------------------------------------------------------------------

instance (MaxArity256 (SumArity (f :+: g)), PeekRepSum 0 (f :+: g))
         => PeekRep (f :+: g) where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker ((:+:) f g x)
peekRep = do
        Word8
tag <- forall a. Unbox a => Peeker a
read
        forall (n :: Nat) (f :: * -> *) a.
PeekRepSum n f =>
Proxy n -> Word8 -> Peeker (f a)
peekRepSum (forall {k} (t :: k). Proxy t
Proxy :: Proxy 0) Word8
tag

{-# INLINE genericPeeker #-}
genericPeeker :: (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker :: forall a. (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker = forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep

{-# INLINE genericPeekBoundedPtr #-}
genericPeekBoundedPtr :: (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a
genericPeekBoundedPtr :: forall a. (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a
genericPeekBoundedPtr = forall a. Peeker a -> BoundedPtr -> IO a
runPeeker forall a. (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker

{-# INLINE genericPeekByteIndex #-}
genericPeekByteIndex :: (Generic a, PeekRep (Rep a)) =>
    MutableByteArray -> Int -> IO a
genericPeekByteIndex :: forall a.
(Generic a, PeekRep (Rep a)) =>
MutableByteArray -> Int -> IO a
genericPeekByteIndex MutableByteArray
arr Int
index = do
    -- XXX Should we use unsafe peek?
    Int
end <- MutableByteArray -> IO Int
sizeOfMutableByteArray MutableByteArray
arr
    forall a. (Generic a, PeekRep (Rep a)) => BoundedPtr -> IO a
genericPeekBoundedPtr (MutableByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutableByteArray
arr Int
index Int
end)