content: -- |
  -- 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
    { mvectorBase :: {-# UNPACK #-} !(SEXP s ty)
    , mvectorOffset :: {-# UNPACK #-} !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 { 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 _ = return ()
  #endif
    {-# INLINE basicLength #-}
    basicLength (unW -> MVector _ _ len) = fromIntegral len
  
    {-# INLINE basicUnsafeSlice #-}
    basicUnsafeSlice j m (unW -> MVector ptr off _len) =
        W $ MVector ptr (off + fromIntegral j) (fromIntegral m)
  
    {-# INLINE basicOverlaps #-}
    basicOverlaps (unW -> MVector ptr1 off1 len1) (unW -> MVector ptr2 off2 len2) =
        ptr1 == ptr2 && (off2 < off1 + len1 || off1 < off2 + len2)
  
    {-# INLINE basicUnsafeNew #-}
    basicUnsafeNew n
      -- R calls using allocVector() for CHARSXP "defunct"...
      | fromSing (sing :: SSEXPTYPE ty) == R.Char =
        failure "Data.Vector.SEXP.Mutable.new"
                "R character vectors are immutable and globally cached. Use 'mkChar' instead."
      | otherwise = do
        sx <- unsafePrimToPrim (acquireIO =<< R.allocVector (sing :: SSEXPTYPE ty) n)
        return $ W $ MVector (R.unsafeRelease sx) 0 (fromIntegral n)
      where
        AcquireIO acquireIO = reflect (Proxy :: Proxy t)
  
    {-# INLINE basicUnsafeRead #-}
    basicUnsafeRead (unW -> mv) i =
        unsafePrimToPrim $ peekElemOff (unsafeToPtr mv) i
  
    {-# INLINE basicUnsafeWrite #-}
    basicUnsafeWrite (unW -> mv) i x =
        unsafePrimToPrim $ pokeElemOff (unsafeToPtr mv) i x
  
    {-# INLINE basicUnsafeCopy #-}
    basicUnsafeCopy w1@(unW -> mv1) (unW -> mv2) = unsafePrimToPrim $ do
        copyArray (unsafeToPtr mv1)
                  (unsafeToPtr mv2)
                  (G.basicLength w1)
  
    {-# INLINE basicUnsafeMove #-}
    basicUnsafeMove w1@(unW -> mv1) (unW -> mv2)  = unsafePrimToPrim $ do
        moveArray (unsafeToPtr mv1)
                  (unsafeToPtr mv2)
                  (G.basicLength w1)
  
  unsafeToPtr :: Storable a => MVector s ty a -> Ptr a
  unsafeToPtr (MVector sx off _) =
      castPtr (R.unsafeSEXPToVectorPtr sx) `advancePtr` fromIntegral off
  
  proxyW :: Monad m => m (W t ty s a) -> proxy t -> m (MVector s ty a)
  proxyW m _ = fmap unW m
  
  withW :: proxy t -> MVector s ty a -> W t ty s a
  withW _ v = W v
  
  release :: (s' <= s) => MVector s ty a -> MVector s' ty a
  release = unsafeRelease
  
  unsafeRelease :: MVector s ty a -> MVector s' ty a
  unsafeRelease (MVector b o l) = MVector (R.unsafeRelease b) o l
  