contiguous 0.3.3.0 → 0.6.5.0
raw patch · 11 files changed
Files
- CHANGELOG.md +151/−0
- README.md +11/−1
- Setup.hs +0/−2
- bench/Main.hs +365/−0
- cabal.project +2/−0
- contiguous.cabal +80/−25
- src/Data/Primitive/Contiguous.hs +2363/−623
- src/Data/Primitive/Contiguous/Class.hs +1449/−0
- src/Data/Primitive/Contiguous/Shim.hs +72/−0
- test/Laws.hs +77/−0
- test/UnitTests.hs +280/−0
+ CHANGELOG.md view
@@ -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.
README.md view
@@ -1,1 +1,11 @@-# primitive-class+# contiguous++[](https://hackage.haskell.org/package/contiguous)+[](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.+
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ bench/Main.hs view
@@ -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'
+ cabal.project view
@@ -0,0 +1,2 @@+packages: .+tests: True
contiguous.cabal view
@@ -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
src/Data/Primitive/Contiguous.hs view
@@ -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 #-}
+ src/Data/Primitive/Contiguous/Class.hs view
@@ -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"
+ src/Data/Primitive/Contiguous/Shim.hs view
@@ -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 #-}
+ test/Laws.hs view
@@ -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
+ test/UnitTests.hs view
@@ -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