{-# LANGUAGE CPP                  #-}
{-# LANGUAGE MagicHash            #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Storable-based unboxed vectors.
module Data.Vector.Fixed.Storable (
    -- * Immutable
    Vec
  , Vec1
  , Vec2
  , Vec3
  , Vec4
  , Vec5
    -- * Raw pointers
  , unsafeFromForeignPtr
  , unsafeToForeignPtr
  , unsafeWith
    -- * Mutable
  , MVec(..)
    -- * Type classes
  , Storable
  ) where

import Control.Monad.Primitive
import Control.DeepSeq (NFData(..))
import Data.Monoid           (Monoid(..))
import Data.Semigroup        (Semigroup(..))
import Data.Data
import Foreign.Ptr           (castPtr)
import Foreign.Storable
import Foreign.Marshal.Array ( copyArray, moveArray )
import GHC.ForeignPtr        ( mallocPlainForeignPtrBytes )
import GHC.Ptr               ( Ptr(..) )
import GHC.Exts              ( proxy# )
import GHC.TypeLits
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr       ( unsafeWithForeignPtr )
#endif
import Foreign.ForeignPtr   ( ForeignPtr, withForeignPtr )
import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int
               , ($),undefined,seq,pure)

import Data.Vector.Fixed hiding (index)
import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, index, new,unsafeFreeze)
import qualified Data.Vector.Fixed.Cont     as C
import           Data.Vector.Fixed.Cont     (ArityPeano(..))



----------------------------------------------------------------
-- Data types
----------------------------------------------------------------

-- | Storable-based vector with fixed length
newtype Vec (n :: Nat) a = Vec (ForeignPtr a)

-- | Storable-based mutable vector with fixed length
newtype MVec (n :: Nat) s a = MVec (ForeignPtr a)

type Vec1 = Vec 1
type Vec2 = Vec 2
type Vec3 = Vec 3
type Vec4 = Vec 4
type Vec5 = Vec 5

type instance Mutable (Vec  n) = MVec n
type instance Dim     (Vec  n) = Peano n
type instance DimM    (MVec n) = Peano n


----------------------------------------------------------------
-- Raw Ptrs
----------------------------------------------------------------

-- | Get underlying pointer. Data may not be modified through pointer.
unsafeToForeignPtr :: Vec n a -> ForeignPtr a
{-# INLINE unsafeToForeignPtr #-}
unsafeToForeignPtr :: forall (n :: Nat) a. Vec n a -> ForeignPtr a
unsafeToForeignPtr (Vec ForeignPtr a
fp) = ForeignPtr a
fp

-- | Construct vector from foreign pointer.
unsafeFromForeignPtr :: ForeignPtr a -> Vec n a
{-# INLINE unsafeFromForeignPtr #-}
unsafeFromForeignPtr :: forall a (n :: Nat). ForeignPtr a -> Vec n a
unsafeFromForeignPtr = ForeignPtr a -> Vec n a
forall (n :: Nat) a. ForeignPtr a -> Vec n a
Vec

-- | Pass pointer to the vector's data to the IO action. The data may
--   not be modified through the 'Ptr.
unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b
{-# INLINE unsafeWith #-}
unsafeWith :: forall a b (n :: Nat). (Ptr a -> IO b) -> Vec n a -> IO b
unsafeWith Ptr a -> IO b
f (Vec ForeignPtr a
fp) = ForeignPtr a -> (Ptr a -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fp Ptr a -> IO b
f



----------------------------------------------------------------
-- Instances
----------------------------------------------------------------

instance (Arity n, Storable a, NFData a) => NFData (Vec n a) where
  rnf :: Vec n a -> ()
rnf Vec n a
x = Vec n a -> () -> ()
forall a b. a -> b -> b
seq Vec n a
x ()

deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Show      a) => Show      (Vec n a)
deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Eq        a) => Eq        (Vec n a)
deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Ord       a) => Ord       (Vec n a)
deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a)
deriving via ViaFixed (Vec n) a instance (Arity n, Storable a, Monoid    a) => Monoid    (Vec n a)

instance (Arity n, Storable a) => MVector (MVec n) a where
  basicNew :: forall s. ST s (MVec n s a)
basicNew = IO (MVec n s a) -> ST s (MVec n s a)
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO (MVec n s a) -> ST s (MVec n s a))
-> IO (MVec n s a) -> ST s (MVec n s a)
forall a b. (a -> b) -> a -> b
$ do
    ForeignPtr a
