diff --git a/Data/Primitive/Array.hs b/Data/Primitive/Array.hs index 78aeab2..5421134 100644 --- a/Data/Primitive/Array.hs +++ b/Data/Primitive/Array.hs @@ -736,6 +736,17 @@ instance MonadFix Array where instance Semigroup (Array a) where (<>) = (<|>) sconcat = mconcat . F.toList + stimes n arr = case compare n 0 of + LT -> die "stimes" "negative multiplier" + EQ -> empty + GT -> createArray (n' * sizeofArray arr) (die "stimes" "impossible") $ \ma -> + let go i = if i < n' + then do + copyArray ma (i * sizeofArray arr) arr 0 (sizeofArray arr) + go (i + 1) + else return () + in go 0 + where n' = fromIntegral n :: Int #endif instance Monoid (Array a) where diff --git a/Data/Primitive/ByteArray.hs b/Data/Primitive/ByteArray.hs index 9a53bb3..907f353 100644 --- a/Data/Primitive/ByteArray.hs +++ b/Data/Primitive/ByteArray.hs @@ -682,11 +682,10 @@ replicateByteArray n arr = runST $ do 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 + stimes n arr = case compare n 0 of + LT -> die "stimes" "negative multiplier" + EQ -> emptyByteArray + GT -> replicateByteArray (fromIntegral n) arr #endif instance Monoid ByteArray where diff --git a/Data/Primitive/SmallArray.hs b/Data/Primitive/SmallArray.hs index 224d83c..3016f73 100644 --- a/Data/Primitive/SmallArray.hs +++ b/Data/Primitive/SmallArray.hs @@ -767,6 +767,17 @@ instance MonadFix SmallArray where instance Sem.Semigroup (SmallArray a) where (<>) = (<|>) sconcat = mconcat . toList + stimes n arr = case compare n 0 of + LT -> die "stimes" "negative multiplier" + EQ -> empty + GT -> createSmallArray (n' * sizeofSmallArray arr) (die "stimes" "impossible") $ \sma -> + let go i = if i < n' + then do + copySmallArray sma (i * sizeofSmallArray arr) arr 0 (sizeofSmallArray arr) + go (i + 1) + else return () + in go 0 + where n' = fromIntegral n :: Int #endif instance Monoid (SmallArray a) where diff --git a/test/main.hs b/test/main.hs index 0de897f..b8e796d 100644 --- a/test/main.hs +++ b/test/main.hs @@ -32,7 +32,7 @@ import Data.Functor.Identity (Identity(..)) import qualified Data.Monoid as Monoid import Data.Ord (Down(..)) #if MIN_VERSION_base(4,9,0) -import Data.Semigroup (stimes) +import Data.Semigroup (stimes, stimesMonoid) import qualified Data.Semigroup as Semigroup #endif #if !(MIN_VERSION_base(4,11,0)) @@ -59,6 +59,7 @@ main = do [ testGroup "Array" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (Array Int))) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 Array)) @@ -70,10 +71,14 @@ main = do , TQC.testProperty "mapArray'" (QCCL.mapProp int16 int32 mapArray') , TQC.testProperty "*>" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs *> ys) === (toList xs *> toList ys) , TQC.testProperty "<*" $ \(xs :: Array Int) (ys :: Array Int) -> toList (xs <* ys) === (toList xs <* toList ys) +#if MIN_VERSION_base(4,9,0) + , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: Array Int) -> stimes n xs == stimesMonoid n xs +#endif ] , testGroup "SmallArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (SmallArray Int))) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (SmallArray Int))) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.functorLaws (Proxy1 :: Proxy1 SmallArray)) @@ -85,6 +90,9 @@ main = do , TQC.testProperty "mapSmallArray'" (QCCL.mapProp int16 int32 mapSmallArray') , TQC.testProperty "*>" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs *> ys) === (toList xs *> toList ys) , TQC.testProperty "<*" $ \(xs :: SmallArray Int) (ys :: SmallArray Int) -> toList (xs <* ys) === (toList xs <* toList ys) +#if MIN_VERSION_base(4,9,0) + , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: SmallArray Int) -> stimes n xs == stimesMonoid n xs +#endif ] , testGroup "ByteArray" [ testGroup "Ordering" @@ -109,13 +117,19 @@ main = do ] , lawsToTest (QCC.eqLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.ordLaws (Proxy :: Proxy ByteArray)) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy ByteArray)) + , lawsToTest (QCC.monoidLaws (Proxy :: Proxy ByteArray)) , lawsToTest (QCC.showReadLaws (Proxy :: Proxy (Array Int))) , lawsToTest (QCC.isListLaws (Proxy :: Proxy ByteArray)) , TQC.testProperty "foldrByteArray" (QCCL.foldrProp word8 foldrByteArray) +#if MIN_VERSION_base(4,9,0) + , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: ByteArray) -> stimes n xs == stimesMonoid n xs +#endif ] , testGroup "PrimArray" [ lawsToTest (QCC.eqLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.ordLaws (Proxy :: Proxy (PrimArray Word16))) + , lawsToTest (QCC.semigroupLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.monoidLaws (Proxy :: Proxy (PrimArray Word16))) , lawsToTest (QCC.isListLaws (Proxy :: Proxy (PrimArray Word16))) , TQC.testProperty "foldrPrimArray" (QCCL.foldrProp int16 foldrPrimArray) @@ -141,6 +155,9 @@ main = do , TQC.testProperty "mapMaybePrimArray" (QCCL.mapMaybeProp int16 int32 mapMaybePrimArray) , TQC.testProperty "mapMaybePrimArrayA" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayA) , TQC.testProperty "mapMaybePrimArrayP" (QCCL.mapMaybeMProp int16 int32 mapMaybePrimArrayP) +#if MIN_VERSION_base(4,9,0) + , TQC.testProperty "stimes" $ \(QC.NonNegative (n :: Int)) (xs :: PrimArray Word16) -> stimes n xs == stimesMonoid n xs +#endif ] , testGroup "DefaultSetMethod" [ lawsToTest (primLaws (Proxy :: Proxy DefaultSetMethod))