-- | '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) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s ->
  case forall d.
Int# -> Int# -> State# d -> (# State# d, MutableByteArray# d #)
newAlignedPinnedByteArray# Int#
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) = forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case touch# :: forall a. a -> State# RealWorld -> State# RealWorld
touch# MutableByteArray# RealWorld
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 (forall a. Addr# -> Ptr a
Ptr (ByteArray# -> Addr#
byteArrayContents# (unsafeCoerce# :: forall a b. a -> b
unsafeCoerce# MutableByteArray# RealWorld
mbarr))) 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) = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k (a :: k). Bytes -> ForeignPtr a
ForeignPtr 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 = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  ForeignPtr (Rec f ts)
ptr <- forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Rec f ts))
  forall k (g :: k -> *) (f :: k -> *) (ts :: [k]).
ForeignPtr (Rec f ts) -> SRec2 g f ts
SRec2 ForeignPtr (Rec f ts)
ptr forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
ptr (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Storable a => Ptr a -> a -> IO ()
poke Rec f ts
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 = forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. IO a -> a
inlinePerformIO (forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
ptr 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) = 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 = 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
fieldOffset @f @ts @t @i (Int
n forall a. Num a => a -> a -> a
+ forall a. Storable a => a -> Int
sizeOf (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
fieldOffset @f @ts @t Int
0 of
                     StorableAt Int
i -> forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr ->
                                       forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff Ptr Any
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
fieldOffset @f @ts @t Int
0 of
                   StorableAt Int
i -> forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ts)
fptr forall a b. (a -> b) -> a -> b
$ \Ptr Any
ptr ->
                                     forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr Any
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) = forall a. IO a -> a
inlinePerformIO (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
  ForeignPtr a
dst <- forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
n
  forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr a
src forall a b. (a -> b) -> a -> b
$ \Ptr Any
src' ->
    forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr a
dst forall a b. (a -> b) -> a -> b
$ \Ptr Any
dst' ->
      ForeignPtr a
dst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Any
dst' Ptr Any
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) = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
  let !n :: Int
n = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Rec f ts)
  ForeignPtr (Rec f ts)
dst <- forall {k} (a :: k). ForeignPtr a -> Int -> IO (ForeignPtr a)
mallocAndCopy ForeignPtr (Rec f ts)
src Int
n
  forall k (g :: k -> *) (f :: k -> *) (ts :: [k]).
ForeignPtr (Rec f ts) -> SRec2 g f ts
SRec2 ForeignPtr (Rec f ts)
dst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u} (f :: u -> *) (t :: u) (ts :: [u]).
FieldOffset f ts t =>
ForeignPtr (Rec f ts) -> f t -> IO ()
pokeField ForeignPtr (Rec f ts)
dst f t
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) = forall a. IO a -> a
unsafeDupablePerformIO (SRec2 f f ts
y forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 (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 = 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 = 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 = 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 = coerce :: 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 = coerce :: 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
coerceSRec2to1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} (f :: k -> *) (t :: k) (ts :: [k]).
FieldOffset f ts t =>
SRec2 f f ts -> f t
sget forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
coerceSRec2to1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
  ForeignPtr (Rec f rs)
dst <- forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Rec f rs))
  forall k (g :: k -> *) (f :: k -> *) (ts :: [k]).
ForeignPtr (Rec f ts) -> SRec2 g f ts
SRec2 ForeignPtr (Rec f rs)
dst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f rs)
dst forall a b. (a -> b) -> a -> b
$ \Ptr (Rec f rs)
dst' ->
                 forall {u} (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
rfoldMap @rs 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
rpureConstrained @(FieldOffset f ss) forall (t :: u). FieldOffset f ss t => (:.) IO f t
mkPeeker
        {-# INLINE peekers #-}
        mkPeeker :: FieldOffset f ss t => (IO :. f) t
        mkPeeker :: forall (t :: u). FieldOffset f ss t => (:.) IO f t
mkPeeker = forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (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
rpureConstrained @(FieldOffset f rs) (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
fieldOffset @f @rs @t Int
0 of
                        StorableAt Int
i -> 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 (forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO (f t)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO 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' = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke 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 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) = forall a. IO a -> a
unsafeDupablePerformIO forall a b. (a -> b) -> a -> b
$ do
  let n :: Int
n = forall a. Storable a => a -> Int
sizeOf (forall a. HasCallStack => a
undefined :: Rec f ss)
  ForeignPtr (Rec f ss)
dst <- forall {k} (a :: k). Int -> IO (ForeignPtr a)
mallocForeignPtrBytes Int
n
  forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ss)
srcBig forall a b. (a -> b) -> a -> b
$ \Ptr Any
srcBig' ->
    forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ss)
dst forall a b. (a -> b) -> a -> b
$ \Ptr Any
dst' ->
      forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Any
dst' Ptr Any
srcBig' Int
n
  forall k (g :: k -> *) (f :: k -> *) (ts :: [k]).
ForeignPtr (Rec f ts) -> SRec2 g f ts
SRec2 ForeignPtr (Rec f ss)
dst forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall {k} (a :: k) b r. ForeignPtr a -> (Ptr b -> IO r) -> IO r
withForeignPtr ForeignPtr (Rec f ss)
dst forall a b. (a -> b) -> a -> b
$ \Ptr (Rec f ss)
dst' ->
                 forall {u} (rs :: [u]) m (f :: u -> *).
(Monoid m, RFoldMap rs) =>
(forall (x :: u). f x -> m) -> Rec f rs -> m
rfoldMap @rs forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO
                           (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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: u). (:.) IO f t -> Poker f t -> TaggedIO t
peekNPoke 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 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
rpureConstrained @(FieldOffset f rs) forall (t :: u). FieldOffset f rs t => (:.) IO f t
mkPeeker
        {-# INLINE peekers #-}
        mkPeeker :: FieldOffset f rs t => (IO :. f) t
        mkPeeker :: forall (t :: u). FieldOffset f rs t => (:.) IO f t
mkPeeker = forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (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
rpureConstrained @(FieldOffset f ss) (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
fieldOffset @f @ss @t Int
0 of
                        StorableAt Int
i -> 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 (forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall {k} (a :: k). IO () -> TaggedIO a
TaggedIO (IO (f t)
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall {k} (a :: k). TaggedIO a -> IO ()
unTagIO 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)
_) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 = 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) = forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (record :: (k -> *) -> [k] -> *) (rs :: [k])
       (ss :: [k]) (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)
rsubsetC (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (f :: k -> *) (ts :: [k]). SRec f ts -> SRec2 f f ts
getSRecNT forall b c a. (b -> c) -> (a -> b) -> a -> c
. SRec f rs -> g (SRec f rs)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (ts :: [k]). SRec2 f f ts -> SRec f ts
SRecNT) SRec2 f f ss
s
  {-# INLINE rsubsetC #-}