-- | 'Storable' records offer an efficient flat, packed representation
-- in memory. In particular, field access is constant time (i.e. it
-- doesn't depend on where in the record the field is) and as fast as
-- possible, but updating fields may not be as efficient. The
-- requirement is that all fields of a record have 'Storable'
-- instances.
--
-- The implementation leaks into the usual vinyl lens API: the
-- requirement of 'Storable' instances necessitates specialization on
-- the functor argument of the record so that GHC can find all
-- required instances at compile time (this is required for
-- constant-time field access). What we do is allow ourselves to write
-- instances of the 'RecElem' and 'RecSubset' classes (that provide
-- the main vinyl lens API) that are restricted to particular choices
-- of the record functor. This is why the 'SRec2' type that implements
-- records here takes two functor arguments: they will usually be the
-- same; we fix one when writing instances and write instance contexts
-- that reference that type, and then require that the methods
-- (e.g. 'rget') are called on records whose functor argument is equal
-- to the one we picked. For usability, we provide an 'SRec' type
-- whose lens API is fixed to 'ElField' as the functor. Other
-- specializations are possible, and the work of those instances can
-- always be passed along to the 'SRec2' functions.
--
-- Note that the lens field accessors for 'SRec' do not support
-- changing the types of the fields as they do for 'Rec' and
-- 'ARec'.
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
#if __GLASGOW_HASKELL__ < 806
{-# LANGUAGE TypeInType #-}
#endif

-- We get warnings about incomplete patterns on various class
-- instances.
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module Data.Vinyl.SRec (
  -- * Main record lens API
  SRec(..), toSRec, fromSRec
  -- * Lens API specialized to 'SRec2'
  , sget, sput, slens
  , srecGetSubset, srecSetSubset
  -- * Internals
  , toSRec2, fromSRec2, SRec2(..)
  , FieldOffset, FieldOffsetAux(..), StorableAt(..)
  , peekField, pokeField
) where
import Data.Coerce (coerce)
#if __GLASGOW_HASKELL__ < 806
import Data.Kind
#endif
import Data.Vinyl.Core
import Data.Vinyl.Functor (Lift(..), Compose(..), type (:.), ElField)
import Data.Vinyl.Lens (RecElem(..), RecSubset(..), type (⊆), RecElemFCtx)
import Data.Vinyl.TypeLevel (NatToInt, RImage, RIndex, Nat(..), RecAll, AllConstrained)
import Foreign.Marshal.Utils (copyBytes)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))
import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO)
#if __GLASGOW_HASKELL__ >= 900
import Unsafe.Coerce (unsafeCoerce#)
import GHC.Prim (touch#, RealWorld)
#else
import GHC.Prim (touch#, unsafeCoerce#, RealWorld)
#endif

import GHC.IO (IO(IO))
import GHC.Base (realWorld#)
import GHC.TypeLits (Symbol)
import GHC.Prim (MutableByteArray#, newAlignedPinnedByteArray#, byteArrayContents#)
import GHC.Ptr (Ptr(..))
import GHC.Types (Int(..))

-- * Byte array code adapted from the `memory` package.

data Bytes = Bytes (MutableByteArray# RealWorld)

newBytes :: Int -> IO Bytes
newBytes :: Int -> IO Bytes
newBytes (I# Int#
n) = (State# RealWorld -> (# State# RealWorld, Bytes #)) -> IO Bytes
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, Bytes #)) -> IO Bytes)
-> (State# RealWorld -> (# State# RealWorld, Bytes #)) -> IO Bytes
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case Int#
-> Int#
-> State# RealWorld
-> (# State# RealWorld, MutableByteArray# RealWorld #)
forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
n Int#
8# State# RealWorld
s of
    (# State# RealWorld
s', MutableByteArray# RealWorld
mbarr #) -> (# State# RealWorld
s', MutableByteArray# RealWorld -> Bytes
Bytes MutableByteArray# RealWorld
mbarr #)

touchBytes :: Bytes -> IO ()
touchBytes :: Bytes -> IO ()
touchBytes (Bytes MutableByteArray# RealWorld
mbarr) = (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case MutableByteArray# RealWorld -> State# RealWorld -> State# RealWorld
forall a d. a -> State# d -> State# d
touch# MutableByteArray# RealWorld
mbarr State# RealWorld
s of State# RealWorld
s' -> (# State# RealWorld
s', () #)
{-# INLINE touchBytes #-}

withBytesPtr :: Bytes -> (Ptr a -> IO r) -> IO r
withBytesPtr :: forall a r. Bytes -> (Ptr a -> IO r) -> IO r
withBytesPtr b :: Bytes
b@(Bytes MutableByteArray# RealWorld
mbarr) Ptr a -> IO r
f = do
  Ptr a -> IO r
f (Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# (MutableByteArray# RealWorld -> ByteArray#
forall a b. a -> b
unsafeCoerce# MutableByteArray# RealWorld
mbarr))) IO r -> IO () -> IO r
forall a b. IO a -> IO b -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Bytes -> IO ()
touchBytes Bytes
b
{-# INLINE withBytesPtr #-}

-- * Pun ForeignPtr names to ease refactoring

newtype ForeignPtr (a :: k) = ForeignPtr Bytes

withForeignPtr :: ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr :: forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr (ForeignPtr Bytes
b) = Bytes -> (Ptr b -> IO r) -> IO r
forall a r. Bytes -> (Ptr a -> IO r) -> IO r
withBytesPtr Bytes
b
{-# INLINE withForeignPtr #-}

mallocForeignPtrBytes :: Int -> IO (ForeignPtr a)
mallocForeignPtrBytes :: forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes = (Bytes -> ForeignPtr a) -> IO Bytes -> IO (ForeignPtr a)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bytes -> ForeignPtr a
forall k (a :: k). Bytes -> ForeignPtr a
ForeignPtr (IO Bytes -> IO (ForeignPtr a))
-> (Int -> IO Bytes) -> Int -> IO (ForeignPtr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO Bytes
newBytes
{-# INLINE mallocForeignPtrBytes #-}

-- * The SRec types

-- | A 'Storable'-backed 'Rec'. Each field of such a value has
-- statically known size, allowing for a very efficient representation
-- and very fast field access. The @2@ suffix is due to apparently
-- taking /two/ functor arguments, but the first type parameter is
-- phantom and exists so that we can write multiple instances of
-- 'RecElem' and 'RecSubset' for different functors. The first functor
-- argument will typically be identical to the second argument. We
-- currently provide instances for the 'ElField' functor; if you wish
-- to use it at a different type, consider using 'sget', 'sput', and
-- 'slens' which work with any functor given that the necessary
-- 'Storable' instances exist.
newtype SRec2 (g :: k -> *) (f :: k -> *) (ts :: [k]) =
  SRec2 (ForeignPtr (Rec f ts))

-- | A simpler type for 'SRec2' whose 'RecElem' and 'RecSubset'
-- instances are specialized to the 'ElField' functor.
newtype SRec f ts = SRecNT { forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
getSRecNT :: SRec2 f f ts }

-- | Create an 'SRec2' from a 'Rec'.
toSRec2 :: forall f ts. Storable (Rec f ts) => Rec f ts -> SRec2 f f ts
toSRec2 :: forall {k} (f :: k -> *) (ts :: [k]).
Storable (Rec f ts) =>
Rec f ts -> SRec2 f f ts
toSRec2 Rec f ts
x = IO (SRec2 f f ts) -> SRec2 f f ts
forall a. IO a -> a
unsafePerformIO (IO (SRec2 f f ts) -> SRec2 f f ts)
-> IO (SRec2 f f ts) -> SRec2 f f ts
forall a b. (a -> b) -> a -> b
$ do
  ptr <- Int -> IO (ForeignPtr (Rec f ts))
forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (Rec f ts -> Int
forall a. Storable a => a -> Int
sizeOf (Rec f ts
forall a. HasCallStack => a
undefined :: Rec f ts))
  SRec2 ptr <$ (withForeignPtr ptr (flip poke x))
{-# NOINLINE toSRec2 #-}

-- | Create an 'SRec' from a 'Rec'. This should offer very fast field
-- access, but note that its lens API (via 'RecElem' and 'RecSubset')
-- is restricted to the 'ElField' functor.
toSRec :: Storable (Rec f ts) => Rec f ts -> SRec f ts
toSRec :: forall {k} (f :: k -> *) (ts :: [k]).
Storable (Rec f ts) =>
Rec f ts -> SRec f ts
toSRec = SRec2 f f ts -> SRec f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT (SRec2 f f ts -> SRec f ts)
-> (Rec f ts -> SRec2 f f ts) -> Rec f ts -> SRec f ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec f ts -> SRec2 f f ts
forall {k} (f :: k -> *) (ts :: [k]).
Storable (Rec f ts) =>
Rec f ts -> SRec2 f f ts
toSRec2
{-# INLINE toSRec #-}

-- | Create a 'Rec' from an 'SRec2'.
fromSRec2 :: Storable (Rec f ts) => SRec2 g f ts -> Rec f ts
fromSRec2 :: forall {u} (f :: u -> *) (ts :: [u]) (g :: u -> *).
Storable (Rec f ts) =>
SRec2 g f ts -> Rec f ts
fromSRec2 (SRec2 ForeignPtr (Rec f ts)
ptr) = IO (Rec f ts) -> Rec f ts
forall a. IO a -> a
inlinePerformIO (ForeignPtr (Rec f ts)
-> (Ptr (Rec f ts) -> IO (Rec f ts)) -> IO (Rec f ts)
forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
ptr Ptr (Rec f ts) -> IO (Rec f ts)
forall a. Storable a => Ptr a -> IO a
peek)
{-# INLINE fromSRec2 #-}

-- | Create a 'Rec' from an 'SRec'.
fromSRec :: Storable (Rec f ts) => SRec f ts -> Rec f ts
fromSRec :: forall {u} (f :: u -> *) (ts :: [u]).
Storable (Rec f ts) =>
SRec f ts -> Rec f ts
fromSRec (SRecNT SRec2 f f ts
s) = SRec2 f f ts -> Rec f ts
forall {u} (f :: u -> *) (ts :: [u]) (g :: u -> *).
Storable (Rec f ts) =>
SRec2 g f ts -> Rec f ts
fromSRec2 SRec2 f f ts
s
{-# INLINE fromSRec #-}

-- | Just like unsafePerformIO, but we inline it. Big performance gains as
-- it exposes lots of things to further inlining. /Very unsafe/. In
-- particular, you should do no memory allocation inside an
-- 'inlinePerformIO' block. On Hugs this is just @unsafePerformIO@.
--
-- Copied from the @text@ package
{-# INLINE inlinePerformIO #-}
inlinePerformIO :: IO a -> a
inlinePerformIO :: forall a. IO a -> a
inlinePerformIO (IO State# RealWorld -> (# State# RealWorld, a #)
m) = case State# RealWorld -> (# State# RealWorld, a #)
m State# RealWorld
realWorld# of (# State# RealWorld
_, a
r #) -> a
r

-- | Capture a 'Storable' dictionary along with a byte offset from
-- some origin address.
data StorableAt f a where
  StorableAt :: Storable (f a) => {-# UNPACK  #-} !Int -> StorableAt f a

-- | The ability to work with a particular field of a 'Rec' stored at
-- a 'Ptr'.
class (RIndex t ts ~ i, RecAll f ts Storable) => FieldOffsetAux f ts t i where
  -- | Get the byte offset of a field from the given origin and the
  -- 'Storable' dictionary needed to work with that field.
  fieldOffset :: Int -> StorableAt f t

-- | A more concise constraint equivalent to 'FieldOffsetAux'.
class FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where
instance FieldOffsetAux f ts t (RIndex t ts) => FieldOffset f ts t where

instance (RecAll f (t ': ts) Storable) => FieldOffsetAux f (t ': ts) t 'Z where
  fieldOffset :: Int -> StorableAt f t
fieldOffset !Int
n = Int -> StorableAt f t
forall {k} (f :: k -> *) (a :: k).
Storable (f a) =>
Int -> StorableAt f a
StorableAt Int
n
  {-# INLINE fieldOffset #-}

instance (RIndex t (s ': ts) ~ 'S i,
          FieldOffsetAux f ts t i,
          RecAll f (s ': ts) Storable)
  => FieldOffsetAux f (s ': ts) t ('S i) where
  fieldOffset :: Int -> StorableAt f t
fieldOffset !Int
n = forall {k} (f :: k -> *) (ts :: [k]) (t :: k) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
forall (f :: a -> *) (ts :: [a]) (t :: a) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
fieldOffset @f @ts @t @i (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ f s -> Int
forall a. Storable a => a -> Int
sizeOf (f s
forall a. HasCallStack => a
undefined :: f s))
  {-# INLINE fieldOffset #-}

-- | Set a field in a record stored at a 'ForeignPtr'.
pokeField :: forall f t ts. FieldOffset f ts t
          => ForeignPtr (Rec f ts) -> f t -> IO ()
pokeField :: forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> f t -> IO ()
pokeField ForeignPtr (Rec f ts)
fptr f t
x = case forall {k} (f :: k -> *) (ts :: [k]) (t :: k) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
forall (f :: u -> *) (ts :: [u]) (t :: u) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
fieldOffset @f @ts @t Int
0 of
                     StorableAt Int
i -> ForeignPtr (Rec f ts) -> (Ptr (ZonkAny 0) -> IO ()) -> IO ()
forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
fptr ((Ptr (ZonkAny 0) -> IO ()) -> IO ())
-> (Ptr (ZonkAny 0) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 0)
ptr ->
                                       Ptr (ZonkAny 0) -> Int -> f t -> IO ()
forall b. Ptr b -> Int -> f t -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (ZonkAny 0)
ptr Int
i f t
x
{-# INLINE pokeField #-}

-- | Get a field in a record stored at a 'ForeignPtr'.
peekField :: forall f t ts. FieldOffset f ts t
          => ForeignPtr (Rec f ts) -> IO (f t)
peekField :: forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> IO (f t)
peekField ForeignPtr (Rec f ts)
fptr = case forall {k} (f :: k -> *) (ts :: [k]) (t :: k) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
forall (f :: u -> *) (ts :: [u]) (t :: u) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
fieldOffset @f @ts @t Int
0 of
                   StorableAt Int
i -> ForeignPtr (Rec f ts) -> (Ptr (ZonkAny 1) -> IO (f t)) -> IO (f t)
forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
fptr ((Ptr (ZonkAny 1) -> IO (f t)) -> IO (f t))
-> (Ptr (ZonkAny 1) -> IO (f t)) -> IO (f t)
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 1)
ptr ->
                                     Ptr (ZonkAny 1) -> Int -> IO (f t)
forall b. Ptr b -> Int -> IO (f t)
forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr (ZonkAny 1)
ptr Int
i
{-# INLINE peekField #-}

-- | Get a field from an 'SRec'.
sget :: forall f t ts. FieldOffset f ts t
     => SRec2 f f ts -> f t
sget :: forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
SRec2 f f ts -> f t
sget (SRec2 ForeignPtr (Rec f ts)
ptr) = IO (f t) -> f t
forall a. IO a -> a
inlinePerformIO (ForeignPtr (Rec f ts) -> IO (f t)
forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> IO (f t)
peekField ForeignPtr (Rec f ts)
ptr)
{-# INLINE sget #-}

mallocAndCopy :: ForeignPtr a -> Int -> IO (ForeignPtr a)
mallocAndCopy :: forall {k} (a :: k). ForeignPtr a -> Int -> IO (ForeignPtr a)
mallocAndCopy ForeignPtr a
src Int
n = do
  dst <- Int -> IO (ForeignPtr a)
forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
n
  withForeignPtr src $ \Ptr (ZonkAny 2)
src' ->
    ForeignPtr a
-> (Ptr (ZonkAny 2) -> IO (ForeignPtr a)) -> IO (ForeignPtr a)
forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr a
dst ((Ptr (ZonkAny 2) -> IO (ForeignPtr a)) -> IO (ForeignPtr a))
-> (Ptr (ZonkAny 2) -> IO (ForeignPtr a)) -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 2)
dst' ->
      ForeignPtr a
dst ForeignPtr a -> IO () -> IO (ForeignPtr a)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Ptr (ZonkAny 2) -> Ptr (ZonkAny 2) -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr (ZonkAny 2)
dst' Ptr (ZonkAny 2)
src' Int
n

-- | Set a field.
sput :: forall u (f :: u -> *) (t :: u) (ts :: [u]).
        ( FieldOffset f ts t
        , Storable (Rec f ts)
        , AllConstrained (FieldOffset f ts) ts)
     => f t -> SRec2 f f ts -> SRec2 f f ts
sput :: forall u (f :: u -> *) (t :: u) (ts :: [u]).
(FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
f t -> SRec2 f f ts -> SRec2 f f ts
sput !f t
x (SRec2 ForeignPtr (Rec f ts)
src) = IO (SRec2 f f ts) -> SRec2 f f ts
forall a. IO a -> a
unsafePerformIO (IO (SRec2 f f ts) -> SRec2 f f ts)
-> IO (SRec2 f f ts) -> SRec2 f f ts
forall a b. (a -> b) -> a -> b
$ do
  let !n :: Int
n = Rec f ts -> Int
forall a. Storable a => a -> Int
sizeOf (Rec f ts
forall a. HasCallStack => a
undefined :: Rec f ts)
  dst <- ForeignPtr (Rec f ts) -> Int -> IO (ForeignPtr (Rec f ts))
forall {k} (a :: k). ForeignPtr a -> Int -> IO (ForeignPtr a)
mallocAndCopy ForeignPtr (Rec f ts)
src Int
n
  SRec2 dst <$ pokeField dst x
{-# INLINE [1] sput #-}

pokeFieldUnsafe :: forall f t ts. FieldOffset f ts t
                => f t -> SRec2 f f ts -> SRec2 f f ts
pokeFieldUnsafe :: forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
f t -> SRec2 f f ts -> SRec2 f f ts
pokeFieldUnsafe f t
x y :: SRec2 f f ts
y@(SRec2 ForeignPtr (Rec f ts)
ptr) = IO (SRec2 f f ts) -> SRec2 f f ts
forall a. IO a -> a
unsafeDupablePerformIO (SRec2 f f ts
y SRec2 f f ts -> IO () -> IO (SRec2 f f ts)
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ForeignPtr (Rec f ts) -> f t -> IO ()
forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> f t -> IO ()
pokeField ForeignPtr (Rec f ts)
ptr f t
x)
{-# INLINE [1] pokeFieldUnsafe #-}

{-# RULES
"sput" forall x y z. sput x (sput y z) = pokeFieldUnsafe x (sput y z)
"sputUnsafe" forall x y z. sput x (pokeFieldUnsafe y z) = pokeFieldUnsafe x (pokeFieldUnsafe y z)
  #-}

-- | A lens for a field of an 'SRec2'.
slens :: ( Functor g
         , FieldOffset f ts t
         , Storable (Rec f ts)
         , AllConstrained (FieldOffset f ts) ts)
      => (f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
slens :: forall {k} (g :: * -> *) (f :: k -> *) (ts :: [k]) (t :: k).
(Functor g, FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
(f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
slens f t -> g (f t)
f SRec2 f f ts
sr = (f t -> SRec2 f f ts) -> g (f t) -> g (SRec2 f f ts)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f t -> SRec2 f f ts -> SRec2 f f ts)
-> SRec2 f f ts -> f t -> SRec2 f f ts
forall a b c. (a -> b -> c) -> b -> a -> c
flip f t -> SRec2 f f ts -> SRec2 f f ts
forall u (f :: u -> *) (t :: u) (ts :: [u]).
(FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
f t -> SRec2 f f ts -> SRec2 f f ts
sput SRec2 f f ts
sr) (f t -> g (f t)
f (SRec2 f f ts -> f t
forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
SRec2 f f ts -> f t
sget SRec2 f f ts
sr))
{-# INLINE slens #-}

-- Note: we need the functor to appear in the instance head so that we
-- can demand the needed 'Storable' instances. We do this by giving
-- 'SRec2' a phantom tag that duplicates the "real" functor parameter,
-- and define a constraint that the real argument is in fact
-- 'ElField'. This lets us write instances for different applications
-- of @SRec2@ (e.g. instance for @SRec2 Foo@ for records of type
-- @SRec2 Foo Foo ts@, and an instance for @SRec2 Bar@ for records of
-- type @SRec2 Bar Bar ts@).

-- | Field accessors for 'SRec2' specialized to 'ElField' as the
-- functor.
instance ( i ~ RIndex t ts
         , NatToInt i
         , FieldOffset ElField ts t
         , Storable (Rec ElField ts)
         , AllConstrained (FieldOffset ElField ts) ts)
  => RecElem (SRec2 ElField) t t ts ts i where
  type RecElemFCtx (SRec2 ElField) f = f ~ ElField
  rlensC :: forall (g :: * -> *) (f :: (Symbol, *) -> *).
(Functor g, RecElemFCtx (SRec2 ElField) f) =>
(f t -> g (f t)) -> SRec2 ElField f ts -> g (SRec2 ElField f ts)
rlensC = (f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
(f t -> g (f t)) -> SRec2 ElField f ts -> g (SRec2 ElField f ts)
forall {k} (g :: * -> *) (f :: k -> *) (ts :: [k]) (t :: k).
(Functor g, FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
(f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
slens
  {-# INLINE rlensC #-}
  rgetC :: forall (f :: (Symbol, *) -> *).
(RecElemFCtx (SRec2 ElField) f, t ~ t) =>
SRec2 ElField f ts -> f t
rgetC = SRec2 ElField f ts -> f t
SRec2 ElField ElField ts -> ElField t
forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
SRec2 f f ts -> f t
sget
  {-# INLINE rgetC #-}
  rputC :: forall (f :: (Symbol, *) -> *).
RecElemFCtx (SRec2 ElField) f =>
f t -> SRec2 ElField f ts -> SRec2 ElField f ts
rputC = f t -> SRec2 f f ts -> SRec2 f f ts
f t -> SRec2 ElField f ts -> SRec2 ElField f ts
forall u (f :: u -> *) (t :: u) (ts :: [u]).
(FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
f t -> SRec2 f f ts -> SRec2 f f ts
sput
  {-# INLINE rputC #-}


coerceSRec1to2 :: SRec f ts -> SRec2 f f ts
coerceSRec1to2 :: forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
coerceSRec1to2 = SRec f ts -> SRec2 f f ts
forall a b. Coercible a b => a -> b
coerce

coerceSRec2to1 :: SRec2 f f ts -> SRec f ts
coerceSRec2to1 :: forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
coerceSRec2to1 = SRec2 f f ts -> SRec f ts
forall a b. Coercible a b => a -> b
coerce

instance ( i ~ RIndex (t :: (Symbol,*)) (ts :: [(Symbol,*)])
         , NatToInt i
         , FieldOffset ElField ts t
         , Storable (Rec ElField ts)
         , AllConstrained (FieldOffset ElField ts) ts)
  => RecElem SRec (t :: (Symbol,*)) t (ts :: [(Symbol,*)]) ts i where
  type RecElemFCtx SRec f = f ~ ElField
  rlensC :: forall (g :: * -> *) (f :: (Symbol, *) -> *).
(Functor g, RecElemFCtx SRec f) =>
(f t -> g (f t)) -> SRec f ts -> g (SRec f ts)
rlensC f t -> g (f t)
f = (SRec2 f f ts -> SRec f ts) -> g (SRec2 f f ts) -> g (SRec f ts)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SRec2 f f ts -> SRec f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
coerceSRec2to1 (g (SRec2 f f ts) -> g (SRec f ts))
-> (SRec f ts -> g (SRec2 f f ts)) -> SRec f ts -> g (SRec f ts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
forall {k} (g :: * -> *) (f :: k -> *) (ts :: [k]) (t :: k).
(Functor g, FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
(f t -> g (f t)) -> SRec2 f f ts -> g (SRec2 f f ts)
slens f t -> g (f t)
f (SRec2 f f ts -> g (SRec2 f f ts))
-> (SRec f ts -> SRec2 f f ts) -> SRec f ts -> g (SRec2 f f ts)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec f ts -> SRec2 f f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
coerceSRec1to2
  {-# INLINE rlensC #-}
  rgetC :: forall (f :: (Symbol, *) -> *).
(RecElemFCtx SRec f, t ~ t) =>
SRec f ts -> f t
rgetC = SRec2 f f ts -> f t
forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
SRec2 f f ts -> f t
sget (SRec2 f f ts -> f t)
-> (SRec f ts -> SRec2 f f ts) -> SRec f ts -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec f ts -> SRec2 f f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
coerceSRec1to2
  {-# INLINE rgetC #-}
  rputC :: forall (f :: (Symbol, *) -> *).
RecElemFCtx SRec f =>
f t -> SRec f ts -> SRec f ts
rputC f t
x = SRec2 f f ts -> SRec f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
coerceSRec2to1 (SRec2 f f ts -> SRec f ts)
-> (SRec f ts -> SRec2 f f ts) -> SRec f ts -> SRec f ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f t -> SRec2 f f ts -> SRec2 f f ts
forall u (f :: u -> *) (t :: u) (ts :: [u]).
(FieldOffset f ts t, Storable (Rec f ts),
 AllConstrained (FieldOffset f ts) ts) =>
f t -> SRec2 f f ts -> SRec2 f f ts
sput f t
x (SRec2 f f ts -> SRec2 f f ts)
-> (SRec f ts -> SRec2 f f ts) -> SRec f ts -> SRec2 f f ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec f ts -> SRec2 f f ts
forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
coerceSRec1to2
  {-# INLINE rputC #-}

-- | Get a subset of a record's fields.
srecGetSubset :: forall u (ss :: [u]) (rs :: [u]) (f :: u -> *).
                 (RPureConstrained (FieldOffset f ss) rs,
                  RPureConstrained (FieldOffset f rs) rs,
                  RFoldMap rs, RMap rs, RApply rs,
                  Storable (Rec f rs))
              => SRec2 f f ss -> SRec2 f f rs
srecGetSubset :: forall u (ss :: [u]) (rs :: [u]) (f :: u -> *).
(RPureConstrained (FieldOffset f ss) rs,
 RPureConstrained (FieldOffset f rs) rs, RFoldMap rs, RMap rs,
 RApply rs, Storable (Rec f rs)) =>
SRec2 f f ss -> SRec2 f f rs
srecGetSubset (SRec2 ForeignPtr (Rec f ss)
ptr) = IO (SRec2 f f rs) -> SRec2 f f rs
forall a. IO a -> a
unsafeDupablePerformIO (IO (SRec2 f f rs) -> SRec2 f f rs)
-> IO (SRec2 f f rs) -> SRec2 f f rs
forall a b. (a -> b) -> a -> b
$ do
  dst <- Int -> IO (ForeignPtr (Rec f rs))
forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (Rec f rs -> Int
forall a. Storable a => a -> Int
sizeOf (Rec f rs
forall a. HasCallStack => a
undefined :: Rec f rs))
  SRec2 dst <$ (withForeignPtr dst $ \Ptr (Rec f rs)
dst' ->
                 forall (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
forall {u} (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
rfoldMap @rs TaggedIO x -> IO ()
forall (x :: u). TaggedIO x -> IO ()
forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO (Ptr (Rec f rs) -> Rec TaggedIO rs
peekSmallPokeBig Ptr (Rec f rs)
dst'))
  where peekers :: Rec (IO :. f) rs
        peekers :: Rec (IO :. f) rs
peekers = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
forall (c :: u -> Constraint) (ts :: [u]) (f :: u -> *).
RPureConstrained c ts =>
(forall (a :: u). c a => f a) -> Rec f ts
rpureConstrained @(FieldOffset f ss) (:.) IO f a
forall (a :: u). FieldOffset f ss a => (:.) IO f a
mkPeeker
        {-# INLINE peekers #-}
        mkPeeker :: FieldOffset f ss t => (IO :. f) t
        mkPeeker :: forall (a :: u). FieldOffset f ss a => (:.) IO f a
mkPeeker = IO (f t) -> Compose IO f t
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (ForeignPtr (Rec f ss) -> IO (f t)
forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> IO (f t)
peekField ForeignPtr (Rec f ss)
ptr)
        {-# INLINE mkPeeker #-}
        pokers :: Ptr (Rec f rs) -> Rec (Poker f) rs
        pokers :: Ptr (Rec f rs) -> Rec (Poker f) rs
pokers Ptr (Rec f rs)
dst = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
forall (c :: u -> Constraint) (ts :: [u]) (f :: u -> *).
RPureConstrained c ts =>
(forall (a :: u). c a => f a) -> Rec f ts
rpureConstrained @(FieldOffset f rs) (Ptr (Rec f rs) -> FieldOffset f rs a => Poker f a
forall (t :: u). Ptr (Rec f rs) -> FieldOffset f rs t => Poker f t
mkPoker Ptr (Rec f rs)
dst)
        {-# INLINE pokers #-}
        mkPoker :: forall t. Ptr (Rec f rs) -> FieldOffset f rs t => Poker f t
        mkPoker :: forall (t :: u). Ptr (Rec f rs) -> FieldOffset f rs t => Poker f t
mkPoker Ptr (Rec f rs)
dst = case forall {k} (f :: k -> *) (ts :: [k]) (t :: k) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
forall (f :: u -> *) (ts :: [u]) (t :: u) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
fieldOffset @f @rs @t Int
0 of
                        StorableAt Int
i -> (f t -> TaggedIO t) -> Poker f t
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift (IO () -> TaggedIO t
forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO () -> TaggedIO t) -> (f t -> IO ()) -> f t -> TaggedIO t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (Rec f rs) -> Int -> f t -> IO ()
forall b. Ptr b -> Int -> f t -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Rec f rs)
dst Int
i)
        {-# INLINE mkPoker #-}
        peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t
        peekNPoke :: forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke (Compose IO (f t)
m) (Lift f t -> TaggedIO t
f) = IO () -> TaggedIO t
forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO (f t)
m IO (f t) -> (f t -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TaggedIO t -> IO ()
forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO (TaggedIO t -> IO ()) -> (f t -> TaggedIO t) -> f t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f t -> TaggedIO t
f)
        {-# INLINE peekNPoke #-}
        peekSmallPokeBig :: Ptr (Rec f rs) -> Rec TaggedIO rs
        peekSmallPokeBig :: Ptr (Rec f rs) -> Rec TaggedIO rs
peekSmallPokeBig Ptr (Rec f rs)
dst' = (Poker f x -> TaggedIO x) -> Lift (->) (Poker f) TaggedIO x
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift ((Poker f x -> TaggedIO x) -> Lift (->) (Poker f) TaggedIO x)
-> ((:.) IO f x -> Poker f x -> TaggedIO x)
-> (:.) IO f x
-> Lift (->) (Poker f) TaggedIO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.) IO f x -> Poker f x -> TaggedIO x
forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke (forall {x :: u}. (:.) IO f x -> Lift (->) (Poker f) TaggedIO x)
-> Rec (IO :. f) rs -> Rec (Lift (->) (Poker f) TaggedIO) rs
forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
<<$>> Rec (IO :. f) rs
peekers Rec (Lift (->) (Poker f) TaggedIO) rs
-> Rec (Poker f) rs -> Rec TaggedIO rs
forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
<<*>> Ptr (Rec f rs) -> Rec (Poker f) rs
pokers Ptr (Rec f rs)
dst'
{-# INLINE srecGetSubset #-}

-- | Phantom tagged 'IO ()' value. Used to work with vinyl's 'Lift'
-- that wants @forall a. f a -> g a@.
newtype TaggedIO a = TaggedIO { forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO :: IO () }

-- | A dressed up function of type @f a -> IO ()@
type Poker f = Lift (->) f TaggedIO

-- | Set a subset of a record's fields.
srecSetSubset :: forall u (f :: u -> *) (ss :: [u]) (rs :: [u]).
                 (rs ⊆ ss,
                  RPureConstrained (FieldOffset f ss) rs,
                  RPureConstrained (FieldOffset f rs) rs,
                  RFoldMap rs, RMap rs, RApply rs,
                  Storable (Rec f ss))
              => SRec2 f f ss -> SRec2 f f rs -> SRec2 f f ss
srecSetSubset :: forall u (f :: u -> *) (ss :: [u]) (rs :: [u]).
(rs ⊆ ss, RPureConstrained (FieldOffset f ss) rs,
 RPureConstrained (FieldOffset f rs) rs, RFoldMap rs, RMap rs,
 RApply rs, Storable (Rec f ss)) =>
SRec2 f f ss -> SRec2 f f rs -> SRec2 f f ss
srecSetSubset (SRec2 ForeignPtr (Rec f ss)
srcBig) (SRec2 ForeignPtr (Rec f rs)
srcSmall) = IO (SRec2 f f ss) -> SRec2 f f ss
forall a. IO a -> a
unsafeDupablePerformIO (IO (SRec2 f f ss) -> SRec2 f f ss)
-> IO (SRec2 f f ss) -> SRec2 f f ss
forall a b. (a -> b) -> a -> b
$ do
  let n :: Int
n = Rec f ss -> Int
forall a. Storable a => a -> Int
sizeOf (Rec f ss
forall a. HasCallStack => a
undefined :: Rec f ss)
  dst <- Int -> IO (ForeignPtr (Rec f ss))
forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
n
  withForeignPtr srcBig $ \Ptr (ZonkAny 3)
srcBig' ->
    ForeignPtr (Rec f ss) -> (Ptr (ZonkAny 3) -> IO ()) -> IO ()
forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ss)
dst ((Ptr (ZonkAny 3) -> IO ()) -> IO ())
-> (Ptr (ZonkAny 3) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr (ZonkAny 3)
dst' ->
      Ptr (ZonkAny 3) -> Ptr (ZonkAny 3) -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr (ZonkAny 3)
dst' Ptr (ZonkAny 3)
srcBig' Int
n
  SRec2 dst <$ (withForeignPtr dst $ \Ptr (Rec f ss)
dst' ->
                 forall (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
forall {u} (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
rfoldMap @rs TaggedIO x -> IO ()
forall (x :: u). TaggedIO x -> IO ()
forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO
                           ((Poker f x -> TaggedIO x) -> Lift (->) (Poker f) TaggedIO x
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift ((Poker f x -> TaggedIO x) -> Lift (->) (Poker f) TaggedIO x)
-> ((:.) IO f x -> Poker f x -> TaggedIO x)
-> (:.) IO f x
-> Lift (->) (Poker f) TaggedIO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.) IO f x -> Poker f x -> TaggedIO x
forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke (forall {x :: u}. (:.) IO f x -> Lift (->) (Poker f) TaggedIO x)
-> Rec (IO :. f) rs -> Rec (Lift (->) (Poker f) TaggedIO) rs
forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
<<$>> Rec (IO :. f) rs
peekers Rec (Lift (->) (Poker f) TaggedIO) rs
-> Rec (Poker f) rs -> Rec TaggedIO rs
forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
<<*>> Ptr (Rec f ss) -> Rec (Poker f) rs
pokers Ptr (Rec f ss)
dst'))
  where peekers :: Rec (IO :. f) rs
        peekers :: Rec (IO :. f) rs
peekers = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
forall (c :: u -> Constraint) (ts :: [u]) (f :: u -> *).
RPureConstrained c ts =>
(forall (a :: u). c a => f a) -> Rec f ts
rpureConstrained @(FieldOffset f rs) (:.) IO f a
forall (a :: u). FieldOffset f rs a => (:.) IO f a
mkPeeker
        {-# INLINE peekers #-}
        mkPeeker :: FieldOffset f rs t => (IO :. f) t
        mkPeeker :: forall (a :: u). FieldOffset f rs a => (:.) IO f a
mkPeeker = IO (f t) -> Compose IO f t
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (ForeignPtr (Rec f rs) -> IO (f t)
forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> IO (f t)
peekField ForeignPtr (Rec f rs)
srcSmall)

        pokers :: Ptr (Rec f ss) -> Rec (Poker f) rs
        pokers :: Ptr (Rec f ss) -> Rec (Poker f) rs
pokers Ptr (Rec f ss)
dst = forall {k} (c :: k -> Constraint) (ts :: [k]) (f :: k -> *).
RPureConstrained c ts =>
(forall (a :: k). c a => f a) -> Rec f ts
forall (c :: u -> Constraint) (ts :: [u]) (f :: u -> *).
RPureConstrained c ts =>
(forall (a :: u). c a => f a) -> Rec f ts
rpureConstrained @(FieldOffset f ss) (Ptr (Rec f ss) -> Poker f a
forall (t :: u). FieldOffset f ss t => Ptr (Rec f ss) -> Poker f t
mkPoker Ptr (Rec f ss)
dst)
        {-# INLINE pokers #-}
        mkPoker :: forall t. FieldOffset f ss t => Ptr (Rec f ss) -> Poker f t
        mkPoker :: forall (t :: u). FieldOffset f ss t => Ptr (Rec f ss) -> Poker f t
mkPoker Ptr (Rec f ss)
dst = case forall {k} (f :: k -> *) (ts :: [k]) (t :: k) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
forall (f :: u -> *) (ts :: [u]) (t :: u) (i :: Nat).
FieldOffsetAux f ts t i =>
Int -> StorableAt f t
fieldOffset @f @ss @t Int
0 of
                        StorableAt Int
i -> (f t -> TaggedIO t) -> Poker f t
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift (IO () -> TaggedIO t
forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO () -> TaggedIO t) -> (f t -> IO ()) -> f t -> TaggedIO t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr (Rec f ss) -> Int -> f t -> IO ()
forall b. Ptr b -> Int -> f t -> IO ()
forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr (Rec f ss)
dst Int
i)
        {-# INLINE mkPoker #-}
        peekNPoke :: (IO :. f) t -> Poker f t -> TaggedIO t
        peekNPoke :: forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke (Compose IO (f t)
m) (Lift f t -> TaggedIO t
f) = IO () -> TaggedIO t
forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO (f t)
m IO (f t) -> (f t -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TaggedIO t -> IO ()
forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO (TaggedIO t -> IO ()) -> (f t -> TaggedIO t) -> f t -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f t -> TaggedIO t
f)
        {-# INLINE peekNPoke #-}
{-# INLINE srecSetSubset #-}

instance (is ~ RImage rs ss,
          RecSubset Rec rs ss is,
          Storable (Rec ElField rs),
          Storable (Rec ElField ss),
          RPureConstrained (FieldOffset ElField ss) rs,
          RPureConstrained (FieldOffset ElField rs) rs,
          RFoldMap rs, RMap rs, RApply rs)
  => RecSubset (SRec2 ElField) rs ss is where
  type RecSubsetFCtx (SRec2 ElField) f = f ~ ElField
  rsubsetC :: forall g. Functor g
           => (SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs))
           -> SRec2 ElField ElField ss
           -> g (SRec2 ElField ElField ss)
  rsubsetC :: forall (g :: * -> *).
Functor g =>
(SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs))
-> SRec2 ElField ElField ss -> g (SRec2 ElField ElField ss)
rsubsetC SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs)
f big :: SRec2 ElField ElField ss
big@(SRec2 ForeignPtr (Rec ElField ss)
_) = (SRec2 ElField ElField rs -> SRec2 ElField ElField ss)
-> g (SRec2 ElField ElField rs) -> g (SRec2 ElField ElField ss)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SRec2 ElField ElField ss
-> SRec2 ElField ElField rs -> SRec2 ElField ElField ss
forall u (f :: u -> *) (ss :: [u]) (rs :: [u]).
(rs ⊆ ss, RPureConstrained (FieldOffset f ss) rs,
 RPureConstrained (FieldOffset f rs) rs, RFoldMap rs, RMap rs,
 RApply rs, Storable (Rec f ss)) =>
SRec2 f f ss -> SRec2 f f rs -> SRec2 f f ss
srecSetSubset SRec2 ElField ElField ss
big) (SRec2 ElField ElField rs -> g (SRec2 ElField ElField rs)
f SRec2 ElField ElField rs
smallRec)
    where smallRec :: SRec2 ElField ElField rs
          smallRec :: SRec2 ElField ElField rs
smallRec = SRec2 ElField ElField ss -> SRec2 ElField ElField rs
forall u (ss :: [u]) (rs :: [u]) (f :: u -> *).
(RPureConstrained (FieldOffset f ss) rs,
 RPureConstrained (FieldOffset f rs) rs, RFoldMap rs, RMap rs,
 RApply rs, Storable (Rec f rs)) =>
SRec2 f f ss -> SRec2 f f rs
srecGetSubset SRec2 ElField ElField ss
big
          {-# INLINE smallRec #-}
  {-# INLINE rsubsetC #-}

instance (is ~ RImage rs ss,
          RecSubset Rec rs ss is,
          Storable (Rec ElField rs),
          Storable (Rec ElField ss),
          RPureConstrained (FieldOffset ElField ss) rs,
          RPureConstrained (FieldOffset ElField rs) rs,
          RFoldMap rs, RMap rs, RApply rs)
  => RecSubset SRec rs ss is where
  type RecSubsetFCtx SRec f = f ~ ElField
  rsubsetC :: forall (g :: * -> *) (f :: (Symbol, *) -> *).
(Functor g, RecSubsetFCtx SRec f) =>
(SRec f rs -> g (SRec f rs)) -> SRec f ss -> g (SRec f ss)
rsubsetC SRec f rs -> g (SRec f rs)
f (SRecNT SRec2 f f ss
s) = SRec2 f f ss -> SRec f ss
forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT (SRec2 f f ss -> SRec f ss) -> g (SRec2 f f ss) -> g (SRec f ss)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SRec2 f f rs -> g (SRec2 f f rs))
-> SRec2 f f ss -> g (SRec2 f f ss)
forall {k} {k1} (record :: (k -> *) -> [k1] -> *) (rs :: [k1])
       (ss :: [k1]) (is :: [Nat]) (g :: * -> *) (f :: k -> *).
(RecSubset record rs ss is, Functor g, RecSubsetFCtx record f) =>
(record f rs -> g (record f rs)) -> record f ss -> g (record f ss)
forall (g :: * -> *) (f :: (Symbol, *) -> *).
(Functor g, RecSubsetFCtx (SRec2 f) f) =>
(SRec2 f f rs -> g (SRec2 f f rs))
-> SRec2 f f ss -> g (SRec2 f f ss)
rsubsetC ((SRec f rs -> SRec2 f f rs) -> g (SRec f rs) -> g (SRec2 f f rs)
forall a b. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SRec f rs -> SRec2 f f rs
forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
getSRecNT (g (SRec f rs) -> g (SRec2 f f rs))
-> (SRec2 f f rs -> g (SRec f rs))
-> SRec2 f f rs
-> g (SRec2 f f rs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec f rs -> g (SRec f rs)
f (SRec f rs -> g (SRec f rs))
-> (SRec2 f f rs -> SRec f rs) -> SRec2 f f rs -> g (SRec f rs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec2 f f rs -> SRec f rs
forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT) SRec2 f f ss
s
  {-# INLINE rsubsetC #-}