diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,151 @@ +# Revision history for contiguous + +## 0.6.5.0 -- 2025-04-07 + +* Implement Contiguous and ContiguousU for SmallUnliftedArray +* Re-export Small(Mutable)UnliftedArray from Data.Primitive.Contiguous +* Use functions from newer primitive and primitive-unlifted. The implementation + of UnliftedArray in primitive-unlifted-2.1 penalizes the creation of an + uninitialized unlifted array. When shrinking and resizing unlifted arrays, + there are primitives that we can use to avoid this. + +## 0.6.4.2 -- 2024-02-06 + +* Restore support for versions of base that do not export `liftA2` + from the prelude. + +## 0.6.4.1 -- 2024-02-05 + +* Update package metadata. + +## 0.6.4.0 -- 2023-06-28 + +* Make it work with primitive-unlifted-2.1, which drops + support for older primitive-unlifted. +* Add `quintupleton` and `sextupleton`. +* Add `construct(1|2|3|4|5|6)` aliases for constructing arrays with + a small known number of elements. + +## 0.6.3.0 -- 2022-12-07 + +* Add strict `foldrM` + +## 0.6.2.0 -- 2022-04-13 + +* Make benchmarks build +* Add strict `ifoldlZipWith` and `foldlZipWith` + +## 0.6.1.1 -- 2022-02-16 + +* Allow building with GHC 9.2.1. +* Drop support for GHC 8.8 and earlier. + +## 0.6.1.0 -- 2021-09-01 + +* Add `itraverseP` +* Add `deleteAt` and `ifoldr` + +## 0.6.0 -- 2021-08-28 + +* Add `Slice`, `MutableSlice`. +* Split `Contiguous` into `ContiguousSlice` and `Contiguous`. +* Add `shrink` and `unsafeShrinkAndFreeze` + +## 0.5.2 -- 2021-08-11 + +* Add `ifoldlM'`. +* Add `foldrZipWith` and `ifoldrZipWith`. +* Add `foldlZipWithM'` and `ifoldlZipWithM'`. +* Add `all` and `any`. +* Add `run`. Use it internally to accerelate prevent GHC from + boxing results in `runST`. +* Add `quadrupleton`. + +## 0.5.1 -- 2020-06-30 + +* Add `izipWith`. +* Compatibility with `primitive-0.7.1.0`. + +## 0.5 -- 2019-07-23 + +* Add `generateM`, `reverseSlice`, `swap`, `catMaybes`, + `zipWith`, `zip`, `lefts`, `rights`, `partitionEithers`, `elem`, + `find`, `maximum`/`minimum`, `maximumBy`/`minimumBy`, `asum`, + `mapM(_)`, `forM(_)`, `for(_)`, `sequence(_)`, `(<$)`, `ap`, `scanl`, + `scanl'`, `iscanl`, `iscanl'`, `prescanl`, `prescanl'`, `iprescanl`, + `iprescanl'` +* Re-export Array types from the `primitive` package +* Expand unit test suite to include all added functions +* Expand laws test suite to test Foldable/IsList/Traversable laws + in addition to Functor/Applicative +* Add benchmark suite that measures allocations +* Fix performance issue with fold functions that caused huge increase + in allocations when partially-applied. Partially-applied folds now + perform as well as fully-applied. +* Make sure all functions are marked INLINE. Last function not marked + as inline was `imap'`. + +## 0.4.0.1 -- 2019-05-17 + +* Allow building with `primitive-0.7`. This required depending on the + `primitive-unlifted` package to provide the removed `UnliftedArray` + api. + +## 0.4 -- 2019-05-16 + +* Add `convert`, `filter`, `ifilter`, `itraverse(_)` (#6), `imap'`, + `unsafeFromListN`, `unsafeFromListReverseMutableN`, `ifoldr'`, + `foldl`, `mapMutable`, `imapMutable`, `reverse`, `reverseMutable`, + `replicateMutableM`, `create`, `createT`, `unsafeFromListReverseN`, + `generate`, `generateMutable`, `iterate`, `iterateMutableN`, + `iterateMutableNM`, `unfoldr`, `unfoldrMutable`, `toList`, + `toListMutable`, `fromListMutableN`, `fromListMutable`, `fromListN`, + `fromList`, `modify`, `modify'`, `enumFromN`, `enumFromMutableN` +* Refactor `replicate` functions to make more sense (#19) +* Add `Contiguous` instance for `SmallArray` +* Attempt to mark everything as inline (#18) +* Achieve 100% doc coverage, organise exports a lot more + (mimicking vector). Various haddock fixes +* Make `toListMutable` strict in the accumulator +* Change all instances of `return` to `pure` +* Add initial test suite (some unit tests that check implementations + against base/vector versions of the same functions) +* Export `unsafeFreeze`, `copy`, `write`, +* Rename `sameMutable` to `equalsMutable` + +## 0.3.3.0 -- 2019-03-24 + +* Add `freeze` as a method to `Contiguous` +* Add more folds +* Mark more functions as INLINEABLE + +## 0.3.2.0 -- 2019-01-02 + +* Add `thaw` as a method to `Contiguous` + +## 0.3.1.0 -- 2018-10-19 + +* Add `singleton`,`doubleton`,`tripleton` as methods to `Contiguous` +* Add `map'`, `imap`, `mapMutable'`, `imapMutable'` + +## 0.3.0.0 -- 2018-09-06 + +* Document the need for `Always` +* Generalise API: from `ST s` to `PrimMonad m` +* Add NFData `rnf` function for deeply evaluating + `Contiguous` arrays. +* Add function `equals`, for detecting if two arrays in memory + are the same. +* Add hashing function. +* Make `map` able to produce a new array type. +* Add `replicate`, `null` as methods to `Contiguous`. +* Add `traverse`, `itraverse`, `traverseP`, `foldMap` + +## 0.2.0.0 -- 2018-06-07 + +* Add cabal metadata: category, proper synopsis/description +* Use primitive-0.6.4.0 + +## 0.1.0.0 -- 2018-05-31 + +* Initial version. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,11 @@ -# primitive-class +# contiguous + +[![Hackage](https://img.shields.io/hackage/v/contiguous.svg)](https://hackage.haskell.org/package/contiguous) +[![Hackage](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) + +The contiguous typeclass parameterises over a contiguous array type. +This allows us to have a common API to a number of contiguous +array types and their mutable counterparts, namely those in primitive, +making the experience of working with the primitive datatypes much cleaner +and uniform. + diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} + +module Main (main) where + +import Prelude hiding + ( Foldable (..) + , map + , null + , read + ) + +import Control.Monad +import Data.Functor.Identity (Identity (..)) +import Data.Monoid (Sum (..)) +import Data.Primitive.Contiguous +import GHC.Exts (RealWorld) +import System.Random +import System.Random.Shuffle +import Weigh + +main :: IO () +main = do + array10 <- randomC @Array 10 + array100 <- randomC @Array 100 + array1000 <- randomC @Array 1000 + smallArray10 <- randomC @SmallArray 10 + smallArray100 <- randomC @SmallArray 100 + smallArray1000 <- randomC @SmallArray 1000 + primArray10 <- randomC @PrimArray 10 + primArray100 <- randomC @PrimArray 100 + primArray1000 <- randomC @PrimArray 1000 + + marray10 <- randomCM @Array 10 + marray100 <- randomCM @Array 100 + marray1000 <- randomCM @Array 1000 + msmallArray10 <- randomCM @SmallArray 10 + msmallArray100 <- randomCM @SmallArray 100 + msmallArray1000 <- randomCM @SmallArray 1000 + mprimArray10 <- randomCM @PrimArray 10 + mprimArray100 <- randomCM @PrimArray 100 + mprimArray1000 <- randomCM @PrimArray 1000 + + mainWith $ do + wgroup "0-allocation" $ do + wgroup "size" $ do + func "array10" size array10 + func "array100" size array100 + func "array1000" size array1000 + + func "smallArray10" size smallArray10 + func "smallArray100" size smallArray100 + func "smallArray1000" size smallArray1000 + + func "primArray10" size primArray10 + func "primArray100" size primArray100 + func "primArray1000" size primArray1000 + + io "marray10" sizeMut marray10 + io "marray100" sizeMut marray100 + io "marray1000" sizeMut marray1000 + + io "msmallArray10" sizeMut msmallArray10 + io "msmallArray100" sizeMut msmallArray100 + io "msmallArray1000" sizeMut msmallArray1000 + + io "mprimArray10" sizeMut mprimArray10 + io "mprimArray100" sizeMut mprimArray100 + io "mprimArray1000" sizeMut mprimArray1000 + wgroup "null" $ do + func "array10" null array10 + func "array100" null array100 + func "array1000" null array1000 + + func "smallArray10" null smallArray10 + func "smallArray100" null smallArray100 + func "smallArray1000" null smallArray1000 + + func "primArray10" null primArray10 + func "primArray100" null primArray100 + func "primArray1000" null primArray1000 + wgroup "index/read" $ do + func "array10: index#" (index## 5) array10 + func "array100: index#" (index## 50) array100 + func "array1000: index#" (index## 500) array1000 + + func "smallArray10: index#" (index## 5) smallArray10 + func "smallArray100: index#" (index## 50) smallArray100 + func "smallArray1000: index#" (index## 500) smallArray1000 + + func "primArray10: index#" (index## 5) primArray10 + func "primArray100: index#" (index## 50) primArray100 + func "primArray1000: index#" (index## 500) primArray1000 + + func "array10: index" (flip index 5) array10 + func "array100: index" (flip index 50) array100 + func "array1000: index" (flip index 500) array1000 + + func "smallArray10: index" (flip index 5) smallArray10 + func "smallArray100: index" (flip index 50) smallArray100 + func "smallArray1000: index" (flip index 500) smallArray1000 + + func "primArray10: index" (flip index 5) primArray10 + func "primArray100: index" (flip index 50) primArray100 + func "primArray1000: index" (flip index 500) primArray1000 + + io "marray10: read" (flip read 5) marray10 + io "marray100: read" (flip read 50) marray100 + io "marray1000: read" (flip read 500) marray1000 + + io "msmallArray10: read" (flip read 5) msmallArray10 + io "msmallArray100: read" (flip read 50) msmallArray100 + io "msmallArray1000: read" (flip read 500) msmallArray1000 + + io "mprimArray10: read" (flip read 5) mprimArray10 + io "mprimArray100: read" (flip read 50) mprimArray100 + io "mprimArray1000: read" (flip read 500) mprimArray1000 + wgroup "folds" $ do + wgroup "foldMap" $ do + func "array10: foldMap computes sum" (foldMap sum1) array10 + func "array100: foldMap computes sum" (foldMap sum1) array100 + func "array1000: foldMap computes sum" (foldMap sum1) array1000 + + func "smallArray10: foldMap computes sum" (foldMap sum1) smallArray10 + func "smallArray100: foldMap computes sum" (foldMap sum1) smallArray100 + func "smallArray1000: foldMap computes sum" (foldMap sum1) smallArray1000 + + func "primArray10: foldMap computes sum" (foldMap sum1) primArray10 + func "primArray100: foldMap computes sum" (foldMap sum1) primArray100 + func "primArray1000: foldMap computes sum" (foldMap sum1) primArray1000 + wgroup "foldMap'" $ do + func "array10: foldMap' computes sum" (foldMap' sum1) array10 + func "array100: foldMap' computes sum" (foldMap' sum1) array100 + func "array1000: foldMap' computes sum" (foldMap' sum1) array1000 + + func "smallArray10: foldMap' computes sum" (foldMap' sum1) smallArray10 + func "smallArray100: foldMap' computes sum" (foldMap' sum1) smallArray100 + func "smallArray1000: foldMap' computes sum" (foldMap' sum1) smallArray1000 + + func "primArray10: foldMap' computes sum" (foldMap' sum1) primArray10 + func "primArray100: foldMap' computes sum" (foldMap' sum1) primArray100 + func "primArray1000: foldMap' computes sum" (foldMap' sum1) primArray1000 + wgroup "foldr" $ do + func "array10: foldr computes sum" (foldr (+) 0) array10 + func "array100: foldr computes sum" (foldr (+) 0) array100 + func "array1000: foldr computes sum" (foldr (+) 0) array1000 + + func "smallArray10: foldr computes sum" (foldr (+) 0) smallArray10 + func "smallArray100: foldr computes sum" (foldr (+) 0) smallArray100 + func "smallArray1000: foldr computes sum" (foldr (+) 0) smallArray1000 + + func "primArray10: foldr computes sum" (foldr (+) 0) primArray10 + func "primArray100: foldr computes sum" (foldr (+) 0) primArray100 + func "primArray1000: foldr computes sum" (foldr (+) 0) primArray1000 + wgroup "foldr'" $ do + func "array10: foldr' computes sum" (foldr' (+) 0) array10 + func "array100: foldr' computes sum" (foldr' (+) 0) array100 + func "array1000: foldr' computes sum" (foldr' (+) 0) array1000 + + func "smallArray10: foldr' computes sum" (foldr' (+) 0) smallArray10 + func "smallArray100: foldr' computes sum" (foldr' (+) 0) smallArray100 + func "smallArray1000: foldr' computes sum" (foldr' (+) 0) smallArray1000 + + func "primArray10: foldr' computes sum" (foldr' (+) 0) primArray10 + func "primArray100: foldr' computes sum" (foldr' (+) 0) primArray100 + func "primArray1000: foldr' computes sum" (foldr' (+) 0) primArray1000 + wgroup "foldl" $ do + func "array10: foldl computes sum" (foldl (+) 0) array10 + func "array100: foldl computes sum" (foldl (+) 0) array100 + func "array1000: foldl computes sum" (foldl (+) 0) array1000 + + func "smallArray10: foldl computes sum" (foldl (+) 0) smallArray10 + func "smallArray100: foldl computes sum" (foldl (+) 0) smallArray100 + func "smallArray1000: foldl computes sum" (foldl (+) 0) smallArray1000 + + func "primArray10: foldl computes sum" (foldl (+) 0) primArray10 + func "primArray100: foldl computes sum" (foldl (+) 0) primArray100 + func "primArray1000: foldl computes sum" (foldl (+) 0) primArray1000 + wgroup "foldl'" $ do + func "array10: foldl' computes sum" (foldl' (+) 0) array10 + func "array100: foldl' computes sum" (foldl' (+) 0) array100 + func "array1000: foldl' computes sum" (foldl' (+) 0) array1000 + + func "smallArray10: foldl' computes sum" (foldl' (+) 0) smallArray10 + func "smallArray100: foldl' computes sum" (foldl' (+) 0) smallArray100 + func "smallArray1000: foldl' computes sum" (foldl' (+) 0) smallArray1000 + + func "primArray10: foldl' computes sum" (foldl' (+) 0) primArray10 + func "primArray100: foldl' computes sum" (foldl' (+) 0) primArray100 + func "primArray1000: foldl' computes sum" (foldl' (+) 0) primArray1000 + wgroup "ifoldl'" $ do + func "array10: ifoldl' computes sum" (ifoldl' add3 0) array10 + func "array100: ifoldl' computes sum" (ifoldl' add3 0) array100 + func "array1000: ifoldl' computes sum" (ifoldl' add3 0) array1000 + + func "smallArray10: ifoldl' computes sum" (ifoldl' add3 0) smallArray10 + func "smallArray100: ifoldl' computes sum" (ifoldl' add3 0) smallArray100 + func "smallArray1000: ifoldl' computes sum" (ifoldl' add3 0) smallArray1000 + + func "primArray10: ifoldl' computes sum" (ifoldl' add3 0) primArray10 + func "primArray100: ifoldl' computes sum" (ifoldl' add3 0) primArray100 + func "primArray1000: ifoldl' computes sum" (ifoldl' add3 0) primArray1000 + wgroup "ifoldr'" $ do + func "array10: ifoldr' computes sum" (ifoldr' add3 0) array10 + func "array100: ifoldr' computes sum" (ifoldr' add3 0) array100 + func "array1000: ifoldr' computes sum" (ifoldr' add3 0) array1000 + + func "smallArray10: ifoldr' computes sum" (ifoldr' add3 0) smallArray10 + func "smallArray100: ifoldr' computes sum" (ifoldr' add3 0) smallArray100 + func "smallArray1000: ifoldr' computes sum" (ifoldr' add3 0) smallArray1000 + + func "primArray10: ifoldr' computes sum" (ifoldr' add3 0) primArray10 + func "primArray100: ifoldr' computes sum" (ifoldr' add3 0) primArray100 + func "primArray1000: ifoldr' computes sum" (ifoldr' add3 0) primArray1000 + wgroup "foldlMap'" $ do + func "array10: foldlMap' computes sum" (foldMap' sum1) array10 + func "array100: foldlMap' computes sum" (foldMap' sum1) array100 + func "array1000: foldlMap' computes sum" (foldMap' sum1) array1000 + + func "smallArray10: foldlMap' computes sum" (foldMap' sum1) smallArray10 + func "smallArray100: foldlMap' computes sum" (foldMap' sum1) smallArray100 + func "smallArray1000: foldlMap' computes sum" (foldMap' sum1) smallArray1000 + + func "primArray10: foldlMap' computes sum" (foldMap' sum1) primArray10 + func "primArray100: foldlMap' computes sum" (foldMap' sum1) primArray100 + func "primArray1000: foldlMap' computes sum" (foldMap' sum1) primArray1000 + + wgroup "ifoldlMap'" $ do + func "array10: ifoldlMap' computes sum" (ifoldlMap' isumN) array10 + func "array100: ifoldlMap' computes sum" (ifoldlMap' isumN) array100 + func "array1000: ifoldlMap' computes sum" (ifoldlMap' isumN) array1000 + + func "smallArray10: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray10 + func "smallArray100: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray100 + func "smallArray1000: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray1000 + + func "primArray10: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray10 + func "primArray100: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray100 + func "primArray1000: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray1000 + wgroup "ifoldlMap1'" $ do + func "array10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array10 + func "array100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array100 + func "array1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array1000 + + func "smallArray10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray10 + func "smallArray100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray100 + func "smallArray1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray1000 + + func "primArray10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray10 + func "primArray100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray100 + func "primArray1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray1000 + wgroup "foldlM'" $ do + func "array10: foldlM' computes sum" (foldlM' idM 0) array10 + func "array100: foldlM' computes sum" (foldlM' idM 0) array100 + func "array1000: foldlM' computes sum" (foldlM' idM 0) array1000 + + func "smallArray10: foldlM' computes sum" (foldlM' idM 0) smallArray10 + func "smallArray100: foldlM' computes sum" (foldlM' idM 0) smallArray100 + func "smallArray1000: foldlM' computes sum" (foldlM' idM 0) smallArray1000 + + func "primArray10: foldlM' computes sum" (foldlM' idM 0) primArray10 + func "primArray100: foldlM' computes sum" (foldlM' idM 0) primArray100 + func "primArray1000: foldlM' computes sum" (foldlM' idM 0) primArray1000 + wgroup "maps" $ do + wgroup "map" $ do + func "array10" mapPlus1 array10 + func "array100" mapPlus1 array100 + func "array1000" mapPlus1 array1000 + + func "smallArray10" mapPlus1 smallArray10 + func "smallArray100" mapPlus1 smallArray100 + func "smallArray1000" mapPlus1 smallArray1000 + + func "primArray10" mapPlus1 primArray10 + func "primArray100" mapPlus1 primArray100 + func "primArray1000" mapPlus1 primArray1000 + wgroup "map'" $ do + func "array10" mapPlus1' array10 + func "array100" mapPlus1' array100 + func "array1000" mapPlus1' array1000 + + func "smallArray10" mapPlus1' smallArray10 + func "smallArray100" mapPlus1' smallArray100 + func "smallArray1000" mapPlus1' smallArray1000 + + func "primArray10" mapPlus1' primArray10 + func "primArray100" mapPlus1' primArray100 + func "primArray1000" mapPlus1' primArray1000 + wgroup "mapMaybe" $ do + func "array10" mapMaybeJ array10 + func "array100" mapMaybeJ array100 + func "array1000" mapMaybeJ array1000 + + func "smallArray10" mapMaybeJ smallArray10 + func "smallArray100" mapMaybeJ smallArray100 + func "smallArray1000" mapMaybeJ smallArray1000 + + func "primArray10" mapMaybeJ primArray10 + func "primArray100" mapMaybeJ primArray100 + func "primArray1000" mapMaybeJ primArray1000 + +mapMaybeJ :: + forall arr. + (Contiguous arr, Element arr Int) => + arr Int -> + () +mapMaybeJ arr = + let !(_arr' :: arr Int) = mapMaybe Just arr + in () + +mapPlus1 :: + forall arr. + (Contiguous arr, Element arr Int) => + arr Int -> + () +mapPlus1 arr = let !(_arr' :: arr Int) = map (+ 1) arr in () + +mapPlus1' :: + forall arr. + (Contiguous arr, Element arr Int) => + arr Int -> + () +mapPlus1' arr = let !(_arr' :: arr Int) = map' (+ 1) arr in () + +_plus1 :: Int -> Int +_plus1 = (+ 1) + +sum1 :: a -> Sum Int +sum1 = const (Sum 1) + +isumN :: Int -> a -> Sum Int +isumN x = const (Sum x) + +idM :: Int -> Int -> Identity Int +idM x y = Identity (x + y) + +add3 :: Int -> Int -> Int -> Int +add3 x y z = x + y + z + +index## :: (Contiguous arr, Element arr a) => Int -> arr a -> () +index## ix arr = case index# arr ix of !(# _x #) -> () + +randomList :: Int -> IO [Int] +randomList sz = replicateM sz (randomRIO (minBound, maxBound)) + +randomC :: + (Contiguous arr, Element arr Int) => + Int -> + IO (arr Int) +randomC sz = do + rList <- randomList sz + rList' <- shuffleM rList + pure (fromListN sz rList') + +randomCM :: + (Contiguous arr, Element arr Int) => + Int -> + IO (Mutable arr RealWorld Int) +randomCM sz = do + rList <- randomList sz + rList' <- shuffleM rList + fromListMutableN sz rList' diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,2 @@ +packages: . +tests: True diff --git a/contiguous.cabal b/contiguous.cabal --- a/contiguous.cabal +++ b/contiguous.cabal @@ -1,34 +1,89 @@ -cabal-version: 2.0 -name: contiguous -version: 0.3.3.0 -homepage: https://github.com/andrewthad/contiguous -bug-reports: https://github.com/andrewthad/contiguous/issues -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2018 Andrew Martin -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-source-files: README.md -synopsis: Unified interface for primitive arrays -category: Array +cabal-version: 2.4 +name: contiguous +version: 0.6.5.0 +homepage: https://github.com/byteverse/contiguous +bug-reports: https://github.com/byteverse/contiguous/issues +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2018 Andrew Martin +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +extra-source-files: cabal.project +synopsis: Unified interface for primitive arrays +category: Array,Data,Primitive description: This package provides a typeclass `Contiguous` that offers a - unified interface to working with `Array`, `PrimArray`, and - `UnliftedArray`. + unified interface to working with `Array`, `SmallArray`, + `PrimArray`, and `UnliftedArray`. -source-repository head - type: git - location: https://github.com/andrewthad/contiguous +tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages + library + import: build-settings exposed-modules: Data.Primitive.Contiguous - hs-source-dirs: src + Data.Primitive.Contiguous.Class + + other-modules: Data.Primitive.Contiguous.Shim + hs-source-dirs: src build-depends: - base >=4.9 && <5 - , primitive >= 0.6.4 - , deepseq >= 1.4 - default-language: Haskell2010 - ghc-options: -O2 -Wall + , base >=4.14 && <5 + , deepseq >=1.4 + , primitive >=0.9 && <0.10 + , primitive-unlifted >=2.2 + , run-st >=0.1.3.2 + ghc-options: -O2 + +test-suite unit-tests + import: build-settings + type: exitcode-stdio-1.0 + main-is: UnitTests.hs + hs-source-dirs: test + build-depends: + , base + , contiguous + , primitive + , QuickCheck + , quickcheck-instances + , vector + +test-suite laws + import: build-settings + type: exitcode-stdio-1.0 + main-is: Laws.hs + hs-source-dirs: test + build-depends: + , base + , contiguous + , QuickCheck + , quickcheck-classes + + ghc-options: -O2 + +benchmark weigh + import: build-settings + type: exitcode-stdio-1.0 + build-depends: + , base + , contiguous + , random + , random-shuffle + , weigh + + hs-source-dirs: bench + main-is: Main.hs + ghc-options: -O2 + +source-repository head + type: git + location: git://github.com/byteverse/contiguous.git diff --git a/src/Data/Primitive/Contiguous.hs b/src/Data/Primitive/Contiguous.hs --- a/src/Data/Primitive/Contiguous.hs +++ b/src/Data/Primitive/Contiguous.hs @@ -1,625 +1,2365 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeFamilyDependencies #-} -{-# LANGUAGE UnboxedTuples #-} -module Data.Primitive.Contiguous - ( Contiguous(..) - , Always - , append - , map - , map' - , imap - , mapMutable' - , imapMutable' - , foldr - , foldMap - , foldl' - , ifoldl' - , foldr' - , foldMap' - , foldlMap' - , ifoldlMap' - , ifoldlMap1' - , foldlM' - , traverse - , traverseP - , traverse_ - , itraverse_ - , unsafeFromListN - , unsafeFromListReverseN - , liftHashWithSalt - , same - ) where - -import Prelude hiding (map,foldr,foldMap,traverse,read) -import Control.Monad.ST (runST,ST) -import Control.Monad.Primitive -import Control.Applicative (liftA2) -import Data.Bits (xor) -import Data.Kind (Type) -import Data.Primitive -import Data.Semigroup (Semigroup,(<>)) -import GHC.Exts (MutableArrayArray#,ArrayArray#,Constraint,sizeofByteArray#,sizeofArray#,sizeofArrayArray#,unsafeCoerce#,sameMutableArrayArray#,isTrue#) -import Control.DeepSeq (NFData) - -import qualified Control.DeepSeq as DS - --- | A typeclass that is satisfied by all types. This is used --- used to provide a fake constraint for 'Array' and 'SmallArray'. -class Always a -instance Always a - --- | A contiguous array of elements. -class Contiguous (arr :: Type -> Type) where - type family Mutable arr = (r :: Type -> Type -> Type) | r -> arr - type family Element arr :: Type -> Constraint - empty :: arr a - null :: arr b -> Bool - new :: (PrimMonad m, Element arr b) => Int -> m (Mutable arr (PrimState m) b) - replicateM :: (PrimMonad m, Element arr b) => Int -> b -> m (Mutable arr (PrimState m) b) - index :: Element arr b => arr b -> Int -> b - index# :: Element arr b => arr b -> Int -> (# b #) - indexM :: (Element arr b, Monad m) => arr b -> Int -> m b - read :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> m b - write :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> b -> m () - resize :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> m (Mutable arr (PrimState m) b) - size :: Element arr b => arr b -> Int - sizeMutable :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> m Int - unsafeFreeze :: PrimMonad m => Mutable arr (PrimState m) b -> m (arr b) - freeze :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> Int -> m (arr b) - thaw :: (PrimMonad m, Element arr b) => arr b -> Int -> Int -> m (Mutable arr (PrimState m) b) - copy :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> arr b -> Int -> Int -> m () - copyMutable :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> Mutable arr (PrimState m) b -> Int -> Int -> m () - clone :: Element arr b => arr b -> Int -> Int -> arr b - cloneMutable :: (PrimMonad m, Element arr b) => Mutable arr (PrimState m) b -> Int -> Int -> m (Mutable arr (PrimState m) b) - equals :: (Element arr b, Eq b) => arr b -> arr b -> Bool - unlift :: arr b -> ArrayArray# - lift :: ArrayArray# -> arr b - sameMutable :: Mutable arr s a -> Mutable arr s a -> Bool - singleton :: Element arr a => a -> arr a - doubleton :: Element arr a => a -> a -> arr a - tripleton :: Element arr a => a -> a -> a -> arr a - rnf :: (NFData a, Element arr a) => arr a -> () - -instance Contiguous PrimArray where - type Mutable PrimArray = MutablePrimArray - type Element PrimArray = Prim - empty = mempty - new = newPrimArray - replicateM = replicatePrimArrayM - index = indexPrimArray - index# arr ix = (# indexPrimArray arr ix #) - indexM arr ix = return (indexPrimArray arr ix) - read = readPrimArray - write = writePrimArray - resize = resizeMutablePrimArray - size = sizeofPrimArray - sizeMutable = getSizeofMutablePrimArray - freeze = freezePrimArray - unsafeFreeze = unsafeFreezePrimArray - thaw = thawPrimArray - copy = copyPrimArray - copyMutable = copyMutablePrimArray - clone = clonePrimArray - cloneMutable = cloneMutablePrimArray - equals = (==) - unlift = toArrayArray# - lift = fromArrayArray# - null (PrimArray a) = case sizeofByteArray# a of - 0# -> True - _ -> False - sameMutable = sameMutablePrimArray - rnf (PrimArray !_) = () - singleton a = runST $ do - marr <- newPrimArray 1 - writePrimArray marr 0 a - unsafeFreezePrimArray marr - doubleton a b = runST $ do - m <- newPrimArray 2 - writePrimArray m 0 a - writePrimArray m 1 b - unsafeFreezePrimArray m - tripleton a b c = runST $ do - m <- newPrimArray 3 - writePrimArray m 0 a - writePrimArray m 1 b - writePrimArray m 2 c - unsafeFreezePrimArray m - -instance Contiguous Array where - type Mutable Array = MutableArray - type Element Array = Always - empty = mempty - new n = newArray n errorThunk - replicateM = newArray - index = indexArray - index# = indexArray## - indexM = indexArrayM - read = readArray - write = writeArray - resize = resizeArray - size = sizeofArray - sizeMutable = pure . sizeofMutableArray - freeze = freezeArray - unsafeFreeze = unsafeFreezeArray - thaw = thawArray - copy = copyArray - copyMutable = copyMutableArray - clone = cloneArray - cloneMutable = cloneMutableArray - equals = (==) - unlift = toArrayArray# - lift = fromArrayArray# - null (Array a) = case sizeofArray# a of - 0# -> True - _ -> False - sameMutable = sameMutableArray - rnf !ary = - let !sz = sizeofArray ary - go !i - | i == sz = () - | otherwise = - let !(# x #) = indexArray## ary i - in DS.rnf x `seq` go (i+1) - in go 0 - singleton a = runST (newArray 1 a >>= unsafeFreezeArray) - doubleton a b = runST $ do - m <- newArray 2 a - writeArray m 1 b - unsafeFreezeArray m - tripleton a b c = runST $ do - m <- newArray 3 a - writeArray m 1 b - writeArray m 2 c - unsafeFreezeArray m - -instance Contiguous UnliftedArray where - type Mutable UnliftedArray = MutableUnliftedArray - type Element UnliftedArray = PrimUnlifted - empty = emptyUnliftedArray - new = unsafeNewUnliftedArray - replicateM = newUnliftedArray - index = indexUnliftedArray - index# arr ix = (# indexUnliftedArray arr ix #) - indexM arr ix = return (indexUnliftedArray arr ix) - read = readUnliftedArray - write = writeUnliftedArray - resize = resizeUnliftedArray - size = sizeofUnliftedArray - sizeMutable = pure . sizeofMutableUnliftedArray - freeze = freezeUnliftedArray - unsafeFreeze = unsafeFreezeUnliftedArray - thaw = thawUnliftedArray - copy = copyUnliftedArray - copyMutable = copyMutableUnliftedArray - clone = cloneUnliftedArray - cloneMutable = cloneMutableUnliftedArray - equals = (==) - unlift = toArrayArray# - lift = fromArrayArray# - null (UnliftedArray a) = case sizeofArrayArray# a of - 0# -> True - _ -> False - sameMutable = sameMutableUnliftedArray - rnf !ary = - let !sz = sizeofUnliftedArray ary - go !i - | i == sz = () - | otherwise = - let x = indexUnliftedArray ary i - in DS.rnf x `seq` go (i+1) - in go 0 - singleton a = runST (newUnliftedArray 1 a >>= unsafeFreezeUnliftedArray) - doubleton a b = runST $ do - m <- newUnliftedArray 2 a - writeUnliftedArray m 1 b - unsafeFreezeUnliftedArray m - tripleton a b c = runST $ do - m <- newUnliftedArray 3 a - writeUnliftedArray m 1 b - writeUnliftedArray m 2 c - unsafeFreezeUnliftedArray m - -errorThunk :: a -errorThunk = error "Contiguous typeclass: unitialized element" -{-# NOINLINE errorThunk #-} - -freezePrimArray :: (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -> Int -> m (PrimArray a) -freezePrimArray !src !off !len = do - dst <- newPrimArray len - copyMutablePrimArray dst 0 src off len - unsafeFreezePrimArray dst -{-# INLINE freezePrimArray #-} - -resizeArray :: PrimMonad m => MutableArray (PrimState m) a -> Int -> m (MutableArray (PrimState m) a) -resizeArray !src !sz = do - dst <- newArray sz errorThunk - copyMutableArray dst 0 src 0 (min sz (sizeofMutableArray src)) - return dst -{-# INLINE resizeArray #-} - -resizeUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m (MutableUnliftedArray (PrimState m) a) -resizeUnliftedArray !src !sz = do - dst <- unsafeNewUnliftedArray sz - copyMutableUnliftedArray dst 0 src 0 (min sz (sizeofMutableUnliftedArray src)) - return dst -{-# INLINE resizeUnliftedArray #-} - -emptyUnliftedArray :: UnliftedArray a -emptyUnliftedArray = runST (unsafeNewUnliftedArray 0 >>= unsafeFreezeUnliftedArray) -{-# NOINLINE emptyUnliftedArray #-} - -append :: (Contiguous arr, Element arr a) => arr a -> arr a -> arr a -append !a !b = runST $ do - let !szA = size a - let !szB = size b - m <- new (szA + szB) - copy m 0 a 0 szA - copy m szA b 0 szB - unsafeFreeze m -{-# INLINABLE append #-} - --- | Map over the elements of an array with the index. -imap :: (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => (Int -> b -> c) -> arr1 b -> arr2 c -imap f a = runST $ do - mb <- new (size a) - let go !i - | i == size a = return () - | otherwise = do - x <- indexM a i - write mb i (f i x) - go (i+1) - go 0 - unsafeFreeze mb -{-# INLINABLE imap #-} - --- | Map over the elements of an array. -map :: (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => (b -> c) -> arr1 b -> arr2 c -map f a = runST $ do - mb <- new (size a) - let go !i - | i == size a = return () - | otherwise = do - x <- indexM a i - write mb i (f x) - go (i+1) - go 0 - unsafeFreeze mb -{-# INLINABLE map #-} - --- | Map strictly over the elements of an array. -map' :: (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => (b -> c) -> arr1 b -> arr2 c -map' f a = runST $ do - mb <- new (size a) - let go !i - | i == size a = return () - | otherwise = do - x <- indexM a i - let !b = f x - write mb i b - go (i+1) - go 0 - unsafeFreeze mb -{-# INLINE map' #-} - --- | Right fold over the element of an array. -foldr :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b -{-# INLINE foldr #-} -foldr f z arr = go 0 - where - !sz = size arr - go !i - | sz > i = case index# arr i of - (# x #) -> f x (go (i+1)) - | otherwise = z - --- | Strict left fold over the elements of an array. -foldl' :: (Contiguous arr, Element arr a) => (b -> a -> b) -> b -> arr a -> b -foldl' f !z !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (f acc x) - in go 0 z -{-# INLINE foldl' #-} - --- | Strict left fold over the elements of an array. -ifoldl' :: (Contiguous arr, Element arr a) => (b -> Int -> a -> b) -> b -> arr a -> b -ifoldl' f !z !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (f acc i x) - in go 0 z -{-# INLINE ifoldl' #-} - --- | Strict right fold over the elements of an array. -foldr' :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b -foldr' f !z !ary = - let - go i !acc - | i == -1 = acc - | (# x #) <- index# ary i - = go (i-1) (f x acc) - in go (size ary - 1) z -{-# INLINE foldr' #-} - --- | Monoidal fold over the element of an array. -foldMap :: (Contiguous arr, Element arr a, Monoid m) => (a -> m) -> arr a -> m -foldMap f arr = go 0 - where - !sz = size arr - go !i - | sz > i = case index# arr i of - (# x #) -> mappend (f x) (go (i+1)) - | otherwise = mempty -{-# INLINE foldMap #-} - --- | Strict monoidal fold over the elements of an array. -foldMap' :: (Contiguous arr, Element arr a, Monoid m) - => (a -> m) -> arr a -> m -foldMap' f !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (mappend acc (f x)) - in go 0 mempty -{-# INLINE foldMap' #-} - --- | Strict left monoidal fold over the elements of an array. -foldlMap' :: (Contiguous arr, Element arr a, Monoid m) - => (a -> m) -> arr a -> m -foldlMap' f !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (mappend acc (f x)) - in go 0 mempty -{-# INLINE foldlMap' #-} - --- | Strict monoidal fold over the elements of an array. -ifoldlMap' :: (Contiguous arr, Element arr a, Monoid m) - => (Int -> a -> m) - -> arr a - -> m -ifoldlMap' f !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (mappend acc (f i x)) - in go 0 mempty -{-# INLINE ifoldlMap' #-} - --- | Strict monoidal fold over the elements of an array. -ifoldlMap1' :: (Contiguous arr, Element arr a, Semigroup m) - => (Int -> a -> m) - -> arr a - -> m -ifoldlMap1' f !ary = - let - !sz = size ary - go !i !acc - | i == sz = acc - | (# x #) <- index# ary i = go (i+1) (acc <> f i x) - !(# e0 #) = index# ary 0 - in go 1 (f 0 e0) -{-# INLINE ifoldlMap1' #-} - --- | Strict left monadic fold over the elements of an array. -foldlM' :: (Contiguous arr, Element arr a, Monad m) => (b -> a -> m b) -> b -> arr a -> m b -foldlM' f z0 arr = go 0 z0 - where - !sz = size arr - go !i !acc1 - | i < sz = do - let (# x #) = index# arr i - acc2 <- f acc1 x - go (i + 1) acc2 - | otherwise = return acc1 -{-# INLINABLE foldlM' #-} - -thawPrimArray :: (PrimMonad m, Prim a) => PrimArray a -> Int -> Int -> m (MutablePrimArray (PrimState m) a) -thawPrimArray !arr !off !len = do - marr <- newPrimArray len - copyPrimArray marr 0 arr off len - return marr -{-# INLINE thawPrimArray #-} - -clonePrimArray :: Prim a => PrimArray a -> Int -> Int -> PrimArray a -clonePrimArray !arr !off !len = runST $ do - marr <- newPrimArray len - copyPrimArray marr 0 arr off len - unsafeFreezePrimArray marr -{-# INLINE clonePrimArray #-} - -cloneMutablePrimArray :: (PrimMonad m, Prim a) => MutablePrimArray (PrimState m) a -> Int -> Int -> m (MutablePrimArray (PrimState m) a) -cloneMutablePrimArray !arr !off !len = do - marr <- newPrimArray len - copyMutablePrimArray marr 0 arr off len - return marr -{-# INLINE cloneMutablePrimArray #-} - -replicatePrimArrayM :: (PrimMonad m, Prim a) - => Int -- ^ length - -> a -- ^ element - -> m (MutablePrimArray (PrimState m) a) -replicatePrimArrayM len a = do - marr <- newPrimArray len - setPrimArray marr 0 len a - return marr -{-# INLINE replicatePrimArrayM #-} - --- | Create an array from a list. If the given length does --- not match the actual length, this function has undefined --- behavior. -unsafeFromListN :: (Contiguous arr, Element arr a) - => Int -- ^ length of list - -> [a] -- ^ list - -> arr a -unsafeFromListN n l = runST $ do - m <- new n - let go !_ [] = return () - go !ix (x : xs) = do - write m ix x - go (ix+1) xs - go 0 l - unsafeFreeze m - --- | Create an array from a list, reversing the order of the --- elements. If the given length does not match the actual length, --- this function has undefined behavior. -unsafeFromListReverseN :: (Contiguous arr, Element arr a) - => Int - -> [a] - -> arr a -unsafeFromListReverseN n l = runST $ do - m <- new n - let go !_ [] = return () - go !ix (x : xs) = do - write m ix x - go (ix-1) xs - go (n - 1) l - unsafeFreeze m -{-# INLINE unsafeFromListReverseN #-} - --- | Strictly map over a mutable array, modifying the elements in place. -mapMutable' :: (PrimMonad m, Contiguous arr, Element arr a) - => (a -> a) - -> Mutable arr (PrimState m) a - -> m () -mapMutable' f = \ !mary -> do - !sz <- sizeMutable mary - let - go !i - | i == sz = pure () - | otherwise = do - a <- read mary i - let !b = f a - write mary i b - go (i + 1) - go 0 -{-# INLINE mapMutable' #-} - --- | Strictly map over a mutable array with indices, modifying the elements in place. -imapMutable' :: (PrimMonad m, Contiguous arr, Element arr a) - => (Int -> a -> a) - -> Mutable arr (PrimState m) a - -> m () -imapMutable' f = \ !mary -> do - !sz <- sizeMutable mary - let - go !i - | i == sz = pure () - | otherwise = do - a <- read mary i - let !b = f i a - write mary i b - go (i + 1) - go 0 -{-# INLINE imapMutable' #-} - -traverseP :: (PrimMonad m, Contiguous arr1, Contiguous arr2, Element arr1 a, Element arr2 b) - => (a -> m b) - -> arr1 a - -> m (arr2 b) -traverseP f = \ !ary -> - let - !sz = size ary - go !i !mary - | i == sz = unsafeFreeze mary - | otherwise = do - a <- indexM ary i - b <- f a - write mary i b - go (i + 1) mary - in do - mary <- new sz - go 0 mary -{-# INLINE traverseP #-} - -newtype STA v a = STA {_runSTA :: forall s. Mutable v s a -> ST s (v a)} - -runSTA :: (Contiguous v, Element v a) => Int -> STA v a -> v a -runSTA !sz = \ (STA m) -> runST $ new sz >>= \ ar -> m ar - -traverse :: (Contiguous arr, Element arr a, Element arr b, Applicative f) - => (a -> f b) - -> arr a - -> f (arr b) -traverse f = \ !ary -> - let - !len = size ary - go !i - | i == len = pure $ STA $ \mary -> unsafeFreeze mary - | (# x #) <- index# ary i - = liftA2 (\b (STA m) -> STA $ \mary -> - write mary i b >> m mary) - (f x) (go (i + 1)) - in if len == 0 - then pure empty - else runSTA len <$> go 0 - -traverse_ :: - (Contiguous arr, Element arr a, Applicative f) - => (a -> f b) - -> arr a - -> f () -traverse_ f a = go 0 where - !sz = size a - go !ix = if ix < sz - then f (index a ix) *> go (ix + 1) - else pure () -{-# INLINABLE traverse_ #-} - -itraverse_ :: - (Contiguous arr, Element arr a, Applicative f) - => (Int -> a -> f b) - -> arr a - -> f () -itraverse_ f a = go 0 where - !sz = size a - go !ix = if ix < sz - then f ix (index a ix) *> go (ix + 1) - else pure () -{-# INLINABLE itraverse_ #-} - -liftHashWithSalt :: (Contiguous arr, Element arr a) - => (Int -> a -> Int) - -> Int - -> arr a - -> Int -liftHashWithSalt f s0 arr = go 0 s0 where - sz = size arr - go !ix !s = if ix < sz - then - let !(# x #) = index# arr ix - in go (ix + 1) (f s x) - else hashIntWithSalt s ix -{-# INLINABLE liftHashWithSalt #-} - --- | This function does not behave deterministically. Optimization level and --- inlining can affect its results. However, the one thing that can be counted --- on is that if it returns @True@, the two immutable arrays are definitely the --- same. This is useful as shortcut for equality tests. However, keep in mind --- that a result of @False@ tells us nothing about the arguments. -same :: Contiguous arr => arr a -> arr a -> Bool -same a b = isTrue# (sameMutableArrayArray# (unsafeCoerce# (unlift a) :: MutableArrayArray# s) (unsafeCoerce# (unlift b) :: MutableArrayArray# s)) - -hashIntWithSalt :: Int -> Int -> Int -hashIntWithSalt salt x = salt `combine` x - -combine :: Int -> Int -> Int -combine h1 h2 = (h1 * 16777619) `xor` h2 - - +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | The contiguous package presents a common API to a number of contiguous +array types and their mutable counterparts. This is enabled with the +'Contiguous' typeclass, which parameterises over a contiguous array type and +defines the core operations. However, the stable part of the interface is +contained in this module, which combines those primitives into common, +efficient array algorithms suitable for replacing pointer-heavy list +manipulations. +-} +module Data.Primitive.Contiguous + ( -- * Accessors + + -- ** Length Information + size + , sizeMut + , null + + -- ** Indexing + , index + , index# + , read + + -- ** Monadic indexing + , indexM + + -- * Construction + + -- ** Initialisation + , empty + , new + , singleton + , doubleton + , tripleton + , quadrupleton + , quintupleton + , sextupleton + , replicate + , replicateMut + , generate + , generateM + , generateMutable + , iterateN + , iterateMutableN + , write + + -- ** Fixed Length + , construct1 + , construct2 + , construct3 + , construct4 + , construct5 + , construct6 + + -- ** Running + , run + + -- ** Monadic initialisation + , replicateMutM + , generateMutableM + , iterateMutableNM + , create + , createT + + -- ** Unfolding + , unfoldr + , unfoldrN + , unfoldrMutable + + -- ** Enumeration + , enumFromN + , enumFromMutableN + + -- ** Concatenation + , append + + -- ** Splitting and Splicing + , insertAt + + -- * Slicing + , Slice + , MutableSlice + , slice + , sliceMut + , toSlice + , toSliceMut + + -- * Modifying arrays + , replaceAt + , modifyAt + , modifyAt' + , modifyAtF + , modifyAtF' + , deleteAt + + -- ** Permutations + , reverse + , reverseMutable + , reverseSlice + + -- ** Resizing + , resize + , shrink + , unsafeShrinkAndFreeze + + -- * Elementwise operations + + -- ** Mapping + , map + , map' + , mapMutable + , mapMutable' + , imap + , imap' + , imapMutable + , imapMutable' + , modify + , modify' + , mapMaybe + + -- ** Zipping + , zip + , zipWith + , izipWith + + -- ** Specific elements + , swap + + -- * Working with predicates + + -- ** Filtering + , filter + , ifilter + , catMaybes + , lefts + , rights + , partitionEithers + + -- ** Searching + , find + , findIndex + , elem + , maximum + , minimum + , maximumBy + , minimumBy + + -- ** Comparing for equality + , equals + , equalsMut + , same + + -- * Folds + , foldl + , foldl' + , foldr + , foldr' + , foldMap + , foldMap' + , foldlMap' + , ifoldl' + , ifoldr + , ifoldr' + , ifoldlMap' + , ifoldlMap1' + , foldlM' + , ifoldlM' + , foldrM' + , asum + , all + , any + + -- ** Zipping Folds + , foldrZipWith + , ifoldrZipWith + , foldlZipWith' + , ifoldlZipWith' + , foldlZipWithM' + , ifoldlZipWithM' + + -- * Traversals + , traverse + , traverse_ + , itraverse + , itraverse_ + , traverseP + , itraverseP + , mapM + , forM + , mapM_ + , forM_ + , for + , for_ + , sequence + , sequence_ + + -- * Typeclass method defaults + , (<$) + , ap + + -- * Prefix sums (scans) + , scanl + , scanl' + , iscanl + , iscanl' + , prescanl + , prescanl' + , iprescanl + , iprescanl' + -- , postscanl + -- , ipostscanl + + , mapAccum' + , mapAccumLM' + + -- * Conversions + + -- ** Lists + , fromList + , fromListN + , fromListMutable + , fromListMutableN + , unsafeFromListN + , unsafeFromListReverseN + , unsafeFromListReverseMutableN + , toList + , toListMutable + + -- ** Other array types + , convert + , lift + , liftMut + , unlift + , unliftMut + + -- ** Between mutable and immutable variants + , clone + , cloneMut + , copy + , copyMut + , freeze + , thaw + , unsafeFreeze + + -- * Hashing + , liftHashWithSalt + + -- * Forcing an array and its contents + , rnf + + -- * Classes + , Contiguous (Mutable, Element, Sliced, MutableSliced) + , ContiguousU + , Always + + -- * Re-Exports + , Array + , MutableArray + , SmallArray + , SmallMutableArray + , PrimArray + , MutablePrimArray + , UnliftedArray + , MutableUnliftedArray + , SmallUnliftedArray + , SmallMutableUnliftedArray + ) where + +import Control.Monad.Primitive +import Data.Primitive +import Data.Primitive.Unlifted.Array +import Data.Primitive.Unlifted.SmallArray +import Prelude hiding (Foldable (..), all, any, filter, map, mapM, mapM_, read, replicate, reverse, scanl, sequence, sequence_, traverse, zip, zipWith, (<$)) + +import Control.Monad (when) +import Control.Monad.ST (ST, runST) +import Data.Bits (xor) +import Data.Coerce (coerce) +import Data.Foldable (length) +import Data.Primitive.Contiguous.Class (Always, Contiguous (..), ContiguousU (..), MutableSlice, Slice) +import Data.Semigroup (First (..)) +import Data.Word (Word8) +import GHC.Base (build) +import GHC.Exts (Int (..), MutableArrayArray#, dataToTag#, isTrue#, sameMutableArrayArray#, unsafeCoerce#) + +import qualified Control.Applicative as A +import qualified Prelude + +construct1 :: + (Contiguous arr, Element arr a) => + a -> + arr a +{-# INLINE construct1 #-} +construct1 = singleton + +construct2 :: + (Contiguous arr, Element arr a) => + a -> + a -> + arr a +{-# INLINE construct2 #-} +construct2 = doubleton + +construct3 :: + (Contiguous arr, Element arr a) => + a -> + a -> + a -> + arr a +{-# INLINE construct3 #-} +construct3 = tripleton + +construct4 :: + (Contiguous arr, Element arr a) => + a -> + a -> + a -> + a -> + arr a +{-# INLINE construct4 #-} +construct4 = quadrupleton + +construct5 :: + (Contiguous arr, Element arr a) => + a -> + a -> + a -> + a -> + a -> + arr a +{-# INLINE construct5 #-} +construct5 = quintupleton + +construct6 :: + (Contiguous arr, Element arr a) => + a -> + a -> + a -> + a -> + a -> + a -> + arr a +{-# INLINE construct6 #-} +construct6 = sextupleton + +-- | Append two arrays. +append :: (Contiguous arr, Element arr a) => arr a -> arr a -> arr a +append !a !b = run $ do + m <- new (size a + size b) + copy m 0 (toSlice a) + copy m (size a) (toSlice b) + unsafeFreeze m +{-# INLINE append #-} + +-- | Delete the element at the given position. +deleteAt :: (Contiguous arr, Element arr a) => arr a -> Int -> arr a +deleteAt src i = run $ do + dst <- thaw (slice src 0 (size src - 1)) + let !i' = i + 1 + copy dst i (slice src i' (size src - i')) + unsafeFreeze dst +{-# INLINE deleteAt #-} + +{- | Create a copy of an array except the element at the index is replaced with + the given value. +-} +replaceAt :: (Contiguous arr, Element arr a) => arr a -> Int -> a -> arr a +replaceAt src i x = create $ do + dst <- thaw (toSlice src) + write dst i x + pure dst +{-# INLINE replaceAt #-} + +modifyAt :: + (Contiguous arr, Element arr a) => + (a -> a) -> + arr a -> + Int -> + arr a +modifyAt f src i = replaceAt src i $ f (index src i) +{-# INLINE modifyAt #-} + +{- | Variant of modifyAt that forces the result before installing it in the +array. +-} +modifyAt' :: + (Contiguous arr, Element arr a) => + (a -> a) -> + arr a -> + Int -> + arr a +modifyAt' f src i = replaceAt src i $! f (index src i) +{-# INLINE modifyAt' #-} + +modifyAtF :: + (Contiguous arr, Element arr a, Functor f) => + (a -> f a) -> + arr a -> + Int -> + f (arr a) +modifyAtF f src i = replaceAt src i <$> f (index src i) +{-# INLINE modifyAtF #-} + +{- | Variant of modifyAtF that forces the result before installing it in the +array. Note that this requires 'Monad' rather than 'Functor'. +-} +modifyAtF' :: + (Contiguous arr, Element arr a, Monad f) => + (a -> f a) -> + arr a -> + Int -> + f (arr a) +modifyAtF' f src i = do + !r <- f (index src i) + let !dst = replaceAt src i r + pure dst +{-# INLINE modifyAtF' #-} + +-- | Map over the elements of an array with the index. +imap :: + (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => + (Int -> b -> c) -> + arr1 b -> + arr2 c +imap f a = run $ do + mb <- new (size a) + let go !i + | i == size a = pure () + | otherwise = do + x <- indexM a i + write mb i (f i x) + go (i + 1) + go 0 + unsafeFreeze mb +{-# INLINE imap #-} + +{- | Map strictly over the elements of an array with the index. + + Note that because a new array must be created, the resulting + array type can be /different/ than the original. +-} +imap' :: + (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => + (Int -> b -> c) -> + arr1 b -> + arr2 c +imap' f a = run $ do + mb <- new (size a) + let go !i + | i == size a = pure () + | otherwise = do + x <- indexM a i + let !b = f i x + write mb i b + go (i + 1) + go 0 + unsafeFreeze mb +{-# INLINE imap' #-} + +{- | Map over the elements of an array. + + Note that because a new array must be created, the resulting + array type can be /different/ than the original. +-} +map :: + (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => + (b -> c) -> + arr1 b -> + arr2 c +map f a = run $ do + mb <- new (size a) + let go !i + | i == size a = pure () + | otherwise = do + x <- indexM a i + write mb i (f x) + go (i + 1) + go 0 + unsafeFreeze mb +{-# INLINE map #-} + +{- | Map strictly over the elements of an array. + + Note that because a new array must be created, the resulting + array type can be /different/ than the original. +-} +map' :: + (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => + (b -> c) -> + arr1 b -> + arr2 c +map' f a = run $ do + mb <- new (size a) + let go !i + | i == size a = pure () + | otherwise = do + x <- indexM a i + let !b = f x + write mb i b + go (i + 1) + go 0 + unsafeFreeze mb +{-# INLINE map' #-} + +-- | Convert one type of array into another. +convert :: + (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 b) => + arr1 b -> + arr2 b +convert a = map id a +{-# INLINE convert #-} + +-- | Right fold over the element of an array. +foldr :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b +{-# INLINE foldr #-} +foldr f z = \arr -> + let !sz = size arr + go !ix = + if sz > ix + then case index# arr ix of + (# x #) -> f x (go (ix + 1)) + else z + in go 0 + +{- | Right fold over the element of an array, lazy in the accumulator, +provides index to the step function. +-} +ifoldr :: (Contiguous arr, Element arr a) => (Int -> a -> b -> b) -> b -> arr a -> b +{-# INLINE ifoldr #-} +ifoldr f z = \arr -> + let !sz = size arr + go !ix = + if sz > ix + then case index# arr ix of + (# x #) -> f ix x (go (ix + 1)) + else z + in go 0 + +-- | Strict right fold over the elements of an array. +foldr' :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b +foldr' f !z = \arr -> + let go !ix !acc = + if ix == -1 + then acc + else case index# arr ix of + (# x #) -> go (ix - 1) (f x acc) + in go (size arr - 1) z +{-# INLINE foldr' #-} + +-- | Left fold over the elements of an array. +foldl :: (Contiguous arr, Element arr a) => (b -> a -> b) -> b -> arr a -> b +foldl f z = \arr -> + let !sz = size arr + go !ix acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (f acc x) + in go 0 z +{-# INLINE foldl #-} + +-- | Strict left fold over the elements of an array. +foldl' :: (Contiguous arr, Element arr a) => (b -> a -> b) -> b -> arr a -> b +foldl' f !z = \arr -> + let !sz = size arr + go !ix !acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (f acc x) + in go 0 z +{-# INLINE foldl' #-} + +{- | Strict left fold over the elements of an array, where the accumulating + function cares about the index of the element. +-} +ifoldl' :: + (Contiguous arr, Element arr a) => + (b -> Int -> a -> b) -> + b -> + arr a -> + b +ifoldl' f !z = \arr -> + let !sz = size arr + go !ix !acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (f acc ix x) + in go 0 z +{-# INLINE ifoldl' #-} + +{- | Strict right fold over the elements of an array, where the accumulating + function cares about the index of the element. +-} +ifoldr' :: + (Contiguous arr, Element arr a) => + (Int -> a -> b -> b) -> + b -> + arr a -> + b +ifoldr' f !z = \arr -> + let !sz = size arr + go !ix !acc = + if ix == (-1) + then acc + else case index# arr ix of + (# x #) -> go (ix - 1) (f ix x acc) + in go (sz - 1) z +{-# INLINE ifoldr' #-} + +-- | Monoidal fold over the element of an array. +foldMap :: (Contiguous arr, Element arr a, Monoid m) => (a -> m) -> arr a -> m +foldMap f = \arr -> + let !sz = size arr + go !ix = + if sz > ix + then case index# arr ix of + (# x #) -> mappend (f x) (go (ix + 1)) + else mempty + in go 0 +{-# INLINE foldMap #-} + +-- | Strict monoidal fold over the elements of an array. +foldMap' :: + (Contiguous arr, Element arr a, Monoid m) => + (a -> m) -> + arr a -> + m +foldMap' f = \arr -> + let !sz = size arr + go !ix !acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (mappend acc (f x)) + in go 0 mempty +{-# INLINE foldMap' #-} + +-- | Strict left monoidal fold over the elements of an array. +foldlMap' :: + (Contiguous arr, Element arr a, Monoid m) => + (a -> m) -> + arr a -> + m +foldlMap' = foldMap' +{-# INLINE foldlMap' #-} + +-- | Strict monoidal fold over the elements of an array. +ifoldlMap' :: + (Contiguous arr, Element arr a, Monoid m) => + (Int -> a -> m) -> + arr a -> + m +ifoldlMap' f = \arr -> + let !sz = size arr + go !ix !acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (mappend acc (f ix x)) + in go 0 mempty +{-# INLINE ifoldlMap' #-} + +-- | Strict monoidal fold over the elements of an array. +ifoldlMap1' :: + (Contiguous arr, Element arr a, Semigroup m) => + (Int -> a -> m) -> + arr a -> + m +ifoldlMap1' f = \arr -> + let !sz = size arr + go !ix !acc = + if ix == sz + then acc + else case index# arr ix of + (# x #) -> go (ix + 1) (acc <> f ix x) + !(# e0 #) = index# arr 0 + in go 1 (f 0 e0) +{-# INLINE ifoldlMap1' #-} + +-- | Strict right monadic fold over the elements of an array. +foldrM' :: + (Contiguous arr, Element arr a, Monad m) => + (a -> b -> m b) -> + b -> + arr a -> + m b +foldrM' f !z0 = \arr -> + let !sz = size arr + go !ix !acc1 = + if ix >= 0 + then do + let (# x #) = index# arr ix + acc2 <- f x acc1 + go (ix - 1) acc2 + else pure acc1 + in go (sz - 1) z0 +{-# INLINE foldrM' #-} + +-- | Strict left monadic fold over the elements of an array. +foldlM' :: + (Contiguous arr, Element arr a, Monad m) => + (b -> a -> m b) -> + b -> + arr a -> + m b +foldlM' f !z0 = \arr -> + let !sz = size arr + go !ix !acc1 = + if ix < sz + then do + let (# x #) = index# arr ix + acc2 <- f acc1 x + go (ix + 1) acc2 + else pure acc1 + in go 0 z0 +{-# INLINE foldlM' #-} + +-- | Strict left monadic fold over the elements of an array. +ifoldlM' :: + (Contiguous arr, Element arr a, Monad m) => + (b -> Int -> a -> m b) -> + b -> + arr a -> + m b +ifoldlM' f z0 = \arr -> + let !sz = size arr + go !ix !acc1 = + if ix < sz + then do + let (# x #) = index# arr ix + acc2 <- f acc1 ix x + go (ix + 1) acc2 + else pure acc1 + in go 0 z0 +{-# INLINE ifoldlM' #-} + +-- | Drop elements that do not satisfy the predicate. +filter :: + (Contiguous arr, Element arr a) => + (a -> Bool) -> + arr a -> + arr a +filter p arr = ifilter (const p) arr +{-# INLINE filter #-} + +{- | Drop elements that do not satisfy the predicate which + is applied to values and their indices. +-} +ifilter :: + (Contiguous arr, Element arr a) => + (Int -> a -> Bool) -> + arr a -> + arr a +ifilter p arr = run $ do + marr :: MutablePrimArray s Word8 <- newPrimArray sz + let go1 :: Int -> Int -> ST s Int + go1 !ix !numTrue = + if ix < sz + then do + atIx <- indexM arr ix + let !keep = p ix atIx + let !keepTag = I# (dataToTag# keep) + writePrimArray marr ix (fromIntegral keepTag) + go1 (ix + 1) (numTrue + keepTag) + else pure numTrue + numTrue <- go1 0 0 + if numTrue == sz + then pure arr + else do + marrTrues <- new numTrue + let go2 !ixSrc !ixDst = when (ixDst < numTrue) $ do + atIxKeep <- readPrimArray marr ixSrc + if isTrue atIxKeep + then do + atIxVal <- indexM arr ixSrc + write marrTrues ixDst atIxVal + go2 (ixSrc + 1) (ixDst + 1) + else go2 (ixSrc + 1) ixDst + go2 0 0 + unsafeFreeze marrTrues + where + !sz = size arr +{-# INLINE ifilter #-} + +{- | The 'mapMaybe' function is a version of 'map' which can throw out elements. + In particular, the functional arguments returns something of type @'Maybe' b@. + If this is 'Nothing', no element is added on to the result array. If it is + @'Just' b@, then @b@ is included in the result array. +-} +mapMaybe :: + forall arr1 arr2 a b. + ( Contiguous arr1 + , Element arr1 a + , Contiguous arr2 + , Element arr2 b + ) => + (a -> Maybe b) -> + arr1 a -> + arr2 b +mapMaybe f arr = run $ do + let !sz = size arr + let go :: Int -> Int -> [b] -> ST s ([b], Int) + go !ix !numJusts !justs = + if ix < sz + then do + atIx <- indexM arr ix + case f atIx of + Nothing -> go (ix + 1) numJusts justs + Just x -> go (ix + 1) (numJusts + 1) (x : justs) + else pure (justs, numJusts) + !(bs, !numJusts) <- go 0 0 [] + !marr <- unsafeFromListReverseMutableN numJusts bs + unsafeFreeze marr +{-# INLINE mapMaybe #-} + +{-# INLINE isTrue #-} +isTrue :: Word8 -> Bool +isTrue 0 = False +isTrue _ = True + +{- | The 'catMaybes' function takes a list of 'Maybe's and returns a + list of all the 'Just' values. +-} +catMaybes :: + (Contiguous arr, Element arr a, Element arr (Maybe a)) => + arr (Maybe a) -> + arr a +catMaybes = mapMaybe id +{-# INLINE catMaybes #-} + +-- | @'replicate' n x@ is an array of length @n@ with @x@ the value of every element. +replicate :: (Contiguous arr, Element arr a) => Int -> a -> arr a +replicate n x = create (replicateMut n x) +{-# INLINE replicate #-} + +-- | @'replicateMutM' n act@ performs the action n times, gathering the results. +replicateMutM :: + (PrimMonad m, Contiguous arr, Element arr a) => + Int -> + m a -> + m (Mutable arr (PrimState m) a) +replicateMutM len act = do + marr <- new len + let go !ix = when (ix < len) $ do + x <- act + write marr ix x + go (ix + 1) + go 0 + pure marr +{-# INLINE replicateMutM #-} + +{- | Create an array from a list. If the given length does +not match the actual length, this function has undefined +behavior. +-} +unsafeFromListN :: + (Contiguous arr, Element arr a) => + -- | length of list + Int -> + -- | list + [a] -> + arr a +unsafeFromListN n l = create (unsafeFromListMutableN n l) +{-# INLINE unsafeFromListN #-} + +unsafeFromListMutableN :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + [a] -> + m (Mutable arr (PrimState m) a) +unsafeFromListMutableN n l = do + m <- new n + let go !_ [] = pure m + go !ix (x : xs) = do + write m ix x + go (ix + 1) xs + go 0 l +{-# INLINE unsafeFromListMutableN #-} + +{- | Create a mutable array from a list, reversing the order of + the elements. If the given length does not match the actual length, + this function has undefined behavior. +-} +unsafeFromListReverseMutableN :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + [a] -> + m (Mutable arr (PrimState m) a) +unsafeFromListReverseMutableN n l = do + m <- new n + let go !_ [] = pure m + go !ix (x : xs) = do + write m ix x + go (ix - 1) xs + go (n - 1) l +{-# INLINE unsafeFromListReverseMutableN #-} + +{- | Create an array from a list, reversing the order of the +elements. If the given length does not match the actual length, +this function has undefined behavior. +-} +unsafeFromListReverseN :: + (Contiguous arr, Element arr a) => + Int -> + [a] -> + arr a +unsafeFromListReverseN n l = create (unsafeFromListReverseMutableN n l) +{-# INLINE unsafeFromListReverseN #-} + +-- | Map over a mutable array, modifying the elements in place. +mapMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + (a -> a) -> + Mutable arr (PrimState m) a -> + m () +mapMutable f !marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + a <- read marr ix + write marr ix (f a) + go (ix + 1) + go 0 +{-# INLINE mapMutable #-} + +-- | Strictly map over a mutable array, modifying the elements in place. +mapMutable' :: + (PrimMonad m, Contiguous arr, Element arr a) => + (a -> a) -> + Mutable arr (PrimState m) a -> + m () +mapMutable' f !marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + a <- read marr ix + let !b = f a + write marr ix b + go (ix + 1) + go 0 +{-# INLINE mapMutable' #-} + +-- | Map over a mutable array with indices, modifying the elements in place. +imapMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + (Int -> a -> a) -> + Mutable arr (PrimState m) a -> + m () +imapMutable f !marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + a <- read marr ix + write marr ix (f ix a) + go (ix + 1) + go 0 +{-# INLINE imapMutable #-} + +-- | Strictly map over a mutable array with indices, modifying the elements in place. +imapMutable' :: + (PrimMonad m, Contiguous arr, Element arr a) => + (Int -> a -> a) -> + Mutable arr (PrimState m) a -> + m () +imapMutable' f !marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + a <- read marr ix + let !b = f ix a + write marr ix b + go (ix + 1) + go 0 +{-# INLINE imapMutable' #-} + +{- | Map each element of the array to an action, evaluate these + actions from left to right, and collect the results in a + new array. +-} +traverseP :: + ( PrimMonad m + , Contiguous arr1 + , Element arr1 a + , Contiguous arr2 + , Element arr2 b + ) => + (a -> m b) -> + arr1 a -> + m (arr2 b) +traverseP f !arr = do + let !sz = size arr + !marr <- new sz + let go !ix = when (ix < sz) $ do + a <- indexM arr ix + b <- f a + write marr ix b + go (ix + 1) + go 0 + unsafeFreeze marr +{-# INLINE traverseP #-} + +{- | Map each element of the array to an action, evaluate these + actions from left to right, and collect the results in a + new array. +-} +itraverseP :: + ( PrimMonad m + , Contiguous arr1 + , Element arr1 a + , Contiguous arr2 + , Element arr2 b + ) => + (Int -> a -> m b) -> + arr1 a -> + m (arr2 b) +itraverseP f !arr = do + let !sz = size arr + !marr <- new sz + let go !ix = when (ix < sz) $ do + a <- indexM arr ix + b <- f ix a + write marr ix b + go (ix + 1) + go 0 + unsafeFreeze marr +{-# INLINE itraverseP #-} + +newtype STA v a = STA {_runSTA :: forall s. Mutable v s a -> ST s (v a)} + +runSTA :: (Contiguous v, Element v a) => Int -> STA v a -> v a +runSTA !sz (STA m) = runST $ new sz >>= m +{-# INLINE runSTA #-} + +{- | Map each element of the array to an action, evaluate these + actions from left to right, and collect the results. + For a version that ignores the results, see 'traverse_'. +-} +traverse :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Applicative f + ) => + (a -> f b) -> + arr1 a -> + f (arr2 b) +traverse f = itraverse (const f) +{-# INLINE traverse #-} + +{- | Map each element of the array to an action, evaluate these + actions from left to right, and ignore the results. + For a version that doesn't ignore the results, see 'traverse'. +-} +traverse_ :: + (Contiguous arr, Element arr a, Applicative f) => + (a -> f b) -> + arr a -> + f () +traverse_ f = itraverse_ (const f) + +{- | Map each element of the array and its index to an action, + evaluating these actions from left to right. +-} +itraverse :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Applicative f + ) => + (Int -> a -> f b) -> + arr1 a -> + f (arr2 b) +itraverse f = \arr -> + let !sz = size arr + go !ix = + if ix == sz + then pure (STA unsafeFreeze) + else case index# arr ix of + (# x #) -> + A.liftA2 + ( \b (STA m) -> STA $ \marr -> do + write marr ix b + m marr + ) + (f ix x) + (go (ix + 1)) + in if sz == 0 + then pure empty + else runSTA sz <$> go 0 +{-# INLINE itraverse #-} + +{- | Map each element of the array and its index to an action, + evaluate these actions from left to right, and ignore the results. + For a version that doesn't ignore the results, see 'itraverse'. +-} +itraverse_ :: + (Contiguous arr, Element arr a, Applicative f) => + (Int -> a -> f b) -> + arr a -> + f () +itraverse_ f = \arr -> + let !sz = size arr + go !ix = + when (ix < sz) $ + f ix (index arr ix) *> go (ix + 1) + in go 0 +{-# INLINE itraverse_ #-} + +{- | 'for' is 'traverse' with its arguments flipped. For a version + that ignores the results see 'for_'. +-} +for :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Applicative f + ) => + arr1 a -> + (a -> f b) -> + f (arr2 b) +for = flip traverse +{-# INLINE for #-} + +{- | 'for_' is 'traverse_' with its arguments flipped. For a version + that doesn't ignore the results see 'for'. + + >>> for_ (C.fromList [1..4] :: PrimArray Int) print + 1 + 2 + 3 + 4 +-} +for_ :: + (Contiguous arr, Element arr a, Applicative f) => + arr a -> + (a -> f b) -> + f () +for_ = flip traverse_ +{-# INLINE for_ #-} + +{- | Monadic accumulating strict left fold over the elements on an +array. +-} +mapAccumLM' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 b + , Element arr2 c + , Monad m + ) => + (a -> b -> m (a, c)) -> + a -> + arr1 b -> + m (a, arr2 c) +{-# INLINE mapAccumLM' #-} +mapAccumLM' f a0 src = go 0 [] a0 + where + !sz = size src + go !ix !xs !acc = + if ix < sz + then do + (!acc', !x) <- f acc (index src ix) + go (ix + 1) (x : xs) acc' + else + let !xs' = unsafeFromListReverseN sz xs + in pure (acc, xs') + +mapAccum' :: + forall arr1 arr2 a b c. + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 b + , Element arr2 c + , Monoid a + ) => + (b -> (a, c)) -> + arr1 b -> + (a, arr2 c) +{-# INLINE mapAccum' #-} +mapAccum' f !src = runST $ do + dst <- new sz + acc <- go 0 dst mempty + dst' <- unsafeFreeze dst + pure (acc, dst') + where + !sz = size src + go :: Int -> Mutable arr2 s c -> a -> ST s a + go !ix !dst !accA = + if ix < sz + then do + let (!accB, !x) = f (index src ix) + write dst ix x + go (ix + 1) dst (accA <> accB) + else pure accA + +{- | Map each element of a structure to a monadic action, + evaluate these actions from left to right, and collect + the results. for a version that ignores the results see + 'mapM_'. +-} +mapM :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Monad m + ) => + (a -> m b) -> + arr1 a -> + m (arr2 b) +mapM f arr = + let !sz = size arr + in generateM sz $ \ix -> indexM arr ix >>= f +{-# INLINE mapM #-} + +{- | Map each element of a structure to a monadic action, + evaluate these actions from left to right, and ignore + the results. For a version that doesn't ignore the results + see 'mapM'. + + 'mapM_' = 'traverse_' +-} +mapM_ :: + (Contiguous arr, Element arr a, Element arr b, Applicative f) => + (a -> f b) -> + arr a -> + f () +mapM_ = traverse_ +{-# INLINE mapM_ #-} + +{- | 'forM' is 'mapM' with its arguments flipped. For a version that + ignores its results, see 'forM_'. +-} +forM :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Monad m + ) => + arr1 a -> + (a -> m b) -> + m (arr2 b) +forM = flip mapM +{-# INLINE forM #-} + +{- | 'forM_' is 'mapM_' with its arguments flipped. For a version that + doesn't ignore its results, see 'forM'. +-} +forM_ :: + (Contiguous arr, Element arr a, Element arr b, Applicative f) => + arr a -> + (a -> f b) -> + f () +forM_ = flip traverse_ +{-# INLINE forM_ #-} + +{- | Evaluate each action in the structure from left to right + and collect the results. For a version that ignores the + results see 'sequence_'. +-} +sequence :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 (f a) + , Element arr2 a + , Applicative f + ) => + arr1 (f a) -> + f (arr2 a) +sequence = traverse id +{-# INLINE sequence #-} + +{- | Evaluate each action in the structure from left to right + and ignore the results. For a version that doesn't ignore + the results see 'sequence'. +-} +sequence_ :: + ( Contiguous arr + , Element arr (f a) + , Applicative f + ) => + arr (f a) -> + f () +sequence_ = foldr (*>) (pure ()) +{-# INLINE sequence_ #-} + +{- | The sum of a collection of actions, generalizing 'concat'. + + >>> asum (C.fromList ['Just' "Hello", 'Nothing', Just "World"] :: Array String) + Just "Hello" +-} +asum :: + ( Contiguous arr + , Element arr (f a) + , A.Alternative f + ) => + arr (f a) -> + f a +asum = foldr (A.<|>) A.empty +{-# INLINE asum #-} + +{- | Construct an array of the given length by applying + the function to each index. +-} +generate :: + (Contiguous arr, Element arr a) => + Int -> + (Int -> a) -> + arr a +generate len f = create (generateMutable len f) +{-# INLINE generate #-} + +{- | Construct an array of the given length by applying + the monadic action to each index. +-} +generateM :: + (Contiguous arr, Element arr a, Monad m) => + Int -> + (Int -> m a) -> + m (arr a) +{-# INLINE generateM #-} +generateM !sz f = + let go !ix = + if ix < sz + then + A.liftA2 + ( \b (STA m) -> STA $ \marr -> do + write marr ix b + m marr + ) + (f ix) + (go (ix + 1)) + else pure $ STA unsafeFreeze + in if sz == 0 + then pure empty + else runSTA sz <$> go 0 + +{- | Construct a mutable array of the given length by applying + the function to each index. +-} +generateMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + (Int -> a) -> + m (Mutable arr (PrimState m) a) +generateMutable len f = generateMutableM len (pure . f) +{-# INLINE generateMutable #-} + +{- | Construct a mutable array of the given length by applying + the monadic action to each index. +-} +generateMutableM :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + (Int -> m a) -> + m (Mutable arr (PrimState m) a) +generateMutableM !len f = do + marr <- new len + let go !ix = when (ix < len) $ do + x <- f ix + write marr ix x + go (ix + 1) + go 0 + pure marr +{-# INLINE generateMutableM #-} + +{- | Apply a function @n@ times to a value and construct an array + where each consecutive element is the result of an additional + application of this function. The zeroth element is the original value. + + @'iterateN' 5 ('+' 1) 0 = 'fromListN' 5 [0,1,2,3,4]@ +-} +iterateN :: + (Contiguous arr, Element arr a) => + Int -> + (a -> a) -> + a -> + arr a +iterateN len f z0 = runST (iterateMutableN len f z0 >>= unsafeFreeze) +{-# INLINE iterateN #-} + +{- | Apply a function @n@ times to a value and construct a mutable array + where each consecutive element is the result of an additional + application of this function. The zeroth element is the original value. +-} +iterateMutableN :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + (a -> a) -> + a -> + m (Mutable arr (PrimState m) a) +iterateMutableN len f z0 = iterateMutableNM len (pure . f) z0 +{-# INLINE iterateMutableN #-} + +{- | Apply a monadic function @n@ times to a value and construct a mutable array + where each consecutive element is the result of an additional + application of this function. The zeroth element is the original value. +-} +iterateMutableNM :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + (a -> m a) -> + a -> + m (Mutable arr (PrimState m) a) +iterateMutableNM !len f z0 = do + marr <- new len + -- we are strict in the accumulator because + -- otherwise we could build up a ton of `f (f (f (f .. (f a))))` + -- thunks for no reason. + let go !ix !acc + | ix <= 0 = write marr ix z0 >> go (ix + 1) z0 + | ix == len = pure () + | otherwise = do + a <- f acc + write marr ix a + go (ix + 1) a + go 0 z0 + pure marr +{-# INLINE iterateMutableNM #-} + +-- | Execute the monad action and freeze the resulting array. +create :: + (Contiguous arr, Element arr a) => + (forall s. ST s (Mutable arr s a)) -> + arr a +create x = run (unsafeFreeze =<< x) +{-# INLINE create #-} + +-- | Execute the monadic action and freeze the resulting array. +createT :: + (Contiguous arr, Element arr a, Traversable f) => + (forall s. ST s (f (Mutable arr s a))) -> + f (arr a) +createT p = runST (Prelude.mapM unsafeFreeze =<< p) +{-# INLINE createT #-} + +{- | Construct an array by repeatedly applying a generator + function to a seed. The generator function yields 'Just' the + next element and the new seed or 'Nothing' if there are no more + elements. + +>>> unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1) 10 + <10,9,8,7,6,5,4,3,2,1> +-} + +-- Unfortunately, because we don't know ahead of time when to stop, +-- we need to construct a list and then turn it into an array. +unfoldr :: + (Contiguous arr, Element arr a) => + (b -> Maybe (a, b)) -> + b -> + arr a +unfoldr f z0 = create (unfoldrMutable f z0) +{-# INLINE unfoldr #-} + +{- | Construct a mutable array by repeatedly applying a generator + function to a seed. The generator function yields 'Just' the + next element and the new seed or 'Nothing' if there are no more + elements. + +>>> unfoldrMutable (\n -> if n == 0 then Nothing else Just (n,n-1) 10 + <10,9,8,7,6,5,4,3,2,1> +-} + +-- Unfortunately, because we don't know ahead of time when to stop, +-- we need to construct a list and then turn it into an array. +unfoldrMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + (b -> Maybe (a, b)) -> + b -> + m (Mutable arr (PrimState m) a) +unfoldrMutable f z0 = do + let go !sz s !xs = case f s of + Nothing -> pure (sz, xs) + Just (x, s') -> go (sz + 1) s' (x : xs) + (sz, xs) <- go 0 z0 [] + unsafeFromListReverseMutableN sz xs +{-# INLINE unfoldrMutable #-} + +{- | Construct an array with at most n elements by repeatedly + applying the generator function to a seed. The generator function + yields 'Just' the next element and the new seed or 'Nothing' if + there are no more elements. +-} +unfoldrN :: + (Contiguous arr, Element arr a) => + Int -> + (b -> Maybe (a, b)) -> + b -> + arr a +unfoldrN maxSz f z0 = create (unfoldrMutableN maxSz f z0) +{-# INLINE unfoldrN #-} + +{- | Construct a mutable array with at most n elements by repeatedly + applying the generator function to a seed. The generator function + yields 'Just' the next element and the new seed or 'Nothing' if + there are no more elements. +-} +unfoldrMutableN :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + (b -> Maybe (a, b)) -> + b -> + m (Mutable arr (PrimState m) a) +unfoldrMutableN !maxSz f z0 = do + m <- new maxSz + let go !ix s = + if ix < maxSz + then case f s of + Nothing -> pure ix + Just (x, s') -> do + write m ix x + go (ix + 1) s' + else pure ix + sz <- go 0 z0 + shrink m sz +{-# INLINE unfoldrMutableN #-} + +-- | Convert an array to a list. +toList :: + (Contiguous arr, Element arr a) => + arr a -> + [a] +toList arr = build (\c n -> foldr c n arr) +{-# INLINE toList #-} + +-- | Convert a mutable array to a list. + +-- I don't think this can be expressed in terms of foldr/build, +-- so we just loop through the array. +toListMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + Mutable arr (PrimState m) a -> + m [a] +toListMutable marr = do + sz <- sizeMut marr + let go !ix !acc = + if ix >= 0 + then do + x <- read marr ix + go (ix - 1) (x : acc) + else pure acc + go (sz - 1) [] +{-# INLINE toListMutable #-} + +{- | Given an 'Int' that is representative of the length of + the list, convert the list into a mutable array of the + given length. + + /Note/: calls 'error' if the given length is incorrect. +-} +fromListMutableN :: + (Contiguous arr, Element arr a, PrimMonad m) => + Int -> + [a] -> + m (Mutable arr (PrimState m) a) +fromListMutableN len vs = do + marr <- new len + let go [] !ix = + if ix == len + then pure () + else error "Data.Primitive.Contiguous.fromListN: list length less than specified size." + go (a : as) !ix = + if ix < len + then do + write marr ix a + go as (ix + 1) + else error "Data.Primitive.Contiguous.fromListN: list length greater than specified size." + go vs 0 + pure marr +{-# INLINE fromListMutableN #-} + +-- | Convert a list into a mutable array of the given length. +fromListMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + [a] -> + m (Mutable arr (PrimState m) a) +fromListMutable xs = fromListMutableN (length xs) xs +{-# INLINE fromListMutable #-} + +{- | Given an 'Int' that is representative of the length of + the list, convert the list into a mutable array of the + given length. + + /Note/: calls 'error' if the given length is incorrect. +-} +fromListN :: + (Contiguous arr, Element arr a) => + Int -> + [a] -> + arr a +fromListN len vs = create (fromListMutableN len vs) +{-# INLINE fromListN #-} + +-- | Convert a list into an array. +fromList :: + (Contiguous arr, Element arr a) => + [a] -> + arr a +fromList vs = create (fromListMutable vs) +{-# INLINE fromList #-} + +-- | Modify the elements of a mutable array in-place. +modify :: + (Contiguous arr, Element arr a, PrimMonad m) => + (a -> a) -> + Mutable arr (PrimState m) a -> + m () +modify f marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + x <- read marr ix + write marr ix (f x) + go (ix + 1) + go 0 +{-# INLINE modify #-} + +-- | Strictly modify the elements of a mutable array in-place. +modify' :: + (Contiguous arr, Element arr a, PrimMonad m) => + (a -> a) -> + Mutable arr (PrimState m) a -> + m () +modify' f marr = do + !sz <- sizeMut marr + let go !ix = when (ix < sz) $ do + x <- read marr ix + let !y = f x + write marr ix y + go (ix + 1) + go 0 +{-# INLINE modify' #-} + +{- | Yield an array of the given length containing the values + @x, 'succ' x, 'succ' ('succ' x)@ etc. +-} +enumFromN :: + (Contiguous arr, Element arr a, Enum a) => + a -> + Int -> + arr a +enumFromN z0 sz = create (enumFromMutableN z0 sz) +{-# INLINE enumFromN #-} + +{- | Yield a mutable array of the given length containing the values + @x, 'succ' x, 'succ' ('succ' x)@ etc. +-} +enumFromMutableN :: + (Contiguous arr, Element arr a, PrimMonad m, Enum a) => + a -> + Int -> + m (Mutable arr (PrimState m) a) +enumFromMutableN z0 !sz = do + m <- new sz + let go !ix z = + if ix < sz + then do + write m ix z + go (ix + 1) (succ z) + else pure m + go 0 z0 +{-# INLINE enumFromMutableN #-} + +{- | Lift an accumulating hash function over the elements of the array, + returning the final accumulated hash. +-} +liftHashWithSalt :: + (Contiguous arr, Element arr a) => + (Int -> a -> Int) -> + Int -> + arr a -> + Int +liftHashWithSalt f s0 arr = go 0 s0 + where + sz = size arr + go !ix !s = + if ix < sz + then + let !(# x #) = index# arr ix + in go (ix + 1) (f s x) + else hashIntWithSalt s ix +{-# INLINE liftHashWithSalt #-} + +-- | Reverse the elements of an array. +reverse :: + (Contiguous arr, Element arr a) => + arr a -> + arr a +reverse arr = run $ do + marr <- new (size arr) + copy marr 0 (toSlice arr) + reverseMutable marr + unsafeFreeze marr +{-# INLINE reverse #-} + +-- | Reverse the elements of a mutable array, in-place. +reverseMutable :: + (Contiguous arr, Element arr a, PrimMonad m) => + Mutable arr (PrimState m) a -> + m () +reverseMutable marr = do + !sz <- sizeMut marr + reverseSlice marr 0 (sz - 1) +{-# INLINE reverseMutable #-} + +-- | Reverse the elements of a slice of a mutable array, in-place. +reverseSlice :: + (Contiguous arr, Element arr a, PrimMonad m) => + Mutable arr (PrimState m) a -> + -- | start index + Int -> + -- | end index + Int -> + m () +reverseSlice !marr !start !end = do + let go !s !e = + if s >= e + then pure () + else do + tmp <- read marr s + write marr s =<< read marr e + write marr e tmp + go (s + 1) (e - 1) + go start end +{-# INLINE reverseSlice #-} + +{- | This function does not behave deterministically. Optimization level and +inlining can affect its results. However, the one thing that can be counted +on is that if it returns 'True', the two immutable arrays are definitely the +same. This is useful as shortcut for equality tests. However, keep in mind +that a result of 'False' tells us nothing about the arguments. +-} +same :: (ContiguousU arr) => arr a -> arr a -> Bool +same a b = + isTrue# + ( sameMutableArrayArray# + (unsafeCoerce# (unlift a) :: MutableArrayArray# s) + (unsafeCoerce# (unlift b) :: MutableArrayArray# s) + ) + +hashIntWithSalt :: Int -> Int -> Int +hashIntWithSalt salt x = salt `combine` x +{-# INLINE hashIntWithSalt #-} + +combine :: Int -> Int -> Int +combine h1 h2 = (h1 * 16777619) `xor` h2 +{-# INLINE combine #-} + +-- | Does the element occur in the structure? +elem :: (Contiguous arr, Element arr a, Eq a) => a -> arr a -> Bool +elem a !arr = + let !sz = size arr + go !ix + | ix < sz = case index# arr ix of + !(# x #) -> + if a == x + then True + else go (ix + 1) + | otherwise = False + in go 0 +{-# INLINE elem #-} + +-- | The largest element of a structure. +maximum :: (Contiguous arr, Element arr a, Ord a) => arr a -> Maybe a +maximum = maximumBy compare +{-# INLINE maximum #-} + +-- | The least element of a structure. +minimum :: (Contiguous arr, Element arr a, Ord a) => arr a -> Maybe a +minimum = minimumBy compare +{-# INLINE minimum #-} + +{- | The largest element of a structure with respect to the + given comparison function. +-} +maximumBy :: + (Contiguous arr, Element arr a) => + (a -> a -> Ordering) -> + arr a -> + Maybe a +maximumBy f arr = + let !sz = size arr + go !ix o = + if ix < sz + then case index# arr ix of + !(# x #) -> go (ix + 1) (case f x o of GT -> x; _ -> o) + else o + in if sz == 0 + then Nothing + else Just (go 0 (index arr 0)) +{-# INLINE maximumBy #-} + +{- | The least element of a structure with respect to the + given comparison function. +-} +minimumBy :: + (Contiguous arr, Element arr a) => + (a -> a -> Ordering) -> + arr a -> + Maybe a +minimumBy f arr = + let !sz = size arr + go !ix o = + if ix < sz + then case index# arr ix of + !(# x #) -> go (ix + 1) (case f x o of GT -> o; _ -> x) + else o + in if sz == 0 + then Nothing + else Just (go 0 (index arr 0)) +{-# INLINE minimumBy #-} + +{- | 'find' takes a predicate and an array, and returns the leftmost + element of the array matching the prediate, or 'Nothing' if there + is no such element. +-} +find :: + (Contiguous arr, Element arr a) => + (a -> Bool) -> + arr a -> + Maybe a +find p = coerce . (foldMap (\x -> if p x then Just (First x) else Nothing)) +{-# INLINE find #-} + +{- | 'findIndex' takes a predicate and an array, and returns the index of + the leftmost element of the array matching the prediate, or 'Nothing' + if there is no such element. +-} +findIndex :: + (Contiguous arr, Element arr a) => + (a -> Bool) -> + arr a -> + Maybe Int +findIndex p xs = loop 0 + where + loop i + | i < size xs = if p (index xs i) then Just i else loop (i + 1) + | otherwise = Nothing +{-# INLINE findIndex #-} + +-- | Swap the elements of the mutable array at the given indices. +swap :: + (Contiguous arr, Element arr a, PrimMonad m) => + Mutable arr (PrimState m) a -> + Int -> + Int -> + m () +swap !marr !ix1 !ix2 = do + atIx1 <- read marr ix1 + atIx2 <- read marr ix2 + write marr ix1 atIx2 + write marr ix2 atIx1 +{-# INLINE swap #-} + +{- | Extracts from an array of 'Either' all the 'Left' elements. +All the 'Left' elements are extracted in order. +-} +lefts :: + forall arr a b. + ( Contiguous arr + , Element arr a + , Element arr (Either a b) + ) => + arr (Either a b) -> + arr a +lefts !arr = create $ do + let !sz = size arr + go :: Int -> [a] -> Int -> ST s (Int, [a]) + go !ix !as !acc = + if ix < sz + then do + indexM arr ix >>= \case + Left a -> go (ix + 1) (a : as) (acc + 1) + Right _ -> go (ix + 1) as acc + else pure (acc, as) + (len, as) <- go 0 [] 0 + unsafeFromListReverseMutableN len as +{-# INLINE lefts #-} + +{- | Extracts from an array of 'Either' all the 'Right' elements. +All the 'Right' elements are extracted in order. +-} +rights :: + forall arr a b. + ( Contiguous arr + , Element arr b + , Element arr (Either a b) + ) => + arr (Either a b) -> + arr b +rights !arr = create $ do + let !sz = size arr + go :: Int -> [b] -> Int -> ST s (Int, [b]) + go !ix !bs !acc = + if ix < sz + then do + indexM arr ix >>= \case + Left _ -> go (ix + 1) bs acc + Right b -> go (ix + 1) (b : bs) (acc + 1) + else pure (acc, bs) + (len, bs) <- go 0 [] 0 + unsafeFromListReverseMutableN len bs +{-# INLINE rights #-} + +{- | Partitions an array of 'Either' into two arrays. +All the 'Left' elements are extracted, in order, to the first +component of the output. Similarly the 'Right' elements are extracted +to the second component of the output. +-} +partitionEithers :: + forall arr a b. + ( Contiguous arr + , Element arr a + , Element arr b + , Element arr (Either a b) + ) => + arr (Either a b) -> + (arr a, arr b) +partitionEithers !arr = runST $ do + let !sz = size arr + go :: Int -> [a] -> [b] -> Int -> Int -> ST s (Int, Int, [a], [b]) + go !ix !as !bs !accA !accB = + if ix < sz + then do + indexM arr ix >>= \case + Left a -> go (ix + 1) (a : as) bs (accA + 1) accB + Right b -> go (ix + 1) as (b : bs) accA (accB + 1) + else pure (accA, accB, as, bs) + (lenA, lenB, as, bs) <- go 0 [] [] 0 0 + arrA <- unsafeFreeze =<< unsafeFromListReverseMutableN lenA as + arrB <- unsafeFreeze =<< unsafeFromListReverseMutableN lenB bs + pure (arrA, arrB) +{-# INLINE partitionEithers #-} + +{- | 'scanl' is similar to 'foldl', but returns an array of + successive reduced values from the left: + + > scanl f z [x1, x2, ...] = [z, f z x1, f (f z x1) x2, ...] + + Note that + + > last (toList (scanl f z xs)) == foldl f z xs. +-} +scanl :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (b -> a -> b) -> + b -> + arr1 a -> + arr2 b +scanl f = iscanl (const f) +{-# INLINE scanl #-} + +{- | A variant of 'scanl' whose function argument takes the current + index as an argument. +-} +iscanl :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +iscanl f q as = internalScanl (size as + 1) f q as +{-# INLINE iscanl #-} + +-- | A strictly accumulating version of 'scanl'. +scanl' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (b -> a -> b) -> + b -> + arr1 a -> + arr2 b +scanl' f = iscanl' (const f) +{-# INLINE scanl' #-} + +-- | A strictly accumulating version of 'iscanl'. +iscanl' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +iscanl' f !q as = internalScanl' (size as + 1) f q as +{-# INLINE iscanl' #-} + +-- Internal only. The first argument is the size of the array +-- argument. This function helps prevent duplication. +internalScanl :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + Int -> + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +internalScanl !sz f !q as = create $ do + !marr <- new sz + let go !ix acc = when (ix < sz) $ do + write marr ix acc + x <- indexM as ix + go (ix + 1) (f ix acc x) + go 0 q + pure marr +{-# INLINE internalScanl #-} + +-- Internal only. The first argument is the size of the array +-- argument. This function helps prevent duplication. +internalScanl' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + Int -> + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +internalScanl' !sz f !q as = create $ do + !marr <- new sz + let go !ix !acc = when (ix < sz) $ do + write marr ix acc + x <- indexM as ix + go (ix + 1) (f ix acc x) + go 0 q + pure marr +{-# INLINE internalScanl' #-} + +{- | A prescan. + + @prescanl f z = init . scanl f z@ + + Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ +-} +prescanl :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (b -> a -> b) -> + b -> + arr1 a -> + arr2 b +prescanl f = iprescanl (const f) +{-# INLINE prescanl #-} + +{- | A variant of 'prescanl' where the function argument takes + the current index of the array as an additional argument. +-} +iprescanl :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +iprescanl f q as = internalScanl (size as) f q as +{-# INLINE iprescanl #-} + +-- | Like 'prescanl', but with a strict accumulator. +prescanl' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (b -> a -> b) -> + b -> + arr1 a -> + arr2 b +prescanl' f = iprescanl (const f) +{-# INLINE prescanl' #-} + +-- | Like 'iprescanl', but with a strict accumulator. +iprescanl' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> b -> a -> b) -> + b -> + arr1 a -> + arr2 b +iprescanl' f !q as = internalScanl' (size as) f q as +{-# INLINE iprescanl' #-} + +{- | 'zipWith' generalises 'zip' by zipping with the function + given as the first argument, instead of a tupling function. + For example, 'zipWith' (+) is applied to two arrays to produce + an array of the corresponding sums. +-} +zipWith :: + ( Contiguous arr1 + , Contiguous arr2 + , Contiguous arr3 + , Element arr1 a + , Element arr2 b + , Element arr3 c + ) => + (a -> b -> c) -> + arr1 a -> + arr2 b -> + arr3 c +zipWith f = izipWith (\_ a b -> f a b) +{-# INLINE zipWith #-} + +-- | Variant of 'zipWith' that provides the index of each pair of elements. +izipWith :: + ( Contiguous arr1 + , Contiguous arr2 + , Contiguous arr3 + , Element arr1 a + , Element arr2 b + , Element arr3 c + ) => + (Int -> a -> b -> c) -> + arr1 a -> + arr2 b -> + arr3 c +izipWith f as bs = create $ do + let !sz = min (size as) (size bs) + !marr <- new sz + let go !ix = when (ix < sz) $ do + a <- indexM as ix + b <- indexM bs ix + let !g = f ix a b + write marr ix g + go (ix + 1) + go 0 + pure marr +{-# INLINE izipWith #-} + +{- | Variant of 'zipWith' that accepts an accumulator, performing a lazy +right fold over both arrays. +-} +foldrZipWith :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (a -> b -> c -> c) -> + c -> + arr1 a -> + arr2 b -> + c +foldrZipWith f = ifoldrZipWith (\_ x y c -> f x y c) +{-# INLINE foldrZipWith #-} + +{- | Variant of 'zipWith' that accepts an accumulator, performing a strict +left monadic fold over both arrays. +-} +foldlZipWithM' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Monad m + ) => + (c -> a -> b -> m c) -> + c -> + arr1 a -> + arr2 b -> + m c +foldlZipWithM' f = ifoldlZipWithM' (\_ x y c -> f x y c) +{-# INLINE foldlZipWithM' #-} + +-- | Variant of 'foldrZipWith' that provides the index of each pair of elements. +ifoldrZipWith :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> a -> b -> c -> c) -> + c -> + arr1 a -> + arr2 b -> + c +ifoldrZipWith f z = \arr1 arr2 -> + let !sz = min (size arr1) (size arr2) + go !ix = + if sz > ix + then case index# arr1 ix of + (# x #) -> case index# arr2 ix of + (# y #) -> f ix x y (go (ix + 1)) + else z + in go 0 +{-# INLINE ifoldrZipWith #-} + +foldlZipWith' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (c -> a -> b -> c) -> + c -> + arr1 a -> + arr2 b -> + c +foldlZipWith' f = ifoldlZipWith' (\_ x y c -> f x y c) +{-# INLINE foldlZipWith' #-} + +ifoldlZipWith' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + ) => + (Int -> c -> a -> b -> c) -> + c -> + arr1 a -> + arr2 b -> + c +ifoldlZipWith' f !z !arr1 !arr2 = + let !sz = min (size arr1) (size arr2) + go !ix !acc = + if ix == sz + then acc + else case index# arr1 ix of + (# x #) -> case index# arr2 ix of + (# y #) -> go (ix + 1) (f ix acc x y) + in go 0 z +{-# INLINE ifoldlZipWith' #-} + +-- | Variant of 'foldlZipWithM\'' that provides the index of each pair of elements. +ifoldlZipWithM' :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 a + , Element arr2 b + , Monad m + ) => + (Int -> c -> a -> b -> m c) -> + c -> + arr1 a -> + arr2 b -> + m c +ifoldlZipWithM' f z = \arr1 arr2 -> + let !sz = min (size arr1) (size arr2) + go !ix !acc = + if sz > ix + then case index# arr1 ix of + (# x #) -> case index# arr2 ix of + (# y #) -> do + acc' <- f ix acc x y + go (ix + 1) acc' + else pure acc + in go 0 z +{-# INLINE ifoldlZipWithM' #-} + +{- | 'zip' takes two arrays and returns an array of + corresponding pairs. + + > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')] + + If one input array is shorter than the other, excess + elements of the longer array are discarded: + + > zip [1] ['a', 'b'] = [(1, 'a')] + > zip [1, 2] ['a'] = [(1, 'a')] +-} +zip :: + ( Contiguous arr1 + , Contiguous arr2 + , Contiguous arr3 + , Element arr1 a + , Element arr2 b + , Element arr3 (a, b) + ) => + arr1 a -> + arr2 b -> + arr3 (a, b) +zip = zipWith (,) +{-# INLINE zip #-} + +{- | Replace all locations in the input with the same value. + + Equivalent to Data.Functor.'Data.Functor.<$'. +-} +(<$) :: + ( Contiguous arr1 + , Contiguous arr2 + , Element arr1 b + , Element arr2 a + ) => + a -> + arr1 b -> + arr2 a +a <$ barr = create (replicateMut (size barr) a) +{-# INLINE (<$) #-} + +{- | Sequential application. + + Equivalent to Control.Applicative.'Control.Applicative.<*>'. +-} +ap :: + ( Contiguous arr1 + , Contiguous arr2 + , Contiguous arr3 + , Element arr1 (a -> b) + , Element arr2 a + , Element arr3 b + ) => + arr1 (a -> b) -> + arr2 a -> + arr3 b +ap fs xs = create $ do + marr <- new (szfs * szxs) + let go1 !ix = when (ix < szfs) $ do + f <- indexM fs ix + go2 (ix * szxs) f 0 + go1 (ix + 1) + go2 !off f !j = when (j < szxs) $ do + x <- indexM xs j + write marr (off + j) (f x) + go2 off f (j + 1) + go1 0 + pure marr + where + !szfs = size fs + !szxs = size xs +{-# INLINE ap #-} + +all :: (Contiguous arr, Element arr a) => (a -> Bool) -> arr a -> Bool +all f = foldr (\x acc -> f x && acc) True +{-# INLINE all #-} + +any :: (Contiguous arr, Element arr a) => (a -> Bool) -> arr a -> Bool +any f = foldr (\x acc -> f x || acc) False +{-# INLINE any #-} diff --git a/src/Data/Primitive/Contiguous/Class.hs b/src/Data/Primitive/Contiguous/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Contiguous/Class.hs @@ -0,0 +1,1449 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedNewtypes #-} + +{- | The 'Contiguous' typeclass parameterises over a contiguous array type. +It provides the core primitives necessary to implement the common API in "Data.Primitive.Contiguous". + This allows us to have a common API to a number of contiguous + array types and their mutable counterparts. +-} +module Data.Primitive.Contiguous.Class + ( Contiguous (..) + , Slice (..) + , MutableSlice (..) + , ContiguousU (..) + , Always + ) where + +import Data.Primitive +import Data.Primitive.Contiguous.Shim +import Data.Primitive.Unlifted.Array +import Data.Primitive.Unlifted.SmallArray +import Prelude hiding + ( all + , any + , elem + , filter + , foldMap + , foldl + , foldr + , length + , map + , mapM + , mapM_ + , maximum + , minimum + , null + , read + , replicate + , reverse + , scanl + , sequence + , sequence_ + , traverse + , zip + , zipWith + , (<$) + ) + +import Control.DeepSeq (NFData) +import Control.Monad.Primitive (PrimMonad (..), PrimState) +import Control.Monad.ST (ST, runST) +import Control.Monad.ST.Run (runArrayST, runPrimArrayST, runSmallArrayST, runUnliftedArrayST) +import Data.Kind (Type) +import Data.Primitive.Unlifted.Array () +import Data.Primitive.Unlifted.Array.Primops (MutableUnliftedArray# (MutableUnliftedArray#), UnliftedArray# (UnliftedArray#)) +import Data.Primitive.Unlifted.SmallArray.Primops (SmallUnliftedArray# (SmallUnliftedArray#), SmallMutableUnliftedArray# (SmallMutableUnliftedArray#)) +import Data.Primitive.Unlifted.Class (PrimUnlifted) +import GHC.Exts (Array#, Constraint, MutableArray#, SmallArray#, SmallMutableArray#, TYPE, sizeofArray#, sizeofByteArray#) +import GHC.ST (ST (ST)) + +import qualified Control.DeepSeq as DS +import qualified Data.Primitive.Unlifted.Class as Class +import qualified GHC.Exts as Exts + +-- In GHC 9.2 the UnliftedRep constructor of RuntimeRep was removed +-- and replaced with a type synonym +#if __GLASGOW_HASKELL__ >= 902 +import GHC.Exts (UnliftedRep) +#else +import GHC.Exts (RuntimeRep(UnliftedRep)) +type UnliftedRep = 'UnliftedRep +#endif + +{- | Slices of immutable arrays: packages an offset and length with a backing array. + +@since 0.6.0 +-} +data Slice arr a = Slice + { offset :: {-# UNPACK #-} !Int + , length :: {-# UNPACK #-} !Int + , base :: !(Unlifted arr a) + } + +{- | Slices of mutable arrays: packages an offset and length with a mutable backing array. + +@since 0.6.0 +-} +data MutableSlice arr s a = MutableSlice + { offsetMut :: {-# UNPACK #-} !Int + , lengthMut :: {-# UNPACK #-} !Int + , baseMut :: !(UnliftedMut arr s a) + } + +{- | The 'Contiguous' typeclass as an interface to a multitude of +contiguous structures. + +Some functions do not make sense on slices; for those, see 'ContiguousU'. +-} +class Contiguous (arr :: Type -> Type) where + -- | The Mutable counterpart to the array. + type Mutable arr = (r :: Type -> Type -> Type) | r -> arr + + -- | The constraint needed to store elements in the array. + type Element arr :: Type -> Constraint + + -- | The slice type of this array. + -- The slice of a raw array type @t@ should be 'Slice t', + -- whereas the slice of a slice should be the same slice type. + -- + -- @since 0.6.0 + type Sliced arr :: Type -> Type + + -- | The mutable slice type of this array. + -- The mutable slice of a raw array type @t@ should be 'MutableSlice t', + -- whereas the mutable slice of a mutable slice should be the same slice type. + -- + -- @since 0.6.0 + type MutableSliced arr :: Type -> Type -> Type + + ------ Construction ------ + + -- | Allocate a new mutable array of the given size. + new :: (PrimMonad m, Element arr b) => Int -> m (Mutable arr (PrimState m) b) + + -- | @'replicateMut' n x@ is a mutable array of length @n@ with @x@ the + -- value of every element. + replicateMut :: + (PrimMonad m, Element arr b) => + Int -> -- length + b -> -- fill element + m (Mutable arr (PrimState m) b) + + -- | Resize an array without growing it. It may be shrunk in place. + -- + -- @since 0.6.0 + shrink :: + (PrimMonad m, Element arr a) => + Mutable arr (PrimState m) a -> + -- | new length + Int -> + m (Mutable arr (PrimState m) a) + + -- | The empty array. + empty :: arr a + + -- | Create a singleton array. + singleton :: (Element arr a) => a -> arr a + + -- | Create a doubleton array. + doubleton :: (Element arr a) => a -> a -> arr a + + -- | Create a tripleton array. + tripleton :: (Element arr a) => a -> a -> a -> arr a + + -- | Create a quadrupleton array. + quadrupleton :: (Element arr a) => a -> a -> a -> a -> arr a + + -- | Create a quintupleton array. + quintupleton :: (Element arr a) => a -> a -> a -> a -> a -> arr a + + -- | Create a sextupleton array. + sextupleton :: (Element arr a) => a -> a -> a -> a -> a -> a -> arr a + + ------ Access and Update ------ + + -- | Index into an array at the given index. + index :: (Element arr b) => arr b -> Int -> b + + -- | Index into an array at the given index, yielding an unboxed one-tuple of the element. + index# :: (Element arr b) => arr b -> Int -> (# b #) + + -- | Indexing in a monad. + -- + -- The monad allows operations to be strict in the array + -- when necessary. Suppose array copying is implemented like this: + -- + -- > copy mv v = ... write mv i (v ! i) ... + -- + -- For lazy arrays, @v ! i@ would not be not be evaluated, + -- which means that @mv@ would unnecessarily retain a reference + -- to @v@ in each element written. + -- + -- With 'indexM', copying can be implemented like this instead: + -- + -- > copy mv v = ... do + -- > x <- indexM v i + -- > write mv i x + -- + -- Here, no references to @v@ are retained because indexing + -- (but /not/ the elements) is evaluated eagerly. + indexM :: (Element arr b, Monad m) => arr b -> Int -> m b + + -- | Read a mutable array at the given index. + read :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + Int -> + m b + + -- | Write to a mutable array at the given index. + write :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + Int -> + b -> + m () + + ------ Properties ------ + + -- | Test whether the array is empty. + null :: arr b -> Bool + + -- | The size of the array + size :: (Element arr b) => arr b -> Int + + -- | The size of the mutable array + sizeMut :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + m Int + + -- | Test the two arrays for equality. + equals :: (Element arr b, Eq b) => arr b -> arr b -> Bool + + -- | Test the two mutable arrays for pointer equality. + -- Does not check equality of elements. + equalsMut :: Mutable arr s a -> Mutable arr s a -> Bool + + ------ Conversion ------ + + -- | Create a 'Slice' of an array. + -- + -- @O(1)@. + -- + -- @since 0.6.0 + slice :: + (Element arr a) => + arr a -> -- base array + Int -> -- offset + Int -> -- length + Sliced arr a + + -- | Create a 'MutableSlice' of a mutable array. + -- + -- @O(1)@. + -- + -- @since 0.6.0 + sliceMut :: + (Element arr a) => + Mutable arr s a -> -- base array + Int -> -- offset + Int -> -- length + MutableSliced arr s a + + -- | Create a 'Slice' that covers the entire array. + -- + -- @since 0.6.0 + toSlice :: (Element arr a) => arr a -> Sliced arr a + + -- | Create a 'MutableSlice' that covers the entire array. + -- + -- @since 0.6.0 + toSliceMut :: + (PrimMonad m, Element arr a) => + Mutable arr (PrimState m) a -> + m (MutableSliced arr (PrimState m) a) + + -- | Clone a slice of an array. + clone :: + (Element arr b) => + -- | slice to copy + Sliced arr b -> + arr b + default clone :: + ( Sliced arr ~ Slice arr + , ContiguousU arr + , Element arr b + ) => + Sliced arr b -> + arr b + {-# INLINE clone #-} + clone Slice {offset, length, base} = clone_ (lift base) offset length + + -- | Clone a slice of an array without using the 'Slice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + clone_ :: (Element arr a) => arr a -> Int -> Int -> arr a + + -- | Clone a slice of a mutable array. + cloneMut :: + (PrimMonad m, Element arr b) => + -- | Array to copy a slice of + MutableSliced arr (PrimState m) b -> + m (Mutable arr (PrimState m) b) + default cloneMut :: + ( MutableSliced arr ~ MutableSlice arr + , ContiguousU arr + , PrimMonad m + , Element arr b + ) => + MutableSliced arr (PrimState m) b -> + m (Mutable arr (PrimState m) b) + {-# INLINE cloneMut #-} + cloneMut MutableSlice {offsetMut, lengthMut, baseMut} = + cloneMut_ (liftMut baseMut) offsetMut lengthMut + + -- | Clone a slice of a mutable array without using the 'MutableSlice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + cloneMut_ :: + (PrimMonad m, Element arr b) => + -- | Array to copy a slice of + Mutable arr (PrimState m) b -> + -- | offset + Int -> + -- | length + Int -> + m (Mutable arr (PrimState m) b) + + -- | Turn a mutable array slice an immutable array by copying. + -- + -- @since 0.6.0 + freeze :: + (PrimMonad m, Element arr a) => + MutableSliced arr (PrimState m) a -> + m (arr a) + default freeze :: + ( MutableSliced arr ~ MutableSlice arr + , ContiguousU arr + , PrimMonad m + , Element arr a + ) => + MutableSliced arr (PrimState m) a -> + m (arr a) + {-# INLINE freeze #-} + freeze MutableSlice {offsetMut, lengthMut, baseMut} = + freeze_ (liftMut baseMut) offsetMut lengthMut + + -- | Turn a slice of a mutable array into an immutable one with copying, + -- without using the 'MutableSlice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + freeze_ :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + -- | offset + Int -> + -- | length + Int -> + m (arr b) + + -- | Turn a mutable array into an immutable one without copying. + -- The mutable array should not be used after this conversion. + unsafeFreeze :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + m (arr b) + + unsafeShrinkAndFreeze :: + (PrimMonad m, Element arr a) => + Mutable arr (PrimState m) a -> + -- | final size + Int -> + m (arr a) + + -- | Copy a slice of an immutable array into a new mutable array. + thaw :: + (PrimMonad m, Element arr b) => + Sliced arr b -> + m (Mutable arr (PrimState m) b) + default thaw :: + ( Sliced arr ~ Slice arr + , ContiguousU arr + , PrimMonad m + , Element arr b + ) => + Sliced arr b -> + m (Mutable arr (PrimState m) b) + {-# INLINE thaw #-} + thaw Slice {offset, length, base} = thaw_ (lift base) offset length + + -- | Copy a slice of an immutable array into a new mutable array without using the 'Slice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + thaw_ :: + (PrimMonad m, Element arr b) => + arr b -> + -- | offset into the array + Int -> + -- | length of the slice + Int -> + m (Mutable arr (PrimState m) b) + + ------ Copy Operations ------ + + -- | Copy a slice of an array into a mutable array. + copy :: + (PrimMonad m, Element arr b) => + -- | destination array + Mutable arr (PrimState m) b -> + -- | offset into destination array + Int -> + -- | source slice + Sliced arr b -> + m () + default copy :: + ( Sliced arr ~ Slice arr + , ContiguousU arr + , PrimMonad m + , Element arr b + ) => + Mutable arr (PrimState m) b -> + Int -> + Sliced arr b -> + m () + {-# INLINE copy #-} + copy dst dstOff Slice {offset, length, base} = copy_ dst dstOff (lift base) offset length + + -- | Copy a slice of an array into a mutable array without using the 'Slice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + copy_ :: + (PrimMonad m, Element arr b) => + -- | destination array + Mutable arr (PrimState m) b -> + -- | offset into destination array + Int -> + -- | source array + arr b -> + -- | offset into source array + Int -> + -- | number of elements to copy + Int -> + m () + + -- | Copy a slice of a mutable array into another mutable array. + -- In the case that the destination and source arrays are the + -- same, the regions may overlap. + copyMut :: + (PrimMonad m, Element arr b) => + -- | destination array + Mutable arr (PrimState m) b -> + -- | offset into destination array + Int -> + -- | source slice + MutableSliced arr (PrimState m) b -> + m () + default copyMut :: + ( MutableSliced arr ~ MutableSlice arr + , ContiguousU arr + , PrimMonad m + , Element arr b + ) => + Mutable arr (PrimState m) b -> + Int -> + MutableSliced arr (PrimState m) b -> + m () + {-# INLINE copyMut #-} + copyMut dst dstOff MutableSlice {offsetMut, lengthMut, baseMut} = + copyMut_ dst dstOff (liftMut baseMut) offsetMut lengthMut + + -- | Copy a slice of a mutable array into another mutable array without using the 'Slice' type. + -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; + -- they are not really meant for direct use. + -- + -- @since 0.6.0 + copyMut_ :: + (PrimMonad m, Element arr b) => + -- | destination array + Mutable arr (PrimState m) b -> + -- | offset into destination array + Int -> + -- | source array + Mutable arr (PrimState m) b -> + -- | offset into source array + Int -> + -- | number of elements to copy + Int -> + m () + + -- | Copy a slice of an array and then insert an element into that array. + -- + -- The default implementation performs a memset which would be unnecessary + -- except that the garbage collector might trace the uninitialized array. + -- + -- Was previously @insertSlicing@ + -- @since 0.6.0 + insertAt :: + (Element arr b) => + -- | slice to copy from + arr b -> + -- | index in the output array to insert at + Int -> + -- | element to insert + b -> + arr b + default insertAt :: + (Element arr b, ContiguousU arr) => + arr b -> + Int -> + b -> + arr b + insertAt src i x = run $ do + dst <- replicateMut (size src + 1) x + copy dst 0 (slice src 0 i) + copy dst (i + 1) (slice src i (size src - i)) + unsafeFreeze dst + {-# INLINE insertAt #-} + + ------ Reduction ------ + + -- | Reduce the array and all of its elements to WHNF. + rnf :: (NFData a, Element arr a) => arr a -> () + + -- | Run an effectful computation that produces an array. + run :: (forall s. ST s (arr a)) -> arr a + +{- | The 'ContiguousU' typeclass is an extension of the 'Contiguous' typeclass, +but includes operations that make sense only on unsliced contiguous structures. + +@since 0.6.0 +-} +class (Contiguous arr) => ContiguousU arr where + -- | The unifted version of the immutable array type (i.e. eliminates an indirection through a thunk). + type Unlifted arr = (r :: Type -> TYPE UnliftedRep) | r -> arr + + -- | The unifted version of the mutable array type (i.e. eliminates an indirection through a thunk). + type UnliftedMut arr = (r :: Type -> Type -> TYPE UnliftedRep) | r -> arr + + -- | Resize an array into one with the given size. If the array is grown, + -- then reading from any newly introduced element before writing to it is undefined behavior. + -- The current behavior is that anything backed by @MutableByteArray#@ ends with + -- uninitialized memory at these indices. But for @SmallMutableArray@ or @Array@, these + -- are set to an error thunk, so reading from them and forcing the result + -- causes the program to crash. For @UnliftedArray@, the new elements have undefined values of an unknown type. + -- If the array is not grown, it may (or may not) be modified in place. + resize :: + (PrimMonad m, Element arr b) => + Mutable arr (PrimState m) b -> + Int -> + m (Mutable arr (PrimState m) b) + + -- | Unlift an array (i.e. point to the data without an intervening thunk). + -- + -- @since 0.6.0 + unlift :: arr b -> Unlifted arr b + + -- | Unlift a mutable array (i.e. point to the data without an intervening thunk). + -- + -- @since 0.6.0 + unliftMut :: Mutable arr s b -> UnliftedMut arr s b + + -- | Lift an array (i.e. point to the data through an intervening thunk). + -- + -- @since 0.6.0 + lift :: Unlifted arr b -> arr b + + -- | Lift a mutable array (i.e. point to the data through an intervening thunk). + -- + -- @since 0.6.0 + liftMut :: UnliftedMut arr s b -> Mutable arr s b + +{- | A typeclass that is satisfied by all types. This is used +used to provide a fake constraint for 'Array' and 'SmallArray'. +-} +class Always a + +instance Always a + +instance (ContiguousU arr) => Contiguous (Slice arr) where + type Mutable (Slice arr) = MutableSlice arr + type Element (Slice arr) = Element arr + type Sliced (Slice arr) = Slice arr + type MutableSliced (Slice arr) = MutableSlice arr + + ------ Construction ------ + {-# INLINE new #-} + new len = do + baseMut <- new len + pure MutableSlice {offsetMut = 0, lengthMut = len, baseMut = unliftMut baseMut} + {-# INLINE replicateMut #-} + replicateMut len x = do + baseMut <- replicateMut len x + pure MutableSlice {offsetMut = 0, lengthMut = len, baseMut = unliftMut baseMut} + {-# INLINE unsafeFreeze #-} + unsafeFreeze (MutableSlice off len base) = do + base' <- unsafeFreeze (liftMut base) + pure (Slice off len (unlift base')) + {-# INLINE shrink #-} + shrink xs len' = pure $ case compare len' (lengthMut xs) of + LT -> xs {lengthMut = len'} + EQ -> xs + GT -> errorWithoutStackTrace "Data.Primitive.Contiguous.Class.shrink: passed a larger than existing size" + {-# INLINE empty #-} + empty = Slice {offset = 0, length = 0, base = unlift empty} + {-# INLINE singleton #-} + singleton a = Slice {offset = 0, length = 1, base = unlift $ singleton a} + {-# INLINE doubleton #-} + doubleton a b = Slice {offset = 0, length = 2, base = unlift $ doubleton a b} + {-# INLINE tripleton #-} + tripleton a b c = Slice {offset = 0, length = 3, base = unlift $ tripleton a b c} + {-# INLINE quadrupleton #-} + quadrupleton a b c d = Slice {offset = 0, length = 4, base = unlift $ quadrupleton a b c d} + {-# INLINE quintupleton #-} + quintupleton a b c d e = Slice {offset = 0, length = 5, base = unlift $ quintupleton a b c d e} + {-# INLINE sextupleton #-} + sextupleton a b c d e f = Slice {offset = 0, length = 6, base = unlift $ sextupleton a b c d e f} + + ------ Access and Update ------ + {-# INLINE index #-} + index Slice {offset, base} i = index (lift base) (offset + i) + {-# INLINE index# #-} + index# Slice {offset, base} i = index# (lift base) (offset + i) + {-# INLINE indexM #-} + indexM Slice {offset, base} i = indexM (lift base) (offset + i) + {-# INLINE read #-} + read MutableSlice {offsetMut, baseMut} i = read (liftMut baseMut) (offsetMut + i) + {-# INLINE write #-} + write MutableSlice {offsetMut, baseMut} i = write (liftMut baseMut) (offsetMut + i) + + ------ Properties ------ + {-# INLINE null #-} + null Slice {length} = length == 0 + {-# INLINE size #-} + size Slice {length} = length + {-# INLINE sizeMut #-} + sizeMut MutableSlice {lengthMut} = pure lengthMut + {-# INLINE equals #-} + equals + Slice {offset = oA, length = lenA, base = a} + Slice {offset = oB, length = lenB, base = b} = + lenA == lenB && loop 0 oA oB + where + loop !i !iA !iB = + if i == lenA + then True + else index (lift a) iA == index (lift b) iB && loop (i + 1) (iA + 1) (iB + 1) + {-# INLINE equalsMut #-} + equalsMut + MutableSlice {offsetMut = offA, lengthMut = lenA, baseMut = a} + MutableSlice {offsetMut = offB, lengthMut = lenB, baseMut = b} = + liftMut a `equalsMut` liftMut b + && offA == offB + && lenA == lenB + + ------ Conversion ------ + {-# INLINE slice #-} + slice Slice {offset, base} off' len' = + Slice + { offset = offset + off' + , length = len' + , base + } + {-# INLINE sliceMut #-} + sliceMut MutableSlice {offsetMut, baseMut} off' len' = + MutableSlice + { offsetMut = offsetMut + off' + , lengthMut = len' + , baseMut + } + {-# INLINE clone #-} + clone = id + {-# INLINE clone_ #-} + clone_ Slice {offset, base} off' len' = + Slice {offset = offset + off', length = len', base} + {-# INLINE cloneMut #-} + cloneMut xs@MutableSlice {lengthMut} = cloneMut_ xs 0 lengthMut + {-# INLINE cloneMut_ #-} + cloneMut_ MutableSlice {offsetMut, baseMut} off' len' = do + baseMut' <- cloneMut_ (liftMut baseMut) (offsetMut + off') len' + pure MutableSlice {offsetMut = 0, lengthMut = len', baseMut = unliftMut baseMut'} + {-# INLINE freeze #-} + freeze xs@MutableSlice {lengthMut} = + freeze_ xs 0 lengthMut + {-# INLINE freeze_ #-} + freeze_ MutableSlice {offsetMut, baseMut} off' len' = do + base <- freeze_ (liftMut baseMut) (offsetMut + off') len' + pure Slice {offset = 0, length = len', base = unlift base} + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze MutableSlice {offsetMut = 0, lengthMut, baseMut} len' = do + shrunk <- + if lengthMut /= len' + then resize (liftMut baseMut) len' + else pure (liftMut baseMut) + base <- unsafeFreeze shrunk + pure Slice {offset = 0, length = len', base = unlift base} + unsafeShrinkAndFreeze MutableSlice {offsetMut, baseMut} len' = do + base <- freeze_ (liftMut baseMut) offsetMut len' + pure Slice {offset = 0, length = len', base = unlift base} + {-# INLINE thaw #-} + thaw xs@Slice {length} = thaw_ xs 0 length + {-# INLINE thaw_ #-} + thaw_ Slice {offset, base} off' len' = do + baseMut <- thaw_ (lift base) (offset + off') len' + pure MutableSlice {offsetMut = 0, lengthMut = len', baseMut = unliftMut baseMut} + {-# INLINE toSlice #-} + toSlice = id + {-# INLINE toSliceMut #-} + toSliceMut = pure + + ------ Copy Operations ------ + {-# INLINE copy #-} + copy dst dstOff src@Slice {length} = copy_ dst dstOff src 0 length + {-# INLINE copy_ #-} + copy_ MutableSlice {offsetMut, baseMut} dstOff Slice {offset, base} off' len = + copy_ (liftMut baseMut) (offsetMut + dstOff) (lift base) (offset + off') len + {-# INLINE copyMut #-} + copyMut dst dstOff src@MutableSlice {lengthMut} = copyMut_ dst dstOff src 0 lengthMut + {-# INLINE copyMut_ #-} + copyMut_ + MutableSlice {offsetMut = dstOff, baseMut = dst} + dstOff' + MutableSlice {offsetMut = srcOff, baseMut = src} + srcOff' + len = + copyMut_ (liftMut dst) (dstOff + dstOff') (liftMut src) (srcOff + srcOff') len + {-# INLINE insertAt #-} + insertAt Slice {offset, length, base} i x = run $ do + dst <- replicateMut (length + 1) x + copy_ dst 0 (lift base) offset i + copy_ dst (i + 1) (lift base) (offset + i) (length - i) + base' <- unsafeFreeze dst + pure Slice {offset = 0, length = length + 1, base = unlift base'} + + ------ Reduction ------ + {-# INLINE rnf #-} + rnf !arr@Slice {length} = + let go !ix = + if ix < length + then + let !(# x #) = index# arr ix + in DS.rnf x `seq` go (ix + 1) + else () + in go 0 + {-# INLINE run #-} + run = runST + +instance Contiguous SmallArray where + type Mutable SmallArray = SmallMutableArray + type Element SmallArray = Always + type Sliced SmallArray = Slice SmallArray + type MutableSliced SmallArray = MutableSlice SmallArray + {-# INLINE new #-} + new n = newSmallArray n errorThunk + {-# INLINE empty #-} + empty = mempty + {-# INLINE index #-} + index = indexSmallArray + {-# INLINE indexM #-} + indexM = indexSmallArrayM + {-# INLINE index# #-} + index# = indexSmallArray## + {-# INLINE read #-} + read = readSmallArray + {-# INLINE write #-} + write = writeSmallArray + {-# INLINE null #-} + null a = case sizeofSmallArray a of + 0 -> True + _ -> False + {-# INLINE slice #-} + slice base offset length = Slice {offset, length, base = unlift base} + {-# INLINE sliceMut #-} + sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE toSlice #-} + toSlice base = Slice {offset = 0, length = size base, base = unlift base} + {-# INLINE toSliceMut #-} + toSliceMut baseMut = do + lengthMut <- sizeMut baseMut + pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE freeze_ #-} + freeze_ = freezeSmallArray + {-# INLINE unsafeFreeze #-} + unsafeFreeze = unsafeFreezeSmallArray + {-# INLINE size #-} + size = sizeofSmallArray + {-# INLINE sizeMut #-} + sizeMut = getSizeofSmallMutableArray + {-# INLINE thaw_ #-} + thaw_ = thawSmallArray + {-# INLINE equals #-} + equals = (==) + {-# INLINE equalsMut #-} + equalsMut = (==) + {-# INLINE singleton #-} + singleton a = runST $ do + marr <- newSmallArray 1 a + unsafeFreezeSmallArray marr + {-# INLINE doubleton #-} + doubleton a b = runST $ do + m <- newSmallArray 2 a + writeSmallArray m 1 b + unsafeFreezeSmallArray m + {-# INLINE tripleton #-} + tripleton a b c = runST $ do + m <- newSmallArray 3 a + writeSmallArray m 1 b + writeSmallArray m 2 c + unsafeFreezeSmallArray m + {-# INLINE quadrupleton #-} + quadrupleton a b c d = runST $ do + m <- newSmallArray 4 a + writeSmallArray m 1 b + writeSmallArray m 2 c + writeSmallArray m 3 d + unsafeFreezeSmallArray m + {-# INLINE quintupleton #-} + quintupleton a b c d e = runST $ do + m <- newSmallArray 5 a + writeSmallArray m 1 b + writeSmallArray m 2 c + writeSmallArray m 3 d + writeSmallArray m 4 e + unsafeFreezeSmallArray m + {-# INLINE sextupleton #-} + sextupleton a b c d e f = runST $ do + m <- newSmallArray 6 a + writeSmallArray m 1 b + writeSmallArray m 2 c + writeSmallArray m 3 d + writeSmallArray m 4 e + writeSmallArray m 5 f + unsafeFreezeSmallArray m + {-# INLINE rnf #-} + rnf !ary = + let !sz = sizeofSmallArray ary + go !ix = + if ix < sz + then + let !(# x #) = indexSmallArray## ary ix + in DS.rnf x `seq` go (ix + 1) + else () + in go 0 + {-# INLINE clone_ #-} + clone_ = cloneSmallArray + {-# INLINE cloneMut_ #-} + cloneMut_ = cloneSmallMutableArray + {-# INLINE copy_ #-} + copy_ = copySmallArray + {-# INLINE copyMut_ #-} + copyMut_ = copySmallMutableArray + {-# INLINE replicateMut #-} + replicateMut = newSmallArray + {-# INLINE run #-} + run = runSmallArrayST + {-# INLINE shrink #-} + shrink !arr !n = do + shrinkSmallMutableArray arr n + pure arr + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze !arr !n = do + shrinkSmallMutableArray arr n + unsafeFreezeSmallArray arr + +instance ContiguousU SmallArray where + type Unlifted SmallArray = SmallArray# + type UnliftedMut SmallArray = SmallMutableArray# + {-# INLINE resize #-} + resize !arr !n = resizeSmallMutableArray arr n resizeSmallMutableArrayUninitializedElement + {-# INLINE unlift #-} + unlift (SmallArray x) = x + {-# INLINE unliftMut #-} + unliftMut (SmallMutableArray x) = x + {-# INLINE lift #-} + lift x = SmallArray x + {-# INLINE liftMut #-} + liftMut x = SmallMutableArray x + +instance Contiguous (SmallUnliftedArray_ unlifted_a) where + type Mutable (SmallUnliftedArray_ unlifted_a) = SmallMutableUnliftedArray_ unlifted_a + type Element (SmallUnliftedArray_ unlifted_a) = PrimUnliftsInto unlifted_a + type Sliced (SmallUnliftedArray_ unlifted_a) = Slice (SmallUnliftedArray_ unlifted_a) + type MutableSliced (SmallUnliftedArray_ unlifted_a) = MutableSlice (SmallUnliftedArray_ unlifted_a) + {-# INLINE new #-} + new n = unsafeNewSmallUnliftedArray n + {-# INLINE empty #-} + empty = emptySmallUnliftedArray + {-# INLINE index #-} + index = indexSmallUnliftedArray + {-# INLINE indexM #-} + indexM arr ix = pure (indexSmallUnliftedArray arr ix) + {-# INLINE index# #-} + index# arr ix = (# indexSmallUnliftedArray arr ix #) + {-# INLINE read #-} + read = readSmallUnliftedArray + {-# INLINE write #-} + write = writeSmallUnliftedArray + {-# INLINE null #-} + null a = case sizeofSmallUnliftedArray a of + 0 -> True + _ -> False + {-# INLINE slice #-} + slice base offset length = Slice {offset, length, base = unlift base} + {-# INLINE sliceMut #-} + sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE toSlice #-} + toSlice base = Slice {offset = 0, length = size base, base = unlift base} + {-# INLINE toSliceMut #-} + toSliceMut baseMut = do + lengthMut <- sizeMut baseMut + pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE freeze_ #-} + freeze_ = freezeSmallUnliftedArray + {-# INLINE unsafeFreeze #-} + unsafeFreeze = unsafeFreezeSmallUnliftedArray + {-# INLINE size #-} + size = sizeofSmallUnliftedArray + {-# INLINE sizeMut #-} + sizeMut = getSizeofSmallMutableUnliftedArray + {-# INLINE thaw_ #-} + thaw_ = thawSmallUnliftedArray + {-# INLINE equals #-} + equals = (==) + {-# INLINE equalsMut #-} + equalsMut = sameSmallMutableUnliftedArray + {-# INLINE singleton #-} + singleton a = runST $ do + marr <- newSmallUnliftedArray 1 a + unsafeFreezeSmallUnliftedArray marr + {-# INLINE doubleton #-} + doubleton a b = runST $ do + m <- newSmallUnliftedArray 2 a + writeSmallUnliftedArray m 1 b + unsafeFreezeSmallUnliftedArray m + {-# INLINE tripleton #-} + tripleton a b c = runST $ do + m <- newSmallUnliftedArray 3 a + writeSmallUnliftedArray m 1 b + writeSmallUnliftedArray m 2 c + unsafeFreezeSmallUnliftedArray m + {-# INLINE quadrupleton #-} + quadrupleton a b c d = runST $ do + m <- newSmallUnliftedArray 4 a + writeSmallUnliftedArray m 1 b + writeSmallUnliftedArray m 2 c + writeSmallUnliftedArray m 3 d + unsafeFreezeSmallUnliftedArray m + {-# INLINE quintupleton #-} + quintupleton a b c d e = runST $ do + m <- newSmallUnliftedArray 5 a + writeSmallUnliftedArray m 1 b + writeSmallUnliftedArray m 2 c + writeSmallUnliftedArray m 3 d + writeSmallUnliftedArray m 4 e + unsafeFreezeSmallUnliftedArray m + {-# INLINE sextupleton #-} + sextupleton a b c d e f = runST $ do + m <- newSmallUnliftedArray 6 a + writeSmallUnliftedArray m 1 b + writeSmallUnliftedArray m 2 c + writeSmallUnliftedArray m 3 d + writeSmallUnliftedArray m 4 e + writeSmallUnliftedArray m 5 f + unsafeFreezeSmallUnliftedArray m + {-# INLINE rnf #-} + rnf !ary = + let !sz = sizeofSmallUnliftedArray ary + go !ix = + if ix < sz + then + let !x = indexSmallUnliftedArray ary ix + in DS.rnf x `seq` go (ix + 1) + else () + in go 0 + {-# INLINE clone_ #-} + clone_ = cloneSmallUnliftedArray + {-# INLINE cloneMut_ #-} + cloneMut_ = cloneSmallMutableUnliftedArray + {-# INLINE copy_ #-} + copy_ = copySmallUnliftedArray + {-# INLINE copyMut_ #-} + copyMut_ = copySmallMutableUnliftedArray + {-# INLINE replicateMut #-} + replicateMut = newSmallUnliftedArray + {-# INLINE run #-} + run = runSmallUnliftedArrayST + {-# INLINE shrink #-} + shrink !arr !n = do + shrinkSmallMutableUnliftedArray arr n + pure arr + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze !arr !n = do + shrinkSmallMutableUnliftedArray arr n + unsafeFreezeSmallUnliftedArray arr + + +newtype SmallUnliftedArray## (u :: TYPE UnliftedRep) (a :: Type) + = SmallUnliftedArray## (Exts.SmallArray# u) +newtype SmallMutableUnliftedArray## (u :: TYPE UnliftedRep) s (a :: Type) + = SmallMutableUnliftedArray## (Exts.SmallMutableArray# s u) + +instance ContiguousU (SmallUnliftedArray_ unlifted_a) where + type Unlifted (SmallUnliftedArray_ unlifted_a) = SmallUnliftedArray## unlifted_a + type UnliftedMut (SmallUnliftedArray_ unlifted_a) = SmallMutableUnliftedArray## unlifted_a + {-# INLINE resize #-} + resize = resizeSmallUnliftedArray + {-# INLINE unlift #-} + unlift (SmallUnliftedArray (SmallUnliftedArray# x)) = SmallUnliftedArray## x + {-# INLINE unliftMut #-} + unliftMut (SmallMutableUnliftedArray (SmallMutableUnliftedArray# x)) = SmallMutableUnliftedArray## x + {-# INLINE lift #-} + lift (SmallUnliftedArray## x) = SmallUnliftedArray (SmallUnliftedArray# x) + {-# INLINE liftMut #-} + liftMut (SmallMutableUnliftedArray## x) = SmallMutableUnliftedArray (SmallMutableUnliftedArray# x) + + +-- NOTE: Currently missing from the `run-st` library +-- c.f. https://github.com/byteverse/run-st/issues/5 +runSmallUnliftedArrayST :: (forall s. ST s (SmallUnliftedArray_ unlifted_a a)) -> SmallUnliftedArray_ unlifted_a a +{-# INLINE runSmallUnliftedArrayST #-} +runSmallUnliftedArrayST f = SmallUnliftedArray (Exts.runRW# (\s0 -> case f of ST g -> case g s0 of (# _, SmallUnliftedArray r #) -> r)) + +instance Contiguous PrimArray where + type Mutable PrimArray = MutablePrimArray + type Element PrimArray = Prim + type Sliced PrimArray = Slice PrimArray + type MutableSliced PrimArray = MutableSlice PrimArray + {-# INLINE empty #-} + empty = mempty + {-# INLINE new #-} + new = newPrimArray + {-# INLINE replicateMut #-} + replicateMut = replicateMutablePrimArray + {-# INLINE index #-} + index = indexPrimArray + {-# INLINE index# #-} + index# arr ix = (# indexPrimArray arr ix #) + {-# INLINE indexM #-} + indexM arr ix = pure (indexPrimArray arr ix) + {-# INLINE read #-} + read = readPrimArray + {-# INLINE write #-} + write = writePrimArray + {-# INLINE size #-} + size = sizeofPrimArray + {-# INLINE sizeMut #-} + sizeMut = getSizeofMutablePrimArray + {-# INLINE slice #-} + slice base offset length = Slice {offset, length, base = unlift base} + {-# INLINE sliceMut #-} + sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE toSlice #-} + toSlice base = Slice {offset = 0, length = size base, base = unlift base} + {-# INLINE toSliceMut #-} + toSliceMut baseMut = do + lengthMut <- sizeMut baseMut + pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE freeze_ #-} + freeze_ = freezePrimArray + {-# INLINE unsafeFreeze #-} + unsafeFreeze = unsafeFreezePrimArray + {-# INLINE thaw_ #-} + thaw_ = thawPrimArray + {-# INLINE copy_ #-} + copy_ = copyPrimArray + {-# INLINE copyMut_ #-} + copyMut_ = copyMutablePrimArray + {-# INLINE clone_ #-} + clone_ = clonePrimArray + {-# INLINE cloneMut_ #-} + cloneMut_ = cloneMutablePrimArray + {-# INLINE equals #-} + equals = (==) + {-# INLINE null #-} + null (PrimArray a) = case sizeofByteArray# a of + 0# -> True + _ -> False + {-# INLINE equalsMut #-} + equalsMut = sameMutablePrimArray + {-# INLINE rnf #-} + rnf (PrimArray !_) = () + {-# INLINE singleton #-} + singleton a = runPrimArrayST $ do + marr <- newPrimArray 1 + writePrimArray marr 0 a + unsafeFreezePrimArray marr + {-# INLINE doubleton #-} + doubleton a b = runPrimArrayST $ do + m <- newPrimArray 2 + writePrimArray m 0 a + writePrimArray m 1 b + unsafeFreezePrimArray m + {-# INLINE tripleton #-} + tripleton a b c = runPrimArrayST $ do + m <- newPrimArray 3 + writePrimArray m 0 a + writePrimArray m 1 b + writePrimArray m 2 c + unsafeFreezePrimArray m + {-# INLINE quadrupleton #-} + quadrupleton a b c d = runPrimArrayST $ do + m <- newPrimArray 4 + writePrimArray m 0 a + writePrimArray m 1 b + writePrimArray m 2 c + writePrimArray m 3 d + unsafeFreezePrimArray m + {-# INLINE quintupleton #-} + quintupleton a b c d e = runPrimArrayST $ do + m <- newPrimArray 5 + writePrimArray m 0 a + writePrimArray m 1 b + writePrimArray m 2 c + writePrimArray m 3 d + writePrimArray m 4 e + unsafeFreezePrimArray m + {-# INLINE sextupleton #-} + sextupleton a b c d e f = runPrimArrayST $ do + m <- newPrimArray 6 + writePrimArray m 0 a + writePrimArray m 1 b + writePrimArray m 2 c + writePrimArray m 3 d + writePrimArray m 4 e + writePrimArray m 5 f + unsafeFreezePrimArray m + {-# INLINE insertAt #-} + insertAt src i x = runPrimArrayST $ do + dst <- new (size src + 1) + copy dst 0 (slice src 0 i) + write dst i x + copy dst (i + 1) (slice src i (size src - i)) + unsafeFreeze dst + {-# INLINE run #-} + run = runPrimArrayST + {-# INLINE shrink #-} + shrink !arr !n = do + shrinkMutablePrimArray arr n + pure arr + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze !arr !n = do + shrinkMutablePrimArray arr n + unsafeFreezePrimArray arr + +newtype PrimArray# a = PrimArray# ByteArray# +newtype MutablePrimArray# s a = MutablePrimArray# (MutableByteArray# s) +instance ContiguousU PrimArray where + type Unlifted PrimArray = PrimArray# + type UnliftedMut PrimArray = MutablePrimArray# + {-# INLINE resize #-} + resize = resizeMutablePrimArray + {-# INLINE unlift #-} + unlift (PrimArray x) = PrimArray# x + {-# INLINE unliftMut #-} + unliftMut (MutablePrimArray x) = MutablePrimArray# x + {-# INLINE lift #-} + lift (PrimArray# x) = PrimArray x + {-# INLINE liftMut #-} + liftMut (MutablePrimArray# x) = MutablePrimArray x + +instance Contiguous Array where + type Mutable Array = MutableArray + type Element Array = Always + type Sliced Array = Slice Array + type MutableSliced Array = MutableSlice Array + {-# INLINE empty #-} + empty = mempty + {-# INLINE new #-} + new n = newArray n errorThunk + {-# INLINE replicateMut #-} + replicateMut = newArray + {-# INLINE index #-} + index = indexArray + {-# INLINE index# #-} + index# = indexArray## + {-# INLINE indexM #-} + indexM = indexArrayM + {-# INLINE read #-} + read = readArray + {-# INLINE write #-} + write = writeArray + {-# INLINE size #-} + size = sizeofArray + {-# INLINE sizeMut #-} + sizeMut = (\x -> pure $! sizeofMutableArray x) + {-# INLINE slice #-} + slice base offset length = Slice {offset, length, base = unlift base} + {-# INLINE sliceMut #-} + sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE toSlice #-} + toSlice base = Slice {offset = 0, length = size base, base = unlift base} + {-# INLINE toSliceMut #-} + toSliceMut baseMut = do + lengthMut <- sizeMut baseMut + pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE freeze_ #-} + freeze_ = freezeArray + {-# INLINE unsafeFreeze #-} + unsafeFreeze = unsafeFreezeArray + {-# INLINE thaw_ #-} + thaw_ = thawArray + {-# INLINE copy_ #-} + copy_ = copyArray + {-# INLINE copyMut_ #-} + copyMut_ = copyMutableArray + {-# INLINE clone #-} + clone Slice {offset, length, base} = clone_ (lift base) offset length + {-# INLINE clone_ #-} + clone_ = cloneArray + {-# INLINE cloneMut_ #-} + cloneMut_ = cloneMutableArray + {-# INLINE equals #-} + equals = (==) + {-# INLINE null #-} + null (Array a) = case sizeofArray# a of + 0# -> True + _ -> False + {-# INLINE equalsMut #-} + equalsMut = sameMutableArray + {-# INLINE rnf #-} + rnf !ary = + let !sz = sizeofArray ary + go !i + | i == sz = () + | otherwise = + let !(# x #) = indexArray## ary i + in DS.rnf x `seq` go (i + 1) + in go 0 + {-# INLINE singleton #-} + singleton a = runArrayST (newArray 1 a >>= unsafeFreezeArray) + {-# INLINE doubleton #-} + doubleton a b = runArrayST $ do + m <- newArray 2 a + writeArray m 1 b + unsafeFreezeArray m + {-# INLINE tripleton #-} + tripleton a b c = runArrayST $ do + m <- newArray 3 a + writeArray m 1 b + writeArray m 2 c + unsafeFreezeArray m + {-# INLINE quadrupleton #-} + quadrupleton a b c d = runArrayST $ do + m <- newArray 4 a + writeArray m 1 b + writeArray m 2 c + writeArray m 3 d + unsafeFreezeArray m + {-# INLINE quintupleton #-} + quintupleton a b c d e = runArrayST $ do + m <- newArray 5 a + writeArray m 1 b + writeArray m 2 c + writeArray m 3 d + writeArray m 4 e + unsafeFreezeArray m + {-# INLINE sextupleton #-} + sextupleton a b c d e f = runArrayST $ do + m <- newArray 6 a + writeArray m 1 b + writeArray m 2 c + writeArray m 3 d + writeArray m 4 e + writeArray m 5 f + unsafeFreezeArray m + {-# INLINE run #-} + run = runArrayST + {-# INLINE shrink #-} + shrink !arr !n = do + -- See Note [Shrinking Arrays Without a Shrink Primop] + cloneMutableArray arr 0 n + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze !arr !n = + -- See Note [Shrinking Arrays Without a Shrink Primop] + freezeArray arr 0 n + +instance ContiguousU Array where + type Unlifted Array = Array# + type UnliftedMut Array = MutableArray# + {-# INLINE resize #-} + resize = resizeArray + {-# INLINE unlift #-} + unlift (Array x) = x + {-# INLINE unliftMut #-} + unliftMut (MutableArray x) = x + {-# INLINE lift #-} + lift x = Array x + {-# INLINE liftMut #-} + liftMut x = MutableArray x + +class (Class.Unlifted a ~ u, PrimUnlifted a) => PrimUnliftsInto (u :: TYPE ('Exts.BoxedRep 'Exts.Unlifted)) (a :: Type) +instance (Class.Unlifted a ~ u, PrimUnlifted a) => PrimUnliftsInto u a + +instance Contiguous (UnliftedArray_ unlifted_a) where + type Mutable (UnliftedArray_ unlifted_a) = MutableUnliftedArray_ unlifted_a + type Element (UnliftedArray_ unlifted_a) = PrimUnliftsInto unlifted_a + type Sliced (UnliftedArray_ unlifted_a) = Slice (UnliftedArray_ unlifted_a) + type MutableSliced (UnliftedArray_ unlifted_a) = MutableSlice (UnliftedArray_ unlifted_a) + {-# INLINE empty #-} + empty = emptyUnliftedArray + {-# INLINE new #-} + new = unsafeNewUnliftedArray + {-# INLINE replicateMut #-} + replicateMut = newUnliftedArray + {-# INLINE index #-} + index = indexUnliftedArray + {-# INLINE index# #-} + index# arr ix = (# indexUnliftedArray arr ix #) + {-# INLINE indexM #-} + indexM arr ix = pure (indexUnliftedArray arr ix) + {-# INLINE read #-} + read = readUnliftedArray + {-# INLINE write #-} + write = writeUnliftedArray + {-# INLINE size #-} + size = sizeofUnliftedArray + {-# INLINE sizeMut #-} + sizeMut = pure . sizeofMutableUnliftedArray + {-# INLINE slice #-} + slice base offset length = Slice {offset, length, base = unlift base} + {-# INLINE sliceMut #-} + sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE freeze_ #-} + freeze_ = freezeUnliftedArray + {-# INLINE unsafeFreeze #-} + unsafeFreeze = unsafeFreezeUnliftedArray + {-# INLINE toSlice #-} + toSlice base = Slice {offset = 0, length = size base, base = unlift base} + {-# INLINE toSliceMut #-} + toSliceMut baseMut = do + lengthMut <- sizeMut baseMut + pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} + {-# INLINE thaw_ #-} + thaw_ = thawUnliftedArray + {-# INLINE copy_ #-} + copy_ = copyUnliftedArray + {-# INLINE copyMut_ #-} + copyMut_ = copyMutableUnliftedArray + {-# INLINE clone_ #-} + clone_ = cloneUnliftedArray + {-# INLINE cloneMut_ #-} + cloneMut_ = cloneMutableUnliftedArray + {-# INLINE equals #-} + equals = (==) + {-# INLINE null #-} + null (UnliftedArray (UnliftedArray# a)) = case Exts.sizeofArray# a of + 0# -> True + _ -> False + {-# INLINE equalsMut #-} + equalsMut = sameMutableUnliftedArray + {-# INLINE rnf #-} + rnf !ary = + let !sz = sizeofUnliftedArray ary + go !i + | i == sz = () + | otherwise = + let x = indexUnliftedArray ary i + in DS.rnf x `seq` go (i + 1) + in go 0 + {-# INLINE singleton #-} + singleton a = runUnliftedArrayST (newUnliftedArray 1 a >>= unsafeFreezeUnliftedArray) + {-# INLINE doubleton #-} + doubleton a b = runUnliftedArrayST $ do + m <- newUnliftedArray 2 a + writeUnliftedArray m 1 b + unsafeFreezeUnliftedArray m + {-# INLINE tripleton #-} + tripleton a b c = runUnliftedArrayST $ do + m <- newUnliftedArray 3 a + writeUnliftedArray m 1 b + writeUnliftedArray m 2 c + unsafeFreezeUnliftedArray m + {-# INLINE quadrupleton #-} + quadrupleton a b c d = runUnliftedArrayST $ do + m <- newUnliftedArray 4 a + writeUnliftedArray m 1 b + writeUnliftedArray m 2 c + writeUnliftedArray m 3 d + unsafeFreezeUnliftedArray m + {-# INLINE quintupleton #-} + quintupleton a b c d e = runUnliftedArrayST $ do + m <- newUnliftedArray 5 a + writeUnliftedArray m 1 b + writeUnliftedArray m 2 c + writeUnliftedArray m 3 d + writeUnliftedArray m 4 e + unsafeFreezeUnliftedArray m + {-# INLINE sextupleton #-} + sextupleton a b c d e f = runUnliftedArrayST $ do + m <- newUnliftedArray 6 a + writeUnliftedArray m 1 b + writeUnliftedArray m 2 c + writeUnliftedArray m 3 d + writeUnliftedArray m 4 e + writeUnliftedArray m 5 f + unsafeFreezeUnliftedArray m + {-# INLINE run #-} + run = runUnliftedArrayST + {-# INLINE shrink #-} + shrink !arr !n = do + -- See Note [Shrinking Arrays Without a Shrink Primop] + cloneMutableUnliftedArray arr 0 n + {-# INLINE unsafeShrinkAndFreeze #-} + unsafeShrinkAndFreeze !arr !n = + -- See Note [Shrinking Arrays Without a Shrink Primop] + freezeUnliftedArray arr 0 n + +-- Note [Shrinking Arrays Without a Shrink Primop] +-- =============================================== +-- GHC's Array# type has a card table and cannot currently be shrunk in place. +-- (SmallArray#, however, can be shrunk in place.) These implementations copy +-- the array rather than freezing it in place. But at least they are able to +-- avoid assigning all of the elements to a nonsense value before replacing +-- them with memcpy. + +newtype UnliftedArray## (u :: TYPE UnliftedRep) (a :: Type) + = UnliftedArray## (Exts.Array# u) +newtype MutableUnliftedArray## (u :: TYPE UnliftedRep) s (a :: Type) + = MutableUnliftedArray## (Exts.MutableArray# s u) + +instance ContiguousU (UnliftedArray_ unlifted_a) where + type Unlifted (UnliftedArray_ unlifted_a) = UnliftedArray## unlifted_a + type UnliftedMut (UnliftedArray_ unlifted_a) = MutableUnliftedArray## unlifted_a + {-# INLINE resize #-} + resize = resizeUnliftedArray + {-# INLINE unlift #-} + unlift (UnliftedArray (UnliftedArray# x)) = UnliftedArray## x + {-# INLINE unliftMut #-} + unliftMut (MutableUnliftedArray (MutableUnliftedArray# x)) = MutableUnliftedArray## x + {-# INLINE lift #-} + lift (UnliftedArray## x) = UnliftedArray (UnliftedArray# x) + {-# INLINE liftMut #-} + liftMut (MutableUnliftedArray## x) = MutableUnliftedArray (MutableUnliftedArray# x) + +resizeSmallMutableArrayUninitializedElement :: a +{-# noinline resizeSmallMutableArrayUninitializedElement #-} +resizeSmallMutableArrayUninitializedElement = errorWithoutStackTrace "uninitialized element of resizeSmallMutableArray" diff --git a/src/Data/Primitive/Contiguous/Shim.hs b/src/Data/Primitive/Contiguous/Shim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Primitive/Contiguous/Shim.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +module Data.Primitive.Contiguous.Shim + ( errorThunk + , resizeArray + , resizeUnliftedArray + , resizeSmallUnliftedArray + , replicateMutablePrimArray + ) where + +import Data.Primitive +import Data.Primitive.Unlifted.Array +import Data.Primitive.Unlifted.SmallArray +import Prelude hiding (all, any, elem, filter, foldMap, foldl, foldr, map, mapM, mapM_, maximum, minimum, null, read, replicate, reverse, scanl, sequence, sequence_, traverse, zip, zipWith, (<$)) + +import Control.Monad.Primitive (PrimMonad (..), PrimState) +import Data.Primitive.Unlifted.Class (PrimUnlifted) + +errorThunk :: a +errorThunk = error "Contiguous typeclass: unitialized element" +{-# NOINLINE errorThunk #-} + +resizeArray :: (PrimMonad m) => MutableArray (PrimState m) a -> Int -> m (MutableArray (PrimState m) a) +resizeArray !src !sz = do + let !srcSz = sizeofMutableArray src + case compare sz srcSz of + EQ -> pure src + LT -> cloneMutableArray src 0 sz + GT -> do + dst <- newArray sz errorThunk + copyMutableArray dst 0 src 0 srcSz + pure dst +{-# INLINE resizeArray #-} + +resizeUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m (MutableUnliftedArray (PrimState m) a) +resizeUnliftedArray !src !sz = do + let !srcSz = sizeofMutableUnliftedArray src + case compare sz srcSz of + EQ -> pure src + LT -> cloneMutableUnliftedArray src 0 sz + GT -> do + dst <- unsafeNewUnliftedArray sz + copyMutableUnliftedArray dst 0 src 0 srcSz + pure dst +{-# INLINE resizeUnliftedArray #-} + +resizeSmallUnliftedArray :: (PrimMonad m, PrimUnlifted a) => SmallMutableUnliftedArray (PrimState m) a -> Int -> m (SmallMutableUnliftedArray (PrimState m) a) +resizeSmallUnliftedArray !src !sz = do + srcSz <- getSizeofSmallMutableUnliftedArray src + case compare sz srcSz of + EQ -> pure src + LT -> cloneSmallMutableUnliftedArray src 0 sz + GT -> do + dst <- unsafeNewSmallUnliftedArray sz + copySmallMutableUnliftedArray dst 0 src 0 srcSz + pure dst +{-# INLINE resizeSmallUnliftedArray #-} + + +replicateMutablePrimArray :: + (PrimMonad m, Prim a) => + -- | length + Int -> + -- | element + a -> + m (MutablePrimArray (PrimState m) a) +replicateMutablePrimArray len a = do + marr <- newPrimArray len + setPrimArray marr 0 len a + pure marr +{-# INLINE replicateMutablePrimArray #-} diff --git a/test/Laws.hs b/test/Laws.hs new file mode 100644 --- /dev/null +++ b/test/Laws.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- We define a newtype around `Array a` for the purpose of testing +-- the definitions of many typeclass methods from `Data.Primitive.Contiguous`. +-- Testing the lawfulness of such a proxy lets us establish a higher +-- level of confidence that these implementations are correct. +module Main (main) where + +import Data.Foldable +import Data.Primitive.Contiguous +import qualified Data.Primitive.Contiguous as C +import Data.Proxy +import qualified GHC.Exts as Exts +import Test.QuickCheck +import Test.QuickCheck.Classes + +main :: IO () +main = lawsCheckMany laws + +laws :: [(String, [Laws])] +laws = + [ + ( "Arr" + , + [ functorLaws arr + , applicativeLaws arr + , foldableLaws arr + , traversableLaws arr + , isListLaws arr1 + ] + ) + ] + +newtype Arr a = Arr (Array a) + deriving (Eq, Show) + +instance (Arbitrary a) => Arbitrary (Arr a) where + arbitrary = fmap (Arr . Exts.fromList) arbitrary + +arr :: Proxy Arr +arr = Proxy + +arr1 :: Proxy (Arr Int) +arr1 = Proxy + +instance Functor Arr where + fmap f (Arr a) = Arr (C.map f a) + a <$ (Arr bs) = Arr (a C.<$ bs) + +instance Applicative Arr where + pure = Arr . C.singleton + Arr f <*> Arr x = Arr (C.ap f x) + +instance Foldable Arr where + foldMap f (Arr a) = C.foldMap f a + foldr f z0 (Arr a) = C.foldr f z0 a + foldr' f z0 (Arr a) = C.foldr' f z0 a + foldl f z0 (Arr a) = C.foldl f z0 a + foldl' f z0 (Arr a) = C.foldl' f z0 a + toList (Arr a) = C.toList a + null (Arr a) = C.null a + length (Arr a) = C.size a + +instance Traversable Arr where + traverse :: (Applicative f) => (a -> f b) -> Arr a -> f (Arr b) + traverse f (Arr a) = fmap Arr (C.traverse f a) + + sequenceA :: (Applicative f) => Arr (f a) -> f (Arr a) + sequenceA (Arr f) = fmap Arr (C.sequence f) + +instance Exts.IsList (Arr a) where + type Item (Arr a) = a + fromList = Arr . C.fromList + fromListN len = Arr . C.fromListN len + toList (Arr a) = Exts.toList a diff --git a/test/UnitTests.hs b/test/UnitTests.hs new file mode 100644 --- /dev/null +++ b/test/UnitTests.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Main (main) where + +import qualified Data.Either as P +import Data.Functor.Identity (Identity (..)) +import qualified Data.List as P +import qualified Data.Maybe as P +import Data.Monoid +import Data.Primitive +import qualified Data.Primitive.Contiguous as C +import qualified Data.Vector as V +import qualified GHC.Exts as Exts +import Test.QuickCheck +import Test.QuickCheck.Instances () +import Prelude +import qualified Prelude as P + +main :: IO () +main = unitTests + +unitTests :: IO () +unitTests = + mapM_ + testC + [ quiet "Contiguous.filter = Data.List.filter" prop_filter + , quiet "Contiguous.mapMaybe = Data.Maybe.mapMaybe" prop_mapMaybe + , quiet "Reverse: reverse . reverse = id" prop_reverse1 + , quiet "Contiguous.reverse = Data.List.reverse" prop_reverse2 + , quiet "Contiguous.map = Data.List.map" prop_map + , quiet "Contiguous.unfoldr = Data.List.unfoldr" prop_unfoldr + , quiet "Contiguous.unfoldrN = Data.Vector.unfoldrN" prop_unfoldrN + , quiet "Contiguous.traverse = Data.Traversable.traverse" prop_traverse + , quiet "Contiguous.find = Data.Foldable.find" prop_find + , quiet "Contiguous.scanl = Data.List.scanl" prop_scanl + , quiet "Contiguous.scanl' = Data.List.scanl'" prop_scanl' + , quiet "Contiguous.prescanl = Data.Vector.prescanl" prop_prescanl + , quiet "Contiguous.prescanl' = Data.Vector.prescanl'" prop_prescanl' + , quiet "Contiguous.generate = Data.Vector.generate" prop_generate + , quiet "Contiguous.generateM = Data.Vector.generateM" prop_generateM + , quiet "Contiguous.minimum = Data.Foldable.minimum" prop_minimum + , quiet "Contiguous.maximum = Data.Foldable.maximum" prop_maximum + , quiet "Contiguous.zipWith = Data.List.zipWith" prop_zipWith + , quiet "Contiguous.zip = Data.List.zip" prop_zip + , quiet "Contiguous.lefts = Data.Either.lefts" prop_lefts + , quiet "Contiguous.rights = Data.Either.rights" prop_rights + , quiet "Contiguous.partitionEithers = Data.Either.partitionEithers" prop_partitionEithers + ] + +-- Verbosity with which to run tests. +data Verbosity = Quiet | Verbose + +-- | Hide the prop type. +data Prop = forall prop. (Testable prop) => Prop prop + +-- hack to let us get away with stuffing different +-- prop types in a list +data CTest = CTest + { _verbosity :: Verbosity + , _label :: String + , _prop :: Prop + } + +-- quiet output of a test +quiet :: (Testable prop) => String -> prop -> CTest +quiet l p = CTest Quiet l (Prop p) + +-- verbose output of a test +-- Useful for failing tests +_verbose :: (Testable prop) => String -> prop -> CTest +_verbose l p = CTest Verbose l (Prop p) + +testC :: CTest -> IO () +testC (CTest v lbl (Prop p)) = do + putStrLn $ P.replicate (length lbl + 6) '-' + putStrLn $ "-- " ++ lbl ++ " --" + putStrLn $ P.replicate (length lbl + 6) '-' + putStr "\n" + ($ p) $ case v of Verbose -> verboseCheck; Quiet -> quickCheck + putStr "\n" + +newtype Arr = Arr (Array L) + deriving (Eq, Show) + +newtype L = L [Int] + deriving (Eq, Ord, Exts.IsList) + +instance Show L where + show (L x) = show x + +instance Arbitrary L where + arbitrary = do + j <- choose (1, 6) + fmap L $ vectorOf j arbitrary + +instance Arbitrary Arr where + arbitrary = do + k <- choose (2, 20) + fmap (Arr . Exts.fromList) $ vectorOf k arbitrary + shrink (Arr xs) = fmap Arr (fmap Exts.fromList $ shrink $ Exts.toList xs) + +mean :: forall t a. (Foldable t, Integral a) => t a -> a +mean xs = + let (sum_ :: Sum a, len_ :: Sum a) = foldMap (\x -> (Sum x, Sum 1)) xs + in (round :: Double -> a) $ (fromIntegral (getSum sum_) / fromIntegral (getSum len_)) + +prop_filter :: Arr -> Property +prop_filter (Arr arr) = + property $ + let arrList = C.toList arr + p = \(L xs) -> all even xs + in P.filter p arrList == C.toList (C.filter p arr) + +prop_mapMaybe :: Arr -> Property +prop_mapMaybe (Arr arr) = + property $ + let arrList = C.toList arr + p = \(L xs) -> if all even xs then Just () else Nothing + in P.mapMaybe p arrList == C.toList (C.mapMaybe p arr :: Array ()) + +prop_reverse1 :: Arr -> Property +prop_reverse1 (Arr arr) = + property $ + C.reverse (C.reverse arr) == arr + +prop_reverse2 :: Arr -> Property +prop_reverse2 (Arr arr) = + property $ + let arrList = C.toList arr + in P.reverse arrList == C.toList (C.reverse arr) + +prop_map :: Arr -> Property +prop_map (Arr arr) = + property $ + let arrList = C.toList arr + f = \(L xs) -> mean xs + in P.map f arrList == C.toList (C.map f arr :: Array Int) + +prop_unfoldr :: Property +prop_unfoldr = + property $ + let f = \n -> if n == 0 then Nothing else Just (n, n - 1) + sz = 10 + in P.unfoldr f sz == C.toList (C.unfoldr f sz :: Array Int) + +prop_unfoldrN :: Property +prop_unfoldrN = + property $ + let f = \n -> if n == 0 then Nothing else Just (n, n - 1) + sz = 100 + in V.toList (V.unfoldrN sz f 10) == C.toList (C.unfoldrN sz f 10 :: Array Int) + +prop_traverse :: Arr -> Property +prop_traverse (Arr arr) = + property $ + let arrList = C.toList arr + f = \(L xs) -> Identity (sum xs) + in runIdentity (P.traverse f arrList) == C.toList (runIdentity (C.traverse f arr :: Identity (Array Int))) + +prop_generate :: Property +prop_generate = + property $ + let f = \i -> if even i then Just i else Nothing + in V.toList (V.generate 20 f) == C.toList (C.generate 20 f :: Array (Maybe Int)) + +prop_generateM :: Property +prop_generateM = + property $ + let f = \i -> if even i then Just i else Nothing + in fmap V.toList (V.generateM 20 f) == fmap C.toList (C.generateM 20 f :: Maybe (Array Int)) + +{- +prop_postscanl :: Arr -> Property +prop_postscanl (Arr arr) = property $ + let arrList = V.fromList (C.toList arr) + f = \b (L a) -> b ++ a + in V.toList (V.postscanl f [] arrList) == C.toList (C.postscanl f [] arr :: Array [Int]) +-} + +prop_prescanl :: Arr -> Property +prop_prescanl (Arr arr) = + property $ + let arrList = V.fromList (C.toList arr) + f = \b (L a) -> b ++ a + in V.toList (V.prescanl f [] arrList) == C.toList (C.prescanl f [] arr :: Array [Int]) + +prop_prescanl' :: Arr -> Property +prop_prescanl' (Arr arr) = + property $ + let arrList = V.fromList (C.toList arr) + f = \b (L a) -> b ++ a + in V.toList (V.prescanl' f [] arrList) == C.toList (C.prescanl' f [] arr :: Array [Int]) + +prop_find :: Arr -> Property +prop_find (Arr arr) = + property $ + let arrList = C.toList arr + f = \(L xs) -> even (sum xs) + in P.find f arrList == C.find f arr + +prop_zipWith :: Arr -> Arr -> Property +prop_zipWith (Arr arr1) (Arr arr2) = + property $ + let arrList1 = C.toList arr1 + arrList2 = C.toList arr2 + f = \(L xs) (L ys) -> xs ++ ys + in P.zipWith f arrList1 arrList2 == C.toList (C.zipWith f arr1 arr2 :: Array [Int]) + +prop_zip :: Arr -> Arr -> Property +prop_zip (Arr arr1) (Arr arr2) = + property $ + let arrList1 = C.toList arr1 + arrList2 = C.toList arr2 + in P.zip arrList1 arrList2 == C.toList (C.zip arr1 arr2 :: Array (L, L)) +prop_scanl :: Arr -> Property +prop_scanl (Arr arr) = + property $ + let arrList = C.toList arr + f = \b (L a) -> b ++ a + in P.scanl f [] arrList == C.toList (C.scanl f [] arr :: Array [Int]) + +prop_scanl' :: Arr -> Property +prop_scanl' (Arr arr) = + property $ + let arrList = C.toList arr + f = \b (L a) -> b ++ a + in P.scanl' f [] arrList == C.toList (C.scanl' f [] arr :: Array [Int]) + +prop_partitionEithers :: Array' (Either Int Bool) -> Property +prop_partitionEithers (Array' arr) = + property $ + let arrList = C.toList arr + rhs = case C.partitionEithers arr of (as, bs) -> (C.toList as, C.toList bs) + in P.partitionEithers arrList == rhs + +prop_rights :: Array' (Either Int Bool) -> Property +prop_rights (Array' arr) = + property $ + let arrList = C.toList arr + in P.rights arrList == C.toList (C.rights arr) + +prop_lefts :: Array' (Either Int Bool) -> Property +prop_lefts (Array' arr) = + property $ + let arrList = C.toList arr + in P.lefts arrList == C.toList (C.lefts arr) + +prop_minimum :: Arr -> Property +prop_minimum (Arr arr) = + property $ + let arrList = C.toList arr + in Just (minimum arrList) == C.minimum arr + +prop_maximum :: Arr -> Property +prop_maximum (Arr arr) = + property $ + let arrList = C.toList arr + in Just (maximum arrList) == C.maximum arr + +newtype Array' a = Array' {getArray' :: Array a} + deriving (Eq, Show, Exts.IsList) + +instance (Arbitrary a) => Arbitrary (Array' a) where + arbitrary = do + k <- choose (2, 20) + fmap Exts.fromList $ vectorOf k arbitrary + shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs + +-- Get around quickcheck not generating multiple arrays +-- newtype GenArrM = GenArr { getGenArrM :: Array Int } +-- deriving (Eq, Show, Exts.IsList) + +-- instance Arbitrary GenArrM where +-- arbitrary = do +-- k <- choose (2,20) +-- GenArrM <$> C.generateM k (const arbitrary) +-- shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs