primitive-0.7.0.1/0000755000000000000000000000000007346545000012056 5ustar0000000000000000primitive-0.7.0.1/Control/Monad/0000755000000000000000000000000007346545000014534 5ustar0000000000000000primitive-0.7.0.1/Control/Monad/Primitive.hs0000644000000000000000000002450407346545000017045 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, TypeFamilies #-} {-# LANGUAGE FlexibleContexts, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | -- Module : Control.Monad.Primitive -- Copyright : (c) Roman Leshchinskiy 2009 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive state-transformer monads -- module Control.Monad.Primitive ( PrimMonad(..), RealWorld, primitive_, PrimBase(..), liftPrim, primToPrim, primToIO, primToST, ioToPrim, stToPrim, unsafePrimToPrim, unsafePrimToIO, unsafePrimToST, unsafeIOToPrim, unsafeSTToPrim, unsafeInlinePrim, unsafeInlineIO, unsafeInlineST, touch, evalPrim, unsafeInterleave, unsafeDupableInterleave, noDuplicate ) where import GHC.Exts ( State#, RealWorld, noDuplicate#, touch# , unsafeCoerce#, realWorld#, seq# ) import GHC.IO ( IO(..) ) import GHC.ST ( ST(..) ) import Control.Monad.Trans.Class (lift) #if !MIN_VERSION_base(4,8,0) 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 ) import Control.Monad.Trans.Error ( ErrorT, Error) import Control.Monad.Trans.Reader ( ReaderT ) import Control.Monad.Trans.State ( StateT ) import Control.Monad.Trans.Writer ( WriterT ) import Control.Monad.Trans.RWS ( RWST ) #if MIN_VERSION_transformers(0,4,0) 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 #if MIN_VERSION_transformers(0,5,6) import qualified Control.Monad.Trans.Writer.CPS as CPS import qualified Control.Monad.Trans.RWS.CPS as CPS #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 ) -- | Class of monads which can perform primitive state-transformer actions class Monad m => PrimMonad m where -- | State token type type PrimState m -- | Execute a primitive operation primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a -- | Class of primitive monads for state-transformer actions. -- -- Unlike 'PrimMonad', this typeclass requires that the @Monad@ be fully -- expressed as a state transformer, therefore disallowing other monad -- transformers on top of the base @IO@ or @ST@. -- -- @since 0.6.0.0 class PrimMonad m => PrimBase m where -- | Expose the internal structure of the monad internal :: m a -> State# (PrimState m) -> (# State# (PrimState m), a #) -- | Execute a primitive operation with no result primitive_ :: PrimMonad m => (State# (PrimState m) -> State# (PrimState m)) -> m () {-# INLINE primitive_ #-} primitive_ f = primitive (\s# -> case f s# of s'# -> (# s'#, () #)) instance PrimMonad IO where type PrimState IO = RealWorld primitive = IO {-# INLINE primitive #-} instance PrimBase IO where internal (IO p) = p {-# INLINE internal #-} -- | @since 0.6.3.0 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 {-# INLINE primitive #-} -- | @since 0.6.2.0 instance PrimBase m => PrimBase (IdentityT m) where internal (IdentityT m) = internal m {-# INLINE internal #-} instance PrimMonad m => PrimMonad (ListT m) where type PrimState (ListT m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (MaybeT m) where type PrimState (MaybeT m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Error e, PrimMonad m) => PrimMonad (ErrorT e m) where type PrimState (ErrorT e m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (ReaderT r m) where type PrimState (ReaderT r m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad m => PrimMonad (StateT s m) where type PrimState (StateT s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (WriterT w m) where type PrimState (WriterT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #if MIN_VERSION_transformers(0,5,6) instance (Monoid w, PrimMonad m) => PrimMonad (CPS.WriterT w m) where type PrimState (CPS.WriterT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #endif instance (Monoid w, PrimMonad m) => PrimMonad (RWST r w s m) where type PrimState (RWST r w s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #if MIN_VERSION_transformers(0,5,6) instance (Monoid w, PrimMonad m) => PrimMonad (CPS.RWST r w s m) where type PrimState (CPS.RWST r w s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} #endif #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) -- | @since 0.6.3.0 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 instance PrimMonad m => PrimMonad (Strict.StateT s m) where type PrimState (Strict.StateT s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (Strict.WriterT w m) where type PrimState (Strict.WriterT w m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance (Monoid w, PrimMonad m) => PrimMonad (Strict.RWST r w s m) where type PrimState (Strict.RWST r w s m) = PrimState m primitive = lift . primitive {-# INLINE primitive #-} instance PrimMonad (ST s) where type PrimState (ST s) = s primitive = ST {-# INLINE primitive #-} instance PrimBase (ST s) where internal (ST p) = p {-# INLINE internal #-} -- | Lifts a 'PrimBase' into another 'PrimMonad' with the same underlying state -- token type. liftPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a {-# INLINE liftPrim #-} liftPrim = primToPrim -- | Convert a 'PrimBase' to another monad with the same state token. primToPrim :: (PrimBase m1, PrimMonad m2, PrimState m1 ~ PrimState m2) => m1 a -> m2 a {-# INLINE primToPrim #-} primToPrim m = primitive (internal m) -- | Convert a 'PrimBase' with a 'RealWorld' state token to 'IO' primToIO :: (PrimBase m, PrimState m ~ RealWorld) => m a -> IO a {-# INLINE primToIO #-} primToIO = primToPrim -- | Convert a 'PrimBase' to 'ST' primToST :: PrimBase m => m a -> ST (PrimState m) a {-# INLINE primToST #-} primToST = primToPrim -- | Convert an 'IO' action to a 'PrimMonad'. -- -- @since 0.6.2.0 ioToPrim :: (PrimMonad m, PrimState m ~ RealWorld) => IO a -> m a {-# INLINE ioToPrim #-} ioToPrim = primToPrim -- | Convert an 'ST' action to a 'PrimMonad'. -- -- @since 0.6.2.0 stToPrim :: PrimMonad m => ST (PrimState m) a -> m a {-# INLINE stToPrim #-} stToPrim = primToPrim -- | Convert a 'PrimBase' to another monad with a possibly different state -- token. This operation is highly unsafe! unsafePrimToPrim :: (PrimBase m1, PrimMonad m2) => m1 a -> m2 a {-# INLINE unsafePrimToPrim #-} unsafePrimToPrim m = primitive (unsafeCoerce# (internal m)) -- | Convert any 'PrimBase' to 'ST' with an arbitrary state token. This -- operation is highly unsafe! unsafePrimToST :: PrimBase m => m a -> ST s a {-# INLINE unsafePrimToST #-} unsafePrimToST = unsafePrimToPrim -- | Convert any 'PrimBase' to 'IO'. This operation is highly unsafe! unsafePrimToIO :: PrimBase m => m a -> IO a {-# INLINE unsafePrimToIO #-} unsafePrimToIO = unsafePrimToPrim -- | Convert an 'ST' action with an arbitrary state token to any 'PrimMonad'. -- This operation is highly unsafe! -- -- @since 0.6.2.0 unsafeSTToPrim :: PrimMonad m => ST s a -> m a {-# INLINE unsafeSTToPrim #-} unsafeSTToPrim = unsafePrimToPrim -- | Convert an 'IO' action to any 'PrimMonad'. This operation is highly -- unsafe! -- -- @since 0.6.2.0 unsafeIOToPrim :: PrimMonad m => IO a -> m a {-# INLINE unsafeIOToPrim #-} unsafeIOToPrim = unsafePrimToPrim unsafeInlinePrim :: PrimBase m => m a -> a {-# INLINE unsafeInlinePrim #-} unsafeInlinePrim m = unsafeInlineIO (unsafePrimToIO m) unsafeInlineIO :: IO a -> a {-# INLINE unsafeInlineIO #-} unsafeInlineIO m = case internal m realWorld# of (# _, r #) -> r unsafeInlineST :: ST s a -> a {-# INLINE unsafeInlineST #-} unsafeInlineST = unsafeInlinePrim touch :: PrimMonad m => a -> m () {-# INLINE touch #-} touch x = unsafePrimToPrim $ (primitive (\s -> case touch# x s of { s' -> (# s', () #) }) :: IO ()) -- | Create an action to force a value; generalizes 'Control.Exception.evaluate' -- -- @since 0.6.2.0 evalPrim :: forall a m . PrimMonad m => a -> m a #if MIN_VERSION_base(4,4,0) evalPrim a = primitive (\s -> seq# a s) #else -- This may or may not work so well, but there's probably nothing better to do. {-# NOINLINE evalPrim #-} evalPrim a = unsafePrimToPrim (evaluate a :: IO a) #endif noDuplicate :: PrimMonad m => m () #if __GLASGOW_HASKELL__ >= 802 noDuplicate = primitive $ \ s -> (# noDuplicate# s, () #) #else -- noDuplicate# was limited to RealWorld noDuplicate = unsafeIOToPrim $ primitive $ \s -> (# noDuplicate# s, () #) #endif unsafeInterleave, unsafeDupableInterleave :: PrimBase m => m a -> m a unsafeInterleave x = unsafeDupableInterleave (noDuplicate >> x) unsafeDupableInterleave x = primitive $ \ s -> let r' = case internal x s of (# _, r #) -> r in (# s, r' #) {-# INLINE unsafeInterleave #-} {-# NOINLINE unsafeDupableInterleave #-} -- See Note [unsafeDupableInterleaveIO should not be inlined] -- in GHC.IO.Unsafe primitive-0.7.0.1/Data/0000755000000000000000000000000007346545000012727 5ustar0000000000000000primitive-0.7.0.1/Data/Primitive.hs0000644000000000000000000000717407346545000015244 0ustar0000000000000000{-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} -- | -- Module : Data.Primitive -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Reexports all primitive operations -- module Data.Primitive ( -- * Re-exports module Data.Primitive.Types ,module Data.Primitive.Array ,module Data.Primitive.ByteArray ,module Data.Primitive.SmallArray ,module Data.Primitive.PrimArray ,module Data.Primitive.MutVar -- * Naming Conventions -- $namingConventions ) where import Data.Primitive.Types import Data.Primitive.Array import Data.Primitive.ByteArray import Data.Primitive.SmallArray import Data.Primitive.PrimArray import Data.Primitive.MutVar {- $namingConventions For historical reasons, this library embraces the practice of suffixing the name of a function with the type it operates on. For example, three of the variants of the array indexing function are: > indexArray :: Array a -> Int -> a > indexSmallArray :: SmallArray a -> Int -> a > indexPrimArray :: Prim a => PrimArray a -> Int -> a In a few places, where the language sounds more natural, the array type is instead used as a prefix. For example, @Data.Primitive.SmallArray@ exports @smallArrayFromList@, which would sound unnatural if it used @SmallArray@ as a suffix instead. This library provides several functions traversing, building, and filtering arrays. These functions are suffixed with an additional character to indicate their the nature of their effectfulness: * No suffix: A non-effectful pass over the array. * @-A@ suffix: An effectful pass over the array, where the effect is 'Applicative'. * @-P@ suffix: An effectful pass over the array, where the effect is 'PrimMonad'. Additionally, an apostrophe can be used to indicate strictness in the elements. The variants with an apostrophe are used in @Data.Primitive.Array@ but not in @Data.Primitive.PrimArray@ since the array type it provides is always strict in the element. For example, there are three variants of the function that filters elements from a primitive array. > filterPrimArray :: (Prim a ) => (a -> Bool) -> PrimArray a -> PrimArray a > filterPrimArrayA :: (Prim a, Applicative f) => (a -> f Bool) -> PrimArray a -> f (PrimArray a) > filterPrimArrayP :: (Prim a, PrimMonad m) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) As long as the effectful context is a monad that is sufficiently affine the behaviors of the 'Applicative' and 'PrimMonad' variants produce the same results and differ only in their strictness. Monads that are sufficiently affine include: * 'IO' and 'ST' * Any combination of 'MaybeT', 'ExceptT', 'StateT' and 'Writer' on top of another sufficiently affine monad. * Any Monad which does not include backtracking or other mechanism where an effect can happen more than once is an Affine Monad in the sense we care about. ContT, LogicT, ListT are all examples of search/control monads which are NOT affine: they can run a sub computation more than once. There is one situation where the names deviate from effectful suffix convention described above. Throughout the haskell ecosystem, the 'Applicative' variant of 'map' is known as 'traverse', not @mapA@. Consequently, we adopt the following naming convention for mapping: > mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b > traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -> PrimArray a -> f (PrimArray b) > traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b) -} primitive-0.7.0.1/Data/Primitive/0000755000000000000000000000000007346545000014677 5ustar0000000000000000primitive-0.7.0.1/Data/Primitive/Array.hs0000644000000000000000000007027707346545000016326 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash, UnboxedTuples, DeriveDataTypeable, BangPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Primitive.Array -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive arrays of boxed values. -- module Data.Primitive.Array ( Array(..), MutableArray(..), newArray, readArray, writeArray, indexArray, indexArrayM, indexArray##, freezeArray, thawArray, runArray, unsafeFreezeArray, unsafeThawArray, sameMutableArray, copyArray, copyMutableArray, cloneArray, cloneMutableArray, sizeofArray, sizeofMutableArray, fromListN, fromList, mapArray', traverseArrayP ) where import Control.Monad.Primitive import GHC.Base ( Int(..) ) import GHC.Exts #if (MIN_VERSION_base(4,7,0)) hiding (toList) #endif import qualified GHC.Exts as Exts #if (MIN_VERSION_base(4,7,0)) import GHC.Exts (fromListN, fromList) #endif import Data.Typeable ( Typeable ) import Data.Data (Data(..), DataType, mkDataType, Constr, mkConstr, Fixity(..), constrIndex) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) import Control.Monad.ST(ST,runST) import Control.Applicative import Control.Monad (MonadPlus(..), when) import qualified Control.Monad.Fail as Fail import Control.Monad.Fix #if MIN_VERSION_base(4,4,0) import Control.Monad.Zip #endif import Data.Foldable (Foldable(..), toList) #if !(MIN_VERSION_base(4,8,0)) import Data.Traversable (Traversable(..)) import Data.Monoid #endif #if MIN_VERSION_base(4,9,0) import qualified GHC.ST as GHCST import qualified Data.Foldable as F import Data.Semigroup #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity #endif #if MIN_VERSION_base(4,10,0) import GHC.Exts (runRW#) #elif MIN_VERSION_base(4,9,0) import GHC.Base (runRW#) #endif import Text.Read (Read (..), parens, prec) import Text.ParserCombinators.ReadPrec (ReadPrec) import qualified Text.ParserCombinators.ReadPrec as RdPrc import Text.ParserCombinators.ReadP #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) #endif import Control.Monad (liftM2) -- | Boxed arrays data Array a = Array { array# :: Array# a } deriving ( Typeable ) -- | Mutable boxed arrays associated with a primitive state token. data MutableArray s a = MutableArray { marray# :: MutableArray# s a } deriving ( Typeable ) sizeofArray :: Array a -> Int sizeofArray a = I# (sizeofArray# (array# a)) {-# INLINE sizeofArray #-} sizeofMutableArray :: MutableArray s a -> Int sizeofMutableArray a = I# (sizeofMutableArray# (marray# a)) {-# INLINE sizeofMutableArray #-} -- | Create a new mutable array of the specified size and initialise all -- elements with the given value. newArray :: PrimMonad m => Int -> a -> m (MutableArray (PrimState m) a) {-# INLINE newArray #-} newArray (I# n#) x = primitive (\s# -> case newArray# n# x s# of (# s'#, arr# #) -> let ma = MutableArray arr# in (# s'# , ma #)) -- | Read a value from the array at the given index. readArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m a {-# INLINE readArray #-} readArray arr (I# i#) = primitive (readArray# (marray# arr) i#) -- | Write a value to the array at the given index. writeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> a -> m () {-# INLINE writeArray #-} writeArray arr (I# i#) x = primitive_ (writeArray# (marray# arr) i# x) -- | Read a value from the immutable array at the given index. indexArray :: Array a -> Int -> a {-# INLINE indexArray #-} indexArray arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> x -- | Read a value from the immutable array at the given index, returning -- the result in an unboxed unary tuple. This is currently used to implement -- folds. indexArray## :: Array a -> Int -> (# a #) indexArray## arr (I# i) = indexArray# (array# arr) i {-# INLINE indexArray## #-} -- | Monadically read a value from the immutable array at the given index. -- This allows us to be strict in the array while remaining lazy in the read -- element which is very useful for collective operations. Suppose we want to -- copy an array. We could do something like this: -- -- > copy marr arr ... = do ... -- > writeArray marr i (indexArray arr i) ... -- > ... -- -- But since primitive arrays are lazy, the calls to 'indexArray' will not be -- evaluated. Rather, @marr@ will be filled with thunks each of which would -- retain a reference to @arr@. This is definitely not what we want! -- -- With 'indexArrayM', we can instead write -- -- > copy marr arr ... = do ... -- > x <- indexArrayM arr i -- > writeArray marr i x -- > ... -- -- Now, indexing is executed immediately although the returned element is -- still not evaluated. -- indexArrayM :: Monad m => Array a -> Int -> m a {-# INLINE indexArrayM #-} indexArrayM arr (I# i#) = case indexArray# (array# arr) i# of (# x #) -> return x -- | Create an immutable copy of a slice of an array. -- -- This operation makes a copy of the specified section, so it is safe to -- continue using the mutable array afterward. freezeArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (Array a) {-# INLINE freezeArray #-} freezeArray (MutableArray ma#) (I# off#) (I# len#) = primitive $ \s -> case freezeArray# ma# off# len# s of (# s', a# #) -> (# s', Array a# #) -- | Convert a mutable array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeArray :: PrimMonad m => MutableArray (PrimState m) a -> m (Array a) {-# INLINE unsafeFreezeArray #-} unsafeFreezeArray arr = primitive (\s# -> case unsafeFreezeArray# (marray# arr) s# of (# s'#, arr'# #) -> let a = Array arr'# in (# s'#, a #)) -- | Create a mutable array from a slice of an immutable array. -- -- This operation makes a copy of the specified slice, so it is safe to use the -- immutable array afterward. thawArray :: PrimMonad m => Array a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (MutableArray (PrimState m) a) {-# INLINE thawArray #-} thawArray (Array a#) (I# off#) (I# len#) = primitive $ \s -> case thawArray# a# off# len# s of (# s', ma# #) -> (# s', MutableArray ma# #) -- | Convert an immutable array to an mutable one without copying. The -- immutable array should not be used after the conversion. unsafeThawArray :: PrimMonad m => Array a -> m (MutableArray (PrimState m) a) {-# INLINE unsafeThawArray #-} unsafeThawArray a = primitive (\s# -> case unsafeThawArray# (array# a) s# of (# s'#, arr'# #) -> let ma = MutableArray arr'# in (# s'#, ma #)) -- | Check whether the two arrays refer to the same memory block. sameMutableArray :: MutableArray s a -> MutableArray s a -> Bool {-# INLINE sameMutableArray #-} sameMutableArray arr brr = isTrue# (sameMutableArray# (marray# arr) (marray# brr)) -- | Copy a slice of an immutable array to a mutable array. copyArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> Array a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyArray #-} #if __GLASGOW_HASKELL__ > 706 -- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyArray (MutableArray dst#) (I# doff#) (Array src#) (I# soff#) (I# len#) = primitive_ (copyArray# src# soff# dst# doff# len#) #else copyArray !dst !doff !src !soff !len = go 0 where go i | i < len = do x <- indexArrayM src (soff+i) writeArray dst (doff+i) x go (i+1) | otherwise = return () #endif -- | Copy a slice of a mutable array to another array. The two arrays must -- not be the same when using this library with GHC versions 7.6 and older. -- In GHC 7.8 and newer, overlapping arrays will behave correctly. -- -- Note: The order of arguments is different from that of 'copyMutableArray#'. The primop -- has the source first while this wrapper has the destination first. copyMutableArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> MutableArray (PrimState m) a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyMutableArray #-} #if __GLASGOW_HASKELL__ > 706 -- NOTE: copyArray# and copyMutableArray# are slightly broken in GHC 7.6.* and earlier copyMutableArray (MutableArray dst#) (I# doff#) (MutableArray src#) (I# soff#) (I# len#) = primitive_ (copyMutableArray# src# soff# dst# doff# len#) #else copyMutableArray !dst !doff !src !soff !len = go 0 where go i | i < len = do x <- readArray src (soff+i) writeArray dst (doff+i) x go (i+1) | otherwise = return () #endif -- | Return a newly allocated Array with the specified subrange of the -- provided Array. The provided Array should contain the full subrange -- specified by the two Ints, but this is not checked. cloneArray :: Array a -- ^ source array -> Int -- ^ offset into destination array -> Int -- ^ number of elements to copy -> Array a {-# INLINE cloneArray #-} cloneArray (Array arr#) (I# off#) (I# len#) = case cloneArray# arr# off# len# of arr'# -> Array arr'# -- | Return a newly allocated MutableArray. with the specified subrange of -- the provided MutableArray. The provided MutableArray should contain the -- full subrange specified by the two Ints, but this is not checked. cloneMutableArray :: PrimMonad m => MutableArray (PrimState m) a -- ^ source array -> Int -- ^ offset into destination array -> Int -- ^ number of elements to copy -> m (MutableArray (PrimState m) a) {-# INLINE cloneMutableArray #-} cloneMutableArray (MutableArray arr#) (I# off#) (I# len#) = primitive (\s# -> case cloneMutableArray# arr# off# len# s# of (# s'#, arr'# #) -> (# s'#, MutableArray arr'# #)) emptyArray :: Array a emptyArray = runST $ newArray 0 (die "emptyArray" "impossible") >>= unsafeFreezeArray {-# NOINLINE emptyArray #-} #if !MIN_VERSION_base(4,9,0) createArray :: Int -> a -> (forall s. MutableArray s a -> ST s ()) -> Array a createArray 0 _ _ = emptyArray createArray n x f = runArray $ do mary <- newArray n x f mary pure mary runArray :: (forall s. ST s (MutableArray s a)) -> Array a runArray m = runST $ m >>= unsafeFreezeArray #else /* Below, runRW# is available. */ -- This low-level business is designed to work with GHC's worker-wrapper -- transformation. A lot of the time, we don't actually need an Array -- constructor. By putting it on the outside, and being careful about -- how we special-case the empty array, we can make GHC smarter about this. -- The only downside is that separately created 0-length arrays won't share -- their Array constructors, although they'll share their underlying -- Array#s. createArray :: Int -> a -> (forall s. MutableArray s a -> ST s ()) -> Array a createArray 0 _ _ = Array (emptyArray# (# #)) createArray n x f = runArray $ do mary <- newArray n x f mary pure mary runArray :: (forall s. ST s (MutableArray s a)) -> Array a runArray m = Array (runArray# m) runArray# :: (forall s. ST s (MutableArray s a)) -> Array# a runArray# m = case runRW# $ \s -> case unST m s of { (# s', MutableArray mary# #) -> unsafeFreezeArray# mary# s'} of (# _, ary# #) -> ary# unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f emptyArray# :: (# #) -> Array# a emptyArray# _ = case emptyArray of Array ar -> ar {-# NOINLINE emptyArray# #-} #endif die :: String -> String -> a die fun problem = error $ "Data.Primitive.Array." ++ fun ++ ": " ++ problem arrayLiftEq :: (a -> b -> Bool) -> Array a -> Array b -> Bool arrayLiftEq p a1 a2 = sizeofArray a1 == sizeofArray a2 && loop (sizeofArray a1 - 1) where loop i | i < 0 = True | (# x1 #) <- indexArray## a1 i , (# x2 #) <- indexArray## a2 i , otherwise = p x1 x2 && loop (i-1) instance Eq a => Eq (Array a) where a1 == a2 = arrayLiftEq (==) a1 a2 #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Eq1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftEq = arrayLiftEq #else eq1 = arrayLiftEq (==) #endif #endif instance Eq (MutableArray s a) where ma1 == ma2 = isTrue# (sameMutableArray# (marray# ma1) (marray# ma2)) arrayLiftCompare :: (a -> b -> Ordering) -> Array a -> Array b -> Ordering arrayLiftCompare elemCompare a1 a2 = loop 0 where mn = sizeofArray a1 `min` sizeofArray a2 loop i | i < mn , (# x1 #) <- indexArray## a1 i , (# x2 #) <- indexArray## a2 i = elemCompare x1 x2 `mappend` loop (i+1) | otherwise = compare (sizeofArray a1) (sizeofArray a2) -- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (Array a) where compare a1 a2 = arrayLiftCompare compare a1 a2 #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Ord1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftCompare = arrayLiftCompare #else compare1 = arrayLiftCompare compare #endif #endif instance Foldable Array where -- Note: we perform the array lookups eagerly so we won't -- create thunks to perform lookups even if GHC can't see -- that the folding function is strict. foldr f = \z !ary -> let !sz = sizeofArray ary go i | i == sz = z | (# x #) <- indexArray## ary i = f x (go (i+1)) in go 0 {-# INLINE foldr #-} foldl f = \z !ary -> let go i | i < 0 = z | (# x #) <- indexArray## ary i = f (go (i-1)) x in go (sizeofArray ary - 1) {-# INLINE foldl #-} foldr1 f = \ !ary -> let !sz = sizeofArray ary - 1 go i = case indexArray## ary i of (# x #) | i == sz -> x | otherwise -> f x (go (i+1)) in if sz < 0 then die "foldr1" "empty array" else go 0 {-# INLINE foldr1 #-} foldl1 f = \ !ary -> let !sz = sizeofArray ary - 1 go i = case indexArray## ary i of (# x #) | i == 0 -> x | otherwise -> f (go (i - 1)) x in if sz < 0 then die "foldl1" "empty array" else go sz {-# INLINE foldl1 #-} #if MIN_VERSION_base(4,6,0) foldr' f = \z !ary -> let go i !acc | i == -1 = acc | (# x #) <- indexArray## ary i = go (i-1) (f x acc) in go (sizeofArray ary - 1) z {-# INLINE foldr' #-} foldl' f = \z !ary -> let !sz = sizeofArray ary go i !acc | i == sz = acc | (# x #) <- indexArray## ary i = go (i+1) (f acc x) in go 0 z {-# INLINE foldl' #-} #endif #if MIN_VERSION_base(4,8,0) null a = sizeofArray a == 0 {-# INLINE null #-} length = sizeofArray {-# INLINE length #-} maximum ary | sz == 0 = die "maximum" "empty array" | (# frst #) <- indexArray## ary 0 = go 1 frst where sz = sizeofArray ary go i !e | i == sz = e | (# x #) <- indexArray## ary i = go (i+1) (max e x) {-# INLINE maximum #-} minimum ary | sz == 0 = die "minimum" "empty array" | (# frst #) <- indexArray## ary 0 = go 1 frst where sz = sizeofArray ary go i !e | i == sz = e | (# x #) <- indexArray## ary i = go (i+1) (min e x) {-# INLINE minimum #-} sum = foldl' (+) 0 {-# INLINE sum #-} product = foldl' (*) 1 {-# INLINE product #-} #endif newtype STA a = STA {_runSTA :: forall s. MutableArray# s a -> ST s (Array a)} runSTA :: Int -> STA a -> Array a runSTA !sz = \ (STA m) -> runST $ newArray_ sz >>= \ ar -> m (marray# ar) {-# INLINE runSTA #-} newArray_ :: Int -> ST s (MutableArray s a) newArray_ !n = newArray n badTraverseValue badTraverseValue :: a badTraverseValue = die "traverse" "bad indexing" {-# NOINLINE badTraverseValue #-} instance Traversable Array where traverse f = traverseArray f {-# INLINE traverse #-} traverseArray :: Applicative f => (a -> f b) -> Array a -> f (Array b) traverseArray f = \ !ary -> let !len = sizeofArray ary go !i | i == len = pure $ STA $ \mary -> unsafeFreezeArray (MutableArray mary) | (# x #) <- indexArray## ary i = liftA2 (\b (STA m) -> STA $ \mary -> writeArray (MutableArray mary) i b >> m mary) (f x) (go (i + 1)) in if len == 0 then pure emptyArray else runSTA len <$> go 0 {-# INLINE [1] traverseArray #-} {-# RULES "traverse/ST" forall (f :: a -> ST s b). traverseArray f = traverseArrayP f "traverse/IO" forall (f :: a -> IO b). traverseArray f = traverseArrayP f #-} #if MIN_VERSION_base(4,8,0) {-# RULES "traverse/Id" forall (f :: a -> Identity b). traverseArray f = (coerce :: (Array a -> Array (Identity b)) -> Array a -> Identity (Array b)) (fmap f) #-} #endif -- | This is the fastest, most straightforward way to traverse -- an array, but it only works correctly with a sufficiently -- "affine" 'PrimMonad' instance. In particular, it must only produce -- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed -- monads, for example, will not work right at all. traverseArrayP :: PrimMonad m => (a -> m b) -> Array a -> m (Array b) traverseArrayP f = \ !ary -> let !sz = sizeofArray ary go !i !mary | i == sz = unsafeFreezeArray mary | otherwise = do a <- indexArrayM ary i b <- f a writeArray mary i b go (i + 1) mary in do mary <- newArray sz badTraverseValue go 0 mary {-# INLINE traverseArrayP #-} -- | Strict map over the elements of the array. mapArray' :: (a -> b) -> Array a -> Array b mapArray' f a = createArray (sizeofArray a) (die "mapArray'" "impossible") $ \mb -> let go i | i == sizeofArray a = return () | otherwise = do x <- indexArrayM a i -- We use indexArrayM here so that we will perform the -- indexing eagerly even if f is lazy. let !y = f x writeArray mb i y >> go (i+1) in go 0 {-# INLINE mapArray' #-} arrayFromListN :: Int -> [a] -> Array a arrayFromListN n l = createArray n (die "fromListN" "uninitialized element") $ \sma -> let go !ix [] = if ix == n then return () else die "fromListN" "list length less than specified size" go !ix (x : xs) = if ix < n then do writeArray sma ix x go (ix+1) xs else die "fromListN" "list length greater than specified size" in go 0 l arrayFromList :: [a] -> Array a arrayFromList l = arrayFromListN (length l) l #if MIN_VERSION_base(4,7,0) instance Exts.IsList (Array a) where type Item (Array a) = a fromListN = arrayFromListN fromList = arrayFromList toList = toList #else fromListN :: Int -> [a] -> Array a fromListN = arrayFromListN fromList :: [a] -> Array a fromList = arrayFromList #endif instance Functor Array where fmap f a = createArray (sizeofArray a) (die "fmap" "impossible") $ \mb -> let go i | i == sizeofArray a = return () | otherwise = do x <- indexArrayM a i writeArray mb i (f x) >> go (i+1) in go 0 #if MIN_VERSION_base(4,8,0) e <$ a = createArray (sizeofArray a) e (\ !_ -> pure ()) #endif instance Applicative Array where pure x = runArray $ newArray 1 x ab <*> a = createArray (szab*sza) (die "<*>" "impossible") $ \mb -> let go1 i = when (i < szab) $ do f <- indexArrayM ab i go2 (i*sza) f 0 go1 (i+1) go2 off f j = when (j < sza) $ do x <- indexArrayM a j writeArray mb (off + j) (f x) go2 off f (j + 1) in go1 0 where szab = sizeofArray ab ; sza = sizeofArray a a *> b = createArray (sza*szb) (die "*>" "impossible") $ \mb -> let go i | i < sza = copyArray mb (i * szb) b 0 szb | otherwise = return () in go 0 where sza = sizeofArray a ; szb = sizeofArray b a <* b = createArray (sza*szb) (die "<*" "impossible") $ \ma -> let fill off i e | i < szb = writeArray ma (off+i) e >> fill off (i+1) e | otherwise = return () go i | i < sza = do x <- indexArrayM a i fill (i*szb) 0 x >> go (i+1) | otherwise = return () in go 0 where sza = sizeofArray a ; szb = sizeofArray b instance Alternative Array where empty = emptyArray a1 <|> a2 = createArray (sza1 + sza2) (die "<|>" "impossible") $ \ma -> copyArray ma 0 a1 0 sza1 >> copyArray ma sza1 a2 0 sza2 where sza1 = sizeofArray a1 ; sza2 = sizeofArray a2 some a | sizeofArray a == 0 = emptyArray | otherwise = die "some" "infinite arrays are not well defined" many a | sizeofArray a == 0 = pure [] | otherwise = die "many" "infinite arrays are not well defined" data ArrayStack a = PushArray !(Array a) !(ArrayStack a) | EmptyStack -- See the note in SmallArray about how we might improve this. instance Monad Array where return = pure (>>) = (*>) ary >>= f = collect 0 EmptyStack (la-1) where la = sizeofArray ary collect sz stk i | i < 0 = createArray sz (die ">>=" "impossible") $ fill 0 stk | (# x #) <- indexArray## ary i , let sb = f x lsb = sizeofArray sb -- If we don't perform this check, we could end up allocating -- a stack full of empty arrays if someone is filtering most -- things out. So we refrain from pushing empty arrays. = if lsb == 0 then collect sz stk (i - 1) else collect (sz + lsb) (PushArray sb stk) (i-1) fill _ EmptyStack _ = return () fill off (PushArray sb sbs) smb | let lsb = sizeofArray sb = copyArray smb off sb 0 (lsb) *> fill (off + lsb) sbs smb #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif instance Fail.MonadFail Array where fail _ = empty instance MonadPlus Array where mzero = empty mplus = (<|>) zipW :: String -> (a -> b -> c) -> Array a -> Array b -> Array c zipW s f aa ab = createArray mn (die s "impossible") $ \mc -> let go i | i < mn = do x <- indexArrayM aa i y <- indexArrayM ab i writeArray mc i (f x y) go (i+1) | otherwise = return () in go 0 where mn = sizeofArray aa `min` sizeofArray ab {-# INLINE zipW #-} #if MIN_VERSION_base(4,4,0) instance MonadZip Array where mzip aa ab = zipW "mzip" (,) aa ab mzipWith f aa ab = zipW "mzipWith" f aa ab munzip aab = runST $ do let sz = sizeofArray aab ma <- newArray sz (die "munzip" "impossible") mb <- newArray sz (die "munzip" "impossible") let go i | i < sz = do (a, b) <- indexArrayM aab i writeArray ma i a writeArray mb i b go (i+1) go _ = return () go 0 (,) <$> unsafeFreezeArray ma <*> unsafeFreezeArray mb #endif instance MonadFix Array where mfix f = createArray (sizeofArray (f err)) (die "mfix" "impossible") $ flip fix 0 $ \r !i !mary -> when (i < sz) $ do writeArray mary i (fix (\xi -> f xi `indexArray` i)) r (i + 1) mary where sz = sizeofArray (f err) err = error "mfix for Data.Primitive.Array applied to strict function." #if MIN_VERSION_base(4,9,0) -- | @since 0.6.3.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) = copyArray ma off a 0 (sizeofArray a) >> go (off + sizeofArray a) as in go 0 l where sz = sum . fmap sizeofArray $ l arrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Array a -> ShowS arrayLiftShowsPrec elemShowsPrec elemListShowsPrec p a = showParen (p > 10) $ showString "fromListN " . shows (sizeofArray a) . showString " " . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList a) -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS listLiftShowsPrec _ sl _ = sl instance Show a => Show (Array a) where showsPrec p a = arrayLiftShowsPrec showsPrec showList p a #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Show1 Array where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftShowsPrec = arrayLiftShowsPrec #else showsPrec1 = arrayLiftShowsPrec showsPrec showList #endif #endif instance Read a => Read (Array a) where readPrec = arrayLiftReadPrec readPrec readListPrec #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Read1 Array where #if MIN_VERSION_base(4,10,0) liftReadPrec = arrayLiftReadPrec #elif MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftReadsPrec = arrayLiftReadsPrec #else readsPrec1 = arrayLiftReadsPrec readsPrec readList #endif #endif -- We're really forgiving here. We accept -- "[1,2,3]", "fromList [1,2,3]", and "fromListN 3 [1,2,3]". -- We consider fromListN with an invalid length to be an -- error, rather than a parse failure, because doing otherwise -- seems weird and likely to make debugging difficult. arrayLiftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (Array a) arrayLiftReadPrec _ read_list = parens $ prec app_prec $ RdPrc.lift skipSpaces >> ((fromList <$> read_list) RdPrc.+++ do tag <- RdPrc.lift lexTag case tag of FromListTag -> fromList <$> read_list FromListNTag -> liftM2 fromListN readPrec read_list) where app_prec = 10 data Tag = FromListTag | FromListNTag -- Why don't we just use lexP? The general problem with lexP is that -- it doesn't always fail as fast as we might like. It will -- happily read to the end of an absurdly long lexeme (e.g., a 200MB string -- literal) before returning, at which point we'll immediately discard -- the result because it's not an identifier. Doing the job ourselves, we -- can see very quickly when we've run into a problem. We should also get -- a slight efficiency boost by going through the string just once. lexTag :: ReadP Tag lexTag = do _ <- string "fromList" s <- look case s of 'N':c:_ | '0' <= c && c <= '9' -> fail "" -- We have fromListN3 or similar | otherwise -> FromListNTag <$ get -- Skip the 'N' _ -> return FromListTag #if !MIN_VERSION_base(4,10,0) arrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (Array a) arrayLiftReadsPrec reads_prec list_reads_prec = RdPrc.readPrec_to_S $ arrayLiftReadPrec (RdPrc.readS_to_Prec reads_prec) (RdPrc.readS_to_Prec (const list_reads_prec)) #endif arrayDataType :: DataType arrayDataType = mkDataType "Data.Primitive.Array.Array" [fromListConstr] fromListConstr :: Constr fromListConstr = mkConstr arrayDataType "fromList" [] Prefix instance Data a => Data (Array a) where toConstr _ = fromListConstr dataTypeOf _ = arrayDataType gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> error "gunfold" gfoldl f z m = z fromList `f` toList m instance (Typeable s, Typeable a) => Data (MutableArray s a) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.Array.MutableArray" primitive-0.7.0.1/Data/Primitive/ByteArray.hs0000644000000000000000000005002507346545000017137 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.Primitive.ByteArray -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive operations on ByteArrays -- module Data.Primitive.ByteArray ( -- * Types ByteArray(..), MutableByteArray(..), ByteArray#, MutableByteArray#, -- * Allocation newByteArray, newPinnedByteArray, newAlignedPinnedByteArray, resizeMutableByteArray, -- * Element access readByteArray, writeByteArray, indexByteArray, -- * Constructing byteArrayFromList, byteArrayFromListN, -- * Folding foldrByteArray, -- * Freezing and thawing unsafeFreezeByteArray, unsafeThawByteArray, -- * Block operations copyByteArray, copyMutableByteArray, #if __GLASGOW_HASKELL__ >= 708 copyByteArrayToAddr, copyMutableByteArrayToAddr, #endif moveByteArray, setByteArray, fillByteArray, -- * Information sizeofByteArray, sizeofMutableByteArray, getSizeofMutableByteArray, sameMutableByteArray, #if __GLASGOW_HASKELL__ >= 802 isByteArrayPinned, isMutableByteArrayPinned, #endif byteArrayContents, mutableByteArrayContents ) where import Control.Monad.Primitive import Control.Monad.ST 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.Exts #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#) #endif import Data.Typeable ( Typeable ) import Data.Data ( Data(..) ) import Data.Primitive.Internal.Compat ( isTrue#, mkNoRepType ) import Numeric #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as SG import qualified Data.Foldable as F #endif #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif #if __GLASGOW_HASKELL__ >= 802 import GHC.Exts as Exts (isByteArrayPinned#,isMutableByteArrayPinned#) #endif #if __GLASGOW_HASKELL__ >= 804 import GHC.Exts (compareByteArrays#) #else import System.IO.Unsafe (unsafeDupablePerformIO) #endif -- | Byte arrays data ByteArray = ByteArray ByteArray# deriving ( Typeable ) -- | Mutable byte arrays associated with a primitive state token data MutableByteArray s = MutableByteArray (MutableByteArray# s) deriving( Typeable ) -- | 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 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 in bytes and with the -- given alignment. The garbage collector is guaranteed not to move it. newAlignedPinnedByteArray :: PrimMonad m => Int -- ^ size -> Int -- ^ alignment -> m (MutableByteArray (PrimState m)) {-# INLINE newAlignedPinnedByteArray #-} newAlignedPinnedByteArray (I# n#) (I# k#) = primitive (\s# -> case newAlignedPinnedByteArray# n# k# s# of (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)) -- | Yield a pointer to the array's data. This operation is only safe on -- /pinned/ byte arrays allocated by 'newPinnedByteArray' or -- 'newAlignedPinnedByteArray'. byteArrayContents :: ByteArray -> Ptr Word8 {-# INLINE byteArrayContents #-} byteArrayContents (ByteArray arr#) = Ptr (byteArrayContents# arr#) -- | Yield a pointer to the array's data. This operation is only safe on -- /pinned/ byte arrays allocated by 'newPinnedByteArray' or -- 'newAlignedPinnedByteArray'. mutableByteArrayContents :: MutableByteArray s -> Ptr Word8 {-# INLINE mutableByteArrayContents #-} mutableByteArrayContents (MutableByteArray arr#) = Ptr (byteArrayContents# (unsafeCoerce# arr#)) -- | Check if the two arrays refer to the same memory block. sameMutableByteArray :: MutableByteArray s -> MutableByteArray s -> Bool {-# INLINE sameMutableByteArray #-} sameMutableByteArray (MutableByteArray arr#) (MutableByteArray brr#) = isTrue# (sameMutableByteArray# arr# brr#) -- | Resize a mutable byte array. The new size is given in bytes. -- -- This will either resize the array in-place or, if not possible, allocate the -- contents into a new, unpinned array and copy the original array's contents. -- -- To avoid undefined behaviour, the original 'MutableByteArray' shall not be -- accessed anymore after a 'resizeMutableByteArray' has been performed. -- Moreover, no reference to the old one should be kept in order to allow -- garbage collection of the original 'MutableByteArray' in case a new -- 'MutableByteArray' had to be allocated. -- -- @since 0.6.4.0 resizeMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> Int -> m (MutableByteArray (PrimState m)) {-# INLINE resizeMutableByteArray #-} #if __GLASGOW_HASKELL__ >= 710 resizeMutableByteArray (MutableByteArray arr#) (I# n#) = primitive (\s# -> case resizeMutableByteArray# arr# n# s# of (# s'#, arr'# #) -> (# s'#, MutableByteArray arr'# #)) #else resizeMutableByteArray arr n = do arr' <- newByteArray n copyMutableByteArray arr' 0 arr 0 (min (sizeofMutableByteArray arr) n) return arr' #endif -- | Get the size of a byte array in bytes. Unlike 'sizeofMutableByteArray', -- this function ensures sequencing in the presence of resizing. getSizeofMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> m Int {-# INLINE getSizeofMutableByteArray #-} #if __GLASGOW_HASKELL__ >= 801 getSizeofMutableByteArray (MutableByteArray arr#) = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of (# s'#, n# #) -> (# s'#, I# n# #)) #else getSizeofMutableByteArray arr = return (sizeofMutableByteArray arr) #endif -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezeByteArray :: PrimMonad m => MutableByteArray (PrimState m) -> m ByteArray {-# INLINE unsafeFreezeByteArray #-} unsafeFreezeByteArray (MutableByteArray arr#) = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, ByteArray arr'# #)) -- | Convert an immutable byte array to a mutable one without copying. The -- original array should not be used after the conversion. unsafeThawByteArray :: PrimMonad m => ByteArray -> m (MutableByteArray (PrimState m)) {-# INLINE unsafeThawByteArray #-} unsafeThawByteArray (ByteArray arr#) = primitive (\s# -> (# s#, MutableByteArray (unsafeCoerce# arr#) #)) -- | Size of the byte array in bytes. sizeofByteArray :: ByteArray -> Int {-# INLINE sizeofByteArray #-} sizeofByteArray (ByteArray arr#) = I# (sizeofByteArray# arr#) -- | Size of the mutable byte array in bytes. This function\'s behavior -- is undefined if 'resizeMutableByteArray' is ever called on the mutable -- byte array given as the argument. Consequently, use of this function -- is discouraged. Prefer 'getSizeofMutableByteArray', which ensures correct -- sequencing in the presence of resizing. sizeofMutableByteArray :: MutableByteArray s -> Int {-# INLINE sizeofMutableByteArray #-} sizeofMutableByteArray (MutableByteArray arr#) = I# (sizeofMutableByteArray# arr#) #if __GLASGOW_HASKELL__ >= 802 -- | Check whether or not the byte array is pinned. Pinned byte arrays cannot -- be moved by the garbage collector. It is safe to use 'byteArrayContents' -- on such byte arrays. This function is only available when compiling with -- GHC 8.2 or newer. -- -- @since 0.6.4.0 isByteArrayPinned :: ByteArray -> Bool {-# INLINE isByteArrayPinned #-} isByteArrayPinned (ByteArray arr#) = isTrue# (Exts.isByteArrayPinned# arr#) -- | Check whether or not the mutable byte array is pinned. This function is -- only available when compiling with GHC 8.2 or newer. -- -- @since 0.6.4.0 isMutableByteArrayPinned :: MutableByteArray s -> Bool {-# INLINE isMutableByteArrayPinned #-} isMutableByteArrayPinned (MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) #endif -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes. indexByteArray :: Prim a => ByteArray -> Int -> a {-# INLINE indexByteArray #-} indexByteArray (ByteArray arr#) (I# i#) = indexByteArray# arr# i# -- | Read a primitive value from the byte array. The offset is given in -- elements of type @a@ rather than in bytes. readByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a {-# INLINE readByteArray #-} readByteArray (MutableByteArray arr#) (I# i#) = primitive (readByteArray# arr# i#) -- | Write a primitive value to the byte array. The offset is given in -- elements of type @a@ rather than in bytes. writeByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m () {-# INLINE writeByteArray #-} 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 {-# INLINE foldrByteArray #-} foldrByteArray f z arr = go 0 where go i | i < maxI = f (indexByteArray arr i) (go (i+1)) | otherwise = z maxI = sizeofByteArray arr `quot` sizeOf (undefined :: a) byteArrayFromList :: Prim a => [a] -> ByteArray byteArrayFromList xs = byteArrayFromListN (length xs) xs byteArrayFromListN :: Prim a => Int -> [a] -> ByteArray byteArrayFromListN n ys = runST $ do marr <- newByteArray (n * sizeOf (head ys)) let go !ix [] = if ix == n then return () else die "byteArrayFromListN" "list length less than specified size" go !ix (x : xs) = if ix < n then do writeByteArray marr ix x go (ix + 1) xs else die "byteArrayFromListN" "list length greater than specified size" go 0 ys unsafeFreezeByteArray marr unI# :: Int -> Int# unI# (I# n#) = n# -- | Copy a slice of an immutable byte array to a mutable byte array. copyByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> ByteArray -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyByteArray #-} copyByteArray (MutableByteArray dst#) doff (ByteArray src#) soff sz = primitive_ (copyByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) -- | Copy a slice of a mutable byte array into another array. The two slices -- may not overlap. copyMutableByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> MutableByteArray (PrimState m) -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyMutableByteArray #-} copyMutableByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz = primitive_ (copyMutableByteArray# src# (unI# soff) dst# (unI# doff) (unI# sz)) #if __GLASGOW_HASKELL__ >= 708 -- | Copy a slice of a byte array to an unmanaged address. These must not -- overlap. This function is only available when compiling with GHC 7.8 -- or newer. -- -- @since 0.6.4.0 copyByteArrayToAddr :: PrimMonad m => Ptr Word8 -- ^ destination -> ByteArray -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyByteArrayToAddr #-} copyByteArrayToAddr (Ptr dst#) (ByteArray src#) soff sz = primitive_ (copyByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) -- | Copy a slice of a mutable byte array to an unmanaged address. These must -- not overlap. This function is only available when compiling with GHC 7.8 -- or newer. -- -- @since 0.6.4.0 copyMutableByteArrayToAddr :: PrimMonad m => Ptr Word8 -- ^ destination -> MutableByteArray (PrimState m) -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE copyMutableByteArrayToAddr #-} copyMutableByteArrayToAddr (Ptr dst#) (MutableByteArray src#) soff sz = primitive_ (copyMutableByteArrayToAddr# src# (unI# soff) dst# (unI# sz)) #endif -- | Copy a slice of a mutable byte array into another, potentially -- overlapping array. moveByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ destination array -> Int -- ^ offset into destination array -> MutableByteArray (PrimState m) -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () {-# INLINE moveByteArray #-} moveByteArray (MutableByteArray dst#) doff (MutableByteArray src#) soff sz = unsafePrimToPrim $ memmove_mba dst# (fromIntegral doff) src# (fromIntegral soff) (fromIntegral sz) -- | Fill a slice of a mutable byte array with a value. The offset and length -- are given in elements of type @a@ rather than in bytes. setByteArray :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of values to fill -> a -- ^ value to fill with -> m () {-# INLINE setByteArray #-} setByteArray (MutableByteArray dst#) (I# doff#) (I# sz#) x = primitive_ (setByteArray# dst# doff# sz# x) -- | Fill a slice of a mutable byte array with a byte. fillByteArray :: PrimMonad m => MutableByteArray (PrimState m) -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of bytes to fill -> Word8 -- ^ byte to fill with -> m () {-# INLINE fillByteArray #-} fillByteArray = setByteArray foreign import ccall unsafe "primitive-memops.h hsprimitive_memmove" memmove_mba :: MutableByteArray# s -> CInt -> MutableByteArray# s -> CInt -> CSize -> IO () instance Data ByteArray where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.ByteArray" instance Typeable s => Data (MutableByteArray s) where toConstr _ = error "toConstr" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "Data.Primitive.ByteArray.MutableByteArray" -- | @since 0.6.3.0 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 ", " compareByteArrays :: ByteArray -> ByteArray -> Int -> Ordering {-# INLINE compareByteArrays #-} #if __GLASGOW_HASKELL__ >= 804 compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) = compare (I# (compareByteArrays# ba1# 0# ba2# 0# n#)) 0 #else -- Emulate GHC 8.4's 'GHC.Prim.compareByteArrays#' compareByteArrays (ByteArray ba1#) (ByteArray ba2#) (I# n#) = compare (fromCInt (unsafeDupablePerformIO (memcmp_ba ba1# ba2# n))) 0 where n = fromIntegral (I# n#) :: CSize fromCInt = fromIntegral :: CInt -> Int foreign import ccall unsafe "primitive-memops.h hsprimitive_memcmp" memcmp_ba :: ByteArray# -> ByteArray# -> CSize -> IO CInt #endif 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 -- | @since 0.6.3.0 instance Eq ByteArray where ba1@(ByteArray ba1#) == ba2@(ByteArray ba2#) | sameByteArray ba1# ba2# = True | n1 /= n2 = False | otherwise = compareByteArrays ba1 ba2 n1 == EQ where n1 = sizeofByteArray ba1 n2 = sizeofByteArray ba2 -- | Non-lexicographic ordering. This compares the lengths of -- the byte arrays first and uses a lexicographic ordering if -- the lengths are equal. Subject to change between major versions. -- -- @since 0.6.3.0 instance Ord ByteArray where ba1@(ByteArray ba1#) `compare` ba2@(ByteArray ba2#) | sameByteArray ba1# ba2# = EQ | n1 /= n2 = n1 `compare` n2 | otherwise = compareByteArrays ba1 ba2 n1 where n1 = sizeofByteArray ba1 n2 = sizeofByteArray ba2 -- Note: On GHC 8.4, the primop compareByteArrays# performs a check for pointer -- equality as a shortcut, so the check here is actually redundant. However, it -- is included here because it is likely better to check for pointer equality -- before checking for length equality. Getting the length requires deferencing -- the pointers, which could cause accesses to memory that is not in the cache. -- By contrast, a pointer equality check is always extremely cheap. appendByteArray :: ByteArray -> ByteArray -> ByteArray appendByteArray a b = runST $ do marr <- newByteArray (sizeofByteArray a + sizeofByteArray b) copyByteArray marr 0 a 0 (sizeofByteArray a) copyByteArray marr (sizeofByteArray a) b 0 (sizeofByteArray b) unsafeFreezeByteArray marr concatByteArray :: [ByteArray] -> ByteArray concatByteArray arrs = runST $ do let len = calcLength arrs 0 marr <- newByteArray len pasteByteArrays marr 0 arrs unsafeFreezeByteArray marr pasteByteArrays :: MutableByteArray s -> Int -> [ByteArray] -> ST s () pasteByteArrays !_ !_ [] = return () pasteByteArrays !marr !ix (x : xs) = do copyByteArray marr ix x 0 (sizeofByteArray x) pasteByteArrays marr (ix + sizeofByteArray x) xs calcLength :: [ByteArray] -> Int -> Int calcLength [] !n = n calcLength (x : xs) !n = calcLength xs (sizeofByteArray x + n) emptyByteArray :: ByteArray emptyByteArray = runST (newByteArray 0 >>= unsafeFreezeByteArray) replicateByteArray :: Int -> ByteArray -> ByteArray replicateByteArray n arr = runST $ do marr <- newByteArray (n * sizeofByteArray arr) let go i = if i < n then do copyByteArray marr (i * sizeofByteArray arr) arr 0 (sizeofByteArray arr) go (i + 1) else return () go 0 unsafeFreezeByteArray marr #if MIN_VERSION_base(4,9,0) instance SG.Semigroup ByteArray where (<>) = appendByteArray sconcat = mconcat . F.toList stimes i arr | itgr < 1 = emptyByteArray | itgr <= (fromIntegral (maxBound :: Int)) = replicateByteArray (fromIntegral itgr) arr | otherwise = error "Data.Primitive.ByteArray#stimes: cannot allocate the requested amount of memory" where itgr = toInteger i :: Integer #endif instance Monoid ByteArray where mempty = emptyByteArray #if !(MIN_VERSION_base(4,11,0)) mappend = appendByteArray #endif mconcat = concatByteArray #if __GLASGOW_HASKELL__ >= 708 -- | @since 0.6.3.0 instance Exts.IsList ByteArray where type Item ByteArray = Word8 toList = foldrByteArray (:) [] fromList xs = byteArrayFromListN (length xs) xs fromListN = byteArrayFromListN #endif die :: String -> String -> a die fun problem = error $ "Data.Primitive.ByteArray." ++ fun ++ ": " ++ problem primitive-0.7.0.1/Data/Primitive/Internal/0000755000000000000000000000000007346545000016453 5ustar0000000000000000primitive-0.7.0.1/Data/Primitive/Internal/Compat.hs0000644000000000000000000000123707346545000020235 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash #-} -- | -- Module : Data.Primitive.Internal.Compat -- Copyright : (c) Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Compatibility functions -- module Data.Primitive.Internal.Compat ( isTrue# , mkNoRepType ) where #if MIN_VERSION_base(4,2,0) import Data.Data (mkNoRepType) #else import Data.Data (mkNorepType) #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#) #endif #if !MIN_VERSION_base(4,2,0) mkNoRepType = mkNorepType #endif #if !MIN_VERSION_base(4,7,0) isTrue# :: Bool -> Bool isTrue# b = b #endif primitive-0.7.0.1/Data/Primitive/Internal/Operations.hs0000644000000000000000000001247507346545000021143 0ustar0000000000000000{-# LANGUAGE MagicHash, UnliftedFFITypes #-} -- | -- Module : Data.Primitive.Internal.Operations -- Copyright : (c) Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Internal operations -- module Data.Primitive.Internal.Operations ( setWord8Array#, setWord16Array#, setWord32Array#, setWord64Array#, setWordArray#, setInt8Array#, setInt16Array#, setInt32Array#, setInt64Array#, setIntArray#, setAddrArray#, setStablePtrArray#, setFloatArray#, setDoubleArray#, setWideCharArray#, setWord8OffAddr#, setWord16OffAddr#, setWord32OffAddr#, setWord64OffAddr#, setWordOffAddr#, setInt8OffAddr#, setInt16OffAddr#, setInt32OffAddr#, setInt64OffAddr#, setIntOffAddr#, setAddrOffAddr#, setFloatOffAddr#, setDoubleOffAddr#, setWideCharOffAddr#, setStablePtrOffAddr# ) where import Data.Primitive.MachDeps (Word64_#, Int64_#) import Foreign.C.Types import GHC.Exts foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setWord8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setWord16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setWord32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setWord64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setWordArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setInt8Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setInt16Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setInt32Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setInt64Array# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setIntArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setAddrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Addr# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setStablePtrArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> StablePtr# a -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" setFloatArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" setDoubleArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharArray# :: MutableByteArray# s -> CPtrdiff -> CSize -> Char# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setWord8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setWord16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setWord32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setWord64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Word64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setWordOffAddr# :: Addr# -> CPtrdiff -> CSize -> Word# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word8" setInt8OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word16" setInt16OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word32" setInt32OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word64" setInt64OffAddr# :: Addr# -> CPtrdiff -> CSize -> Int64_# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Word" setIntOffAddr# :: Addr# -> CPtrdiff -> CSize -> Int# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setAddrOffAddr# :: Addr# -> CPtrdiff -> CSize -> Addr# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Ptr" setStablePtrOffAddr# :: Addr# -> CPtrdiff -> CSize -> StablePtr# a -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Float" setFloatOffAddr# :: Addr# -> CPtrdiff -> CSize -> Float# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Double" setDoubleOffAddr# :: Addr# -> CPtrdiff -> CSize -> Double# -> IO () foreign import ccall unsafe "primitive-memops.h hsprimitive_memset_Char" setWideCharOffAddr# :: Addr# -> CPtrdiff -> CSize -> Char# -> IO () primitive-0.7.0.1/Data/Primitive/MVar.hs0000644000000000000000000001313507346545000016103 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Primitive.MVar -- License : BSD2 -- Portability : non-portable -- -- Primitive operations on @MVar@. This module provides a similar interface -- to "Control.Concurrent.MVar". However, the functions are generalized to -- work in any 'PrimMonad' instead of only working in 'IO'. Note that all -- of the functions here are completely deterministic. Users of 'MVar' are -- responsible for designing abstractions that guarantee determinism in -- the presence of multi-threading. -- -- @since 0.6.4.0 module Data.Primitive.MVar ( MVar(..) , newMVar , isEmptyMVar , newEmptyMVar , putMVar , readMVar , takeMVar , tryPutMVar , tryReadMVar , tryTakeMVar ) where import Control.Monad.Primitive import Data.Primitive.Internal.Compat (isTrue#) import GHC.Exts (MVar#,newMVar#,takeMVar#,sameMVar#,putMVar#,tryTakeMVar#, isEmptyMVar#,tryPutMVar#,(/=#)) #if __GLASGOW_HASKELL__ >= 708 import GHC.Exts (readMVar#,tryReadMVar#) #endif data MVar s a = MVar (MVar# s a) instance Eq (MVar s a) where MVar mvar1# == MVar mvar2# = isTrue# (sameMVar# mvar1# mvar2#) -- | Create a new 'MVar' that is initially empty. newEmptyMVar :: PrimMonad m => m (MVar (PrimState m) a) newEmptyMVar = primitive $ \ s# -> case newMVar# s# of (# s2#, svar# #) -> (# s2#, MVar svar# #) -- | Create a new 'MVar' that holds the supplied argument. newMVar :: PrimMonad m => a -> m (MVar (PrimState m) a) newMVar value = newEmptyMVar >>= \ mvar -> putMVar mvar value >> return mvar -- | Return the contents of the 'MVar'. If the 'MVar' is currently -- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', -- the 'MVar' is left empty. takeMVar :: PrimMonad m => MVar (PrimState m) a -> m a takeMVar (MVar mvar#) = primitive $ \ s# -> takeMVar# mvar# s# -- | Atomically read the contents of an 'MVar'. If the 'MVar' is -- currently empty, 'readMVar' will wait until it is full. -- 'readMVar' is guaranteed to receive the next 'putMVar'. -- -- /Multiple Wakeup:/ 'readMVar' is multiple-wakeup, so when multiple readers -- are blocked on an 'MVar', all of them are woken up at the same time. -- -- /Compatibility note:/ On GHCs prior to 7.8, 'readMVar' is a combination -- of 'takeMVar' and 'putMVar'. Consequently, its behavior differs in the -- following ways: -- -- * It is single-wakeup instead of multiple-wakeup. -- * It might not receive the value from the next call to 'putMVar' if -- there is already a pending thread blocked on 'takeMVar'. -- * If another thread puts a value in the 'MVar' in between the -- calls to 'takeMVar' and 'putMVar', that value may be overridden. readMVar :: PrimMonad m => MVar (PrimState m) a -> m a #if __GLASGOW_HASKELL__ >= 708 readMVar (MVar mvar#) = primitive $ \ s# -> readMVar# mvar# s# #else readMVar mv = do a <- takeMVar mv putMVar mv a return a #endif -- |Put a value into an 'MVar'. If the 'MVar' is currently full, -- 'putMVar' will wait until it becomes empty. putMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m () putMVar (MVar mvar#) x = primitive_ (putMVar# mvar# x) -- |A non-blocking version of 'takeMVar'. The 'tryTakeMVar' function -- returns immediately, with 'Nothing' if the 'MVar' was empty, or -- @'Just' a@ if the 'MVar' was full with contents @a@. After 'tryTakeMVar', -- the 'MVar' is left empty. tryTakeMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) tryTakeMVar (MVar m) = primitive $ \ s -> case tryTakeMVar# m s of (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty (# s', _, a #) -> (# s', Just a #) -- MVar is full -- |A non-blocking version of 'putMVar'. The 'tryPutMVar' function -- attempts to put the value @a@ into the 'MVar', returning 'True' if -- it was successful, or 'False' otherwise. tryPutMVar :: PrimMonad m => MVar (PrimState m) a -> a -> m Bool tryPutMVar (MVar mvar#) x = primitive $ \ s# -> case tryPutMVar# mvar# x s# of (# s, 0# #) -> (# s, False #) (# s, _ #) -> (# s, True #) -- | A non-blocking version of 'readMVar'. The 'tryReadMVar' function -- returns immediately, with 'Nothing' if the 'MVar' was empty, or -- @'Just' a@ if the 'MVar' was full with contents @a@. -- -- /Compatibility note:/ On GHCs prior to 7.8, 'tryReadMVar' is a combination -- of 'tryTakeMVar' and 'putMVar'. Consequently, its behavior differs in the -- following ways: -- -- * It is single-wakeup instead of multiple-wakeup. -- * In the presence of other threads calling 'putMVar', 'tryReadMVar' -- may block. -- * If another thread puts a value in the 'MVar' in between the -- calls to 'tryTakeMVar' and 'putMVar', that value may be overridden. tryReadMVar :: PrimMonad m => MVar (PrimState m) a -> m (Maybe a) #if __GLASGOW_HASKELL__ >= 708 tryReadMVar (MVar m) = primitive $ \ s -> case tryReadMVar# m s of (# s', 0#, _ #) -> (# s', Nothing #) -- MVar is empty (# s', _, a #) -> (# s', Just a #) -- MVar is full #else tryReadMVar mv = do ma <- tryTakeMVar mv case ma of Just a -> do putMVar mv a return (Just a) Nothing -> return Nothing #endif -- | Check whether a given 'MVar' is empty. -- -- Notice that the boolean value returned is just a snapshot of -- the state of the MVar. By the time you get to react on its result, -- the MVar may have been filled (or emptied) - so be extremely -- careful when using this operation. Use 'tryTakeMVar' instead if possible. isEmptyMVar :: PrimMonad m => MVar (PrimState m) a -> m Bool isEmptyMVar (MVar mv#) = primitive $ \ s# -> case isEmptyMVar# mv# s# of (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #) primitive-0.7.0.1/Data/Primitive/MachDeps.hs0000644000000000000000000000405507346545000016723 0ustar0000000000000000{-# LANGUAGE CPP, MagicHash #-} -- | -- Module : Data.Primitive.MachDeps -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Machine-dependent constants -- module Data.Primitive.MachDeps where #include "MachDeps.h" import GHC.Exts sIZEOF_CHAR, aLIGNMENT_CHAR, sIZEOF_INT, aLIGNMENT_INT, sIZEOF_WORD, aLIGNMENT_WORD, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, sIZEOF_FLOAT, aLIGNMENT_FLOAT, sIZEOF_PTR, aLIGNMENT_PTR, sIZEOF_FUNPTR, aLIGNMENT_FUNPTR, sIZEOF_STABLEPTR, aLIGNMENT_STABLEPTR, sIZEOF_INT8, aLIGNMENT_INT8, sIZEOF_WORD8, aLIGNMENT_WORD8, sIZEOF_INT16, aLIGNMENT_INT16, sIZEOF_WORD16, aLIGNMENT_WORD16, sIZEOF_INT32, aLIGNMENT_INT32, sIZEOF_WORD32, aLIGNMENT_WORD32, sIZEOF_INT64, aLIGNMENT_INT64, sIZEOF_WORD64, aLIGNMENT_WORD64 :: Int sIZEOF_CHAR = SIZEOF_HSCHAR aLIGNMENT_CHAR = ALIGNMENT_HSCHAR sIZEOF_INT = SIZEOF_HSINT aLIGNMENT_INT = ALIGNMENT_HSINT sIZEOF_WORD = SIZEOF_HSWORD aLIGNMENT_WORD = ALIGNMENT_HSWORD sIZEOF_DOUBLE = SIZEOF_HSDOUBLE aLIGNMENT_DOUBLE = ALIGNMENT_HSDOUBLE sIZEOF_FLOAT = SIZEOF_HSFLOAT aLIGNMENT_FLOAT = ALIGNMENT_HSFLOAT sIZEOF_PTR = SIZEOF_HSPTR aLIGNMENT_PTR = ALIGNMENT_HSPTR sIZEOF_FUNPTR = SIZEOF_HSFUNPTR aLIGNMENT_FUNPTR = ALIGNMENT_HSFUNPTR sIZEOF_STABLEPTR = SIZEOF_HSSTABLEPTR aLIGNMENT_STABLEPTR = ALIGNMENT_HSSTABLEPTR sIZEOF_INT8 = SIZEOF_INT8 aLIGNMENT_INT8 = ALIGNMENT_INT8 sIZEOF_WORD8 = SIZEOF_WORD8 aLIGNMENT_WORD8 = ALIGNMENT_WORD8 sIZEOF_INT16 = SIZEOF_INT16 aLIGNMENT_INT16 = ALIGNMENT_INT16 sIZEOF_WORD16 = SIZEOF_WORD16 aLIGNMENT_WORD16 = ALIGNMENT_WORD16 sIZEOF_INT32 = SIZEOF_INT32 aLIGNMENT_INT32 = ALIGNMENT_INT32 sIZEOF_WORD32 = SIZEOF_WORD32 aLIGNMENT_WORD32 = ALIGNMENT_WORD32 sIZEOF_INT64 = SIZEOF_INT64 aLIGNMENT_INT64 = ALIGNMENT_INT64 sIZEOF_WORD64 = SIZEOF_WORD64 aLIGNMENT_WORD64 = ALIGNMENT_WORD64 #if WORD_SIZE_IN_BITS == 32 type Word64_# = Word64# type Int64_# = Int64# #else type Word64_# = Word# type Int64_# = Int# #endif primitive-0.7.0.1/Data/Primitive/MutVar.hs0000644000000000000000000000553307346545000016457 0ustar0000000000000000{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable, CPP #-} -- | -- Module : Data.Primitive.MutVar -- Copyright : (c) Justin Bonnar 2011, Roman Leshchinskiy 2011-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive boxed mutable variables -- module Data.Primitive.MutVar ( MutVar(..), newMutVar, readMutVar, writeMutVar, atomicModifyMutVar, atomicModifyMutVar', modifyMutVar, modifyMutVar' ) where import Control.Monad.Primitive ( PrimMonad(..), primitive_ ) import GHC.Exts ( MutVar#, sameMutVar#, newMutVar#, readMutVar#, writeMutVar#, atomicModifyMutVar# ) import Data.Primitive.Internal.Compat ( isTrue# ) import Data.Typeable ( Typeable ) -- | A 'MutVar' behaves like a single-element mutable array associated -- with a primitive state token. data MutVar s a = MutVar (MutVar# s a) deriving ( Typeable ) instance Eq (MutVar s a) where MutVar mva# == MutVar mvb# = isTrue# (sameMutVar# mva# mvb#) -- | Create a new 'MutVar' with the specified initial value newMutVar :: PrimMonad m => a -> m (MutVar (PrimState m) a) {-# INLINE newMutVar #-} newMutVar initialValue = primitive $ \s# -> case newMutVar# initialValue s# of (# s'#, mv# #) -> (# s'#, MutVar mv# #) -- | Read the value of a 'MutVar' readMutVar :: PrimMonad m => MutVar (PrimState m) a -> m a {-# INLINE readMutVar #-} readMutVar (MutVar mv#) = primitive (readMutVar# mv#) -- | Write a new value into a 'MutVar' writeMutVar :: PrimMonad m => MutVar (PrimState m) a -> a -> m () {-# INLINE writeMutVar #-} writeMutVar (MutVar mv#) newValue = primitive_ (writeMutVar# mv# newValue) -- | Atomically mutate the contents of a 'MutVar' atomicModifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a,b)) -> m b {-# INLINE atomicModifyMutVar #-} atomicModifyMutVar (MutVar mv#) f = primitive $ atomicModifyMutVar# mv# f -- | Strict version of 'atomicModifyMutVar'. This forces both the value stored -- in the 'MutVar' as well as the value returned. atomicModifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> (a, b)) -> m b {-# INLINE atomicModifyMutVar' #-} atomicModifyMutVar' mv f = do b <- atomicModifyMutVar mv force b `seq` return b where force x = case f x of v@(x',_) -> x' `seq` v -- | Mutate the contents of a 'MutVar' modifyMutVar :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar #-} modifyMutVar (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> writeMutVar# mv# (g a) s'# -- | Strict version of 'modifyMutVar' modifyMutVar' :: PrimMonad m => MutVar (PrimState m) a -> (a -> a) -> m () {-# INLINE modifyMutVar' #-} modifyMutVar' (MutVar mv#) g = primitive_ $ \s# -> case readMutVar# mv# s# of (# s'#, a #) -> let a' = g a in a' `seq` writeMutVar# mv# a' s'# primitive-0.7.0.1/Data/Primitive/PrimArray.hs0000644000000000000000000010054207346545000017143 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} -- | -- Module : Data.Primitive.PrimArray -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Arrays of unboxed primitive types. The function provided by this module -- match the behavior of those provided by @Data.Primitive.ByteArray@, and -- the underlying types and primops that back them are the same. -- However, the type constructors 'PrimArray' and 'MutablePrimArray' take one additional -- argument than their respective counterparts 'ByteArray' and 'MutableByteArray'. -- This argument is used to designate the type of element in the array. -- Consequently, all function this modules accepts length and incides in -- terms of elements, not bytes. -- -- @since 0.6.4.0 module Data.Primitive.PrimArray ( -- * Types PrimArray(..) , MutablePrimArray(..) -- * Allocation , newPrimArray , resizeMutablePrimArray #if __GLASGOW_HASKELL__ >= 710 , shrinkMutablePrimArray #endif -- * Element Access , readPrimArray , writePrimArray , indexPrimArray -- * Freezing and Thawing , unsafeFreezePrimArray , unsafeThawPrimArray -- * Block Operations , copyPrimArray , copyMutablePrimArray #if __GLASGOW_HASKELL__ >= 708 , copyPrimArrayToPtr , copyMutablePrimArrayToPtr #endif , setPrimArray -- * Information , sameMutablePrimArray , getSizeofMutablePrimArray , sizeofMutablePrimArray , sizeofPrimArray -- * List Conversion , primArrayToList , primArrayFromList , primArrayFromListN -- * Folding , foldrPrimArray , foldrPrimArray' , foldlPrimArray , foldlPrimArray' , foldlPrimArrayM' -- * Effectful Folding , traversePrimArray_ , itraversePrimArray_ -- * Map/Create , mapPrimArray , imapPrimArray , generatePrimArray , replicatePrimArray , filterPrimArray , mapMaybePrimArray -- * Effectful Map/Create -- $effectfulMapCreate -- ** Lazy Applicative , traversePrimArray , itraversePrimArray , generatePrimArrayA , replicatePrimArrayA , filterPrimArrayA , mapMaybePrimArrayA -- ** Strict Primitive Monadic , traversePrimArrayP , itraversePrimArrayP , generatePrimArrayP , replicatePrimArrayP , filterPrimArrayP , mapMaybePrimArrayP ) where import GHC.Exts import GHC.Base ( Int(..) ) import Data.Primitive.Internal.Compat (isTrue#) import Data.Primitive.Types import Data.Primitive.ByteArray (ByteArray(..)) import Data.Monoid (Monoid(..),(<>)) import Control.Applicative import Control.Monad.Primitive import Control.Monad.ST import qualified Data.List as L import qualified Data.Primitive.ByteArray as PB import qualified Data.Primitive.Types as PT #if MIN_VERSION_base(4,7,0) import GHC.Exts (IsList(..)) #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Semigroup) import qualified Data.Semigroup as SG #endif -- | Arrays of unboxed elements. This accepts types like 'Double', 'Char', -- 'Int', and 'Word', as well as their fixed-length variants ('Word8', -- 'Word16', etc.). Since the elements are unboxed, a 'PrimArray' is strict -- in its elements. This differs from the behavior of 'Array', which is lazy -- in its elements. data PrimArray a = PrimArray ByteArray# -- | Mutable primitive arrays associated with a primitive state token. -- These can be written to and read from in a monadic context that supports -- sequencing such as 'IO' or 'ST'. Typically, a mutable primitive array will -- be built and then convert to an immutable primitive array using -- 'unsafeFreezePrimArray'. However, it is also acceptable to simply discard -- a mutable primitive array since it lives in managed memory and will be -- garbage collected when no longer referenced. data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) sameByteArray :: ByteArray# -> ByteArray# -> Bool sameByteArray ba1 ba2 = case reallyUnsafePtrEquality# (unsafeCoerce# ba1 :: ()) (unsafeCoerce# ba2 :: ()) of #if __GLASGOW_HASKELL__ >= 708 r -> isTrue# r #else 1# -> True _ -> False #endif -- | @since 0.6.4.0 instance (Eq a, Prim a) => Eq (PrimArray a) where a1@(PrimArray ba1#) == a2@(PrimArray ba2#) | sameByteArray ba1# ba2# = True | sz1 /= sz2 = False | otherwise = loop (quot sz1 (sizeOf (undefined :: a)) - 1) where -- Here, we take the size in bytes, not in elements. We do this -- since it allows us to defer performing the division to -- calculate the size in elements. sz1 = PB.sizeofByteArray (ByteArray ba1#) sz2 = PB.sizeofByteArray (ByteArray ba2#) loop !i | i < 0 = True | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) {-# INLINE (==) #-} -- | Lexicographic ordering. Subject to change between major versions. -- -- @since 0.6.4.0 instance (Ord a, Prim a) => Ord (PrimArray a) where compare a1@(PrimArray ba1#) a2@(PrimArray ba2#) | sameByteArray ba1# ba2# = EQ | otherwise = loop 0 where sz1 = PB.sizeofByteArray (ByteArray ba1#) sz2 = PB.sizeofByteArray (ByteArray ba2#) sz = quot (min sz1 sz2) (sizeOf (undefined :: a)) loop !i | i < sz = compare (indexPrimArray a1 i) (indexPrimArray a2 i) <> loop (i+1) | otherwise = compare sz1 sz2 {-# INLINE compare #-} #if MIN_VERSION_base(4,7,0) -- | @since 0.6.4.0 instance Prim a => IsList (PrimArray a) where type Item (PrimArray a) = a fromList = primArrayFromList fromListN = primArrayFromListN toList = primArrayToList #endif -- | @since 0.6.4.0 instance (Show a, Prim a) => Show (PrimArray a) where showsPrec p a = showParen (p > 10) $ showString "fromListN " . shows (sizeofPrimArray a) . showString " " . shows (primArrayToList a) die :: String -> String -> a die fun problem = error $ "Data.Primitive.PrimArray." ++ fun ++ ": " ++ problem primArrayFromList :: Prim a => [a] -> PrimArray a primArrayFromList vs = primArrayFromListN (L.length vs) vs primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a primArrayFromListN len vs = runST run where run :: forall s. ST s (PrimArray a) run = do arr <- newPrimArray len let go :: [a] -> Int -> ST s () go [] !ix = if ix == len then return () else die "fromListN" "list length less than specified size" go (a : as) !ix = if ix < len then do writePrimArray arr ix a go as (ix + 1) else die "fromListN" "list length greater than specified size" go vs 0 unsafeFreezePrimArray arr -- | Convert the primitive array to a list. {-# INLINE primArrayToList #-} primArrayToList :: forall a. Prim a => PrimArray a -> [a] primArrayToList xs = build (\c n -> foldrPrimArray c n xs) primArrayToByteArray :: PrimArray a -> PB.ByteArray primArrayToByteArray (PrimArray x) = PB.ByteArray x byteArrayToPrimArray :: ByteArray -> PrimArray a byteArrayToPrimArray (PB.ByteArray x) = PrimArray x #if MIN_VERSION_base(4,9,0) -- | @since 0.6.4.0 instance Semigroup (PrimArray a) where x <> y = byteArrayToPrimArray (primArrayToByteArray x SG.<> primArrayToByteArray y) sconcat = byteArrayToPrimArray . SG.sconcat . fmap primArrayToByteArray stimes i arr = byteArrayToPrimArray (SG.stimes i (primArrayToByteArray arr)) #endif -- | @since 0.6.4.0 instance Monoid (PrimArray a) where mempty = emptyPrimArray #if !(MIN_VERSION_base(4,11,0)) mappend x y = byteArrayToPrimArray (mappend (primArrayToByteArray x) (primArrayToByteArray y)) #endif mconcat = byteArrayToPrimArray . mconcat . map primArrayToByteArray -- | The empty primitive array. emptyPrimArray :: PrimArray a {-# NOINLINE emptyPrimArray #-} emptyPrimArray = runST $ primitive $ \s0# -> case newByteArray# 0# s0# of (# s1#, arr# #) -> case unsafeFreezeByteArray# arr# s1# of (# s2#, arr'# #) -> (# s2#, PrimArray arr'# #) -- | Create a new mutable primitive array of the given length. The -- underlying memory is left uninitialized. newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) {-# INLINE newPrimArray #-} newPrimArray (I# n#) = primitive (\s# -> case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) ) -- | Resize a mutable primitive array. The new size is given in elements. -- -- This will either resize the array in-place or, if not possible, allocate the -- contents into a new, unpinned array and copy the original array\'s contents. -- -- To avoid undefined behaviour, the original 'MutablePrimArray' shall not be -- accessed anymore after a 'resizeMutablePrimArray' has been performed. -- Moreover, no reference to the old one should be kept in order to allow -- garbage collection of the original 'MutablePrimArray' in case a new -- 'MutablePrimArray' had to be allocated. resizeMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -- ^ new size -> m (MutablePrimArray (PrimState m) a) {-# INLINE resizeMutablePrimArray #-} #if __GLASGOW_HASKELL__ >= 710 resizeMutablePrimArray (MutablePrimArray arr#) (I# n#) = primitive (\s# -> case resizeMutableByteArray# arr# (n# *# sizeOf# (undefined :: a)) s# of (# s'#, arr'# #) -> (# s'#, MutablePrimArray arr'# #)) #else resizeMutablePrimArray arr n = do arr' <- newPrimArray n copyMutablePrimArray arr' 0 arr 0 (min (sizeofMutablePrimArray arr) n) return arr' #endif -- Although it is possible to shim resizeMutableByteArray for old GHCs, this -- is not the case with shrinkMutablePrimArray. #if __GLASGOW_HASKELL__ >= 710 -- | Shrink a mutable primitive array. The new size is given in elements. -- It must be smaller than the old size. The array will be resized in place. -- This function is only available when compiling with GHC 7.10 or newer. shrinkMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -- ^ new size -> m () {-# INLINE shrinkMutablePrimArray #-} shrinkMutablePrimArray (MutablePrimArray arr#) (I# n#) = primitive_ (shrinkMutableByteArray# arr# (n# *# sizeOf# (undefined :: a))) #endif readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a {-# INLINE readPrimArray #-} readPrimArray (MutablePrimArray arr#) (I# i#) = primitive (readByteArray# arr# i#) -- | Write an element to the given index. writePrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array -> Int -- ^ index -> a -- ^ element -> m () {-# INLINE writePrimArray #-} writePrimArray (MutablePrimArray arr#) (I# i#) x = primitive_ (writeByteArray# arr# i# x) -- | Copy part of a mutable array into another mutable array. -- In the case that the destination and -- source arrays are the same, the regions may overlap. copyMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> MutablePrimArray (PrimState m) a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyMutablePrimArray #-} copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) = primitive_ (copyMutableByteArray# src# (soff# *# (sizeOf# (undefined :: a))) dst# (doff# *# (sizeOf# (undefined :: a))) (n# *# (sizeOf# (undefined :: a))) ) -- | Copy part of an array into another mutable array. copyPrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> PrimArray a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of elements to copy -> m () {-# INLINE copyPrimArray #-} copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) = primitive_ (copyByteArray# src# (soff# *# (sizeOf# (undefined :: a))) dst# (doff# *# (sizeOf# (undefined :: a))) (n# *# (sizeOf# (undefined :: a))) ) #if __GLASGOW_HASKELL__ >= 708 -- | Copy a slice of an immutable primitive array to an address. -- The offset and length are given in elements of type @a@. -- This function assumes that the 'Prim' instance of @a@ -- agrees with the 'Storable' instance. This function is only -- available when building with GHC 7.8 or newer. copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> PrimArray a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of prims to copy -> m () {-# INLINE copyPrimArrayToPtr #-} copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = primitive (\ s# -> let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #)) where siz# = sizeOf# (undefined :: a) -- | Copy a slice of an immutable primitive array to an address. -- The offset and length are given in elements of type @a@. -- This function assumes that the 'Prim' instance of @a@ -- agrees with the 'Storable' instance. This function is only -- available when building with GHC 7.8 or newer. copyMutablePrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> MutablePrimArray (PrimState m) a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of prims to copy -> m () {-# INLINE copyMutablePrimArrayToPtr #-} copyMutablePrimArrayToPtr (Ptr addr#) (MutablePrimArray mba#) (I# soff#) (I# n#) = primitive (\ s# -> let s'# = copyMutableByteArrayToAddr# mba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #)) where siz# = sizeOf# (undefined :: a) #endif -- | Fill a slice of a mutable primitive array with a value. setPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of values to fill -> a -- ^ value to fill with -> m () {-# INLINE setPrimArray #-} setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x = primitive_ (PT.setByteArray# dst# doff# sz# x) -- | Get the size of a mutable primitive array in elements. Unlike 'sizeofMutablePrimArray', -- this function ensures sequencing in the presence of resizing. getSizeofMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ array -> m Int {-# INLINE getSizeofMutablePrimArray #-} #if __GLASGOW_HASKELL__ >= 801 getSizeofMutablePrimArray (MutablePrimArray arr#) = primitive (\s# -> case getSizeofMutableByteArray# arr# s# of (# s'#, sz# #) -> (# s'#, I# (quotInt# sz# (sizeOf# (undefined :: a))) #) ) #else -- On older GHCs, it is not possible to resize a byte array, so -- this provides behavior consistent with the implementation for -- newer GHCs. getSizeofMutablePrimArray arr = return (sizeofMutablePrimArray arr) #endif -- | Size of the mutable primitive array in elements. This function shall not -- be used on primitive arrays that are an argument to or a result of -- 'resizeMutablePrimArray' or 'shrinkMutablePrimArray'. sizeofMutablePrimArray :: forall s a. Prim a => MutablePrimArray s a -> Int {-# INLINE sizeofMutablePrimArray #-} sizeofMutablePrimArray (MutablePrimArray arr#) = I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (undefined :: a))) -- | Check if the two arrays refer to the same memory block. sameMutablePrimArray :: MutablePrimArray s a -> MutablePrimArray s a -> Bool {-# INLINE sameMutablePrimArray #-} sameMutablePrimArray (MutablePrimArray arr#) (MutablePrimArray brr#) = isTrue# (sameMutableByteArray# arr# brr#) -- | Convert a mutable byte array to an immutable one without copying. The -- array should not be modified after the conversion. unsafeFreezePrimArray :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) {-# INLINE unsafeFreezePrimArray #-} unsafeFreezePrimArray (MutablePrimArray arr#) = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) -- | Convert an immutable array to a mutable one without copying. The -- original array should not be used after the conversion. unsafeThawPrimArray :: PrimMonad m => PrimArray a -> m (MutablePrimArray (PrimState m) a) {-# INLINE unsafeThawPrimArray #-} unsafeThawPrimArray (PrimArray arr#) = primitive (\s# -> (# s#, MutablePrimArray (unsafeCoerce# arr#) #)) -- | Read a primitive value from the primitive array. indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a {-# INLINE indexPrimArray #-} indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# -- | Get the size, in elements, of the primitive array. sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int {-# INLINE sizeofPrimArray #-} sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (sizeOf# (undefined :: a))) -- | Lazy right-associated fold over the elements of a 'PrimArray'. {-# INLINE foldrPrimArray #-} foldrPrimArray :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b foldrPrimArray f z arr = go 0 where !sz = sizeofPrimArray arr go !i | sz > i = f (indexPrimArray arr i) (go (i+1)) | otherwise = z -- | Strict right-associated fold over the elements of a 'PrimArray'. {-# INLINE foldrPrimArray' #-} foldrPrimArray' :: forall a b. Prim a => (a -> b -> b) -> b -> PrimArray a -> b foldrPrimArray' f z0 arr = go (sizeofPrimArray arr - 1) z0 where go !i !acc | i < 0 = acc | otherwise = go (i - 1) (f (indexPrimArray arr i) acc) -- | Lazy left-associated fold over the elements of a 'PrimArray'. {-# INLINE foldlPrimArray #-} foldlPrimArray :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b foldlPrimArray f z arr = go (sizeofPrimArray arr - 1) where go !i | i < 0 = z | otherwise = f (go (i - 1)) (indexPrimArray arr i) -- | Strict left-associated fold over the elements of a 'PrimArray'. {-# INLINE foldlPrimArray' #-} foldlPrimArray' :: forall a b. Prim a => (b -> a -> b) -> b -> PrimArray a -> b foldlPrimArray' f z0 arr = go 0 z0 where !sz = sizeofPrimArray arr go !i !acc | i < sz = go (i + 1) (f acc (indexPrimArray arr i)) | otherwise = acc -- | Strict left-associated fold over the elements of a 'PrimArray'. {-# INLINE foldlPrimArrayM' #-} foldlPrimArrayM' :: (Prim a, Monad m) => (b -> a -> m b) -> b -> PrimArray a -> m b foldlPrimArrayM' f z0 arr = go 0 z0 where !sz = sizeofPrimArray arr go !i !acc1 | i < sz = do acc2 <- f acc1 (indexPrimArray arr i) go (i + 1) acc2 | otherwise = return acc1 -- | Traverse a primitive array. The traversal forces the resulting values and -- writes them to the new primitive array as it performs the monadic effects. -- Consequently: -- -- >>> traversePrimArrayP (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) -- 1 -- 2 -- *** Exception: Prelude.undefined -- -- In many situations, 'traversePrimArrayP' can replace 'traversePrimArray', -- changing the strictness characteristics of the traversal but typically improving -- the performance. Consider the following short-circuiting traversal: -- -- > incrPositiveA :: PrimArray Int -> Maybe (PrimArray Int) -- > incrPositiveA xs = traversePrimArray (\x -> bool Nothing (Just (x + 1)) (x > 0)) xs -- -- This can be rewritten using 'traversePrimArrayP'. To do this, we must -- change the traversal context to @MaybeT (ST s)@, which has a 'PrimMonad' -- instance: -- -- > incrPositiveB :: PrimArray Int -> Maybe (PrimArray Int) -- > incrPositiveB xs = runST $ runMaybeT $ traversePrimArrayP -- > (\x -> bool (MaybeT (return Nothing)) (MaybeT (return (Just (x + 1)))) (x > 0)) -- > xs -- -- Benchmarks demonstrate that the second implementation runs 150 times -- faster than the first. It also results in fewer allocations. {-# INLINE traversePrimArrayP #-} traversePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m b) -> PrimArray a -> m (PrimArray b) traversePrimArrayP f arr = do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ix = if ix < sz then do b <- f (indexPrimArray arr ix) writePrimArray marr ix b go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Filter the primitive array, keeping the elements for which the monadic -- predicate evaluates true. {-# INLINE filterPrimArrayP #-} filterPrimArrayP :: (PrimMonad m, Prim a) => (a -> m Bool) -> PrimArray a -> m (PrimArray a) filterPrimArrayP f arr = do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ixSrc !ixDst = if ixSrc < sz then do let a = indexPrimArray arr ixSrc b <- f a if b then do writePrimArray marr ixDst a go (ixSrc + 1) (ixDst + 1) else go (ixSrc + 1) ixDst else return ixDst lenDst <- go 0 0 marr' <- resizeMutablePrimArray marr lenDst unsafeFreezePrimArray marr' -- | Map over the primitive array, keeping the elements for which the monadic -- predicate provides a 'Just'. {-# INLINE mapMaybePrimArrayP #-} mapMaybePrimArrayP :: (PrimMonad m, Prim a, Prim b) => (a -> m (Maybe b)) -> PrimArray a -> m (PrimArray b) mapMaybePrimArrayP f arr = do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ixSrc !ixDst = if ixSrc < sz then do let a = indexPrimArray arr ixSrc mb <- f a case mb of Just b -> do writePrimArray marr ixDst b go (ixSrc + 1) (ixDst + 1) Nothing -> go (ixSrc + 1) ixDst else return ixDst lenDst <- go 0 0 marr' <- resizeMutablePrimArray marr lenDst unsafeFreezePrimArray marr' -- | Generate a primitive array by evaluating the monadic generator function -- at each index. {-# INLINE generatePrimArrayP #-} generatePrimArrayP :: (PrimMonad m, Prim a) => Int -- ^ length -> (Int -> m a) -- ^ generator -> m (PrimArray a) generatePrimArrayP sz f = do marr <- newPrimArray sz let go !ix = if ix < sz then do b <- f ix writePrimArray marr ix b go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Execute the monadic action the given number of times and store the -- results in a primitive array. {-# INLINE replicatePrimArrayP #-} replicatePrimArrayP :: (PrimMonad m, Prim a) => Int -> m a -> m (PrimArray a) replicatePrimArrayP sz f = do marr <- newPrimArray sz let go !ix = if ix < sz then do b <- f writePrimArray marr ix b go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Map over the elements of a primitive array. {-# INLINE mapPrimArray #-} mapPrimArray :: (Prim a, Prim b) => (a -> b) -> PrimArray a -> PrimArray b mapPrimArray f arr = runST $ do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ix = if ix < sz then do let b = f (indexPrimArray arr ix) writePrimArray marr ix b go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Indexed map over the elements of a primitive array. {-# INLINE imapPrimArray #-} imapPrimArray :: (Prim a, Prim b) => (Int -> a -> b) -> PrimArray a -> PrimArray b imapPrimArray f arr = runST $ do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ix = if ix < sz then do let b = f ix (indexPrimArray arr ix) writePrimArray marr ix b go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Filter elements of a primitive array according to a predicate. {-# INLINE filterPrimArray #-} filterPrimArray :: Prim a => (a -> Bool) -> PrimArray a -> PrimArray a filterPrimArray p arr = runST $ do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ixSrc !ixDst = if ixSrc < sz then do let !a = indexPrimArray arr ixSrc if p a then do writePrimArray marr ixDst a go (ixSrc + 1) (ixDst + 1) else go (ixSrc + 1) ixDst else return ixDst dstLen <- go 0 0 marr' <- resizeMutablePrimArray marr dstLen unsafeFreezePrimArray marr' -- | Filter the primitive array, keeping the elements for which the monadic -- predicate evaluates true. filterPrimArrayA :: (Applicative f, Prim a) => (a -> f Bool) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray a) filterPrimArrayA f = \ !ary -> let !len = sizeofPrimArray ary go !ixSrc | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst | otherwise = let x = indexPrimArray ary ixSrc in liftA2 (\keep (IxSTA m) -> IxSTA $ \ixDst mary -> if keep then writePrimArray (MutablePrimArray mary) ixDst x >> m (ixDst + 1) mary else m ixDst mary ) (f x) (go (ixSrc + 1)) in if len == 0 then pure emptyPrimArray else runIxSTA len <$> go 0 -- | Map over the primitive array, keeping the elements for which the applicative -- predicate provides a 'Just'. mapMaybePrimArrayA :: (Applicative f, Prim a, Prim b) => (a -> f (Maybe b)) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray b) mapMaybePrimArrayA f = \ !ary -> let !len = sizeofPrimArray ary go !ixSrc | ixSrc == len = pure $ IxSTA $ \ixDst _ -> return ixDst | otherwise = let x = indexPrimArray ary ixSrc in liftA2 (\mb (IxSTA m) -> IxSTA $ \ixDst mary -> case mb of Just b -> writePrimArray (MutablePrimArray mary) ixDst b >> m (ixDst + 1) mary Nothing -> m ixDst mary ) (f x) (go (ixSrc + 1)) in if len == 0 then pure emptyPrimArray else runIxSTA len <$> go 0 -- | Map over a primitive array, optionally discarding some elements. This -- has the same behavior as @Data.Maybe.mapMaybe@. {-# INLINE mapMaybePrimArray #-} mapMaybePrimArray :: (Prim a, Prim b) => (a -> Maybe b) -> PrimArray a -> PrimArray b mapMaybePrimArray p arr = runST $ do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ixSrc !ixDst = if ixSrc < sz then do let !a = indexPrimArray arr ixSrc case p a of Just b -> do writePrimArray marr ixDst b go (ixSrc + 1) (ixDst + 1) Nothing -> go (ixSrc + 1) ixDst else return ixDst dstLen <- go 0 0 marr' <- resizeMutablePrimArray marr dstLen unsafeFreezePrimArray marr' -- | Traverse a primitive array. The traversal performs all of the applicative -- effects /before/ forcing the resulting values and writing them to the new -- primitive array. Consequently: -- -- >>> traversePrimArray (\x -> print x $> bool x undefined (x == 2)) (fromList [1, 2, 3 :: Int]) -- 1 -- 2 -- 3 -- *** Exception: Prelude.undefined -- -- The function 'traversePrimArrayP' always outperforms this function, but it -- requires a 'PrimMonad' constraint, and it forces the values as -- it performs the effects. traversePrimArray :: (Applicative f, Prim a, Prim b) => (a -> f b) -- ^ mapping function -> PrimArray a -- ^ primitive array -> f (PrimArray b) traversePrimArray f = \ !ary -> let !len = sizeofPrimArray ary go !i | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) | x <- indexPrimArray ary i = liftA2 (\b (STA m) -> STA $ \mary -> writePrimArray (MutablePrimArray mary) i b >> m mary) (f x) (go (i + 1)) in if len == 0 then pure emptyPrimArray else runSTA len <$> go 0 -- | Traverse a primitive array with the index of each element. itraversePrimArray :: (Applicative f, Prim a, Prim b) => (Int -> a -> f b) -> PrimArray a -> f (PrimArray b) itraversePrimArray f = \ !ary -> let !len = sizeofPrimArray ary go !i | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) | x <- indexPrimArray ary i = liftA2 (\b (STA m) -> STA $ \mary -> writePrimArray (MutablePrimArray mary) i b >> m mary) (f i x) (go (i + 1)) in if len == 0 then pure emptyPrimArray else runSTA len <$> go 0 -- | Traverse a primitive array with the indices. The traversal forces the -- resulting values and writes them to the new primitive array as it performs -- the monadic effects. {-# INLINE itraversePrimArrayP #-} itraversePrimArrayP :: (Prim a, Prim b, PrimMonad m) => (Int -> a -> m b) -> PrimArray a -> m (PrimArray b) itraversePrimArrayP f arr = do let !sz = sizeofPrimArray arr marr <- newPrimArray sz let go !ix | ix < sz = do writePrimArray marr ix =<< f ix (indexPrimArray arr ix) go (ix + 1) | otherwise = return () go 0 unsafeFreezePrimArray marr -- | Generate a primitive array. {-# INLINE generatePrimArray #-} generatePrimArray :: Prim a => Int -- ^ length -> (Int -> a) -- ^ element from index -> PrimArray a generatePrimArray len f = runST $ do marr <- newPrimArray len let go !ix = if ix < len then do writePrimArray marr ix (f ix) go (ix + 1) else return () go 0 unsafeFreezePrimArray marr -- | Create a primitive array by copying the element the given -- number of times. {-# INLINE replicatePrimArray #-} replicatePrimArray :: Prim a => Int -- ^ length -> a -- ^ element -> PrimArray a replicatePrimArray len a = runST $ do marr <- newPrimArray len setPrimArray marr 0 len a unsafeFreezePrimArray marr -- | Generate a primitive array by evaluating the applicative generator -- function at each index. {-# INLINE generatePrimArrayA #-} generatePrimArrayA :: (Applicative f, Prim a) => Int -- ^ length -> (Int -> f a) -- ^ element from index -> f (PrimArray a) generatePrimArrayA len f = let go !i | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) | otherwise = liftA2 (\b (STA m) -> STA $ \mary -> writePrimArray (MutablePrimArray mary) i b >> m mary) (f i) (go (i + 1)) in if len == 0 then pure emptyPrimArray else runSTA len <$> go 0 -- | Execute the applicative action the given number of times and store the -- results in a vector. {-# INLINE replicatePrimArrayA #-} replicatePrimArrayA :: (Applicative f, Prim a) => Int -- ^ length -> f a -- ^ applicative element producer -> f (PrimArray a) replicatePrimArrayA len f = let go !i | i == len = pure $ STA $ \mary -> unsafeFreezePrimArray (MutablePrimArray mary) | otherwise = liftA2 (\b (STA m) -> STA $ \mary -> writePrimArray (MutablePrimArray mary) i b >> m mary) f (go (i + 1)) in if len == 0 then pure emptyPrimArray else runSTA len <$> go 0 -- | Traverse the primitive array, discarding the results. There -- is no 'PrimMonad' variant of this function since it would not provide -- any performance benefit. traversePrimArray_ :: (Applicative f, Prim a) => (a -> f b) -> PrimArray a -> f () traversePrimArray_ f a = go 0 where !sz = sizeofPrimArray a go !ix = if ix < sz then f (indexPrimArray a ix) *> go (ix + 1) else pure () -- | Traverse the primitive array with the indices, discarding the results. -- There is no 'PrimMonad' variant of this function since it would not -- provide any performance benefit. itraversePrimArray_ :: (Applicative f, Prim a) => (Int -> a -> f b) -> PrimArray a -> f () itraversePrimArray_ f a = go 0 where !sz = sizeofPrimArray a go !ix = if ix < sz then f ix (indexPrimArray a ix) *> go (ix + 1) else pure () newtype IxSTA a = IxSTA {_runIxSTA :: forall s. Int -> MutableByteArray# s -> ST s Int} runIxSTA :: forall a. Prim a => Int -- maximum possible size -> IxSTA a -> PrimArray a runIxSTA !szUpper = \ (IxSTA m) -> runST $ do ar :: MutablePrimArray s a <- newPrimArray szUpper sz <- m 0 (unMutablePrimArray ar) ar' <- resizeMutablePrimArray ar sz unsafeFreezePrimArray ar' {-# INLINE runIxSTA #-} newtype STA a = STA {_runSTA :: forall s. MutableByteArray# s -> ST s (PrimArray a)} runSTA :: forall a. Prim a => Int -> STA a -> PrimArray a runSTA !sz = \ (STA m) -> runST $ newPrimArray sz >>= \ (ar :: MutablePrimArray s a) -> m (unMutablePrimArray ar) {-# INLINE runSTA #-} unMutablePrimArray :: MutablePrimArray s a -> MutableByteArray# s unMutablePrimArray (MutablePrimArray m) = m {- $effectfulMapCreate The naming conventions adopted in this section are explained in the documentation of the @Data.Primitive@ module. -} primitive-0.7.0.1/Data/Primitive/Ptr.hs0000644000000000000000000001016707346545000016005 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Primitive.Ptr -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Primitive operations on machine addresses -- -- @since 0.6.4.0 module Data.Primitive.Ptr ( -- * Types Ptr(..), -- * Address arithmetic nullPtr, advancePtr, subtractPtr, -- * Element access indexOffPtr, readOffPtr, writeOffPtr, -- * Block operations copyPtr, movePtr, setPtr #if __GLASGOW_HASKELL__ >= 708 , copyPtrToMutablePrimArray #endif ) where import Control.Monad.Primitive import Data.Primitive.Types #if __GLASGOW_HASKELL__ >= 708 import Data.Primitive.PrimArray (MutablePrimArray(..)) #endif import GHC.Base ( Int(..) ) import GHC.Exts import GHC.Ptr import Foreign.Marshal.Utils -- | Offset a pointer by the given number of elements. advancePtr :: forall a. Prim a => Ptr a -> Int -> Ptr a {-# INLINE advancePtr #-} advancePtr (Ptr a#) (I# i#) = Ptr (plusAddr# a# (i# *# sizeOf# (undefined :: a))) -- | Subtract a pointer from another pointer. The result represents -- the number of elements of type @a@ that fit in the contiguous -- memory range bounded by these two pointers. subtractPtr :: forall a. Prim a => Ptr a -> Ptr a -> Int {-# INLINE subtractPtr #-} subtractPtr (Ptr a#) (Ptr b#) = I# (quotInt# (minusAddr# a# b#) (sizeOf# (undefined :: a))) -- | Read a value from a memory position given by a pointer and an offset. -- The memory block the address refers to must be immutable. The offset is in -- elements of type @a@ rather than in bytes. indexOffPtr :: Prim a => Ptr a -> Int -> a {-# INLINE indexOffPtr #-} indexOffPtr (Ptr addr#) (I# i#) = indexOffAddr# addr# i# -- | Read a value from a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. readOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> m a {-# INLINE readOffPtr #-} readOffPtr (Ptr addr#) (I# i#) = primitive (readOffAddr# addr# i#) -- | Write a value to a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. writeOffPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () {-# INLINE writeOffPtr #-} writeOffPtr (Ptr addr#) (I# i#) x = primitive_ (writeOffAddr# addr# i# x) -- | Copy the given number of elements from the second 'Ptr' to the first. The -- areas may not overlap. copyPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> Ptr a -- ^ source pointer -> Int -- ^ number of elements -> m () {-# INLINE copyPtr #-} copyPtr (Ptr dst#) (Ptr src#) n = unsafePrimToPrim $ copyBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) -- | Copy the given number of elements from the second 'Ptr' to the first. The -- areas may overlap. movePtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination address -> Ptr a -- ^ source address -> Int -- ^ number of elements -> m () {-# INLINE movePtr #-} movePtr (Ptr dst#) (Ptr src#) n = unsafePrimToPrim $ moveBytes (Ptr dst#) (Ptr src#) (n * sizeOf (undefined :: a)) -- | Fill a memory block with the given value. The length is in -- elements of type @a@ rather than in bytes. setPtr :: (Prim a, PrimMonad m) => Ptr a -> Int -> a -> m () {-# INLINE setPtr #-} setPtr (Ptr addr#) (I# n#) x = primitive_ (setOffAddr# addr# 0# n# x) #if __GLASGOW_HASKELL__ >= 708 -- | Copy from a pointer to a mutable primitive array. -- The offset and length are given in elements of type @a@. -- This function is only available when building with GHC 7.8 -- or newer. copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ destination array -> Int -- ^ destination offset -> Ptr a -- ^ source pointer -> Int -- ^ number of elements -> m () {-# INLINE copyPtrToMutablePrimArray #-} copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = primitive_ (copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#)) where siz# = sizeOf# (undefined :: a) #endif primitive-0.7.0.1/Data/Primitive/SmallArray.hs0000644000000000000000000007304007346545000017306 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} -- | -- Module : Data.Primitive.SmallArray -- Copyright: (c) 2015 Dan Doel -- License: BSD3 -- -- Maintainer: libraries@haskell.org -- Portability: non-portable -- -- Small arrays are boxed (im)mutable arrays. -- -- The underlying structure of the 'Array' type contains a card table, allowing -- segments of the array to be marked as having been mutated. This allows the -- garbage collector to only re-traverse segments of the array that have been -- marked during certain phases, rather than having to traverse the entire -- array. -- -- 'SmallArray' lacks this table. This means that it takes up less memory and -- has slightly faster writes. It is also more efficient during garbage -- collection so long as the card table would have a single entry covering the -- entire array. These advantages make them suitable for use as arrays that are -- known to be small. -- -- The card size is 128, so for uses much larger than that, 'Array' would likely -- be superior. -- -- The underlying type, 'SmallArray#', was introduced in GHC 7.10, so prior to -- that version, this module simply implements small arrays as 'Array'. module Data.Primitive.SmallArray ( SmallArray(..) , SmallMutableArray(..) , newSmallArray , readSmallArray , writeSmallArray , copySmallArray , copySmallMutableArray , indexSmallArray , indexSmallArrayM , indexSmallArray## , cloneSmallArray , cloneSmallMutableArray , freezeSmallArray , unsafeFreezeSmallArray , thawSmallArray , runSmallArray , unsafeThawSmallArray , sizeofSmallArray , sizeofSmallMutableArray , smallArrayFromList , smallArrayFromListN , mapSmallArray' , traverseSmallArrayP ) where #if (__GLASGOW_HASKELL__ >= 710) #define HAVE_SMALL_ARRAY 1 #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts hiding (toList) import qualified GHC.Exts #endif import Control.Applicative import Control.Monad import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.ST import Control.Monad.Zip import Data.Data import Data.Foldable as Foldable import Data.Functor.Identity #if !(MIN_VERSION_base(4,10,0)) import Data.Monoid #endif #if MIN_VERSION_base(4,9,0) import qualified GHC.ST as GHCST import qualified Data.Semigroup as Sem #endif import Text.ParserCombinators.ReadP #if MIN_VERSION_base(4,10,0) import GHC.Exts (runRW#) #elif MIN_VERSION_base(4,9,0) import GHC.Base (runRW#) #endif #if !(HAVE_SMALL_ARRAY) import Data.Primitive.Array import Data.Traversable import qualified Data.Primitive.Array as Array #endif #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) import Data.Functor.Classes (Eq1(..),Ord1(..),Show1(..),Read1(..)) #endif #if HAVE_SMALL_ARRAY data SmallArray a = SmallArray (SmallArray# a) deriving Typeable #else newtype SmallArray a = SmallArray (Array a) deriving ( Eq , Ord , Show , Read , Foldable , Traversable , Functor , Applicative , Alternative , Monad , MonadPlus , MonadZip , MonadFix , Monoid , Typeable #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , Eq1 , Ord1 , Show1 , Read1 #endif ) #if MIN_VERSION_base(4,7,0) instance IsList (SmallArray a) where type Item (SmallArray a) = a fromListN n l = SmallArray (fromListN n l) fromList l = SmallArray (fromList l) toList a = Foldable.toList a #endif #endif #if HAVE_SMALL_ARRAY data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a) deriving Typeable #else newtype SmallMutableArray s a = SmallMutableArray (MutableArray s a) deriving (Eq, Typeable) #endif -- | Create a new small mutable array. newSmallArray :: PrimMonad m => Int -- ^ size -> a -- ^ initial contents -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY newSmallArray (I# i#) x = primitive $ \s -> case newSmallArray# i# x s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else newSmallArray n e = SmallMutableArray `liftM` newArray n e #endif {-# INLINE newSmallArray #-} -- | Read the element at a given index in a mutable array. readSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ array -> Int -- ^ index -> m a #if HAVE_SMALL_ARRAY readSmallArray (SmallMutableArray sma#) (I# i#) = primitive $ readSmallArray# sma# i# #else readSmallArray (SmallMutableArray a) = readArray a #endif {-# INLINE readSmallArray #-} -- | Write an element at the given idex in a mutable array. writeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ array -> Int -- ^ index -> a -- ^ new element -> m () #if HAVE_SMALL_ARRAY writeSmallArray (SmallMutableArray sma#) (I# i#) x = primitive_ $ writeSmallArray# sma# i# x #else writeSmallArray (SmallMutableArray a) = writeArray a #endif {-# INLINE writeSmallArray #-} -- | Look up an element in an immutable array. -- -- The purpose of returning a result using a monad is to allow the caller to -- avoid retaining references to the array. Evaluating the return value will -- cause the array lookup to be performed, even though it may not require the -- element of the array to be evaluated (which could throw an exception). For -- instance: -- -- > data Box a = Box a -- > ... -- > -- > f sa = case indexSmallArrayM sa 0 of -- > Box x -> ... -- -- 'x' is not a closure that references 'sa' as it would be if we instead -- wrote: -- -- > let x = indexSmallArray sa 0 -- -- And does not prevent 'sa' from being garbage collected. -- -- Note that 'Identity' is not adequate for this use, as it is a newtype, and -- cannot be evaluated without evaluating the element. indexSmallArrayM :: Monad m => SmallArray a -- ^ array -> Int -- ^ index -> m a #if HAVE_SMALL_ARRAY indexSmallArrayM (SmallArray sa#) (I# i#) = case indexSmallArray# sa# i# of (# x #) -> pure x #else indexSmallArrayM (SmallArray a) = indexArrayM a #endif {-# INLINE indexSmallArrayM #-} -- | Look up an element in an immutable array. indexSmallArray :: SmallArray a -- ^ array -> Int -- ^ index -> a #if HAVE_SMALL_ARRAY indexSmallArray sa i = runIdentity $ indexSmallArrayM sa i #else indexSmallArray (SmallArray a) = indexArray a #endif {-# INLINE indexSmallArray #-} -- | Read a value from the immutable array at the given index, returning -- the result in an unboxed unary tuple. This is currently used to implement -- folds. indexSmallArray## :: SmallArray a -> Int -> (# a #) #if HAVE_SMALL_ARRAY indexSmallArray## (SmallArray ary) (I# i) = indexSmallArray# ary i #else indexSmallArray## (SmallArray a) = indexArray## a #endif {-# INLINE indexSmallArray## #-} -- | Create a copy of a slice of an immutable array. cloneSmallArray :: SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> SmallArray a #if HAVE_SMALL_ARRAY cloneSmallArray (SmallArray sa#) (I# i#) (I# j#) = SmallArray (cloneSmallArray# sa# i# j#) #else cloneSmallArray (SmallArray a) i j = SmallArray $ cloneArray a i j #endif {-# INLINE cloneSmallArray #-} -- | Create a copy of a slice of a mutable array. cloneSmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY cloneSmallMutableArray (SmallMutableArray sma#) (I# o#) (I# l#) = primitive $ \s -> case cloneSmallMutableArray# sma# o# l# s of (# s', smb# #) -> (# s', SmallMutableArray smb# #) #else cloneSmallMutableArray (SmallMutableArray ma) i j = SmallMutableArray `liftM` cloneMutableArray ma i j #endif {-# INLINE cloneSmallMutableArray #-} -- | Create an immutable array corresponding to a slice of a mutable array. -- -- This operation copies the portion of the array to be frozen. freezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallArray a) #if HAVE_SMALL_ARRAY freezeSmallArray (SmallMutableArray sma#) (I# i#) (I# j#) = primitive $ \s -> case freezeSmallArray# sma# i# j# s of (# s', sa# #) -> (# s', SmallArray sa# #) #else freezeSmallArray (SmallMutableArray ma) i j = SmallArray `liftM` freezeArray ma i j #endif {-# INLINE freezeSmallArray #-} -- | Render a mutable array immutable. -- -- This operation performs no copying, so care must be taken not to modify the -- input array after freezing. unsafeFreezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a) #if HAVE_SMALL_ARRAY unsafeFreezeSmallArray (SmallMutableArray sma#) = primitive $ \s -> case unsafeFreezeSmallArray# sma# s of (# s', sa# #) -> (# s', SmallArray sa# #) #else unsafeFreezeSmallArray (SmallMutableArray ma) = SmallArray `liftM` unsafeFreezeArray ma #endif {-# INLINE unsafeFreezeSmallArray #-} -- | Create a mutable array corresponding to a slice of an immutable array. -- -- This operation copies the portion of the array to be thawed. thawSmallArray :: PrimMonad m => SmallArray a -- ^ source -> Int -- ^ offset -> Int -- ^ length -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY thawSmallArray (SmallArray sa#) (I# o#) (I# l#) = primitive $ \s -> case thawSmallArray# sa# o# l# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else thawSmallArray (SmallArray a) off len = SmallMutableArray `liftM` thawArray a off len #endif {-# INLINE thawSmallArray #-} -- | Render an immutable array mutable. -- -- This operation performs no copying, so care must be taken with its use. unsafeThawSmallArray :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a) #if HAVE_SMALL_ARRAY unsafeThawSmallArray (SmallArray sa#) = primitive $ \s -> case unsafeThawSmallArray# sa# s of (# s', sma# #) -> (# s', SmallMutableArray sma# #) #else unsafeThawSmallArray (SmallArray a) = SmallMutableArray `liftM` unsafeThawArray a #endif {-# INLINE unsafeThawSmallArray #-} -- | Copy a slice of an immutable array into a mutable array. copySmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ destination -> Int -- ^ destination offset -> SmallArray a -- ^ source -> Int -- ^ source offset -> Int -- ^ length -> m () #if HAVE_SMALL_ARRAY copySmallArray (SmallMutableArray dst#) (I# do#) (SmallArray src#) (I# so#) (I# l#) = primitive_ $ copySmallArray# src# so# dst# do# l# #else copySmallArray (SmallMutableArray dst) i (SmallArray src) = copyArray dst i src #endif {-# INLINE copySmallArray #-} -- | Copy a slice of one mutable array into another. copySmallMutableArray :: PrimMonad m => SmallMutableArray (PrimState m) a -- ^ destination -> Int -- ^ destination offset -> SmallMutableArray (PrimState m) a -- ^ source -> Int -- ^ source offset -> Int -- ^ length -> m () #if HAVE_SMALL_ARRAY copySmallMutableArray (SmallMutableArray dst#) (I# do#) (SmallMutableArray src#) (I# so#) (I# l#) = primitive_ $ copySmallMutableArray# src# so# dst# do# l# #else copySmallMutableArray (SmallMutableArray dst) i (SmallMutableArray src) = copyMutableArray dst i src #endif {-# INLINE copySmallMutableArray #-} sizeofSmallArray :: SmallArray a -> Int #if HAVE_SMALL_ARRAY sizeofSmallArray (SmallArray sa#) = I# (sizeofSmallArray# sa#) #else sizeofSmallArray (SmallArray a) = sizeofArray a #endif {-# INLINE sizeofSmallArray #-} sizeofSmallMutableArray :: SmallMutableArray s a -> Int #if HAVE_SMALL_ARRAY sizeofSmallMutableArray (SmallMutableArray sa#) = I# (sizeofSmallMutableArray# sa#) #else sizeofSmallMutableArray (SmallMutableArray ma) = sizeofMutableArray ma #endif {-# INLINE sizeofSmallMutableArray #-} -- | This is the fastest, most straightforward way to traverse -- an array, but it only works correctly with a sufficiently -- "affine" 'PrimMonad' instance. In particular, it must only produce -- *one* result array. 'Control.Monad.Trans.List.ListT'-transformed -- monads, for example, will not work right at all. traverseSmallArrayP :: PrimMonad m => (a -> m b) -> SmallArray a -> m (SmallArray b) #if HAVE_SMALL_ARRAY traverseSmallArrayP f = \ !ary -> let !sz = sizeofSmallArray ary go !i !mary | i == sz = unsafeFreezeSmallArray mary | otherwise = do a <- indexSmallArrayM ary i b <- f a writeSmallArray mary i b go (i + 1) mary in do mary <- newSmallArray sz badTraverseValue go 0 mary #else traverseSmallArrayP f (SmallArray ar) = SmallArray `liftM` traverseArrayP f ar #endif {-# INLINE traverseSmallArrayP #-} -- | Strict map over the elements of the array. mapSmallArray' :: (a -> b) -> SmallArray a -> SmallArray b #if HAVE_SMALL_ARRAY mapSmallArray' f sa = createSmallArray (length sa) (die "mapSmallArray'" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < length sa) $ do x <- indexSmallArrayM sa i let !y = f x writeSmallArray smb i y *> go (i+1) #else mapSmallArray' f (SmallArray ar) = SmallArray (mapArray' f ar) #endif {-# INLINE mapSmallArray' #-} #ifndef HAVE_SMALL_ARRAY runSmallArray :: (forall s. ST s (SmallMutableArray s a)) -> SmallArray a runSmallArray m = SmallArray $ runArray $ m >>= \(SmallMutableArray mary) -> return mary #elif !MIN_VERSION_base(4,9,0) runSmallArray :: (forall s. ST s (SmallMutableArray s a)) -> SmallArray a runSmallArray m = runST $ m >>= unsafeFreezeSmallArray #else -- This low-level business is designed to work with GHC's worker-wrapper -- transformation. A lot of the time, we don't actually need an Array -- constructor. By putting it on the outside, and being careful about -- how we special-case the empty array, we can make GHC smarter about this. -- The only downside is that separately created 0-length arrays won't share -- their Array constructors, although they'll share their underlying -- Array#s. runSmallArray :: (forall s. ST s (SmallMutableArray s a)) -> SmallArray a runSmallArray m = SmallArray (runSmallArray# m) runSmallArray# :: (forall s. ST s (SmallMutableArray s a)) -> SmallArray# a runSmallArray# m = case runRW# $ \s -> case unST m s of { (# s', SmallMutableArray mary# #) -> unsafeFreezeSmallArray# mary# s'} of (# _, ary# #) -> ary# unST :: ST s a -> State# s -> (# State# s, a #) unST (GHCST.ST f) = f #endif #if HAVE_SMALL_ARRAY -- See the comment on runSmallArray for why we use emptySmallArray#. createSmallArray :: Int -> a -> (forall s. SmallMutableArray s a -> ST s ()) -> SmallArray a createSmallArray 0 _ _ = SmallArray (emptySmallArray# (# #)) createSmallArray n x f = runSmallArray $ do mary <- newSmallArray n x f mary pure mary emptySmallArray# :: (# #) -> SmallArray# a emptySmallArray# _ = case emptySmallArray of SmallArray ar -> ar {-# NOINLINE emptySmallArray# #-} die :: String -> String -> a die fun problem = error $ "Data.Primitive.SmallArray." ++ fun ++ ": " ++ problem emptySmallArray :: SmallArray a emptySmallArray = runST $ newSmallArray 0 (die "emptySmallArray" "impossible") >>= unsafeFreezeSmallArray {-# NOINLINE emptySmallArray #-} infixl 1 ? (?) :: (a -> b -> c) -> (b -> a -> c) (?) = flip {-# INLINE (?) #-} noOp :: a -> ST s () noOp = const $ pure () smallArrayLiftEq :: (a -> b -> Bool) -> SmallArray a -> SmallArray b -> Bool smallArrayLiftEq p sa1 sa2 = length sa1 == length sa2 && loop (length sa1 - 1) where loop i | i < 0 = True | (# x #) <- indexSmallArray## sa1 i , (# y #) <- indexSmallArray## sa2 i = p x y && loop (i-1) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Eq1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftEq = smallArrayLiftEq #else eq1 = smallArrayLiftEq (==) #endif #endif instance Eq a => Eq (SmallArray a) where sa1 == sa2 = smallArrayLiftEq (==) sa1 sa2 instance Eq (SmallMutableArray s a) where SmallMutableArray sma1# == SmallMutableArray sma2# = isTrue# (sameSmallMutableArray# sma1# sma2#) smallArrayLiftCompare :: (a -> b -> Ordering) -> SmallArray a -> SmallArray b -> Ordering smallArrayLiftCompare elemCompare a1 a2 = loop 0 where mn = length a1 `min` length a2 loop i | i < mn , (# x1 #) <- indexSmallArray## a1 i , (# x2 #) <- indexSmallArray## a2 i = elemCompare x1 x2 `mappend` loop (i+1) | otherwise = compare (length a1) (length a2) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Ord1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftCompare = smallArrayLiftCompare #else compare1 = smallArrayLiftCompare compare #endif #endif -- | Lexicographic ordering. Subject to change between major versions. instance Ord a => Ord (SmallArray a) where compare sa1 sa2 = smallArrayLiftCompare compare sa1 sa2 instance Foldable SmallArray where -- Note: we perform the array lookups eagerly so we won't -- create thunks to perform lookups even if GHC can't see -- that the folding function is strict. foldr f = \z !ary -> let !sz = sizeofSmallArray ary go i | i == sz = z | (# x #) <- indexSmallArray## ary i = f x (go (i+1)) in go 0 {-# INLINE foldr #-} foldl f = \z !ary -> let go i | i < 0 = z | (# x #) <- indexSmallArray## ary i = f (go (i-1)) x in go (sizeofSmallArray ary - 1) {-# INLINE foldl #-} foldr1 f = \ !ary -> let !sz = sizeofSmallArray ary - 1 go i = case indexSmallArray## ary i of (# x #) | i == sz -> x | otherwise -> f x (go (i+1)) in if sz < 0 then die "foldr1" "Empty SmallArray" else go 0 {-# INLINE foldr1 #-} foldl1 f = \ !ary -> let !sz = sizeofSmallArray ary - 1 go i = case indexSmallArray## ary i of (# x #) | i == 0 -> x | otherwise -> f (go (i - 1)) x in if sz < 0 then die "foldl1" "Empty SmallArray" else go sz {-# INLINE foldl1 #-} foldr' f = \z !ary -> let go i !acc | i == -1 = acc | (# x #) <- indexSmallArray## ary i = go (i-1) (f x acc) in go (sizeofSmallArray ary - 1) z {-# INLINE foldr' #-} foldl' f = \z !ary -> let !sz = sizeofSmallArray ary go i !acc | i == sz = acc | (# x #) <- indexSmallArray## ary i = go (i+1) (f acc x) in go 0 z {-# INLINE foldl' #-} null a = sizeofSmallArray a == 0 {-# INLINE null #-} length = sizeofSmallArray {-# INLINE length #-} maximum ary | sz == 0 = die "maximum" "Empty SmallArray" | (# frst #) <- indexSmallArray## ary 0 = go 1 frst where sz = sizeofSmallArray ary go i !e | i == sz = e | (# x #) <- indexSmallArray## ary i = go (i+1) (max e x) {-# INLINE maximum #-} minimum ary | sz == 0 = die "minimum" "Empty SmallArray" | (# frst #) <- indexSmallArray## ary 0 = go 1 frst where sz = sizeofSmallArray ary go i !e | i == sz = e | (# x #) <- indexSmallArray## ary i = go (i+1) (min e x) {-# INLINE minimum #-} sum = foldl' (+) 0 {-# INLINE sum #-} product = foldl' (*) 1 {-# INLINE product #-} newtype STA a = STA {_runSTA :: forall s. SmallMutableArray# s a -> ST s (SmallArray a)} runSTA :: Int -> STA a -> SmallArray a runSTA !sz = \ (STA m) -> runST $ newSmallArray_ sz >>= \ (SmallMutableArray ar#) -> m ar# {-# INLINE runSTA #-} newSmallArray_ :: Int -> ST s (SmallMutableArray s a) newSmallArray_ !n = newSmallArray n badTraverseValue badTraverseValue :: a badTraverseValue = die "traverse" "bad indexing" {-# NOINLINE badTraverseValue #-} instance Traversable SmallArray where traverse f = traverseSmallArray f {-# INLINE traverse #-} traverseSmallArray :: Applicative f => (a -> f b) -> SmallArray a -> f (SmallArray b) traverseSmallArray f = \ !ary -> let !len = sizeofSmallArray ary go !i | i == len = pure $ STA $ \mary -> unsafeFreezeSmallArray (SmallMutableArray mary) | (# x #) <- indexSmallArray## ary i = liftA2 (\b (STA m) -> STA $ \mary -> writeSmallArray (SmallMutableArray mary) i b >> m mary) (f x) (go (i + 1)) in if len == 0 then pure emptySmallArray else runSTA len <$> go 0 {-# INLINE [1] traverseSmallArray #-} {-# RULES "traverse/ST" forall (f :: a -> ST s b). traverseSmallArray f = traverseSmallArrayP f "traverse/IO" forall (f :: a -> IO b). traverseSmallArray f = traverseSmallArrayP f "traverse/Id" forall (f :: a -> Identity b). traverseSmallArray f = (coerce :: (SmallArray a -> SmallArray (Identity b)) -> SmallArray a -> Identity (SmallArray b)) (fmap f) #-} instance Functor SmallArray where fmap f sa = createSmallArray (length sa) (die "fmap" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < length sa) $ do x <- indexSmallArrayM sa i writeSmallArray smb i (f x) *> go (i+1) {-# INLINE fmap #-} x <$ sa = createSmallArray (length sa) x noOp instance Applicative SmallArray where pure x = createSmallArray 1 x noOp sa *> sb = createSmallArray (la*lb) (die "*>" "impossible") $ \smb -> fix ? 0 $ \go i -> when (i < la) $ copySmallArray smb 0 sb 0 lb *> go (i+1) where la = length sa ; lb = length sb a <* b = createSmallArray (sza*szb) (die "<*" "impossible") $ \ma -> let fill off i e = when (i < szb) $ writeSmallArray ma (off+i) e >> fill off (i+1) e go i = when (i < sza) $ do x <- indexSmallArrayM a i fill (i*szb) 0 x go (i+1) in go 0 where sza = sizeofSmallArray a ; szb = sizeofSmallArray b ab <*> a = createSmallArray (szab*sza) (die "<*>" "impossible") $ \mb -> let go1 i = when (i < szab) $ do f <- indexSmallArrayM ab i go2 (i*sza) f 0 go1 (i+1) go2 off f j = when (j < sza) $ do x <- indexSmallArrayM a j writeSmallArray mb (off + j) (f x) go2 off f (j + 1) in go1 0 where szab = sizeofSmallArray ab ; sza = sizeofSmallArray a instance Alternative SmallArray where empty = emptySmallArray sl <|> sr = createSmallArray (length sl + length sr) (die "<|>" "impossible") $ \sma -> copySmallArray sma 0 sl 0 (length sl) *> copySmallArray sma (length sl) sr 0 (length sr) many sa | null sa = pure [] | otherwise = die "many" "infinite arrays are not well defined" some sa | null sa = emptySmallArray | otherwise = die "some" "infinite arrays are not well defined" data ArrayStack a = PushArray !(SmallArray a) !(ArrayStack a) | EmptyStack -- TODO: This isn't terribly efficient. It would be better to wrap -- ArrayStack with a type like -- -- data NES s a = NES !Int !(SmallMutableArray s a) !(ArrayStack a) -- -- We'd copy incoming arrays into the mutable array until we would -- overflow it. Then we'd freeze it, push it on the stack, and continue. -- Any sufficiently large incoming arrays would go straight on the stack. -- Such a scheme would make the stack much more compact in the case -- of many small arrays. instance Monad SmallArray where return = pure (>>) = (*>) sa >>= f = collect 0 EmptyStack (la-1) where la = length sa collect sz stk i | i < 0 = createSmallArray sz (die ">>=" "impossible") $ fill 0 stk | (# x #) <- indexSmallArray## sa i , let sb = f x lsb = length sb -- If we don't perform this check, we could end up allocating -- a stack full of empty arrays if someone is filtering most -- things out. So we refrain from pushing empty arrays. = if lsb == 0 then collect sz stk (i-1) else collect (sz + lsb) (PushArray sb stk) (i-1) fill _ EmptyStack _ = return () fill off (PushArray sb sbs) smb = copySmallArray smb off sb 0 (length sb) *> fill (off + length sb) sbs smb #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif instance Fail.MonadFail SmallArray where fail _ = emptySmallArray instance MonadPlus SmallArray where mzero = empty mplus = (<|>) zipW :: String -> (a -> b -> c) -> SmallArray a -> SmallArray b -> SmallArray c zipW nm = \f sa sb -> let mn = length sa `min` length sb in createSmallArray mn (die nm "impossible") $ \mc -> fix ? 0 $ \go i -> when (i < mn) $ do x <- indexSmallArrayM sa i y <- indexSmallArrayM sb i writeSmallArray mc i (f x y) go (i+1) {-# INLINE zipW #-} instance MonadZip SmallArray where mzip = zipW "mzip" (,) mzipWith = zipW "mzipWith" {-# INLINE mzipWith #-} munzip sab = runST $ do let sz = length sab sma <- newSmallArray sz $ die "munzip" "impossible" smb <- newSmallArray sz $ die "munzip" "impossible" fix ? 0 $ \go i -> when (i < sz) $ case indexSmallArray sab i of (x, y) -> do writeSmallArray sma i x writeSmallArray smb i y go $ i+1 (,) <$> unsafeFreezeSmallArray sma <*> unsafeFreezeSmallArray smb instance MonadFix SmallArray where mfix f = createSmallArray (sizeofSmallArray (f err)) (die "mfix" "impossible") $ flip fix 0 $ \r !i !mary -> when (i < sz) $ do writeSmallArray mary i (fix (\xi -> f xi `indexSmallArray` i)) r (i + 1) mary where sz = sizeofSmallArray (f err) err = error "mfix for Data.Primitive.SmallArray applied to strict function." #if MIN_VERSION_base(4,9,0) -- | @since 0.6.3.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 l = createSmallArray n (die "mconcat" "impossible") $ \ma -> let go !_ [ ] = return () go off (a:as) = copySmallArray ma off a 0 (sizeofSmallArray a) >> go (off + sizeofSmallArray a) as in go 0 l where n = sum . fmap length $ l instance IsList (SmallArray a) where type Item (SmallArray a) = a fromListN = smallArrayFromListN fromList = smallArrayFromList toList = Foldable.toList smallArrayLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> SmallArray a -> ShowS smallArrayLiftShowsPrec elemShowsPrec elemListShowsPrec p sa = showParen (p > 10) $ showString "fromListN " . shows (length sa) . showString " " . listLiftShowsPrec elemShowsPrec elemListShowsPrec 11 (toList sa) -- this need to be included for older ghcs listLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> [a] -> ShowS listLiftShowsPrec _ sl _ = sl instance Show a => Show (SmallArray a) where showsPrec p sa = smallArrayLiftShowsPrec showsPrec showList p sa #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Show1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftShowsPrec = smallArrayLiftShowsPrec #else showsPrec1 = smallArrayLiftShowsPrec showsPrec showList #endif #endif smallArrayLiftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (SmallArray a) smallArrayLiftReadsPrec _ listReadsPrec p = readParen (p > 10) . readP_to_S $ do () <$ string "fromListN" skipSpaces n <- readS_to_P reads skipSpaces l <- readS_to_P listReadsPrec return $ smallArrayFromListN n l instance Read a => Read (SmallArray a) where readsPrec = smallArrayLiftReadsPrec readsPrec readList #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) -- | @since 0.6.4.0 instance Read1 SmallArray where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftReadsPrec = smallArrayLiftReadsPrec #else readsPrec1 = smallArrayLiftReadsPrec readsPrec readList #endif #endif smallArrayDataType :: DataType smallArrayDataType = mkDataType "Data.Primitive.SmallArray.SmallArray" [fromListConstr] fromListConstr :: Constr fromListConstr = mkConstr smallArrayDataType "fromList" [] Prefix instance Data a => Data (SmallArray a) where toConstr _ = fromListConstr dataTypeOf _ = smallArrayDataType gunfold k z c = case constrIndex c of 1 -> k (z fromList) _ -> die "gunfold" "SmallArray" gfoldl f z m = z fromList `f` toList m instance (Typeable s, Typeable a) => Data (SmallMutableArray s a) where toConstr _ = die "toConstr" "SmallMutableArray" gunfold _ _ = die "gunfold" "SmallMutableArray" dataTypeOf _ = mkNoRepType "Data.Primitive.SmallArray.SmallMutableArray" #endif -- | Create a 'SmallArray' from a list of a known length. If the length -- of the list does not match the given length, this throws an exception. smallArrayFromListN :: Int -> [a] -> SmallArray a #if HAVE_SMALL_ARRAY smallArrayFromListN n l = createSmallArray n (die "smallArrayFromListN" "uninitialized element") $ \sma -> let go !ix [] = if ix == n then return () else die "smallArrayFromListN" "list length less than specified size" go !ix (x : xs) = if ix < n then do writeSmallArray sma ix x go (ix+1) xs else die "smallArrayFromListN" "list length greater than specified size" in go 0 l #else smallArrayFromListN n l = SmallArray (Array.fromListN n l) #endif -- | Create a 'SmallArray' from a list. smallArrayFromList :: [a] -> SmallArray a smallArrayFromList l = smallArrayFromListN (length l) l primitive-0.7.0.1/Data/Primitive/Types.hs0000644000000000000000000003777407346545000016361 0ustar0000000000000000{-# LANGUAGE CPP, UnboxedTuples, MagicHash, DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} {-# LANGUAGE DeriveGeneric #-} #endif #include "HsBaseConfig.h" -- | -- Module : Data.Primitive.Types -- Copyright : (c) Roman Leshchinskiy 2009-2012 -- License : BSD-style -- -- Maintainer : Roman Leshchinskiy -- Portability : non-portable -- -- Basic types and classes for primitive array operations -- module Data.Primitive.Types ( Prim(..) ,sizeOf, alignment, defaultSetByteArray#, defaultSetOffAddr# ,PrimStorable(..) ,Ptr(..) ) where import Control.Monad.Primitive import Data.Primitive.MachDeps import Data.Primitive.Internal.Operations import Foreign.C.Types import System.Posix.Types import GHC.Base ( Int(..), Char(..), ) import GHC.Float ( Float(..), Double(..) ) import GHC.Word ( Word(..), Word8(..), Word16(..), Word32(..), Word64(..) ) import GHC.Int ( Int8(..), Int16(..), Int32(..), Int64(..) ) import GHC.Ptr ( Ptr(..), FunPtr(..) ) import GHC.Stable ( StablePtr(..) ) import GHC.Exts #if __GLASGOW_HASKELL__ >= 706 hiding (setByteArray#) #endif import Data.Primitive.Internal.Compat ( isTrue# ) import Foreign.Storable (Storable) import qualified Foreign.Storable as FS import Control.Applicative (Const(..)) #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) #else import GHC.Exts (Down(..)) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Semigroup as Semigroup #endif -- | Class of types supporting primitive array operations. This includes -- interfacing with GC-managed memory (functions suffixed with @ByteArray#@) -- and interfacing with unmanaged memory (functions suffixed with @Addr#@). -- Endianness is platform-dependent. class Prim a where -- | Size of values of type @a@. The argument is not used. sizeOf# :: a -> Int# -- | Alignment of values of type @a@. The argument is not used. alignment# :: a -> Int# -- | Read a value from the array. The offset is in elements of type -- @a@ rather than in bytes. indexByteArray# :: ByteArray# -> Int# -> a -- | Read a value from the mutable array. The offset is in elements of type -- @a@ rather than in bytes. readByteArray# :: MutableByteArray# s -> Int# -> State# s -> (# State# s, a #) -- | Write a value to the mutable array. The offset is in elements of type -- @a@ rather than in bytes. writeByteArray# :: MutableByteArray# s -> Int# -> a -> State# s -> State# s -- | Fill a slice of the mutable array with a value. The offset and length -- of the chunk are in elements of type @a@ rather than in bytes. setByteArray# :: MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s -- | Read a value from a memory position given by an address and an offset. -- The memory block the address refers to must be immutable. The offset is in -- elements of type @a@ rather than in bytes. indexOffAddr# :: Addr# -> Int# -> a -- | Read a value from a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. readOffAddr# :: Addr# -> Int# -> State# s -> (# State# s, a #) -- | Write a value to a memory position given by an address and an offset. -- The offset is in elements of type @a@ rather than in bytes. writeOffAddr# :: Addr# -> Int# -> a -> State# s -> State# s -- | 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. -- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- to 'Data.Primitive.Types' in version 0.6.3.0 sizeOf :: Prim a => a -> Int sizeOf x = I# (sizeOf# x) -- | Alignment of values of type @a@. The argument is not used. -- -- This function has existed since 0.1, but was moved from 'Data.Primitive' -- to 'Data.Primitive.Types' in version 0.6.3.0 alignment :: Prim a => a -> Int alignment x = I# (alignment# x) -- | An implementation of 'setByteArray#' that calls 'writeByteArray#' -- to set each element. This is helpful when writing a 'Prim' instance -- for a multi-word data type for which there is no cpu-accelerated way -- to broadcast a value to contiguous memory. It is typically used -- alongside 'defaultSetOffAddr#'. For example: -- -- > data Trip = Trip Int Int Int -- > -- > instance Prim Trip -- > sizeOf# _ = 3# *# sizeOf# (undefined :: Int) -- > alignment# _ = alignment# (undefined :: Int) -- > indexByteArray# arr# i# = ... -- > readByteArray# arr# i# = ... -- > writeByteArray# arr# i# (Trip a b c) = -- > \s0 -> case writeByteArray# arr# (3# *# i#) a s0 of -- > s1 -> case writeByteArray# arr# ((3# *# i#) +# 1#) b s1 of -- > s2 -> case writeByteArray# arr# ((3# *# i#) +# 2# ) c s2 of -- > s3 -> s3 -- > setByteArray# = defaultSetByteArray# -- > indexOffAddr# addr# i# = ... -- > readOffAddr# addr# i# = ... -- > writeOffAddr# addr# i# (Trip a b c) = -- > \s0 -> case writeOffAddr# addr# (3# *# i#) a s0 of -- > s1 -> case writeOffAddr# addr# ((3# *# i#) +# 1#) b s1 of -- > s2 -> case writeOffAddr# addr# ((3# *# i#) +# 2# ) c s2 of -- > s3 -> s3 -- > setOffAddr# = defaultSetOffAddr# defaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s defaultSetByteArray# arr# i# len# ident = go 0# where go ix# s0 = if isTrue# (ix# <# len#) then case writeByteArray# arr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 -- | An implementation of 'setOffAddr#' that calls 'writeOffAddr#' -- to set each element. The documentation of 'defaultSetByteArray#' -- provides an example of how to use this. defaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s defaultSetOffAddr# addr# i# len# ident = go 0# where go ix# s0 = if isTrue# (ix# <# len#) then case writeOffAddr# addr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 -- | Newtype that uses a 'Prim' instance to give rise to a 'Storable' instance. -- This type is intended to be used with the @DerivingVia@ extension available -- in GHC 8.6 and up. For example, consider a user-defined 'Prim' instance for -- a multi-word data type. -- -- > data Uuid = Uuid Word64 Word64 -- > deriving Storable via (PrimStorable Uuid) -- > instance Prim Uuid where ... -- -- Writing the 'Prim' instance is tedious and unavoidable, but the 'Storable' -- instance comes for free once the 'Prim' instance is written. newtype PrimStorable a = PrimStorable { getPrimStorable :: a } instance Prim a => Storable (PrimStorable a) where sizeOf _ = sizeOf (undefined :: a) alignment _ = alignment (undefined :: a) peekElemOff (Ptr addr#) (I# i#) = primitive $ \s0# -> case readOffAddr# addr# i# s0# of (# s1, x #) -> (# s1, PrimStorable x #) pokeElemOff (Ptr addr#) (I# i#) (PrimStorable a) = primitive_ $ \s# -> writeOffAddr# addr# i# a s# #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 { \ sizeOf# _ = unI# sz \ ; alignment# _ = unI# align \ ; indexByteArray# arr# i# = ctr (idx_arr arr# i#) \ ; readByteArray# arr# i# s# = case rd_arr arr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ ; writeByteArray# arr# i# (ctr x#) s# = wr_arr arr# i# x# s# \ ; setByteArray# arr# i# n# (ctr x#) s# \ = let { i = fromIntegral (I# i#) \ ; n = fromIntegral (I# n#) \ } in \ case unsafeCoerce# (internal (set_arr arr# i n x#)) s# of \ { (# s1#, _ #) -> s1# } \ \ ; indexOffAddr# addr# i# = ctr (idx_addr addr# i#) \ ; readOffAddr# addr# i# s# = case rd_addr addr# i# s# of \ { (# s1#, x# #) -> (# s1#, ctr x# #) } \ ; writeOffAddr# addr# i# (ctr x#) s# = wr_addr addr# i# x# s# \ ; setOffAddr# addr# i# n# (ctr x#) s# \ = let { i = fromIntegral (I# i#) \ ; n = fromIntegral (I# n#) \ } in \ case unsafeCoerce# (internal (set_addr addr# i n x#)) s# of \ { (# s1#, _ #) -> s1# } \ ; {-# INLINE sizeOf# #-} \ ; {-# INLINE alignment# #-} \ ; {-# INLINE indexByteArray# #-} \ ; {-# INLINE readByteArray# #-} \ ; {-# INLINE writeByteArray# #-} \ ; {-# INLINE setByteArray# #-} \ ; {-# INLINE indexOffAddr# #-} \ ; {-# INLINE readOffAddr# #-} \ ; {-# INLINE writeOffAddr# #-} \ ; {-# INLINE setOffAddr# #-} \ } unI# :: Int -> Int# unI# (I# n#) = n# derivePrim(Word, W#, sIZEOF_WORD, aLIGNMENT_WORD, indexWordArray#, readWordArray#, writeWordArray#, setWordArray#, indexWordOffAddr#, readWordOffAddr#, writeWordOffAddr#, setWordOffAddr#) derivePrim(Word8, W8#, sIZEOF_WORD8, aLIGNMENT_WORD8, indexWord8Array#, readWord8Array#, writeWord8Array#, setWord8Array#, indexWord8OffAddr#, readWord8OffAddr#, writeWord8OffAddr#, setWord8OffAddr#) derivePrim(Word16, W16#, sIZEOF_WORD16, aLIGNMENT_WORD16, indexWord16Array#, readWord16Array#, writeWord16Array#, setWord16Array#, indexWord16OffAddr#, readWord16OffAddr#, writeWord16OffAddr#, setWord16OffAddr#) derivePrim(Word32, W32#, sIZEOF_WORD32, aLIGNMENT_WORD32, indexWord32Array#, readWord32Array#, writeWord32Array#, setWord32Array#, indexWord32OffAddr#, readWord32OffAddr#, writeWord32OffAddr#, setWord32OffAddr#) derivePrim(Word64, W64#, sIZEOF_WORD64, aLIGNMENT_WORD64, indexWord64Array#, readWord64Array#, writeWord64Array#, setWord64Array#, indexWord64OffAddr#, readWord64OffAddr#, writeWord64OffAddr#, setWord64OffAddr#) derivePrim(Int, I#, sIZEOF_INT, aLIGNMENT_INT, indexIntArray#, readIntArray#, writeIntArray#, setIntArray#, indexIntOffAddr#, readIntOffAddr#, writeIntOffAddr#, setIntOffAddr#) derivePrim(Int8, I8#, sIZEOF_INT8, aLIGNMENT_INT8, indexInt8Array#, readInt8Array#, writeInt8Array#, setInt8Array#, indexInt8OffAddr#, readInt8OffAddr#, writeInt8OffAddr#, setInt8OffAddr#) derivePrim(Int16, I16#, sIZEOF_INT16, aLIGNMENT_INT16, indexInt16Array#, readInt16Array#, writeInt16Array#, setInt16Array#, indexInt16OffAddr#, readInt16OffAddr#, writeInt16OffAddr#, setInt16OffAddr#) derivePrim(Int32, I32#, sIZEOF_INT32, aLIGNMENT_INT32, indexInt32Array#, readInt32Array#, writeInt32Array#, setInt32Array#, indexInt32OffAddr#, readInt32OffAddr#, writeInt32OffAddr#, setInt32OffAddr#) derivePrim(Int64, I64#, sIZEOF_INT64, aLIGNMENT_INT64, indexInt64Array#, readInt64Array#, writeInt64Array#, setInt64Array#, indexInt64OffAddr#, readInt64OffAddr#, writeInt64OffAddr#, setInt64OffAddr#) derivePrim(Float, F#, sIZEOF_FLOAT, aLIGNMENT_FLOAT, indexFloatArray#, readFloatArray#, writeFloatArray#, setFloatArray#, indexFloatOffAddr#, readFloatOffAddr#, writeFloatOffAddr#, setFloatOffAddr#) derivePrim(Double, D#, sIZEOF_DOUBLE, aLIGNMENT_DOUBLE, indexDoubleArray#, readDoubleArray#, writeDoubleArray#, setDoubleArray#, indexDoubleOffAddr#, readDoubleOffAddr#, writeDoubleOffAddr#, setDoubleOffAddr#) derivePrim(Char, C#, sIZEOF_CHAR, aLIGNMENT_CHAR, indexWideCharArray#, readWideCharArray#, writeWideCharArray#, setWideCharArray#, indexWideCharOffAddr#, readWideCharOffAddr#, writeWideCharOffAddr#, setWideCharOffAddr#) derivePrim(Ptr a, Ptr, sIZEOF_PTR, aLIGNMENT_PTR, indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) derivePrim(StablePtr a, StablePtr, sIZEOF_PTR, aLIGNMENT_PTR, indexStablePtrArray#, readStablePtrArray#, writeStablePtrArray#, setStablePtrArray#, indexStablePtrOffAddr#, readStablePtrOffAddr#, writeStablePtrOffAddr#, setStablePtrOffAddr#) derivePrim(FunPtr a, FunPtr, sIZEOF_PTR, aLIGNMENT_PTR, indexAddrArray#, readAddrArray#, writeAddrArray#, setAddrArray#, indexAddrOffAddr#, readAddrOffAddr#, writeAddrOffAddr#, setAddrOffAddr#) -- Prim instances for newtypes in Foreign.C.Types deriving instance Prim CChar deriving instance Prim CSChar deriving instance Prim CUChar deriving instance Prim CShort deriving instance Prim CUShort deriving instance Prim CInt deriving instance Prim CUInt deriving instance Prim CLong deriving instance Prim CULong deriving instance Prim CPtrdiff deriving instance Prim CSize deriving instance Prim CWchar deriving instance Prim CSigAtomic deriving instance Prim CLLong deriving instance Prim CULLong #if MIN_VERSION_base(4,10,0) deriving instance Prim CBool #endif deriving instance Prim CIntPtr deriving instance Prim CUIntPtr deriving instance Prim CIntMax deriving instance Prim CUIntMax deriving instance Prim CClock deriving instance Prim CTime deriving instance Prim CUSeconds deriving instance Prim CSUSeconds deriving instance Prim CFloat deriving instance Prim CDouble -- Prim instances for newtypes in System.Posix.Types #if defined(HTYPE_DEV_T) deriving instance Prim CDev #endif #if defined(HTYPE_INO_T) deriving instance Prim CIno #endif #if defined(HTYPE_MODE_T) deriving instance Prim CMode #endif #if defined(HTYPE_OFF_T) deriving instance Prim COff #endif #if defined(HTYPE_PID_T) deriving instance Prim CPid #endif #if defined(HTYPE_SSIZE_T) deriving instance Prim CSsize #endif #if defined(HTYPE_GID_T) deriving instance Prim CGid #endif #if defined(HTYPE_NLINK_T) deriving instance Prim CNlink #endif #if defined(HTYPE_UID_T) deriving instance Prim CUid #endif #if defined(HTYPE_CC_T) deriving instance Prim CCc #endif #if defined(HTYPE_SPEED_T) deriving instance Prim CSpeed #endif #if defined(HTYPE_TCFLAG_T) deriving instance Prim CTcflag #endif #if defined(HTYPE_RLIM_T) deriving instance Prim CRLim #endif #if defined(HTYPE_BLKSIZE_T) deriving instance Prim CBlkSize #endif #if defined(HTYPE_BLKCNT_T) deriving instance Prim CBlkCnt #endif #if defined(HTYPE_CLOCKID_T) deriving instance Prim CClockId #endif #if defined(HTYPE_FSBLKCNT_T) deriving instance Prim CFsBlkCnt #endif #if defined(HTYPE_FSFILCNT_T) deriving instance Prim CFsFilCnt #endif #if defined(HTYPE_ID_T) deriving instance Prim CId #endif #if defined(HTYPE_KEY_T) deriving instance Prim CKey #endif #if defined(HTYPE_TIMER_T) deriving instance Prim CTimer #endif deriving instance Prim Fd -- | @since 0.6.5.0 deriving instance Prim a => Prim (Const a b) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Down a) #if MIN_VERSION_base(4,8,0) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Identity a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Monoid.Dual a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Monoid.Sum a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Monoid.Product a) #endif #if MIN_VERSION_base(4,9,0) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Semigroup.First a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Semigroup.Last a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Semigroup.Min a) -- | @since 0.6.5.0 deriving instance Prim a => Prim (Semigroup.Max a) #endif primitive-0.7.0.1/LICENSE0000644000000000000000000000301607346545000013063 0ustar0000000000000000Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. primitive-0.7.0.1/Setup.hs0000644000000000000000000000005707346545000013514 0ustar0000000000000000import Distribution.Simple main = defaultMain primitive-0.7.0.1/cbits/0000755000000000000000000000000007346545000013162 5ustar0000000000000000primitive-0.7.0.1/cbits/primitive-memops.c0000644000000000000000000000474407346545000016645 0ustar0000000000000000#include #include "primitive-memops.h" void hsprimitive_memcpy( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) { memcpy( (char *)dst + doff, (char *)src + soff, len ); } void hsprimitive_memmove( void *dst, ptrdiff_t doff, void *src, ptrdiff_t soff, size_t len ) { memmove( (char *)dst + doff, (char *)src + soff, len ); } #define MEMSET(TYPE, ATYPE) \ void hsprimitive_memset_ ## TYPE (Hs ## TYPE *p, ptrdiff_t off, size_t n, ATYPE x) \ { \ p += off; \ if (x == 0) \ memset(p, 0, n * sizeof(Hs ## TYPE)); \ else if (sizeof(Hs ## TYPE) == sizeof(int)*2) { \ int *q = (int *)p; \ const int *r = (const int *)(void *)&x; \ while (n>0) { \ q[0] = r[0]; \ q[1] = r[1]; \ q += 2; \ --n; \ } \ } \ else { \ while (n>0) { \ *p++ = x; \ --n; \ } \ } \ } 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 ); } /* MEMSET(HsWord8, HsWord) */ MEMSET(Word16, HsWord) MEMSET(Word32, HsWord) MEMSET(Word64, HsWord64) MEMSET(Word, HsWord) MEMSET(Ptr, HsPtr) MEMSET(Float, HsFloat) MEMSET(Double, HsDouble) MEMSET(Char, HsChar) primitive-0.7.0.1/cbits/primitive-memops.h0000644000000000000000000000200107346545000016632 0ustar0000000000000000#ifndef haskell_primitive_memops_h #define haskell_primitive_memops_h #include #include #include 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); void hsprimitive_memset_Word32 (HsWord32 *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Word64 (HsWord64 *, ptrdiff_t, size_t, HsWord64); void hsprimitive_memset_Word (HsWord *, ptrdiff_t, size_t, HsWord); void hsprimitive_memset_Ptr (HsPtr *, ptrdiff_t, size_t, HsPtr); void hsprimitive_memset_Float (HsFloat *, ptrdiff_t, size_t, HsFloat); void hsprimitive_memset_Double (HsDouble *, ptrdiff_t, size_t, HsDouble); void hsprimitive_memset_Char (HsChar *, ptrdiff_t, size_t, HsChar); #endif primitive-0.7.0.1/changelog.md0000755000000000000000000001474307346545000014343 0ustar0000000000000000## Changes in version 0.7.0.1 * Allow building with GHC 8.12. ## Changes in version 0.7.0.0 * Remove `Addr` data type, lifted code should use `Ptr a` now * Define `MonadFail` instances for `Array` and `SmallArray`. * Define `unsafeInterleave`. * Add a `Prim` instance for `StablePtr` * Remove `UnliftedArray` and related type classes * Add a lot more tests for `PrimArray`. * Added PrimMonad instance for CPS Writer and RWS monads from Transformers * Remove useless accidental laziness in `atomicModifyMutVar`, making it match `atomicModifyIORef`. The semantics should be the same. * lots of little documentation twiddles. ## Changes in version 0.6.4.1 * Add instances for the following newtypes from `base`: `Const`, `Identity`, `Down`, `Dual`, `Sum`, `Product`, `First`, `Last`, `Min`, `Max` * Add `base-orphans` dependency to test suite to accomodate older versions of GHC not having instances of `Show` and `Eq` for some of the above newtypes. ## Changes in version 0.6.4.0 * Introduce `Data.Primitive.PrimArray`, which offers types and function for dealing with a `ByteArray` tagged with a phantom type variable for tracking the element type. * Implement `isByteArrayPinned` and `isMutableByteArrayPinned`. * Add `Eq1`, `Ord1`, `Show1`, and `Read1` instances for `Array` and `SmallArray`. * Improve the test suite. This includes having property tests for typeclasses from `base` such as `Eq`, `Ord`, `Functor`, `Applicative`, `Monad`, `IsList`, `Monoid`, `Foldable`, and `Traversable`. * Fix the broken `IsList` instance for `ByteArray`. The old definition would allocate a byte array of the correct size and then leave the memory unitialized instead of writing the list elements to it. * Fix the broken `Functor` instance for `Array`. The old definition would allocate an array of the correct size with thunks for erroring installed at every index. It failed to replace these thunks with the result of the function applied to the elements of the argument array. * Fix the broken `Applicative` instances of `Array` and `SmallArray`. The old implementation of `<*>` for `Array` failed to initialize some elements but correctly initialized others in the resulting `Array`. It is unclear what the old behavior of `<*>` was for `SmallArray`, but it was incorrect. * Fix the broken `Monad` instances for `Array` and `SmallArray`. * Fix the implementation of `foldl1` in the `Foldable` instances for `Array` and `SmallArray`. In both cases, the old implementation simply returned the first element of the array and made no use of the other elements in the array. * Fix the implementation of `mconcat` in the `Monoid` instance for `SmallArray`. * Implement `Data.Primitive.Ptr`, implementations of `Ptr` functions that require a `Prim` constraint instead of a `Storable` constraint. * Add `PrimUnlifted` instances for `TVar` and `MVar`. * Use `compareByteArrays#` for the `Eq` and `Ord` instances of `ByteArray` when building with GHC 8.4 and newer. * Add `Prim` instances for lots of types in `Foreign.C.Types` and `System.Posix.Types`. * Reexport `Data.Primitive.SmallArray` and `Data.Primitive.UnliftedArray` from `Data.Primitive`. * Add fold functions and map function to `Data.Primitive.UnliftedArray`. Add typeclass instances for `IsList`, `Ord`, and `Show`. * Add `defaultSetByteArray#` and `defaultSetOffAddr#` to `Data.Primitive.Types`. * Add `Data.Primitive.MVar`, a replacement for `Control.Concurrent.MVar` that can run in any `PrimMonad` instead of just `IO`. It is not a full replacement. Notably, it's missing masking functions and support for adding finalizers. ## 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 * `SmallArray` support * `ArrayArray#` based support for more efficient arrays of unlifted pointer types * Make `Array` and the like instances of various classes for convenient use * Add `Prim` instances for Ptr and FunPtr * Add `ioToPrim`, `stToPrim` and unsafe counterparts for situations that would otherwise require type ascriptions on `primToPrim` * Add `evalPrim` * Add `PrimBase` instance for `IdentityT` ## Changes in version 0.6.1.0 * Use more appropriate types in internal memset functions, which prevents overflows/segfaults on 64-bit systems. * Fixed a warning on GHC 7.10 * Worked around a -dcore-lint bug in GHC 7.6/7.7 ## Changes in version 0.6 * Split PrimMonad into two classes to allow automatic lifting of primitive operations into monad transformers. The `internal` operation has moved to the `PrimBase` class. * Fixed the test suite on older GHCs ## Changes in version 0.5.4.0 * Changed primitive_ to work around an oddity with GHC's code generation on certain versions that led to side effects not happening when used in conjunction with certain very unsafe IO performers. * Allow primitive to build on GHC 7.9 ## Changes in version 0.5.3.0 * Implement `cloneArray` and `cloneMutableArray` primitives (with fall-back implementations for GHCs prior to version 7.2.1) ## Changes in version 0.5.2.1 * Add strict variants of `MutVar` modification functions `atomicModifyMutVar'` and `modifyMutVar'` * Fix compilation on Solaris 10 with GNU C 3.4.3 ## Changes in version 0.5.1.0 * Add support for GHC 7.7's new primitive `Bool` representation ## Changes in version 0.5.0.1 * Disable array copying primitives for GHC 7.6.* and earlier ## Changes in version 0.5 * New in `Data.Primitive.MutVar`: `atomicModifyMutVar` * Efficient block fill operations: `setByteArray`, `setAddr` ## Changes in version 0.4.1 * New module `Data.Primitive.MutVar` ## Changes in version 0.4.0.1 * Critical bug fix in `fillByteArray` ## Changes in version 0.4 * Support for GHC 7.2 array copying primitives * New in `Data.Primitive.ByteArray`: `copyByteArray`, `copyMutableByteArray`, `moveByteArray`, `fillByteArray` * Deprecated in `Data.Primitive.ByteArray`: `memcpyByteArray`, `memcpyByteArray'`, `memmoveByteArray`, `memsetByteArray` * New in `Data.Primitive.Array`: `copyArray`, `copyMutableByteArray` * New in `Data.Primitive.Addr`: `copyAddr`, `moveAddr` * Deprecated in `Data.Primitive.Addr`: `memcpyAddr` primitive-0.7.0.1/primitive.cabal0000644000000000000000000000655107346545000015061 0ustar0000000000000000Cabal-Version: 2.2 Name: primitive Version: 0.7.0.1 License: BSD-3-Clause License-File: LICENSE Author: Roman Leshchinskiy Maintainer: libraries@haskell.org Copyright: (c) Roman Leshchinskiy 2009-2012 Homepage: https://github.com/haskell/primitive Bug-Reports: https://github.com/haskell/primitive/issues Category: Data Synopsis: Primitive memory-related operations Build-Type: Simple Description: This package provides various primitive memory-related operations. Extra-Source-Files: changelog.md test/*.hs test/LICENSE Tested-With: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.2, GHC == 8.10.1 Library Default-Language: Haskell2010 Other-Extensions: BangPatterns, CPP, DeriveDataTypeable, MagicHash, TypeFamilies, UnboxedTuples, UnliftedFFITypes Exposed-Modules: Control.Monad.Primitive Data.Primitive Data.Primitive.MachDeps Data.Primitive.Types Data.Primitive.Array Data.Primitive.ByteArray Data.Primitive.PrimArray Data.Primitive.SmallArray Data.Primitive.Ptr Data.Primitive.MutVar Data.Primitive.MVar Other-Modules: Data.Primitive.Internal.Compat Data.Primitive.Internal.Operations Build-Depends: base >= 4.5 && < 4.15 , ghc-prim >= 0.2 && < 0.7 , transformers >= 0.2 && < 0.6 if !impl(ghc >= 8.0) Build-Depends: fail == 4.9.* Ghc-Options: -O2 Include-Dirs: cbits Install-Includes: primitive-memops.h includes: primitive-memops.h c-sources: cbits/primitive-memops.c if !os(solaris) cc-options: -ftree-vectorize if arch(i386) || arch(x86_64) cc-options: -msse2 test-suite test-qc Default-Language: Haskell2010 hs-source-dirs: test test/src main-is: main.hs Other-Modules: PrimLawsWIP Test.QuickCheck.Classes Test.QuickCheck.Classes.Alternative Test.QuickCheck.Classes.Applicative Test.QuickCheck.Classes.Common Test.QuickCheck.Classes.Compat Test.QuickCheck.Classes.Enum Test.QuickCheck.Classes.Eq Test.QuickCheck.Classes.Foldable Test.QuickCheck.Classes.Functor Test.QuickCheck.Classes.Generic Test.QuickCheck.Classes.Integral Test.QuickCheck.Classes.IsList Test.QuickCheck.Classes.Monad Test.QuickCheck.Classes.MonadPlus Test.QuickCheck.Classes.MonadZip Test.QuickCheck.Classes.Monoid Test.QuickCheck.Classes.Ord Test.QuickCheck.Classes.Semigroup Test.QuickCheck.Classes.Show Test.QuickCheck.Classes.ShowRead Test.QuickCheck.Classes.Storable Test.QuickCheck.Classes.Traversable type: exitcode-stdio-1.0 build-depends: base , base-orphans , ghc-prim , primitive , QuickCheck ^>= 2.13 , tasty ^>= 1.2 , tasty-quickcheck , tagged , transformers >=0.4 , transformers-compat , semigroups cpp-options: -DHAVE_UNARY_LAWS ghc-options: -O2 source-repository head type: git location: https://github.com/haskell/primitive primitive-0.7.0.1/test/0000755000000000000000000000000007346545000013035 5ustar0000000000000000primitive-0.7.0.1/test/LICENSE0000755000000000000000000000301607346545000014045 0ustar0000000000000000Copyright (c) 2008-2009, Roman Leshchinskiy All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. - Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - Neither name of the University nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. primitive-0.7.0.1/test/main.hs0000644000000000000000000004075207346545000014325 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeInType #-} #endif import Control.Monad import Control.Monad.ST import Data.Primitive import Data.Word import Data.Proxy (Proxy(..)) import GHC.Int import GHC.IO import GHC.Exts import Data.Function (on) import Control.Applicative (Const(..)) import PrimLawsWIP (primLaws) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) #else import GHC.Exts (Down(..)) #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimes) import qualified Data.Semigroup as Semigroup #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif #if __GLASGOW_HASKELL__ >= 805 import Foreign.Storable (Storable) #endif import Data.Orphans () import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function) import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Classes as QCC import qualified Test.QuickCheck.Classes.IsList as QCCL import qualified Data.List as L main :: IO () main = do testArray testByteArray defaultMain $ testGroup "properties" [ testGroup "Array" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array)) #endif #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int))) , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray') #endif ] , testGroup "SmallArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray)) #endif #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int))) , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray') #endif ] , testGroup "ByteArray" [ testGroup "Ordering" [ TQC.testProperty "equality" byteArrayEqProp , TQC.testProperty "compare" byteArrayCompareProp ] , testGroup "Resize" [ TQC.testProperty "shrink" byteArrayShrinkProp , TQC.testProperty "grow" byteArrayGrowProp ] , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray) #endif ] , testGroup "PrimArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16))) #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray') , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray) , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray') , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM') , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray) , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray) , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP) , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray) , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray) , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP) , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray) , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA) , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP) , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray) , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA) , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP) , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray) , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA) , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP) , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) #endif ] ,testGroup "DefaultSetMethod" [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod)) ] #if __GLASGOW_HASKELL__ >= 805 ,testGroup "PrimStorable" [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived)) ] #endif ,testGroup "Prim" [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word)) , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8)) , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16)) , renameLawsToTest "Word32" (primLaws (Proxy :: Proxy Word32)) , renameLawsToTest "Word64" (primLaws (Proxy :: Proxy Word64)) , renameLawsToTest "Int" (primLaws (Proxy :: Proxy Int)) , renameLawsToTest "Int8" (primLaws (Proxy :: Proxy Int8)) , renameLawsToTest "Int16" (primLaws (Proxy :: Proxy Int16)) , renameLawsToTest "Int32" (primLaws (Proxy :: Proxy Int32)) , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64)) , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16))) , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16))) #if MIN_VERSION_base(4,8,0) , renameLawsToTest "Identity" (primLaws (Proxy :: Proxy (Identity Int16))) , renameLawsToTest "Dual" (primLaws (Proxy :: Proxy (Monoid.Dual Int16))) , renameLawsToTest "Sum" (primLaws (Proxy :: Proxy (Monoid.Sum Int16))) , renameLawsToTest "Product" (primLaws (Proxy :: Proxy (Monoid.Product Int16))) #endif #if MIN_VERSION_base(4,9,0) , renameLawsToTest "First" (primLaws (Proxy :: Proxy (Semigroup.First Int16))) , renameLawsToTest "Last" (primLaws (Proxy :: Proxy (Semigroup.Last Int16))) , renameLawsToTest "Min" (primLaws (Proxy :: Proxy (Semigroup.Min Int16))) , renameLawsToTest "Max" (primLaws (Proxy :: Proxy (Semigroup.Max Int16))) #endif ] ] deriving instance Arbitrary a => Arbitrary (Down a) -- Const, Dual, Sum, Product: all have Arbitrary instances defined -- in QuickCheck itself #if MIN_VERSION_base(4,9,0) deriving instance Arbitrary a => Arbitrary (Semigroup.First a) deriving instance Arbitrary a => Arbitrary (Semigroup.Last a) deriving instance Arbitrary a => Arbitrary (Semigroup.Min a) deriving instance Arbitrary a => Arbitrary (Semigroup.Max a) #endif word8 :: Proxy Word8 word8 = Proxy int16 :: Proxy Int16 int16 = Proxy int32 :: Proxy Int32 int32 = Proxy -- Tests that using resizeByteArray to shrink a byte array produces -- the same results as calling Data.List.take on the list that the -- byte array corresponds to. byteArrayShrinkProp :: QC.Property byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> let large = max n m small = min n m xs = intsLessThan large ys = byteArrayFromList xs largeBytes = large * sizeOf (undefined :: Int) smallBytes = small * sizeOf (undefined :: Int) expected = byteArrayFromList (L.take small xs) actual = runST $ do mzs0 <- newByteArray largeBytes copyByteArray mzs0 0 ys 0 largeBytes mzs1 <- resizeMutableByteArray mzs0 smallBytes unsafeFreezeByteArray mzs1 in expected === actual -- Tests that using resizeByteArray with copyByteArray (to fill in the -- new empty space) to grow a byte array produces the same results as -- calling Data.List.++ on the lists corresponding to the original -- byte array and the appended byte array. byteArrayGrowProp :: QC.Property byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> let large = max n m small = min n m xs1 = intsLessThan small xs2 = intsLessThan (large - small) ys1 = byteArrayFromList xs1 ys2 = byteArrayFromList xs2 largeBytes = large * sizeOf (undefined :: Int) smallBytes = small * sizeOf (undefined :: Int) expected = byteArrayFromList (xs1 ++ xs2) actual = runST $ do mzs0 <- newByteArray smallBytes copyByteArray mzs0 0 ys1 0 smallBytes mzs1 <- resizeMutableByteArray mzs0 largeBytes copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int)) unsafeFreezeByteArray mzs1 in expected === actual -- Tests that writing stable ptrs to a PrimArray, reading them back -- out, and then dereferencing them gives correct results. --stablePtrPrimProp :: QC.Property --stablePtrPrimProp = QC.property $ \(xs :: [Integer]) -> unsafePerformIO $ do -- ptrs <- mapM newStablePtr xs -- let ptrs' = primArrayToList (primArrayFromList ptrs) -- ys <- mapM deRefStablePtr ptrs' -- mapM_ freeStablePtr ptrs' -- return (xs === ys) --stablePtrPrimBlockProp :: QC.Property --stablePtrPrimBlockProp = QC.property $ \(x :: Word) (QC.NonNegative (len :: Int)) -> unsafePerformIO $ do -- ptr <- newStablePtr x -- let ptrs' = replicatePrimArray len ptr -- let go ix = if ix < len -- then do -- n <- deRefStablePtr (indexPrimArray ptrs' ix) -- ns <- go (ix + 1) -- return (n : ns) -- else return [] -- ys <- go 0 -- freeStablePtr ptr -- return (L.replicate len x === ys) -- Provide the non-negative integers up to the bound. For example: -- -- >>> intsLessThan 5 -- [0,1,2,3,4] intsLessThan :: Int -> [Int] intsLessThan i = if i < 1 then [] else (i - 1) : intsLessThan (i - 1) byteArrayCompareProp :: QC.Property byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys) byteArrayEqProp :: QC.Property byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys) compareLengthFirst :: [Word8] -> [Word8] -> Ordering compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys -- on GHC 7.4, Proxy is not polykinded, so we need this instead. data Proxy1 (f :: * -> *) = Proxy1 lawsToTest :: QCC.Laws -> TestTree lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) renameLawsToTest :: String -> QCC.Laws -> TestTree renameLawsToTest name (QCC.Laws _ pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) testArray :: IO () testArray = do arr <- newArray 1 'A' let unit = case writeArray arr 0 'B' of IO f -> case f realWorld# of (# _, _ #) -> () c1 <- readArray arr 0 return $! unit c2 <- readArray arr 0 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]) arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8]) arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [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" unless (mappend arr1 arr4 == arr5) $ fail $ "ByteArray Monoid mappend incorrect" unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $ fail $ "ByteArray Monoid mappend not associative" unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $ fail $ "ByteArray Monoid mconcat incorrect" #if MIN_VERSION_base(4,9,0) unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $ fail $ "ByteArray Semigroup stimes incorrect" #endif mkByteArray :: Prim a => [a] -> ByteArray mkByteArray xs = runST $ do marr <- newByteArray (length xs * sizeOf (head xs)) sequence_ $ zipWith (writeByteArray marr) [0..] xs unsafeFreezeByteArray marr instance Arbitrary1 Array where liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen) instance Arbitrary a => Arbitrary (Array a) where arbitrary = fmap fromList QC.arbitrary instance Arbitrary1 SmallArray where liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen) instance Arbitrary a => Arbitrary (SmallArray a) where arbitrary = fmap smallArrayFromList QC.arbitrary instance Arbitrary ByteArray where arbitrary = do xs <- QC.arbitrary :: Gen [Word8] return $ runST $ do a <- newByteArray (L.length xs) iforM_ xs $ \ix x -> do writeByteArray a ix x unsafeFreezeByteArray a instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where arbitrary = do xs <- QC.arbitrary :: Gen [a] return $ runST $ do a <- newPrimArray (L.length xs) iforM_ xs $ \ix x -> do writePrimArray a ix x unsafeFreezePrimArray a instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where coarbitrary x = QC.coarbitrary (primArrayToList x) instance (Prim a, Function a) => Function (PrimArray a) where function = QC.functionMap primArrayToList primArrayFromList iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m () iforM_ xs0 f = go 0 xs0 where go !_ [] = return () go !ix (x : xs) = f ix x >> go (ix + 1) xs newtype DefaultSetMethod = DefaultSetMethod Int16 deriving (Eq,Show,Arbitrary) instance Prim DefaultSetMethod where sizeOf# _ = sizeOf# (undefined :: Int16) alignment# _ = alignment# (undefined :: Int16) indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix) readByteArray# arr ix s0 = case readByteArray# arr ix s0 of (# s1, n #) -> (# s1, DefaultSetMethod n #) writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0 setByteArray# = defaultSetByteArray# indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off) readOffAddr# addr off s0 = case readOffAddr# addr off s0 of (# s1, n #) -> (# s1, DefaultSetMethod n #) writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0 setOffAddr# = defaultSetOffAddr# #if __GLASGOW_HASKELL__ >= 805 newtype Derived = Derived Int16 deriving stock (Eq, Show) deriving newtype (Arbitrary, Prim) deriving Storable via (PrimStorable Derived) #endif primitive-0.7.0.1/test/main.hs0000755000000000000000000004075207346545000014330 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 805 {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeInType #-} #endif import Control.Monad import Control.Monad.ST import Data.Primitive import Data.Word import Data.Proxy (Proxy(..)) import GHC.Int import GHC.IO import GHC.Exts import Data.Function (on) import Control.Applicative (Const(..)) import PrimLawsWIP (primLaws) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid #endif #if MIN_VERSION_base(4,6,0) import Data.Ord (Down(..)) #else import GHC.Exts (Down(..)) #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (stimes) import qualified Data.Semigroup as Semigroup #endif #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif #if __GLASGOW_HASKELL__ >= 805 import Foreign.Storable (Storable) #endif import Data.Orphans () import Test.Tasty (defaultMain,testGroup,TestTree) import Test.QuickCheck (Arbitrary,Arbitrary1,Gen,(===),CoArbitrary,Function) import qualified Test.Tasty.QuickCheck as TQC import qualified Test.QuickCheck as QC import qualified Test.QuickCheck.Classes as QCC import qualified Test.QuickCheck.Classes.IsList as QCCL import qualified Data.List as L main :: IO () main = do testArray testByteArray defaultMain $ testGroup "properties" [ testGroup "Array" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 Array)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 Array)) #endif #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (Array Int))) , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray') #endif ] , testGroup "SmallArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,4,0) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.applicativeLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.monadLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.foldableLaws (Proxy1 :: Proxy1 SmallArray)) , lawsToTest (QCC.traversableLaws (Proxy1 :: Proxy1 SmallArray)) #endif #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (SmallArray Int))) , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray') #endif ] , testGroup "ByteArray" [ testGroup "Ordering" [ TQC.testProperty "equality" byteArrayEqProp , TQC.testProperty "compare" byteArrayCompareProp ] , testGroup "Resize" [ TQC.testProperty "shrink" byteArrayShrinkProp , TQC.testProperty "grow" byteArrayGrowProp ] , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray) #endif ] , testGroup "PrimArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16))) #if MIN_VERSION_base(4,7,0) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) , TQC.testProperty "foldrPrimArray'" (QCCL.foldrProp int16 foldrPrimArray') , TQC.testProperty "foldlPrimArray" (QCCL.foldlProp int16 foldlPrimArray) , TQC.testProperty "foldlPrimArray'" (QCCL.foldlProp int16 foldlPrimArray') , TQC.testProperty "foldlPrimArrayM'" (QCCL.foldlMProp int16 foldlPrimArrayM') , TQC.testProperty "mapPrimArray" (QCCL.mapProp int16 int32 mapPrimArray) , TQC.testProperty "traversePrimArray" (QCCL.traverseProp int16 int32 traversePrimArray) , TQC.testProperty "traversePrimArrayP" (QCCL.traverseProp int16 int32 traversePrimArrayP) , TQC.testProperty "imapPrimArray" (QCCL.imapProp int16 int32 imapPrimArray) , TQC.testProperty "itraversePrimArray" (QCCL.imapMProp int16 int32 itraversePrimArray) , TQC.testProperty "itraversePrimArrayP" (QCCL.imapMProp int16 int32 itraversePrimArrayP) , TQC.testProperty "generatePrimArray" (QCCL.generateProp int16 generatePrimArray) , TQC.testProperty "generatePrimArrayA" (QCCL.generateMProp int16 generatePrimArrayA) , TQC.testProperty "generatePrimArrayP" (QCCL.generateMProp int16 generatePrimArrayP) , TQC.testProperty "replicatePrimArray" (QCCL.replicateProp int16 replicatePrimArray) , TQC.testProperty "replicatePrimArrayA" (QCCL.replicateMProp int16 replicatePrimArrayA) , TQC.testProperty "replicatePrimArrayP" (QCCL.replicateMProp int16 replicatePrimArrayP) , TQC.testProperty "filterPrimArray" (QCCL.filterProp int16 filterPrimArray) , TQC.testProperty "filterPrimArrayA" (QCCL.filterMProp int16 filterPrimArrayA) , TQC.testProperty "filterPrimArrayP" (QCCL.filterMProp int16 filterPrimArrayP) , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) #endif ] ,testGroup "DefaultSetMethod" [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod)) ] #if __GLASGOW_HASKELL__ >= 805 ,testGroup "PrimStorable" [ lawsToTest (QCC.storableLaws (Proxy :: Proxy Derived)) ] #endif ,testGroup "Prim" [ renameLawsToTest "Word" (primLaws (Proxy :: Proxy Word)) , renameLawsToTest "Word8" (primLaws (Proxy :: Proxy Word8)) , renameLawsToTest "Word16" (primLaws (Proxy :: Proxy Word16)) , renameLawsToTest "Word32" (primLaws (Proxy :: Proxy Word32)) , renameLawsToTest "Word64" (primLaws (Proxy :: Proxy Word64)) , renameLawsToTest "Int" (primLaws (Proxy :: Proxy Int)) , renameLawsToTest "Int8" (primLaws (Proxy :: Proxy Int8)) , renameLawsToTest "Int16" (primLaws (Proxy :: Proxy Int16)) , renameLawsToTest "Int32" (primLaws (Proxy :: Proxy Int32)) , renameLawsToTest "Int64" (primLaws (Proxy :: Proxy Int64)) , renameLawsToTest "Const" (primLaws (Proxy :: Proxy (Const Int16 Int16))) , renameLawsToTest "Down" (primLaws (Proxy :: Proxy (Down Int16))) #if MIN_VERSION_base(4,8,0) , renameLawsToTest "Identity" (primLaws (Proxy :: Proxy (Identity Int16))) , renameLawsToTest "Dual" (primLaws (Proxy :: Proxy (Monoid.Dual Int16))) , renameLawsToTest "Sum" (primLaws (Proxy :: Proxy (Monoid.Sum Int16))) , renameLawsToTest "Product" (primLaws (Proxy :: Proxy (Monoid.Product Int16))) #endif #if MIN_VERSION_base(4,9,0) , renameLawsToTest "First" (primLaws (Proxy :: Proxy (Semigroup.First Int16))) , renameLawsToTest "Last" (primLaws (Proxy :: Proxy (Semigroup.Last Int16))) , renameLawsToTest "Min" (primLaws (Proxy :: Proxy (Semigroup.Min Int16))) , renameLawsToTest "Max" (primLaws (Proxy :: Proxy (Semigroup.Max Int16))) #endif ] ] deriving instance Arbitrary a => Arbitrary (Down a) -- Const, Dual, Sum, Product: all have Arbitrary instances defined -- in QuickCheck itself #if MIN_VERSION_base(4,9,0) deriving instance Arbitrary a => Arbitrary (Semigroup.First a) deriving instance Arbitrary a => Arbitrary (Semigroup.Last a) deriving instance Arbitrary a => Arbitrary (Semigroup.Min a) deriving instance Arbitrary a => Arbitrary (Semigroup.Max a) #endif word8 :: Proxy Word8 word8 = Proxy int16 :: Proxy Int16 int16 = Proxy int32 :: Proxy Int32 int32 = Proxy -- Tests that using resizeByteArray to shrink a byte array produces -- the same results as calling Data.List.take on the list that the -- byte array corresponds to. byteArrayShrinkProp :: QC.Property byteArrayShrinkProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> let large = max n m small = min n m xs = intsLessThan large ys = byteArrayFromList xs largeBytes = large * sizeOf (undefined :: Int) smallBytes = small * sizeOf (undefined :: Int) expected = byteArrayFromList (L.take small xs) actual = runST $ do mzs0 <- newByteArray largeBytes copyByteArray mzs0 0 ys 0 largeBytes mzs1 <- resizeMutableByteArray mzs0 smallBytes unsafeFreezeByteArray mzs1 in expected === actual -- Tests that using resizeByteArray with copyByteArray (to fill in the -- new empty space) to grow a byte array produces the same results as -- calling Data.List.++ on the lists corresponding to the original -- byte array and the appended byte array. byteArrayGrowProp :: QC.Property byteArrayGrowProp = QC.property $ \(QC.NonNegative (n :: Int)) (QC.NonNegative (m :: Int)) -> let large = max n m small = min n m xs1 = intsLessThan small xs2 = intsLessThan (large - small) ys1 = byteArrayFromList xs1 ys2 = byteArrayFromList xs2 largeBytes = large * sizeOf (undefined :: Int) smallBytes = small * sizeOf (undefined :: Int) expected = byteArrayFromList (xs1 ++ xs2) actual = runST $ do mzs0 <- newByteArray smallBytes copyByteArray mzs0 0 ys1 0 smallBytes mzs1 <- resizeMutableByteArray mzs0 largeBytes copyByteArray mzs1 smallBytes ys2 0 ((large - small) * sizeOf (undefined :: Int)) unsafeFreezeByteArray mzs1 in expected === actual -- Tests that writing stable ptrs to a PrimArray, reading them back -- out, and then dereferencing them gives correct results. --stablePtrPrimProp :: QC.Property --stablePtrPrimProp = QC.property $ \(xs :: [Integer]) -> unsafePerformIO $ do -- ptrs <- mapM newStablePtr xs -- let ptrs' = primArrayToList (primArrayFromList ptrs) -- ys <- mapM deRefStablePtr ptrs' -- mapM_ freeStablePtr ptrs' -- return (xs === ys) --stablePtrPrimBlockProp :: QC.Property --stablePtrPrimBlockProp = QC.property $ \(x :: Word) (QC.NonNegative (len :: Int)) -> unsafePerformIO $ do -- ptr <- newStablePtr x -- let ptrs' = replicatePrimArray len ptr -- let go ix = if ix < len -- then do -- n <- deRefStablePtr (indexPrimArray ptrs' ix) -- ns <- go (ix + 1) -- return (n : ns) -- else return [] -- ys <- go 0 -- freeStablePtr ptr -- return (L.replicate len x === ys) -- Provide the non-negative integers up to the bound. For example: -- -- >>> intsLessThan 5 -- [0,1,2,3,4] intsLessThan :: Int -> [Int] intsLessThan i = if i < 1 then [] else (i - 1) : intsLessThan (i - 1) byteArrayCompareProp :: QC.Property byteArrayCompareProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> compareLengthFirst xs ys === compare (byteArrayFromList xs) (byteArrayFromList ys) byteArrayEqProp :: QC.Property byteArrayEqProp = QC.property $ \(xs :: [Word8]) (ys :: [Word8]) -> (compareLengthFirst xs ys == EQ) === (byteArrayFromList xs == byteArrayFromList ys) compareLengthFirst :: [Word8] -> [Word8] -> Ordering compareLengthFirst xs ys = (compare `on` length) xs ys <> compare xs ys -- on GHC 7.4, Proxy is not polykinded, so we need this instead. data Proxy1 (f :: * -> *) = Proxy1 lawsToTest :: QCC.Laws -> TestTree lawsToTest (QCC.Laws name pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) renameLawsToTest :: String -> QCC.Laws -> TestTree renameLawsToTest name (QCC.Laws _ pairs) = testGroup name (map (uncurry TQC.testProperty) pairs) testArray :: IO () testArray = do arr <- newArray 1 'A' let unit = case writeArray arr 0 'B' of IO f -> case f realWorld# of (# _, _ #) -> () c1 <- readArray arr 0 return $! unit c2 <- readArray arr 0 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]) arr4 = mkByteArray ([0xde, 0xad, 0xbe, 0xdd] :: [Word8]) arr5 = mkByteArray ([0xde, 0xad, 0xbe, 0xef, 0xde, 0xad, 0xbe, 0xdd] :: [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" unless (mappend arr1 arr4 == arr5) $ fail $ "ByteArray Monoid mappend incorrect" unless (mappend arr1 (mappend arr3 arr4) == mappend (mappend arr1 arr3) arr4) $ fail $ "ByteArray Monoid mappend not associative" unless (mconcat [arr1,arr2,arr3,arr4,arr5] == (arr1 <> arr2 <> arr3 <> arr4 <> arr5)) $ fail $ "ByteArray Monoid mconcat incorrect" #if MIN_VERSION_base(4,9,0) unless (stimes (3 :: Int) arr4 == (arr4 <> arr4 <> arr4)) $ fail $ "ByteArray Semigroup stimes incorrect" #endif mkByteArray :: Prim a => [a] -> ByteArray mkByteArray xs = runST $ do marr <- newByteArray (length xs * sizeOf (head xs)) sequence_ $ zipWith (writeByteArray marr) [0..] xs unsafeFreezeByteArray marr instance Arbitrary1 Array where liftArbitrary elemGen = fmap fromList (QC.liftArbitrary elemGen) instance Arbitrary a => Arbitrary (Array a) where arbitrary = fmap fromList QC.arbitrary instance Arbitrary1 SmallArray where liftArbitrary elemGen = fmap smallArrayFromList (QC.liftArbitrary elemGen) instance Arbitrary a => Arbitrary (SmallArray a) where arbitrary = fmap smallArrayFromList QC.arbitrary instance Arbitrary ByteArray where arbitrary = do xs <- QC.arbitrary :: Gen [Word8] return $ runST $ do a <- newByteArray (L.length xs) iforM_ xs $ \ix x -> do writeByteArray a ix x unsafeFreezeByteArray a instance (Arbitrary a, Prim a) => Arbitrary (PrimArray a) where arbitrary = do xs <- QC.arbitrary :: Gen [a] return $ runST $ do a <- newPrimArray (L.length xs) iforM_ xs $ \ix x -> do writePrimArray a ix x unsafeFreezePrimArray a instance (Prim a, CoArbitrary a) => CoArbitrary (PrimArray a) where coarbitrary x = QC.coarbitrary (primArrayToList x) instance (Prim a, Function a) => Function (PrimArray a) where function = QC.functionMap primArrayToList primArrayFromList iforM_ :: Monad m => [a] -> (Int -> a -> m b) -> m () iforM_ xs0 f = go 0 xs0 where go !_ [] = return () go !ix (x : xs) = f ix x >> go (ix + 1) xs newtype DefaultSetMethod = DefaultSetMethod Int16 deriving (Eq,Show,Arbitrary) instance Prim DefaultSetMethod where sizeOf# _ = sizeOf# (undefined :: Int16) alignment# _ = alignment# (undefined :: Int16) indexByteArray# arr ix = DefaultSetMethod (indexByteArray# arr ix) readByteArray# arr ix s0 = case readByteArray# arr ix s0 of (# s1, n #) -> (# s1, DefaultSetMethod n #) writeByteArray# arr ix (DefaultSetMethod n) s0 = writeByteArray# arr ix n s0 setByteArray# = defaultSetByteArray# indexOffAddr# addr off = DefaultSetMethod (indexOffAddr# addr off) readOffAddr# addr off s0 = case readOffAddr# addr off s0 of (# s1, n #) -> (# s1, DefaultSetMethod n #) writeOffAddr# addr off (DefaultSetMethod n) s0 = writeOffAddr# addr off n s0 setOffAddr# = defaultSetOffAddr# #if __GLASGOW_HASKELL__ >= 805 newtype Derived = Derived Int16 deriving stock (Eq, Show) deriving newtype (Arbitrary, Prim) deriving Storable via (PrimStorable Derived) #endif primitive-0.7.0.1/test/src/0000755000000000000000000000000007346545000013624 5ustar0000000000000000primitive-0.7.0.1/test/src/PrimLawsWIP.hs0000644000000000000000000003232107346545000016277 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wall #-} module PrimLawsWIP ( primLaws ) where import Control.Applicative import Control.Monad.Primitive (PrimMonad, PrimState,primitive,primitive_) import Control.Monad.ST import Data.Proxy (Proxy) import Data.Primitive.ByteArray import Data.Primitive.Types import Data.Primitive.Ptr import Foreign.Marshal.Alloc import GHC.Exts (State#,Int#,Addr#,Int(I#),(*#),(+#),(<#),newByteArray#,unsafeFreezeByteArray#, copyMutableByteArray#,copyByteArray#,quotInt#,sizeofByteArray#) #if MIN_VERSION_base(4,7,0) import GHC.Exts (IsList(fromList,toList,fromListN),Item, copyByteArrayToAddr#,copyAddrToByteArray#) #endif import GHC.Ptr (Ptr(..)) import System.IO.Unsafe import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import qualified Data.List as L import qualified Data.Primitive as P import Test.QuickCheck.Classes.Common (Laws(..)) import Test.QuickCheck.Classes.Compat (isTrue#) -- | Test that a 'Prim' instance obey the several laws. primLaws :: (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws primLaws p = Laws "Prim" [ ("ByteArray Put-Get (you get back what you put in)", primPutGetByteArray p) , ("ByteArray Get-Put (putting back what you got out has no effect)", primGetPutByteArray p) , ("ByteArray Put-Put (putting twice is same as putting once)", primPutPutByteArray p) , ("ByteArray Set Range", primSetByteArray p) #if MIN_VERSION_base(4,7,0) , ("ByteArray List Conversion Roundtrips", primListByteArray p) #endif , ("Addr Put-Get (you get back what you put in)", primPutGetAddr p) , ("Addr Get-Put (putting back what you got out has no effect)", primGetPutAddr p) , ("Addr Set Range", primSetOffAddr p) , ("Addr List Conversion Roundtrips", primListAddr p) ] primListAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListAddr _ = property $ \(as :: [a]) -> unsafePerformIO $ do let len = L.length as ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) let go :: Int -> [a] -> IO () go !ix xs = case xs of [] -> return () (x : xsNext) -> do writeOffPtr ptr ix x go (ix + 1) xsNext go 0 as let rebuild :: Int -> IO [a] rebuild !ix = if ix < len then (:) <$> readOffPtr ptr ix <*> rebuild (ix + 1) else return [] asNew <- rebuild 0 free ptr return (as == asNew) primPutGetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primPutGetByteArray _ = property $ \(a :: a) len -> (len > 0) ==> do ix <- choose (0,len - 1) return $ runST $ do arr <- newPrimArray len writePrimArray arr ix a a' <- readPrimArray arr ix return (a == a') primGetPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primGetPutByteArray _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do let arr1 = primArrayFromList as :: PrimArray a len = L.length as ix <- choose (0,len - 1) arr2 <- return $ runST $ do marr <- newPrimArray len copyPrimArray marr 0 arr1 0 len a <- readPrimArray marr ix writePrimArray marr ix a unsafeFreezePrimArray marr return (arr1 == arr2) primPutPutByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primPutPutByteArray _ = property $ \(a :: a) (as :: [a]) -> (not (L.null as)) ==> do let arr1 = primArrayFromList as :: PrimArray a len = L.length as ix <- choose (0,len - 1) (arr2,arr3) <- return $ runST $ do marr2 <- newPrimArray len copyPrimArray marr2 0 arr1 0 len writePrimArray marr2 ix a marr3 <- newPrimArray len copyMutablePrimArray marr3 0 marr2 0 len arr2 <- unsafeFreezePrimArray marr2 writePrimArray marr3 ix a arr3 <- unsafeFreezePrimArray marr3 return (arr2,arr3) return (arr2 == arr3) primPutGetAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primPutGetAddr _ = property $ \(a :: a) len -> (len > 0) ==> do ix <- choose (0,len - 1) return $ unsafePerformIO $ do ptr :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) writeOffPtr ptr ix a a' <- readOffPtr ptr ix free ptr return (a == a') primGetPutAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primGetPutAddr _ = property $ True --property $ \(as :: [a]) -> (not (L.null as)) ==> do -- let arr1 = primArrayFromList as :: PrimArray a -- len = L.length as -- ix <- choose (0,len - 1) -- arr2 <- return $ unsafePerformIO $ do -- ptr:: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) -- copyPrimArrayToPtr ptr arr1 0 len -- a <- readOffPtr ptr ix -- writeOffPtr ptr ix a -- marr <- newPrimArray len -- copyPtrToMutablePrimArray marr 0 ptr len -- free ptr -- unsafeFreezePrimArray marr -- return (arr1 == arr2) primSetByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primSetByteArray _ = property $ \(as :: [a]) (z :: a) -> do let arr1 = primArrayFromList as :: PrimArray a len = L.length as x <- choose (0,len) y <- choose (0,len) let lo = min x y hi = max x y return $ runST $ do marr2 <- newPrimArray len copyPrimArray marr2 0 arr1 0 len marr3 <- newPrimArray len copyPrimArray marr3 0 arr1 0 len setPrimArray marr2 lo (hi - lo) z internalDefaultSetPrimArray marr3 lo (hi - lo) z arr2 <- unsafeFreezePrimArray marr2 arr3 <- unsafeFreezePrimArray marr3 return (arr2 == arr3) -- having trouble getting this to type check AND as written its really unsafe primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primSetOffAddr _ = property $ True --primSetOffAddr :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property --primSetOffAddr _ = property $ \(as :: [a]) (z :: a) -> do -- let arr1 = primArrayFromList as :: PrimArray a -- len = L.length as -- x <- choose (0,len) -- y <- choose (0,len) -- let lo = min x y -- hi = max x y -- return $ unsafePerformIO $ do -- ptrA@(Ptr addrA#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) -- copyPrimArrayToPtr ptrA arr1 0 len -- ptrB@(Ptr addrB#) :: Ptr a <- mallocBytes (len * P.sizeOf (undefined :: a)) -- copyPrimArrayToPtr ptrB arr1 0 len -- setPtr ptrA lo (hi - lo) z -- internalDefaultSetOffAddr ptrB lo (hi - lo) z -- marrA <- newPrimArray len -- copyPtrToMutablePrimArray marrA 0 ptrA len -- free ptrA -- marrB <- newPrimArray len -- copyPtrToMutablePrimArray marrB 0 ptrB len -- free ptrB -- arrA <- unsafeFreezePrimArray marrA -- arrB <- unsafeFreezePrimArray marrB -- return (arrA == arrB) -- byte array with phantom variable that specifies element type data PrimArray a = PrimArray ByteArray# data MutablePrimArray s a = MutablePrimArray (MutableByteArray# s) instance (Eq a, Prim a) => Eq (PrimArray a) where a1 == a2 = sizeofPrimArray a1 == sizeofPrimArray a2 && loop (sizeofPrimArray a1 - 1) where loop !i | i < 0 = True | otherwise = indexPrimArray a1 i == indexPrimArray a2 i && loop (i-1) #if MIN_VERSION_base(4,7,0) instance Prim a => IsList (PrimArray a) where type Item (PrimArray a) = a fromList = primArrayFromList fromListN = primArrayFromListN toList = primArrayToList #endif indexPrimArray :: forall a. Prim a => PrimArray a -> Int -> a indexPrimArray (PrimArray arr#) (I# i#) = indexByteArray# arr# i# sizeofPrimArray :: forall a. Prim a => PrimArray a -> Int sizeofPrimArray (PrimArray arr#) = I# (quotInt# (sizeofByteArray# arr#) (P.sizeOf# (undefined :: a))) newPrimArray :: forall m a. (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a) newPrimArray (I# n#) = primitive (\s# -> case newByteArray# (n# *# sizeOf# (undefined :: a)) s# of (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #) ) readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a readPrimArray (MutablePrimArray arr#) (I# i#) = primitive (readByteArray# arr# i#) writePrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> a -> m () writePrimArray (MutablePrimArray arr#) (I# i#) x = primitive_ (writeByteArray# arr# i# x) unsafeFreezePrimArray :: PrimMonad m => MutablePrimArray (PrimState m) a -> m (PrimArray a) unsafeFreezePrimArray (MutablePrimArray arr#) = primitive (\s# -> case unsafeFreezeByteArray# arr# s# of (# s'#, arr'# #) -> (# s'#, PrimArray arr'# #)) generateM_ :: Monad m => Int -> (Int -> m a) -> m () generateM_ n f = go 0 where go !ix = if ix < n then f ix >> go (ix + 1) else return () copyPrimArrayToPtr :: forall m a. (PrimMonad m, Prim a) => Ptr a -- ^ destination pointer -> PrimArray a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of prims to copy -> m () #if MIN_VERSION_base(4,7,0) copyPrimArrayToPtr (Ptr addr#) (PrimArray ba#) (I# soff#) (I# n#) = primitive (\ s# -> let s'# = copyByteArrayToAddr# ba# (soff# *# siz#) addr# (n# *# siz#) s# in (# s'#, () #)) where siz# = sizeOf# (undefined :: a) #else copyPrimArrayToPtr ptr ba soff n = generateM_ n $ \ix -> writeOffPtr ptr ix (indexPrimArray ba (ix + soff)) #endif {- copyPtrToMutablePrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -> Ptr a -> Int -> m () #if MIN_VERSION_base(4,7,0) copyPtrToMutablePrimArray (MutablePrimArray ba#) (I# doff#) (Ptr addr#) (I# n#) = primitive (\ s# -> let s'# = copyAddrToByteArray# addr# ba# (doff# *# siz#) (n# *# siz#) s# in (# s'#, () #)) where siz# = sizeOf# (undefined :: a) #else copyPtrToMutablePrimArray ba doff addr n = generateM_ n $ \ix -> do x <- readOffAddr (ptrToAddr addr) ix writePrimArray ba (doff + ix) x #endif -} copyMutablePrimArray :: forall m s a. (PrimMonad m, s ~ PrimState m , Prim a) => MutablePrimArray s a -- ^ destination array -> Int -- ^ offset into destination array -> MutablePrimArray s a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () copyMutablePrimArray (MutablePrimArray dst#) (I# doff#) (MutablePrimArray src#) (I# soff#) (I# n#) = primitive_ (copyMutableByteArray# src# (soff# *# (sizeOf# (undefined :: a))) dst# (doff# *# (sizeOf# (undefined :: a))) (n# *# (sizeOf# (undefined :: a))) ) copyPrimArray :: forall m a. (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -- ^ destination array -> Int -- ^ offset into destination array -> PrimArray a -- ^ source array -> Int -- ^ offset into source array -> Int -- ^ number of bytes to copy -> m () copyPrimArray (MutablePrimArray dst#) (I# doff#) (PrimArray src#) (I# soff#) (I# n#) = primitive_ (copyByteArray# src# (soff# *# (sizeOf# (undefined :: a))) dst# (doff# *# (sizeOf# (undefined :: a))) (n# *# (sizeOf# (undefined :: a))) ) setPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -- ^ array to fill -> Int -- ^ offset into array -> Int -- ^ number of values to fill -> a -- ^ value to fill with -> m () setPrimArray (MutablePrimArray dst#) (I# doff#) (I# sz#) x = primitive_ (P.setByteArray# dst# doff# sz# x) primArrayFromList :: Prim a => [a] -> PrimArray a primArrayFromList xs = primArrayFromListN (L.length xs) xs primArrayFromListN :: forall a. Prim a => Int -> [a] -> PrimArray a primArrayFromListN len vs = runST run where run :: forall s. ST s (PrimArray a) run = do arr <- newPrimArray len let go :: [a] -> Int -> ST s () go !xs !ix = case xs of [] -> return () a : as -> do writePrimArray arr ix a go as (ix + 1) go vs 0 unsafeFreezePrimArray arr primArrayToList :: forall a. Prim a => PrimArray a -> [a] primArrayToList arr = go 0 where !len = sizeofPrimArray arr go :: Int -> [a] go !ix = if ix < len then indexPrimArray arr ix : go (ix + 1) else [] #if MIN_VERSION_base(4,7,0) primListByteArray :: forall a. (Prim a, Eq a, Arbitrary a, Show a) => Proxy a -> Property primListByteArray _ = property $ \(as :: [a]) -> as == toList (fromList as :: PrimArray a) #endif internalDefaultSetPrimArray :: Prim a => MutablePrimArray s a -> Int -> Int -> a -> ST s () internalDefaultSetPrimArray (MutablePrimArray arr) (I# i) (I# len) ident = primitive_ (internalDefaultSetByteArray# arr i len ident) internalDefaultSetByteArray# :: Prim a => MutableByteArray# s -> Int# -> Int# -> a -> State# s -> State# s internalDefaultSetByteArray# arr# i# len# ident = go 0# where go ix# s0 = if isTrue# (ix# <# len#) then case writeByteArray# arr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 internalDefaultSetOffAddr :: Prim a => Ptr a -> Int -> Int -> a -> IO () internalDefaultSetOffAddr (Ptr addr) (I# ix) (I# len) a = primitive_ (internalDefaultSetOffAddr# addr ix len a) internalDefaultSetOffAddr# :: Prim a => Addr# -> Int# -> Int# -> a -> State# s -> State# s internalDefaultSetOffAddr# addr# i# len# ident = go 0# where go ix# s0 = if isTrue# (ix# <# len#) then case writeOffAddr# addr# (i# +# ix#) ident s0 of s1 -> go (ix# +# 1#) s1 else s0 primitive-0.7.0.1/test/src/Test/QuickCheck/0000755000000000000000000000000007346545000016555 5ustar0000000000000000primitive-0.7.0.1/test/src/Test/QuickCheck/Classes.hs0000644000000000000000000001533207346545000020512 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wall #-} {-| This library provides sets of properties that should hold for common typeclasses. /Note:/ on GHC < 8.5, this library uses the higher-kinded typeclasses ('Data.Functor.Classes.Show1', 'Data.Functor.Classes.Eq1', 'Data.Functor.Classes.Ord1', etc.), but on GHC >= 8.5, it uses `-XQuantifiedConstraints` to express these constraints more cleanly. -} module Test.QuickCheck.Classes ( -- * Running lawsCheck , lawsCheckMany , lawsCheckOne -- * Properties -- ** Ground types -- * Laws , eqLaws , integralLaws #if MIN_VERSION_base(4,7,0) , isListLaws #endif , monoidLaws , commutativeMonoidLaws , ordLaws , enumLaws , boundedEnumLaws #if HAVE_SEMIRINGS , semiringLaws , ringLaws #endif , showLaws , showReadLaws , storableLaws #if MIN_VERSION_base(4,5,0) , genericLaws --, generic1Laws #endif #if HAVE_UNARY_LAWS -- ** Unary type constructors , alternativeLaws #if HAVE_SEMIGROUPOIDS , altLaws , applyLaws #endif , applicativeLaws , foldableLaws , functorLaws , monadLaws , monadPlusLaws , monadZipLaws #if HAVE_SEMIGROUPOIDS , plusLaws , extendedPlusLaws #endif , traversableLaws #endif -- * Types , Laws(..) , Proxy1(..) , Proxy2(..) ) where -- -- re-exports -- -- Ground Types import Test.QuickCheck.Classes.Enum import Test.QuickCheck.Classes.Eq import Test.QuickCheck.Classes.Integral #if MIN_VERSION_base(4,7,0) import Test.QuickCheck.Classes.IsList #endif import Test.QuickCheck.Classes.Monoid import Test.QuickCheck.Classes.Ord import Test.QuickCheck.Classes.Show import Test.QuickCheck.Classes.ShowRead import Test.QuickCheck.Classes.Storable #if MIN_VERSION_base(4,5,0) import Test.QuickCheck.Classes.Generic #endif -- Unary type constructors #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Alternative #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Alt import Test.QuickCheck.Classes.Apply #endif import Test.QuickCheck.Classes.Applicative import Test.QuickCheck.Classes.Foldable import Test.QuickCheck.Classes.Functor import Test.QuickCheck.Classes.Monad import Test.QuickCheck.Classes.MonadPlus import Test.QuickCheck.Classes.MonadZip #if HAVE_SEMIGROUPOIDS import Test.QuickCheck.Classes.Plus #endif import Test.QuickCheck.Classes.Traversable #endif -- -- used below -- import Test.QuickCheck import Test.QuickCheck.Classes.Common (foldMapA, Laws(..)) import Control.Monad import Data.Foldable import Data.Monoid (Monoid(..)) import Data.Proxy (Proxy(..)) import Data.Semigroup (Semigroup) import System.Exit (exitFailure) import qualified Data.List as List import qualified Data.Semigroup as SG -- | A convenience function for testing properties in GHCi. -- For example, at GHCi: -- -- >>> lawsCheck (monoidLaws (Proxy :: Proxy Ordering)) -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- -- Assuming that the 'Arbitrary' instance for 'Ordering' is good, we now -- have confidence that the 'Monoid' instance for 'Ordering' satisfies -- the monoid laws. lawsCheck :: Laws -> IO () lawsCheck (Laws className properties) = do flip foldMapA properties $ \(name,p) -> do putStr (className ++ ": " ++ name ++ " ") quickCheck p -- | A convenience function that allows one to check many typeclass -- instances of the same type. -- -- >>> specialisedLawsCheckMany (Proxy :: Proxy Word) [jsonLaws, showReadLaws] -- ToJSON/FromJSON: Encoding Equals Value +++ OK, passed 100 tests. -- ToJSON/FromJSON: Partial Isomorphism +++ OK, passed 100 tests. -- Show/Read: Partial Isomorphism +++ OK, passed 100 tests. lawsCheckOne :: Proxy a -> [Proxy a -> Laws] -> IO () lawsCheckOne p ls = foldlMapM (lawsCheck . ($ p)) ls -- | A convenience function for checking multiple typeclass instances -- of multiple types. Consider the following Haskell source file: -- -- @ -- import Data.Proxy (Proxy(..)) -- import Data.Map (Map) -- import Data.Set (Set) -- -- -- A 'Proxy' for 'Set' 'Int'. -- setInt :: Proxy (Set Int) -- setInt = Proxy -- -- -- A 'Proxy' for 'Map' 'Int' 'Int'. -- mapInt :: Proxy (Map Int Int) -- mapInt = Proxy -- -- myLaws :: Proxy a -> [Laws] -- myLaws p = [eqLaws p, monoidLaws p] -- -- namedTests :: [(String, [Laws])] -- namedTests = -- [ ("Set Int", myLaws setInt) -- , ("Map Int Int", myLaws mapInt) -- ] -- @ -- -- Now, in GHCi: -- -- >>> lawsCheckMany namedTests -- -- @ -- Testing properties for common typeclasses -- ------------- -- -- Set Int -- -- ------------- -- -- Eq: Transitive +++ OK, passed 100 tests. -- Eq: Symmetric +++ OK, passed 100 tests. -- Eq: Reflexive +++ OK, passed 100 tests. -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- Monoid: Concatenation +++ OK, passed 100 tests. -- -- ----------------- -- -- Map Int Int -- -- ----------------- -- -- Eq: Transitive +++ OK, passed 100 tests. -- Eq: Symmetric +++ OK, passed 100 tests. -- Eq: Reflexive +++ OK, passed 100 tests. -- Monoid: Associative +++ OK, passed 100 tests. -- Monoid: Left Identity +++ OK, passed 100 tests. -- Monoid: Right Identity +++ OK, passed 100 tests. -- Monoid: Concatenation +++ OK, passed 100 tests. -- @ -- -- In the case of a failing test, the program terminates with -- exit code 1. lawsCheckMany :: [(String,[Laws])] -- ^ Element is type name paired with typeclass laws -> IO () lawsCheckMany xs = do putStrLn "Testing properties for common typeclasses" r <- flip foldMapA xs $ \(typeName,laws) -> do putStrLn $ List.replicate (length typeName + 6) '-' putStrLn $ "-- " ++ typeName ++ " --" putStrLn $ List.replicate (length typeName + 6) '-' flip foldMapA laws $ \(Laws typeClassName properties) -> do flip foldMapA properties $ \(name,p) -> do putStr (typeClassName ++ ": " ++ name ++ " ") r <- quickCheckResult p return $ case r of Success{} -> Good _ -> Bad putStrLn "" case r of Good -> putStrLn "All tests succeeded" Bad -> do putStrLn "One or more tests failed" exitFailure data Status = Bad | Good instance Semigroup Status where Good <> x = x Bad <> _ = Bad instance Monoid Status where mempty = Good mappend = (SG.<>) -- | In older versions of GHC, Proxy is not poly-kinded, -- so we provide Proxy1. data Proxy1 (f :: * -> *) = Proxy1 -- | In older versions of GHC, Proxy is not poly-kinded, -- so we provide Proxy2. data Proxy2 (f :: * -> * -> *) = Proxy2 -- This is used internally to work around a missing Monoid -- instance for IO on older GHCs. foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/0000755000000000000000000000000007346545000020152 5ustar0000000000000000primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Alternative.hs0000644000000000000000000000472107346545000022770 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Alternative ( #if HAVE_UNARY_LAWS alternativeLaws #endif ) where import Control.Applicative (Alternative(..)) import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following alternative properties: -- -- [/Left Identity/] -- @'empty' '<|>' x ≡ x@ -- [/Right Identity/] -- @x '<|>' 'empty' ≡ x@ -- [/Associativity/] -- @a '<|>' (b '<|>' c) ≡ (a '<|>' b) '<|>' c)@ alternativeLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws alternativeLaws p = Laws "Alternative" [ ("Left Identity", alternativeLeftIdentity p) , ("Right Identity", alternativeRightIdentity p) , ("Associativity", alternativeAssociativity p) ] alternativeLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 (empty <|> a) a) alternativeRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeRightIdentity _ = property $ \(Apply (a :: f Integer)) -> (eq1 a (empty <|> a)) alternativeAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Alternative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Alternative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property alternativeAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (a <|> (b <|> c)) ((a <|> b) <|> c) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Applicative.hs0000644000000000000000000000737207346545000022760 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Applicative ( #if HAVE_UNARY_LAWS applicativeLaws #endif ) where import Control.Applicative import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following applicative properties: -- -- [/Identity/] -- @'pure' 'id' '<*>' v ≡ v@ -- [/Composition/] -- @'pure' ('.') '<*>' u '<*>' v '<*>' w ≡ u '<*>' (v '<*>' w)@ -- [/Homomorphism/] -- @'pure' f '<*>' 'pure' x ≡ 'pure' (f x)@ -- [/Interchange/] -- @u '<*>' 'pure' y ≡ 'pure' ('$' y) '<*>' u@ -- [/LiftA2 (1)/] -- @('<*>') ≡ 'liftA2' 'id'@ applicativeLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws applicativeLaws p = Laws "Applicative" [ ("Identity", applicativeIdentity p) , ("Composition", applicativeComposition p) , ("Homomorphism", applicativeHomomorphism p) , ("Interchange", applicativeInterchange p) , ("LiftA2 Part 1", applicativeLiftA2_1 p) -- todo: liftA2 part 2, we need an equation of two variables for this ] applicativeIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (pure id <*> a) a applicativeComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeComposition _ = property $ \(Apply (u' :: f QuadraticEquation)) (Apply (v' :: f QuadraticEquation)) (Apply (w :: f Integer)) -> let u = fmap runQuadraticEquation u' v = fmap runQuadraticEquation v' in eq1 (pure (.) <*> u <*> v <*> w) (u <*> (v <*> w)) applicativeHomomorphism :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a)) #else (Applicative f, Eq1 f, Show1 f) #endif => proxy f -> Property applicativeHomomorphism _ = property $ \(e :: QuadraticEquation) (a :: Integer) -> let f = runQuadraticEquation e in eq1 (pure f <*> pure a) (pure (f a) :: f Integer) applicativeInterchange :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeInterchange _ = property $ \(Apply (u' :: f QuadraticEquation)) (y :: Integer) -> let u = fmap runQuadraticEquation u' in eq1 (u <*> pure y) (pure ($ y) <*> u) applicativeLiftA2_1 :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property applicativeLiftA2_1 _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> let f = fmap runQuadraticEquation f' in eq1 (liftA2 id f x) (f <*> x) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Common.hs0000644000000000000000000003375007346545000021746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Common ( Laws(..) , foldMapA , myForAllShrink -- Modifiers , SmallList(..) , ShowReadPrecedence(..) -- only used for higher-kinded types , Apply(..) , Triple(..) , ChooseFirst(..) , ChooseSecond(..) , LastNothing(..) , Bottom(..) , LinearEquation(..) #if HAVE_UNARY_LAWS , LinearEquationM(..) #endif , QuadraticEquation(..) , LinearEquationTwo(..) #if HAVE_UNARY_LAWS , nestedEq1 , propNestedEq1 --, toSpecialApplicative #endif , flipPair #if HAVE_UNARY_LAWS --, apTrans #endif , func1 , func2 , func3 #if HAVE_UNARY_LAWS --, func4 #endif , func5 , func6 , reverseTriple , runLinearEquation #if HAVE_UNARY_LAWS , runLinearEquationM #endif , runQuadraticEquation , runLinearEquationTwo ) where import Control.Applicative import Control.Monad import Data.Foldable import Data.Traversable import Data.Monoid #if defined(HAVE_UNARY_LAWS) import Data.Functor.Classes (Eq1(..),Show1(..),eq1,showsPrec1) import Data.Functor.Compose #endif import Data.Semigroup (Semigroup) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property(..)) import qualified Control.Monad.Trans.Writer.Lazy as WL import qualified Data.List as L import qualified Data.Monoid as MND import qualified Data.Semigroup as SG --import qualified Data.Set as S -- | A set of laws associated with a typeclass. data Laws = Laws { lawsTypeclass :: String -- ^ Name of the typeclass whose laws are tested , lawsProperties :: [(String,Property)] -- ^ Pairs of law name and property } myForAllShrink :: (Arbitrary a, Show b, Eq b) => Bool -- Should we show the RHS. It's better not to show it -- if the RHS is equal to the input. -> (a -> Bool) -- is the value a valid input -> (a -> [String]) -- show the 'a' values -> String -- show the LHS -> (a -> b) -- the function that makes the LHS -> String -- show the RHS -> (a -> b) -- the function that makes the RHS -> Property myForAllShrink displayRhs isValid showInputs name1 calc1 name2 calc2 = #if MIN_VERSION_QuickCheck(2,9,0) again $ #endif MkProperty $ arbitrary >>= \x -> unProperty $ shrinking shrink x $ \x' -> let b1 = calc1 x' b2 = calc2 x' sb1 = show b1 sb2 = show b2 description = " Description: " ++ name1 ++ " = " ++ name2 err = description ++ "\n" ++ unlines (map (" " ++) (showInputs x')) ++ " " ++ name1 ++ " = " ++ sb1 ++ (if displayRhs then "\n " ++ name2 ++ " = " ++ sb2 else "") in isValid x' ==> counterexample err (b1 == b2) #if HAVE_UNARY_LAWS -- the Functor constraint is needed for transformers-0.4 #if HAVE_QUANTIFIED_CONSTRAINTS nestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a) => f (g a) -> f (g a) -> Bool nestedEq1 = (==) #else nestedEq1 :: (Eq1 f, Eq1 g, Eq a, Functor f) => f (g a) -> f (g a) -> Bool nestedEq1 x y = eq1 (Compose x) (Compose y) #endif #if HAVE_QUANTIFIED_CONSTRAINTS propNestedEq1 :: (forall x. Eq x => Eq (f x), forall x. Eq x => Eq (g x), Eq a, forall x. Show x => Show (f x), forall x. Show x => Show (g x), Show a) => f (g a) -> f (g a) -> Property propNestedEq1 = (===) #else propNestedEq1 :: (Eq1 f, Eq1 g, Eq a, Show1 f, Show1 g, Show a, Functor f) => f (g a) -> f (g a) -> Property propNestedEq1 x y = Compose x === Compose y #endif --toSpecialApplicative :: -- Compose Triple ((,) (S.Set Integer)) Integer -- -> Compose Triple (WL.Writer (S.Set Integer)) Integer --toSpecialApplicative (Compose (Triple a b c)) = -- Compose (Triple (WL.writer (flipPair a)) (WL.writer (flipPair b)) (WL.writer (flipPair c))) #endif flipPair :: (a,b) -> (b,a) flipPair (x,y) = (y,x) #if HAVE_UNARY_LAWS -- Reverse the list and accumulate the writers. We cannot -- use Sum or Product or else it wont actually be a valid -- applicative transformation. --apTrans :: -- Compose Triple (WL.Writer (S.Set Integer)) a -- -> Compose (WL.Writer (S.Set Integer)) Triple a --apTrans (Compose xs) = Compose (sequenceA (reverseTriple xs)) #endif func1 :: Integer -> (Integer,Integer) func1 i = (div (i + 5) 3, i * i - 2 * i + 1) func2 :: (Integer,Integer) -> (Bool,Either Ordering Integer) func2 (a,b) = (odd a, if even a then Left (compare a b) else Right (b + 2)) func3 :: Integer -> SG.Sum Integer func3 i = SG.Sum (3 * i * i - 7 * i + 4) #if HAVE_UNARY_LAWS --func4 :: Integer -> Compose Triple (WL.Writer (S.Set Integer)) Integer --func4 i = Compose $ Triple -- (WL.writer (i * i, S.singleton (i * 7 + 5))) -- (WL.writer (i + 2, S.singleton (i * i + 3))) -- (WL.writer (i * 7, S.singleton 4)) #endif func5 :: Integer -> Triple Integer func5 i = Triple (i + 2) (i * 3) (i * i) func6 :: Integer -> Triple Integer func6 i = Triple (i * i * i) (4 * i - 7) (i * i * i) data Triple a = Triple a a a deriving (Show,Eq) tripleLiftEq :: (a -> b -> Bool) -> Triple a -> Triple b -> Bool tripleLiftEq p (Triple a1 b1 c1) (Triple a2 b2 c2) = p a1 a2 && p b1 b2 && p c1 c2 #if HAVE_UNARY_LAWS instance Eq1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftEq = tripleLiftEq #else eq1 = tripleLiftEq (==) #endif #endif tripleLiftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Triple a -> ShowS tripleLiftShowsPrec elemShowsPrec _ p (Triple a b c) = showParen (p > 10) $ showString "Triple " . elemShowsPrec 11 a . showString " " . elemShowsPrec 11 b . showString " " . elemShowsPrec 11 c #if HAVE_UNARY_LAWS instance Show1 Triple where #if MIN_VERSION_base(4,9,0) || MIN_VERSION_transformers(0,5,0) liftShowsPrec = tripleLiftShowsPrec #else showsPrec1 = tripleLiftShowsPrec showsPrec showList #endif #endif #if HAVE_UNARY_LAWS instance Arbitrary1 Triple where liftArbitrary x = Triple <$> x <*> x <*> x instance Arbitrary a => Arbitrary (Triple a) where arbitrary = liftArbitrary arbitrary #else instance Arbitrary a => Arbitrary (Triple a) where arbitrary = Triple <$> arbitrary <*> arbitrary <*> arbitrary #endif instance Functor Triple where fmap f (Triple a b c) = Triple (f a) (f b) (f c) instance Applicative Triple where pure a = Triple a a a Triple f g h <*> Triple a b c = Triple (f a) (g b) (h c) instance Foldable Triple where foldMap f (Triple a b c) = f a MND.<> f b MND.<> f c instance Traversable Triple where traverse f (Triple a b c) = Triple <$> f a <*> f b <*> f c reverseTriple :: Triple a -> Triple a reverseTriple (Triple a b c) = Triple c b a data ChooseSecond = ChooseSecond deriving (Eq) data ChooseFirst = ChooseFirst deriving (Eq) data LastNothing = LastNothing deriving (Eq) data Bottom a = BottomUndefined | BottomValue a deriving (Eq) instance Show ChooseFirst where show ChooseFirst = "\\a b -> if even a then a else b" instance Show ChooseSecond where show ChooseSecond = "\\a b -> if even b then a else b" instance Show LastNothing where show LastNothing = "0" instance Show a => Show (Bottom a) where show x = case x of BottomUndefined -> "undefined" BottomValue a -> show a instance Arbitrary ChooseSecond where arbitrary = pure ChooseSecond instance Arbitrary ChooseFirst where arbitrary = pure ChooseFirst instance Arbitrary LastNothing where arbitrary = pure LastNothing instance Arbitrary a => Arbitrary (Bottom a) where arbitrary = fmap maybeToBottom arbitrary shrink x = map maybeToBottom (shrink (bottomToMaybe x)) bottomToMaybe :: Bottom a -> Maybe a bottomToMaybe BottomUndefined = Nothing bottomToMaybe (BottomValue a) = Just a maybeToBottom :: Maybe a -> Bottom a maybeToBottom Nothing = BottomUndefined maybeToBottom (Just a) = BottomValue a newtype Apply f a = Apply { getApply :: f a } instance (Applicative f, Monoid a) => Semigroup (Apply f a) where Apply x <> Apply y = Apply $ liftA2 mappend x y instance (Applicative f, Monoid a) => Monoid (Apply f a) where mempty = Apply $ pure mempty mappend = (SG.<>) #if HAVE_UNARY_LAWS #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (f x), Eq a) => Eq (Apply f a) deriving instance (forall x. Arbitrary x => Arbitrary (f x), Arbitrary a) => Arbitrary (Apply f a) deriving instance (forall x. Show x => Show (f x), Show a) => Show (Apply f a) #else instance (Eq1 f, Eq a) => Eq (Apply f a) where Apply a == Apply b = eq1 a b -- This show instance is intentionally a little bit wrong. -- We don't wrap the result in Apply since the end user -- should not be made aware of the Apply wrapper anyway. instance (Show1 f, Show a) => Show (Apply f a) where showsPrec p = showsPrec1 p . getApply instance (Arbitrary1 f, Arbitrary a) => Arbitrary (Apply f a) where arbitrary = fmap Apply arbitrary1 shrink = map Apply . shrink1 . getApply #endif #endif foldMapA :: (Foldable t, Monoid m, Semigroup m, Applicative f) => (a -> f m) -> t a -> f m foldMapA f = getApply . foldMap (Apply . f) data LinearEquation = LinearEquation { _linearEquationLinear :: Integer , _linearEquationConstant :: Integer } deriving (Eq) instance Show LinearEquation where showsPrec = showLinear showList = showLinearList runLinearEquation :: LinearEquation -> Integer -> Integer runLinearEquation (LinearEquation a b) x = a * x + b showLinear :: Int -> LinearEquation -> ShowS showLinear _ (LinearEquation a b) = shows a . showString " * x + " . shows b showLinearList :: [LinearEquation] -> ShowS showLinearList xs = SG.appEndo $ mconcat $ [SG.Endo (showChar '[')] ++ L.intersperse (SG.Endo (showChar ',')) (map (SG.Endo . showLinear 0) xs) ++ [SG.Endo (showChar ']')] #if HAVE_UNARY_LAWS data LinearEquationM m = LinearEquationM (m LinearEquation) (m LinearEquation) runLinearEquationM :: Monad m => LinearEquationM m -> Integer -> m Integer runLinearEquationM (LinearEquationM e1 e2) i = if odd i then liftM (flip runLinearEquation i) e1 else liftM (flip runLinearEquation i) e2 #if HAVE_QUANTIFIED_CONSTRAINTS deriving instance (forall x. Eq x => Eq (m x)) => Eq (LinearEquationM m) instance (forall a. Show a => Show (m a)) => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec 0 a . showString " else " . showsPrec 0 b instance (forall a. Arbitrary a => Arbitrary (m a)) => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary arbitrary shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink a) , map (\x -> LinearEquationM a x) (shrink b) ] #else instance Eq1 m => Eq (LinearEquationM m) where LinearEquationM a1 b1 == LinearEquationM a2 b2 = eq1 a1 a2 && eq1 b1 b2 instance Show1 m => Show (LinearEquationM m) where show (LinearEquationM a b) = (\f -> f "") $ showString "\\x -> if odd x then " . showsPrec1 0 a . showString " else " . showsPrec1 0 b instance Arbitrary1 m => Arbitrary (LinearEquationM m) where arbitrary = liftA2 LinearEquationM arbitrary1 arbitrary1 shrink (LinearEquationM a b) = L.concat [ map (\x -> LinearEquationM x b) (shrink1 a) , map (\x -> LinearEquationM a x) (shrink1 b) ] #endif #endif instance Arbitrary LinearEquation where arbitrary = do (a,b) <- arbitrary return (LinearEquation (abs a) (abs b)) shrink (LinearEquation a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquation (abs x) (abs y)) xs -- this is a quadratic equation data QuadraticEquation = QuadraticEquation { _quadraticEquationQuadratic :: Integer , _quadraticEquationLinear :: Integer , _quadraticEquationConstant :: Integer } deriving (Eq) -- This show instance is does not actually provide a -- way to create an equation. Instead, it makes it look -- like a lambda. instance Show QuadraticEquation where show (QuadraticEquation a b c) = "\\x -> " ++ show a ++ " * x ^ 2 + " ++ show b ++ " * x + " ++ show c instance Arbitrary QuadraticEquation where arbitrary = do (a,b,c) <- arbitrary return (QuadraticEquation (abs a) (abs b) (abs c)) shrink (QuadraticEquation a b c) = let xs = shrink (a,b,c) in map (\(x,y,z) -> QuadraticEquation (abs x) (abs y) (abs z)) xs runQuadraticEquation :: QuadraticEquation -> Integer -> Integer runQuadraticEquation (QuadraticEquation a b c) x = a * x ^ (2 :: Integer) + b * x + c data LinearEquationTwo = LinearEquationTwo { _linearEquationTwoX :: Integer , _linearEquationTwoY :: Integer } deriving (Eq) -- This show instance does not actually provide a -- way to create a LinearEquationTwo. Instead, it makes it look -- like a lambda that takes two variables. instance Show LinearEquationTwo where show (LinearEquationTwo a b) = "\\x y -> " ++ show a ++ " * x + " ++ show b ++ " * y" instance Arbitrary LinearEquationTwo where arbitrary = do (a,b) <- arbitrary return (LinearEquationTwo (abs a) (abs b)) shrink (LinearEquationTwo a b) = let xs = shrink (a,b) in map (\(x,y) -> LinearEquationTwo (abs x) (abs y)) xs runLinearEquationTwo :: LinearEquationTwo -> Integer -> Integer -> Integer runLinearEquationTwo (LinearEquationTwo a b) x y = a * x + b * y newtype SmallList a = SmallList { getSmallList :: [a] } deriving (Eq,Show) instance Arbitrary a => Arbitrary (SmallList a) where arbitrary = do n <- choose (0,6) xs <- vector n return (SmallList xs) shrink = map SmallList . shrink . getSmallList -- Haskell uses the operator precedences 0..9, the special function application -- precedence 10 and the precedence 11 for function arguments. Both show and -- read instances have to accept this range. According to the Haskell Language -- Report, the output of derived show instances in precedence context 11 has to -- be an atomic expression. showReadPrecedences :: [Int] showReadPrecedences = [0..11] newtype ShowReadPrecedence = ShowReadPrecedence Int deriving (Eq,Ord,Show) instance Arbitrary ShowReadPrecedence where arbitrary = ShowReadPrecedence <$> elements showReadPrecedences shrink (ShowReadPrecedence p) = [ ShowReadPrecedence p' | p' <- showReadPrecedences, p' < p ] primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Compat.hs0000644000000000000000000000223607346545000021734 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif module Test.QuickCheck.Classes.Compat ( isTrue# , eq1 , readMaybe ) where #if MIN_VERSION_base(4,6,0) import Text.Read (readMaybe) #else import Text.ParserCombinators.ReadP (skipSpaces) import Text.ParserCombinators.ReadPrec (lift, minPrec, readPrec_to_S) import Text.Read (readPrec) #endif #if MIN_VERSION_base(4,7,0) import GHC.Exts (isTrue#) #endif import qualified Data.Functor.Classes as C #if !MIN_VERSION_base(4,6,0) readMaybe :: Read a => String -> Maybe a readMaybe s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of [x] -> Just x _ -> Nothing where read' = do x <- readPrec lift skipSpaces return x #endif #if !MIN_VERSION_base(4,7,0) isTrue# :: Bool -> Bool isTrue# b = b #endif #if HAVE_QUANTIFIED_CONSTRAINTS eq1 :: (forall a. Eq a => Eq (f a), Eq a) => f a -> f a -> Bool eq1 = (==) #else eq1 :: (C.Eq1 f, Eq a) => f a -> f a -> Bool #if !(MIN_VERSION_transformers(0,5,0)) -- checking for transformers 0.4 by another name eq1 = C.eq1 #else eq1 = C.liftEq (==) #endif #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Enum.hs0000644000000000000000000000476407346545000021425 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Enum ( enumLaws , boundedEnumLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Succ Pred Identity/] -- @'succ' ('pred' x) ≡ x@ -- [/Pred Succ Identity/] -- @'pred' ('succ' x) ≡ x@ -- -- This only works for @Enum@ types that are not bounded, meaning -- that 'succ' and 'pred' must be total. This means that these property -- tests work correctly for types like 'Integer' but not for 'Int'. -- -- Sadly, there is not a good way to test 'fromEnum' and 'toEnum', -- since many types that have reasonable implementations for 'succ' -- and 'pred' have more inhabitants than 'Int' does. enumLaws :: (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws enumLaws p = Laws "Enum" [ ("Succ Pred Identity", succPredIdentity p) , ("Pred Succ Identity", predSuccIdentity p) ] -- | Tests the same properties as 'enumLaws' except that it requires -- the type to have a 'Bounded' instance. These tests avoid taking the -- successor of the maximum element or the predecessor of the minimal -- element. boundedEnumLaws :: (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws boundedEnumLaws p = Laws "Enum" [ ("Succ Pred Identity", succPredBoundedIdentity p) , ("Pred Succ Identity", predSuccBoundedIdentity p) ] succPredIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property succPredIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "succ (pred x)" (\a -> succ (pred a)) "x" (\a -> a) predSuccIdentity :: forall a. (Enum a, Eq a, Arbitrary a, Show a) => Proxy a -> Property predSuccIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "pred (succ x)" (\a -> pred (succ a)) "x" (\a -> a) succPredBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property succPredBoundedIdentity _ = myForAllShrink False (\a -> a /= minBound) (\(a :: a) -> ["a = " ++ show a]) "succ (pred x)" (\a -> succ (pred a)) "x" (\a -> a) predSuccBoundedIdentity :: forall a. (Enum a, Bounded a, Eq a, Arbitrary a, Show a) => Proxy a -> Property predSuccBoundedIdentity _ = myForAllShrink False (\a -> a /= maxBound) (\(a :: a) -> ["a = " ++ show a]) "pred (succ x)" (\a -> pred (succ a)) "x" (\a -> a) primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Eq.hs0000644000000000000000000000265307346545000021061 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Eq ( eqLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..)) -- | Tests the following properties: -- -- [/Transitive/] -- @a == b ∧ b == c ⇒ a == c@ -- [/Symmetric/] -- @a == b ⇒ b == a@ -- [/Reflexive/] -- @a == a@ -- -- Some of these properties involve implication. In the case that -- the left hand side of the implication arrow does not hold, we -- do not retry. Consequently, these properties only end up being -- useful when the data type has a small number of inhabitants. eqLaws :: (Eq a, Arbitrary a, Show a) => Proxy a -> Laws eqLaws p = Laws "Eq" [ ("Transitive", eqTransitive p) , ("Symmetric", eqSymmetric p) , ("Reflexive", eqReflexive p) ] eqTransitive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqTransitive _ = property $ \(a :: a) b c -> case a == b of True -> case b == c of True -> a == c False -> a /= c False -> case b == c of True -> a /= c False -> True eqSymmetric :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqSymmetric _ = property $ \(a :: a) b -> case a == b of True -> b == a False -> b /= a eqReflexive :: forall a. (Show a, Eq a, Arbitrary a) => Proxy a -> Property eqReflexive _ = property $ \(a :: a) -> a == a primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Foldable.hs0000644000000000000000000001434307346545000022223 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Foldable ( #if HAVE_UNARY_LAWS foldableLaws #endif ) where import Data.Monoid import Data.Foldable import Test.QuickCheck hiding ((.&.)) import Control.Exception (ErrorCall,try,evaluate) import Control.Monad.Trans.Class (lift) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) #endif import Test.QuickCheck.Monadic (monadicIO) #if HAVE_UNARY_LAWS import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import qualified Data.Foldable as F import qualified Data.Semigroup as SG import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following 'Foldable' properties: -- -- [/fold/] -- @'fold' ≡ 'foldMap' 'id'@ -- [/foldMap/] -- @'foldMap' f ≡ 'foldr' ('mappend' . f) 'mempty'@ -- [/foldr/] -- @'foldr' f z t ≡ 'appEndo' ('foldMap' ('Endo' . f) t ) z@ -- [/foldr'/] -- @'foldr'' f z0 xs ≡ let f\' k x z = k '$!' f x z in 'foldl' f\' 'id' xs z0@ -- [/foldr1/] -- @'foldr1' f t ≡ let 'Just' (xs,x) = 'unsnoc' ('toList' t) in 'foldr' f x xs@ -- [/foldl/] -- @'foldl' f z t ≡ 'appEndo' ('getDual' ('foldMap' ('Dual' . 'Endo' . 'flip' f) t)) z@ -- [/foldl'/] -- @'foldl'' f z0 xs ≡ let f' x k z = k '$!' f z x in 'foldr' f\' 'id' xs z0@ -- [/foldl1/] -- @'foldl1' f t ≡ let x : xs = 'toList' t in 'foldl' f x xs@ -- [/toList/] -- @'F.toList' ≡ 'foldr' (:) []@ -- [/null/] -- @'null' ≡ 'foldr' ('const' ('const' 'False')) 'True'@ -- [/length/] -- @'length' ≡ 'getSum' . 'foldMap' ('const' ('Sum' 1))@ -- -- Note that this checks to ensure that @foldl\'@ and @foldr\'@ -- are suitably strict. foldableLaws :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws foldableLaws = foldableLawsInternal foldableLawsInternal :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws foldableLawsInternal p = Laws "Foldable" [ (,) "fold" $ property $ \(Apply (a :: f (SG.Sum Integer))) -> F.fold a == F.foldMap id a , (,) "foldMap" $ property $ \(Apply (a :: f Integer)) (e :: QuadraticEquation) -> let f = SG.Sum . runQuadraticEquation e in F.foldMap f a == F.foldr (mappend . f) mempty a , (,) "foldr" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> let f = runLinearEquationTwo e in F.foldr f z t == SG.appEndo (foldMap (SG.Endo . f) t) z , (,) "foldr'" (foldableFoldr' p) , (,) "foldl" $ property $ \(e :: LinearEquationTwo) (z :: Integer) (Apply (t :: f Integer)) -> let f = runLinearEquationTwo e in F.foldl f z t == SG.appEndo (SG.getDual (F.foldMap (SG.Dual . SG.Endo . flip f) t)) z , (,) "foldl'" (foldableFoldl' p) , (,) "foldl1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> case compatToList t of [] -> True x : xs -> let f = runLinearEquationTwo e in F.foldl1 f t == F.foldl f x xs , (,) "foldr1" $ property $ \(e :: LinearEquationTwo) (Apply (t :: f Integer)) -> case unsnoc (compatToList t) of Nothing -> True Just (xs,x) -> let f = runLinearEquationTwo e in F.foldr1 f t == F.foldr f x xs , (,) "toList" $ property $ \(Apply (t :: f Integer)) -> eq1 (F.toList t) (F.foldr (:) [] t) #if MIN_VERSION_base(4,8,0) , (,) "null" $ property $ \(Apply (t :: f Integer)) -> null t == F.foldr (const (const False)) True t , (,) "length" $ property $ \(Apply (t :: f Integer)) -> F.length t == SG.getSum (F.foldMap (const (SG.Sum 1)) t) #endif ] unsnoc :: [a] -> Maybe ([a],a) unsnoc [] = Nothing unsnoc [x] = Just ([],x) unsnoc (x:y:xs) = fmap (\(bs,b) -> (x:bs,b)) (unsnoc (y : xs)) compatToList :: Foldable f => f a -> [a] compatToList = foldMap (\x -> [x]) foldableFoldl' :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property foldableFoldl' _ = property $ \(_ :: ChooseSecond) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> monadicIO $ do let f :: Integer -> Bottom Integer -> Integer f a b = case b of BottomUndefined -> error "foldableFoldl' example" BottomValue v -> if even v then a else v z0 = 0 r1 <- lift $ do let f' x k z = k $! f z x e <- try (evaluate (F.foldr f' id xs z0)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) r2 <- lift $ do e <- try (evaluate (F.foldl' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) return (r1 == r2) foldableFoldr' :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Foldable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Foldable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property foldableFoldr' _ = property $ \(_ :: ChooseFirst) (_ :: LastNothing) (Apply (xs :: f (Bottom Integer))) -> monadicIO $ do let f :: Bottom Integer -> Integer -> Integer f a b = case a of BottomUndefined -> error "foldableFoldl' example" BottomValue v -> if even v then v else b z0 = 0 r1 <- lift $ do let f' k x z = k $! f x z e <- try (evaluate (F.foldl f' id xs z0)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) r2 <- lift $ do e <- try (evaluate (F.foldr' f z0 xs)) case e of Left (_ :: ErrorCall) -> return Nothing Right i -> return (Just i) return (r1 == r2) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Functor.hs0000644000000000000000000000450407346545000022131 0ustar0000000000000000{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Functor ( #if HAVE_UNARY_LAWS functorLaws #endif ) where import Data.Functor import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following functor properties: -- -- [/Identity/] -- @'fmap' 'id' ≡ 'id'@ -- [/Composition/] -- @'fmap' (f '.' g) ≡ 'fmap' f '.' 'fmap' g@ -- [/Const/] -- @('<$') ≡ 'fmap' 'const'@ functorLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws functorLaws p = Laws "Functor" [ ("Identity", functorIdentity p) , ("Composition", functorComposition p) , ("Const", functorConst p) ] functorIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap id a) a functorComposition :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorComposition _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap func2 (fmap func1 a)) (fmap (func2 . func1) a) functorConst :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property functorConst _ = property $ \(Apply (a :: f Integer)) -> eq1 (fmap (const 'X') a) ('X' <$ a) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Generic.hs0000644000000000000000000000701607346545000022066 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Generic ( #if MIN_VERSION_base(4,5,0) genericLaws #if HAVE_UNARY_LAWS , generic1Laws #endif #endif ) where #if MIN_VERSION_base(4,5,0) import Control.Applicative import Data.Semigroup as SG import Data.Monoid as MD import GHC.Generics #if HAVE_UNARY_LAWS import Data.Functor.Classes #endif import Data.Proxy (Proxy(Proxy)) import Test.QuickCheck import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..), Apply(..)) -- | Tests the following properties: -- -- [/From-To Inverse/] -- @'from' '.' 'to' ≡ 'id'@ -- [/To-From Inverse/] -- @'to' '.' 'from' ≡ 'id'@ -- -- /Note:/ This property test is only available when -- using @base-4.5@ or newer. -- -- /Note:/ 'from' and 'to' don't actually care about -- the type variable @x@ in @'Rep' a x@, so here we instantiate -- it to @'()'@ by default. If you would like to instantiate @x@ -- as something else, please file a bug report. genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws genericLaws pa = Laws "Generic" [ ("From-To inverse", fromToInverse pa (Proxy :: Proxy ())) , ("To-From inverse", toFromInverse pa) ] toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property toFromInverse _ = property $ \(v :: a) -> (to . from $ v) == v fromToInverse :: forall proxy a x. (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x)) => proxy a -> proxy x -> Property fromToInverse _ _ = property $ \(r :: Rep a x) -> r == (from (to r :: a)) #if HAVE_UNARY_LAWS -- | Tests the following properties: -- -- [/From-To Inverse/] -- @'from1' '.' 'to1' ≡ 'id'@ -- [/To-From Inverse/] -- @'to1' '.' 'from1' ≡ 'id'@ -- -- /Note:/ This property test is only available when -- using @base-4.9@ or newer. generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f)) => proxy f -> Laws generic1Laws p = Laws "Generic1" [ ("From1-To1 inverse", fromToInverse1 p) , ("To1-From1 inverse", toFromInverse1 p) ] -- hack for quantified constraints: under base >= 4.12, -- our usual 'Apply' wrapper has Eq, Show, and Arbitrary -- instances that are incompatible. newtype GApply f a = GApply { getGApply :: f a } instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where GApply x <> GApply y = GApply $ liftA2 (SG.<>) x y instance (Applicative f, Monoid a) => Monoid (GApply f a) where mempty = GApply $ pure mempty mappend (GApply x) (GApply y) = GApply $ liftA2 (MD.<>) x y instance (Eq1 f, Eq a) => Eq (GApply f a) where GApply a == GApply b = eq1 a b instance (Show1 f, Show a) => Show (GApply f a) where showsPrec p = showsPrec1 p . getGApply instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where arbitrary = fmap GApply arbitrary1 shrink = map GApply . shrink1 . getGApply toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property toFromInverse1 _ = property $ \(GApply (v :: f Integer)) -> eq1 v (to1 . from1 $ v) fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property fromToInverse1 _ = property $ \(GApply (r :: Rep1 f Integer)) -> eq1 r (from1 ((to1 $ r) :: f Integer)) #endif #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Integral.hs0000644000000000000000000000326507346545000022261 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Integral ( integralLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Quotient Remainder/] -- @(quot x y) * y + (rem x y) ≡ x@ -- [/Division Modulus/] -- @(div x y) * y + (mod x y) ≡ x@ -- [/Integer Roundtrip/] -- @fromInteger (toInteger x) ≡ x@ integralLaws :: (Integral a, Arbitrary a, Show a) => Proxy a -> Laws integralLaws p = Laws "Integral" [ ("Quotient Remainder", integralQuotientRemainder p) , ("Division Modulus", integralDivisionModulus p) , ("Integer Roundtrip", integralIntegerRoundtrip p) ] integralQuotientRemainder :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralQuotientRemainder _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "(quot x y) * y + (rem x y)" (\(x,y) -> (quot x y) * y + (rem x y)) "x" (\(x,_) -> x) integralDivisionModulus :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralDivisionModulus _ = myForAllShrink False (\(_,y) -> y /= 0) (\(x :: a, y) -> ["x = " ++ show x, "y = " ++ show y]) "(div x y) * y + (mod x y)" (\(x,y) -> (div x y) * y + (mod x y)) "x" (\(x,_) -> x) integralIntegerRoundtrip :: forall a. (Integral a, Arbitrary a, Show a) => Proxy a -> Property integralIntegerRoundtrip _ = myForAllShrink False (const True) (\(x :: a) -> ["x = " ++ show x]) "fromInteger (toInteger x)" (\x -> fromInteger (toInteger x)) "x" (\x -> x) primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/IsList.hs0000644000000000000000000002334307346545000021722 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wall #-} {-| This module provides property tests for functions that operate on list-like data types. If your data type is fully polymorphic in its element type, is it recommended that you use @foldableLaws@ and @traversableLaws@ from @Test.QuickCheck.Classes@. However, if your list-like data type is either monomorphic in its element type (like @Text@ or @ByteString@) or if it requires a typeclass constraint on its element (like @Data.Vector.Unboxed@), the properties provided here can be helpful for testing that your functions have the expected behavior. All properties in this module require your data type to have an 'IsList' instance. -} module Test.QuickCheck.Classes.IsList ( #if MIN_VERSION_base(4,7,0) isListLaws , foldrProp , foldlProp , foldlMProp , mapProp , imapProp , imapMProp , traverseProp , generateProp , generateMProp , replicateProp , replicateMProp , filterProp , filterMProp , mapMaybeProp , mapMaybeMProp #endif ) where #if MIN_VERSION_base(4,7,0) import Control.Applicative import Control.Monad.ST (ST,runST) import Control.Monad (mapM,filterM,replicateM) import Control.Applicative (liftA2) import GHC.Exts (IsList,Item,toList,fromList,fromListN) import Data.Maybe (mapMaybe,catMaybes) import Data.Proxy (Proxy) import Data.Foldable (foldlM) import Data.Traversable (traverse) import Test.QuickCheck (Property,Arbitrary,CoArbitrary,(===),property, NonNegative(..)) #if MIN_VERSION_QuickCheck(2,10,0) import Test.QuickCheck.Function (Function,Fun,applyFun,applyFun2) #else import Test.QuickCheck.Function (Function,Fun,apply) #endif import qualified Data.List as L import Test.QuickCheck.Classes.Common (Laws(..), myForAllShrink) -- | Tests the following properties: -- -- [/Partial Isomorphism/] -- @fromList . toList ≡ id@ -- [/Length Preservation/] -- @fromList xs ≡ fromListN (length xs) xs@ -- -- /Note:/ This property test is only available when -- using @base-4.7@ or newer. isListLaws :: (IsList a, Show a, Show (Item a), Arbitrary a, Arbitrary (Item a), Eq a) => Proxy a -> Laws isListLaws p = Laws "IsList" [ ("Partial Isomorphism", isListPartialIsomorphism p) , ("Length Preservation", isListLengthPreservation p) ] isListPartialIsomorphism :: forall a. (IsList a, Show a, Arbitrary a, Eq a) => Proxy a -> Property isListPartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "fromList (toList a)" (\a -> fromList (toList a)) "a" (\a -> a) isListLengthPreservation :: forall a. (IsList a, Show (Item a), Arbitrary (Item a), Eq a) => Proxy a -> Property isListLengthPreservation _ = property $ \(xs :: [Item a]) -> (fromList xs :: a) == fromListN (length xs) xs foldrProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall b. (a -> b -> b) -> b -> c -> b) -- ^ foldr function -> Property foldrProp _ f = property $ \c (b0 :: Integer) func -> let g = applyFun2 func in L.foldr g b0 (toList c) === f g b0 c foldlProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall b. (b -> a -> b) -> b -> c -> b) -- ^ foldl function -> Property foldlProp _ f = property $ \c (b0 :: Integer) func -> let g = applyFun2 func in L.foldl g b0 (toList c) === f g b0 c foldlMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> (forall s b. (b -> a -> ST s b) -> b -> c -> ST s b) -- ^ monadic foldl function -> Property foldlMProp _ f = property $ \c (b0 :: Integer) func -> runST (foldlM (stApplyFun2 func) b0 (toList c)) === runST (f (stApplyFun2 func) b0 c) mapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((a -> b) -> c -> d) -- ^ map function -> Property mapProp _ _ f = property $ \c func -> fromList (map (applyFun func) (toList c)) === f (applyFun func) c imapProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((Int -> a -> b) -> c -> d) -- ^ indexed map function -> Property imapProp _ _ f = property $ \c func -> fromList (imapList (applyFun2 func) (toList c)) === f (applyFun2 func) c imapMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (Int -> a -> ST s b) -> c -> ST s d) -- ^ monadic indexed map function -> Property imapMProp _ _ f = property $ \c func -> fromList (runST (imapMList (stApplyFun2 func) (toList c))) === runST (f (stApplyFun2 func) c) traverseProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (a -> ST s b) -> c -> ST s d) -- ^ traverse function -> Property traverseProp _ _ f = property $ \c func -> fromList (runST (mapM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) -- | Property for the @generate@ function, which builds a container -- of a given length by applying a function to each index. generateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (Int -> (Int -> a) -> c) -- generate function -> Property generateProp _ f = property $ \(NonNegative len) func -> fromList (generateList len (applyFun func)) === f len (applyFun func) generateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (forall s. Int -> (Int -> ST s a) -> ST s c) -- monadic generate function -> Property generateMProp _ f = property $ \(NonNegative len) func -> fromList (runST (stGenerateList len (stApplyFun func))) === runST (f len (stApplyFun func)) replicateProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (Int -> a -> c) -- replicate function -> Property replicateProp _ f = property $ \(NonNegative len) a -> fromList (replicate len a) === f len a replicateMProp :: (Item c ~ a, Eq c, Show c, IsList c, Arbitrary a, Show a) => Proxy a -- ^ input element type -> (forall s. Int -> ST s a -> ST s c) -- replicate function -> Property replicateMProp _ f = property $ \(NonNegative len) a -> fromList (runST (replicateM len (return a))) === runST (f len (return a)) -- | Property for the @filter@ function, which keeps elements for which -- the predicate holds true. filterProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ element type -> ((a -> Bool) -> c -> c) -- ^ map function -> Property filterProp _ f = property $ \c func -> fromList (filter (applyFun func) (toList c)) === f (applyFun func) c -- | Property for the @filterM@ function, which keeps elements for which -- the predicate holds true in an applicative context. filterMProp :: (IsList c, Item c ~ a, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ element type -> (forall s. (a -> ST s Bool) -> c -> ST s c) -- ^ traverse function -> Property filterMProp _ f = property $ \c func -> fromList (runST (filterM (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) -- | Property for the @mapMaybe@ function, which keeps elements for which -- the predicate holds true. mapMaybeProp :: (IsList c, Item c ~ a, Item d ~ b, Eq d, IsList d, Arbitrary b, Show d, Show b, Arbitrary c, Show c, Show a, Eq c, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> ((a -> Maybe b) -> c -> d) -- ^ map function -> Property mapMaybeProp _ _ f = property $ \c func -> fromList (mapMaybe (applyFun func) (toList c)) === f (applyFun func) c mapMaybeMProp :: (IsList c, IsList d, Eq d, Show d, Show b, Item c ~ a, Item d ~ b, Arbitrary c, Arbitrary b, Show c, Show a, CoArbitrary a, Function a) => Proxy a -- ^ input element type -> Proxy b -- ^ output element type -> (forall s. (a -> ST s (Maybe b)) -> c -> ST s d) -- ^ traverse function -> Property mapMaybeMProp _ _ f = property $ \c func -> fromList (runST (mapMaybeMList (return . applyFun func) (toList c))) === runST (f (return . applyFun func) c) imapList :: (Int -> a -> b) -> [a] -> [b] imapList f xs = map (uncurry f) (zip (enumFrom 0) xs) imapMList :: (Int -> a -> ST s b) -> [a] -> ST s [b] imapMList f = go 0 where go !_ [] = return [] go !ix (x : xs) = liftA2 (:) (f ix x) (go (ix + 1) xs) mapMaybeMList :: Applicative f => (a -> f (Maybe b)) -> [a] -> f [b] mapMaybeMList f = fmap catMaybes . traverse f generateList :: Int -> (Int -> a) -> [a] generateList len f = go 0 where go !ix = if ix < len then f ix : go (ix + 1) else [] stGenerateList :: Int -> (Int -> ST s a) -> ST s [a] stGenerateList len f = go 0 where go !ix = if ix < len then liftA2 (:) (f ix) (go (ix + 1)) else return [] stApplyFun :: Fun a b -> a -> ST s b stApplyFun f a = return (applyFun f a) stApplyFun2 :: Fun (a,b) c -> a -> b -> ST s c stApplyFun2 f a b = return (applyFun2 f a b) #if !MIN_VERSION_QuickCheck(2,10,0) applyFun :: Fun a b -> (a -> b) applyFun = apply applyFun2 :: Fun (a, b) c -> (a -> b -> c) applyFun2 = curry . apply #endif #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Monad.hs0000644000000000000000000000674107346545000021554 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Monad ( #if HAVE_UNARY_LAWS monadLaws #endif ) where import Control.Applicative import Test.QuickCheck hiding ((.&.)) import Control.Monad (ap) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following monadic properties: -- -- [/Left Identity/] -- @'return' a '>>=' k ≡ k a@ -- [/Right Identity/] -- @m '>>=' 'return' ≡ m@ -- [/Associativity/] -- @m '>>=' (\\x -> k x '>>=' h) ≡ (m '>>=' k) '>>=' h@ -- [/Return/] -- @'pure' ≡ 'return'@ -- [/Ap/] -- @('<*>') ≡ 'ap'@ monadLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadLaws p = Laws "Monad" [ ("Left Identity", monadLeftIdentity p) , ("Right Identity", monadRightIdentity p) , ("Associativity", monadAssociativity p) , ("Return", monadReturn p) , ("Ap", monadAp p) ] monadLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadLeftIdentity _ = property $ \(k' :: LinearEquationM f) (a :: Integer) -> let k = runLinearEquationM k' in eq1 (return a >>= k) (k a) monadRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadRightIdentity _ = property $ \(Apply (m :: f Integer)) -> eq1 (m >>= return) m monadAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Functor f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadAssociativity _ = property $ \(Apply (m :: f Integer)) (k' :: LinearEquationM f) (h' :: LinearEquationM f) -> let k = runLinearEquationM k' h = runLinearEquationM h' in eq1 (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h) monadReturn :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadReturn _ = property $ \(x :: Integer) -> eq1 (return x) (pure x :: f Integer) monadAp :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Monad f, Applicative f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Monad f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadAp _ = property $ \(Apply (f' :: f QuadraticEquation)) (Apply (x :: f Integer)) -> let f = fmap runQuadraticEquation f' in eq1 (ap f x) (f <*> x) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/MonadPlus.hs0000644000000000000000000000654307346545000022420 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.MonadPlus ( #if HAVE_UNARY_LAWS monadPlusLaws #endif ) where import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif import Control.Monad (MonadPlus(mzero,mplus)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif #if HAVE_UNARY_LAWS -- | Tests the following monad plus properties: -- -- [/Left Identity/] -- @'mplus' 'mzero' x ≡ x@ -- [/Right Identity/] -- @'mplus' x 'mzero' ≡ x@ -- [/Associativity/] -- @'mplus' a ('mplus' b c) ≡ 'mplus' ('mplus' a b) c)@ -- [/Left Zero/] -- @'mzero' '>>=' f ≡ 'mzero'@ -- [/Right Zero/] -- @m '>>' 'mzero' ≡ 'mzero'@ monadPlusLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadPlusLaws p = Laws "MonadPlus" [ ("Left Identity", monadPlusLeftIdentity p) , ("Right Identity", monadPlusRightIdentity p) , ("Associativity", monadPlusAssociativity p) , ("Left Zero", monadPlusLeftZero p) , ("Right Zero", monadPlusRightZero p) ] monadPlusLeftIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusLeftIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus mzero a) a monadPlusRightIdentity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusRightIdentity _ = property $ \(Apply (a :: f Integer)) -> eq1 (mplus a mzero) a monadPlusAssociativity :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusAssociativity _ = property $ \(Apply (a :: f Integer)) (Apply (b :: f Integer)) (Apply (c :: f Integer)) -> eq1 (mplus a (mplus b c)) (mplus (mplus a b) c) monadPlusLeftZero :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusLeftZero _ = property $ \(k' :: LinearEquationM f) -> eq1 (mzero >>= runLinearEquationM k') mzero monadPlusRightZero :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadPlus f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadPlus f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadPlusRightZero _ = property $ \(Apply (a :: f Integer)) -> eq1 (a >> (mzero :: f Integer)) mzero #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/MonadZip.hs0000644000000000000000000000352307346545000022232 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.MonadZip ( #if HAVE_UNARY_LAWS monadZipLaws #endif ) where import Control.Applicative import Control.Arrow (Arrow(..)) import Control.Monad.Zip (MonadZip(mzip)) import Test.QuickCheck hiding ((.&.)) import Control.Monad (liftM) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following monadic zipping properties: -- -- [/Naturality/] -- @'liftM' (f '***' g) ('mzip' ma mb) = 'mzip' ('liftM' f ma) ('liftM' g mb)@ -- -- In the laws above, the infix function @'***'@ refers to a typeclass -- method of 'Arrow'. monadZipLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadZip f, Applicative f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws monadZipLaws p = Laws "MonadZip" [ ("Naturality", monadZipNaturality p) ] monadZipNaturality :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (MonadZip f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (MonadZip f, Functor f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Property monadZipNaturality _ = property $ \(f' :: LinearEquation) (g' :: LinearEquation) (Apply (ma :: f Integer)) (Apply (mb :: f Integer)) -> let f = runLinearEquation f' g = runLinearEquation g' in eq1 (liftM (f *** g) (mzip ma mb)) (mzip (liftM f ma) (liftM g mb)) #endif primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Monoid.hs0000644000000000000000000000540207346545000021734 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Monoid ( monoidLaws , commutativeMonoidLaws ) where import Data.Monoid import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..), SmallList(..), myForAllShrink) -- | Tests the following properties: -- -- [/Associative/] -- @mappend a (mappend b c) ≡ mappend (mappend a b) c@ -- [/Left Identity/] -- @mappend mempty a ≡ a@ -- [/Right Identity/] -- @mappend a mempty ≡ a@ -- [/Concatenation/] -- @mconcat as ≡ foldr mappend mempty as@ monoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws monoidLaws p = Laws "Monoid" [ ("Associative", monoidAssociative p) , ("Left Identity", monoidLeftIdentity p) , ("Right Identity", monoidRightIdentity p) , ("Concatenation", monoidConcatenation p) ] -- | Tests the following properties: -- -- [/Commutative/] -- @mappend a b ≡ mappend b a@ -- -- Note that this does not test associativity or identity. Make sure to use -- 'monoidLaws' in addition to this set of laws. commutativeMonoidLaws :: (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws commutativeMonoidLaws p = Laws "Commutative Monoid" [ ("Commutative", monoidCommutative p) ] monoidConcatenation :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidConcatenation _ = myForAllShrink True (const True) (\(SmallList (as :: [a])) -> ["as = " ++ show as]) "mconcat as" (\(SmallList as) -> mconcat as) "foldr mappend mempty as" (\(SmallList as) -> foldr mappend mempty as) monoidAssociative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidAssociative _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "mappend a (mappend b c)" (\(a,b,c) -> mappend a (mappend b c)) "mappend (mappend a b) c" (\(a,b,c) -> mappend (mappend a b) c) monoidLeftIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidLeftIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "mappend mempty a" (\a -> mappend mempty a) "a" (\a -> a) monoidRightIdentity :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidRightIdentity _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "mappend a mempty" (\a -> mappend a mempty) "a" (\a -> a) monoidCommutative :: forall a. (Monoid a, Eq a, Arbitrary a, Show a) => Proxy a -> Property monoidCommutative _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "mappend a b" (\(a,b) -> mappend a b) "mappend b a" (\(a,b) -> mappend b a) primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Ord.hs0000644000000000000000000000273107346545000021235 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Ord ( ordLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..)) -- | Tests the following properties: -- -- [/Antisymmetry/] -- @a ≤ b ∧ b ≤ a ⇒ a = b@ -- [/Transitivity/] -- @a ≤ b ∧ b ≤ c ⇒ a ≤ c@ -- [/Totality/] -- @a ≤ b ∨ a > b@ ordLaws :: (Ord a, Arbitrary a, Show a) => Proxy a -> Laws ordLaws p = Laws "Ord" [ ("Antisymmetry", ordAntisymmetric p) , ("Transitivity", ordTransitive p) , ("Totality", ordTotal p) ] ordAntisymmetric :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordAntisymmetric _ = property $ \(a :: a) b -> ((a <= b) && (b <= a)) == (a == b) ordTotal :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordTotal _ = property $ \(a :: a) b -> ((a <= b) || (b <= a)) == True -- Technically, this tests something a little stronger than it is supposed to. -- But that should be alright since this additional strength is implied by -- the rest of the Ord laws. ordTransitive :: forall a. (Show a, Ord a, Arbitrary a) => Proxy a -> Property ordTransitive _ = property $ \(a :: a) b c -> case (compare a b, compare b c) of (LT,LT) -> a < c (LT,EQ) -> a < c (LT,GT) -> True (EQ,LT) -> a < c (EQ,EQ) -> a == c (EQ,GT) -> a > c (GT,LT) -> True (GT,EQ) -> a > c (GT,GT) -> a > c primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Semigroup.hs0000644000000000000000000001164007346545000022462 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Semigroup ( -- * Laws semigroupLaws , commutativeSemigroupLaws , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws ) where import Prelude hiding (foldr1) import Data.Semigroup (Semigroup(..)) import Data.Proxy (Proxy) import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import Test.QuickCheck.Classes.Common (Laws(..), SmallList(..), myForAllShrink) import Data.Foldable (foldr1,toList) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List as L -- | Tests the following properties: -- -- [/Associative/] -- @a '<>' (b '<>' c) ≡ (a '<>' b) '<>' c@ -- [/Concatenation/] -- @'sconcat' as ≡ 'foldr1' ('<>') as@ -- [/Times/] -- @'stimes' n a ≡ 'foldr1' ('<>') ('replicate' n a)@ semigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws semigroupLaws p = Laws "Semigroup" [ ("Associative", semigroupAssociative p) , ("Concatenation", semigroupConcatenation p) , ("Times", semigroupTimes p) ] -- | Tests the following properties: -- -- [/Commutative/] -- @a '<>' b ≡ b '<>' a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. commutativeSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws commutativeSemigroupLaws p = Laws "Commutative Semigroup" [ ("Commutative", semigroupCommutative p) ] -- | Tests the following properties: -- -- [/Idempotent/] -- @a '<>' a ≡ a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. In literature, -- this class of semigroup is known as a band. idempotentSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws idempotentSemigroupLaws p = Laws "Idempotent Semigroup" [ ("Idempotent", semigroupIdempotent p) ] -- | Tests the following properties: -- -- [/Rectangular Band/] -- @a '<>' b '<>' a ≡ a@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. rectangularBandSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws rectangularBandSemigroupLaws p = Laws "Rectangular Band Semigroup" [ ("Rectangular Band", semigroupRectangularBand p) ] -- | Tests the following properties: -- -- [/Exponential/] -- @'stimes' n (a '<>' b) ≡ 'stimes' n a '<>' 'stimes' n b@ -- -- Note that this does not test associativity. Make sure to use -- 'semigroupLaws' in addition to this set of laws. exponentialSemigroupLaws :: (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws exponentialSemigroupLaws p = Laws "Exponential Semigroup" [ ("Exponential", semigroupExponential p) ] semigroupAssociative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupAssociative _ = myForAllShrink True (const True) (\(a :: a,b,c) -> ["a = " ++ show a, "b = " ++ show b, "c = " ++ show c]) "a <> (b <> c)" (\(a,b,c) -> a <> (b <> c)) "(a <> b) <> c" (\(a,b,c) -> (a <> b) <> c) semigroupCommutative :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupCommutative _ = myForAllShrink True (const True) (\(a :: a,b) -> ["a = " ++ show a, "b = " ++ show b]) "a <> b" (\(a,b) -> a <> b) "b <> a" (\(a,b) -> b <> a) semigroupConcatenation :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupConcatenation _ = myForAllShrink True (const True) (\(a, SmallList (as :: [a])) -> ["as = " ++ show (a :| as)]) "sconcat as" (\(a, SmallList as) -> sconcat (a :| as)) "foldr1 (<>) as" (\(a, SmallList as) -> foldr1 (<>) (a :| as)) semigroupTimes :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupTimes _ = myForAllShrink True (\(_,n) -> n > 0) (\(a :: a, n :: Int) -> ["a = " ++ show a, "n = " ++ show n]) "stimes n a" (\(a,n) -> stimes n a) "foldr1 (<>) (replicate n a)" (\(a,n) -> foldr1 (<>) (replicate n a)) semigroupExponential :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupExponential _ = myForAllShrink True (\(_,_,n) -> n > 0) (\(a :: a, b, n :: Int) -> ["a = " ++ show a, "b = " ++ show b, "n = " ++ show n]) "stimes n (a <> b)" (\(a,b,n) -> stimes n (a <> b)) "stimes n a <> stimes n b" (\(a,b,n) -> stimes n a <> stimes n b) semigroupIdempotent :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupIdempotent _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) "a <> a" (\a -> a <> a) "a" (\a -> a) semigroupRectangularBand :: forall a. (Semigroup a, Eq a, Arbitrary a, Show a) => Proxy a -> Property semigroupRectangularBand _ = myForAllShrink False (const True) (\(a :: a, b) -> ["a = " ++ show a, "b = " ++ show b]) "a <> b <> a" (\(a,b) -> a <> b <> a) "a" (\(a,_) -> a) primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Show.hs0000644000000000000000000000300207346545000021421 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-| Module : Test.QuickCheck.Classes.Show Description : Properties for testing the properties of the Show type class. -} module Test.QuickCheck.Classes.Show ( showLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck (Arbitrary, Property, property) import Test.QuickCheck.Classes.Common (Laws(..), ShowReadPrecedence(..)) -- | Tests the following properties: -- -- [/Show/] -- @'show' a ≡ 'showsPrec' 0 a ""@ -- [/Equivariance: 'showsPrec'/] -- @'showsPrec' p a r '++' s ≡ 'showsPrec' p a (r '++' s)@ -- [/Equivariance: 'showList'/] -- @'showList' as r '++' s ≡ 'showList' as (r '++' s)@ -- showLaws :: (Show a, Arbitrary a) => Proxy a -> Laws showLaws p = Laws "Show" [ ("Show", showShowsPrecZero p) , ("Equivariance: showsPrec", equivarianceShowsPrec p) , ("Equivariance: showList", equivarianceShowList p) ] showShowsPrecZero :: forall a. (Show a, Arbitrary a) => Proxy a -> Property showShowsPrecZero _ = property $ \(a :: a) -> show a == showsPrec 0 a "" equivarianceShowsPrec :: forall a. (Show a, Arbitrary a) => Proxy a -> Property equivarianceShowsPrec _ = property $ \(ShowReadPrecedence p) (a :: a) (r :: String) (s :: String) -> showsPrec p a r ++ s == showsPrec p a (r ++ s) equivarianceShowList :: forall a. (Show a, Arbitrary a) => Proxy a -> Property equivarianceShowList _ = property $ \(as :: [a]) (r :: String) (s :: String) -> showList as r ++ s == showList as (r ++ s) primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/ShowRead.hs0000644000000000000000000000623307346545000022226 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall #-} {-| Module : Test.QuickCheck.Classes.ShowRead Description : Properties for testing the interaction between the Show and Read type classes. -} module Test.QuickCheck.Classes.ShowRead ( showReadLaws ) where import Data.Proxy (Proxy) import Test.QuickCheck import Text.Read (readListDefault) import Text.Show (showListWith) import Test.QuickCheck.Classes.Common (Laws(..), ShowReadPrecedence(..), SmallList(..), myForAllShrink) import Test.QuickCheck.Classes.Compat (readMaybe) -- | Tests the following properties: -- -- [/Partial Isomorphism: 'show' \/ 'read'/] -- @'readMaybe' ('show' a) ≡ 'Just' a@ -- [/Partial Isomorphism: 'show' \/ 'read' with initial space/] -- @'readMaybe' (" " ++ 'show' a) ≡ 'Just' a@ -- [/Partial Isomorphism: 'showsPrec' \/ 'readsPrec'/] -- @(a,"") \`elem\` 'readsPrec' p ('showsPrec' p a "")@ -- [/Partial Isomorphism: 'showList' \/ 'readList'/] -- @(as,"") \`elem\` 'readList' ('showList' as "")@ -- [/Partial Isomorphism: 'showListWith' 'shows' \/ 'readListDefault'/] -- @(as,"") \`elem\` 'readListDefault' ('showListWith' 'shows' as "")@ -- -- /Note:/ When using @base-4.5@ or older, a shim implementation -- of 'readMaybe' is used. -- showReadLaws :: (Show a, Read a, Eq a, Arbitrary a) => Proxy a -> Laws showReadLaws p = Laws "Show/Read" [ ("Partial Isomorphism: show/read", showReadPartialIsomorphism p) , ("Partial Isomorphism: show/read with initial space", showReadSpacePartialIsomorphism p) , ("Partial Isomorphism: showsPrec/readsPrec", showsPrecReadsPrecPartialIsomorphism p) , ("Partial Isomorphism: showList/readList", showListReadListPartialIsomorphism p) , ("Partial Isomorphism: showListWith shows / readListDefault", showListWithShowsReadListDefaultPartialIsomorphism p) ] showReadPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showReadPartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) ("readMaybe (show a)") (\a -> readMaybe (show a)) ("Just a") (\a -> Just a) showReadSpacePartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showReadSpacePartialIsomorphism _ = myForAllShrink False (const True) (\(a :: a) -> ["a = " ++ show a]) ("readMaybe (\" \" ++ show a)") (\a -> readMaybe (" " ++ show a)) ("Just a") (\a -> Just a) showsPrecReadsPrecPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showsPrecReadsPrecPartialIsomorphism _ = property $ \(a :: a) (ShowReadPrecedence p) -> (a,"") `elem` readsPrec p (showsPrec p a "") showListReadListPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showListReadListPartialIsomorphism _ = property $ \(SmallList (as :: [a])) -> (as,"") `elem` readList (showList as "") showListWithShowsReadListDefaultPartialIsomorphism :: forall a. (Show a, Read a, Arbitrary a, Eq a) => Proxy a -> Property showListWithShowsReadListDefaultPartialIsomorphism _ = property $ \(SmallList (as :: [a])) -> (as,"") `elem` readListDefault (showListWith shows as "") primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Storable.hs0000644000000000000000000001161607346545000022266 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Storable ( storableLaws ) where import Control.Applicative import Data.Proxy (Proxy) import Foreign.Marshal.Alloc import Foreign.Marshal.Array import Foreign.Storable import GHC.Ptr (Ptr(..), plusPtr) import System.IO.Unsafe import Test.QuickCheck hiding ((.&.)) import Test.QuickCheck.Property (Property) import qualified Data.List as L import Test.QuickCheck.Classes.Common (Laws(..)) -- | Tests the following alternative properties: -- -- [/Set-Get/] -- @('pokeElemOff' ptr ix a >> 'peekElemOff' ptr ix') ≡ 'pure' a@ -- [/Get-Set/] -- @('peekElemOff' ptr ix >> 'pokeElemOff' ptr ix a) ≡ 'pure' a@ storableLaws :: (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Laws storableLaws p = Laws "Storable" [ ("Set-Get (you get back what you put in)", storableSetGet p) , ("Get-Set (putting back what you got out has no effect)", storableGetSet p) , ("List Conversion Roundtrips", storableList p) , ("peekElemOff a i ≡ peek (plusPtr a (i * sizeOf undefined))", storablePeekElem p) , ("peekElemOff a i x ≡ poke (plusPtr a (i * sizeOf undefined)) x ≡ id ", storablePokeElem p) , ("peekByteOff a i ≡ peek (plusPtr a i)", storablePeekByte p) , ("peekByteOff a i x ≡ poke (plusPtr a i) x ≡ id ", storablePokeByte p) ] arrayArbitrary :: forall a. (Arbitrary a, Storable a) => Int -> IO (Ptr a) arrayArbitrary len = do let go ix xs = if ix == len then pure xs else do x <- generate (arbitrary :: Gen a) go (ix + 1) (x : xs) as <- go 0 [] newArray as storablePeekElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePeekElem _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do let len = L.length as ix <- choose (0, len - 1) return $ unsafePerformIO $ do addr :: Ptr a <- arrayArbitrary len x <- peekElemOff addr ix y <- peek (addr `plusPtr` (ix * sizeOf (undefined :: a))) free addr return (x == y) storablePokeElem :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePokeElem _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do let len = L.length as ix <- choose (0, len - 1) return $ unsafePerformIO $ do addr :: Ptr a <- arrayArbitrary len pokeElemOff addr ix x u <- peekElemOff addr ix poke (addr `plusPtr` (ix * sizeOf x)) x v <- peekElemOff addr ix free addr return (u == v) storablePeekByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePeekByte _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do let len = L.length as off <- choose (0, len - 1) return $ unsafePerformIO $ do addr :: Ptr a <- arrayArbitrary len x :: a <- peekByteOff addr off y :: a <- peek (addr `plusPtr` off) free addr return (x == y) storablePokeByte :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storablePokeByte _ = property $ \(as :: [a]) (x :: a) -> (not (L.null as)) ==> do let len = L.length as off <- choose (0, len - 1) return $ unsafePerformIO $ do addr :: Ptr a <- arrayArbitrary len pokeByteOff addr off x u :: a <- peekByteOff addr off poke (addr `plusPtr` off) x v :: a <- peekByteOff addr off free addr return (u == v) storableSetGet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableSetGet _ = property $ \(a :: a) len -> (len > 0) ==> do ix <- choose (0,len - 1) return $ unsafePerformIO $ do ptr :: Ptr a <- arrayArbitrary len pokeElemOff ptr ix a a' <- peekElemOff ptr ix free ptr return (a == a') storableGetSet :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableGetSet _ = property $ \(as :: [a]) -> (not (L.null as)) ==> do let len = L.length as ix <- choose (0,len - 1) return $ unsafePerformIO $ do ptrA <- newArray as ptrB <- arrayArbitrary len copyArray ptrB ptrA len a <- peekElemOff ptrA ix pokeElemOff ptrA ix a res <- arrayEq ptrA ptrB len free ptrA free ptrB return res storableList :: forall a. (Storable a, Eq a, Arbitrary a, Show a) => Proxy a -> Property storableList _ = property $ \(as :: [a]) -> unsafePerformIO $ do let len = L.length as ptr <- newArray as let rebuild :: Int -> IO [a] rebuild !ix = if ix < len then (:) <$> peekElemOff ptr ix <*> rebuild (ix + 1) else return [] asNew <- rebuild 0 free ptr return (as == asNew) arrayEq :: forall a. (Storable a, Eq a) => Ptr a -> Ptr a -> Int -> IO Bool arrayEq ptrA ptrB len = go 0 where go !i = if i < len then do a <- peekElemOff ptrA i b <- peekElemOff ptrB i if a == b then go (i + 1) else return False else return True primitive-0.7.0.1/test/src/Test/QuickCheck/Classes/Traversable.hs0000644000000000000000000000622507346545000022765 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} #if HAVE_QUANTIFIED_CONSTRAINTS {-# LANGUAGE QuantifiedConstraints #-} #endif {-# OPTIONS_GHC -Wall #-} module Test.QuickCheck.Classes.Traversable ( #if HAVE_UNARY_LAWS traversableLaws #endif ) where import Data.Foldable (foldMap) import Data.Traversable (Traversable,fmapDefault,foldMapDefault,sequenceA,traverse) import Test.QuickCheck hiding ((.&.)) #if HAVE_UNARY_LAWS import Test.QuickCheck.Arbitrary (Arbitrary1(..)) import Data.Functor.Classes (Eq1,Show1) #endif import Data.Functor.Compose import Data.Functor.Identity import Test.QuickCheck.Classes.Common #if HAVE_UNARY_LAWS import Test.QuickCheck.Classes.Compat (eq1) #endif #if HAVE_UNARY_LAWS -- | Tests the following 'Traversable' properties: -- -- [/Naturality/] -- @t '.' 'traverse' f ≡ 'traverse' (t '.' f)@ -- for every applicative transformation @t@ -- [/Identity/] -- @'traverse' 'Identity' ≡ 'Identity'@ -- [/Composition/] -- @'traverse' ('Compose' '.' 'fmap' g '.' f) ≡ 'Compose' '.' 'fmap' ('traverse' g) '.' 'traverse' f@ -- [/Sequence Naturality/] -- @t '.' 'sequenceA' ≡ 'sequenceA' '.' 'fmap' t@ -- for every applicative transformation @t@ -- [/Sequence Identity/] -- @'sequenceA' '.' 'fmap' 'Identity' ≡ 'Identity'@ -- [/Sequence Composition/] -- @'sequenceA' '.' 'fmap' 'Compose' ≡ 'Compose' '.' 'fmap' 'sequenceA' '.' 'sequenceA'@ -- [/foldMap/] -- @'foldMap' ≡ 'foldMapDefault'@ -- [/fmap/] -- @'fmap' ≡ 'fmapDefault'@ -- -- Where an /applicative transformation/ is a function -- -- @t :: (Applicative f, Applicative g) => f a -> g a@ -- -- preserving the 'Applicative' operations, i.e. -- -- * Identity: @t ('pure' x) ≡ 'pure' x@ -- * Distributivity: @t (x '<*>' y) ≡ t x '<*>' t y@ traversableLaws :: #if HAVE_QUANTIFIED_CONSTRAINTS (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws traversableLaws = traversableLawsInternal traversableLawsInternal :: forall proxy f. #if HAVE_QUANTIFIED_CONSTRAINTS (Traversable f, forall a. Eq a => Eq (f a), forall a. Show a => Show (f a), forall a. Arbitrary a => Arbitrary (f a)) #else (Traversable f, Eq1 f, Show1 f, Arbitrary1 f) #endif => proxy f -> Laws traversableLawsInternal _ = Laws "Traversable" [ (,) "Identity" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (traverse Identity t) (Identity t) , (,) "Composition" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (traverse (Compose . fmap func5 . func6) t) (Compose (fmap (traverse func5) (traverse func6 t))) , (,) "Sequence Identity" $ property $ \(Apply (t :: f Integer)) -> nestedEq1 (sequenceA (fmap Identity t)) (Identity t) , (,) "Sequence Composition" $ property $ \(Apply (t :: f (Triple (Triple Integer)))) -> nestedEq1 (sequenceA (fmap Compose t)) (Compose (fmap sequenceA (sequenceA t))) , (,) "foldMap" $ property $ \(Apply (t :: f Integer)) -> foldMap func3 t == foldMapDefault func3 t , (,) "fmap" $ property $ \(Apply (t :: f Integer)) -> eq1 (fmap func3 t) (fmapDefault func3 t) ] #endif