fp <- Int -> IO (ForeignPtr a)
forall a. Storable a => Int -> IO (ForeignPtr a)
mallocVector (Proxy# (Peano n) -> Int
forall (n :: PeanoNum). ArityPeano n => Proxy# n -> Int
peanoToInt (forall {k} (a :: k). Proxy# a
forall (a :: PeanoNum). Proxy# a
proxy# @(Peano n)))
    MVec n s a -> IO (MVec n s a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MVec n s a -> IO (MVec n s a)) -> MVec n s a -> IO (MVec n s a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> MVec n s a
forall (n :: Nat) s a. ForeignPtr a -> MVec n s a
MVec ForeignPtr a
fp
  {-# INLINE basicNew         #-}
  basicCopy :: forall s. MVec n s a -> MVec n s a -> ST s ()
basicCopy (MVec ForeignPtr a
fp) (MVec ForeignPtr a
fq)
    = IO () -> ST s ()
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim
    (IO () -> ST s ()) -> IO () -> ST s ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
p ->
      ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fq ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
q ->
      Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
copyArray Ptr a
p Ptr a
q (Proxy# (Peano n) -> Int
forall (n :: PeanoNum). ArityPeano n => Proxy# n -> Int
peanoToInt (forall {k} (a :: k). Proxy# a
forall (a :: PeanoNum). Proxy# a
proxy# @(Peano n)))
  {-# INLINE basicCopy        #-}
  basicUnsafeRead :: forall s. MVec n s a -> Int -> ST s a
basicUnsafeRead (MVec ForeignPtr a
fp) Int
i
    = IO a -> ST s a
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim
    (IO a -> ST s a) -> IO a -> ST s a
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp (Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
i)
  {-# INLINE basicUnsafeRead  #-}
  basicUnsafeWrite :: forall s. MVec n s a -> Int -> a -> ST s ()
basicUnsafeWrite (MVec ForeignPtr a
fp) Int
i a
x
    = IO () -> ST s ()
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim
    (IO () -> ST s ()) -> IO () -> ST s ()
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
p -> Ptr a -> Int -> a -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr a
p Int
i a
x
  {-# INLINE basicUnsafeWrite #-}

instance (Arity n, Storable a) => IVector (Vec n) a where
  basicUnsafeFreeze :: forall s. Mutable (Vec n) s a -> ST s (Vec n a)
basicUnsafeFreeze (MVec ForeignPtr a
fp) = Vec n a -> ST s (Vec n a)
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Vec n a -> ST s (Vec n a)) -> Vec n a -> ST s (Vec n a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> Vec n a
forall (n :: Nat) a. ForeignPtr a -> Vec n a
Vec  ForeignPtr a
fp
  basicThaw :: forall s. Vec n a -> ST s (Mutable (Vec n) s a)
basicThaw         (Vec  ForeignPtr a
fp) = do
    MVec n s a
mv <- ST s (MVec n s a)
forall s. ST s (MVec n s a)
forall (v :: * -> * -> *) a s. MVector v a => ST s (v s a)
basicNew
    MVec n s a -> MVec n s a -> ST s ()
forall s. MVec n s a -> MVec n s a -> ST s ()
forall (v :: * -> * -> *) a s.
MVector v a =>
v s a -> v s a -> ST s ()
basicCopy MVec n s a
mv (ForeignPtr a -> MVec n s a
forall (n :: Nat) s a. ForeignPtr a -> MVec n s a
MVec ForeignPtr a
fp)
    MVec n s a -> ST s (MVec n s a)
forall a. a -> ST s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVec n s a
mv
  unsafeIndex :: Vec n a -> Int -> a
unsafeIndex  (Vec  ForeignPtr a
fp) Int
i
    = IO a -> a
forall a. IO a -> a
unsafeInlineIO
    (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> (Ptr a -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp (Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
i)
  {-# INLINE basicUnsafeFreeze #-}
  {-# INLINE basicThaw         #-}
  {-# INLINE unsafeIndex       #-}

instance (Arity n, Storable a) => Vector (Vec n) a where
  construct :: Fun (Dim (Vec n)) a (Vec n a)
construct  = Fun (Dim (Vec n)) a (Vec n a)
forall (v :: * -> *) a.
(ArityPeano (Dim v), IVector v a) =>
Fun (Dim v) a (v a)
constructVec
  inspect :: forall b. Vec n a -> Fun (Dim (Vec n)) a b -> b
inspect    = Vec n a -> Fun (Dim (Vec n)) a b -> b
forall (v :: * -> *) a b.
(ArityPeano (Dim v), IVector v a) =>
v a -> Fun (Dim v) a b -> b
inspectVec
  basicIndex :: Vec n a -> Int -> a
basicIndex = Vec n a -> Int -> a
forall (v :: * -> *) a. IVector v a => v a -> Int -> a
index
  {-# INLINE construct  #-}
  {-# INLINE inspect    #-}
  {-# INLINE basicIndex #-}

instance (Arity n, Storable a) => Storable (Vec n a) where
  sizeOf :: Vec n a -> Int
sizeOf    = Vec n a -> Int
forall a (v :: * -> *). (Storable a, Vector v a) => v a -> Int
defaultSizeOf
  alignment :: Vec n a -> Int
alignment = Vec n a -> Int
forall a (v :: * -> *). Storable a => v a -> Int
defaultAlignemnt
  peek :: Ptr (Vec n a) -> IO (Vec n a)
peek Ptr (Vec n a)
ptr = do
    arr :: MVec n RealWorld a
arr@(MVec ForeignPtr a
fp) <- IO (MVec n RealWorld a)
IO (MVec n (PrimState IO) a)
forall (v :: * -> * -> *) a (m :: * -> *).
(MVector v a, PrimMonad m) =>
m (v (PrimState m) a)
new
    ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
p ->
      Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray Ptr a
p (Ptr (Vec n a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (Vec n a)
ptr) (Proxy# (Peano n) -> Int
forall (n :: PeanoNum). ArityPeano n => Proxy# n -> Int
peanoToInt (forall {k} (a :: k). Proxy# a
forall (a :: PeanoNum). Proxy# a
proxy# @(Peano n)))
    Mutable (Vec n) (PrimState IO) a -> IO (Vec n a)
forall (v :: * -> *) a (m :: * -> *).
(IVector v a, PrimMonad m) =>
Mutable v (PrimState m) a -> m (v a)
unsafeFreeze Mutable (Vec n) (PrimState IO) a
MVec n RealWorld a
arr
  poke :: Ptr (Vec n a) -> Vec n a -> IO ()
poke Ptr (Vec n a)
ptr (Vec ForeignPtr a
fp)
    = ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr ForeignPtr a
fp ((Ptr a -> IO ()) -> IO ()) -> (Ptr a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr a
p ->
      Ptr a -> Ptr a -> Int -> IO ()
forall a. Storable a => Ptr a -> Ptr a -> Int -> IO ()
moveArray (Ptr (Vec n a) -> Ptr a
forall a b. Ptr a -> Ptr b
castPtr Ptr (Vec n a)
ptr) Ptr a
p (Proxy# (Peano n) -> Int
forall (n :: PeanoNum). ArityPeano n => Proxy# n -> Int
peanoToInt (forall {k} (a :: k). Proxy# a
forall (a :: PeanoNum). Proxy# a
proxy# @(Peano n)))

instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where
  gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Vec n a -> c (Vec n a)
gfoldl       = (forall x y. Data x => c (x -> y) -> x -> c y)
-> (forall x. x -> c x) -> Vec n a -> c (Vec n a)
forall (c :: * -> *) (v :: * -> *) a.
(Vector v a, Data a) =>
(forall x y. Data x => c (x -> y) -> x -> c y)
-> (forall x. x -> c x) -> v a -> c (v a)
C.gfoldl
  gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Vec n a)
gunfold      = (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Vec n a)
forall con (c :: * -> *) (v :: * -> *) a.
(Vector v a, Data a) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> con -> c (v a)
C.gunfold
  toConstr :: Vec n a -> Constr
toConstr   Vec n a
_ = Constr
con_Vec
  dataTypeOf :: Vec n a -> DataType
dataTypeOf Vec n a
_ = DataType
ty_Vec

ty_Vec :: DataType
ty_Vec :: DataType
ty_Vec  = String -> [Constr] -> DataType
mkDataType String
"Data.Vector.Fixed.Primitive.Vec" [Constr
con_Vec]

con_Vec :: Constr
con_Vec :: Constr
con_Vec = DataType -> String -> [String] -> Fixity -> Constr
mkConstr DataType
ty_Vec String
"Vec" [] Fixity
Prefix




----------------------------------------------------------------
-- Helpers
----------------------------------------------------------------

-- Code copied verbatim from vector package

mallocVector :: forall a. Storable a => Int -> IO (ForeignPtr a)
{-# INLINE mallocVector #-}
mallocVector :: forall a. Storable a => Int -> IO (ForeignPtr a)
mallocVector Int
size
  = Int -> IO (ForeignPtr a)
forall a. Int -> IO (ForeignPtr a)
mallocPlainForeignPtrBytes (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* a -> Int
forall a. Storable a => a -> Int
sizeOf (a
forall a. HasCallStack => a
undefined :: a))

#if !MIN_VERSION_base(4,15,0)
-- | A compatibility wrapper for 'GHC.ForeignPtr.unsafeWithForeignPtr' provided
-- by GHC 9.0.1 and later.
--
-- Only to be used when the continuation is known not to
-- unconditionally diverge lest unsoundness can result.
unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
unsafeWithForeignPtr = withForeignPtr
#endif