diff --git a/primitive-checked.cabal b/primitive-checked.cabal --- a/primitive-checked.cabal +++ b/primitive-checked.cabal @@ -1,5 +1,6 @@ +cabal-version: 2.0 name: primitive-checked -version: 0.6.4.0 +version: 0.6.4.1 synopsis: primitive functions with bounds-checking homepage: https://github.com/andrewthad/primitive-checked#readme bug-reports: https://github.com/andrewthad/primitive-checked/issues @@ -9,7 +10,7 @@ license: BSD3 license-file: LICENSE build-type: Simple -cabal-version: >= 1.21 +category: Array description: . This library is intended to be used as a drop-in replacement for @@ -25,7 +26,10 @@ The versioning for this library matches the version of primitive that is targeted. The first three digits of the version match the version of `primitive`. The fourth digit is used for bug fixes. + This packages deviates slightly from the PVP in that functions + can be added to the API with only a bump to the fourth digit. + extra-source-files: README.md @@ -37,7 +41,7 @@ hs-source-dirs: src build-depends: - base >=4.9 && <5 + base >=4.9.1.0 && <5 , primitive == 0.6.4.* exposed-modules: Data.Primitive diff --git a/src/Data/Primitive.hs b/src/Data/Primitive.hs --- a/src/Data/Primitive.hs +++ b/src/Data/Primitive.hs @@ -4,12 +4,16 @@ module Data.Primitive.ByteArray, module Data.Primitive.Addr, module Data.Primitive.PrimArray, - module Data.Primitive.UnliftedArray + module Data.Primitive.SmallArray, + module Data.Primitive.UnliftedArray, + module Data.Primitive.MutVar ) where -import Data.Primitive.Types +import Data.Primitive.Addr import Data.Primitive.Array import Data.Primitive.ByteArray -import Data.Primitive.Addr +import Data.Primitive.MutVar import Data.Primitive.PrimArray +import Data.Primitive.SmallArray +import Data.Primitive.Types import Data.Primitive.UnliftedArray diff --git a/src/Data/Primitive/ByteArray.hs b/src/Data/Primitive/ByteArray.hs --- a/src/Data/Primitive/ByteArray.hs +++ b/src/Data/Primitive/ByteArray.hs @@ -13,6 +13,7 @@ , newByteArray , newPinnedByteArray , newAlignedPinnedByteArray + , resizeMutableByteArray -- * Element access , readByteArray , writeByteArray @@ -71,6 +72,9 @@ newAlignedPinnedByteArray :: (HasCallStack, PrimMonad m) => Int -> Int -> m (MutableByteArray (PrimState m)) newAlignedPinnedByteArray n k = check "newAlignedPinnedByteArray: negative size" (n>=0) (A.newAlignedPinnedByteArray n k) + +resizeMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> m (MutableByteArray (PrimState m)) +resizeMutableByteArray a n = check "resizeMutableByteArray: negative size" (n>=0) (A.resizeMutableByteArray a n) readByteArray :: forall m a. (HasCallStack, Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a readByteArray marr i = do diff --git a/src/Data/Primitive/PrimArray.hs b/src/Data/Primitive/PrimArray.hs --- a/src/Data/Primitive/PrimArray.hs +++ b/src/Data/Primitive/PrimArray.hs @@ -79,6 +79,7 @@ import "primitive" Data.Primitive.PrimArray (PrimArray,MutablePrimArray) import qualified "primitive" Data.Primitive.PrimArray as A import GHC.Stack +import qualified Data.List as L check :: HasCallStack => String -> Bool -> a -> a check _ True x = x @@ -106,7 +107,14 @@ readPrimArray :: (HasCallStack, Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a readPrimArray marr i = do siz <- A.getSizeofMutablePrimArray marr - check "readPrimArray: index of out bounds" (i>=0 && i=0 && i m () writePrimArray marr i x = do siz <- A.getSizeofMutablePrimArray marr - check "writePrimArray: index of out bounds" (i>=0 && i=0 && i PrimArray a -> Int -> a -indexPrimArray arr i = check "indexPrimArray: index of out bounds" - (i>=0 && i< A.sizeofPrimArray arr) - (A.indexPrimArray arr i) +indexPrimArray arr i = + let sz = A.sizeofPrimArray arr + explain = L.concat + [ "[size: " + , show sz + , ", index: " + , show i + , "]" + ] + in check ("indexPrimArray: index of out bounds " ++ explain) + (i>=0 && i< sz) + (A.indexPrimArray arr i) setPrimArray :: forall m a. (HasCallStack, Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array to fill @@ -131,7 +155,16 @@ -> m () setPrimArray dst doff sz x = do arrSz <- A.getSizeofMutablePrimArray dst - check "copyMutablePrimArray: index range of out bounds" + let explain = L.concat + [ "[size: " + , show arrSz + , ", offset: " + , show doff + , ", length: " + , show sz + , "]" + ] + check ("setPrimArray: index range of out bounds " ++ explain) (doff>=0 && (doff+sz)<=arrSz) (A.setPrimArray dst doff sz x) diff --git a/src/Data/Primitive/SmallArray.hs b/src/Data/Primitive/SmallArray.hs --- a/src/Data/Primitive/SmallArray.hs +++ b/src/Data/Primitive/SmallArray.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE UnboxedTuples #-} module Data.Primitive.SmallArray ( SmallArray(..) @@ -7,6 +9,7 @@ , readSmallArray , writeSmallArray , indexSmallArray + , indexSmallArray## , indexSmallArrayM , freezeSmallArray , thawSmallArray @@ -21,32 +24,68 @@ ) where import Control.Monad.Primitive (PrimMonad,PrimState) -import Control.Exception (throw, ArrayException(..)) +import Control.Exception (throw, ArrayException(..), Exception, toException) import "primitive" Data.Primitive.SmallArray (SmallArray,SmallMutableArray) import qualified "primitive" Data.Primitive.SmallArray as A +import GHC.Exts (raise#) import GHC.Stack +import qualified Data.List as L check :: HasCallStack => String -> Bool -> a -> a check _ True x = x check errMsg False _ = throw (IndexOutOfBounds $ "Data.Primitive.SmallArray.Checked." ++ errMsg ++ "\n" ++ prettyCallStack callStack) +checkUnary :: HasCallStack => String -> Bool -> (# a #) -> (# a #) +checkUnary _ True x = x +checkUnary errMsg False _ = throwUnary (IndexOutOfBounds $ "Data.Primitive.SmallArray.Checked." ++ errMsg ++ "\n" ++ prettyCallStack callStack) + +throwUnary :: Exception e => e -> (# a #) +throwUnary e = raise# (toException e) + newSmallArray :: (HasCallStack, PrimMonad m) => Int -> a -> m (SmallMutableArray (PrimState m) a) newSmallArray n x = check "newSmallArray: negative size" (n>=0) (A.newSmallArray n x) readSmallArray :: (HasCallStack, PrimMonad m) => SmallMutableArray (PrimState m) a -> Int -> m a readSmallArray marr i = do let siz = A.sizeofSmallMutableArray marr - check "readSmallArray: index of out bounds" (i>=0 && i=0 && i SmallMutableArray (PrimState m) a -> Int -> a -> m () writeSmallArray marr i x = do let siz = A.sizeofSmallMutableArray marr - check "writeSmallArray: index of out bounds" (i>=0 && i=0 && i SmallArray a -> Int -> a -indexSmallArray arr i = check "indexSmallArray: index of out bounds" +indexSmallArray arr i = check ("indexSmallArray: index of out bounds " ++ explain) (i>=0 && i SmallArray a -> Int -> (# a #) +indexSmallArray## arr i = checkUnary "indexSmallArray##: index of out bounds" + (i>=0 && i SmallArray a -> Int -> m a indexSmallArrayM arr i = check "indexSmallArrayM: index of out bounds" diff --git a/src/Data/Primitive/UnliftedArray.hs b/src/Data/Primitive/UnliftedArray.hs --- a/src/Data/Primitive/UnliftedArray.hs +++ b/src/Data/Primitive/UnliftedArray.hs @@ -23,6 +23,10 @@ , cloneMutableUnliftedArray , A.mapUnliftedArray , A.foldrUnliftedArray + , A.foldlUnliftedArray + , A.foldrUnliftedArray' + , A.foldlUnliftedArray' + , A.unliftedArrayFromList ) where import Control.Monad.Primitive (PrimMonad,PrimState)