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

-- |
-- Module      : Streamly.Internal.Data.Unbox
-- Copyright   : (c) 2023 Composewell Technologies
-- License     : BSD3-3-Clause
-- Maintainer  : streamly@composewell.com
-- Stability   : experimental
-- Portability : GHC
--
module Streamly.Internal.Data.Unbox
    (
    -- ** Unbox type class
      Unbox(..)

    -- ** Peek and poke utilities
    , BoundedPtr (..)
    -- Peek
    , Peeker (..)
    , read
    , readUnsafe
    , skipByte
    , runPeeker
    -- Poke
    , pokeBoundedPtrUnsafe
    , pokeBoundedPtr

    -- ** Generic Deriving
    , PeekRep(..)
    , PokeRep(..)
    , SizeOfRep(..)
    , genericSizeOf
    , genericPeekByteIndex
    , genericPokeByteIndex
    ) 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 GHC.Generics
import GHC.Exts
import GHC.TypeLits
import Prelude hiding (read)

import Streamly.Internal.Data.MutByteArray.Type (MutByteArray(..))
#ifdef DEBUG
import Streamly.Internal.Data.MutByteArray.Type (sizeOfMutableByteArray)
#endif

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

-- XXX generate error if the size is < 1

-- = Design notes =
--
-- == Fixed length data types ==
--
-- 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.
-- * recursive data types cannot be fixed length, therefore, cannot be
-- serialized using this type class.
-- * 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.
--
-- == Stream vs Array ==
--
-- In theory we could convert a type to and from a byte stream and use that
-- to implement boxing, unboxing. But composing a stream from parts of the
-- structure is much more inefficient than writing them to a memory location.
-- However, it should be possible to efficiently parse a Haskell type from an
-- array using chunk folds.
--
-- Also, this type class allows each primitive type to have its own specific
-- efficient implementation to read and write the type to the mutable byte
-- array using special GHC byte array operations. For example, see the Unbox
-- instances of Char, Int, Word types.
--
-- == MutableByteArray vs ForeignPtr ==
--
-- The Unbox typeclass 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.
--
-- == Byte Offset vs Element Index ==
--
-- 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 necessarily align with
-- the original type.
--
-- == Alignment ==
--
-- 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/
--
-- = Unboxed Records =
--
-- Unboxed types can be treated as unboxed records. We can provide a more
-- convenient API to access different parts from the Unboxed representation
-- without having to unbox the entire type. The type can have nested parts
-- therefore, we will need a general way (some sort of lenses) to address the
-- parts.
--
-- = Lazy Boxing =
--
-- When converting an unboxed representation to a boxed representation we can
-- use lazy construction. Each constructor of the constructed computation may
-- just hold a lazy computation to actually construct it on demand. This could
-- be useful for larger structures where we may need only small parts of it.
--
-- Same thing can be done for serialize type class as well but it will require
-- size fields at each nesting level, aggregating the size upwards.

