primitive 0.6.2.0 → 0.6.3.0
raw patch · 11 files changed
+201/−23 lines, 11 filesdep ~base
Dependency ranges changed: base
Files
- Control/Monad/Primitive.hs +26/−0
- Data/Primitive.hs +0/−11
- Data/Primitive/Array.hs +13/−1
- Data/Primitive/ByteArray.hs +89/−7
- Data/Primitive/SmallArray.hs +11/−0
- Data/Primitive/Types.hs +9/−0
- cbits/primitive-memops.c +5/−0
- cbits/primitive-memops.h +1/−0
- changelog.md +10/−0
- primitive.cabal +5/−3
- test/main.hs +32/−1
Control/Monad/Primitive.hs view
@@ -41,6 +41,7 @@ import Data.Monoid (Monoid) #endif +import Control.Monad.Trans.Cont ( ContT ) import Control.Monad.Trans.Identity ( IdentityT (IdentityT) ) import Control.Monad.Trans.List ( ListT ) import Control.Monad.Trans.Maybe ( MaybeT )@@ -54,6 +55,11 @@ import Control.Monad.Trans.Except ( ExceptT ) #endif +#if MIN_VERSION_transformers(0,5,3)+import Control.Monad.Trans.Accum ( AccumT )+import Control.Monad.Trans.Select ( SelectT )+#endif+ import qualified Control.Monad.Trans.RWS.Strict as Strict ( RWST ) import qualified Control.Monad.Trans.State.Strict as Strict ( StateT ) import qualified Control.Monad.Trans.Writer.Strict as Strict ( WriterT )@@ -91,6 +97,10 @@ internal (IO p) = p {-# INLINE internal #-} +instance PrimMonad m => PrimMonad (ContT r m) where+ type PrimState (ContT r m) = PrimState m+ primitive = lift . primitive+ {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (IdentityT m) where type PrimState (IdentityT m) = PrimState m primitive = lift . primitive@@ -130,6 +140,22 @@ #if MIN_VERSION_transformers(0,4,0) instance PrimMonad m => PrimMonad (ExceptT e m) where type PrimState (ExceptT e m) = PrimState m+ primitive = lift . primitive+ {-# INLINE primitive #-}+#endif++#if MIN_VERSION_transformers(0,5,3)+instance ( Monoid w+ , PrimMonad m+# if !(MIN_VERSION_base(4,8,0))+ , Functor m+# endif+ ) => PrimMonad (AccumT w m) where+ type PrimState (AccumT w m) = PrimState m+ primitive = lift . primitive+ {-# INLINE primitive #-}+instance PrimMonad m => PrimMonad (SelectT r m) where+ type PrimState (SelectT r m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #endif
Data/Primitive.hs view
@@ -23,14 +23,3 @@ import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.Addr--import GHC.Base ( Int(..) )---- | Size of values of type @a@. The argument is not used.-sizeOf :: Prim a => a -> Int-sizeOf x = I# (sizeOf# x)---- | Alignment of values of type @a@. The argument is not used.-alignment :: Prim a => a -> Int-alignment x = I# (alignment# x)-
Data/Primitive/Array.hs view
@@ -52,6 +52,10 @@ import Data.Traversable (Traversable(..)) import Data.Monoid #endif+#if MIN_VERSION_base(4,9,0)+import qualified Data.Foldable as F+import Data.Semigroup+#endif import Text.ParserCombinators.ReadP @@ -272,7 +276,7 @@ -> Array a {-# INLINE cloneArray #-} #if __GLASGOW_HASKELL__ >= 702-cloneArray (Array arr#) (I# off#) (I# len#) +cloneArray (Array arr#) (I# off#) (I# len#) = case cloneArray# arr# off# len# of arr'# -> Array arr'# #else cloneArray arr off len = runST $ do@@ -528,9 +532,17 @@ instance MonadFix Array where mfix f = let l = mfix (toList . f) in fromListN (length l) l +#if MIN_VERSION_base(4,9,0)+instance Semigroup (Array a) where+ (<>) = (<|>)+ sconcat = mconcat . F.toList+#endif+ instance Monoid (Array a) where mempty = empty+#if !(MIN_VERSION_base(4,11,0)) mappend = (<|>)+#endif mconcat l = createArray sz (die "mconcat" "impossible") $ \ma -> let go !_ [ ] = return () go off (a:as) =
Data/Primitive/ByteArray.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Primitive.ByteArray@@ -21,6 +23,9 @@ -- * Element access readByteArray, writeByteArray, indexByteArray, + -- * Folding+ foldrByteArray,+ -- * Freezing and thawing unsafeFreezeByteArray, unsafeThawByteArray, @@ -34,11 +39,16 @@ ) where import Control.Monad.Primitive+import Control.Monad.ST+import Control.Monad ( zipWithM_ ) import Data.Primitive.Types import Foreign.C.Types import Data.Word ( Word8 ) import GHC.Base ( Int(..) )+#if __GLASGOW_HASKELL__ >= 708+import qualified GHC.Exts as Exts ( IsList(..) )+#endif import GHC.Prim #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#)@@ -47,6 +57,8 @@ import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType )+import Numeric+import System.IO.Unsafe -- | Byte arrays data ByteArray = ByteArray ByteArray# deriving ( Typeable )@@ -55,23 +67,23 @@ data MutableByteArray s = MutableByteArray (MutableByteArray# s) deriving( Typeable ) --- | Create a new mutable byte array of the specified size.+-- | Create a new mutable byte array of the specified size in bytes. newByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newByteArray #-} newByteArray (I# n#) = primitive (\s# -> case newByteArray# n# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) --- | Create a /pinned/ byte array of the specified size. The garbage collector--- is guaranteed not to move it.+-- | Create a /pinned/ byte array of the specified size in bytes. The garbage+-- collector is guaranteed not to move it. newPinnedByteArray :: PrimMonad m => Int -> m (MutableByteArray (PrimState m)) {-# INLINE newPinnedByteArray #-} newPinnedByteArray (I# n#) = primitive (\s# -> case newPinnedByteArray# n# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) --- | Create a /pinned/ byte array of the specified size and with the give--- alignment. The garbage collector is guaranteed not to move it.+-- | Create a /pinned/ byte array of the specified size in bytes and with the+-- give alignment. The garbage collector is guaranteed not to move it. newAlignedPinnedByteArray :: PrimMonad m => Int -> Int -> m (MutableByteArray (PrimState m)) {-# INLINE newAlignedPinnedByteArray #-}@@ -117,12 +129,12 @@ unsafeThawByteArray (ByteArray arr#) = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) --- | Size of the byte array.+-- | Size of the byte array in bytes. sizeofByteArray :: ByteArray -> Int {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) --- | Size of the mutable byte array.+-- | Size of the mutable byte array in bytes. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#)@@ -149,6 +161,21 @@ writeByteArray (MutableByteArray arr#) (I# i#) x = primitive_ (writeByteArray# arr# i# x) +-- | Right-fold over the elements of a 'ByteArray'.+foldrByteArray :: forall a b. (Prim a) => (a -> b -> b) -> b -> ByteArray -> b+foldrByteArray f z arr = go 0+ where+ go i+ | sizeofByteArray arr > i * sz = f (indexByteArray arr i) (go (i+1))+ | otherwise = z+ sz = sizeofByteArray arr++fromListN :: Prim a => Int -> [a] -> ByteArray+fromListN n xs = runST $ do+ marr <- newByteArray (n * sizeOf (head xs))+ zipWithM_ (writeByteArray marr) [0..n] xs+ unsafeFreezeByteArray marr+ #if __GLASGOW_HASKELL__ >= 702 unI# :: Int -> Int# unI# (I# n#) = n#@@ -262,3 +289,58 @@ toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray"++instance Show ByteArray where+ showsPrec _ ba =+ showString "[" . go 0+ where+ go i+ | i < sizeofByteArray ba = comma . showString "0x" . showHex (indexByteArray ba i :: Word8) . go (i+1)+ | otherwise = showChar ']'+ where+ comma | i == 0 = id+ | otherwise = showString ", "++foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp"+ memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt++sameByteArray :: ByteArray# -> ByteArray# -> Bool+sameByteArray ba1 ba2 =+ case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of+#if __GLASGOW_HASKELL__ >= 708+ r -> isTrue# r+#else+ 1# -> True+ 0# -> False+#endif++instance Eq ByteArray where+ ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#)+ | sameByteArray ba1# ba2# = True+ | sizeofByteArray ba1 /= sizeofByteArray ba2 = False+ | otherwise =+ case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral $ sizeofByteArray ba1) of+ 0 -> True+ _ -> False++instance Ord ByteArray where+ ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#)+ | sameByteArray ba1# ba2# = EQ+ | n1 /= n2 = n1 `compare` n2+ | otherwise =+ case unsafeDupablePerformIO $ memcmp_ba ba1# ba2# (fromIntegral n1) of+ x | x > 0 -> GT+ | x == 0 -> EQ+ | otherwise -> LT+ where+ n1 = sizeofByteArray ba1+ n2 = sizeofByteArray ba2++#if __GLASGOW_HASKELL__ >= 708+instance Exts.IsList ByteArray where+ type Item ByteArray = Word8++ toList = foldrByteArray (:) []+ fromList xs = fromListN (length xs) xs+ fromListN = fromListN+#endif
Data/Primitive/SmallArray.hs view
@@ -77,6 +77,9 @@ import Data.Foldable import Data.Functor.Identity import Data.Monoid+#if MIN_VERSION_base(4,9,0)+import qualified Data.Semigroup as Sem+#endif import Text.ParserCombinators.ReadPrec import Text.Read import Text.Read.Lex@@ -575,9 +578,17 @@ instance MonadFix SmallArray where mfix f = fromList . mfix $ toList . f +#if MIN_VERSION_base(4,9,0)+instance Sem.Semigroup (SmallArray a) where+ (<>) = (<|>)+ sconcat = mconcat . toList+#endif+ instance Monoid (SmallArray a) where mempty = empty+#if !(MIN_VERSION_base(4,11,0)) mappend = (<|>)+#endif mconcat sas = createSmallArray n (die "mconcat" "impossible") $ \sma -> fix ? 0 ? sas $ \go off l -> case l of [] -> return ()
Data/Primitive/Types.hs view
@@ -13,6 +13,7 @@ module Data.Primitive.Types ( Prim(..),+ sizeOf, alignment, Addr(..), ) where@@ -107,6 +108,14 @@ -- | Fill a memory block given by an address, an offset and a length. -- The offset and length are in elements of type @a@ rather than in bytes. setOffAddr# :: Addr# -> Int# -> Int# -> a -> State# s -> State# s++-- | Size of values of type @a@. The argument is not used.+sizeOf :: Prim a => a -> Int+sizeOf x = I# (sizeOf# x)++-- | Alignment of values of type @a@. The argument is not used.+alignment :: Prim a => a -> Int+alignment x = I# (alignment# x) #define derivePrim(ty, ctr, sz, align, idx_arr, rd_arr, wr_arr, set_arr, idx_addr, rd_addr, wr_addr, set_addr) \ instance Prim (ty) where { \
cbits/primitive-memops.c view
@@ -35,6 +35,11 @@ } \ } +int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n )+{+ return memcmp( s1, s2, n );+}+ void hsprimitive_memset_Word8 (HsWord8 *p, ptrdiff_t off, size_t n, HsWord x) { memset( (char *)(p+off), x, n );
cbits/primitive-memops.h view
@@ -7,6 +7,7 @@ void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ); void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len );+int hsprimitive_memcmp( HsWord8 *s1, HsWord8 *s2, size_t n ); void hsprimitive_memset_Word8 (HsWord8 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word16 (HsWord16 *, ptrdiff_t, size_t, HsWord);
changelog.md view
@@ -1,3 +1,13 @@+## Changes in version 0.6.3.0++ * Add `PrimMonad` instances for `ContT`, `AccumT`, and `SelectT` from+ `transformers`++ * Add `Eq`, `Ord`, `Show`, and `IsList` instances for `ByteArray`++ * Add `Semigroup` instances for `Array` and `SmallArray`. This allows+ `primitive` to build on GHC 8.4 and later.+ ## Changes in version 0.6.2.0 * Drop support for GHCs before 7.4
primitive.cabal view
@@ -1,5 +1,5 @@ Name: primitive-Version: 0.6.2.0+Version: 0.6.3.0 License: BSD3 License-File: LICENSE @@ -21,7 +21,9 @@ GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3,- GHC == 8.0.1+ GHC == 8.0.2,+ GHC == 8.2.2,+ GHC == 8.4.1 Library Default-Language: Haskell2010@@ -45,7 +47,7 @@ Data.Primitive.Internal.Compat Data.Primitive.Internal.Operations - Build-Depends: base >= 4.5 && < 4.10+ Build-Depends: base >= 4.5 && < 4.12 , ghc-prim >= 0.2 && < 0.6 , transformers >= 0.2 && < 0.6
test/main.hs view
@@ -1,15 +1,28 @@ {-# LANGUAGE MagicHash, UnboxedTuples #-}++import Control.Monad import Control.Monad.Primitive+import Control.Monad.ST+import Data.Primitive import Data.Primitive.Array+import Data.Primitive.ByteArray+import Data.Primitive.Types+import Data.Word+import GHC.Int import GHC.IO import GHC.Prim --- Since we only have a single test case right now, I'm going to avoid the+-- Since we only have two test cases right now, I'm going to avoid the -- issue of choosing a test framework for the moment. This also keeps the -- package as a whole light on dependencies. main :: IO () main = do+ testArray+ testByteArray++testArray :: IO ()+testArray = do arr <- newArray 1 'A' let unit = case writeArray arr 0 'B' of@@ -22,3 +35,21 @@ if c1 == 'A' && c2 == 'B' then return () else error $ "Expected AB, got: " ++ show (c1, c2)++testByteArray :: IO ()+testByteArray = do+ let arr1 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+ arr2 = mkByteArray ([0xde, 0xad, 0xbe, 0xef] :: [Word8])+ arr3 = mkByteArray ([0xde, 0xad, 0xbe, 0xee] :: [Word8])+ when (show arr1 /= "[0xde, 0xad, 0xbe, 0xef]") $+ fail $ "ByteArray Show incorrect: "++show arr1+ unless (arr1 > arr3) $+ fail $ "ByteArray Ord incorrect"+ unless (arr1 == arr2) $+ fail $ "ByteArray Eq incorrect"++mkByteArray :: Prim a => [a] -> ByteArray+mkByteArray xs = runST $ do+ marr <- newByteArray (length xs * sizeOf (head xs))+ sequence $ zipWith (writeByteArray marr) [0..] xs+ unsafeFreezeByteArray marr