-- |
-- Copyright: (C) 2016 Tweag I/O Limited.

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}

module Data.Vector.SEXP.Mutable.Internal
  ( MVector(..)
  , W(..)
  , withW
  , proxyW
  , unsafeToPtr
  , release
  , unsafeRelease
  ) where

import Control.Memory.Region
import qualified Foreign.R as R

import Control.Monad.Primitive (unsafePrimToPrim)
import Control.Monad.R.Internal
import Data.Int (Int32)
import Data.Proxy (Proxy(..))
import Data.Reflection (Reifies(..))
import Data.Singletons (fromSing, sing)
import qualified Data.Vector.Generic.Mutable as G
import Data.Vector.SEXP.Base
import Foreign (Storable(..), Ptr, castPtr)
import Foreign.Marshal.Array (advancePtr, copyArray, moveArray)
import Foreign.R (SEXP)
import Foreign.R.Type (SSEXPTYPE)
import Internal.Error

-- | Mutable R vector. Represented in memory with the same header as 'SEXP'
-- nodes. The second type parameter is phantom, reflecting at the type level the
-- tag of the vector when viewed as a 'SEXP'. The tag of the vector and the
-- representation type are related via 'ElemRep'.
data MVector s ty a = MVector
  { MVector s ty a -> SEXP s ty
mvectorBase :: {-# UNPACK #-} !(SEXP s ty)
  , MVector s ty a -> Int32
mvectorOffset :: {-# UNPACK #-} !Int32
  , MVector s ty a -> Int32
mvectorLength :: {-# UNPACK #-} !Int32
  }

-- | Internal wrapper type for reflection. First type parameter is the reified
-- type to reflect.
newtype W t ty s a = W { W t ty s a -> MVector s ty a
unW :: MVector s ty a }

instance (Reifies t (AcquireIO s), VECTOR s ty a) => G.MVector (W t ty) a where
#if MIN_VERSION_vector(0,11,0)
  basicInitialize :: W t ty (PrimState m) a -> m ()
basicInitialize _ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
  {-# INLINE basicLength #-}
  basicLength :: W t ty s a -> Int
basicLength (W t ty s a -> MVector s ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector _ _ len :: Int32
len) = Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len

  {-# INLINE basicUnsafeSlice #-}
  basicUnsafeSlice :: Int -> Int -> W t ty s a -> W t ty s a
basicUnsafeSlice j :: Int
j m :: Int
m (W t ty s a -> MVector s ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector ptr :: SEXP s ty
ptr off :: Int32
off _len :: Int32
_len) =
      MVector s ty a -> W t ty s a
forall t (ty :: SEXPTYPE) s a. MVector s ty a -> W t ty s a
W (MVector s ty a -> W t ty s a) -> MVector s ty a -> W t ty s a
forall a b. (a -> b) -> a -> b
$ SEXP s ty -> Int32 -> Int32 -> MVector s ty a
forall s (ty :: SEXPTYPE) a.
SEXP s ty -> Int32 -> Int32 -> MVector s ty a
MVector SEXP s ty
ptr (Int32
off Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
j) (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
m)

  {-# INLINE basicOverlaps #-}
  basicOverlaps :: W t ty s a -> W t ty s a -> Bool
basicOverlaps (W t ty s a -> MVector s ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector ptr1 :: SEXP s ty
ptr1 off1 :: Int32
off1 len1 :: Int32
len1) (W t ty s a -> MVector s ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector ptr2 :: SEXP s ty
ptr2 off2 :: Int32
off2 len2 :: Int32
len2) =
      SEXP s ty
ptr1 SEXP s ty -> SEXP s ty -> Bool
forall a. Eq a => a -> a -> Bool
== SEXP s ty
ptr2 Bool -> Bool -> Bool
&& (Int32
off2 Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
off1 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
len1 Bool -> Bool -> Bool
|| Int32
off1 Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
off2 Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Int32
len2)

  {-# INLINE basicUnsafeNew #-}
  basicUnsafeNew :: Int -> m (W t ty (PrimState m) a)
basicUnsafeNew n :: Int
n
    -- R calls using allocVector() for CHARSXP "defunct"...
    | Sing ty -> Demote SEXPTYPE
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing (SSEXPTYPE ty
forall k (a :: k). SingI a => Sing a
sing :: SSEXPTYPE ty) SEXPTYPE -> SEXPTYPE -> Bool
forall a. Eq a => a -> a -> Bool
== SEXPTYPE
R.Char =
      String -> String -> m (W t ty (PrimState m) a)
forall a. String -> String -> a
failure "Data.Vector.SEXP.Mutable.new"
              "R character vectors are immutable and globally cached. Use 'mkChar' instead."
    | Bool
otherwise = do
      SEXP s ty
sx <- IO (SEXP s ty) -> m (SEXP s ty)
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (SEXP V ty -> IO (SEXP s ty)
forall (ty :: SEXPTYPE). SEXP V ty -> IO (SEXP s ty)
acquireIO (SEXP V ty -> IO (SEXP s ty)) -> IO (SEXP V ty) -> IO (SEXP s ty)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SSEXPTYPE ty -> Int -> IO (SEXP V ty)
forall (a :: SEXPTYPE).
IsVector a =>
SSEXPTYPE a -> Int -> IO (SEXP V a)
R.allocVector (SSEXPTYPE ty
forall k (a :: k). SingI a => Sing a
sing :: SSEXPTYPE ty) Int
n)
      W t ty (PrimState m) a -> m (W t ty (PrimState m) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (W t ty (PrimState m) a -> m (W t ty (PrimState m) a))
-> W t ty (PrimState m) a -> m (W t ty (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ MVector (PrimState m) ty a -> W t ty (PrimState m) a
forall t (ty :: SEXPTYPE) s a. MVector s ty a -> W t ty s a
W (MVector (PrimState m) ty a -> W t ty (PrimState m) a)
-> MVector (PrimState m) ty a -> W t ty (PrimState m) a
forall a b. (a -> b) -> a -> b
$ SEXP (PrimState m) ty
-> Int32 -> Int32 -> MVector (PrimState m) ty a
forall s (ty :: SEXPTYPE) a.
SEXP s ty -> Int32 -> Int32 -> MVector s ty a
MVector (SEXP s ty -> SEXP (PrimState m) ty
forall s (a :: SEXPTYPE) r. SEXP s a -> SEXP r a
R.unsafeRelease SEXP s ty
sx) 0 (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
    where
      AcquireIO acquireIO :: forall (ty :: SEXPTYPE). SEXP V ty -> IO (SEXP s ty)
acquireIO = Proxy t -> AcquireIO s
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect (Proxy t
forall k (t :: k). Proxy t
Proxy :: Proxy t)

  {-# INLINE basicUnsafeRead #-}
  basicUnsafeRead :: W t ty (PrimState m) a -> Int -> m a
basicUnsafeRead (W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv) i :: Int
i =
      IO a -> m a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv) Int
i

  {-# INLINE basicUnsafeWrite #-}
  basicUnsafeWrite :: W t ty (PrimState m) a -> Int -> a -> m ()
basicUnsafeWrite (W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv) i :: Int
i x :: a
x =
      IO () -> m ()
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv) Int
i a
x

  {-# INLINE basicUnsafeCopy #-}
  basicUnsafeCopy :: W t ty (PrimState m) a -> W t ty (PrimState m) a -> m ()
basicUnsafeCopy w1 :: W t ty (PrimState m) a
w1@(W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv1) (W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv2) = IO () -> m ()
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv1)
                (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv2)
                (W t ty (PrimState m) a -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
G.basicLength W t ty (PrimState m) a
w1)

  {-# INLINE basicUnsafeMove #-}
  basicUnsafeMove :: W t ty (PrimState m) a -> W t ty (PrimState m) a -> m ()
basicUnsafeMove w1 :: W t ty (PrimState m) a
w1@(W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv1) (W t ty (PrimState m) a -> MVector (PrimState m) ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv2)  = IO () -> m ()
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv1)
                (MVector (PrimState m) ty a -> Ptr a
forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv2)
                (W t ty (PrimState m) a -> Int
forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
G.basicLength W t ty (PrimState m) a
w1)

unsafeToPtr :: Storable a => MVector s ty a -> Ptr a
unsafeToPtr :: MVector s ty a -> Ptr a
unsafeToPtr (MVector sx :: SEXP s ty
sx off :: Int32
off _) =
    Ptr () -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr (SEXP s ty -> Ptr ()
forall s (a :: SEXPTYPE). SEXP s a -> Ptr ()
R.unsafeSEXPToVectorPtr SEXP s ty
sx) Ptr a -> Int -> Ptr a
forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
off

proxyW :: Monad m => m (W t ty s a) -> proxy t -> m (MVector s ty a)
proxyW :: m (W t ty s a) -> proxy t -> m (MVector s ty a)
proxyW m :: m (W t ty s a)
m _ = (W t ty s a -> MVector s ty a)
-> m (W t ty s a) -> m (MVector s ty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap W t ty s a -> MVector s ty a
forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW m (W t ty s a)
m

withW :: proxy t -> MVector s ty a -> W t ty s a
withW :: proxy t -> MVector s ty a -> W t ty s a
withW _ v :: MVector s ty a
v = MVector s ty a -> W t ty s a
forall t (ty :: SEXPTYPE) s a. MVector s ty a -> W t ty s a
W MVector s ty a
v

release :: (s' <= s) => MVector s ty a -> MVector s' ty a
release :: MVector s ty a -> MVector s' ty a
release = MVector s ty a -> MVector s' ty a
forall s (ty :: SEXPTYPE) a s'. MVector s ty a -> MVector s' ty a
unsafeRelease

unsafeRelease :: MVector s ty a -> MVector s' ty a
unsafeRelease :: MVector s ty a -> MVector s' ty a
unsafeRelease (MVector b :: SEXP s ty
b o :: Int32
o l :: Int32
l) = SEXP s' ty -> Int32 -> Int32 -> MVector s' ty a
forall s (ty :: SEXPTYPE) a.
SEXP s ty -> Int32 -> Int32 -> MVector s ty a
MVector (SEXP s ty -> SEXP s' ty
forall s (a :: SEXPTYPE) r. SEXP s a -> SEXP r a
R.unsafeRelease SEXP s ty
b) Int32
o Int32
l