diff --git a/mutable-containers/mutable-containers.cabal b/mutable-containers/mutable-containers.cabal index 63b08d6..a945cbc 100644 --- a/mutable-containers/mutable-containers.cabal +++ b/mutable-containers/mutable-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -28,6 +28,7 @@ library exposed-modules: Data.Mutable other-modules: + Data.Mutable.Array Data.Mutable.BRef Data.Mutable.Class Data.Mutable.Deque diff --git a/mutable-containers/src/Data/Mutable.hs b/mutable-containers/src/Data/Mutable.hs index 00dc921..dcf191a 100644 --- a/mutable-containers/src/Data/Mutable.hs +++ b/mutable-containers/src/Data/Mutable.hs @@ -34,13 +34,15 @@ module Data.Mutable , asBDeque , DLList , asDLList + , Array (..) + , ArrayMemoryProperties (..) -- * Type classes , MutableContainer (..) , MutableRef (..) , MutableAtomicRef (..) , MutableCollection (..) - , MutableInitialSizedCollection (..) - , MutableIndexing (..) + , MutableAllocatedCollection (..) + , MutableIndexingWrite (..) , MutablePushFront (..) , MutablePushBack (..) , MutablePopFront (..) @@ -65,6 +67,7 @@ import Data.Mutable.PRef import Data.Mutable.BRef import Data.Mutable.Deque import Data.Mutable.DLList +import Data.Mutable.Array import Data.Vector.Unboxed (Unbox) import Data.Primitive (Prim) import Data.Vector.Storable (Storable) diff --git a/mutable-containers/src/Data/Mutable/Array.hs b/mutable-containers/src/Data/Mutable/Array.hs new file mode 100644 index 0000000..4504971 --- /dev/null +++ b/mutable-containers/src/Data/Mutable/Array.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Data.Mutable.Array + ( Array (..) + , ArrayMemoryProperties (..) + ) where + +import Data.Mutable.Class +import Data.Word +import GHC.TypeLits +import Data.Kind (Constraint) +import Data.Proxy (Proxy(Proxy)) +import Unsafe.Coerce (unsafeCoerce) +import Control.Monad.Primitive + +import Data.Primitive.ByteArray (MutableByteArray, newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, writeByteArray) +import Data.Primitive.Types (Prim) + +newtype Array (p :: ArrayMemoryProperties) e s = Array (MutableByteArray s) + +data ArrayMemoryProperties = Regular | Pinned | AlignedPinned Nat + +instance MutableContainer (Array p e s) where + type MCState (Array p e s) = s + +instance MutableCollection (Array Regular e s) where + type CollElement (Array Regular e s) = e + newColl = coerceToArray $ newByteArray 0 +instance MutableCollection (Array Pinned e s) where + type CollElement (Array Pinned e s) = e + newColl = coerceToArray $ newPinnedByteArray 0 +instance KnownNat n => MutableCollection (Array (AlignedPinned n) e s) where + type CollElement (Array (AlignedPinned n) e s) = e + newColl = coerceToArray $ newAlignedPinnedByteArray 0 alignment + where + alignment = fromIntegral $ natVal $ Proxy @n + +type instance CollIndex (Array _ _ _) = Int +instance MutableAllocatedCollection (Array Regular e s) where + newCollOfSize = coerceToArray . newByteArray +instance MutableAllocatedCollection (Array Pinned e s) where + newCollOfSize = coerceToArray . newPinnedByteArray +instance KnownNat n => MutableAllocatedCollection (Array (AlignedPinned n) e s) where + newCollOfSize = coerceToArray . flip newAlignedPinnedByteArray alignment + where + alignment = fromIntegral $ natVal $ Proxy @n + +coerceToArray :: m (MutableByteArray s) -> m (Array p e s) +coerceToArray = unsafeCoerce + +instance (Prim (CollElement (Array p e s)), MutableAllocatedCollection (Array p e s)) => MutableIndexingWrite (Array p e s) where + writeIndex (Array c) i x = writeByteArray c i x + +type IsPow2 :: Nat -> Constraint +type IsPow2 x = IsPow2' (Mod x 2) x +type IsPow2' :: Nat -> Nat -> Constraint +type family IsPow2' m x where + IsPow2' _ 2 = () + IsPow2' 1 x = TypeError (ShowType x :<>: Text " is not a power of 2.") + IsPow2' 0 x = IsPow2' 0 (Div x 2) diff --git a/mutable-containers/src/Data/Mutable/Class.hs b/mutable-containers/src/Data/Mutable/Class.hs index 902b1a8..a85d3ac 100644 --- a/mutable-containers/src/Data/Mutable/Class.hs +++ b/mutable-containers/src/Data/Mutable/Class.hs @@ -20,8 +20,9 @@ module Data.Mutable.Class , MutableRef (..) , MutableAtomicRef (..) , MutableCollection (..) - , MutableInitialSizedCollection (..) - , MutableIndexing (..) + , MutableAllocatedCollection (..) + , CollIndex + , MutableIndexingWrite (..) , MutablePushFront (..) , MutablePushBack (..) , MutablePopFront (..) @@ -228,90 +229,85 @@ instance Monoid w => MutableCollection (MutVar s w) where instance MutableCollection (MV.MVector s a) where type CollElement (MV.MVector s a) = a newColl = MV.new 0 - {-# INLINE newColl #-} instance MPV.Prim a => MutableCollection (MPV.MVector s a) where type CollElement (MPV.MVector s a) = a newColl = MPV.new 0 - {-# INLINE newColl #-} instance Storable a => MutableCollection (MSV.MVector s a) where type CollElement (MSV.MVector s a) = a newColl = MSV.new 0 - {-# INLINE newColl #-} instance MUV.Unbox a => MutableCollection (MUV.MVector s a) where type CollElement (MUV.MVector s a) = a newColl = MUV.new 0 - {-# INLINE newColl #-} instance (GHC.Arr.Ix i, Num i) => MutableCollection (GHC.Arr.STArray s i e) where type CollElement (GHC.Arr.STArray s i e) = e newColl = primToPrim $ GHC.Arr.newSTArray (0,0) undefined - {-# INLINE newColl #-} instance Storable a => MutableCollection (Ptr a) where type CollElement (Ptr a) = a newColl = primToPrim $ Foreign.mallocArray 0 - {-# INLINE newColl #-} -- | Containers that can be initialized with n elements. -class MutableCollection c => MutableInitialSizedCollection c where - type CollIndex c +type family CollIndex c + +class MutableCollection c => MutableAllocatedCollection c where newCollOfSize :: (PrimMonad m, PrimState m ~ MCState c) => CollIndex c -> m c -instance MutableInitialSizedCollection (MV.MVector s a) where - type CollIndex (MV.MVector s a) = Int +type instance CollIndex (MV.MVector s a) = Int +instance MutableAllocatedCollection (MV.MVector s a) where newCollOfSize = MV.new {-# INLINE newCollOfSize #-} -instance MPV.Prim a => MutableInitialSizedCollection (MPV.MVector s a) where - type CollIndex (MPV.MVector s a) = Int +type instance CollIndex (MPV.MVector s a) = Int +instance MPV.Prim a => MutableAllocatedCollection (MPV.MVector s a) where newCollOfSize = MPV.new {-# INLINE newCollOfSize #-} -instance Storable a => MutableInitialSizedCollection (MSV.MVector s a) where - type CollIndex (MSV.MVector s a) = Int +type instance CollIndex (MSV.MVector s a) = Int +instance Storable a => MutableAllocatedCollection (MSV.MVector s a) where newCollOfSize = MSV.new {-# INLINE newCollOfSize #-} -instance MUV.Unbox a => MutableInitialSizedCollection (MUV.MVector s a) where - type CollIndex (MUV.MVector s a) = Int +type instance CollIndex (MUV.MVector s a) = Int +instance MUV.Unbox a => MutableAllocatedCollection (MUV.MVector s a) where newCollOfSize = MUV.new {-# INLINE newCollOfSize #-} -instance (GHC.Arr.Ix i, Num i) => MutableInitialSizedCollection (GHC.Arr.STArray s i e) where - type CollIndex (GHC.Arr.STArray s i e) = i +type instance CollIndex (GHC.Arr.STArray s i e) = i +instance (GHC.Arr.Ix i, Num i) => MutableAllocatedCollection (GHC.Arr.STArray s i e) where newCollOfSize x = primToPrim $ GHC.Arr.newSTArray (0,x) undefined {-# INLINE newCollOfSize #-} -instance Storable a => MutableInitialSizedCollection (Ptr a) where - type CollIndex (Ptr a) = Int +type instance CollIndex (Ptr a) = Int +instance Storable a => MutableAllocatedCollection (Ptr a) where newCollOfSize = primToPrim . Foreign.mallocArray {-# INLINE newCollOfSize #-} -class MutableInitialSizedCollection c => MutableIndexing c where - readIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> m (CollElement c) +class MutableAllocatedCollection c => MutableIndexingWrite c where +-- readIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> m (CollElement c) writeIndex :: (PrimMonad m, PrimState m ~ MCState c) => c -> CollIndex c -> CollElement c -> m () -instance MutableIndexing (MV.MVector s a) where - readIndex = MV.read - {-# INLINE readIndex #-} +instance MutableIndexingWrite (MV.MVector s a) where +-- readIndex = MV.read +-- {-# INLINE readIndex #-} writeIndex = MV.write {-# INLINE writeIndex #-} -instance MPV.Prim a => MutableIndexing (MPV.MVector s a) where - readIndex = MPV.read - {-# INLINE readIndex #-} +instance MPV.Prim a => MutableIndexingWrite (MPV.MVector s a) where +-- readIndex = MPV.read +-- {-# INLINE readIndex #-} writeIndex = MPV.write {-# INLINE writeIndex #-} -instance Storable a => MutableIndexing (MSV.MVector s a) where - readIndex = MSV.read - {-# INLINE readIndex #-} +instance Storable a => MutableIndexingWrite (MSV.MVector s a) where +-- readIndex = MSV.read +-- {-# INLINE readIndex #-} writeIndex = MSV.write {-# INLINE writeIndex #-} -instance MUV.Unbox a => MutableIndexing (MUV.MVector s a) where - readIndex = MUV.read - {-# INLINE readIndex #-} +instance MUV.Unbox a => MutableIndexingWrite (MUV.MVector s a) where +-- readIndex = MUV.read +-- {-# INLINE readIndex #-} writeIndex = MUV.write {-# INLINE writeIndex #-} -instance (GHC.Arr.Ix i, Num i) => MutableIndexing (GHC.Arr.STArray s i e) where - readIndex c i = primToPrim $ GHC.Arr.readSTArray c i - {-# INLINE readIndex #-} +instance (GHC.Arr.Ix i, Num i) => MutableIndexingWrite (GHC.Arr.STArray s i e) where +-- readIndex c i = primToPrim $ GHC.Arr.readSTArray c i +-- {-# INLINE readIndex #-} writeIndex c i e = primToPrim $ GHC.Arr.writeSTArray c i e {-# INLINE writeIndex #-} -instance Storable a => MutableIndexing (Ptr a) where - readIndex p i = primToPrim $ Foreign.peekElemOff p i - {-# INLINE readIndex #-} +instance Storable a => MutableIndexingWrite (Ptr a) where +-- readIndex p i = primToPrim $ Foreign.peekElemOff p i +-- {-# INLINE readIndex #-} writeIndex p i e = primToPrim $ Foreign.pokeElemOff p i e {-# INLINE writeIndex #-}