├── .github ├── CODEOWNERS └── workflows │ ├── release.yaml │ └── build.yaml ├── cabal.project ├── .gitignore ├── README.md ├── LICENSE ├── fourmolu.yaml ├── test ├── Laws.hs └── UnitTests.hs ├── contiguous.cabal ├── src └── Data │ └── Primitive │ ├── Contiguous │ ├── Shim.hs │ └── Class.hs │ └── Contiguous.hs ├── CHANGELOG.md └── bench └── Main.hs /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | @byteverse/l3c 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: True 3 | -------------------------------------------------------------------------------- /.github/workflows/release.yaml: -------------------------------------------------------------------------------- 1 | name: release 2 | on: 3 | push: 4 | tags: 5 | - "*" 6 | 7 | jobs: 8 | call-workflow: 9 | uses: byteverse/.github/.github/workflows/release.yaml@main 10 | secrets: inherit 11 | -------------------------------------------------------------------------------- /.github/workflows/build.yaml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | pull_request: 4 | branches: 5 | - "*" 6 | 7 | jobs: 8 | call-workflow: 9 | uses: byteverse/.github/.github/workflows/build-matrix.yaml@main 10 | with: 11 | cabal-file: contiguous.cabal 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .vscode/ 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | .hpc 12 | .hsenv 13 | .cabal-sandbox/ 14 | cabal.sandbox.config 15 | *.prof 16 | *.aux 17 | *.hp 18 | *.eventlog 19 | .stack-work/ 20 | cabal.project.local 21 | cabal.project.local~ 22 | .HTF/ 23 | .ghc.environment.* 24 | stack.yaml 25 | *.swo 26 | *.swp 27 | result 28 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # contiguous 2 | 3 | [![Hackage](https://img.shields.io/hackage/v/contiguous.svg)](https://hackage.haskell.org/package/contiguous) 4 | [![Hackage](https://img.shields.io/badge/license-BSD3-blue.svg)](LICENSE) 5 | 6 | The contiguous typeclass parameterises over a contiguous array type. 7 | This allows us to have a common API to a number of contiguous 8 | array types and their mutable counterparts, namely those in primitive, 9 | making the experience of working with the primitive datatypes much cleaner 10 | and uniform. 11 | 12 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Andrew Martin (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Andrew Martin nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 2 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 200 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: trailing 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: false 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: true 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: multi-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: auto 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: right-align 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: always 39 | 40 | # Output Unicode syntax (choices: detect, always, or never) 41 | unicode: never 42 | 43 | # Give the programmer more choice on where to insert blank lines 44 | respectful: true 45 | 46 | # Fixity information for operators 47 | fixities: [] 48 | 49 | # Module reexports Fourmolu should know about 50 | reexports: [] 51 | 52 | -------------------------------------------------------------------------------- /test/Laws.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | 5 | -- We define a newtype around `Array a` for the purpose of testing 6 | -- the definitions of many typeclass methods from `Data.Primitive.Contiguous`. 7 | -- Testing the lawfulness of such a proxy lets us establish a higher 8 | -- level of confidence that these implementations are correct. 9 | module Main (main) where 10 | 11 | import Data.Foldable 12 | import Data.Primitive.Contiguous 13 | import qualified Data.Primitive.Contiguous as C 14 | import Data.Proxy 15 | import qualified GHC.Exts as Exts 16 | import Test.QuickCheck 17 | import Test.QuickCheck.Classes 18 | 19 | main :: IO () 20 | main = lawsCheckMany laws 21 | 22 | laws :: [(String, [Laws])] 23 | laws = 24 | [ 25 | ( "Arr" 26 | , 27 | [ functorLaws arr 28 | , applicativeLaws arr 29 | , foldableLaws arr 30 | , traversableLaws arr 31 | , isListLaws arr1 32 | ] 33 | ) 34 | ] 35 | 36 | newtype Arr a = Arr (Array a) 37 | deriving (Eq, Show) 38 | 39 | instance (Arbitrary a) => Arbitrary (Arr a) where 40 | arbitrary = fmap (Arr . Exts.fromList) arbitrary 41 | 42 | arr :: Proxy Arr 43 | arr = Proxy 44 | 45 | arr1 :: Proxy (Arr Int) 46 | arr1 = Proxy 47 | 48 | instance Functor Arr where 49 | fmap f (Arr a) = Arr (C.map f a) 50 | a <$ (Arr bs) = Arr (a C.<$ bs) 51 | 52 | instance Applicative Arr where 53 | pure = Arr . C.singleton 54 | Arr f <*> Arr x = Arr (C.ap f x) 55 | 56 | instance Foldable Arr where 57 | foldMap f (Arr a) = C.foldMap f a 58 | foldr f z0 (Arr a) = C.foldr f z0 a 59 | foldr' f z0 (Arr a) = C.foldr' f z0 a 60 | foldl f z0 (Arr a) = C.foldl f z0 a 61 | foldl' f z0 (Arr a) = C.foldl' f z0 a 62 | toList (Arr a) = C.toList a 63 | null (Arr a) = C.null a 64 | length (Arr a) = C.size a 65 | 66 | instance Traversable Arr where 67 | traverse :: (Applicative f) => (a -> f b) -> Arr a -> f (Arr b) 68 | traverse f (Arr a) = fmap Arr (C.traverse f a) 69 | 70 | sequenceA :: (Applicative f) => Arr (f a) -> f (Arr a) 71 | sequenceA (Arr f) = fmap Arr (C.sequence f) 72 | 73 | instance Exts.IsList (Arr a) where 74 | type Item (Arr a) = a 75 | fromList = Arr . C.fromList 76 | fromListN len = Arr . C.fromListN len 77 | toList (Arr a) = Exts.toList a 78 | -------------------------------------------------------------------------------- /contiguous.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: contiguous 3 | version: 0.6.5.0 4 | homepage: https://github.com/byteverse/contiguous 5 | bug-reports: https://github.com/byteverse/contiguous/issues 6 | author: Andrew Martin 7 | maintainer: amartin@layer3com.com 8 | copyright: 2018 Andrew Martin 9 | license: BSD-3-Clause 10 | license-file: LICENSE 11 | build-type: Simple 12 | extra-doc-files: 13 | CHANGELOG.md 14 | README.md 15 | 16 | extra-source-files: cabal.project 17 | synopsis: Unified interface for primitive arrays 18 | category: Array,Data,Primitive 19 | description: 20 | This package provides a typeclass `Contiguous` that offers a 21 | unified interface to working with `Array`, `SmallArray`, 22 | `PrimArray`, and `UnliftedArray`. 23 | 24 | tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 25 | 26 | common build-settings 27 | default-language: Haskell2010 28 | ghc-options: -Wall -Wunused-packages 29 | 30 | library 31 | import: build-settings 32 | exposed-modules: 33 | Data.Primitive.Contiguous 34 | Data.Primitive.Contiguous.Class 35 | 36 | other-modules: Data.Primitive.Contiguous.Shim 37 | hs-source-dirs: src 38 | build-depends: 39 | , base >=4.14 && <5 40 | , deepseq >=1.4 41 | , primitive >=0.9 && <0.10 42 | , primitive-unlifted >=2.2 43 | , run-st >=0.1.3.2 44 | 45 | ghc-options: -O2 46 | 47 | test-suite unit-tests 48 | import: build-settings 49 | type: exitcode-stdio-1.0 50 | main-is: UnitTests.hs 51 | hs-source-dirs: test 52 | build-depends: 53 | , base 54 | , contiguous 55 | , primitive 56 | , QuickCheck 57 | , quickcheck-instances 58 | , vector 59 | 60 | test-suite laws 61 | import: build-settings 62 | type: exitcode-stdio-1.0 63 | main-is: Laws.hs 64 | hs-source-dirs: test 65 | build-depends: 66 | , base 67 | , contiguous 68 | , QuickCheck 69 | , quickcheck-classes 70 | 71 | ghc-options: -O2 72 | 73 | benchmark weigh 74 | import: build-settings 75 | type: exitcode-stdio-1.0 76 | build-depends: 77 | , base 78 | , contiguous 79 | , random 80 | , random-shuffle 81 | , weigh 82 | 83 | hs-source-dirs: bench 84 | main-is: Main.hs 85 | ghc-options: -O2 86 | 87 | source-repository head 88 | type: git 89 | location: git://github.com/byteverse/contiguous.git 90 | -------------------------------------------------------------------------------- /src/Data/Primitive/Contiguous/Shim.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | 4 | module Data.Primitive.Contiguous.Shim 5 | ( errorThunk 6 | , resizeArray 7 | , resizeUnliftedArray 8 | , resizeSmallUnliftedArray 9 | , replicateMutablePrimArray 10 | ) where 11 | 12 | import Data.Primitive 13 | import Data.Primitive.Unlifted.Array 14 | import Data.Primitive.Unlifted.SmallArray 15 | 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, (<$)) 16 | 17 | import Control.Monad.Primitive (PrimMonad (..), PrimState) 18 | import Data.Primitive.Unlifted.Class (PrimUnlifted) 19 | 20 | errorThunk :: a 21 | errorThunk = error "Contiguous typeclass: unitialized element" 22 | {-# NOINLINE errorThunk #-} 23 | 24 | resizeArray :: (PrimMonad m) => MutableArray (PrimState m) a -> Int -> m (MutableArray (PrimState m) a) 25 | resizeArray !src !sz = do 26 | let !srcSz = sizeofMutableArray src 27 | case compare sz srcSz of 28 | EQ -> pure src 29 | LT -> cloneMutableArray src 0 sz 30 | GT -> do 31 | dst <- newArray sz errorThunk 32 | copyMutableArray dst 0 src 0 srcSz 33 | pure dst 34 | {-# INLINE resizeArray #-} 35 | 36 | resizeUnliftedArray :: (PrimMonad m, PrimUnlifted a) => MutableUnliftedArray (PrimState m) a -> Int -> m (MutableUnliftedArray (PrimState m) a) 37 | resizeUnliftedArray !src !sz = do 38 | let !srcSz = sizeofMutableUnliftedArray src 39 | case compare sz srcSz of 40 | EQ -> pure src 41 | LT -> cloneMutableUnliftedArray src 0 sz 42 | GT -> do 43 | dst <- unsafeNewUnliftedArray sz 44 | copyMutableUnliftedArray dst 0 src 0 srcSz 45 | pure dst 46 | {-# INLINE resizeUnliftedArray #-} 47 | 48 | resizeSmallUnliftedArray :: (PrimMonad m, PrimUnlifted a) => SmallMutableUnliftedArray (PrimState m) a -> Int -> m (SmallMutableUnliftedArray (PrimState m) a) 49 | resizeSmallUnliftedArray !src !sz = do 50 | srcSz <- getSizeofSmallMutableUnliftedArray src 51 | case compare sz srcSz of 52 | EQ -> pure src 53 | LT -> cloneSmallMutableUnliftedArray src 0 sz 54 | GT -> do 55 | dst <- unsafeNewSmallUnliftedArray sz 56 | copySmallMutableUnliftedArray dst 0 src 0 srcSz 57 | pure dst 58 | {-# INLINE resizeSmallUnliftedArray #-} 59 | 60 | 61 | replicateMutablePrimArray :: 62 | (PrimMonad m, Prim a) => 63 | -- | length 64 | Int -> 65 | -- | element 66 | a -> 67 | m (MutablePrimArray (PrimState m) a) 68 | replicateMutablePrimArray len a = do 69 | marr <- newPrimArray len 70 | setPrimArray marr 0 len a 71 | pure marr 72 | {-# INLINE replicateMutablePrimArray #-} 73 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for contiguous 2 | 3 | ## 0.6.5.0 -- 2025-04-07 4 | 5 | * Implement Contiguous and ContiguousU for SmallUnliftedArray 6 | * Re-export Small(Mutable)UnliftedArray from Data.Primitive.Contiguous 7 | * Use functions from newer primitive and primitive-unlifted. The implementation 8 | of UnliftedArray in primitive-unlifted-2.1 penalizes the creation of an 9 | uninitialized unlifted array. When shrinking and resizing unlifted arrays, 10 | there are primitives that we can use to avoid this. 11 | 12 | ## 0.6.4.2 -- 2024-02-06 13 | 14 | * Restore support for versions of base that do not export `liftA2` 15 | from the prelude. 16 | 17 | ## 0.6.4.1 -- 2024-02-05 18 | 19 | * Update package metadata. 20 | 21 | ## 0.6.4.0 -- 2023-06-28 22 | 23 | * Make it work with primitive-unlifted-2.1, which drops 24 | support for older primitive-unlifted. 25 | * Add `quintupleton` and `sextupleton`. 26 | * Add `construct(1|2|3|4|5|6)` aliases for constructing arrays with 27 | a small known number of elements. 28 | 29 | ## 0.6.3.0 -- 2022-12-07 30 | 31 | * Add strict `foldrM` 32 | 33 | ## 0.6.2.0 -- 2022-04-13 34 | 35 | * Make benchmarks build 36 | * Add strict `ifoldlZipWith` and `foldlZipWith` 37 | 38 | ## 0.6.1.1 -- 2022-02-16 39 | 40 | * Allow building with GHC 9.2.1. 41 | * Drop support for GHC 8.8 and earlier. 42 | 43 | ## 0.6.1.0 -- 2021-09-01 44 | 45 | * Add `itraverseP` 46 | * Add `deleteAt` and `ifoldr` 47 | 48 | ## 0.6.0 -- 2021-08-28 49 | 50 | * Add `Slice`, `MutableSlice`. 51 | * Split `Contiguous` into `ContiguousSlice` and `Contiguous`. 52 | * Add `shrink` and `unsafeShrinkAndFreeze` 53 | 54 | ## 0.5.2 -- 2021-08-11 55 | 56 | * Add `ifoldlM'`. 57 | * Add `foldrZipWith` and `ifoldrZipWith`. 58 | * Add `foldlZipWithM'` and `ifoldlZipWithM'`. 59 | * Add `all` and `any`. 60 | * Add `run`. Use it internally to accerelate prevent GHC from 61 | boxing results in `runST`. 62 | * Add `quadrupleton`. 63 | 64 | ## 0.5.1 -- 2020-06-30 65 | 66 | * Add `izipWith`. 67 | * Compatibility with `primitive-0.7.1.0`. 68 | 69 | ## 0.5 -- 2019-07-23 70 | 71 | * Add `generateM`, `reverseSlice`, `swap`, `catMaybes`, 72 | `zipWith`, `zip`, `lefts`, `rights`, `partitionEithers`, `elem`, 73 | `find`, `maximum`/`minimum`, `maximumBy`/`minimumBy`, `asum`, 74 | `mapM(_)`, `forM(_)`, `for(_)`, `sequence(_)`, `(<$)`, `ap`, `scanl`, 75 | `scanl'`, `iscanl`, `iscanl'`, `prescanl`, `prescanl'`, `iprescanl`, 76 | `iprescanl'` 77 | * Re-export Array types from the `primitive` package 78 | * Expand unit test suite to include all added functions 79 | * Expand laws test suite to test Foldable/IsList/Traversable laws 80 | in addition to Functor/Applicative 81 | * Add benchmark suite that measures allocations 82 | * Fix performance issue with fold functions that caused huge increase 83 | in allocations when partially-applied. Partially-applied folds now 84 | perform as well as fully-applied. 85 | * Make sure all functions are marked INLINE. Last function not marked 86 | as inline was `imap'`. 87 | 88 | ## 0.4.0.1 -- 2019-05-17 89 | 90 | * Allow building with `primitive-0.7`. This required depending on the 91 | `primitive-unlifted` package to provide the removed `UnliftedArray` 92 | api. 93 | 94 | ## 0.4 -- 2019-05-16 95 | 96 | * Add `convert`, `filter`, `ifilter`, `itraverse(_)` (#6), `imap'`, 97 | `unsafeFromListN`, `unsafeFromListReverseMutableN`, `ifoldr'`, 98 | `foldl`, `mapMutable`, `imapMutable`, `reverse`, `reverseMutable`, 99 | `replicateMutableM`, `create`, `createT`, `unsafeFromListReverseN`, 100 | `generate`, `generateMutable`, `iterate`, `iterateMutableN`, 101 | `iterateMutableNM`, `unfoldr`, `unfoldrMutable`, `toList`, 102 | `toListMutable`, `fromListMutableN`, `fromListMutable`, `fromListN`, 103 | `fromList`, `modify`, `modify'`, `enumFromN`, `enumFromMutableN` 104 | * Refactor `replicate` functions to make more sense (#19) 105 | * Add `Contiguous` instance for `SmallArray` 106 | * Attempt to mark everything as inline (#18) 107 | * Achieve 100% doc coverage, organise exports a lot more 108 | (mimicking vector). Various haddock fixes 109 | * Make `toListMutable` strict in the accumulator 110 | * Change all instances of `return` to `pure` 111 | * Add initial test suite (some unit tests that check implementations 112 | against base/vector versions of the same functions) 113 | * Export `unsafeFreeze`, `copy`, `write`, 114 | * Rename `sameMutable` to `equalsMutable` 115 | 116 | ## 0.3.3.0 -- 2019-03-24 117 | 118 | * Add `freeze` as a method to `Contiguous` 119 | * Add more folds 120 | * Mark more functions as INLINEABLE 121 | 122 | ## 0.3.2.0 -- 2019-01-02 123 | 124 | * Add `thaw` as a method to `Contiguous` 125 | 126 | ## 0.3.1.0 -- 2018-10-19 127 | 128 | * Add `singleton`,`doubleton`,`tripleton` as methods to `Contiguous` 129 | * Add `map'`, `imap`, `mapMutable'`, `imapMutable'` 130 | 131 | ## 0.3.0.0 -- 2018-09-06 132 | 133 | * Document the need for `Always` 134 | * Generalise API: from `ST s` to `PrimMonad m` 135 | * Add NFData `rnf` function for deeply evaluating 136 | `Contiguous` arrays. 137 | * Add function `equals`, for detecting if two arrays in memory 138 | are the same. 139 | * Add hashing function. 140 | * Make `map` able to produce a new array type. 141 | * Add `replicate`, `null` as methods to `Contiguous`. 142 | * Add `traverse`, `itraverse`, `traverseP`, `foldMap` 143 | 144 | ## 0.2.0.0 -- 2018-06-07 145 | 146 | * Add cabal metadata: category, proper synopsis/description 147 | * Use primitive-0.6.4.0 148 | 149 | ## 0.1.0.0 -- 2018-05-31 150 | 151 | * Initial version. 152 | -------------------------------------------------------------------------------- /test/UnitTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExistentialQuantification #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | 6 | module Main (main) where 7 | 8 | import qualified Data.Either as P 9 | import Data.Functor.Identity (Identity (..)) 10 | import qualified Data.List as P 11 | import qualified Data.Maybe as P 12 | import Data.Monoid 13 | import Data.Primitive 14 | import qualified Data.Primitive.Contiguous as C 15 | import qualified Data.Vector as V 16 | import qualified GHC.Exts as Exts 17 | import Test.QuickCheck 18 | import Test.QuickCheck.Instances () 19 | import Prelude 20 | import qualified Prelude as P 21 | 22 | main :: IO () 23 | main = unitTests 24 | 25 | unitTests :: IO () 26 | unitTests = 27 | mapM_ 28 | testC 29 | [ quiet "Contiguous.filter = Data.List.filter" prop_filter 30 | , quiet "Contiguous.mapMaybe = Data.Maybe.mapMaybe" prop_mapMaybe 31 | , quiet "Reverse: reverse . reverse = id" prop_reverse1 32 | , quiet "Contiguous.reverse = Data.List.reverse" prop_reverse2 33 | , quiet "Contiguous.map = Data.List.map" prop_map 34 | , quiet "Contiguous.unfoldr = Data.List.unfoldr" prop_unfoldr 35 | , quiet "Contiguous.unfoldrN = Data.Vector.unfoldrN" prop_unfoldrN 36 | , quiet "Contiguous.traverse = Data.Traversable.traverse" prop_traverse 37 | , quiet "Contiguous.find = Data.Foldable.find" prop_find 38 | , quiet "Contiguous.scanl = Data.List.scanl" prop_scanl 39 | , quiet "Contiguous.scanl' = Data.List.scanl'" prop_scanl' 40 | , quiet "Contiguous.prescanl = Data.Vector.prescanl" prop_prescanl 41 | , quiet "Contiguous.prescanl' = Data.Vector.prescanl'" prop_prescanl' 42 | , quiet "Contiguous.generate = Data.Vector.generate" prop_generate 43 | , quiet "Contiguous.generateM = Data.Vector.generateM" prop_generateM 44 | , quiet "Contiguous.minimum = Data.Foldable.minimum" prop_minimum 45 | , quiet "Contiguous.maximum = Data.Foldable.maximum" prop_maximum 46 | , quiet "Contiguous.zipWith = Data.List.zipWith" prop_zipWith 47 | , quiet "Contiguous.zip = Data.List.zip" prop_zip 48 | , quiet "Contiguous.lefts = Data.Either.lefts" prop_lefts 49 | , quiet "Contiguous.rights = Data.Either.rights" prop_rights 50 | , quiet "Contiguous.partitionEithers = Data.Either.partitionEithers" prop_partitionEithers 51 | ] 52 | 53 | -- Verbosity with which to run tests. 54 | data Verbosity = Quiet | Verbose 55 | 56 | -- | Hide the prop type. 57 | data Prop = forall prop. (Testable prop) => Prop prop 58 | 59 | -- hack to let us get away with stuffing different 60 | -- prop types in a list 61 | data CTest = CTest 62 | { _verbosity :: Verbosity 63 | , _label :: String 64 | , _prop :: Prop 65 | } 66 | 67 | -- quiet output of a test 68 | quiet :: (Testable prop) => String -> prop -> CTest 69 | quiet l p = CTest Quiet l (Prop p) 70 | 71 | -- verbose output of a test 72 | -- Useful for failing tests 73 | _verbose :: (Testable prop) => String -> prop -> CTest 74 | _verbose l p = CTest Verbose l (Prop p) 75 | 76 | testC :: CTest -> IO () 77 | testC (CTest v lbl (Prop p)) = do 78 | putStrLn $ P.replicate (length lbl + 6) '-' 79 | putStrLn $ "-- " ++ lbl ++ " --" 80 | putStrLn $ P.replicate (length lbl + 6) '-' 81 | putStr "\n" 82 | ($ p) $ case v of Verbose -> verboseCheck; Quiet -> quickCheck 83 | putStr "\n" 84 | 85 | newtype Arr = Arr (Array L) 86 | deriving (Eq, Show) 87 | 88 | newtype L = L [Int] 89 | deriving (Eq, Ord, Exts.IsList) 90 | 91 | instance Show L where 92 | show (L x) = show x 93 | 94 | instance Arbitrary L where 95 | arbitrary = do 96 | j <- choose (1, 6) 97 | fmap L $ vectorOf j arbitrary 98 | 99 | instance Arbitrary Arr where 100 | arbitrary = do 101 | k <- choose (2, 20) 102 | fmap (Arr . Exts.fromList) $ vectorOf k arbitrary 103 | shrink (Arr xs) = fmap Arr (fmap Exts.fromList $ shrink $ Exts.toList xs) 104 | 105 | mean :: forall t a. (Foldable t, Integral a) => t a -> a 106 | mean xs = 107 | let (sum_ :: Sum a, len_ :: Sum a) = foldMap (\x -> (Sum x, Sum 1)) xs 108 | in (round :: Double -> a) $ (fromIntegral (getSum sum_) / fromIntegral (getSum len_)) 109 | 110 | prop_filter :: Arr -> Property 111 | prop_filter (Arr arr) = 112 | property $ 113 | let arrList = C.toList arr 114 | p = \(L xs) -> all even xs 115 | in P.filter p arrList == C.toList (C.filter p arr) 116 | 117 | prop_mapMaybe :: Arr -> Property 118 | prop_mapMaybe (Arr arr) = 119 | property $ 120 | let arrList = C.toList arr 121 | p = \(L xs) -> if all even xs then Just () else Nothing 122 | in P.mapMaybe p arrList == C.toList (C.mapMaybe p arr :: Array ()) 123 | 124 | prop_reverse1 :: Arr -> Property 125 | prop_reverse1 (Arr arr) = 126 | property $ 127 | C.reverse (C.reverse arr) == arr 128 | 129 | prop_reverse2 :: Arr -> Property 130 | prop_reverse2 (Arr arr) = 131 | property $ 132 | let arrList = C.toList arr 133 | in P.reverse arrList == C.toList (C.reverse arr) 134 | 135 | prop_map :: Arr -> Property 136 | prop_map (Arr arr) = 137 | property $ 138 | let arrList = C.toList arr 139 | f = \(L xs) -> mean xs 140 | in P.map f arrList == C.toList (C.map f arr :: Array Int) 141 | 142 | prop_unfoldr :: Property 143 | prop_unfoldr = 144 | property $ 145 | let f = \n -> if n == 0 then Nothing else Just (n, n - 1) 146 | sz = 10 147 | in P.unfoldr f sz == C.toList (C.unfoldr f sz :: Array Int) 148 | 149 | prop_unfoldrN :: Property 150 | prop_unfoldrN = 151 | property $ 152 | let f = \n -> if n == 0 then Nothing else Just (n, n - 1) 153 | sz = 100 154 | in V.toList (V.unfoldrN sz f 10) == C.toList (C.unfoldrN sz f 10 :: Array Int) 155 | 156 | prop_traverse :: Arr -> Property 157 | prop_traverse (Arr arr) = 158 | property $ 159 | let arrList = C.toList arr 160 | f = \(L xs) -> Identity (sum xs) 161 | in runIdentity (P.traverse f arrList) == C.toList (runIdentity (C.traverse f arr :: Identity (Array Int))) 162 | 163 | prop_generate :: Property 164 | prop_generate = 165 | property $ 166 | let f = \i -> if even i then Just i else Nothing 167 | in V.toList (V.generate 20 f) == C.toList (C.generate 20 f :: Array (Maybe Int)) 168 | 169 | prop_generateM :: Property 170 | prop_generateM = 171 | property $ 172 | let f = \i -> if even i then Just i else Nothing 173 | in fmap V.toList (V.generateM 20 f) == fmap C.toList (C.generateM 20 f :: Maybe (Array Int)) 174 | 175 | {- 176 | prop_postscanl :: Arr -> Property 177 | prop_postscanl (Arr arr) = property $ 178 | let arrList = V.fromList (C.toList arr) 179 | f = \b (L a) -> b ++ a 180 | in V.toList (V.postscanl f [] arrList) == C.toList (C.postscanl f [] arr :: Array [Int]) 181 | -} 182 | 183 | prop_prescanl :: Arr -> Property 184 | prop_prescanl (Arr arr) = 185 | property $ 186 | let arrList = V.fromList (C.toList arr) 187 | f = \b (L a) -> b ++ a 188 | in V.toList (V.prescanl f [] arrList) == C.toList (C.prescanl f [] arr :: Array [Int]) 189 | 190 | prop_prescanl' :: Arr -> Property 191 | prop_prescanl' (Arr arr) = 192 | property $ 193 | let arrList = V.fromList (C.toList arr) 194 | f = \b (L a) -> b ++ a 195 | in V.toList (V.prescanl' f [] arrList) == C.toList (C.prescanl' f [] arr :: Array [Int]) 196 | 197 | prop_find :: Arr -> Property 198 | prop_find (Arr arr) = 199 | property $ 200 | let arrList = C.toList arr 201 | f = \(L xs) -> even (sum xs) 202 | in P.find f arrList == C.find f arr 203 | 204 | prop_zipWith :: Arr -> Arr -> Property 205 | prop_zipWith (Arr arr1) (Arr arr2) = 206 | property $ 207 | let arrList1 = C.toList arr1 208 | arrList2 = C.toList arr2 209 | f = \(L xs) (L ys) -> xs ++ ys 210 | in P.zipWith f arrList1 arrList2 == C.toList (C.zipWith f arr1 arr2 :: Array [Int]) 211 | 212 | prop_zip :: Arr -> Arr -> Property 213 | prop_zip (Arr arr1) (Arr arr2) = 214 | property $ 215 | let arrList1 = C.toList arr1 216 | arrList2 = C.toList arr2 217 | in P.zip arrList1 arrList2 == C.toList (C.zip arr1 arr2 :: Array (L, L)) 218 | prop_scanl :: Arr -> Property 219 | prop_scanl (Arr arr) = 220 | property $ 221 | let arrList = C.toList arr 222 | f = \b (L a) -> b ++ a 223 | in P.scanl f [] arrList == C.toList (C.scanl f [] arr :: Array [Int]) 224 | 225 | prop_scanl' :: Arr -> Property 226 | prop_scanl' (Arr arr) = 227 | property $ 228 | let arrList = C.toList arr 229 | f = \b (L a) -> b ++ a 230 | in P.scanl' f [] arrList == C.toList (C.scanl' f [] arr :: Array [Int]) 231 | 232 | prop_partitionEithers :: Array' (Either Int Bool) -> Property 233 | prop_partitionEithers (Array' arr) = 234 | property $ 235 | let arrList = C.toList arr 236 | rhs = case C.partitionEithers arr of (as, bs) -> (C.toList as, C.toList bs) 237 | in P.partitionEithers arrList == rhs 238 | 239 | prop_rights :: Array' (Either Int Bool) -> Property 240 | prop_rights (Array' arr) = 241 | property $ 242 | let arrList = C.toList arr 243 | in P.rights arrList == C.toList (C.rights arr) 244 | 245 | prop_lefts :: Array' (Either Int Bool) -> Property 246 | prop_lefts (Array' arr) = 247 | property $ 248 | let arrList = C.toList arr 249 | in P.lefts arrList == C.toList (C.lefts arr) 250 | 251 | prop_minimum :: Arr -> Property 252 | prop_minimum (Arr arr) = 253 | property $ 254 | let arrList = C.toList arr 255 | in Just (minimum arrList) == C.minimum arr 256 | 257 | prop_maximum :: Arr -> Property 258 | prop_maximum (Arr arr) = 259 | property $ 260 | let arrList = C.toList arr 261 | in Just (maximum arrList) == C.maximum arr 262 | 263 | newtype Array' a = Array' {getArray' :: Array a} 264 | deriving (Eq, Show, Exts.IsList) 265 | 266 | instance (Arbitrary a) => Arbitrary (Array' a) where 267 | arbitrary = do 268 | k <- choose (2, 20) 269 | fmap Exts.fromList $ vectorOf k arbitrary 270 | shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs 271 | 272 | -- Get around quickcheck not generating multiple arrays 273 | -- newtype GenArrM = GenArr { getGenArrM :: Array Int } 274 | -- deriving (Eq, Show, Exts.IsList) 275 | 276 | -- instance Arbitrary GenArrM where 277 | -- arbitrary = do 278 | -- k <- choose (2,20) 279 | -- GenArrM <$> C.generateM k (const arbitrary) 280 | -- shrink xs = fmap Exts.fromList $ shrink $ Exts.toList xs 281 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UnboxedTuples #-} 6 | 7 | module Main (main) where 8 | 9 | import Prelude hiding 10 | ( Foldable (..) 11 | , map 12 | , null 13 | , read 14 | ) 15 | 16 | import Control.Monad 17 | import Data.Functor.Identity (Identity (..)) 18 | import Data.Monoid (Sum (..)) 19 | import Data.Primitive.Contiguous 20 | import GHC.Exts (RealWorld) 21 | import System.Random 22 | import System.Random.Shuffle 23 | import Weigh 24 | 25 | main :: IO () 26 | main = do 27 | array10 <- randomC @Array 10 28 | array100 <- randomC @Array 100 29 | array1000 <- randomC @Array 1000 30 | smallArray10 <- randomC @SmallArray 10 31 | smallArray100 <- randomC @SmallArray 100 32 | smallArray1000 <- randomC @SmallArray 1000 33 | primArray10 <- randomC @PrimArray 10 34 | primArray100 <- randomC @PrimArray 100 35 | primArray1000 <- randomC @PrimArray 1000 36 | 37 | marray10 <- randomCM @Array 10 38 | marray100 <- randomCM @Array 100 39 | marray1000 <- randomCM @Array 1000 40 | msmallArray10 <- randomCM @SmallArray 10 41 | msmallArray100 <- randomCM @SmallArray 100 42 | msmallArray1000 <- randomCM @SmallArray 1000 43 | mprimArray10 <- randomCM @PrimArray 10 44 | mprimArray100 <- randomCM @PrimArray 100 45 | mprimArray1000 <- randomCM @PrimArray 1000 46 | 47 | mainWith $ do 48 | wgroup "0-allocation" $ do 49 | wgroup "size" $ do 50 | func "array10" size array10 51 | func "array100" size array100 52 | func "array1000" size array1000 53 | 54 | func "smallArray10" size smallArray10 55 | func "smallArray100" size smallArray100 56 | func "smallArray1000" size smallArray1000 57 | 58 | func "primArray10" size primArray10 59 | func "primArray100" size primArray100 60 | func "primArray1000" size primArray1000 61 | 62 | io "marray10" sizeMut marray10 63 | io "marray100" sizeMut marray100 64 | io "marray1000" sizeMut marray1000 65 | 66 | io "msmallArray10" sizeMut msmallArray10 67 | io "msmallArray100" sizeMut msmallArray100 68 | io "msmallArray1000" sizeMut msmallArray1000 69 | 70 | io "mprimArray10" sizeMut mprimArray10 71 | io "mprimArray100" sizeMut mprimArray100 72 | io "mprimArray1000" sizeMut mprimArray1000 73 | wgroup "null" $ do 74 | func "array10" null array10 75 | func "array100" null array100 76 | func "array1000" null array1000 77 | 78 | func "smallArray10" null smallArray10 79 | func "smallArray100" null smallArray100 80 | func "smallArray1000" null smallArray1000 81 | 82 | func "primArray10" null primArray10 83 | func "primArray100" null primArray100 84 | func "primArray1000" null primArray1000 85 | wgroup "index/read" $ do 86 | func "array10: index#" (index## 5) array10 87 | func "array100: index#" (index## 50) array100 88 | func "array1000: index#" (index## 500) array1000 89 | 90 | func "smallArray10: index#" (index## 5) smallArray10 91 | func "smallArray100: index#" (index## 50) smallArray100 92 | func "smallArray1000: index#" (index## 500) smallArray1000 93 | 94 | func "primArray10: index#" (index## 5) primArray10 95 | func "primArray100: index#" (index## 50) primArray100 96 | func "primArray1000: index#" (index## 500) primArray1000 97 | 98 | func "array10: index" (flip index 5) array10 99 | func "array100: index" (flip index 50) array100 100 | func "array1000: index" (flip index 500) array1000 101 | 102 | func "smallArray10: index" (flip index 5) smallArray10 103 | func "smallArray100: index" (flip index 50) smallArray100 104 | func "smallArray1000: index" (flip index 500) smallArray1000 105 | 106 | func "primArray10: index" (flip index 5) primArray10 107 | func "primArray100: index" (flip index 50) primArray100 108 | func "primArray1000: index" (flip index 500) primArray1000 109 | 110 | io "marray10: read" (flip read 5) marray10 111 | io "marray100: read" (flip read 50) marray100 112 | io "marray1000: read" (flip read 500) marray1000 113 | 114 | io "msmallArray10: read" (flip read 5) msmallArray10 115 | io "msmallArray100: read" (flip read 50) msmallArray100 116 | io "msmallArray1000: read" (flip read 500) msmallArray1000 117 | 118 | io "mprimArray10: read" (flip read 5) mprimArray10 119 | io "mprimArray100: read" (flip read 50) mprimArray100 120 | io "mprimArray1000: read" (flip read 500) mprimArray1000 121 | wgroup "folds" $ do 122 | wgroup "foldMap" $ do 123 | func "array10: foldMap computes sum" (foldMap sum1) array10 124 | func "array100: foldMap computes sum" (foldMap sum1) array100 125 | func "array1000: foldMap computes sum" (foldMap sum1) array1000 126 | 127 | func "smallArray10: foldMap computes sum" (foldMap sum1) smallArray10 128 | func "smallArray100: foldMap computes sum" (foldMap sum1) smallArray100 129 | func "smallArray1000: foldMap computes sum" (foldMap sum1) smallArray1000 130 | 131 | func "primArray10: foldMap computes sum" (foldMap sum1) primArray10 132 | func "primArray100: foldMap computes sum" (foldMap sum1) primArray100 133 | func "primArray1000: foldMap computes sum" (foldMap sum1) primArray1000 134 | wgroup "foldMap'" $ do 135 | func "array10: foldMap' computes sum" (foldMap' sum1) array10 136 | func "array100: foldMap' computes sum" (foldMap' sum1) array100 137 | func "array1000: foldMap' computes sum" (foldMap' sum1) array1000 138 | 139 | func "smallArray10: foldMap' computes sum" (foldMap' sum1) smallArray10 140 | func "smallArray100: foldMap' computes sum" (foldMap' sum1) smallArray100 141 | func "smallArray1000: foldMap' computes sum" (foldMap' sum1) smallArray1000 142 | 143 | func "primArray10: foldMap' computes sum" (foldMap' sum1) primArray10 144 | func "primArray100: foldMap' computes sum" (foldMap' sum1) primArray100 145 | func "primArray1000: foldMap' computes sum" (foldMap' sum1) primArray1000 146 | wgroup "foldr" $ do 147 | func "array10: foldr computes sum" (foldr (+) 0) array10 148 | func "array100: foldr computes sum" (foldr (+) 0) array100 149 | func "array1000: foldr computes sum" (foldr (+) 0) array1000 150 | 151 | func "smallArray10: foldr computes sum" (foldr (+) 0) smallArray10 152 | func "smallArray100: foldr computes sum" (foldr (+) 0) smallArray100 153 | func "smallArray1000: foldr computes sum" (foldr (+) 0) smallArray1000 154 | 155 | func "primArray10: foldr computes sum" (foldr (+) 0) primArray10 156 | func "primArray100: foldr computes sum" (foldr (+) 0) primArray100 157 | func "primArray1000: foldr computes sum" (foldr (+) 0) primArray1000 158 | wgroup "foldr'" $ do 159 | func "array10: foldr' computes sum" (foldr' (+) 0) array10 160 | func "array100: foldr' computes sum" (foldr' (+) 0) array100 161 | func "array1000: foldr' computes sum" (foldr' (+) 0) array1000 162 | 163 | func "smallArray10: foldr' computes sum" (foldr' (+) 0) smallArray10 164 | func "smallArray100: foldr' computes sum" (foldr' (+) 0) smallArray100 165 | func "smallArray1000: foldr' computes sum" (foldr' (+) 0) smallArray1000 166 | 167 | func "primArray10: foldr' computes sum" (foldr' (+) 0) primArray10 168 | func "primArray100: foldr' computes sum" (foldr' (+) 0) primArray100 169 | func "primArray1000: foldr' computes sum" (foldr' (+) 0) primArray1000 170 | wgroup "foldl" $ do 171 | func "array10: foldl computes sum" (foldl (+) 0) array10 172 | func "array100: foldl computes sum" (foldl (+) 0) array100 173 | func "array1000: foldl computes sum" (foldl (+) 0) array1000 174 | 175 | func "smallArray10: foldl computes sum" (foldl (+) 0) smallArray10 176 | func "smallArray100: foldl computes sum" (foldl (+) 0) smallArray100 177 | func "smallArray1000: foldl computes sum" (foldl (+) 0) smallArray1000 178 | 179 | func "primArray10: foldl computes sum" (foldl (+) 0) primArray10 180 | func "primArray100: foldl computes sum" (foldl (+) 0) primArray100 181 | func "primArray1000: foldl computes sum" (foldl (+) 0) primArray1000 182 | wgroup "foldl'" $ do 183 | func "array10: foldl' computes sum" (foldl' (+) 0) array10 184 | func "array100: foldl' computes sum" (foldl' (+) 0) array100 185 | func "array1000: foldl' computes sum" (foldl' (+) 0) array1000 186 | 187 | func "smallArray10: foldl' computes sum" (foldl' (+) 0) smallArray10 188 | func "smallArray100: foldl' computes sum" (foldl' (+) 0) smallArray100 189 | func "smallArray1000: foldl' computes sum" (foldl' (+) 0) smallArray1000 190 | 191 | func "primArray10: foldl' computes sum" (foldl' (+) 0) primArray10 192 | func "primArray100: foldl' computes sum" (foldl' (+) 0) primArray100 193 | func "primArray1000: foldl' computes sum" (foldl' (+) 0) primArray1000 194 | wgroup "ifoldl'" $ do 195 | func "array10: ifoldl' computes sum" (ifoldl' add3 0) array10 196 | func "array100: ifoldl' computes sum" (ifoldl' add3 0) array100 197 | func "array1000: ifoldl' computes sum" (ifoldl' add3 0) array1000 198 | 199 | func "smallArray10: ifoldl' computes sum" (ifoldl' add3 0) smallArray10 200 | func "smallArray100: ifoldl' computes sum" (ifoldl' add3 0) smallArray100 201 | func "smallArray1000: ifoldl' computes sum" (ifoldl' add3 0) smallArray1000 202 | 203 | func "primArray10: ifoldl' computes sum" (ifoldl' add3 0) primArray10 204 | func "primArray100: ifoldl' computes sum" (ifoldl' add3 0) primArray100 205 | func "primArray1000: ifoldl' computes sum" (ifoldl' add3 0) primArray1000 206 | wgroup "ifoldr'" $ do 207 | func "array10: ifoldr' computes sum" (ifoldr' add3 0) array10 208 | func "array100: ifoldr' computes sum" (ifoldr' add3 0) array100 209 | func "array1000: ifoldr' computes sum" (ifoldr' add3 0) array1000 210 | 211 | func "smallArray10: ifoldr' computes sum" (ifoldr' add3 0) smallArray10 212 | func "smallArray100: ifoldr' computes sum" (ifoldr' add3 0) smallArray100 213 | func "smallArray1000: ifoldr' computes sum" (ifoldr' add3 0) smallArray1000 214 | 215 | func "primArray10: ifoldr' computes sum" (ifoldr' add3 0) primArray10 216 | func "primArray100: ifoldr' computes sum" (ifoldr' add3 0) primArray100 217 | func "primArray1000: ifoldr' computes sum" (ifoldr' add3 0) primArray1000 218 | wgroup "foldlMap'" $ do 219 | func "array10: foldlMap' computes sum" (foldMap' sum1) array10 220 | func "array100: foldlMap' computes sum" (foldMap' sum1) array100 221 | func "array1000: foldlMap' computes sum" (foldMap' sum1) array1000 222 | 223 | func "smallArray10: foldlMap' computes sum" (foldMap' sum1) smallArray10 224 | func "smallArray100: foldlMap' computes sum" (foldMap' sum1) smallArray100 225 | func "smallArray1000: foldlMap' computes sum" (foldMap' sum1) smallArray1000 226 | 227 | func "primArray10: foldlMap' computes sum" (foldMap' sum1) primArray10 228 | func "primArray100: foldlMap' computes sum" (foldMap' sum1) primArray100 229 | func "primArray1000: foldlMap' computes sum" (foldMap' sum1) primArray1000 230 | 231 | wgroup "ifoldlMap'" $ do 232 | func "array10: ifoldlMap' computes sum" (ifoldlMap' isumN) array10 233 | func "array100: ifoldlMap' computes sum" (ifoldlMap' isumN) array100 234 | func "array1000: ifoldlMap' computes sum" (ifoldlMap' isumN) array1000 235 | 236 | func "smallArray10: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray10 237 | func "smallArray100: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray100 238 | func "smallArray1000: ifoldlMap' computes sum" (ifoldlMap' isumN) smallArray1000 239 | 240 | func "primArray10: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray10 241 | func "primArray100: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray100 242 | func "primArray1000: ifoldlMap' computes sum" (ifoldlMap' isumN) primArray1000 243 | wgroup "ifoldlMap1'" $ do 244 | func "array10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array10 245 | func "array100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array100 246 | func "array1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) array1000 247 | 248 | func "smallArray10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray10 249 | func "smallArray100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray100 250 | func "smallArray1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) smallArray1000 251 | 252 | func "primArray10: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray10 253 | func "primArray100: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray100 254 | func "primArray1000: ifoldlMap1' computes sum" (ifoldlMap1' isumN) primArray1000 255 | wgroup "foldlM'" $ do 256 | func "array10: foldlM' computes sum" (foldlM' idM 0) array10 257 | func "array100: foldlM' computes sum" (foldlM' idM 0) array100 258 | func "array1000: foldlM' computes sum" (foldlM' idM 0) array1000 259 | 260 | func "smallArray10: foldlM' computes sum" (foldlM' idM 0) smallArray10 261 | func "smallArray100: foldlM' computes sum" (foldlM' idM 0) smallArray100 262 | func "smallArray1000: foldlM' computes sum" (foldlM' idM 0) smallArray1000 263 | 264 | func "primArray10: foldlM' computes sum" (foldlM' idM 0) primArray10 265 | func "primArray100: foldlM' computes sum" (foldlM' idM 0) primArray100 266 | func "primArray1000: foldlM' computes sum" (foldlM' idM 0) primArray1000 267 | wgroup "maps" $ do 268 | wgroup "map" $ do 269 | func "array10" mapPlus1 array10 270 | func "array100" mapPlus1 array100 271 | func "array1000" mapPlus1 array1000 272 | 273 | func "smallArray10" mapPlus1 smallArray10 274 | func "smallArray100" mapPlus1 smallArray100 275 | func "smallArray1000" mapPlus1 smallArray1000 276 | 277 | func "primArray10" mapPlus1 primArray10 278 | func "primArray100" mapPlus1 primArray100 279 | func "primArray1000" mapPlus1 primArray1000 280 | wgroup "map'" $ do 281 | func "array10" mapPlus1' array10 282 | func "array100" mapPlus1' array100 283 | func "array1000" mapPlus1' array1000 284 | 285 | func "smallArray10" mapPlus1' smallArray10 286 | func "smallArray100" mapPlus1' smallArray100 287 | func "smallArray1000" mapPlus1' smallArray1000 288 | 289 | func "primArray10" mapPlus1' primArray10 290 | func "primArray100" mapPlus1' primArray100 291 | func "primArray1000" mapPlus1' primArray1000 292 | wgroup "mapMaybe" $ do 293 | func "array10" mapMaybeJ array10 294 | func "array100" mapMaybeJ array100 295 | func "array1000" mapMaybeJ array1000 296 | 297 | func "smallArray10" mapMaybeJ smallArray10 298 | func "smallArray100" mapMaybeJ smallArray100 299 | func "smallArray1000" mapMaybeJ smallArray1000 300 | 301 | func "primArray10" mapMaybeJ primArray10 302 | func "primArray100" mapMaybeJ primArray100 303 | func "primArray1000" mapMaybeJ primArray1000 304 | 305 | mapMaybeJ :: 306 | forall arr. 307 | (Contiguous arr, Element arr Int) => 308 | arr Int -> 309 | () 310 | mapMaybeJ arr = 311 | let !(_arr' :: arr Int) = mapMaybe Just arr 312 | in () 313 | 314 | mapPlus1 :: 315 | forall arr. 316 | (Contiguous arr, Element arr Int) => 317 | arr Int -> 318 | () 319 | mapPlus1 arr = let !(_arr' :: arr Int) = map (+ 1) arr in () 320 | 321 | mapPlus1' :: 322 | forall arr. 323 | (Contiguous arr, Element arr Int) => 324 | arr Int -> 325 | () 326 | mapPlus1' arr = let !(_arr' :: arr Int) = map' (+ 1) arr in () 327 | 328 | _plus1 :: Int -> Int 329 | _plus1 = (+ 1) 330 | 331 | sum1 :: a -> Sum Int 332 | sum1 = const (Sum 1) 333 | 334 | isumN :: Int -> a -> Sum Int 335 | isumN x = const (Sum x) 336 | 337 | idM :: Int -> Int -> Identity Int 338 | idM x y = Identity (x + y) 339 | 340 | add3 :: Int -> Int -> Int -> Int 341 | add3 x y z = x + y + z 342 | 343 | index## :: (Contiguous arr, Element arr a) => Int -> arr a -> () 344 | index## ix arr = case index# arr ix of !(# _x #) -> () 345 | 346 | randomList :: Int -> IO [Int] 347 | randomList sz = replicateM sz (randomRIO (minBound, maxBound)) 348 | 349 | randomC :: 350 | (Contiguous arr, Element arr Int) => 351 | Int -> 352 | IO (arr Int) 353 | randomC sz = do 354 | rList <- randomList sz 355 | rList' <- shuffleM rList 356 | pure (fromListN sz rList') 357 | 358 | randomCM :: 359 | (Contiguous arr, Element arr Int) => 360 | Int -> 361 | IO (Mutable arr RealWorld Int) 362 | randomCM sz = do 363 | rList <- randomList sz 364 | rList' <- shuffleM rList 365 | fromListMutableN sz rList' 366 | -------------------------------------------------------------------------------- /src/Data/Primitive/Contiguous/Class.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DefaultSignatures #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE MagicHash #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | {-# LANGUAGE NamedFieldPuns #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeFamilyDependencies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UnboxedTuples #-} 15 | {-# LANGUAGE UnliftedNewtypes #-} 16 | 17 | {- | The 'Contiguous' typeclass parameterises over a contiguous array type. 18 | It provides the core primitives necessary to implement the common API in "Data.Primitive.Contiguous". 19 | This allows us to have a common API to a number of contiguous 20 | array types and their mutable counterparts. 21 | -} 22 | module Data.Primitive.Contiguous.Class 23 | ( Contiguous (..) 24 | , Slice (..) 25 | , MutableSlice (..) 26 | , ContiguousU (..) 27 | , Always 28 | ) where 29 | 30 | import Data.Primitive 31 | import Data.Primitive.Contiguous.Shim 32 | import Data.Primitive.Unlifted.Array 33 | import Data.Primitive.Unlifted.SmallArray 34 | import Prelude hiding 35 | ( all 36 | , any 37 | , elem 38 | , filter 39 | , foldMap 40 | , foldl 41 | , foldr 42 | , length 43 | , map 44 | , mapM 45 | , mapM_ 46 | , maximum 47 | , minimum 48 | , null 49 | , read 50 | , replicate 51 | , reverse 52 | , scanl 53 | , sequence 54 | , sequence_ 55 | , traverse 56 | , zip 57 | , zipWith 58 | , (<$) 59 | ) 60 | 61 | import Control.DeepSeq (NFData) 62 | import Control.Monad.Primitive (PrimMonad (..), PrimState) 63 | import Control.Monad.ST (ST, runST) 64 | import Control.Monad.ST.Run (runArrayST, runPrimArrayST, runSmallArrayST, runUnliftedArrayST) 65 | import Data.Kind (Type) 66 | import Data.Primitive.Unlifted.Array () 67 | import Data.Primitive.Unlifted.Array.Primops (MutableUnliftedArray# (MutableUnliftedArray#), UnliftedArray# (UnliftedArray#)) 68 | import Data.Primitive.Unlifted.SmallArray.Primops (SmallUnliftedArray# (SmallUnliftedArray#), SmallMutableUnliftedArray# (SmallMutableUnliftedArray#)) 69 | import Data.Primitive.Unlifted.Class (PrimUnlifted) 70 | import GHC.Exts (Array#, Constraint, MutableArray#, SmallArray#, SmallMutableArray#, TYPE, sizeofArray#, sizeofByteArray#) 71 | import GHC.ST (ST (ST)) 72 | 73 | import qualified Control.DeepSeq as DS 74 | import qualified Data.Primitive.Unlifted.Class as Class 75 | import qualified GHC.Exts as Exts 76 | 77 | -- In GHC 9.2 the UnliftedRep constructor of RuntimeRep was removed 78 | -- and replaced with a type synonym 79 | #if __GLASGOW_HASKELL__ >= 902 80 | import GHC.Exts (UnliftedRep) 81 | #else 82 | import GHC.Exts (RuntimeRep(UnliftedRep)) 83 | type UnliftedRep = 'UnliftedRep 84 | #endif 85 | 86 | {- | Slices of immutable arrays: packages an offset and length with a backing array. 87 | 88 | @since 0.6.0 89 | -} 90 | data Slice arr a = Slice 91 | { offset :: {-# UNPACK #-} !Int 92 | , length :: {-# UNPACK #-} !Int 93 | , base :: !(Unlifted arr a) 94 | } 95 | 96 | {- | Slices of mutable arrays: packages an offset and length with a mutable backing array. 97 | 98 | @since 0.6.0 99 | -} 100 | data MutableSlice arr s a = MutableSlice 101 | { offsetMut :: {-# UNPACK #-} !Int 102 | , lengthMut :: {-# UNPACK #-} !Int 103 | , baseMut :: !(UnliftedMut arr s a) 104 | } 105 | 106 | {- | The 'Contiguous' typeclass as an interface to a multitude of 107 | contiguous structures. 108 | 109 | Some functions do not make sense on slices; for those, see 'ContiguousU'. 110 | -} 111 | class Contiguous (arr :: Type -> Type) where 112 | -- | The Mutable counterpart to the array. 113 | type Mutable arr = (r :: Type -> Type -> Type) | r -> arr 114 | 115 | -- | The constraint needed to store elements in the array. 116 | type Element arr :: Type -> Constraint 117 | 118 | -- | The slice type of this array. 119 | -- The slice of a raw array type @t@ should be 'Slice t', 120 | -- whereas the slice of a slice should be the same slice type. 121 | -- 122 | -- @since 0.6.0 123 | type Sliced arr :: Type -> Type 124 | 125 | -- | The mutable slice type of this array. 126 | -- The mutable slice of a raw array type @t@ should be 'MutableSlice t', 127 | -- whereas the mutable slice of a mutable slice should be the same slice type. 128 | -- 129 | -- @since 0.6.0 130 | type MutableSliced arr :: Type -> Type -> Type 131 | 132 | ------ Construction ------ 133 | 134 | -- | Allocate a new mutable array of the given size. 135 | new :: (PrimMonad m, Element arr b) => Int -> m (Mutable arr (PrimState m) b) 136 | 137 | -- | @'replicateMut' n x@ is a mutable array of length @n@ with @x@ the 138 | -- value of every element. 139 | replicateMut :: 140 | (PrimMonad m, Element arr b) => 141 | Int -> -- length 142 | b -> -- fill element 143 | m (Mutable arr (PrimState m) b) 144 | 145 | -- | Resize an array without growing it. It may be shrunk in place. 146 | -- 147 | -- @since 0.6.0 148 | shrink :: 149 | (PrimMonad m, Element arr a) => 150 | Mutable arr (PrimState m) a -> 151 | -- | new length 152 | Int -> 153 | m (Mutable arr (PrimState m) a) 154 | 155 | -- | The empty array. 156 | empty :: arr a 157 | 158 | -- | Create a singleton array. 159 | singleton :: (Element arr a) => a -> arr a 160 | 161 | -- | Create a doubleton array. 162 | doubleton :: (Element arr a) => a -> a -> arr a 163 | 164 | -- | Create a tripleton array. 165 | tripleton :: (Element arr a) => a -> a -> a -> arr a 166 | 167 | -- | Create a quadrupleton array. 168 | quadrupleton :: (Element arr a) => a -> a -> a -> a -> arr a 169 | 170 | -- | Create a quintupleton array. 171 | quintupleton :: (Element arr a) => a -> a -> a -> a -> a -> arr a 172 | 173 | -- | Create a sextupleton array. 174 | sextupleton :: (Element arr a) => a -> a -> a -> a -> a -> a -> arr a 175 | 176 | ------ Access and Update ------ 177 | 178 | -- | Index into an array at the given index. 179 | index :: (Element arr b) => arr b -> Int -> b 180 | 181 | -- | Index into an array at the given index, yielding an unboxed one-tuple of the element. 182 | index# :: (Element arr b) => arr b -> Int -> (# b #) 183 | 184 | -- | Indexing in a monad. 185 | -- 186 | -- The monad allows operations to be strict in the array 187 | -- when necessary. Suppose array copying is implemented like this: 188 | -- 189 | -- > copy mv v = ... write mv i (v ! i) ... 190 | -- 191 | -- For lazy arrays, @v ! i@ would not be not be evaluated, 192 | -- which means that @mv@ would unnecessarily retain a reference 193 | -- to @v@ in each element written. 194 | -- 195 | -- With 'indexM', copying can be implemented like this instead: 196 | -- 197 | -- > copy mv v = ... do 198 | -- > x <- indexM v i 199 | -- > write mv i x 200 | -- 201 | -- Here, no references to @v@ are retained because indexing 202 | -- (but /not/ the elements) is evaluated eagerly. 203 | indexM :: (Element arr b, Monad m) => arr b -> Int -> m b 204 | 205 | -- | Read a mutable array at the given index. 206 | read :: 207 | (PrimMonad m, Element arr b) => 208 | Mutable arr (PrimState m) b -> 209 | Int -> 210 | m b 211 | 212 | -- | Write to a mutable array at the given index. 213 | write :: 214 | (PrimMonad m, Element arr b) => 215 | Mutable arr (PrimState m) b -> 216 | Int -> 217 | b -> 218 | m () 219 | 220 | ------ Properties ------ 221 | 222 | -- | Test whether the array is empty. 223 | null :: arr b -> Bool 224 | 225 | -- | The size of the array 226 | size :: (Element arr b) => arr b -> Int 227 | 228 | -- | The size of the mutable array 229 | sizeMut :: 230 | (PrimMonad m, Element arr b) => 231 | Mutable arr (PrimState m) b -> 232 | m Int 233 | 234 | -- | Test the two arrays for equality. 235 | equals :: (Element arr b, Eq b) => arr b -> arr b -> Bool 236 | 237 | -- | Test the two mutable arrays for pointer equality. 238 | -- Does not check equality of elements. 239 | equalsMut :: Mutable arr s a -> Mutable arr s a -> Bool 240 | 241 | ------ Conversion ------ 242 | 243 | -- | Create a 'Slice' of an array. 244 | -- 245 | -- @O(1)@. 246 | -- 247 | -- @since 0.6.0 248 | slice :: 249 | (Element arr a) => 250 | arr a -> -- base array 251 | Int -> -- offset 252 | Int -> -- length 253 | Sliced arr a 254 | 255 | -- | Create a 'MutableSlice' of a mutable array. 256 | -- 257 | -- @O(1)@. 258 | -- 259 | -- @since 0.6.0 260 | sliceMut :: 261 | (Element arr a) => 262 | Mutable arr s a -> -- base array 263 | Int -> -- offset 264 | Int -> -- length 265 | MutableSliced arr s a 266 | 267 | -- | Create a 'Slice' that covers the entire array. 268 | -- 269 | -- @since 0.6.0 270 | toSlice :: (Element arr a) => arr a -> Sliced arr a 271 | 272 | -- | Create a 'MutableSlice' that covers the entire array. 273 | -- 274 | -- @since 0.6.0 275 | toSliceMut :: 276 | (PrimMonad m, Element arr a) => 277 | Mutable arr (PrimState m) a -> 278 | m (MutableSliced arr (PrimState m) a) 279 | 280 | -- | Clone a slice of an array. 281 | clone :: 282 | (Element arr b) => 283 | -- | slice to copy 284 | Sliced arr b -> 285 | arr b 286 | default clone :: 287 | ( Sliced arr ~ Slice arr 288 | , ContiguousU arr 289 | , Element arr b 290 | ) => 291 | Sliced arr b -> 292 | arr b 293 | {-# INLINE clone #-} 294 | clone Slice {offset, length, base} = clone_ (lift base) offset length 295 | 296 | -- | Clone a slice of an array without using the 'Slice' type. 297 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 298 | -- they are not really meant for direct use. 299 | -- 300 | -- @since 0.6.0 301 | clone_ :: (Element arr a) => arr a -> Int -> Int -> arr a 302 | 303 | -- | Clone a slice of a mutable array. 304 | cloneMut :: 305 | (PrimMonad m, Element arr b) => 306 | -- | Array to copy a slice of 307 | MutableSliced arr (PrimState m) b -> 308 | m (Mutable arr (PrimState m) b) 309 | default cloneMut :: 310 | ( MutableSliced arr ~ MutableSlice arr 311 | , ContiguousU arr 312 | , PrimMonad m 313 | , Element arr b 314 | ) => 315 | MutableSliced arr (PrimState m) b -> 316 | m (Mutable arr (PrimState m) b) 317 | {-# INLINE cloneMut #-} 318 | cloneMut MutableSlice {offsetMut, lengthMut, baseMut} = 319 | cloneMut_ (liftMut baseMut) offsetMut lengthMut 320 | 321 | -- | Clone a slice of a mutable array without using the 'MutableSlice' type. 322 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 323 | -- they are not really meant for direct use. 324 | -- 325 | -- @since 0.6.0 326 | cloneMut_ :: 327 | (PrimMonad m, Element arr b) => 328 | -- | Array to copy a slice of 329 | Mutable arr (PrimState m) b -> 330 | -- | offset 331 | Int -> 332 | -- | length 333 | Int -> 334 | m (Mutable arr (PrimState m) b) 335 | 336 | -- | Turn a mutable array slice an immutable array by copying. 337 | -- 338 | -- @since 0.6.0 339 | freeze :: 340 | (PrimMonad m, Element arr a) => 341 | MutableSliced arr (PrimState m) a -> 342 | m (arr a) 343 | default freeze :: 344 | ( MutableSliced arr ~ MutableSlice arr 345 | , ContiguousU arr 346 | , PrimMonad m 347 | , Element arr a 348 | ) => 349 | MutableSliced arr (PrimState m) a -> 350 | m (arr a) 351 | {-# INLINE freeze #-} 352 | freeze MutableSlice {offsetMut, lengthMut, baseMut} = 353 | freeze_ (liftMut baseMut) offsetMut lengthMut 354 | 355 | -- | Turn a slice of a mutable array into an immutable one with copying, 356 | -- without using the 'MutableSlice' type. 357 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 358 | -- they are not really meant for direct use. 359 | -- 360 | -- @since 0.6.0 361 | freeze_ :: 362 | (PrimMonad m, Element arr b) => 363 | Mutable arr (PrimState m) b -> 364 | -- | offset 365 | Int -> 366 | -- | length 367 | Int -> 368 | m (arr b) 369 | 370 | -- | Turn a mutable array into an immutable one without copying. 371 | -- The mutable array should not be used after this conversion. 372 | unsafeFreeze :: 373 | (PrimMonad m, Element arr b) => 374 | Mutable arr (PrimState m) b -> 375 | m (arr b) 376 | 377 | unsafeShrinkAndFreeze :: 378 | (PrimMonad m, Element arr a) => 379 | Mutable arr (PrimState m) a -> 380 | -- | final size 381 | Int -> 382 | m (arr a) 383 | 384 | -- | Copy a slice of an immutable array into a new mutable array. 385 | thaw :: 386 | (PrimMonad m, Element arr b) => 387 | Sliced arr b -> 388 | m (Mutable arr (PrimState m) b) 389 | default thaw :: 390 | ( Sliced arr ~ Slice arr 391 | , ContiguousU arr 392 | , PrimMonad m 393 | , Element arr b 394 | ) => 395 | Sliced arr b -> 396 | m (Mutable arr (PrimState m) b) 397 | {-# INLINE thaw #-} 398 | thaw Slice {offset, length, base} = thaw_ (lift base) offset length 399 | 400 | -- | Copy a slice of an immutable array into a new mutable array without using the 'Slice' type. 401 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 402 | -- they are not really meant for direct use. 403 | -- 404 | -- @since 0.6.0 405 | thaw_ :: 406 | (PrimMonad m, Element arr b) => 407 | arr b -> 408 | -- | offset into the array 409 | Int -> 410 | -- | length of the slice 411 | Int -> 412 | m (Mutable arr (PrimState m) b) 413 | 414 | ------ Copy Operations ------ 415 | 416 | -- | Copy a slice of an array into a mutable array. 417 | copy :: 418 | (PrimMonad m, Element arr b) => 419 | -- | destination array 420 | Mutable arr (PrimState m) b -> 421 | -- | offset into destination array 422 | Int -> 423 | -- | source slice 424 | Sliced arr b -> 425 | m () 426 | default copy :: 427 | ( Sliced arr ~ Slice arr 428 | , ContiguousU arr 429 | , PrimMonad m 430 | , Element arr b 431 | ) => 432 | Mutable arr (PrimState m) b -> 433 | Int -> 434 | Sliced arr b -> 435 | m () 436 | {-# INLINE copy #-} 437 | copy dst dstOff Slice {offset, length, base} = copy_ dst dstOff (lift base) offset length 438 | 439 | -- | Copy a slice of an array into a mutable array without using the 'Slice' type. 440 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 441 | -- they are not really meant for direct use. 442 | -- 443 | -- @since 0.6.0 444 | copy_ :: 445 | (PrimMonad m, Element arr b) => 446 | -- | destination array 447 | Mutable arr (PrimState m) b -> 448 | -- | offset into destination array 449 | Int -> 450 | -- | source array 451 | arr b -> 452 | -- | offset into source array 453 | Int -> 454 | -- | number of elements to copy 455 | Int -> 456 | m () 457 | 458 | -- | Copy a slice of a mutable array into another mutable array. 459 | -- In the case that the destination and source arrays are the 460 | -- same, the regions may overlap. 461 | copyMut :: 462 | (PrimMonad m, Element arr b) => 463 | -- | destination array 464 | Mutable arr (PrimState m) b -> 465 | -- | offset into destination array 466 | Int -> 467 | -- | source slice 468 | MutableSliced arr (PrimState m) b -> 469 | m () 470 | default copyMut :: 471 | ( MutableSliced arr ~ MutableSlice arr 472 | , ContiguousU arr 473 | , PrimMonad m 474 | , Element arr b 475 | ) => 476 | Mutable arr (PrimState m) b -> 477 | Int -> 478 | MutableSliced arr (PrimState m) b -> 479 | m () 480 | {-# INLINE copyMut #-} 481 | copyMut dst dstOff MutableSlice {offsetMut, lengthMut, baseMut} = 482 | copyMut_ dst dstOff (liftMut baseMut) offsetMut lengthMut 483 | 484 | -- | Copy a slice of a mutable array into another mutable array without using the 'Slice' type. 485 | -- These methods are required to implement 'Contiguous (Slice arr)' for any `Contiguous arr`; 486 | -- they are not really meant for direct use. 487 | -- 488 | -- @since 0.6.0 489 | copyMut_ :: 490 | (PrimMonad m, Element arr b) => 491 | -- | destination array 492 | Mutable arr (PrimState m) b -> 493 | -- | offset into destination array 494 | Int -> 495 | -- | source array 496 | Mutable arr (PrimState m) b -> 497 | -- | offset into source array 498 | Int -> 499 | -- | number of elements to copy 500 | Int -> 501 | m () 502 | 503 | -- | Copy a slice of an array and then insert an element into that array. 504 | -- 505 | -- The default implementation performs a memset which would be unnecessary 506 | -- except that the garbage collector might trace the uninitialized array. 507 | -- 508 | -- Was previously @insertSlicing@ 509 | -- @since 0.6.0 510 | insertAt :: 511 | (Element arr b) => 512 | -- | slice to copy from 513 | arr b -> 514 | -- | index in the output array to insert at 515 | Int -> 516 | -- | element to insert 517 | b -> 518 | arr b 519 | default insertAt :: 520 | (Element arr b, ContiguousU arr) => 521 | arr b -> 522 | Int -> 523 | b -> 524 | arr b 525 | insertAt src i x = run $ do 526 | dst <- replicateMut (size src + 1) x 527 | copy dst 0 (slice src 0 i) 528 | copy dst (i + 1) (slice src i (size src - i)) 529 | unsafeFreeze dst 530 | {-# INLINE insertAt #-} 531 | 532 | ------ Reduction ------ 533 | 534 | -- | Reduce the array and all of its elements to WHNF. 535 | rnf :: (NFData a, Element arr a) => arr a -> () 536 | 537 | -- | Run an effectful computation that produces an array. 538 | run :: (forall s. ST s (arr a)) -> arr a 539 | 540 | {- | The 'ContiguousU' typeclass is an extension of the 'Contiguous' typeclass, 541 | but includes operations that make sense only on unsliced contiguous structures. 542 | 543 | @since 0.6.0 544 | -} 545 | class (Contiguous arr) => ContiguousU arr where 546 | -- | The unifted version of the immutable array type (i.e. eliminates an indirection through a thunk). 547 | type Unlifted arr = (r :: Type -> TYPE UnliftedRep) | r -> arr 548 | 549 | -- | The unifted version of the mutable array type (i.e. eliminates an indirection through a thunk). 550 | type UnliftedMut arr = (r :: Type -> Type -> TYPE UnliftedRep) | r -> arr 551 | 552 | -- | Resize an array into one with the given size. If the array is grown, 553 | -- then reading from any newly introduced element before writing to it is undefined behavior. 554 | -- The current behavior is that anything backed by @MutableByteArray#@ ends with 555 | -- uninitialized memory at these indices. But for @SmallMutableArray@ or @Array@, these 556 | -- are set to an error thunk, so reading from them and forcing the result 557 | -- causes the program to crash. For @UnliftedArray@, the new elements have undefined values of an unknown type. 558 | -- If the array is not grown, it may (or may not) be modified in place. 559 | resize :: 560 | (PrimMonad m, Element arr b) => 561 | Mutable arr (PrimState m) b -> 562 | Int -> 563 | m (Mutable arr (PrimState m) b) 564 | 565 | -- | Unlift an array (i.e. point to the data without an intervening thunk). 566 | -- 567 | -- @since 0.6.0 568 | unlift :: arr b -> Unlifted arr b 569 | 570 | -- | Unlift a mutable array (i.e. point to the data without an intervening thunk). 571 | -- 572 | -- @since 0.6.0 573 | unliftMut :: Mutable arr s b -> UnliftedMut arr s b 574 | 575 | -- | Lift an array (i.e. point to the data through an intervening thunk). 576 | -- 577 | -- @since 0.6.0 578 | lift :: Unlifted arr b -> arr b 579 | 580 | -- | Lift a mutable array (i.e. point to the data through an intervening thunk). 581 | -- 582 | -- @since 0.6.0 583 | liftMut :: UnliftedMut arr s b -> Mutable arr s b 584 | 585 | {- | A typeclass that is satisfied by all types. This is used 586 | used to provide a fake constraint for 'Array' and 'SmallArray'. 587 | -} 588 | class Always a 589 | 590 | instance Always a 591 | 592 | instance (ContiguousU arr) => Contiguous (Slice arr) where 593 | type Mutable (Slice arr) = MutableSlice arr 594 | type Element (Slice arr) = Element arr 595 | type Sliced (Slice arr) = Slice arr 596 | type MutableSliced (Slice arr) = MutableSlice arr 597 | 598 | ------ Construction ------ 599 | {-# INLINE new #-} 600 | new len = do 601 | baseMut <- new len 602 | pure MutableSlice {offsetMut = 0, lengthMut = len, baseMut = unliftMut baseMut} 603 | {-# INLINE replicateMut #-} 604 | replicateMut len x = do 605 | baseMut <- replicateMut len x 606 | pure MutableSlice {offsetMut = 0, lengthMut = len, baseMut = unliftMut baseMut} 607 | {-# INLINE unsafeFreeze #-} 608 | unsafeFreeze (MutableSlice off len base) = do 609 | base' <- unsafeFreeze (liftMut base) 610 | pure (Slice off len (unlift base')) 611 | {-# INLINE shrink #-} 612 | shrink xs len' = pure $ case compare len' (lengthMut xs) of 613 | LT -> xs {lengthMut = len'} 614 | EQ -> xs 615 | GT -> errorWithoutStackTrace "Data.Primitive.Contiguous.Class.shrink: passed a larger than existing size" 616 | {-# INLINE empty #-} 617 | empty = Slice {offset = 0, length = 0, base = unlift empty} 618 | {-# INLINE singleton #-} 619 | singleton a = Slice {offset = 0, length = 1, base = unlift $ singleton a} 620 | {-# INLINE doubleton #-} 621 | doubleton a b = Slice {offset = 0, length = 2, base = unlift $ doubleton a b} 622 | {-# INLINE tripleton #-} 623 | tripleton a b c = Slice {offset = 0, length = 3, base = unlift $ tripleton a b c} 624 | {-# INLINE quadrupleton #-} 625 | quadrupleton a b c d = Slice {offset = 0, length = 4, base = unlift $ quadrupleton a b c d} 626 | {-# INLINE quintupleton #-} 627 | quintupleton a b c d e = Slice {offset = 0, length = 5, base = unlift $ quintupleton a b c d e} 628 | {-# INLINE sextupleton #-} 629 | sextupleton a b c d e f = Slice {offset = 0, length = 6, base = unlift $ sextupleton a b c d e f} 630 | 631 | ------ Access and Update ------ 632 | {-# INLINE index #-} 633 | index Slice {offset, base} i = index (lift base) (offset + i) 634 | {-# INLINE index# #-} 635 | index# Slice {offset, base} i = index# (lift base) (offset + i) 636 | {-# INLINE indexM #-} 637 | indexM Slice {offset, base} i = indexM (lift base) (offset + i) 638 | {-# INLINE read #-} 639 | read MutableSlice {offsetMut, baseMut} i = read (liftMut baseMut) (offsetMut + i) 640 | {-# INLINE write #-} 641 | write MutableSlice {offsetMut, baseMut} i = write (liftMut baseMut) (offsetMut + i) 642 | 643 | ------ Properties ------ 644 | {-# INLINE null #-} 645 | null Slice {length} = length == 0 646 | {-# INLINE size #-} 647 | size Slice {length} = length 648 | {-# INLINE sizeMut #-} 649 | sizeMut MutableSlice {lengthMut} = pure lengthMut 650 | {-# INLINE equals #-} 651 | equals 652 | Slice {offset = oA, length = lenA, base = a} 653 | Slice {offset = oB, length = lenB, base = b} = 654 | lenA == lenB && loop 0 oA oB 655 | where 656 | loop !i !iA !iB = 657 | if i == lenA 658 | then True 659 | else index (lift a) iA == index (lift b) iB && loop (i + 1) (iA + 1) (iB + 1) 660 | {-# INLINE equalsMut #-} 661 | equalsMut 662 | MutableSlice {offsetMut = offA, lengthMut = lenA, baseMut = a} 663 | MutableSlice {offsetMut = offB, lengthMut = lenB, baseMut = b} = 664 | liftMut a `equalsMut` liftMut b 665 | && offA == offB 666 | && lenA == lenB 667 | 668 | ------ Conversion ------ 669 | {-# INLINE slice #-} 670 | slice Slice {offset, base} off' len' = 671 | Slice 672 | { offset = offset + off' 673 | , length = len' 674 | , base 675 | } 676 | {-# INLINE sliceMut #-} 677 | sliceMut MutableSlice {offsetMut, baseMut} off' len' = 678 | MutableSlice 679 | { offsetMut = offsetMut + off' 680 | , lengthMut = len' 681 | , baseMut 682 | } 683 | {-# INLINE clone #-} 684 | clone = id 685 | {-# INLINE clone_ #-} 686 | clone_ Slice {offset, base} off' len' = 687 | Slice {offset = offset + off', length = len', base} 688 | {-# INLINE cloneMut #-} 689 | cloneMut xs@MutableSlice {lengthMut} = cloneMut_ xs 0 lengthMut 690 | {-# INLINE cloneMut_ #-} 691 | cloneMut_ MutableSlice {offsetMut, baseMut} off' len' = do 692 | baseMut' <- cloneMut_ (liftMut baseMut) (offsetMut + off') len' 693 | pure MutableSlice {offsetMut = 0, lengthMut = len', baseMut = unliftMut baseMut'} 694 | {-# INLINE freeze #-} 695 | freeze xs@MutableSlice {lengthMut} = 696 | freeze_ xs 0 lengthMut 697 | {-# INLINE freeze_ #-} 698 | freeze_ MutableSlice {offsetMut, baseMut} off' len' = do 699 | base <- freeze_ (liftMut baseMut) (offsetMut + off') len' 700 | pure Slice {offset = 0, length = len', base = unlift base} 701 | {-# INLINE unsafeShrinkAndFreeze #-} 702 | unsafeShrinkAndFreeze MutableSlice {offsetMut = 0, lengthMut, baseMut} len' = do 703 | shrunk <- 704 | if lengthMut /= len' 705 | then resize (liftMut baseMut) len' 706 | else pure (liftMut baseMut) 707 | base <- unsafeFreeze shrunk 708 | pure Slice {offset = 0, length = len', base = unlift base} 709 | unsafeShrinkAndFreeze MutableSlice {offsetMut, baseMut} len' = do 710 | base <- freeze_ (liftMut baseMut) offsetMut len' 711 | pure Slice {offset = 0, length = len', base = unlift base} 712 | {-# INLINE thaw #-} 713 | thaw xs@Slice {length} = thaw_ xs 0 length 714 | {-# INLINE thaw_ #-} 715 | thaw_ Slice {offset, base} off' len' = do 716 | baseMut <- thaw_ (lift base) (offset + off') len' 717 | pure MutableSlice {offsetMut = 0, lengthMut = len', baseMut = unliftMut baseMut} 718 | {-# INLINE toSlice #-} 719 | toSlice = id 720 | {-# INLINE toSliceMut #-} 721 | toSliceMut = pure 722 | 723 | ------ Copy Operations ------ 724 | {-# INLINE copy #-} 725 | copy dst dstOff src@Slice {length} = copy_ dst dstOff src 0 length 726 | {-# INLINE copy_ #-} 727 | copy_ MutableSlice {offsetMut, baseMut} dstOff Slice {offset, base} off' len = 728 | copy_ (liftMut baseMut) (offsetMut + dstOff) (lift base) (offset + off') len 729 | {-# INLINE copyMut #-} 730 | copyMut dst dstOff src@MutableSlice {lengthMut} = copyMut_ dst dstOff src 0 lengthMut 731 | {-# INLINE copyMut_ #-} 732 | copyMut_ 733 | MutableSlice {offsetMut = dstOff, baseMut = dst} 734 | dstOff' 735 | MutableSlice {offsetMut = srcOff, baseMut = src} 736 | srcOff' 737 | len = 738 | copyMut_ (liftMut dst) (dstOff + dstOff') (liftMut src) (srcOff + srcOff') len 739 | {-# INLINE insertAt #-} 740 | insertAt Slice {offset, length, base} i x = run $ do 741 | dst <- replicateMut (length + 1) x 742 | copy_ dst 0 (lift base) offset i 743 | copy_ dst (i + 1) (lift base) (offset + i) (length - i) 744 | base' <- unsafeFreeze dst 745 | pure Slice {offset = 0, length = length + 1, base = unlift base'} 746 | 747 | ------ Reduction ------ 748 | {-# INLINE rnf #-} 749 | rnf !arr@Slice {length} = 750 | let go !ix = 751 | if ix < length 752 | then 753 | let !(# x #) = index# arr ix 754 | in DS.rnf x `seq` go (ix + 1) 755 | else () 756 | in go 0 757 | {-# INLINE run #-} 758 | run = runST 759 | 760 | instance Contiguous SmallArray where 761 | type Mutable SmallArray = SmallMutableArray 762 | type Element SmallArray = Always 763 | type Sliced SmallArray = Slice SmallArray 764 | type MutableSliced SmallArray = MutableSlice SmallArray 765 | {-# INLINE new #-} 766 | new n = newSmallArray n errorThunk 767 | {-# INLINE empty #-} 768 | empty = mempty 769 | {-# INLINE index #-} 770 | index = indexSmallArray 771 | {-# INLINE indexM #-} 772 | indexM = indexSmallArrayM 773 | {-# INLINE index# #-} 774 | index# = indexSmallArray## 775 | {-# INLINE read #-} 776 | read = readSmallArray 777 | {-# INLINE write #-} 778 | write = writeSmallArray 779 | {-# INLINE null #-} 780 | null a = case sizeofSmallArray a of 781 | 0 -> True 782 | _ -> False 783 | {-# INLINE slice #-} 784 | slice base offset length = Slice {offset, length, base = unlift base} 785 | {-# INLINE sliceMut #-} 786 | sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} 787 | {-# INLINE toSlice #-} 788 | toSlice base = Slice {offset = 0, length = size base, base = unlift base} 789 | {-# INLINE toSliceMut #-} 790 | toSliceMut baseMut = do 791 | lengthMut <- sizeMut baseMut 792 | pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} 793 | {-# INLINE freeze_ #-} 794 | freeze_ = freezeSmallArray 795 | {-# INLINE unsafeFreeze #-} 796 | unsafeFreeze = unsafeFreezeSmallArray 797 | {-# INLINE size #-} 798 | size = sizeofSmallArray 799 | {-# INLINE sizeMut #-} 800 | sizeMut = getSizeofSmallMutableArray 801 | {-# INLINE thaw_ #-} 802 | thaw_ = thawSmallArray 803 | {-# INLINE equals #-} 804 | equals = (==) 805 | {-# INLINE equalsMut #-} 806 | equalsMut = (==) 807 | {-# INLINE singleton #-} 808 | singleton a = runST $ do 809 | marr <- newSmallArray 1 a 810 | unsafeFreezeSmallArray marr 811 | {-# INLINE doubleton #-} 812 | doubleton a b = runST $ do 813 | m <- newSmallArray 2 a 814 | writeSmallArray m 1 b 815 | unsafeFreezeSmallArray m 816 | {-# INLINE tripleton #-} 817 | tripleton a b c = runST $ do 818 | m <- newSmallArray 3 a 819 | writeSmallArray m 1 b 820 | writeSmallArray m 2 c 821 | unsafeFreezeSmallArray m 822 | {-# INLINE quadrupleton #-} 823 | quadrupleton a b c d = runST $ do 824 | m <- newSmallArray 4 a 825 | writeSmallArray m 1 b 826 | writeSmallArray m 2 c 827 | writeSmallArray m 3 d 828 | unsafeFreezeSmallArray m 829 | {-# INLINE quintupleton #-} 830 | quintupleton a b c d e = runST $ do 831 | m <- newSmallArray 5 a 832 | writeSmallArray m 1 b 833 | writeSmallArray m 2 c 834 | writeSmallArray m 3 d 835 | writeSmallArray m 4 e 836 | unsafeFreezeSmallArray m 837 | {-# INLINE sextupleton #-} 838 | sextupleton a b c d e f = runST $ do 839 | m <- newSmallArray 6 a 840 | writeSmallArray m 1 b 841 | writeSmallArray m 2 c 842 | writeSmallArray m 3 d 843 | writeSmallArray m 4 e 844 | writeSmallArray m 5 f 845 | unsafeFreezeSmallArray m 846 | {-# INLINE rnf #-} 847 | rnf !ary = 848 | let !sz = sizeofSmallArray ary 849 | go !ix = 850 | if ix < sz 851 | then 852 | let !(# x #) = indexSmallArray## ary ix 853 | in DS.rnf x `seq` go (ix + 1) 854 | else () 855 | in go 0 856 | {-# INLINE clone_ #-} 857 | clone_ = cloneSmallArray 858 | {-# INLINE cloneMut_ #-} 859 | cloneMut_ = cloneSmallMutableArray 860 | {-# INLINE copy_ #-} 861 | copy_ = copySmallArray 862 | {-# INLINE copyMut_ #-} 863 | copyMut_ = copySmallMutableArray 864 | {-# INLINE replicateMut #-} 865 | replicateMut = newSmallArray 866 | {-# INLINE run #-} 867 | run = runSmallArrayST 868 | {-# INLINE shrink #-} 869 | shrink !arr !n = do 870 | shrinkSmallMutableArray arr n 871 | pure arr 872 | {-# INLINE unsafeShrinkAndFreeze #-} 873 | unsafeShrinkAndFreeze !arr !n = do 874 | shrinkSmallMutableArray arr n 875 | unsafeFreezeSmallArray arr 876 | 877 | instance ContiguousU SmallArray where 878 | type Unlifted SmallArray = SmallArray# 879 | type UnliftedMut SmallArray = SmallMutableArray# 880 | {-# INLINE resize #-} 881 | resize !arr !n = resizeSmallMutableArray arr n resizeSmallMutableArrayUninitializedElement 882 | {-# INLINE unlift #-} 883 | unlift (SmallArray x) = x 884 | {-# INLINE unliftMut #-} 885 | unliftMut (SmallMutableArray x) = x 886 | {-# INLINE lift #-} 887 | lift x = SmallArray x 888 | {-# INLINE liftMut #-} 889 | liftMut x = SmallMutableArray x 890 | 891 | instance Contiguous (SmallUnliftedArray_ unlifted_a) where 892 | type Mutable (SmallUnliftedArray_ unlifted_a) = SmallMutableUnliftedArray_ unlifted_a 893 | type Element (SmallUnliftedArray_ unlifted_a) = PrimUnliftsInto unlifted_a 894 | type Sliced (SmallUnliftedArray_ unlifted_a) = Slice (SmallUnliftedArray_ unlifted_a) 895 | type MutableSliced (SmallUnliftedArray_ unlifted_a) = MutableSlice (SmallUnliftedArray_ unlifted_a) 896 | {-# INLINE new #-} 897 | new n = unsafeNewSmallUnliftedArray n 898 | {-# INLINE empty #-} 899 | empty = emptySmallUnliftedArray 900 | {-# INLINE index #-} 901 | index = indexSmallUnliftedArray 902 | {-# INLINE indexM #-} 903 | indexM arr ix = pure (indexSmallUnliftedArray arr ix) 904 | {-# INLINE index# #-} 905 | index# arr ix = (# indexSmallUnliftedArray arr ix #) 906 | {-# INLINE read #-} 907 | read = readSmallUnliftedArray 908 | {-# INLINE write #-} 909 | write = writeSmallUnliftedArray 910 | {-# INLINE null #-} 911 | null a = case sizeofSmallUnliftedArray a of 912 | 0 -> True 913 | _ -> False 914 | {-# INLINE slice #-} 915 | slice base offset length = Slice {offset, length, base = unlift base} 916 | {-# INLINE sliceMut #-} 917 | sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} 918 | {-# INLINE toSlice #-} 919 | toSlice base = Slice {offset = 0, length = size base, base = unlift base} 920 | {-# INLINE toSliceMut #-} 921 | toSliceMut baseMut = do 922 | lengthMut <- sizeMut baseMut 923 | pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} 924 | {-# INLINE freeze_ #-} 925 | freeze_ = freezeSmallUnliftedArray 926 | {-# INLINE unsafeFreeze #-} 927 | unsafeFreeze = unsafeFreezeSmallUnliftedArray 928 | {-# INLINE size #-} 929 | size = sizeofSmallUnliftedArray 930 | {-# INLINE sizeMut #-} 931 | sizeMut = getSizeofSmallMutableUnliftedArray 932 | {-# INLINE thaw_ #-} 933 | thaw_ = thawSmallUnliftedArray 934 | {-# INLINE equals #-} 935 | equals = (==) 936 | {-# INLINE equalsMut #-} 937 | equalsMut = sameSmallMutableUnliftedArray 938 | {-# INLINE singleton #-} 939 | singleton a = runST $ do 940 | marr <- newSmallUnliftedArray 1 a 941 | unsafeFreezeSmallUnliftedArray marr 942 | {-# INLINE doubleton #-} 943 | doubleton a b = runST $ do 944 | m <- newSmallUnliftedArray 2 a 945 | writeSmallUnliftedArray m 1 b 946 | unsafeFreezeSmallUnliftedArray m 947 | {-# INLINE tripleton #-} 948 | tripleton a b c = runST $ do 949 | m <- newSmallUnliftedArray 3 a 950 | writeSmallUnliftedArray m 1 b 951 | writeSmallUnliftedArray m 2 c 952 | unsafeFreezeSmallUnliftedArray m 953 | {-# INLINE quadrupleton #-} 954 | quadrupleton a b c d = runST $ do 955 | m <- newSmallUnliftedArray 4 a 956 | writeSmallUnliftedArray m 1 b 957 | writeSmallUnliftedArray m 2 c 958 | writeSmallUnliftedArray m 3 d 959 | unsafeFreezeSmallUnliftedArray m 960 | {-# INLINE quintupleton #-} 961 | quintupleton a b c d e = runST $ do 962 | m <- newSmallUnliftedArray 5 a 963 | writeSmallUnliftedArray m 1 b 964 | writeSmallUnliftedArray m 2 c 965 | writeSmallUnliftedArray m 3 d 966 | writeSmallUnliftedArray m 4 e 967 | unsafeFreezeSmallUnliftedArray m 968 | {-# INLINE sextupleton #-} 969 | sextupleton a b c d e f = runST $ do 970 | m <- newSmallUnliftedArray 6 a 971 | writeSmallUnliftedArray m 1 b 972 | writeSmallUnliftedArray m 2 c 973 | writeSmallUnliftedArray m 3 d 974 | writeSmallUnliftedArray m 4 e 975 | writeSmallUnliftedArray m 5 f 976 | unsafeFreezeSmallUnliftedArray m 977 | {-# INLINE rnf #-} 978 | rnf !ary = 979 | let !sz = sizeofSmallUnliftedArray ary 980 | go !ix = 981 | if ix < sz 982 | then 983 | let !x = indexSmallUnliftedArray ary ix 984 | in DS.rnf x `seq` go (ix + 1) 985 | else () 986 | in go 0 987 | {-# INLINE clone_ #-} 988 | clone_ = cloneSmallUnliftedArray 989 | {-# INLINE cloneMut_ #-} 990 | cloneMut_ = cloneSmallMutableUnliftedArray 991 | {-# INLINE copy_ #-} 992 | copy_ = copySmallUnliftedArray 993 | {-# INLINE copyMut_ #-} 994 | copyMut_ = copySmallMutableUnliftedArray 995 | {-# INLINE replicateMut #-} 996 | replicateMut = newSmallUnliftedArray 997 | {-# INLINE run #-} 998 | run = runSmallUnliftedArrayST 999 | {-# INLINE shrink #-} 1000 | shrink !arr !n = do 1001 | shrinkSmallMutableUnliftedArray arr n 1002 | pure arr 1003 | {-# INLINE unsafeShrinkAndFreeze #-} 1004 | unsafeShrinkAndFreeze !arr !n = do 1005 | shrinkSmallMutableUnliftedArray arr n 1006 | unsafeFreezeSmallUnliftedArray arr 1007 | 1008 | 1009 | newtype SmallUnliftedArray## (u :: TYPE UnliftedRep) (a :: Type) 1010 | = SmallUnliftedArray## (Exts.SmallArray# u) 1011 | newtype SmallMutableUnliftedArray## (u :: TYPE UnliftedRep) s (a :: Type) 1012 | = SmallMutableUnliftedArray## (Exts.SmallMutableArray# s u) 1013 | 1014 | instance ContiguousU (SmallUnliftedArray_ unlifted_a) where 1015 | type Unlifted (SmallUnliftedArray_ unlifted_a) = SmallUnliftedArray## unlifted_a 1016 | type UnliftedMut (SmallUnliftedArray_ unlifted_a) = SmallMutableUnliftedArray## unlifted_a 1017 | {-# INLINE resize #-} 1018 | resize = resizeSmallUnliftedArray 1019 | {-# INLINE unlift #-} 1020 | unlift (SmallUnliftedArray (SmallUnliftedArray# x)) = SmallUnliftedArray## x 1021 | {-# INLINE unliftMut #-} 1022 | unliftMut (SmallMutableUnliftedArray (SmallMutableUnliftedArray# x)) = SmallMutableUnliftedArray## x 1023 | {-# INLINE lift #-} 1024 | lift (SmallUnliftedArray## x) = SmallUnliftedArray (SmallUnliftedArray# x) 1025 | {-# INLINE liftMut #-} 1026 | liftMut (SmallMutableUnliftedArray## x) = SmallMutableUnliftedArray (SmallMutableUnliftedArray# x) 1027 | 1028 | 1029 | -- NOTE: Currently missing from the `run-st` library 1030 | -- c.f. https://github.com/byteverse/run-st/issues/5 1031 | runSmallUnliftedArrayST :: (forall s. ST s (SmallUnliftedArray_ unlifted_a a)) -> SmallUnliftedArray_ unlifted_a a 1032 | {-# INLINE runSmallUnliftedArrayST #-} 1033 | runSmallUnliftedArrayST f = SmallUnliftedArray (Exts.runRW# (\s0 -> case f of ST g -> case g s0 of (# _, SmallUnliftedArray r #) -> r)) 1034 | 1035 | instance Contiguous PrimArray where 1036 | type Mutable PrimArray = MutablePrimArray 1037 | type Element PrimArray = Prim 1038 | type Sliced PrimArray = Slice PrimArray 1039 | type MutableSliced PrimArray = MutableSlice PrimArray 1040 | {-# INLINE empty #-} 1041 | empty = mempty 1042 | {-# INLINE new #-} 1043 | new = newPrimArray 1044 | {-# INLINE replicateMut #-} 1045 | replicateMut = replicateMutablePrimArray 1046 | {-# INLINE index #-} 1047 | index = indexPrimArray 1048 | {-# INLINE index# #-} 1049 | index# arr ix = (# indexPrimArray arr ix #) 1050 | {-# INLINE indexM #-} 1051 | indexM arr ix = pure (indexPrimArray arr ix) 1052 | {-# INLINE read #-} 1053 | read = readPrimArray 1054 | {-# INLINE write #-} 1055 | write = writePrimArray 1056 | {-# INLINE size #-} 1057 | size = sizeofPrimArray 1058 | {-# INLINE sizeMut #-} 1059 | sizeMut = getSizeofMutablePrimArray 1060 | {-# INLINE slice #-} 1061 | slice base offset length = Slice {offset, length, base = unlift base} 1062 | {-# INLINE sliceMut #-} 1063 | sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} 1064 | {-# INLINE toSlice #-} 1065 | toSlice base = Slice {offset = 0, length = size base, base = unlift base} 1066 | {-# INLINE toSliceMut #-} 1067 | toSliceMut baseMut = do 1068 | lengthMut <- sizeMut baseMut 1069 | pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} 1070 | {-# INLINE freeze_ #-} 1071 | freeze_ = freezePrimArray 1072 | {-# INLINE unsafeFreeze #-} 1073 | unsafeFreeze = unsafeFreezePrimArray 1074 | {-# INLINE thaw_ #-} 1075 | thaw_ = thawPrimArray 1076 | {-# INLINE copy_ #-} 1077 | copy_ = copyPrimArray 1078 | {-# INLINE copyMut_ #-} 1079 | copyMut_ = copyMutablePrimArray 1080 | {-# INLINE clone_ #-} 1081 | clone_ = clonePrimArray 1082 | {-# INLINE cloneMut_ #-} 1083 | cloneMut_ = cloneMutablePrimArray 1084 | {-# INLINE equals #-} 1085 | equals = (==) 1086 | {-# INLINE null #-} 1087 | null (PrimArray a) = case sizeofByteArray# a of 1088 | 0# -> True 1089 | _ -> False 1090 | {-# INLINE equalsMut #-} 1091 | equalsMut = sameMutablePrimArray 1092 | {-# INLINE rnf #-} 1093 | rnf (PrimArray !_) = () 1094 | {-# INLINE singleton #-} 1095 | singleton a = runPrimArrayST $ do 1096 | marr <- newPrimArray 1 1097 | writePrimArray marr 0 a 1098 | unsafeFreezePrimArray marr 1099 | {-# INLINE doubleton #-} 1100 | doubleton a b = runPrimArrayST $ do 1101 | m <- newPrimArray 2 1102 | writePrimArray m 0 a 1103 | writePrimArray m 1 b 1104 | unsafeFreezePrimArray m 1105 | {-# INLINE tripleton #-} 1106 | tripleton a b c = runPrimArrayST $ do 1107 | m <- newPrimArray 3 1108 | writePrimArray m 0 a 1109 | writePrimArray m 1 b 1110 | writePrimArray m 2 c 1111 | unsafeFreezePrimArray m 1112 | {-# INLINE quadrupleton #-} 1113 | quadrupleton a b c d = runPrimArrayST $ do 1114 | m <- newPrimArray 4 1115 | writePrimArray m 0 a 1116 | writePrimArray m 1 b 1117 | writePrimArray m 2 c 1118 | writePrimArray m 3 d 1119 | unsafeFreezePrimArray m 1120 | {-# INLINE quintupleton #-} 1121 | quintupleton a b c d e = runPrimArrayST $ do 1122 | m <- newPrimArray 5 1123 | writePrimArray m 0 a 1124 | writePrimArray m 1 b 1125 | writePrimArray m 2 c 1126 | writePrimArray m 3 d 1127 | writePrimArray m 4 e 1128 | unsafeFreezePrimArray m 1129 | {-# INLINE sextupleton #-} 1130 | sextupleton a b c d e f = runPrimArrayST $ do 1131 | m <- newPrimArray 6 1132 | writePrimArray m 0 a 1133 | writePrimArray m 1 b 1134 | writePrimArray m 2 c 1135 | writePrimArray m 3 d 1136 | writePrimArray m 4 e 1137 | writePrimArray m 5 f 1138 | unsafeFreezePrimArray m 1139 | {-# INLINE insertAt #-} 1140 | insertAt src i x = runPrimArrayST $ do 1141 | dst <- new (size src + 1) 1142 | copy dst 0 (slice src 0 i) 1143 | write dst i x 1144 | copy dst (i + 1) (slice src i (size src - i)) 1145 | unsafeFreeze dst 1146 | {-# INLINE run #-} 1147 | run = runPrimArrayST 1148 | {-# INLINE shrink #-} 1149 | shrink !arr !n = do 1150 | shrinkMutablePrimArray arr n 1151 | pure arr 1152 | {-# INLINE unsafeShrinkAndFreeze #-} 1153 | unsafeShrinkAndFreeze !arr !n = do 1154 | shrinkMutablePrimArray arr n 1155 | unsafeFreezePrimArray arr 1156 | 1157 | newtype PrimArray# a = PrimArray# ByteArray# 1158 | newtype MutablePrimArray# s a = MutablePrimArray# (MutableByteArray# s) 1159 | instance ContiguousU PrimArray where 1160 | type Unlifted PrimArray = PrimArray# 1161 | type UnliftedMut PrimArray = MutablePrimArray# 1162 | {-# INLINE resize #-} 1163 | resize = resizeMutablePrimArray 1164 | {-# INLINE unlift #-} 1165 | unlift (PrimArray x) = PrimArray# x 1166 | {-# INLINE unliftMut #-} 1167 | unliftMut (MutablePrimArray x) = MutablePrimArray# x 1168 | {-# INLINE lift #-} 1169 | lift (PrimArray# x) = PrimArray x 1170 | {-# INLINE liftMut #-} 1171 | liftMut (MutablePrimArray# x) = MutablePrimArray x 1172 | 1173 | instance Contiguous Array where 1174 | type Mutable Array = MutableArray 1175 | type Element Array = Always 1176 | type Sliced Array = Slice Array 1177 | type MutableSliced Array = MutableSlice Array 1178 | {-# INLINE empty #-} 1179 | empty = mempty 1180 | {-# INLINE new #-} 1181 | new n = newArray n errorThunk 1182 | {-# INLINE replicateMut #-} 1183 | replicateMut = newArray 1184 | {-# INLINE index #-} 1185 | index = indexArray 1186 | {-# INLINE index# #-} 1187 | index# = indexArray## 1188 | {-# INLINE indexM #-} 1189 | indexM = indexArrayM 1190 | {-# INLINE read #-} 1191 | read = readArray 1192 | {-# INLINE write #-} 1193 | write = writeArray 1194 | {-# INLINE size #-} 1195 | size = sizeofArray 1196 | {-# INLINE sizeMut #-} 1197 | sizeMut = (\x -> pure $! sizeofMutableArray x) 1198 | {-# INLINE slice #-} 1199 | slice base offset length = Slice {offset, length, base = unlift base} 1200 | {-# INLINE sliceMut #-} 1201 | sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} 1202 | {-# INLINE toSlice #-} 1203 | toSlice base = Slice {offset = 0, length = size base, base = unlift base} 1204 | {-# INLINE toSliceMut #-} 1205 | toSliceMut baseMut = do 1206 | lengthMut <- sizeMut baseMut 1207 | pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} 1208 | {-# INLINE freeze_ #-} 1209 | freeze_ = freezeArray 1210 | {-# INLINE unsafeFreeze #-} 1211 | unsafeFreeze = unsafeFreezeArray 1212 | {-# INLINE thaw_ #-} 1213 | thaw_ = thawArray 1214 | {-# INLINE copy_ #-} 1215 | copy_ = copyArray 1216 | {-# INLINE copyMut_ #-} 1217 | copyMut_ = copyMutableArray 1218 | {-# INLINE clone #-} 1219 | clone Slice {offset, length, base} = clone_ (lift base) offset length 1220 | {-# INLINE clone_ #-} 1221 | clone_ = cloneArray 1222 | {-# INLINE cloneMut_ #-} 1223 | cloneMut_ = cloneMutableArray 1224 | {-# INLINE equals #-} 1225 | equals = (==) 1226 | {-# INLINE null #-} 1227 | null (Array a) = case sizeofArray# a of 1228 | 0# -> True 1229 | _ -> False 1230 | {-# INLINE equalsMut #-} 1231 | equalsMut = sameMutableArray 1232 | {-# INLINE rnf #-} 1233 | rnf !ary = 1234 | let !sz = sizeofArray ary 1235 | go !i 1236 | | i == sz = () 1237 | | otherwise = 1238 | let !(# x #) = indexArray## ary i 1239 | in DS.rnf x `seq` go (i + 1) 1240 | in go 0 1241 | {-# INLINE singleton #-} 1242 | singleton a = runArrayST (newArray 1 a >>= unsafeFreezeArray) 1243 | {-# INLINE doubleton #-} 1244 | doubleton a b = runArrayST $ do 1245 | m <- newArray 2 a 1246 | writeArray m 1 b 1247 | unsafeFreezeArray m 1248 | {-# INLINE tripleton #-} 1249 | tripleton a b c = runArrayST $ do 1250 | m <- newArray 3 a 1251 | writeArray m 1 b 1252 | writeArray m 2 c 1253 | unsafeFreezeArray m 1254 | {-# INLINE quadrupleton #-} 1255 | quadrupleton a b c d = runArrayST $ do 1256 | m <- newArray 4 a 1257 | writeArray m 1 b 1258 | writeArray m 2 c 1259 | writeArray m 3 d 1260 | unsafeFreezeArray m 1261 | {-# INLINE quintupleton #-} 1262 | quintupleton a b c d e = runArrayST $ do 1263 | m <- newArray 5 a 1264 | writeArray m 1 b 1265 | writeArray m 2 c 1266 | writeArray m 3 d 1267 | writeArray m 4 e 1268 | unsafeFreezeArray m 1269 | {-# INLINE sextupleton #-} 1270 | sextupleton a b c d e f = runArrayST $ do 1271 | m <- newArray 6 a 1272 | writeArray m 1 b 1273 | writeArray m 2 c 1274 | writeArray m 3 d 1275 | writeArray m 4 e 1276 | writeArray m 5 f 1277 | unsafeFreezeArray m 1278 | {-# INLINE run #-} 1279 | run = runArrayST 1280 | {-# INLINE shrink #-} 1281 | shrink !arr !n = do 1282 | -- See Note [Shrinking Arrays Without a Shrink Primop] 1283 | cloneMutableArray arr 0 n 1284 | {-# INLINE unsafeShrinkAndFreeze #-} 1285 | unsafeShrinkAndFreeze !arr !n = 1286 | -- See Note [Shrinking Arrays Without a Shrink Primop] 1287 | freezeArray arr 0 n 1288 | 1289 | instance ContiguousU Array where 1290 | type Unlifted Array = Array# 1291 | type UnliftedMut Array = MutableArray# 1292 | {-# INLINE resize #-} 1293 | resize = resizeArray 1294 | {-# INLINE unlift #-} 1295 | unlift (Array x) = x 1296 | {-# INLINE unliftMut #-} 1297 | unliftMut (MutableArray x) = x 1298 | {-# INLINE lift #-} 1299 | lift x = Array x 1300 | {-# INLINE liftMut #-} 1301 | liftMut x = MutableArray x 1302 | 1303 | class (Class.Unlifted a ~ u, PrimUnlifted a) => PrimUnliftsInto (u :: TYPE ('Exts.BoxedRep 'Exts.Unlifted)) (a :: Type) 1304 | instance (Class.Unlifted a ~ u, PrimUnlifted a) => PrimUnliftsInto u a 1305 | 1306 | instance Contiguous (UnliftedArray_ unlifted_a) where 1307 | type Mutable (UnliftedArray_ unlifted_a) = MutableUnliftedArray_ unlifted_a 1308 | type Element (UnliftedArray_ unlifted_a) = PrimUnliftsInto unlifted_a 1309 | type Sliced (UnliftedArray_ unlifted_a) = Slice (UnliftedArray_ unlifted_a) 1310 | type MutableSliced (UnliftedArray_ unlifted_a) = MutableSlice (UnliftedArray_ unlifted_a) 1311 | {-# INLINE empty #-} 1312 | empty = emptyUnliftedArray 1313 | {-# INLINE new #-} 1314 | new = unsafeNewUnliftedArray 1315 | {-# INLINE replicateMut #-} 1316 | replicateMut = newUnliftedArray 1317 | {-# INLINE index #-} 1318 | index = indexUnliftedArray 1319 | {-# INLINE index# #-} 1320 | index# arr ix = (# indexUnliftedArray arr ix #) 1321 | {-# INLINE indexM #-} 1322 | indexM arr ix = pure (indexUnliftedArray arr ix) 1323 | {-# INLINE read #-} 1324 | read = readUnliftedArray 1325 | {-# INLINE write #-} 1326 | write = writeUnliftedArray 1327 | {-# INLINE size #-} 1328 | size = sizeofUnliftedArray 1329 | {-# INLINE sizeMut #-} 1330 | sizeMut = pure . sizeofMutableUnliftedArray 1331 | {-# INLINE slice #-} 1332 | slice base offset length = Slice {offset, length, base = unlift base} 1333 | {-# INLINE sliceMut #-} 1334 | sliceMut baseMut offsetMut lengthMut = MutableSlice {offsetMut, lengthMut, baseMut = unliftMut baseMut} 1335 | {-# INLINE freeze_ #-} 1336 | freeze_ = freezeUnliftedArray 1337 | {-# INLINE unsafeFreeze #-} 1338 | unsafeFreeze = unsafeFreezeUnliftedArray 1339 | {-# INLINE toSlice #-} 1340 | toSlice base = Slice {offset = 0, length = size base, base = unlift base} 1341 | {-# INLINE toSliceMut #-} 1342 | toSliceMut baseMut = do 1343 | lengthMut <- sizeMut baseMut 1344 | pure MutableSlice {offsetMut = 0, lengthMut, baseMut = unliftMut baseMut} 1345 | {-# INLINE thaw_ #-} 1346 | thaw_ = thawUnliftedArray 1347 | {-# INLINE copy_ #-} 1348 | copy_ = copyUnliftedArray 1349 | {-# INLINE copyMut_ #-} 1350 | copyMut_ = copyMutableUnliftedArray 1351 | {-# INLINE clone_ #-} 1352 | clone_ = cloneUnliftedArray 1353 | {-# INLINE cloneMut_ #-} 1354 | cloneMut_ = cloneMutableUnliftedArray 1355 | {-# INLINE equals #-} 1356 | equals = (==) 1357 | {-# INLINE null #-} 1358 | null (UnliftedArray (UnliftedArray# a)) = case Exts.sizeofArray# a of 1359 | 0# -> True 1360 | _ -> False 1361 | {-# INLINE equalsMut #-} 1362 | equalsMut = sameMutableUnliftedArray 1363 | {-# INLINE rnf #-} 1364 | rnf !ary = 1365 | let !sz = sizeofUnliftedArray ary 1366 | go !i 1367 | | i == sz = () 1368 | | otherwise = 1369 | let x = indexUnliftedArray ary i 1370 | in DS.rnf x `seq` go (i + 1) 1371 | in go 0 1372 | {-# INLINE singleton #-} 1373 | singleton a = runUnliftedArrayST (newUnliftedArray 1 a >>= unsafeFreezeUnliftedArray) 1374 | {-# INLINE doubleton #-} 1375 | doubleton a b = runUnliftedArrayST $ do 1376 | m <- newUnliftedArray 2 a 1377 | writeUnliftedArray m 1 b 1378 | unsafeFreezeUnliftedArray m 1379 | {-# INLINE tripleton #-} 1380 | tripleton a b c = runUnliftedArrayST $ do 1381 | m <- newUnliftedArray 3 a 1382 | writeUnliftedArray m 1 b 1383 | writeUnliftedArray m 2 c 1384 | unsafeFreezeUnliftedArray m 1385 | {-# INLINE quadrupleton #-} 1386 | quadrupleton a b c d = runUnliftedArrayST $ do 1387 | m <- newUnliftedArray 4 a 1388 | writeUnliftedArray m 1 b 1389 | writeUnliftedArray m 2 c 1390 | writeUnliftedArray m 3 d 1391 | unsafeFreezeUnliftedArray m 1392 | {-# INLINE quintupleton #-} 1393 | quintupleton a b c d e = runUnliftedArrayST $ do 1394 | m <- newUnliftedArray 5 a 1395 | writeUnliftedArray m 1 b 1396 | writeUnliftedArray m 2 c 1397 | writeUnliftedArray m 3 d 1398 | writeUnliftedArray m 4 e 1399 | unsafeFreezeUnliftedArray m 1400 | {-# INLINE sextupleton #-} 1401 | sextupleton a b c d e f = runUnliftedArrayST $ do 1402 | m <- newUnliftedArray 6 a 1403 | writeUnliftedArray m 1 b 1404 | writeUnliftedArray m 2 c 1405 | writeUnliftedArray m 3 d 1406 | writeUnliftedArray m 4 e 1407 | writeUnliftedArray m 5 f 1408 | unsafeFreezeUnliftedArray m 1409 | {-# INLINE run #-} 1410 | run = runUnliftedArrayST 1411 | {-# INLINE shrink #-} 1412 | shrink !arr !n = do 1413 | -- See Note [Shrinking Arrays Without a Shrink Primop] 1414 | cloneMutableUnliftedArray arr 0 n 1415 | {-# INLINE unsafeShrinkAndFreeze #-} 1416 | unsafeShrinkAndFreeze !arr !n = 1417 | -- See Note [Shrinking Arrays Without a Shrink Primop] 1418 | freezeUnliftedArray arr 0 n 1419 | 1420 | -- Note [Shrinking Arrays Without a Shrink Primop] 1421 | -- =============================================== 1422 | -- GHC's Array# type has a card table and cannot currently be shrunk in place. 1423 | -- (SmallArray#, however, can be shrunk in place.) These implementations copy 1424 | -- the array rather than freezing it in place. But at least they are able to 1425 | -- avoid assigning all of the elements to a nonsense value before replacing 1426 | -- them with memcpy. 1427 | 1428 | newtype UnliftedArray## (u :: TYPE UnliftedRep) (a :: Type) 1429 | = UnliftedArray## (Exts.Array# u) 1430 | newtype MutableUnliftedArray## (u :: TYPE UnliftedRep) s (a :: Type) 1431 | = MutableUnliftedArray## (Exts.MutableArray# s u) 1432 | 1433 | instance ContiguousU (UnliftedArray_ unlifted_a) where 1434 | type Unlifted (UnliftedArray_ unlifted_a) = UnliftedArray## unlifted_a 1435 | type UnliftedMut (UnliftedArray_ unlifted_a) = MutableUnliftedArray## unlifted_a 1436 | {-# INLINE resize #-} 1437 | resize = resizeUnliftedArray 1438 | {-# INLINE unlift #-} 1439 | unlift (UnliftedArray (UnliftedArray# x)) = UnliftedArray## x 1440 | {-# INLINE unliftMut #-} 1441 | unliftMut (MutableUnliftedArray (MutableUnliftedArray# x)) = MutableUnliftedArray## x 1442 | {-# INLINE lift #-} 1443 | lift (UnliftedArray## x) = UnliftedArray (UnliftedArray# x) 1444 | {-# INLINE liftMut #-} 1445 | liftMut (MutableUnliftedArray## x) = MutableUnliftedArray (MutableUnliftedArray# x) 1446 | 1447 | resizeSmallMutableArrayUninitializedElement :: a 1448 | {-# noinline resizeSmallMutableArrayUninitializedElement #-} 1449 | resizeSmallMutableArrayUninitializedElement = errorWithoutStackTrace "uninitialized element of resizeSmallMutableArray" 1450 | -------------------------------------------------------------------------------- /src/Data/Primitive/Contiguous.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeFamilyDependencies #-} 9 | {-# LANGUAGE UnboxedTuples #-} 10 | 11 | {- | The contiguous package presents a common API to a number of contiguous 12 | array types and their mutable counterparts. This is enabled with the 13 | 'Contiguous' typeclass, which parameterises over a contiguous array type and 14 | defines the core operations. However, the stable part of the interface is 15 | contained in this module, which combines those primitives into common, 16 | efficient array algorithms suitable for replacing pointer-heavy list 17 | manipulations. 18 | -} 19 | module Data.Primitive.Contiguous 20 | ( -- * Accessors 21 | 22 | -- ** Length Information 23 | size 24 | , sizeMut 25 | , null 26 | 27 | -- ** Indexing 28 | , index 29 | , index# 30 | , read 31 | 32 | -- ** Monadic indexing 33 | , indexM 34 | 35 | -- * Construction 36 | 37 | -- ** Initialisation 38 | , empty 39 | , new 40 | , singleton 41 | , doubleton 42 | , tripleton 43 | , quadrupleton 44 | , quintupleton 45 | , sextupleton 46 | , replicate 47 | , replicateMut 48 | , generate 49 | , generateM 50 | , generateMutable 51 | , iterateN 52 | , iterateMutableN 53 | , write 54 | 55 | -- ** Fixed Length 56 | , construct1 57 | , construct2 58 | , construct3 59 | , construct4 60 | , construct5 61 | , construct6 62 | 63 | -- ** Running 64 | , run 65 | 66 | -- ** Monadic initialisation 67 | , replicateMutM 68 | , generateMutableM 69 | , iterateMutableNM 70 | , create 71 | , createT 72 | 73 | -- ** Unfolding 74 | , unfoldr 75 | , unfoldrN 76 | , unfoldrMutable 77 | 78 | -- ** Enumeration 79 | , enumFromN 80 | , enumFromMutableN 81 | 82 | -- ** Concatenation 83 | , append 84 | 85 | -- ** Splitting and Splicing 86 | , insertAt 87 | 88 | -- * Slicing 89 | , Slice 90 | , MutableSlice 91 | , slice 92 | , sliceMut 93 | , toSlice 94 | , toSliceMut 95 | 96 | -- * Modifying arrays 97 | , replaceAt 98 | , modifyAt 99 | , modifyAt' 100 | , modifyAtF 101 | , modifyAtF' 102 | , deleteAt 103 | 104 | -- ** Permutations 105 | , reverse 106 | , reverseMutable 107 | , reverseSlice 108 | 109 | -- ** Resizing 110 | , resize 111 | , shrink 112 | , unsafeShrinkAndFreeze 113 | 114 | -- * Elementwise operations 115 | 116 | -- ** Mapping 117 | , map 118 | , map' 119 | , mapMutable 120 | , mapMutable' 121 | , imap 122 | , imap' 123 | , imapMutable 124 | , imapMutable' 125 | , modify 126 | , modify' 127 | , mapMaybe 128 | 129 | -- ** Zipping 130 | , zip 131 | , zipWith 132 | , izipWith 133 | 134 | -- ** Specific elements 135 | , swap 136 | 137 | -- * Working with predicates 138 | 139 | -- ** Filtering 140 | , filter 141 | , ifilter 142 | , catMaybes 143 | , lefts 144 | , rights 145 | , partitionEithers 146 | 147 | -- ** Searching 148 | , find 149 | , findIndex 150 | , elem 151 | , maximum 152 | , minimum 153 | , maximumBy 154 | , minimumBy 155 | 156 | -- ** Comparing for equality 157 | , equals 158 | , equalsMut 159 | , same 160 | 161 | -- * Folds 162 | , foldl 163 | , foldl' 164 | , foldr 165 | , foldr' 166 | , foldMap 167 | , foldMap' 168 | , foldlMap' 169 | , ifoldl' 170 | , ifoldr 171 | , ifoldr' 172 | , ifoldlMap' 173 | , ifoldlMap1' 174 | , foldlM' 175 | , ifoldlM' 176 | , foldrM' 177 | , asum 178 | , all 179 | , any 180 | 181 | -- ** Zipping Folds 182 | , foldrZipWith 183 | , ifoldrZipWith 184 | , foldlZipWith' 185 | , ifoldlZipWith' 186 | , foldlZipWithM' 187 | , ifoldlZipWithM' 188 | 189 | -- * Traversals 190 | , traverse 191 | , traverse_ 192 | , itraverse 193 | , itraverse_ 194 | , traverseP 195 | , itraverseP 196 | , mapM 197 | , forM 198 | , mapM_ 199 | , forM_ 200 | , for 201 | , for_ 202 | , sequence 203 | , sequence_ 204 | 205 | -- * Typeclass method defaults 206 | , (<$) 207 | , ap 208 | 209 | -- * Prefix sums (scans) 210 | , scanl 211 | , scanl' 212 | , iscanl 213 | , iscanl' 214 | , prescanl 215 | , prescanl' 216 | , iprescanl 217 | , iprescanl' 218 | -- , postscanl 219 | -- , ipostscanl 220 | 221 | , mapAccum' 222 | , mapAccumLM' 223 | 224 | -- * Conversions 225 | 226 | -- ** Lists 227 | , fromList 228 | , fromListN 229 | , fromListMutable 230 | , fromListMutableN 231 | , unsafeFromListN 232 | , unsafeFromListReverseN 233 | , unsafeFromListReverseMutableN 234 | , toList 235 | , toListMutable 236 | 237 | -- ** Other array types 238 | , convert 239 | , lift 240 | , liftMut 241 | , unlift 242 | , unliftMut 243 | 244 | -- ** Between mutable and immutable variants 245 | , clone 246 | , cloneMut 247 | , copy 248 | , copyMut 249 | , freeze 250 | , thaw 251 | , unsafeFreeze 252 | 253 | -- * Hashing 254 | , liftHashWithSalt 255 | 256 | -- * Forcing an array and its contents 257 | , rnf 258 | 259 | -- * Classes 260 | , Contiguous (Mutable, Element, Sliced, MutableSliced) 261 | , ContiguousU 262 | , Always 263 | 264 | -- * Re-Exports 265 | , Array 266 | , MutableArray 267 | , SmallArray 268 | , SmallMutableArray 269 | , PrimArray 270 | , MutablePrimArray 271 | , UnliftedArray 272 | , MutableUnliftedArray 273 | , SmallUnliftedArray 274 | , SmallMutableUnliftedArray 275 | ) where 276 | 277 | import Control.Monad.Primitive 278 | import Data.Primitive 279 | import Data.Primitive.Unlifted.Array 280 | import Data.Primitive.Unlifted.SmallArray 281 | import Prelude hiding (Foldable (..), all, any, filter, map, mapM, mapM_, read, replicate, reverse, scanl, sequence, sequence_, traverse, zip, zipWith, (<$)) 282 | 283 | import Control.Monad (when) 284 | import Control.Monad.ST (ST, runST) 285 | import Data.Bits (xor) 286 | import Data.Coerce (coerce) 287 | import Data.Foldable (length) 288 | import Data.Primitive.Contiguous.Class (Always, Contiguous (..), ContiguousU (..), MutableSlice, Slice) 289 | import Data.Semigroup (First (..)) 290 | import Data.Word (Word8) 291 | import GHC.Base (build) 292 | import GHC.Exts (Int (..), MutableArrayArray#, dataToTag#, isTrue#, sameMutableArrayArray#, unsafeCoerce#) 293 | 294 | import qualified Control.Applicative as A 295 | import qualified Prelude 296 | 297 | construct1 :: 298 | (Contiguous arr, Element arr a) => 299 | a -> 300 | arr a 301 | {-# INLINE construct1 #-} 302 | construct1 = singleton 303 | 304 | construct2 :: 305 | (Contiguous arr, Element arr a) => 306 | a -> 307 | a -> 308 | arr a 309 | {-# INLINE construct2 #-} 310 | construct2 = doubleton 311 | 312 | construct3 :: 313 | (Contiguous arr, Element arr a) => 314 | a -> 315 | a -> 316 | a -> 317 | arr a 318 | {-# INLINE construct3 #-} 319 | construct3 = tripleton 320 | 321 | construct4 :: 322 | (Contiguous arr, Element arr a) => 323 | a -> 324 | a -> 325 | a -> 326 | a -> 327 | arr a 328 | {-# INLINE construct4 #-} 329 | construct4 = quadrupleton 330 | 331 | construct5 :: 332 | (Contiguous arr, Element arr a) => 333 | a -> 334 | a -> 335 | a -> 336 | a -> 337 | a -> 338 | arr a 339 | {-# INLINE construct5 #-} 340 | construct5 = quintupleton 341 | 342 | construct6 :: 343 | (Contiguous arr, Element arr a) => 344 | a -> 345 | a -> 346 | a -> 347 | a -> 348 | a -> 349 | a -> 350 | arr a 351 | {-# INLINE construct6 #-} 352 | construct6 = sextupleton 353 | 354 | -- | Append two arrays. 355 | append :: (Contiguous arr, Element arr a) => arr a -> arr a -> arr a 356 | append !a !b = run $ do 357 | m <- new (size a + size b) 358 | copy m 0 (toSlice a) 359 | copy m (size a) (toSlice b) 360 | unsafeFreeze m 361 | {-# INLINE append #-} 362 | 363 | -- | Delete the element at the given position. 364 | deleteAt :: (Contiguous arr, Element arr a) => arr a -> Int -> arr a 365 | deleteAt src i = run $ do 366 | dst <- thaw (slice src 0 (size src - 1)) 367 | let !i' = i + 1 368 | copy dst i (slice src i' (size src - i')) 369 | unsafeFreeze dst 370 | {-# INLINE deleteAt #-} 371 | 372 | {- | Create a copy of an array except the element at the index is replaced with 373 | the given value. 374 | -} 375 | replaceAt :: (Contiguous arr, Element arr a) => arr a -> Int -> a -> arr a 376 | replaceAt src i x = create $ do 377 | dst <- thaw (toSlice src) 378 | write dst i x 379 | pure dst 380 | {-# INLINE replaceAt #-} 381 | 382 | modifyAt :: 383 | (Contiguous arr, Element arr a) => 384 | (a -> a) -> 385 | arr a -> 386 | Int -> 387 | arr a 388 | modifyAt f src i = replaceAt src i $ f (index src i) 389 | {-# INLINE modifyAt #-} 390 | 391 | {- | Variant of modifyAt that forces the result before installing it in the 392 | array. 393 | -} 394 | modifyAt' :: 395 | (Contiguous arr, Element arr a) => 396 | (a -> a) -> 397 | arr a -> 398 | Int -> 399 | arr a 400 | modifyAt' f src i = replaceAt src i $! f (index src i) 401 | {-# INLINE modifyAt' #-} 402 | 403 | modifyAtF :: 404 | (Contiguous arr, Element arr a, Functor f) => 405 | (a -> f a) -> 406 | arr a -> 407 | Int -> 408 | f (arr a) 409 | modifyAtF f src i = replaceAt src i <$> f (index src i) 410 | {-# INLINE modifyAtF #-} 411 | 412 | {- | Variant of modifyAtF that forces the result before installing it in the 413 | array. Note that this requires 'Monad' rather than 'Functor'. 414 | -} 415 | modifyAtF' :: 416 | (Contiguous arr, Element arr a, Monad f) => 417 | (a -> f a) -> 418 | arr a -> 419 | Int -> 420 | f (arr a) 421 | modifyAtF' f src i = do 422 | !r <- f (index src i) 423 | let !dst = replaceAt src i r 424 | pure dst 425 | {-# INLINE modifyAtF' #-} 426 | 427 | -- | Map over the elements of an array with the index. 428 | imap :: 429 | (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => 430 | (Int -> b -> c) -> 431 | arr1 b -> 432 | arr2 c 433 | imap f a = run $ do 434 | mb <- new (size a) 435 | let go !i 436 | | i == size a = pure () 437 | | otherwise = do 438 | x <- indexM a i 439 | write mb i (f i x) 440 | go (i + 1) 441 | go 0 442 | unsafeFreeze mb 443 | {-# INLINE imap #-} 444 | 445 | {- | Map strictly over the elements of an array with the index. 446 | 447 | Note that because a new array must be created, the resulting 448 | array type can be /different/ than the original. 449 | -} 450 | imap' :: 451 | (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => 452 | (Int -> b -> c) -> 453 | arr1 b -> 454 | arr2 c 455 | imap' f a = run $ do 456 | mb <- new (size a) 457 | let go !i 458 | | i == size a = pure () 459 | | otherwise = do 460 | x <- indexM a i 461 | let !b = f i x 462 | write mb i b 463 | go (i + 1) 464 | go 0 465 | unsafeFreeze mb 466 | {-# INLINE imap' #-} 467 | 468 | {- | Map over the elements of an array. 469 | 470 | Note that because a new array must be created, the resulting 471 | array type can be /different/ than the original. 472 | -} 473 | map :: 474 | (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => 475 | (b -> c) -> 476 | arr1 b -> 477 | arr2 c 478 | map f a = run $ do 479 | mb <- new (size a) 480 | let go !i 481 | | i == size a = pure () 482 | | otherwise = do 483 | x <- indexM a i 484 | write mb i (f x) 485 | go (i + 1) 486 | go 0 487 | unsafeFreeze mb 488 | {-# INLINE map #-} 489 | 490 | {- | Map strictly over the elements of an array. 491 | 492 | Note that because a new array must be created, the resulting 493 | array type can be /different/ than the original. 494 | -} 495 | map' :: 496 | (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 c) => 497 | (b -> c) -> 498 | arr1 b -> 499 | arr2 c 500 | map' f a = run $ do 501 | mb <- new (size a) 502 | let go !i 503 | | i == size a = pure () 504 | | otherwise = do 505 | x <- indexM a i 506 | let !b = f x 507 | write mb i b 508 | go (i + 1) 509 | go 0 510 | unsafeFreeze mb 511 | {-# INLINE map' #-} 512 | 513 | -- | Convert one type of array into another. 514 | convert :: 515 | (Contiguous arr1, Element arr1 b, Contiguous arr2, Element arr2 b) => 516 | arr1 b -> 517 | arr2 b 518 | convert a = map id a 519 | {-# INLINE convert #-} 520 | 521 | -- | Right fold over the element of an array. 522 | foldr :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b 523 | {-# INLINE foldr #-} 524 | foldr f z = \arr -> 525 | let !sz = size arr 526 | go !ix = 527 | if sz > ix 528 | then case index# arr ix of 529 | (# x #) -> f x (go (ix + 1)) 530 | else z 531 | in go 0 532 | 533 | {- | Right fold over the element of an array, lazy in the accumulator, 534 | provides index to the step function. 535 | -} 536 | ifoldr :: (Contiguous arr, Element arr a) => (Int -> a -> b -> b) -> b -> arr a -> b 537 | {-# INLINE ifoldr #-} 538 | ifoldr f z = \arr -> 539 | let !sz = size arr 540 | go !ix = 541 | if sz > ix 542 | then case index# arr ix of 543 | (# x #) -> f ix x (go (ix + 1)) 544 | else z 545 | in go 0 546 | 547 | -- | Strict right fold over the elements of an array. 548 | foldr' :: (Contiguous arr, Element arr a) => (a -> b -> b) -> b -> arr a -> b 549 | foldr' f !z = \arr -> 550 | let go !ix !acc = 551 | if ix == -1 552 | then acc 553 | else case index# arr ix of 554 | (# x #) -> go (ix - 1) (f x acc) 555 | in go (size arr - 1) z 556 | {-# INLINE foldr' #-} 557 | 558 | -- | Left fold over the elements of an array. 559 | foldl :: (Contiguous arr, Element arr a) => (b -> a -> b) -> b -> arr a -> b 560 | foldl f z = \arr -> 561 | let !sz = size arr 562 | go !ix acc = 563 | if ix == sz 564 | then acc 565 | else case index# arr ix of 566 | (# x #) -> go (ix + 1) (f acc x) 567 | in go 0 z 568 | {-# INLINE foldl #-} 569 | 570 | -- | Strict left fold over the elements of an array. 571 | foldl' :: (Contiguous arr, Element arr a) => (b -> a -> b) -> b -> arr a -> b 572 | foldl' f !z = \arr -> 573 | let !sz = size arr 574 | go !ix !acc = 575 | if ix == sz 576 | then acc 577 | else case index# arr ix of 578 | (# x #) -> go (ix + 1) (f acc x) 579 | in go 0 z 580 | {-# INLINE foldl' #-} 581 | 582 | {- | Strict left fold over the elements of an array, where the accumulating 583 | function cares about the index of the element. 584 | -} 585 | ifoldl' :: 586 | (Contiguous arr, Element arr a) => 587 | (b -> Int -> a -> b) -> 588 | b -> 589 | arr a -> 590 | b 591 | ifoldl' f !z = \arr -> 592 | let !sz = size arr 593 | go !ix !acc = 594 | if ix == sz 595 | then acc 596 | else case index# arr ix of 597 | (# x #) -> go (ix + 1) (f acc ix x) 598 | in go 0 z 599 | {-# INLINE ifoldl' #-} 600 | 601 | {- | Strict right fold over the elements of an array, where the accumulating 602 | function cares about the index of the element. 603 | -} 604 | ifoldr' :: 605 | (Contiguous arr, Element arr a) => 606 | (Int -> a -> b -> b) -> 607 | b -> 608 | arr a -> 609 | b 610 | ifoldr' f !z = \arr -> 611 | let !sz = size arr 612 | go !ix !acc = 613 | if ix == (-1) 614 | then acc 615 | else case index# arr ix of 616 | (# x #) -> go (ix - 1) (f ix x acc) 617 | in go (sz - 1) z 618 | {-# INLINE ifoldr' #-} 619 | 620 | -- | Monoidal fold over the element of an array. 621 | foldMap :: (Contiguous arr, Element arr a, Monoid m) => (a -> m) -> arr a -> m 622 | foldMap f = \arr -> 623 | let !sz = size arr 624 | go !ix = 625 | if sz > ix 626 | then case index# arr ix of 627 | (# x #) -> mappend (f x) (go (ix + 1)) 628 | else mempty 629 | in go 0 630 | {-# INLINE foldMap #-} 631 | 632 | -- | Strict monoidal fold over the elements of an array. 633 | foldMap' :: 634 | (Contiguous arr, Element arr a, Monoid m) => 635 | (a -> m) -> 636 | arr a -> 637 | m 638 | foldMap' f = \arr -> 639 | let !sz = size arr 640 | go !ix !acc = 641 | if ix == sz 642 | then acc 643 | else case index# arr ix of 644 | (# x #) -> go (ix + 1) (mappend acc (f x)) 645 | in go 0 mempty 646 | {-# INLINE foldMap' #-} 647 | 648 | -- | Strict left monoidal fold over the elements of an array. 649 | foldlMap' :: 650 | (Contiguous arr, Element arr a, Monoid m) => 651 | (a -> m) -> 652 | arr a -> 653 | m 654 | foldlMap' = foldMap' 655 | {-# INLINE foldlMap' #-} 656 | 657 | -- | Strict monoidal fold over the elements of an array. 658 | ifoldlMap' :: 659 | (Contiguous arr, Element arr a, Monoid m) => 660 | (Int -> a -> m) -> 661 | arr a -> 662 | m 663 | ifoldlMap' f = \arr -> 664 | let !sz = size arr 665 | go !ix !acc = 666 | if ix == sz 667 | then acc 668 | else case index# arr ix of 669 | (# x #) -> go (ix + 1) (mappend acc (f ix x)) 670 | in go 0 mempty 671 | {-# INLINE ifoldlMap' #-} 672 | 673 | -- | Strict monoidal fold over the elements of an array. 674 | ifoldlMap1' :: 675 | (Contiguous arr, Element arr a, Semigroup m) => 676 | (Int -> a -> m) -> 677 | arr a -> 678 | m 679 | ifoldlMap1' f = \arr -> 680 | let !sz = size arr 681 | go !ix !acc = 682 | if ix == sz 683 | then acc 684 | else case index# arr ix of 685 | (# x #) -> go (ix + 1) (acc <> f ix x) 686 | !(# e0 #) = index# arr 0 687 | in go 1 (f 0 e0) 688 | {-# INLINE ifoldlMap1' #-} 689 | 690 | -- | Strict right monadic fold over the elements of an array. 691 | foldrM' :: 692 | (Contiguous arr, Element arr a, Monad m) => 693 | (a -> b -> m b) -> 694 | b -> 695 | arr a -> 696 | m b 697 | foldrM' f !z0 = \arr -> 698 | let !sz = size arr 699 | go !ix !acc1 = 700 | if ix >= 0 701 | then do 702 | let (# x #) = index# arr ix 703 | acc2 <- f x acc1 704 | go (ix - 1) acc2 705 | else pure acc1 706 | in go (sz - 1) z0 707 | {-# INLINE foldrM' #-} 708 | 709 | -- | Strict left monadic fold over the elements of an array. 710 | foldlM' :: 711 | (Contiguous arr, Element arr a, Monad m) => 712 | (b -> a -> m b) -> 713 | b -> 714 | arr a -> 715 | m b 716 | foldlM' f !z0 = \arr -> 717 | let !sz = size arr 718 | go !ix !acc1 = 719 | if ix < sz 720 | then do 721 | let (# x #) = index# arr ix 722 | acc2 <- f acc1 x 723 | go (ix + 1) acc2 724 | else pure acc1 725 | in go 0 z0 726 | {-# INLINE foldlM' #-} 727 | 728 | -- | Strict left monadic fold over the elements of an array. 729 | ifoldlM' :: 730 | (Contiguous arr, Element arr a, Monad m) => 731 | (b -> Int -> a -> m b) -> 732 | b -> 733 | arr a -> 734 | m b 735 | ifoldlM' f z0 = \arr -> 736 | let !sz = size arr 737 | go !ix !acc1 = 738 | if ix < sz 739 | then do 740 | let (# x #) = index# arr ix 741 | acc2 <- f acc1 ix x 742 | go (ix + 1) acc2 743 | else pure acc1 744 | in go 0 z0 745 | {-# INLINE ifoldlM' #-} 746 | 747 | -- | Drop elements that do not satisfy the predicate. 748 | filter :: 749 | (Contiguous arr, Element arr a) => 750 | (a -> Bool) -> 751 | arr a -> 752 | arr a 753 | filter p arr = ifilter (const p) arr 754 | {-# INLINE filter #-} 755 | 756 | {- | Drop elements that do not satisfy the predicate which 757 | is applied to values and their indices. 758 | -} 759 | ifilter :: 760 | (Contiguous arr, Element arr a) => 761 | (Int -> a -> Bool) -> 762 | arr a -> 763 | arr a 764 | ifilter p arr = run $ do 765 | marr :: MutablePrimArray s Word8 <- newPrimArray sz 766 | let go1 :: Int -> Int -> ST s Int 767 | go1 !ix !numTrue = 768 | if ix < sz 769 | then do 770 | atIx <- indexM arr ix 771 | let !keep = p ix atIx 772 | let !keepTag = I# (dataToTag# keep) 773 | writePrimArray marr ix (fromIntegral keepTag) 774 | go1 (ix + 1) (numTrue + keepTag) 775 | else pure numTrue 776 | numTrue <- go1 0 0 777 | if numTrue == sz 778 | then pure arr 779 | else do 780 | marrTrues <- new numTrue 781 | let go2 !ixSrc !ixDst = when (ixDst < numTrue) $ do 782 | atIxKeep <- readPrimArray marr ixSrc 783 | if isTrue atIxKeep 784 | then do 785 | atIxVal <- indexM arr ixSrc 786 | write marrTrues ixDst atIxVal 787 | go2 (ixSrc + 1) (ixDst + 1) 788 | else go2 (ixSrc + 1) ixDst 789 | go2 0 0 790 | unsafeFreeze marrTrues 791 | where 792 | !sz = size arr 793 | {-# INLINE ifilter #-} 794 | 795 | {- | The 'mapMaybe' function is a version of 'map' which can throw out elements. 796 | In particular, the functional arguments returns something of type @'Maybe' b@. 797 | If this is 'Nothing', no element is added on to the result array. If it is 798 | @'Just' b@, then @b@ is included in the result array. 799 | -} 800 | mapMaybe :: 801 | forall arr1 arr2 a b. 802 | ( Contiguous arr1 803 | , Element arr1 a 804 | , Contiguous arr2 805 | , Element arr2 b 806 | ) => 807 | (a -> Maybe b) -> 808 | arr1 a -> 809 | arr2 b 810 | mapMaybe f arr = run $ do 811 | let !sz = size arr 812 | let go :: Int -> Int -> [b] -> ST s ([b], Int) 813 | go !ix !numJusts !justs = 814 | if ix < sz 815 | then do 816 | atIx <- indexM arr ix 817 | case f atIx of 818 | Nothing -> go (ix + 1) numJusts justs 819 | Just x -> go (ix + 1) (numJusts + 1) (x : justs) 820 | else pure (justs, numJusts) 821 | !(bs, !numJusts) <- go 0 0 [] 822 | !marr <- unsafeFromListReverseMutableN numJusts bs 823 | unsafeFreeze marr 824 | {-# INLINE mapMaybe #-} 825 | 826 | {-# INLINE isTrue #-} 827 | isTrue :: Word8 -> Bool 828 | isTrue 0 = False 829 | isTrue _ = True 830 | 831 | {- | The 'catMaybes' function takes a list of 'Maybe's and returns a 832 | list of all the 'Just' values. 833 | -} 834 | catMaybes :: 835 | (Contiguous arr, Element arr a, Element arr (Maybe a)) => 836 | arr (Maybe a) -> 837 | arr a 838 | catMaybes = mapMaybe id 839 | {-# INLINE catMaybes #-} 840 | 841 | -- | @'replicate' n x@ is an array of length @n@ with @x@ the value of every element. 842 | replicate :: (Contiguous arr, Element arr a) => Int -> a -> arr a 843 | replicate n x = create (replicateMut n x) 844 | {-# INLINE replicate #-} 845 | 846 | -- | @'replicateMutM' n act@ performs the action n times, gathering the results. 847 | replicateMutM :: 848 | (PrimMonad m, Contiguous arr, Element arr a) => 849 | Int -> 850 | m a -> 851 | m (Mutable arr (PrimState m) a) 852 | replicateMutM len act = do 853 | marr <- new len 854 | let go !ix = when (ix < len) $ do 855 | x <- act 856 | write marr ix x 857 | go (ix + 1) 858 | go 0 859 | pure marr 860 | {-# INLINE replicateMutM #-} 861 | 862 | {- | Create an array from a list. If the given length does 863 | not match the actual length, this function has undefined 864 | behavior. 865 | -} 866 | unsafeFromListN :: 867 | (Contiguous arr, Element arr a) => 868 | -- | length of list 869 | Int -> 870 | -- | list 871 | [a] -> 872 | arr a 873 | unsafeFromListN n l = create (unsafeFromListMutableN n l) 874 | {-# INLINE unsafeFromListN #-} 875 | 876 | unsafeFromListMutableN :: 877 | (Contiguous arr, Element arr a, PrimMonad m) => 878 | Int -> 879 | [a] -> 880 | m (Mutable arr (PrimState m) a) 881 | unsafeFromListMutableN n l = do 882 | m <- new n 883 | let go !_ [] = pure m 884 | go !ix (x : xs) = do 885 | write m ix x 886 | go (ix + 1) xs 887 | go 0 l 888 | {-# INLINE unsafeFromListMutableN #-} 889 | 890 | {- | Create a mutable array from a list, reversing the order of 891 | the elements. If the given length does not match the actual length, 892 | this function has undefined behavior. 893 | -} 894 | unsafeFromListReverseMutableN :: 895 | (Contiguous arr, Element arr a, PrimMonad m) => 896 | Int -> 897 | [a] -> 898 | m (Mutable arr (PrimState m) a) 899 | unsafeFromListReverseMutableN n l = do 900 | m <- new n 901 | let go !_ [] = pure m 902 | go !ix (x : xs) = do 903 | write m ix x 904 | go (ix - 1) xs 905 | go (n - 1) l 906 | {-# INLINE unsafeFromListReverseMutableN #-} 907 | 908 | {- | Create an array from a list, reversing the order of the 909 | elements. If the given length does not match the actual length, 910 | this function has undefined behavior. 911 | -} 912 | unsafeFromListReverseN :: 913 | (Contiguous arr, Element arr a) => 914 | Int -> 915 | [a] -> 916 | arr a 917 | unsafeFromListReverseN n l = create (unsafeFromListReverseMutableN n l) 918 | {-# INLINE unsafeFromListReverseN #-} 919 | 920 | -- | Map over a mutable array, modifying the elements in place. 921 | mapMutable :: 922 | (Contiguous arr, Element arr a, PrimMonad m) => 923 | (a -> a) -> 924 | Mutable arr (PrimState m) a -> 925 | m () 926 | mapMutable f !marr = do 927 | !sz <- sizeMut marr 928 | let go !ix = when (ix < sz) $ do 929 | a <- read marr ix 930 | write marr ix (f a) 931 | go (ix + 1) 932 | go 0 933 | {-# INLINE mapMutable #-} 934 | 935 | -- | Strictly map over a mutable array, modifying the elements in place. 936 | mapMutable' :: 937 | (PrimMonad m, Contiguous arr, Element arr a) => 938 | (a -> a) -> 939 | Mutable arr (PrimState m) a -> 940 | m () 941 | mapMutable' f !marr = do 942 | !sz <- sizeMut marr 943 | let go !ix = when (ix < sz) $ do 944 | a <- read marr ix 945 | let !b = f a 946 | write marr ix b 947 | go (ix + 1) 948 | go 0 949 | {-# INLINE mapMutable' #-} 950 | 951 | -- | Map over a mutable array with indices, modifying the elements in place. 952 | imapMutable :: 953 | (Contiguous arr, Element arr a, PrimMonad m) => 954 | (Int -> a -> a) -> 955 | Mutable arr (PrimState m) a -> 956 | m () 957 | imapMutable f !marr = do 958 | !sz <- sizeMut marr 959 | let go !ix = when (ix < sz) $ do 960 | a <- read marr ix 961 | write marr ix (f ix a) 962 | go (ix + 1) 963 | go 0 964 | {-# INLINE imapMutable #-} 965 | 966 | -- | Strictly map over a mutable array with indices, modifying the elements in place. 967 | imapMutable' :: 968 | (PrimMonad m, Contiguous arr, Element arr a) => 969 | (Int -> a -> a) -> 970 | Mutable arr (PrimState m) a -> 971 | m () 972 | imapMutable' f !marr = do 973 | !sz <- sizeMut marr 974 | let go !ix = when (ix < sz) $ do 975 | a <- read marr ix 976 | let !b = f ix a 977 | write marr ix b 978 | go (ix + 1) 979 | go 0 980 | {-# INLINE imapMutable' #-} 981 | 982 | {- | Map each element of the array to an action, evaluate these 983 | actions from left to right, and collect the results in a 984 | new array. 985 | -} 986 | traverseP :: 987 | ( PrimMonad m 988 | , Contiguous arr1 989 | , Element arr1 a 990 | , Contiguous arr2 991 | , Element arr2 b 992 | ) => 993 | (a -> m b) -> 994 | arr1 a -> 995 | m (arr2 b) 996 | traverseP f !arr = do 997 | let !sz = size arr 998 | !marr <- new sz 999 | let go !ix = when (ix < sz) $ do 1000 | a <- indexM arr ix 1001 | b <- f a 1002 | write marr ix b 1003 | go (ix + 1) 1004 | go 0 1005 | unsafeFreeze marr 1006 | {-# INLINE traverseP #-} 1007 | 1008 | {- | Map each element of the array to an action, evaluate these 1009 | actions from left to right, and collect the results in a 1010 | new array. 1011 | -} 1012 | itraverseP :: 1013 | ( PrimMonad m 1014 | , Contiguous arr1 1015 | , Element arr1 a 1016 | , Contiguous arr2 1017 | , Element arr2 b 1018 | ) => 1019 | (Int -> a -> m b) -> 1020 | arr1 a -> 1021 | m (arr2 b) 1022 | itraverseP f !arr = do 1023 | let !sz = size arr 1024 | !marr <- new sz 1025 | let go !ix = when (ix < sz) $ do 1026 | a <- indexM arr ix 1027 | b <- f ix a 1028 | write marr ix b 1029 | go (ix + 1) 1030 | go 0 1031 | unsafeFreeze marr 1032 | {-# INLINE itraverseP #-} 1033 | 1034 | newtype STA v a = STA {_runSTA :: forall s. Mutable v s a -> ST s (v a)} 1035 | 1036 | runSTA :: (Contiguous v, Element v a) => Int -> STA v a -> v a 1037 | runSTA !sz (STA m) = runST $ new sz >>= m 1038 | {-# INLINE runSTA #-} 1039 | 1040 | {- | Map each element of the array to an action, evaluate these 1041 | actions from left to right, and collect the results. 1042 | For a version that ignores the results, see 'traverse_'. 1043 | -} 1044 | traverse :: 1045 | ( Contiguous arr1 1046 | , Contiguous arr2 1047 | , Element arr1 a 1048 | , Element arr2 b 1049 | , Applicative f 1050 | ) => 1051 | (a -> f b) -> 1052 | arr1 a -> 1053 | f (arr2 b) 1054 | traverse f = itraverse (const f) 1055 | {-# INLINE traverse #-} 1056 | 1057 | {- | Map each element of the array to an action, evaluate these 1058 | actions from left to right, and ignore the results. 1059 | For a version that doesn't ignore the results, see 'traverse'. 1060 | -} 1061 | traverse_ :: 1062 | (Contiguous arr, Element arr a, Applicative f) => 1063 | (a -> f b) -> 1064 | arr a -> 1065 | f () 1066 | traverse_ f = itraverse_ (const f) 1067 | 1068 | {- | Map each element of the array and its index to an action, 1069 | evaluating these actions from left to right. 1070 | -} 1071 | itraverse :: 1072 | ( Contiguous arr1 1073 | , Contiguous arr2 1074 | , Element arr1 a 1075 | , Element arr2 b 1076 | , Applicative f 1077 | ) => 1078 | (Int -> a -> f b) -> 1079 | arr1 a -> 1080 | f (arr2 b) 1081 | itraverse f = \arr -> 1082 | let !sz = size arr 1083 | go !ix = 1084 | if ix == sz 1085 | then pure (STA unsafeFreeze) 1086 | else case index# arr ix of 1087 | (# x #) -> 1088 | A.liftA2 1089 | ( \b (STA m) -> STA $ \marr -> do 1090 | write marr ix b 1091 | m marr 1092 | ) 1093 | (f ix x) 1094 | (go (ix + 1)) 1095 | in if sz == 0 1096 | then pure empty 1097 | else runSTA sz <$> go 0 1098 | {-# INLINE itraverse #-} 1099 | 1100 | {- | Map each element of the array and its index to an action, 1101 | evaluate these actions from left to right, and ignore the results. 1102 | For a version that doesn't ignore the results, see 'itraverse'. 1103 | -} 1104 | itraverse_ :: 1105 | (Contiguous arr, Element arr a, Applicative f) => 1106 | (Int -> a -> f b) -> 1107 | arr a -> 1108 | f () 1109 | itraverse_ f = \arr -> 1110 | let !sz = size arr 1111 | go !ix = 1112 | when (ix < sz) $ 1113 | f ix (index arr ix) *> go (ix + 1) 1114 | in go 0 1115 | {-# INLINE itraverse_ #-} 1116 | 1117 | {- | 'for' is 'traverse' with its arguments flipped. For a version 1118 | that ignores the results see 'for_'. 1119 | -} 1120 | for :: 1121 | ( Contiguous arr1 1122 | , Contiguous arr2 1123 | , Element arr1 a 1124 | , Element arr2 b 1125 | , Applicative f 1126 | ) => 1127 | arr1 a -> 1128 | (a -> f b) -> 1129 | f (arr2 b) 1130 | for = flip traverse 1131 | {-# INLINE for #-} 1132 | 1133 | {- | 'for_' is 'traverse_' with its arguments flipped. For a version 1134 | that doesn't ignore the results see 'for'. 1135 | 1136 | >>> for_ (C.fromList [1..4] :: PrimArray Int) print 1137 | 1 1138 | 2 1139 | 3 1140 | 4 1141 | -} 1142 | for_ :: 1143 | (Contiguous arr, Element arr a, Applicative f) => 1144 | arr a -> 1145 | (a -> f b) -> 1146 | f () 1147 | for_ = flip traverse_ 1148 | {-# INLINE for_ #-} 1149 | 1150 | {- | Monadic accumulating strict left fold over the elements on an 1151 | array. 1152 | -} 1153 | mapAccumLM' :: 1154 | ( Contiguous arr1 1155 | , Contiguous arr2 1156 | , Element arr1 b 1157 | , Element arr2 c 1158 | , Monad m 1159 | ) => 1160 | (a -> b -> m (a, c)) -> 1161 | a -> 1162 | arr1 b -> 1163 | m (a, arr2 c) 1164 | {-# INLINE mapAccumLM' #-} 1165 | mapAccumLM' f a0 src = go 0 [] a0 1166 | where 1167 | !sz = size src 1168 | go !ix !xs !acc = 1169 | if ix < sz 1170 | then do 1171 | (!acc', !x) <- f acc (index src ix) 1172 | go (ix + 1) (x : xs) acc' 1173 | else 1174 | let !xs' = unsafeFromListReverseN sz xs 1175 | in pure (acc, xs') 1176 | 1177 | mapAccum' :: 1178 | forall arr1 arr2 a b c. 1179 | ( Contiguous arr1 1180 | , Contiguous arr2 1181 | , Element arr1 b 1182 | , Element arr2 c 1183 | , Monoid a 1184 | ) => 1185 | (b -> (a, c)) -> 1186 | arr1 b -> 1187 | (a, arr2 c) 1188 | {-# INLINE mapAccum' #-} 1189 | mapAccum' f !src = runST $ do 1190 | dst <- new sz 1191 | acc <- go 0 dst mempty 1192 | dst' <- unsafeFreeze dst 1193 | pure (acc, dst') 1194 | where 1195 | !sz = size src 1196 | go :: Int -> Mutable arr2 s c -> a -> ST s a 1197 | go !ix !dst !accA = 1198 | if ix < sz 1199 | then do 1200 | let (!accB, !x) = f (index src ix) 1201 | write dst ix x 1202 | go (ix + 1) dst (accA <> accB) 1203 | else pure accA 1204 | 1205 | {- | Map each element of a structure to a monadic action, 1206 | evaluate these actions from left to right, and collect 1207 | the results. for a version that ignores the results see 1208 | 'mapM_'. 1209 | -} 1210 | mapM :: 1211 | ( Contiguous arr1 1212 | , Contiguous arr2 1213 | , Element arr1 a 1214 | , Element arr2 b 1215 | , Monad m 1216 | ) => 1217 | (a -> m b) -> 1218 | arr1 a -> 1219 | m (arr2 b) 1220 | mapM f arr = 1221 | let !sz = size arr 1222 | in generateM sz $ \ix -> indexM arr ix >>= f 1223 | {-# INLINE mapM #-} 1224 | 1225 | {- | Map each element of a structure to a monadic action, 1226 | evaluate these actions from left to right, and ignore 1227 | the results. For a version that doesn't ignore the results 1228 | see 'mapM'. 1229 | 1230 | 'mapM_' = 'traverse_' 1231 | -} 1232 | mapM_ :: 1233 | (Contiguous arr, Element arr a, Element arr b, Applicative f) => 1234 | (a -> f b) -> 1235 | arr a -> 1236 | f () 1237 | mapM_ = traverse_ 1238 | {-# INLINE mapM_ #-} 1239 | 1240 | {- | 'forM' is 'mapM' with its arguments flipped. For a version that 1241 | ignores its results, see 'forM_'. 1242 | -} 1243 | forM :: 1244 | ( Contiguous arr1 1245 | , Contiguous arr2 1246 | , Element arr1 a 1247 | , Element arr2 b 1248 | , Monad m 1249 | ) => 1250 | arr1 a -> 1251 | (a -> m b) -> 1252 | m (arr2 b) 1253 | forM = flip mapM 1254 | {-# INLINE forM #-} 1255 | 1256 | {- | 'forM_' is 'mapM_' with its arguments flipped. For a version that 1257 | doesn't ignore its results, see 'forM'. 1258 | -} 1259 | forM_ :: 1260 | (Contiguous arr, Element arr a, Element arr b, Applicative f) => 1261 | arr a -> 1262 | (a -> f b) -> 1263 | f () 1264 | forM_ = flip traverse_ 1265 | {-# INLINE forM_ #-} 1266 | 1267 | {- | Evaluate each action in the structure from left to right 1268 | and collect the results. For a version that ignores the 1269 | results see 'sequence_'. 1270 | -} 1271 | sequence :: 1272 | ( Contiguous arr1 1273 | , Contiguous arr2 1274 | , Element arr1 (f a) 1275 | , Element arr2 a 1276 | , Applicative f 1277 | ) => 1278 | arr1 (f a) -> 1279 | f (arr2 a) 1280 | sequence = traverse id 1281 | {-# INLINE sequence #-} 1282 | 1283 | {- | Evaluate each action in the structure from left to right 1284 | and ignore the results. For a version that doesn't ignore 1285 | the results see 'sequence'. 1286 | -} 1287 | sequence_ :: 1288 | ( Contiguous arr 1289 | , Element arr (f a) 1290 | , Applicative f 1291 | ) => 1292 | arr (f a) -> 1293 | f () 1294 | sequence_ = foldr (*>) (pure ()) 1295 | {-# INLINE sequence_ #-} 1296 | 1297 | {- | The sum of a collection of actions, generalizing 'concat'. 1298 | 1299 | >>> asum (C.fromList ['Just' "Hello", 'Nothing', Just "World"] :: Array String) 1300 | Just "Hello" 1301 | -} 1302 | asum :: 1303 | ( Contiguous arr 1304 | , Element arr (f a) 1305 | , A.Alternative f 1306 | ) => 1307 | arr (f a) -> 1308 | f a 1309 | asum = foldr (A.<|>) A.empty 1310 | {-# INLINE asum #-} 1311 | 1312 | {- | Construct an array of the given length by applying 1313 | the function to each index. 1314 | -} 1315 | generate :: 1316 | (Contiguous arr, Element arr a) => 1317 | Int -> 1318 | (Int -> a) -> 1319 | arr a 1320 | generate len f = create (generateMutable len f) 1321 | {-# INLINE generate #-} 1322 | 1323 | {- | Construct an array of the given length by applying 1324 | the monadic action to each index. 1325 | -} 1326 | generateM :: 1327 | (Contiguous arr, Element arr a, Monad m) => 1328 | Int -> 1329 | (Int -> m a) -> 1330 | m (arr a) 1331 | {-# INLINE generateM #-} 1332 | generateM !sz f = 1333 | let go !ix = 1334 | if ix < sz 1335 | then 1336 | A.liftA2 1337 | ( \b (STA m) -> STA $ \marr -> do 1338 | write marr ix b 1339 | m marr 1340 | ) 1341 | (f ix) 1342 | (go (ix + 1)) 1343 | else pure $ STA unsafeFreeze 1344 | in if sz == 0 1345 | then pure empty 1346 | else runSTA sz <$> go 0 1347 | 1348 | {- | Construct a mutable array of the given length by applying 1349 | the function to each index. 1350 | -} 1351 | generateMutable :: 1352 | (Contiguous arr, Element arr a, PrimMonad m) => 1353 | Int -> 1354 | (Int -> a) -> 1355 | m (Mutable arr (PrimState m) a) 1356 | generateMutable len f = generateMutableM len (pure . f) 1357 | {-# INLINE generateMutable #-} 1358 | 1359 | {- | Construct a mutable array of the given length by applying 1360 | the monadic action to each index. 1361 | -} 1362 | generateMutableM :: 1363 | (Contiguous arr, Element arr a, PrimMonad m) => 1364 | Int -> 1365 | (Int -> m a) -> 1366 | m (Mutable arr (PrimState m) a) 1367 | generateMutableM !len f = do 1368 | marr <- new len 1369 | let go !ix = when (ix < len) $ do 1370 | x <- f ix 1371 | write marr ix x 1372 | go (ix + 1) 1373 | go 0 1374 | pure marr 1375 | {-# INLINE generateMutableM #-} 1376 | 1377 | {- | Apply a function @n@ times to a value and construct an array 1378 | where each consecutive element is the result of an additional 1379 | application of this function. The zeroth element is the original value. 1380 | 1381 | @'iterateN' 5 ('+' 1) 0 = 'fromListN' 5 [0,1,2,3,4]@ 1382 | -} 1383 | iterateN :: 1384 | (Contiguous arr, Element arr a) => 1385 | Int -> 1386 | (a -> a) -> 1387 | a -> 1388 | arr a 1389 | iterateN len f z0 = runST (iterateMutableN len f z0 >>= unsafeFreeze) 1390 | {-# INLINE iterateN #-} 1391 | 1392 | {- | Apply a function @n@ times to a value and construct a mutable array 1393 | where each consecutive element is the result of an additional 1394 | application of this function. The zeroth element is the original value. 1395 | -} 1396 | iterateMutableN :: 1397 | (Contiguous arr, Element arr a, PrimMonad m) => 1398 | Int -> 1399 | (a -> a) -> 1400 | a -> 1401 | m (Mutable arr (PrimState m) a) 1402 | iterateMutableN len f z0 = iterateMutableNM len (pure . f) z0 1403 | {-# INLINE iterateMutableN #-} 1404 | 1405 | {- | Apply a monadic function @n@ times to a value and construct a mutable array 1406 | where each consecutive element is the result of an additional 1407 | application of this function. The zeroth element is the original value. 1408 | -} 1409 | iterateMutableNM :: 1410 | (Contiguous arr, Element arr a, PrimMonad m) => 1411 | Int -> 1412 | (a -> m a) -> 1413 | a -> 1414 | m (Mutable arr (PrimState m) a) 1415 | iterateMutableNM !len f z0 = do 1416 | marr <- new len 1417 | -- we are strict in the accumulator because 1418 | -- otherwise we could build up a ton of `f (f (f (f .. (f a))))` 1419 | -- thunks for no reason. 1420 | let go !ix !acc 1421 | | ix <= 0 = write marr ix z0 >> go (ix + 1) z0 1422 | | ix == len = pure () 1423 | | otherwise = do 1424 | a <- f acc 1425 | write marr ix a 1426 | go (ix + 1) a 1427 | go 0 z0 1428 | pure marr 1429 | {-# INLINE iterateMutableNM #-} 1430 | 1431 | -- | Execute the monad action and freeze the resulting array. 1432 | create :: 1433 | (Contiguous arr, Element arr a) => 1434 | (forall s. ST s (Mutable arr s a)) -> 1435 | arr a 1436 | create x = run (unsafeFreeze =<< x) 1437 | {-# INLINE create #-} 1438 | 1439 | -- | Execute the monadic action and freeze the resulting array. 1440 | createT :: 1441 | (Contiguous arr, Element arr a, Traversable f) => 1442 | (forall s. ST s (f (Mutable arr s a))) -> 1443 | f (arr a) 1444 | createT p = runST (Prelude.mapM unsafeFreeze =<< p) 1445 | {-# INLINE createT #-} 1446 | 1447 | {- | Construct an array by repeatedly applying a generator 1448 | function to a seed. The generator function yields 'Just' the 1449 | next element and the new seed or 'Nothing' if there are no more 1450 | elements. 1451 | 1452 | >>> unfoldr (\n -> if n == 0 then Nothing else Just (n,n-1) 10 1453 | <10,9,8,7,6,5,4,3,2,1> 1454 | -} 1455 | 1456 | -- Unfortunately, because we don't know ahead of time when to stop, 1457 | -- we need to construct a list and then turn it into an array. 1458 | unfoldr :: 1459 | (Contiguous arr, Element arr a) => 1460 | (b -> Maybe (a, b)) -> 1461 | b -> 1462 | arr a 1463 | unfoldr f z0 = create (unfoldrMutable f z0) 1464 | {-# INLINE unfoldr #-} 1465 | 1466 | {- | Construct a mutable array by repeatedly applying a generator 1467 | function to a seed. The generator function yields 'Just' the 1468 | next element and the new seed or 'Nothing' if there are no more 1469 | elements. 1470 | 1471 | >>> unfoldrMutable (\n -> if n == 0 then Nothing else Just (n,n-1) 10 1472 | <10,9,8,7,6,5,4,3,2,1> 1473 | -} 1474 | 1475 | -- Unfortunately, because we don't know ahead of time when to stop, 1476 | -- we need to construct a list and then turn it into an array. 1477 | unfoldrMutable :: 1478 | (Contiguous arr, Element arr a, PrimMonad m) => 1479 | (b -> Maybe (a, b)) -> 1480 | b -> 1481 | m (Mutable arr (PrimState m) a) 1482 | unfoldrMutable f z0 = do 1483 | let go !sz s !xs = case f s of 1484 | Nothing -> pure (sz, xs) 1485 | Just (x, s') -> go (sz + 1) s' (x : xs) 1486 | (sz, xs) <- go 0 z0 [] 1487 | unsafeFromListReverseMutableN sz xs 1488 | {-# INLINE unfoldrMutable #-} 1489 | 1490 | {- | Construct an array with at most n elements by repeatedly 1491 | applying the generator function to a seed. The generator function 1492 | yields 'Just' the next element and the new seed or 'Nothing' if 1493 | there are no more elements. 1494 | -} 1495 | unfoldrN :: 1496 | (Contiguous arr, Element arr a) => 1497 | Int -> 1498 | (b -> Maybe (a, b)) -> 1499 | b -> 1500 | arr a 1501 | unfoldrN maxSz f z0 = create (unfoldrMutableN maxSz f z0) 1502 | {-# INLINE unfoldrN #-} 1503 | 1504 | {- | Construct a mutable array with at most n elements by repeatedly 1505 | applying the generator function to a seed. The generator function 1506 | yields 'Just' the next element and the new seed or 'Nothing' if 1507 | there are no more elements. 1508 | -} 1509 | unfoldrMutableN :: 1510 | (Contiguous arr, Element arr a, PrimMonad m) => 1511 | Int -> 1512 | (b -> Maybe (a, b)) -> 1513 | b -> 1514 | m (Mutable arr (PrimState m) a) 1515 | unfoldrMutableN !maxSz f z0 = do 1516 | m <- new maxSz 1517 | let go !ix s = 1518 | if ix < maxSz 1519 | then case f s of 1520 | Nothing -> pure ix 1521 | Just (x, s') -> do 1522 | write m ix x 1523 | go (ix + 1) s' 1524 | else pure ix 1525 | sz <- go 0 z0 1526 | shrink m sz 1527 | {-# INLINE unfoldrMutableN #-} 1528 | 1529 | -- | Convert an array to a list. 1530 | toList :: 1531 | (Contiguous arr, Element arr a) => 1532 | arr a -> 1533 | [a] 1534 | toList arr = build (\c n -> foldr c n arr) 1535 | {-# INLINE toList #-} 1536 | 1537 | -- | Convert a mutable array to a list. 1538 | 1539 | -- I don't think this can be expressed in terms of foldr/build, 1540 | -- so we just loop through the array. 1541 | toListMutable :: 1542 | (Contiguous arr, Element arr a, PrimMonad m) => 1543 | Mutable arr (PrimState m) a -> 1544 | m [a] 1545 | toListMutable marr = do 1546 | sz <- sizeMut marr 1547 | let go !ix !acc = 1548 | if ix >= 0 1549 | then do 1550 | x <- read marr ix 1551 | go (ix - 1) (x : acc) 1552 | else pure acc 1553 | go (sz - 1) [] 1554 | {-# INLINE toListMutable #-} 1555 | 1556 | {- | Given an 'Int' that is representative of the length of 1557 | the list, convert the list into a mutable array of the 1558 | given length. 1559 | 1560 | /Note/: calls 'error' if the given length is incorrect. 1561 | -} 1562 | fromListMutableN :: 1563 | (Contiguous arr, Element arr a, PrimMonad m) => 1564 | Int -> 1565 | [a] -> 1566 | m (Mutable arr (PrimState m) a) 1567 | fromListMutableN len vs = do 1568 | marr <- new len 1569 | let go [] !ix = 1570 | if ix == len 1571 | then pure () 1572 | else error "Data.Primitive.Contiguous.fromListN: list length less than specified size." 1573 | go (a : as) !ix = 1574 | if ix < len 1575 | then do 1576 | write marr ix a 1577 | go as (ix + 1) 1578 | else error "Data.Primitive.Contiguous.fromListN: list length greater than specified size." 1579 | go vs 0 1580 | pure marr 1581 | {-# INLINE fromListMutableN #-} 1582 | 1583 | -- | Convert a list into a mutable array of the given length. 1584 | fromListMutable :: 1585 | (Contiguous arr, Element arr a, PrimMonad m) => 1586 | [a] -> 1587 | m (Mutable arr (PrimState m) a) 1588 | fromListMutable xs = fromListMutableN (length xs) xs 1589 | {-# INLINE fromListMutable #-} 1590 | 1591 | {- | Given an 'Int' that is representative of the length of 1592 | the list, convert the list into a mutable array of the 1593 | given length. 1594 | 1595 | /Note/: calls 'error' if the given length is incorrect. 1596 | -} 1597 | fromListN :: 1598 | (Contiguous arr, Element arr a) => 1599 | Int -> 1600 | [a] -> 1601 | arr a 1602 | fromListN len vs = create (fromListMutableN len vs) 1603 | {-# INLINE fromListN #-} 1604 | 1605 | -- | Convert a list into an array. 1606 | fromList :: 1607 | (Contiguous arr, Element arr a) => 1608 | [a] -> 1609 | arr a 1610 | fromList vs = create (fromListMutable vs) 1611 | {-# INLINE fromList #-} 1612 | 1613 | -- | Modify the elements of a mutable array in-place. 1614 | modify :: 1615 | (Contiguous arr, Element arr a, PrimMonad m) => 1616 | (a -> a) -> 1617 | Mutable arr (PrimState m) a -> 1618 | m () 1619 | modify f marr = do 1620 | !sz <- sizeMut marr 1621 | let go !ix = when (ix < sz) $ do 1622 | x <- read marr ix 1623 | write marr ix (f x) 1624 | go (ix + 1) 1625 | go 0 1626 | {-# INLINE modify #-} 1627 | 1628 | -- | Strictly modify the elements of a mutable array in-place. 1629 | modify' :: 1630 | (Contiguous arr, Element arr a, PrimMonad m) => 1631 | (a -> a) -> 1632 | Mutable arr (PrimState m) a -> 1633 | m () 1634 | modify' f marr = do 1635 | !sz <- sizeMut marr 1636 | let go !ix = when (ix < sz) $ do 1637 | x <- read marr ix 1638 | let !y = f x 1639 | write marr ix y 1640 | go (ix + 1) 1641 | go 0 1642 | {-# INLINE modify' #-} 1643 | 1644 | {- | Yield an array of the given length containing the values 1645 | @x, 'succ' x, 'succ' ('succ' x)@ etc. 1646 | -} 1647 | enumFromN :: 1648 | (Contiguous arr, Element arr a, Enum a) => 1649 | a -> 1650 | Int -> 1651 | arr a 1652 | enumFromN z0 sz = create (enumFromMutableN z0 sz) 1653 | {-# INLINE enumFromN #-} 1654 | 1655 | {- | Yield a mutable array of the given length containing the values 1656 | @x, 'succ' x, 'succ' ('succ' x)@ etc. 1657 | -} 1658 | enumFromMutableN :: 1659 | (Contiguous arr, Element arr a, PrimMonad m, Enum a) => 1660 | a -> 1661 | Int -> 1662 | m (Mutable arr (PrimState m) a) 1663 | enumFromMutableN z0 !sz = do 1664 | m <- new sz 1665 | let go !ix z = 1666 | if ix < sz 1667 | then do 1668 | write m ix z 1669 | go (ix + 1) (succ z) 1670 | else pure m 1671 | go 0 z0 1672 | {-# INLINE enumFromMutableN #-} 1673 | 1674 | {- | Lift an accumulating hash function over the elements of the array, 1675 | returning the final accumulated hash. 1676 | -} 1677 | liftHashWithSalt :: 1678 | (Contiguous arr, Element arr a) => 1679 | (Int -> a -> Int) -> 1680 | Int -> 1681 | arr a -> 1682 | Int 1683 | liftHashWithSalt f s0 arr = go 0 s0 1684 | where 1685 | sz = size arr 1686 | go !ix !s = 1687 | if ix < sz 1688 | then 1689 | let !(# x #) = index# arr ix 1690 | in go (ix + 1) (f s x) 1691 | else hashIntWithSalt s ix 1692 | {-# INLINE liftHashWithSalt #-} 1693 | 1694 | -- | Reverse the elements of an array. 1695 | reverse :: 1696 | (Contiguous arr, Element arr a) => 1697 | arr a -> 1698 | arr a 1699 | reverse arr = run $ do 1700 | marr <- new (size arr) 1701 | copy marr 0 (toSlice arr) 1702 | reverseMutable marr 1703 | unsafeFreeze marr 1704 | {-# INLINE reverse #-} 1705 | 1706 | -- | Reverse the elements of a mutable array, in-place. 1707 | reverseMutable :: 1708 | (Contiguous arr, Element arr a, PrimMonad m) => 1709 | Mutable arr (PrimState m) a -> 1710 | m () 1711 | reverseMutable marr = do 1712 | !sz <- sizeMut marr 1713 | reverseSlice marr 0 (sz - 1) 1714 | {-# INLINE reverseMutable #-} 1715 | 1716 | -- | Reverse the elements of a slice of a mutable array, in-place. 1717 | reverseSlice :: 1718 | (Contiguous arr, Element arr a, PrimMonad m) => 1719 | Mutable arr (PrimState m) a -> 1720 | -- | start index 1721 | Int -> 1722 | -- | end index 1723 | Int -> 1724 | m () 1725 | reverseSlice !marr !start !end = do 1726 | let go !s !e = 1727 | if s >= e 1728 | then pure () 1729 | else do 1730 | tmp <- read marr s 1731 | write marr s =<< read marr e 1732 | write marr e tmp 1733 | go (s + 1) (e - 1) 1734 | go start end 1735 | {-# INLINE reverseSlice #-} 1736 | 1737 | {- | This function does not behave deterministically. Optimization level and 1738 | inlining can affect its results. However, the one thing that can be counted 1739 | on is that if it returns 'True', the two immutable arrays are definitely the 1740 | same. This is useful as shortcut for equality tests. However, keep in mind 1741 | that a result of 'False' tells us nothing about the arguments. 1742 | -} 1743 | same :: (ContiguousU arr) => arr a -> arr a -> Bool 1744 | same a b = 1745 | isTrue# 1746 | ( sameMutableArrayArray# 1747 | (unsafeCoerce# (unlift a) :: MutableArrayArray# s) 1748 | (unsafeCoerce# (unlift b) :: MutableArrayArray# s) 1749 | ) 1750 | 1751 | hashIntWithSalt :: Int -> Int -> Int 1752 | hashIntWithSalt salt x = salt `combine` x 1753 | {-# INLINE hashIntWithSalt #-} 1754 | 1755 | combine :: Int -> Int -> Int 1756 | combine h1 h2 = (h1 * 16777619) `xor` h2 1757 | {-# INLINE combine #-} 1758 | 1759 | -- | Does the element occur in the structure? 1760 | elem :: (Contiguous arr, Element arr a, Eq a) => a -> arr a -> Bool 1761 | elem a !arr = 1762 | let !sz = size arr 1763 | go !ix 1764 | | ix < sz = case index# arr ix of 1765 | !(# x #) -> 1766 | if a == x 1767 | then True 1768 | else go (ix + 1) 1769 | | otherwise = False 1770 | in go 0 1771 | {-# INLINE elem #-} 1772 | 1773 | -- | The largest element of a structure. 1774 | maximum :: (Contiguous arr, Element arr a, Ord a) => arr a -> Maybe a 1775 | maximum = maximumBy compare 1776 | {-# INLINE maximum #-} 1777 | 1778 | -- | The least element of a structure. 1779 | minimum :: (Contiguous arr, Element arr a, Ord a) => arr a -> Maybe a 1780 | minimum = minimumBy compare 1781 | {-# INLINE minimum #-} 1782 | 1783 | {- | The largest element of a structure with respect to the 1784 | given comparison function. 1785 | -} 1786 | maximumBy :: 1787 | (Contiguous arr, Element arr a) => 1788 | (a -> a -> Ordering) -> 1789 | arr a -> 1790 | Maybe a 1791 | maximumBy f arr = 1792 | let !sz = size arr 1793 | go !ix o = 1794 | if ix < sz 1795 | then case index# arr ix of 1796 | !(# x #) -> go (ix + 1) (case f x o of GT -> x; _ -> o) 1797 | else o 1798 | in if sz == 0 1799 | then Nothing 1800 | else Just (go 0 (index arr 0)) 1801 | {-# INLINE maximumBy #-} 1802 | 1803 | {- | The least element of a structure with respect to the 1804 | given comparison function. 1805 | -} 1806 | minimumBy :: 1807 | (Contiguous arr, Element arr a) => 1808 | (a -> a -> Ordering) -> 1809 | arr a -> 1810 | Maybe a 1811 | minimumBy f arr = 1812 | let !sz = size arr 1813 | go !ix o = 1814 | if ix < sz 1815 | then case index# arr ix of 1816 | !(# x #) -> go (ix + 1) (case f x o of GT -> o; _ -> x) 1817 | else o 1818 | in if sz == 0 1819 | then Nothing 1820 | else Just (go 0 (index arr 0)) 1821 | {-# INLINE minimumBy #-} 1822 | 1823 | {- | 'find' takes a predicate and an array, and returns the leftmost 1824 | element of the array matching the prediate, or 'Nothing' if there 1825 | is no such element. 1826 | -} 1827 | find :: 1828 | (Contiguous arr, Element arr a) => 1829 | (a -> Bool) -> 1830 | arr a -> 1831 | Maybe a 1832 | find p = coerce . (foldMap (\x -> if p x then Just (First x) else Nothing)) 1833 | {-# INLINE find #-} 1834 | 1835 | {- | 'findIndex' takes a predicate and an array, and returns the index of 1836 | the leftmost element of the array matching the prediate, or 'Nothing' 1837 | if there is no such element. 1838 | -} 1839 | findIndex :: 1840 | (Contiguous arr, Element arr a) => 1841 | (a -> Bool) -> 1842 | arr a -> 1843 | Maybe Int 1844 | findIndex p xs = loop 0 1845 | where 1846 | loop i 1847 | | i < size xs = if p (index xs i) then Just i else loop (i + 1) 1848 | | otherwise = Nothing 1849 | {-# INLINE findIndex #-} 1850 | 1851 | -- | Swap the elements of the mutable array at the given indices. 1852 | swap :: 1853 | (Contiguous arr, Element arr a, PrimMonad m) => 1854 | Mutable arr (PrimState m) a -> 1855 | Int -> 1856 | Int -> 1857 | m () 1858 | swap !marr !ix1 !ix2 = do 1859 | atIx1 <- read marr ix1 1860 | atIx2 <- read marr ix2 1861 | write marr ix1 atIx2 1862 | write marr ix2 atIx1 1863 | {-# INLINE swap #-} 1864 | 1865 | {- | Extracts from an array of 'Either' all the 'Left' elements. 1866 | All the 'Left' elements are extracted in order. 1867 | -} 1868 | lefts :: 1869 | forall arr a b. 1870 | ( Contiguous arr 1871 | , Element arr a 1872 | , Element arr (Either a b) 1873 | ) => 1874 | arr (Either a b) -> 1875 | arr a 1876 | lefts !arr = create $ do 1877 | let !sz = size arr 1878 | go :: Int -> [a] -> Int -> ST s (Int, [a]) 1879 | go !ix !as !acc = 1880 | if ix < sz 1881 | then do 1882 | indexM arr ix >>= \case 1883 | Left a -> go (ix + 1) (a : as) (acc + 1) 1884 | Right _ -> go (ix + 1) as acc 1885 | else pure (acc, as) 1886 | (len, as) <- go 0 [] 0 1887 | unsafeFromListReverseMutableN len as 1888 | {-# INLINE lefts #-} 1889 | 1890 | {- | Extracts from an array of 'Either' all the 'Right' elements. 1891 | All the 'Right' elements are extracted in order. 1892 | -} 1893 | rights :: 1894 | forall arr a b. 1895 | ( Contiguous arr 1896 | , Element arr b 1897 | , Element arr (Either a b) 1898 | ) => 1899 | arr (Either a b) -> 1900 | arr b 1901 | rights !arr = create $ do 1902 | let !sz = size arr 1903 | go :: Int -> [b] -> Int -> ST s (Int, [b]) 1904 | go !ix !bs !acc = 1905 | if ix < sz 1906 | then do 1907 | indexM arr ix >>= \case 1908 | Left _ -> go (ix + 1) bs acc 1909 | Right b -> go (ix + 1) (b : bs) (acc + 1) 1910 | else pure (acc, bs) 1911 | (len, bs) <- go 0 [] 0 1912 | unsafeFromListReverseMutableN len bs 1913 | {-# INLINE rights #-} 1914 | 1915 | {- | Partitions an array of 'Either' into two arrays. 1916 | All the 'Left' elements are extracted, in order, to the first 1917 | component of the output. Similarly the 'Right' elements are extracted 1918 | to the second component of the output. 1919 | -} 1920 | partitionEithers :: 1921 | forall arr a b. 1922 | ( Contiguous arr 1923 | , Element arr a 1924 | , Element arr b 1925 | , Element arr (Either a b) 1926 | ) => 1927 | arr (Either a b) -> 1928 | (arr a, arr b) 1929 | partitionEithers !arr = runST $ do 1930 | let !sz = size arr 1931 | go :: Int -> [a] -> [b] -> Int -> Int -> ST s (Int, Int, [a], [b]) 1932 | go !ix !as !bs !accA !accB = 1933 | if ix < sz 1934 | then do 1935 | indexM arr ix >>= \case 1936 | Left a -> go (ix + 1) (a : as) bs (accA + 1) accB 1937 | Right b -> go (ix + 1) as (b : bs) accA (accB + 1) 1938 | else pure (accA, accB, as, bs) 1939 | (lenA, lenB, as, bs) <- go 0 [] [] 0 0 1940 | arrA <- unsafeFreeze =<< unsafeFromListReverseMutableN lenA as 1941 | arrB <- unsafeFreeze =<< unsafeFromListReverseMutableN lenB bs 1942 | pure (arrA, arrB) 1943 | {-# INLINE partitionEithers #-} 1944 | 1945 | {- | 'scanl' is similar to 'foldl', but returns an array of 1946 | successive reduced values from the left: 1947 | 1948 | > scanl f z [x1, x2, ...] = [z, f z x1, f (f z x1) x2, ...] 1949 | 1950 | Note that 1951 | 1952 | > last (toList (scanl f z xs)) == foldl f z xs. 1953 | -} 1954 | scanl :: 1955 | ( Contiguous arr1 1956 | , Contiguous arr2 1957 | , Element arr1 a 1958 | , Element arr2 b 1959 | ) => 1960 | (b -> a -> b) -> 1961 | b -> 1962 | arr1 a -> 1963 | arr2 b 1964 | scanl f = iscanl (const f) 1965 | {-# INLINE scanl #-} 1966 | 1967 | {- | A variant of 'scanl' whose function argument takes the current 1968 | index as an argument. 1969 | -} 1970 | iscanl :: 1971 | ( Contiguous arr1 1972 | , Contiguous arr2 1973 | , Element arr1 a 1974 | , Element arr2 b 1975 | ) => 1976 | (Int -> b -> a -> b) -> 1977 | b -> 1978 | arr1 a -> 1979 | arr2 b 1980 | iscanl f q as = internalScanl (size as + 1) f q as 1981 | {-# INLINE iscanl #-} 1982 | 1983 | -- | A strictly accumulating version of 'scanl'. 1984 | scanl' :: 1985 | ( Contiguous arr1 1986 | , Contiguous arr2 1987 | , Element arr1 a 1988 | , Element arr2 b 1989 | ) => 1990 | (b -> a -> b) -> 1991 | b -> 1992 | arr1 a -> 1993 | arr2 b 1994 | scanl' f = iscanl' (const f) 1995 | {-# INLINE scanl' #-} 1996 | 1997 | -- | A strictly accumulating version of 'iscanl'. 1998 | iscanl' :: 1999 | ( Contiguous arr1 2000 | , Contiguous arr2 2001 | , Element arr1 a 2002 | , Element arr2 b 2003 | ) => 2004 | (Int -> b -> a -> b) -> 2005 | b -> 2006 | arr1 a -> 2007 | arr2 b 2008 | iscanl' f !q as = internalScanl' (size as + 1) f q as 2009 | {-# INLINE iscanl' #-} 2010 | 2011 | -- Internal only. The first argument is the size of the array 2012 | -- argument. This function helps prevent duplication. 2013 | internalScanl :: 2014 | ( Contiguous arr1 2015 | , Contiguous arr2 2016 | , Element arr1 a 2017 | , Element arr2 b 2018 | ) => 2019 | Int -> 2020 | (Int -> b -> a -> b) -> 2021 | b -> 2022 | arr1 a -> 2023 | arr2 b 2024 | internalScanl !sz f !q as = create $ do 2025 | !marr <- new sz 2026 | let go !ix acc = when (ix < sz) $ do 2027 | write marr ix acc 2028 | x <- indexM as ix 2029 | go (ix + 1) (f ix acc x) 2030 | go 0 q 2031 | pure marr 2032 | {-# INLINE internalScanl #-} 2033 | 2034 | -- Internal only. The first argument is the size of the array 2035 | -- argument. This function helps prevent duplication. 2036 | internalScanl' :: 2037 | ( Contiguous arr1 2038 | , Contiguous arr2 2039 | , Element arr1 a 2040 | , Element arr2 b 2041 | ) => 2042 | Int -> 2043 | (Int -> b -> a -> b) -> 2044 | b -> 2045 | arr1 a -> 2046 | arr2 b 2047 | internalScanl' !sz f !q as = create $ do 2048 | !marr <- new sz 2049 | let go !ix !acc = when (ix < sz) $ do 2050 | write marr ix acc 2051 | x <- indexM as ix 2052 | go (ix + 1) (f ix acc x) 2053 | go 0 q 2054 | pure marr 2055 | {-# INLINE internalScanl' #-} 2056 | 2057 | {- | A prescan. 2058 | 2059 | @prescanl f z = init . scanl f z@ 2060 | 2061 | Example: @prescanl (+) 0 \<1,2,3,4\> = \<0,1,3,6\>@ 2062 | -} 2063 | prescanl :: 2064 | ( Contiguous arr1 2065 | , Contiguous arr2 2066 | , Element arr1 a 2067 | , Element arr2 b 2068 | ) => 2069 | (b -> a -> b) -> 2070 | b -> 2071 | arr1 a -> 2072 | arr2 b 2073 | prescanl f = iprescanl (const f) 2074 | {-# INLINE prescanl #-} 2075 | 2076 | {- | A variant of 'prescanl' where the function argument takes 2077 | the current index of the array as an additional argument. 2078 | -} 2079 | iprescanl :: 2080 | ( Contiguous arr1 2081 | , Contiguous arr2 2082 | , Element arr1 a 2083 | , Element arr2 b 2084 | ) => 2085 | (Int -> b -> a -> b) -> 2086 | b -> 2087 | arr1 a -> 2088 | arr2 b 2089 | iprescanl f q as = internalScanl (size as) f q as 2090 | {-# INLINE iprescanl #-} 2091 | 2092 | -- | Like 'prescanl', but with a strict accumulator. 2093 | prescanl' :: 2094 | ( Contiguous arr1 2095 | , Contiguous arr2 2096 | , Element arr1 a 2097 | , Element arr2 b 2098 | ) => 2099 | (b -> a -> b) -> 2100 | b -> 2101 | arr1 a -> 2102 | arr2 b 2103 | prescanl' f = iprescanl (const f) 2104 | {-# INLINE prescanl' #-} 2105 | 2106 | -- | Like 'iprescanl', but with a strict accumulator. 2107 | iprescanl' :: 2108 | ( Contiguous arr1 2109 | , Contiguous arr2 2110 | , Element arr1 a 2111 | , Element arr2 b 2112 | ) => 2113 | (Int -> b -> a -> b) -> 2114 | b -> 2115 | arr1 a -> 2116 | arr2 b 2117 | iprescanl' f !q as = internalScanl' (size as) f q as 2118 | {-# INLINE iprescanl' #-} 2119 | 2120 | {- | 'zipWith' generalises 'zip' by zipping with the function 2121 | given as the first argument, instead of a tupling function. 2122 | For example, 'zipWith' (+) is applied to two arrays to produce 2123 | an array of the corresponding sums. 2124 | -} 2125 | zipWith :: 2126 | ( Contiguous arr1 2127 | , Contiguous arr2 2128 | , Contiguous arr3 2129 | , Element arr1 a 2130 | , Element arr2 b 2131 | , Element arr3 c 2132 | ) => 2133 | (a -> b -> c) -> 2134 | arr1 a -> 2135 | arr2 b -> 2136 | arr3 c 2137 | zipWith f = izipWith (\_ a b -> f a b) 2138 | {-# INLINE zipWith #-} 2139 | 2140 | -- | Variant of 'zipWith' that provides the index of each pair of elements. 2141 | izipWith :: 2142 | ( Contiguous arr1 2143 | , Contiguous arr2 2144 | , Contiguous arr3 2145 | , Element arr1 a 2146 | , Element arr2 b 2147 | , Element arr3 c 2148 | ) => 2149 | (Int -> a -> b -> c) -> 2150 | arr1 a -> 2151 | arr2 b -> 2152 | arr3 c 2153 | izipWith f as bs = create $ do 2154 | let !sz = min (size as) (size bs) 2155 | !marr <- new sz 2156 | let go !ix = when (ix < sz) $ do 2157 | a <- indexM as ix 2158 | b <- indexM bs ix 2159 | let !g = f ix a b 2160 | write marr ix g 2161 | go (ix + 1) 2162 | go 0 2163 | pure marr 2164 | {-# INLINE izipWith #-} 2165 | 2166 | {- | Variant of 'zipWith' that accepts an accumulator, performing a lazy 2167 | right fold over both arrays. 2168 | -} 2169 | foldrZipWith :: 2170 | ( Contiguous arr1 2171 | , Contiguous arr2 2172 | , Element arr1 a 2173 | , Element arr2 b 2174 | ) => 2175 | (a -> b -> c -> c) -> 2176 | c -> 2177 | arr1 a -> 2178 | arr2 b -> 2179 | c 2180 | foldrZipWith f = ifoldrZipWith (\_ x y c -> f x y c) 2181 | {-# INLINE foldrZipWith #-} 2182 | 2183 | {- | Variant of 'zipWith' that accepts an accumulator, performing a strict 2184 | left monadic fold over both arrays. 2185 | -} 2186 | foldlZipWithM' :: 2187 | ( Contiguous arr1 2188 | , Contiguous arr2 2189 | , Element arr1 a 2190 | , Element arr2 b 2191 | , Monad m 2192 | ) => 2193 | (c -> a -> b -> m c) -> 2194 | c -> 2195 | arr1 a -> 2196 | arr2 b -> 2197 | m c 2198 | foldlZipWithM' f = ifoldlZipWithM' (\_ x y c -> f x y c) 2199 | {-# INLINE foldlZipWithM' #-} 2200 | 2201 | -- | Variant of 'foldrZipWith' that provides the index of each pair of elements. 2202 | ifoldrZipWith :: 2203 | ( Contiguous arr1 2204 | , Contiguous arr2 2205 | , Element arr1 a 2206 | , Element arr2 b 2207 | ) => 2208 | (Int -> a -> b -> c -> c) -> 2209 | c -> 2210 | arr1 a -> 2211 | arr2 b -> 2212 | c 2213 | ifoldrZipWith f z = \arr1 arr2 -> 2214 | let !sz = min (size arr1) (size arr2) 2215 | go !ix = 2216 | if sz > ix 2217 | then case index# arr1 ix of 2218 | (# x #) -> case index# arr2 ix of 2219 | (# y #) -> f ix x y (go (ix + 1)) 2220 | else z 2221 | in go 0 2222 | {-# INLINE ifoldrZipWith #-} 2223 | 2224 | foldlZipWith' :: 2225 | ( Contiguous arr1 2226 | , Contiguous arr2 2227 | , Element arr1 a 2228 | , Element arr2 b 2229 | ) => 2230 | (c -> a -> b -> c) -> 2231 | c -> 2232 | arr1 a -> 2233 | arr2 b -> 2234 | c 2235 | foldlZipWith' f = ifoldlZipWith' (\_ x y c -> f x y c) 2236 | {-# INLINE foldlZipWith' #-} 2237 | 2238 | ifoldlZipWith' :: 2239 | ( Contiguous arr1 2240 | , Contiguous arr2 2241 | , Element arr1 a 2242 | , Element arr2 b 2243 | ) => 2244 | (Int -> c -> a -> b -> c) -> 2245 | c -> 2246 | arr1 a -> 2247 | arr2 b -> 2248 | c 2249 | ifoldlZipWith' f !z !arr1 !arr2 = 2250 | let !sz = min (size arr1) (size arr2) 2251 | go !ix !acc = 2252 | if ix == sz 2253 | then acc 2254 | else case index# arr1 ix of 2255 | (# x #) -> case index# arr2 ix of 2256 | (# y #) -> go (ix + 1) (f ix acc x y) 2257 | in go 0 z 2258 | {-# INLINE ifoldlZipWith' #-} 2259 | 2260 | -- | Variant of 'foldlZipWithM\'' that provides the index of each pair of elements. 2261 | ifoldlZipWithM' :: 2262 | ( Contiguous arr1 2263 | , Contiguous arr2 2264 | , Element arr1 a 2265 | , Element arr2 b 2266 | , Monad m 2267 | ) => 2268 | (Int -> c -> a -> b -> m c) -> 2269 | c -> 2270 | arr1 a -> 2271 | arr2 b -> 2272 | m c 2273 | ifoldlZipWithM' f z = \arr1 arr2 -> 2274 | let !sz = min (size arr1) (size arr2) 2275 | go !ix !acc = 2276 | if sz > ix 2277 | then case index# arr1 ix of 2278 | (# x #) -> case index# arr2 ix of 2279 | (# y #) -> do 2280 | acc' <- f ix acc x y 2281 | go (ix + 1) acc' 2282 | else pure acc 2283 | in go 0 z 2284 | {-# INLINE ifoldlZipWithM' #-} 2285 | 2286 | {- | 'zip' takes two arrays and returns an array of 2287 | corresponding pairs. 2288 | 2289 | > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')] 2290 | 2291 | If one input array is shorter than the other, excess 2292 | elements of the longer array are discarded: 2293 | 2294 | > zip [1] ['a', 'b'] = [(1, 'a')] 2295 | > zip [1, 2] ['a'] = [(1, 'a')] 2296 | -} 2297 | zip :: 2298 | ( Contiguous arr1 2299 | , Contiguous arr2 2300 | , Contiguous arr3 2301 | , Element arr1 a 2302 | , Element arr2 b 2303 | , Element arr3 (a, b) 2304 | ) => 2305 | arr1 a -> 2306 | arr2 b -> 2307 | arr3 (a, b) 2308 | zip = zipWith (,) 2309 | {-# INLINE zip #-} 2310 | 2311 | {- | Replace all locations in the input with the same value. 2312 | 2313 | Equivalent to Data.Functor.'Data.Functor.<$'. 2314 | -} 2315 | (<$) :: 2316 | ( Contiguous arr1 2317 | , Contiguous arr2 2318 | , Element arr1 b 2319 | , Element arr2 a 2320 | ) => 2321 | a -> 2322 | arr1 b -> 2323 | arr2 a 2324 | a <$ barr = create (replicateMut (size barr) a) 2325 | {-# INLINE (<$) #-} 2326 | 2327 | {- | Sequential application. 2328 | 2329 | Equivalent to Control.Applicative.'Control.Applicative.<*>'. 2330 | -} 2331 | ap :: 2332 | ( Contiguous arr1 2333 | , Contiguous arr2 2334 | , Contiguous arr3 2335 | , Element arr1 (a -> b) 2336 | , Element arr2 a 2337 | , Element arr3 b 2338 | ) => 2339 | arr1 (a -> b) -> 2340 | arr2 a -> 2341 | arr3 b 2342 | ap fs xs = create $ do 2343 | marr <- new (szfs * szxs) 2344 | let go1 !ix = when (ix < szfs) $ do 2345 | f <- indexM fs ix 2346 | go2 (ix * szxs) f 0 2347 | go1 (ix + 1) 2348 | go2 !off f !j = when (j < szxs) $ do 2349 | x <- indexM xs j 2350 | write marr (off + j) (f x) 2351 | go2 off f (j + 1) 2352 | go1 0 2353 | pure marr 2354 | where 2355 | !szfs = size fs 2356 | !szxs = size xs 2357 | {-# INLINE ap #-} 2358 | 2359 | all :: (Contiguous arr, Element arr a) => (a -> Bool) -> arr a -> Bool 2360 | all f = foldr (\x acc -> f x && acc) True 2361 | {-# INLINE all #-} 2362 | 2363 | any :: (Contiguous arr, Element arr a) => (a -> Bool) -> arr a -> Bool 2364 | any f = foldr (\x acc -> f x || acc) False 2365 | {-# INLINE any #-} 2366 | --------------------------------------------------------------------------------