{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}
{-# 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.ForeignPtr
import Foreign.Marshal.Array ( copyArray, moveArray )
import GHC.ForeignPtr        ( ForeignPtr(..), mallocPlainForeignPtrBytes )
import GHC.Ptr               ( Ptr(..) )
import GHC.TypeLits
import Prelude ( Show(..),Eq(..),Ord(..),Num(..),Monad(..),IO,Int
               , ($),undefined,seq)

import Data.Vector.Fixed hiding (index)
import Data.Vector.Fixed.Mutable (Mutable, MVector(..), IVector(..), DimM, constructVec, inspectVec, arity, index)
import qualified Data.Vector.Fixed.Cont     as C
import qualified Data.Vector.Fixed.Internal as I



----------------------------------------------------------------
-- 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)

deriving instance Typeable Vec
deriving instance Typeable MVec

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



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

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

unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b
{-# INLINE unsafeWith #-}
unsafeWith :: (Ptr a -> IO b) -> Vec n a -> IO b
unsafeWith Ptr a -> IO b
f (Vec ForeignPtr a
fp) = Ptr a -> IO b
f (ForeignPtr a -> Ptr a
forall a. ForeignPtr a -> Ptr a
getPtr ForeignPtr a
fp)



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

instance (Arity n, Storable a, Show a) => Show (Vec n a) where
  showsPrec :: Int -> Vec n a -> ShowS
showsPrec = Int -> Vec n a -> ShowS
forall (v :: * -> *) a. (Vector v a, Show a) => Int -> v a -> ShowS
I.showsPrec

instance (Arity n, Storable a, NFData a) => NFData (Vec n a) where
  rnf :: Vec n a -> ()
rnf = (() -> a -> ()) -> () -> Vec n a -> ()
forall (v :: * -> *) a b.
Vector v a =>
(b -> a -> b) -> b -> v a -> b
foldl (\()
r a
a -> ()
r () -> () -> ()
`seq` a -> ()
forall a. NFData a => a -> ()
rnf a
a) ()
  {-# INLINE rnf #-}

type instance Mutable (Vec n) = MVec n

instance (Arity n, Storable a) => MVector (MVec n) a where
  new :: m (MVec n (PrimState m) a)
new = IO (MVec n (PrimState m) a) -> m (MVec n (PrimState m) a)
forall (m1 :: * -> *) (m2 :: * -> *) a.
(PrimBase m1, PrimMonad m2) =>
m1 a -> m2 a
unsafePrimToPrim (IO (MVec n (PrimState m) a) -> m (MVec n (PrimState m) a))
-> IO (MVec n (PrimState m) a) -> m (MVec n (PrimState m) 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 (Int -> IO (ForeignPtr a)) -> Int -> IO (ForeignPtr a)
forall a b. (a -> b) -> a -> b
$ Proxy n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n)
    MVec n (PrimState m) a -> IO (MVec n (PrimState m) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVec n (PrimState m) a -> IO (MVec n (PrimState m) a))
-> MVec n (PrimState m) a -> IO (MVec n (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> MVec n (PrimState m) a
forall (n :: Nat) s a. ForeignPtr a -> MVec n s a
MVec ForeignPtr a
fp
  {-# INLINE new         #-}
  copy :: MVec n (PrimState m) a -> MVec n (PrimState m) a -> m ()
copy (MVec ForeignPtr a
fp) (MVec ForeignPtr a
fq)
    = 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
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr 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
withForeignPtr 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 n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
  {-# INLINE copy        #-}
  move :: MVec n (PrimState m) a -> MVec n (PrimState m) a -> m ()
move (MVec ForeignPtr a
fp) (MVec ForeignPtr a
fq)
    = 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
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr 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
withForeignPtr 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 ()
moveArray Ptr a
p Ptr a
q (Proxy n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))
  {-# INLINE move        #-}
  unsafeRead :: MVec n (PrimState m) a -> Int -> m a
unsafeRead (MVec ForeignPtr a
fp) 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
$ ForeignPtr a -> (Ptr a -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr a
fp (Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
i)
  {-# INLINE unsafeRead  #-}
  unsafeWrite :: MVec n (PrimState m) a -> Int -> a -> m ()
unsafeWrite (MVec ForeignPtr a
fp) Int
i 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
$ ForeignPtr a -> (Ptr a -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr 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 unsafeWrite #-}


instance (Arity n, Storable a) => IVector (Vec n) a where
  unsafeFreeze :: Mutable (Vec n) (PrimState m) a -> m (Vec n a)
unsafeFreeze (MVec fp)   = Vec n a -> m (Vec n a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Vec n a -> m (Vec n a)) -> Vec n a -> m (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
  unsafeThaw :: Vec n a -> m (Mutable (Vec n) (PrimState m) a)
unsafeThaw   (Vec  ForeignPtr a
fp)   = MVec n (PrimState m) a -> m (MVec n (PrimState m) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (MVec n (PrimState m) a -> m (MVec n (PrimState m) a))
-> MVec n (PrimState m) a -> m (MVec n (PrimState m) a)
forall a b. (a -> b) -> a -> b
$ ForeignPtr a -> MVec n (PrimState m) a
forall (n :: Nat) s a. ForeignPtr a -> MVec n s a
MVec ForeignPtr a
fp
  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
withForeignPtr ForeignPtr a
fp (Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
`peekElemOff` Int
i)
  {-# INLINE unsafeFreeze #-}
  {-# INLINE unsafeThaw   #-}
  {-# INLINE unsafeIndex  #-}


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

instance (Arity n, Storable a) => Vector (Vec n) a where
  construct :: Fun (Peano (Dim (Vec n))) a (Vec n a)
construct  = Fun (Peano (Dim (Vec n))) a (Vec n a)
forall (v :: * -> *) a.
(Arity (Dim v), IVector v a) =>
Fun (Peano (Dim v)) a (v a)
constructVec
  inspect :: Vec n a -> Fun (Peano (Dim (Vec n))) a b -> b
inspect    = Vec n a -> Fun (Peano (Dim (Vec n))) a b -> b
forall (v :: * -> *) a b.
(Arity (Dim v), IVector v a) =>
v a -> Fun (Peano (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) => VectorN Vec n a

instance (Arity n, Storable a, Eq a) => Eq (Vec n a) where
  == :: Vec n a -> Vec n a -> Bool
(==) = Vec n a -> Vec n a -> Bool
forall (v :: * -> *) a. (Vector v a, Eq a) => v a -> v a -> Bool
eq
  {-# INLINE (==) #-}
instance (Arity n, Storable a, Ord a) => Ord (Vec n a) where
  compare :: Vec n a -> Vec n a -> Ordering
compare = Vec n a -> Vec n a -> Ordering
forall (v :: * -> *) a.
(Vector v a, Ord a) =>
v a -> v a -> Ordering
ord
  {-# INLINE compare #-}

instance (Arity n, Storable a, Monoid a) => Monoid (Vec n a) where
  mempty :: Vec n a
mempty  = a -> Vec n a
forall (v :: * -> *) a. Vector v a => a -> v a
replicate a
forall a. Monoid a => a
mempty
  mappend :: Vec n a -> Vec n a -> Vec n a
mappend = (a -> a -> a) -> Vec n a -> Vec n a -> Vec n a
forall (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
zipWith a -> a -> a
forall a. Monoid a => a -> a -> a
mappend
  {-# INLINE mempty  #-}
  {-# INLINE mappend #-}

instance (Arity n, Storable a, Semigroup a) => Semigroup (Vec n a) where
  <> :: Vec n a -> Vec n a -> Vec n a
(<>) = (a -> a -> a) -> Vec n a -> Vec n a -> Vec n a
forall (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
zipWith a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>)
  {-# INLINE (<>) #-}

instance (Arity n, Storable a) => Storable (Vec n a) where
  sizeOf :: Vec n a -> Int
sizeOf    Vec n a
_ = Proxy n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity  (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n)
              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)
  alignment :: Vec n a -> Int
alignment Vec n a
_ = a -> Int
forall a. Storable a => a -> Int
alignment (a
forall a. HasCallStack => a
undefined :: a)
  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)
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
withForeignPtr 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 n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy 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
withForeignPtr 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 n -> Int
forall (n :: Nat) (proxy :: Nat -> *). KnownNat n => proxy n -> Int
arity (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

instance (Typeable n, Arity n, Storable a, Data a) => Data (Vec n a) where
  gfoldl :: (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 d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> 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 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 :: 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))

getPtr :: ForeignPtr a -> Ptr a
{-# INLINE getPtr #-}
getPtr :: ForeignPtr a -> Ptr a
getPtr (ForeignPtr Addr#
addr ForeignPtrContents
_) = Addr# -> Ptr a
forall a. Addr# -> Ptr a
Ptr Addr#
addr