-- |
-- 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
  { forall s (ty :: SEXPTYPE) a. MVector s ty a -> SEXP s ty
mvectorBase :: {-# UNPACK #-} !(SEXP s ty)
  , forall s (ty :: SEXPTYPE) a. MVector s ty a -> Int32
mvectorOffset :: {-# UNPACK #-} !Int32
  , forall s (ty :: SEXPTYPE) a. 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 { forall t (ty :: SEXPTYPE) s a. 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 :: forall (m :: * -> *). PrimMonad m => W t ty (PrimState m) a -> m ()
basicInitialize W t ty (PrimState m) a
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
  {-# INLINE basicLength #-}
  basicLength :: forall s. W t ty s a -> Int
basicLength (forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector SEXP s ty
_ Int32
_ Int32
len) = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
len

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

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

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

  {-# INLINE basicUnsafeRead #-}
  basicUnsafeRead :: forall (m :: * -> *).
PrimMonad m =>
W t ty (PrimState m) a -> Int -> m a
basicUnsafeRead (forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv) Int
i =
      forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff (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 :: forall (m :: * -> *).
PrimMonad m =>
W t ty (PrimState m) a -> Int -> a -> m ()
basicUnsafeWrite (forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv) Int
i a
x =
      forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim forall a b. (a -> b) -> a -> b
$ forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff (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 :: forall (m :: * -> *).
PrimMonad m =>
W t ty (PrimState m) a -> W t ty (PrimState m) a -> m ()
basicUnsafeCopy w1 :: W t ty (PrimState m) a
w1@(forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv1) (forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv2) = forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim forall a b. (a -> b) -> a -> b
$ do
      forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray (forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv1)
                (forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv2)
                (forall (v :: * -> * -> *) a s. MVector v a => v s a -> Int
G.basicLength W t ty (PrimState m) a
w1)

  {-# INLINE basicUnsafeMove #-}
  basicUnsafeMove :: forall (m :: * -> *).
PrimMonad m =>
W t ty (PrimState m) a -> W t ty (PrimState m) a -> m ()
basicUnsafeMove w1 :: W t ty (PrimState m) a
w1@(forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv1) (forall t (ty :: SEXPTYPE) s a. W t ty s a -> MVector s ty a
unW -> MVector (PrimState m) ty a
mv2)  = forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim forall a b. (a -> b) -> a -> b
$ do
      forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray (forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv1)
                (forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr MVector (PrimState m) ty a
mv2)
                (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 :: forall a s (ty :: SEXPTYPE). Storable a => MVector s ty a -> Ptr a
unsafeToPtr (MVector SEXP s ty
sx Int32
off Int32
_) =
    forall a b. Ptr a -> Ptr b
castPtr (forall s (a :: SEXPTYPE). SEXP s a -> Ptr ()
R.unsafeSEXPToVectorPtr SEXP s ty
sx) forall a. Storable a => Ptr a -> Int -> Ptr a
`advancePtr` 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 :: forall (m :: * -> *) t (ty :: SEXPTYPE) s a (proxy :: * -> *).
Monad m =>
m (W t ty s a) -> proxy t -> m (MVector s ty a)
proxyW m (W t ty s a)
m proxy t
_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 :: forall (proxy :: * -> *) t s (ty :: SEXPTYPE) a.
proxy t -> MVector s ty a -> W t ty s a
withW proxy t
_ MVector s ty a
v = 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 :: forall s' s (ty :: SEXPTYPE) a.
(s' <= s) =>
MVector s ty a -> MVector s' ty a
release = 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 :: forall s (ty :: SEXPTYPE) a s'. MVector s ty a -> MVector s' ty a
unsafeRelease (MVector SEXP s ty
b Int32
o Int32
l) = forall s (ty :: SEXPTYPE) a.
SEXP s ty -> Int32 -> Int32 -> MVector s ty a
MVector (forall s (a :: SEXPTYPE) r. SEXP s a -> SEXP r a
R.unsafeRelease SEXP s ty
b) Int32
o Int32
l