-- | The 'Unbox' type class provides operations for serialization (unboxing)
-- and deserialization (boxing) of fixed-length, non-recursive Haskell data
-- types to and from their byte stream representation.
--
-- Unbox uses fixed size encoding, therefore, size is independent of the value,
-- it must be determined solely by the type. This restriction makes types with
-- 'Unbox' instances suitable for storing in arrays. Note that sum types may
-- have multiple constructors of different sizes, the size of a sum type is
-- computed as the maximum required by any constructor.
--
-- The 'peekAt' operation reads as many bytes from the mutable byte
-- array as the @size@ of the data type and builds a Haskell data type from
-- these bytes. 'pokeAt' operation converts a Haskell data type to its
-- binary representation which consists of @size@ bytes and then stores
-- these bytes into the mutable byte array. These operations do not check the
-- bounds of the array, the user of the type class is expected to check the
-- bounds before peeking or poking.
--
-- IMPORTANT: The serialized data's byte ordering remains the same as the host
-- machine's byte order. Therefore, it can not be deserialized from host
-- machines with a different byte ordering.
--
-- Instances can be derived via Generics, Template Haskell, or written
-- manually. Note that the data type must be non-recursive. WARNING! Generic
-- and Template Haskell deriving, both hang for recursive data types. Deriving
-- via Generics is more convenient but Template Haskell should be preferred
-- over Generics for the following reasons:
--
-- 1. Instances derived via Template Haskell provide better and more reliable
-- performance.
-- 2. Generic deriving allows only 256 fields or constructor tags whereas
-- template Haskell has no limit.
--
-- Here is an example, for deriving an instance of this type class using
-- generics:
--
-- >>> import GHC.Generics (Generic)
-- >>> :{
-- data Object = Object
--     { _int0 :: Int
--     , _int1 :: Int
--     } deriving Generic
-- :}
--
-- >>> import Streamly.Data.MutByteArray (Unbox(..))
-- >>> instance Unbox Object
--
-- To derive the instance via Template Haskell:
--
-- @
-- import Streamly.Data.MutByteArray (deriveUnbox)
-- \$(deriveUnbox [d|instance Unbox Object|])
-- @
--
-- See 'Streamly.Data.MutByteArray.deriveUnbox' for more information on deriving
-- using Template Haskell.
--
-- If you want to write the instance manually:
--
-- >>> :{
-- instance Unbox Object where
--     sizeOf _ = 16
--     peekAt i arr = do
--        -- Check the array bounds
--         x0 <- peekAt i arr
--         x1 <- peekAt (i + 8) arr
--         return $ Object x0 x1
--     pokeAt i arr (Object x0 x1) = do
--        -- Check the array bounds
--         pokeAt i arr x0
--         pokeAt (i + 8) arr x1
-- :}
--
class Unbox a where
    -- | Get the size. Size cannot be zero, should be at least 1 byte.
    sizeOf :: Proxy a -> Int

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

    -- | @peekAt byte-offset array@ reads an element of type @a@ from the
    -- the given the byte offset in the array.
    --
    -- IMPORTANT: The implementation of this interface may not check the bounds
    -- of the array, the caller must not assume that.
    peekAt :: Int -> MutByteArray -> IO a

    {-# INLINE peekAt #-}
    default peekAt :: (Generic a, PeekRep (Rep a)) =>
         Int -> MutByteArray -> IO a
    peekAt Int
i MutByteArray
arr = MutByteArray -> Int -> IO a
forall a.
(Generic a, PeekRep (Rep a)) =>
MutByteArray -> Int -> IO a
genericPeekByteIndex MutByteArray
arr Int
i

    peekByteIndex :: Int -> MutByteArray -> IO a
    peekByteIndex = Int -> MutByteArray -> IO a
forall a. Unbox a => Int -> MutByteArray -> IO a
peekAt

    -- | @pokeAt byte-offset array@ writes an element of type @a@ to the
    -- the given the byte offset in the array.
    --
    -- IMPORTANT: The implementation of this interface may not check the bounds
    -- of the array, the caller must not assume that.
    pokeAt :: Int -> MutByteArray -> a -> IO ()

    pokeByteIndex :: Int -> MutByteArray -> a -> IO ()
    pokeByteIndex = Int -> MutByteArray -> a -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt

    {-# INLINE pokeAt #-}
    default pokeAt :: (Generic a, PokeRep (Rep a)) =>
        Int -> MutByteArray -> a -> IO ()
    pokeAt Int
i MutByteArray
arr = MutByteArray -> Int -> a -> IO ()
forall a.
(Generic a, PokeRep (Rep a)) =>
MutByteArray -> Int -> a -> IO ()
genericPokeByteIndex MutByteArray
arr Int
i

{-# DEPRECATED peekByteIndex "Use peekAt." #-}
{-# DEPRECATED pokeByteIndex "Use pokeAt." #-}

-- _size is the length from array start to the last accessed byte.
{-# INLINE checkBounds #-}
checkBounds :: String -> Int -> MutByteArray -> IO ()
checkBounds :: String -> Int -> MutByteArray -> IO ()
checkBounds String
_label Int
_size MutByteArray
_arr = do
#ifdef DEBUG
    sz <- sizeOfMutableByteArray _arr
    if (_size > sz)
    then error
        $ _label
            ++ ": accessing array at offset = "
            ++ show (_size - 1)
            ++ " max valid offset = " ++ show (sz - 1)
    else return ()
#else
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif

#define DERIVE_UNBOXED(_type, _constructor, _readArray, _writeArray, _sizeOf) \
instance Unbox _type where {                                                  \
; {-# INLINE peekAt #-}                                                       \
; peekAt off@(I# n) arr@(MutByteArray mbarr) =                                \
    checkBounds "peek" (off + sizeOf (Proxy :: Proxy _type)) arr              \
    >> (IO $ \s ->                                                            \
      case _readArray mbarr n s of                                            \
          { (# s1, i #) -> (# s1, _constructor i #) })                        \
; {-# INLINE pokeAt #-}                                                       \
; pokeAt off@(I# n) arr@(MutByteArray mbarr) (_constructor val) =             \
    checkBounds "poke" (off + sizeOf (Proxy :: Proxy _type)) arr              \
    >> (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 peekAt #-}                                                       \
; peekAt i arr =                                                              \
    checkBounds "peek" (i + sizeOf (Proxy :: Proxy _type)) arr                \
    >> _constructor <$> peekAt i arr                                          \
; {-# INLINE pokeAt #-}                                                       \
; pokeAt i arr (_constructor a) =                                             \
    checkBounds "poke" (i + sizeOf (Proxy :: Proxy _type)) arr                \
    >> pokeAt i arr a                                                         \
; {-# INLINE sizeOf #-}                                                       \
; sizeOf _ = SIZE_OF(_innerType)

#define DERIVE_BINARY_UNBOX(_constraint, _type, _constructor, _innerType)     \
instance _constraint Unbox _type where {                                      \
; {-# INLINE peekAt #-}                                                       \
; peekAt i arr =                                                              \
      checkBounds "peek" (i + sizeOf (Proxy :: Proxy _type)) arr >>           \
      peekAt i arr >>=                                                        \
        (\p1 -> peekAt (i + SIZE_OF(_innerType)) arr <&> _constructor p1)     \
; {-# INLINE pokeAt #-}                                                       \
; pokeAt i arr (_constructor p1 p2) =                                         \
      checkBounds "poke" (i + sizeOf (Proxy :: Proxy _type)) arr >>           \
      pokeAt i arr p1 >>                                                      \
        pokeAt (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 peekAt #-}
    peekAt :: Int -> MutByteArray -> IO ()
peekAt Int
i MutByteArray
arr =
      String -> Int -> MutByteArray -> IO ()
checkBounds String
"peek ()" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy () -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy ()
forall {k} (t :: k). Proxy t
Proxy :: Proxy ())) MutByteArray
arr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    {-# INLINE pokeAt #-}
    pokeAt :: Int -> MutByteArray -> () -> IO ()
pokeAt Int
i MutByteArray
arr ()
_ =
      String -> Int -> MutByteArray -> IO ()
checkBounds String
"poke ()" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy () -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy ()
forall {k} (t :: k). Proxy t
Proxy :: Proxy ())) MutByteArray
arr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
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 peekAt #-}
    peekAt :: Int -> MutByteArray -> IO IoSubSystem
peekAt Int
i MutByteArray
arr =
        String -> Int -> MutByteArray -> IO ()
checkBounds
            String
"peek IoSubSystem" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy IoSubSystem -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy IoSubSystem
forall {k} (t :: k). Proxy t
Proxy :: Proxy IoSubSystem)) MutByteArray
arr
        IO () -> IO IoSubSystem -> IO IoSubSystem
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IoSubSystem
forall a. Enum a => Int -> a
toEnum (Int -> IoSubSystem) -> IO Int -> IO IoSubSystem
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> MutByteArray -> IO Int
forall a. Unbox a => Int -> MutByteArray -> IO a
peekAt Int
i MutByteArray
arr

    {-# INLINE pokeAt #-}
    pokeAt :: Int -> MutByteArray -> IoSubSystem -> IO ()
pokeAt Int
i MutByteArray
arr IoSubSystem
a =
        String -> Int -> MutByteArray -> IO ()
checkBounds
            String
"poke IoSubSystem" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy IoSubSystem -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy IoSubSystem
forall {k} (t :: k). Proxy t
Proxy :: Proxy IoSubSystem)) MutByteArray
arr
        IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> MutByteArray -> Int -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt Int
i MutByteArray
arr (IoSubSystem -> Int
forall a. Enum a => a -> Int
fromEnum IoSubSystem
a)

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

instance Unbox Bool where

    {-# INLINE peekAt #-}
    peekAt :: Int -> MutByteArray -> IO Bool
peekAt Int
i MutByteArray
arr = do
        String -> Int -> MutByteArray -> IO ()
checkBounds String
"peek Bool" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy Bool -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy Bool
forall {k} (t :: k). Proxy t
Proxy :: Proxy Bool)) MutByteArray
arr
        Int8
res <- Int -> MutByteArray -> IO Int8
forall a. Unbox a => Int -> MutByteArray -> IO a
peekAt Int
i MutByteArray
arr
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Int8
res Int8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
/= (Int8
0 :: Int8)

    {-# INLINE pokeAt #-}
    pokeAt :: Int -> MutByteArray -> Bool -> IO ()
pokeAt Int
i MutByteArray
arr Bool
a =
        String -> Int -> MutByteArray -> IO ()
checkBounds String
"poke Bool" (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy Bool -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy Bool
forall {k} (t :: k). Proxy t
Proxy :: Proxy Bool)) MutByteArray
arr
        IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> if Bool
a
           then Int -> MutByteArray -> Int8 -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt Int
i MutByteArray
arr (Int8
1 :: Int8)
           else Int -> MutByteArray -> Int8 -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt Int
i MutByteArray
arr (Int8
0 :: Int8)

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

--------------------------------------------------------------------------------
-- 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
        MutByteArray          -- 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 -> b) -> Peeker a -> Peeker b)
-> (forall a b. a -> Peeker b -> Peeker a) -> Functor Peeker
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
Functor Peeker
-> (forall a. a -> Peeker a)
-> (forall a b. Peeker (a -> b) -> Peeker a -> Peeker b)
-> (forall a b c.
    (a -> b -> c) -> Peeker a -> Peeker b -> Peeker c)
-> (forall a b. Peeker a -> Peeker b -> Peeker b)
-> (forall a b. Peeker a -> Peeker b -> Peeker a)
-> Applicative 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
Applicative Peeker
-> (forall a b. Peeker a -> (a -> Peeker b) -> Peeker b)
-> (forall a b. Peeker a -> Peeker b -> Peeker b)
-> (forall a. a -> Peeker a)
-> Monad 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 = Builder BoundedPtr IO a -> Peeker a
forall a. Builder BoundedPtr IO a -> Peeker a
Peeker ((BoundedPtr -> IO (a, BoundedPtr)) -> Builder BoundedPtr IO a
forall s (m :: * -> *) a. (s -> m (a, s)) -> Builder s m a
Builder BoundedPtr -> IO (a, BoundedPtr)
forall a. Unbox a => BoundedPtr -> IO (a, BoundedPtr)
step)

    where

    {-# INLINE step #-}
    step :: forall a. Unbox a => BoundedPtr -> IO (a, BoundedPtr)
    step :: forall a. Unbox a => BoundedPtr -> IO (a, BoundedPtr)
step (BoundedPtr MutByteArray
arr Int
pos Int
end) = do
        let next :: Int
next = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy a -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
#ifdef DEBUG
        when (next > end)
            $ error $ "readUnsafe: reading beyond limit. next = "
                ++ show next
                ++ " end = " ++ show end
#endif
        a
r <- Int -> MutByteArray -> IO a
forall a. Unbox a => Int -> MutByteArray -> IO a
peekAt Int
pos MutByteArray
arr
        (a, BoundedPtr) -> IO (a, BoundedPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
r, MutByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutByteArray
arr Int
next Int
end)

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

    where

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

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

    where

    {-# INLINE step #-}
    step :: BoundedPtr -> IO ((), BoundedPtr)
    step :: BoundedPtr -> IO ((), BoundedPtr)
step (BoundedPtr MutByteArray
arr Int
pos Int
end) = do
        let next :: Int
next = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
#ifdef DEBUG
        when (next > end)
            $ error $ "skipByte: reading beyond limit. next = "
                ++ show next
                ++ " end = " ++ show end
#endif
        ((), BoundedPtr) -> IO ((), BoundedPtr)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), MutByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutByteArray
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 (a, BoundedPtr)
f)) BoundedPtr
ptr = ((a, BoundedPtr) -> a) -> IO (a, BoundedPtr) -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a, BoundedPtr) -> a
forall a b. (a, b) -> a
fst (BoundedPtr -> IO (a, BoundedPtr)
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 MutByteArray
arr Int
pos Int
end) = do
    let next :: Int
next = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy a -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
#ifdef DEBUG
    when (next > end)
        $ error $ "pokeBoundedPtrUnsafe: reading beyond limit. next = "
            ++ show next
            ++ " end = " ++ show end
#endif
    Int -> MutByteArray -> a -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt Int
pos MutByteArray
arr a
a
    BoundedPtr -> IO BoundedPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (MutByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutByteArray
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 MutByteArray
arr Int
pos Int
end) = do
    let next :: Int
next = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Proxy a -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a)
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
next Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
end) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. HasCallStack => String -> a
error String
"pokeBoundedPtr writing beyond limit"
    Int -> MutByteArray -> a -> IO ()
forall a. Unbox a => Int -> MutByteArray -> a -> IO ()
pokeAt Int
pos MutByteArray
arr a
a
    BoundedPtr -> IO BoundedPtr
forall (m :: * -> *) a. Monad m => a -> m a
return (MutByteArray -> Int -> Int -> BoundedPtr
BoundedPtr MutByteArray
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.
-- Note that Arity starts from 1 and constructor tags start from 0. So if max
-- arity is 256 then max constructor tag would be 255.
-- XXX Use variable length encoding to support more than 256 constructors.
type MaxArity256 n = ArityCheck (n <=? 256)

--------------------------------------------------------------------------------
-- 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
_ = f Any -> Int
forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall {x}. f x
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
_ = Proxy a -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy a
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 = String -> V1 x -> Int
forall a. HasCallStack => String -> a
error String
"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
_ = f Any -> Int
forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall {x}. f x
forall a. HasCallStack => a
undefined :: f x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ g Any -> Int
forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall {x}. g x
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 = M1 C c a x -> Int
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
_ =
        Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (f Any -> Int
forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall {x}. f x
forall a. HasCallStack => a
undefined :: f x)) (g Any -> Int
forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall {x}. g x
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 account 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.
        Proxy Word8 -> Int
forall a. Unbox a => Proxy a -> Int
sizeOf (Proxy Word8
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word8) Int -> Int -> Int
forall a. Num a => a -> a -> a
+
            Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (f Any -> Int
forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall {x}. f x
forall a. HasCallStack => a
undefined :: f x))
                (g Any -> Int
forall (f :: * -> *) x. SizeOfRepSum f => f x -> Int
sizeOfRepSum (forall {x}. g x
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.
--
-- Some examples:
--
-- data B = B -- one byte
-- data A = A B -- one byte
-- data X = X1 | X2 -- one byte (constructor tag only)
--
{-# 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 = Rep a Any -> Int
forall (f :: * -> *) x. SizeOfRep f => f x -> Int
sizeOfRep (forall {x}. Rep a x
forall a. HasCallStack => a
undefined :: Rep a x)
      in if Int
s Int -> Int -> Bool
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 = f a -> BoundedPtr -> IO BoundedPtr
forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep (M1 i c f a -> f a
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 = a -> BoundedPtr -> IO BoundedPtr
forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtrUnsafe (K1 i a a -> a
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 = String -> V1 a -> BoundedPtr -> IO BoundedPtr
forall a. HasCallStack => String -> a
error String
"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 = BoundedPtr -> IO BoundedPtr
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 = f a -> BoundedPtr -> IO BoundedPtr
forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep f a
f BoundedPtr
ptr IO BoundedPtr -> (BoundedPtr -> IO BoundedPtr) -> IO BoundedPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= g a -> BoundedPtr -> IO BoundedPtr
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
        let tag :: Word8
tag = Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall {k} (t :: k). Proxy t
Proxy :: Proxy n)) :: Word8
        Word8 -> BoundedPtr -> IO BoundedPtr
forall a. Unbox a => a -> BoundedPtr -> IO BoundedPtr
pokeBoundedPtrUnsafe Word8
tag BoundedPtr
ptr IO BoundedPtr -> (BoundedPtr -> IO BoundedPtr) -> IO BoundedPtr
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= C1 c a a -> BoundedPtr -> IO BoundedPtr
forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep C1 c a a
x

instance (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 =
        Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (Proxy n
forall {k} (t :: k). Proxy t
Proxy :: Proxy n) f a
x BoundedPtr
ptr
    pokeRepSum Proxy n
_ (R1 g a
x) BoundedPtr
ptr =
        Proxy (n + SumArity f) -> g a -> BoundedPtr -> IO BoundedPtr
forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (Proxy (n + SumArity f)
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 = Proxy 0 -> (:+:) f g a -> BoundedPtr -> IO BoundedPtr
forall (n :: Nat) (f :: * -> *) a.
PokeRepSum n f =>
Proxy n -> f a -> BoundedPtr -> IO BoundedPtr
pokeRepSum (Proxy 0
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 = Rep a Any -> BoundedPtr -> IO BoundedPtr
forall (f :: * -> *) a.
PokeRep f =>
f a -> BoundedPtr -> IO BoundedPtr
pokeRep (a -> Rep a Any
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 = IO BoundedPtr -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO BoundedPtr -> IO ()) -> IO BoundedPtr -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> BoundedPtr -> IO BoundedPtr
forall a.
(Generic a, PokeRep (Rep a)) =>
a -> BoundedPtr -> IO BoundedPtr
genericPokeObject a
a BoundedPtr
ptr

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

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

class PeekRep (f :: Type -> Type) where
    -- Like pokeRep, we can use the following signature instead of using Peeker
    -- peekRep :: BoundedPtr -> IO (BoundedPtr, f a)
    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 = (f x -> M1 i c f x) -> Peeker (f x) -> Peeker (M1 i c f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f x -> M1 i c f x
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 Peeker (f x)
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 = (a -> K1 i a x) -> Peeker a -> Peeker (K1 i a x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a x
forall k i c (p :: k). c -> K1 i c p
K1 Peeker a
forall a. Unbox a => Peeker a
readUnsafe

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

instance PeekRep U1 where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker (U1 x)
peekRep = U1 x -> Peeker (U1 x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 x
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 = f x -> g x -> (:*:) f g x
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f x -> g x -> (:*:) f g x)
-> Peeker (f x) -> Peeker (g x -> (:*:) f g x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peeker (f x)
forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep Peeker (g x -> (:*:) f g x) -> Peeker (g x) -> Peeker ((:*:) f g x)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Peeker (g x)
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
_ = Peeker (M1 C c a a)
forall (f :: * -> *) x. PeekRep f => Peeker (f x)
peekRep
    {-
    -- These error checks are expensive, to avoid these
    -- we validate the max value of the tag in peekRep.
    -- XXX Add tests to cover all cases
    peekRepSum _ tag
        | tag == curTag = peekRep
        | tag > curTag =
            error $ "Unbox instance peek: Constructor tag index "
                ++ show tag ++ " out of range, max tag index is "
                ++ show curTag
        | otherwise = error "peekRepSum: bug"

        where

        curTag = fromInteger (natVal (Proxy :: Proxy n))
    -}

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

        where

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

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

instance ( MaxArity256 (SumArity (f :+: g))
         , KnownNat (SumArity (f :+: g))
         , PeekRepSum 0 (f :+: g))
         => PeekRep (f :+: g) where
    {-# INLINE peekRep #-}
    peekRep :: forall x. Peeker ((:+:) f g x)
peekRep = do
        Word8
tag :: Word8 <- Peeker Word8
forall a. Unbox a => Peeker a
readUnsafe
        -- XXX test with 256 and more constructors
        let Int
arity :: Int =
                Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Proxy (SumArity f + SumArity g) -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy (SumArity (f :+: g))
forall {k} (t :: k). Proxy t
Proxy :: Proxy (SumArity (f :+: g))))
        Bool -> Peeker () -> Peeker ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
arity)
            (Peeker () -> Peeker ()) -> Peeker () -> Peeker ()
forall a b. (a -> b) -> a -> b
$ String -> Peeker ()
forall a. HasCallStack => String -> a
error (String -> Peeker ()) -> String -> Peeker ()
forall a b. (a -> b) -> a -> b
$ String
"peek: Tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
tag
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is greater than the max tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for the data type"
        Proxy 0 -> Word8 -> Peeker ((:+:) f g x)
forall (n :: Nat) (f :: * -> *) a.
PeekRepSum n f =>
Proxy n -> Word8 -> Peeker (f a)
peekRepSum (Proxy 0
forall {k} (t :: k). Proxy t
Proxy :: Proxy 0) Word8
tag -- DataKinds

{-# INLINE genericPeeker #-}
genericPeeker :: (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker :: forall a. (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> Peeker (Rep a Any) -> Peeker a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Peeker (Rep a Any)
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 = Peeker a -> BoundedPtr -> IO a
forall a. Peeker a -> BoundedPtr -> IO a
runPeeker Peeker a
forall a. (Generic a, PeekRep (Rep a)) => Peeker a
genericPeeker

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