primitive-sort 0.1.2.0 → 0.1.2.1
raw patch · 6 files changed
+757/−645 lines, 6 filesdep −doctestdep ~basedep ~ghc-primsetup-changednew-uploader
Dependencies removed: doctest
Dependency ranges changed: base, ghc-prim
Files
- CHANGELOG.md +5/−0
- Setup.hs +0/−2
- primitive-sort.cabal +40/−47
- src/Data/Primitive/Sort.hs +470/−426
- test/Doctest.hs +0/−6
- test/Main.hs +242/−164
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for primitive-sort++## 0.1.2.1 -- 2024-02-01++* Updated package metadata.
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
primitive-sort.cabal view
@@ -1,81 +1,74 @@-cabal-version: 2.2-name: primitive-sort-version: 0.1.2.0-synopsis: Sort primitive arrays+cabal-version: 2.2+name: primitive-sort+version: 0.1.2.1+synopsis: Sort primitive arrays description: This library provides a stable sorting algorithm for primitive arrays.- . The algorithm currently uses mergesort on large chunks and switches- to insertion sort on small chunks. The are also novel improvements+ to insertion sort on small chunks. There are also novel improvements to increase the performance if the input array is already mostly sorted.-homepage: https://github.com/andrewthad/primitive-sort-license: BSD-3-Clause-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2018 Andrew Martin-category: software-build-type: Simple-extra-source-files: README.md +homepage: https://github.com/byteverse/primitive-sort+bug-reports: https://github.com/byteverse/primitive-sort/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: amartin@layer3com.com+copyright: 2018 Andrew Martin+category: software+build-type: Simple+extra-doc-files:+ CHANGELOG.md+ README.md+ library- hs-source-dirs: src- exposed-modules:- Data.Primitive.Sort+ hs-source-dirs: src+ exposed-modules: Data.Primitive.Sort build-depends:- , base >= 0.4.9 && < 5- , ghc-prim- , contiguous >= 0.6 && < 0.7- , primitive >= 0.6.4 && < 0.8- ghc-options: -O2 -Wall+ , base >=0.4.9 && <5+ , contiguous >=0.6 && <0.7+ , ghc-prim >=0.9.1 && <0.10+ , primitive >=0.6.4 && <0.10++ ghc-options: -O2 -Wall default-language: Haskell2010 test-suite test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs build-depends:- , HUnit- , QuickCheck , base , containers+ , HUnit , primitive , primitive-sort+ , QuickCheck , smallcheck , tasty , tasty-hunit , tasty-quickcheck , tasty-smallcheck- ghc-options: -threaded -rtsopts -O2 -with-rtsopts=-N1- default-language: Haskell2010 -test-suite doctest- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Doctest.hs- build-depends:- , QuickCheck- , base- , doctest >= 0.10- , primitive-sort+ ghc-options: -threaded -rtsopts -O2 -with-rtsopts=-N1 default-language: Haskell2010 benchmark bench- type: exitcode-stdio-1.0+ type: exitcode-stdio-1.0 build-depends: , base , contiguous- , gauge >=0.2.5+ , gauge >=0.2.5 , ghc-prim , primitive , primitive-sort , random- ghc-options: -threaded -rtsopts -O2 -with-rtsopts=-N1++ ghc-options: -threaded -rtsopts -O2 -with-rtsopts=-N1 default-language: Haskell2010- hs-source-dirs: bench- main-is: Main.hs+ hs-source-dirs: bench+ main-is: Main.hs source-repository head- type: git- location: https://github.com/andrewthad/primitive-sort-+ type: git+ location: git://github.com/byteverse/primitive-sort.git
src/Data/Primitive/Sort.hs view
@@ -1,20 +1,19 @@-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE UnboxedTuples #-} --- | Sort primitive arrays with a stable sorting algorithm. All functions--- in this module are marked as @INLINABLE@, so they will specialize--- when used in a monomorphic setting.+{- | Sort primitive arrays with a stable sorting algorithm. All functions+in this module are marked as @INLINABLE@, so they will specialize+when used in a monomorphic setting.+-} module Data.Primitive.Sort ( -- * Immutable sort , sortUnique , sortTagged , sortUniqueTagged+ -- * Mutable , sortMutable , sortUniqueMutable@@ -22,35 +21,33 @@ , sortUniqueTaggedMutable ) where -import Control.Monad.ST import Control.Applicative-import GHC.Int (Int(..))-import GHC.Prim-import Data.Word+import Control.Monad.ST import Data.Int-import Data.Primitive.Contiguous (Contiguous,ContiguousU,Mutable,Element)-import Data.Primitive (Prim,PrimArray,MutablePrimArray)+import Data.Primitive (MutablePrimArray, Prim, PrimArray)+import Data.Primitive.Contiguous (Contiguous, ContiguousU, Element, Mutable) import qualified Data.Primitive.Contiguous as C+import Data.Word+import GHC.Int (Int (..))+import GHC.Prim -- | Sort an immutable array. Duplicate elements are preserved.------ >>> sort ([5,6,7,9,5,4,5,7] :: Array Int)--- fromListN 8 [4,5,5,5,6,7,7,9]-sort :: (Prim a, Ord a)- => C.PrimArray a- -> C.PrimArray a-{-# inlineable sort #-}-{-# specialize sort :: C.PrimArray Double -> C.PrimArray Double #-}-{-# specialize sort :: C.PrimArray Int -> C.PrimArray Int #-}-{-# specialize sort :: C.PrimArray Int64 -> C.PrimArray Int64 #-}-{-# specialize sort :: C.PrimArray Int32 -> C.PrimArray Int32 #-}-{-# specialize sort :: C.PrimArray Int16 -> C.PrimArray Int16 #-}-{-# specialize sort :: C.PrimArray Int8 -> C.PrimArray Int8 #-}-{-# specialize sort :: C.PrimArray Word -> C.PrimArray Word #-}-{-# specialize sort :: C.PrimArray Word64 -> C.PrimArray Word64 #-}-{-# specialize sort :: C.PrimArray Word32 -> C.PrimArray Word32 #-}-{-# specialize sort :: C.PrimArray Word16 -> C.PrimArray Word16 #-}-{-# specialize sort :: C.PrimArray Word8 -> C.PrimArray Word8 #-}+sort ::+ (Prim a, Ord a) =>+ C.PrimArray a ->+ C.PrimArray a+{-# INLINEABLE sort #-}+{-# SPECIALIZE sort :: C.PrimArray Double -> C.PrimArray Double #-}+{-# SPECIALIZE sort :: C.PrimArray Int -> C.PrimArray Int #-}+{-# SPECIALIZE sort :: C.PrimArray Int64 -> C.PrimArray Int64 #-}+{-# SPECIALIZE sort :: C.PrimArray Int32 -> C.PrimArray Int32 #-}+{-# SPECIALIZE sort :: C.PrimArray Int16 -> C.PrimArray Int16 #-}+{-# SPECIALIZE sort :: C.PrimArray Int8 -> C.PrimArray Int8 #-}+{-# SPECIALIZE sort :: C.PrimArray Word -> C.PrimArray Word #-}+{-# SPECIALIZE sort :: C.PrimArray Word64 -> C.PrimArray Word64 #-}+{-# SPECIALIZE sort :: C.PrimArray Word32 -> C.PrimArray Word32 #-}+{-# SPECIALIZE sort :: C.PrimArray Word16 -> C.PrimArray Word16 #-}+{-# SPECIALIZE sort :: C.PrimArray Word8 -> C.PrimArray Word8 #-} sort !src = runST $ do let len = C.size src dst <- C.new (C.size src)@@ -58,78 +55,84 @@ res <- sortMutable dst C.unsafeFreeze res --- | Sort a tagged immutable array. Each element from the @keys@ array is--- paired up with an element from the @values@ array at the matching--- index. The sort permutes the @values@ array so that a value end up--- in the same position as its corresponding key. The two argument array--- should be of the same length, but if one is shorter than the other,--- the longer one will be truncated so that the lengths match.------ >>> sortTagged ([5,6,7,5,5,7] :: Array Int) ([1,2,3,4,5,6] :: Array Int)--- (fromListN 6 [5,5,5,6,7,7],fromListN 6 [1,4,5,2,3,6])------ Since the sort is stable, the values corresponding to a key that--- appears multiple times have their original order preserved.-sortTagged :: forall k v karr varr. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => karr k -- ^ keys- -> varr v -- ^ values- -> (karr k,varr v)-{-# inlineable sortTagged #-}+{- | Sort a tagged immutable array. Each element from the @keys@ array is+paired up with an element from the @values@ array at the matching+index. The sort permutes the @values@ array so that a value end up+in the same position as its corresponding key. The two argument array+should be of the same length, but if one is shorter than the other,+the longer one will be truncated so that the lengths match.++Since the sort is stable, the values corresponding to a key that+appears multiple times have their original order preserved.+-}+sortTagged ::+ forall k v karr varr.+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ -- | keys+ karr k ->+ -- | values+ varr v ->+ (karr k, varr v)+{-# INLINEABLE sortTagged #-} sortTagged !src !srcTags = runST $ do let len = min (C.size src) (C.size srcTags) dst <- C.new len C.copy dst 0 (C.slice src 0 len) dstTags <- C.new len C.copy dstTags 0 (C.slice srcTags 0 len)- (res,resTags) <- sortTaggedMutableN len dst dstTags+ (res, resTags) <- sortTaggedMutableN len dst dstTags res' <- C.unsafeFreeze res resTags' <- C.unsafeFreeze resTags- return (res',resTags')+ return (res', resTags') --- | Sort a tagged immutable array. Only a single copy of each--- duplicate key is preserved, along with the last value from @values@--- that corresponded to it. The two argument arrays--- should be of the same length, but if one is shorter than the other,--- the longer one will be truncated so that the lengths match.------ >>> sortUniqueTagged ([5,6,7,5,5,7] :: Array Int) ([1,2,3,4,5,6] :: Array Int)--- (fromListN 3 [5,6,7],fromListN 3 [5,2,6])-sortUniqueTagged :: forall k v karr varr. (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v)- => karr k -- ^ keys- -> varr v -- ^ values- -> (karr k,varr v)-{-# inlineable sortUniqueTagged #-}+{- | Sort a tagged immutable array. Only a single copy of each+duplicate key is preserved, along with the last value from @values@+that corresponded to it. The two argument arrays+should be of the same length, but if one is shorter than the other,+the longer one will be truncated so that the lengths match.+-}+sortUniqueTagged ::+ forall k v karr varr.+ (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) =>+ -- | keys+ karr k ->+ -- | values+ varr v ->+ (karr k, varr v)+{-# INLINEABLE sortUniqueTagged #-} sortUniqueTagged !src !srcTags = runST $ do let len = min (C.size src) (C.size srcTags) dst <- C.new len C.copy dst 0 (C.slice src 0 len) dstTags <- C.new len C.copy dstTags 0 (C.slice srcTags 0 len)- (res0,resTags0) <- sortTaggedMutableN len dst dstTags- (res1,resTags1) <- uniqueTaggedMutableN len res0 resTags0+ (res0, resTags0) <- sortTaggedMutableN len dst dstTags+ (res1, resTags1) <- uniqueTaggedMutableN len res0 resTags0 res' <- C.unsafeFreeze res1 resTags' <- C.unsafeFreeze resTags1- return (res',resTags')+ return (res', resTags') --- | Sort the mutable array. This operation preserves duplicate--- elements. The argument may either be modified in-place, or another--- array may be allocated and returned. The argument--- may not be reused after being passed to this function.-sortMutable :: (Prim a, Ord a)- => MutablePrimArray s a- -> ST s (MutablePrimArray s a)-{-# inlineable sortMutable #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Double -> ST s (C.MutablePrimArray s Double) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Int -> ST s (C.MutablePrimArray s Int) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Int64 -> ST s (C.MutablePrimArray s Int64) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Int32 -> ST s (C.MutablePrimArray s Int32) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Int16 -> ST s (C.MutablePrimArray s Int16) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Int8 -> ST s (C.MutablePrimArray s Int8) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Word -> ST s (C.MutablePrimArray s Word) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Word64 -> ST s (C.MutablePrimArray s Word64) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Word32 -> ST s (C.MutablePrimArray s Word32) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Word16 -> ST s (C.MutablePrimArray s Word16) #-}-{-# specialize sortMutable :: forall s. C.MutablePrimArray s Word8 -> ST s (C.MutablePrimArray s Word8) #-}+{- | Sort the mutable array. This operation preserves duplicate+elements. The argument may either be modified in-place, or another+array may be allocated and returned. The argument+may not be reused after being passed to this function.+-}+sortMutable ::+ (Prim a, Ord a) =>+ MutablePrimArray s a ->+ ST s (MutablePrimArray s a)+{-# INLINEABLE sortMutable #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Double -> ST s (C.MutablePrimArray s Double) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Int -> ST s (C.MutablePrimArray s Int) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Int64 -> ST s (C.MutablePrimArray s Int64) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Int32 -> ST s (C.MutablePrimArray s Int32) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Int16 -> ST s (C.MutablePrimArray s Int16) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Int8 -> ST s (C.MutablePrimArray s Int8) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Word -> ST s (C.MutablePrimArray s Word) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Word64 -> ST s (C.MutablePrimArray s Word64) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Word32 -> ST s (C.MutablePrimArray s Word32) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Word16 -> ST s (C.MutablePrimArray s Word16) #-}+{-# SPECIALIZE sortMutable :: forall s. C.MutablePrimArray s Word8 -> ST s (C.MutablePrimArray s Word8) #-} sortMutable !dst = do len <- C.sizeMut dst if len < threshold@@ -140,82 +143,89 @@ splitMerge dst work 0 len return dst --- | Sort an array of a key type @k@, rearranging the values of--- type @v@ according to the element they correspond to in the--- key array. The argument arrays may not be reused after they--- are passed to the function.-sortTaggedMutable :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v)- => Mutable karr s k- -> Mutable varr s v- -> ST s (Mutable karr s k, Mutable varr s v)-{-# inlineable sortTaggedMutable #-}+{- | Sort an array of a key type @k@, rearranging the values of+type @v@ according to the element they correspond to in the+key array. The argument arrays may not be reused after they+are passed to the function.+-}+sortTaggedMutable ::+ (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) =>+ Mutable karr s k ->+ Mutable varr s v ->+ ST s (Mutable karr s k, Mutable varr s v)+{-# INLINEABLE sortTaggedMutable #-} sortTaggedMutable !dst0 !dstTags0 = do- (!dst,!dstTags,!len) <- alignArrays dst0 dstTags0+ (!dst, !dstTags, !len) <- alignArrays dst0 dstTags0 sortTaggedMutableN len dst dstTags -alignArrays :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v)- => Mutable karr s k- -> Mutable varr s v- -> ST s (Mutable karr s k, Mutable varr s v,Int)-{-# inlineable alignArrays #-}+alignArrays ::+ (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) =>+ Mutable karr s k ->+ Mutable varr s v ->+ ST s (Mutable karr s k, Mutable varr s v, Int)+{-# INLINEABLE alignArrays #-} alignArrays dst0 dstTags0 = do lenDst <- C.sizeMut dst0 lenDstTags <- C.sizeMut dstTags0 -- This cleans up mismatched lengths. if lenDst == lenDstTags- then return (dst0,dstTags0,lenDst)- else if lenDst < lenDstTags- then do- dstTags <- C.resize dstTags0 lenDst- return (dst0,dstTags,lenDst)- else do- dst <- C.resize dst0 lenDstTags- return (dst,dstTags0,lenDstTags)+ then return (dst0, dstTags0, lenDst)+ else+ if lenDst < lenDstTags+ then do+ dstTags <- C.resize dstTags0 lenDst+ return (dst0, dstTags, lenDst)+ else do+ dst <- C.resize dst0 lenDstTags+ return (dst, dstTags0, lenDstTags) -sortUniqueTaggedMutable :: (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v)- => Mutable karr s k -- ^ keys- -> Mutable varr s v -- ^ values- -> ST s (Mutable karr s k, Mutable varr s v)-{-# inlineable sortUniqueTaggedMutable #-}+sortUniqueTaggedMutable ::+ (ContiguousU karr, Element karr k, Ord k, ContiguousU varr, Element varr v) =>+ -- | keys+ Mutable karr s k ->+ -- | values+ Mutable varr s v ->+ ST s (Mutable karr s k, Mutable varr s v)+{-# INLINEABLE sortUniqueTaggedMutable #-} sortUniqueTaggedMutable dst0 dstTags0 = do- (!dst1,!dstTags1,!len) <- alignArrays dst0 dstTags0- (!dst2,!dstTags2) <- sortTaggedMutableN len dst1 dstTags1+ (!dst1, !dstTags1, !len) <- alignArrays dst0 dstTags0+ (!dst2, !dstTags2) <- sortTaggedMutableN len dst1 dstTags1 uniqueTaggedMutableN len dst2 dstTags2 -sortTaggedMutableN :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => Int- -> Mutable karr s k- -> Mutable varr s v- -> ST s (Mutable karr s k, Mutable varr s v)-{-# inlineable sortTaggedMutableN #-}-sortTaggedMutableN !len !dst !dstTags = if len < thresholdTagged- then do- insertionSortTaggedRange dst dstTags 0 len- return (dst,dstTags)- else do- work <- C.cloneMut (C.sliceMut dst 0 len)- workTags <- C.cloneMut (C.sliceMut dstTags 0 len)- splitMergeTagged dst work dstTags workTags 0 len- return (dst,dstTags)+sortTaggedMutableN ::+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ Int ->+ Mutable karr s k ->+ Mutable varr s v ->+ ST s (Mutable karr s k, Mutable varr s v)+{-# INLINEABLE sortTaggedMutableN #-}+sortTaggedMutableN !len !dst !dstTags =+ if len < thresholdTagged+ then do+ insertionSortTaggedRange dst dstTags 0 len+ return (dst, dstTags)+ else do+ work <- C.cloneMut (C.sliceMut dst 0 len)+ workTags <- C.cloneMut (C.sliceMut dstTags 0 len)+ splitMergeTagged dst work dstTags workTags 0 len+ return (dst, dstTags) --- | Sort an immutable array. Only a single copy of each duplicated--- element is preserved.------ >>> sortUnique ([5,6,7,9,5,4,5,7] :: Array Int)--- fromListN 5 [4,5,6,7,9]+{- | Sort an immutable array. Only a single copy of each duplicated+element is preserved.+-} sortUnique :: (Prim a, Ord a) => PrimArray a -> PrimArray a-{-# inlineable sortUnique #-}-{-# specialize sortUnique :: C.PrimArray Double -> C.PrimArray Double #-}-{-# specialize sortUnique :: C.PrimArray Int -> C.PrimArray Int #-}-{-# specialize sortUnique :: C.PrimArray Int64 -> C.PrimArray Int64 #-}-{-# specialize sortUnique :: C.PrimArray Int32 -> C.PrimArray Int32 #-}-{-# specialize sortUnique :: C.PrimArray Int16 -> C.PrimArray Int16 #-}-{-# specialize sortUnique :: C.PrimArray Int8 -> C.PrimArray Int8 #-}-{-# specialize sortUnique :: C.PrimArray Word -> C.PrimArray Word #-}-{-# specialize sortUnique :: C.PrimArray Word64 -> C.PrimArray Word64 #-}-{-# specialize sortUnique :: C.PrimArray Word32 -> C.PrimArray Word32 #-}-{-# specialize sortUnique :: C.PrimArray Word16 -> C.PrimArray Word16 #-}-{-# specialize sortUnique :: C.PrimArray Word8 -> C.PrimArray Word8 #-}+{-# INLINEABLE sortUnique #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Double -> C.PrimArray Double #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Int -> C.PrimArray Int #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Int64 -> C.PrimArray Int64 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Int32 -> C.PrimArray Int32 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Int16 -> C.PrimArray Int16 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Int8 -> C.PrimArray Int8 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Word -> C.PrimArray Word #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Word64 -> C.PrimArray Word64 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Word32 -> C.PrimArray Word32 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Word16 -> C.PrimArray Word16 #-}+{-# SPECIALIZE sortUnique :: C.PrimArray Word8 -> C.PrimArray Word8 #-} sortUnique src = runST $ do let len = C.size src dst <- C.new len@@ -223,189 +233,213 @@ res <- sortUniqueMutable dst C.unsafeFreeze res --- | Sort an immutable array. Only a single copy of each duplicated--- element is preserved. This operation may run in-place, or it may--- need to allocate a new array, so the argument may not be reused--- after this function is applied to it. -sortUniqueMutable :: forall s a. (Prim a, Ord a)- => MutablePrimArray s a- -> ST s (MutablePrimArray s a)-{-# inlineable sortUniqueMutable #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Double -> ST s (C.MutablePrimArray s Double) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Int -> ST s (C.MutablePrimArray s Int) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Int64 -> ST s (C.MutablePrimArray s Int64) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Int32 -> ST s (C.MutablePrimArray s Int32) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Int16 -> ST s (C.MutablePrimArray s Int16) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Int8 -> ST s (C.MutablePrimArray s Int8) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Word -> ST s (C.MutablePrimArray s Word) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Word64 -> ST s (C.MutablePrimArray s Word64) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Word32 -> ST s (C.MutablePrimArray s Word32) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Word16 -> ST s (C.MutablePrimArray s Word16) #-}-{-# specialize sortUniqueMutable :: forall s. C.MutablePrimArray s Word8 -> ST s (C.MutablePrimArray s Word8) #-}+{- | Sort an immutable array. Only a single copy of each duplicated+element is preserved. This operation may run in-place, or it may+need to allocate a new array, so the argument may not be reused+after this function is applied to it.+-}+sortUniqueMutable ::+ forall s a.+ (Prim a, Ord a) =>+ MutablePrimArray s a ->+ ST s (MutablePrimArray s a)+{-# INLINEABLE sortUniqueMutable #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Double -> ST s (C.MutablePrimArray s Double) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Int -> ST s (C.MutablePrimArray s Int) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Int64 -> ST s (C.MutablePrimArray s Int64) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Int32 -> ST s (C.MutablePrimArray s Int32) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Int16 -> ST s (C.MutablePrimArray s Int16) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Int8 -> ST s (C.MutablePrimArray s Int8) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Word -> ST s (C.MutablePrimArray s Word) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Word64 -> ST s (C.MutablePrimArray s Word64) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Word32 -> ST s (C.MutablePrimArray s Word32) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Word16 -> ST s (C.MutablePrimArray s Word16) #-}+{-# SPECIALIZE sortUniqueMutable :: forall s. C.MutablePrimArray s Word8 -> ST s (C.MutablePrimArray s Word8) #-} sortUniqueMutable marr = do res <- sortMutable marr uniqueMutable res --- | Discards adjacent equal elements from an array. This operation--- may run in-place, or it may need to allocate a new array, so the--- argument may not be reused after this function is applied to it.-uniqueMutable :: forall arr s a. (ContiguousU arr, Element arr a, Eq a)- => Mutable arr s a -> ST s (Mutable arr s a)-{-# inlineable uniqueMutable #-}+{- | Discards adjacent equal elements from an array. This operation+may run in-place, or it may need to allocate a new array, so the+argument may not be reused after this function is applied to it.+-}+uniqueMutable ::+ forall arr s a.+ (ContiguousU arr, Element arr a, Eq a) =>+ Mutable arr s a ->+ ST s (Mutable arr s a)+{-# INLINEABLE uniqueMutable #-} uniqueMutable !marr = do !len <- C.sizeMut marr if len > 1 then do !a0 <- C.read marr 0 let findFirstDuplicate :: a -> Int -> ST s Int- findFirstDuplicate !prev !ix = if ix < len- then do- a <- C.read marr ix- if a == prev- then return ix- else findFirstDuplicate a (ix + 1)- else return ix+ findFirstDuplicate !prev !ix =+ if ix < len+ then do+ a <- C.read marr ix+ if a == prev+ then return ix+ else findFirstDuplicate a (ix + 1)+ else return ix dupIx <- findFirstDuplicate a0 1 if dupIx == len then return marr else do let deduplicate :: a -> Int -> Int -> ST s Int- deduplicate !prev !srcIx !dstIx = if srcIx < len- then do- a <- C.read marr srcIx- if a == prev- then deduplicate a (srcIx + 1) dstIx- else do- C.write marr dstIx a- deduplicate a (srcIx + 1) (dstIx + 1)- else return dstIx+ deduplicate !prev !srcIx !dstIx =+ if srcIx < len+ then do+ a <- C.read marr srcIx+ if a == prev+ then deduplicate a (srcIx + 1) dstIx+ else do+ C.write marr dstIx a+ deduplicate a (srcIx + 1) (dstIx + 1)+ else return dstIx !a <- C.read marr dupIx !reducedLen <- deduplicate a (dupIx + 1) dupIx C.resize marr reducedLen else return marr -uniqueTaggedMutableN :: forall karr varr s k v. (ContiguousU karr, Element karr k, Eq k, ContiguousU varr, Element varr v)- => Int- -> Mutable karr s k- -> Mutable varr s v- -> ST s (Mutable karr s k, Mutable varr s v)-{-# inlineable uniqueTaggedMutableN #-}-uniqueTaggedMutableN !len !marr !marrTags = if len > 1- then do- !a0 <- C.read marr 0- let findFirstDuplicate :: k -> Int -> ST s Int- findFirstDuplicate !prev !ix = if ix < len- then do- a <- C.read marr ix- if a == prev- then return ix- else findFirstDuplicate a (ix + 1)- else return ix- dupIx <- findFirstDuplicate a0 1- if dupIx == len- then return (marr,marrTags)- else do- C.read marrTags dupIx >>= C.write marrTags (dupIx - 1)- let deduplicate :: k -> Int -> Int -> ST s Int- deduplicate !prev !srcIx !dstIx = if srcIx < len+uniqueTaggedMutableN ::+ forall karr varr s k v.+ (ContiguousU karr, Element karr k, Eq k, ContiguousU varr, Element varr v) =>+ Int ->+ Mutable karr s k ->+ Mutable varr s v ->+ ST s (Mutable karr s k, Mutable varr s v)+{-# INLINEABLE uniqueTaggedMutableN #-}+uniqueTaggedMutableN !len !marr !marrTags =+ if len > 1+ then do+ !a0 <- C.read marr 0+ let findFirstDuplicate :: k -> Int -> ST s Int+ findFirstDuplicate !prev !ix =+ if ix < len then do- a <- C.read marr srcIx+ a <- C.read marr ix if a == prev+ then return ix+ else findFirstDuplicate a (ix + 1)+ else return ix+ dupIx <- findFirstDuplicate a0 1+ if dupIx == len+ then return (marr, marrTags)+ else do+ C.read marrTags dupIx >>= C.write marrTags (dupIx - 1)+ let deduplicate :: k -> Int -> Int -> ST s Int+ deduplicate !prev !srcIx !dstIx =+ if srcIx < len then do- C.read marrTags srcIx >>= C.write marrTags (dstIx - 1)- deduplicate a (srcIx + 1) dstIx- else do- C.read marrTags srcIx >>= C.write marrTags dstIx- C.write marr dstIx a- deduplicate a (srcIx + 1) (dstIx + 1)- else return dstIx- !a <- C.read marr dupIx- !reducedLen <- deduplicate a (dupIx + 1) dupIx- liftA2 (,) (C.resize marr reducedLen) (C.resize marrTags reducedLen)- else return (marr,marrTags)+ a <- C.read marr srcIx+ if a == prev+ then do+ C.read marrTags srcIx >>= C.write marrTags (dstIx - 1)+ deduplicate a (srcIx + 1) dstIx+ else do+ C.read marrTags srcIx >>= C.write marrTags dstIx+ C.write marr dstIx a+ deduplicate a (srcIx + 1) (dstIx + 1)+ else return dstIx+ !a <- C.read marr dupIx+ !reducedLen <- deduplicate a (dupIx + 1) dupIx+ liftA2 (,) (C.resize marr reducedLen) (C.resize marrTags reducedLen)+ else return (marr, marrTags) -splitMerge :: forall s a. (Prim a, Ord a)- => MutablePrimArray s a -- source and destination- -> MutablePrimArray s a -- work array- -> Int -- start- -> Int -- end- -> ST s ()-{-# inlineable splitMerge #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Double -> C.MutablePrimArray s Double -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Int -> C.MutablePrimArray s Int -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Int64 -> C.MutablePrimArray s Int64 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Int32 -> C.MutablePrimArray s Int32 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Int16 -> C.MutablePrimArray s Int16 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Int8 -> C.MutablePrimArray s Int8 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Word -> C.MutablePrimArray s Word -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Word64 -> C.MutablePrimArray s Word64 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Word32 -> C.MutablePrimArray s Word32 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Word16 -> C.MutablePrimArray s Word16 -> Int -> Int -> ST s () #-}-{-# specialize splitMerge :: forall s. C.MutablePrimArray s Word8 -> C.MutablePrimArray s Word8 -> Int -> Int -> ST s () #-}-splitMerge !arr !work !start !end = if end - start < 2- then return ()- else if end - start > threshold- then do- let !mid = unsafeQuot (end + start) 2- splitMerge work arr start mid- splitMerge work arr mid end- mergeNonContiguous work arr start mid mid end start- else insertionSortRange arr start end+splitMerge ::+ forall s a.+ (Prim a, Ord a) =>+ MutablePrimArray s a -> -- source and destination+ MutablePrimArray s a -> -- work array+ Int -> -- start+ Int -> -- end+ ST s ()+{-# INLINEABLE splitMerge #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Double -> C.MutablePrimArray s Double -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Int -> C.MutablePrimArray s Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Int64 -> C.MutablePrimArray s Int64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Int32 -> C.MutablePrimArray s Int32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Int16 -> C.MutablePrimArray s Int16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Int8 -> C.MutablePrimArray s Int8 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Word -> C.MutablePrimArray s Word -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Word64 -> C.MutablePrimArray s Word64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Word32 -> C.MutablePrimArray s Word32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Word16 -> C.MutablePrimArray s Word16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE splitMerge :: forall s. C.MutablePrimArray s Word8 -> C.MutablePrimArray s Word8 -> Int -> Int -> ST s () #-}+splitMerge !arr !work !start !end =+ if end - start < 2+ then return ()+ else+ if end - start > threshold+ then do+ let !mid = unsafeQuot (end + start) 2+ splitMerge work arr start mid+ splitMerge work arr mid end+ mergeNonContiguous work arr start mid mid end start+ else insertionSortRange arr start end -splitMergeTagged :: (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => Mutable karr s k -- source and destination- -> Mutable karr s k -- work array- -> Mutable varr s v- -> Mutable varr s v- -> Int -- start- -> Int -- end- -> ST s ()-{-# inlineable splitMergeTagged #-}-splitMergeTagged !arr !work !arrTags !workTags !start !end = if end - start < 2- then return ()- else if end - start > thresholdTagged- then do- let !mid = unsafeQuot (end + start) 2- splitMergeTagged work arr workTags arrTags start mid- splitMergeTagged work arr workTags arrTags mid end- mergeNonContiguousTagged work arr workTags arrTags start mid mid end start- else insertionSortTaggedRange arr arrTags start end+splitMergeTagged ::+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ Mutable karr s k -> -- source and destination+ Mutable karr s k -> -- work array+ Mutable varr s v ->+ Mutable varr s v ->+ Int -> -- start+ Int -> -- end+ ST s ()+{-# INLINEABLE splitMergeTagged #-}+splitMergeTagged !arr !work !arrTags !workTags !start !end =+ if end - start < 2+ then return ()+ else+ if end - start > thresholdTagged+ then do+ let !mid = unsafeQuot (end + start) 2+ splitMergeTagged work arr workTags arrTags start mid+ splitMergeTagged work arr workTags arrTags mid end+ mergeNonContiguousTagged work arr workTags arrTags start mid mid end start+ else insertionSortTaggedRange arr arrTags start end unsafeQuot :: Int -> Int -> Int unsafeQuot (I# a) (I# b) = I# (quotInt# a b)-{-# inline unsafeQuot #-}+{-# INLINE unsafeQuot #-} -- stepA assumes that we previously incremented ixA. -- Consequently, we do not need to check that ixB -- is still in bounds. As a precondition, both -- indices are guarenteed to start in bounds.-mergeNonContiguous :: forall arr s a. (Contiguous arr, Element arr a, Ord a)- => Mutable arr s a -- source- -> Mutable arr s a -- dest- -> Int -- start A- -> Int -- end A- -> Int -- start B- -> Int -- end B- -> Int -- start destination- -> ST s ()-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Double -> C.MutablePrimArray s Double -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Int -> C.MutablePrimArray s Int -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Int64 -> C.MutablePrimArray s Int64 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Int32 -> C.MutablePrimArray s Int32 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Int16 -> C.MutablePrimArray s Int16 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Int8 -> C.MutablePrimArray s Int8 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Word -> C.MutablePrimArray s Word -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Word64 -> C.MutablePrimArray s Word64 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Word32 -> C.MutablePrimArray s Word32 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Word16 -> C.MutablePrimArray s Word16 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize mergeNonContiguous :: forall s. C.MutablePrimArray s Word8 -> C.MutablePrimArray s Word8 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+mergeNonContiguous ::+ forall arr s a.+ (Contiguous arr, Element arr a, Ord a) =>+ Mutable arr s a -> -- source+ Mutable arr s a -> -- dest+ Int -> -- start A+ Int -> -- end A+ Int -> -- start B+ Int -> -- end B+ Int -> -- start destination+ ST s ()+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Double -> C.MutablePrimArray s Double -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Int -> C.MutablePrimArray s Int -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Int64 -> C.MutablePrimArray s Int64 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Int32 -> C.MutablePrimArray s Int32 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Int16 -> C.MutablePrimArray s Int16 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Int8 -> C.MutablePrimArray s Int8 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Word -> C.MutablePrimArray s Word -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Word64 -> C.MutablePrimArray s Word64 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Word32 -> C.MutablePrimArray s Word32 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Word16 -> C.MutablePrimArray s Word16 -> Int -> Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE mergeNonContiguous :: forall s. C.MutablePrimArray s Word8 -> C.MutablePrimArray s Word8 -> Int -> Int -> Int -> Int -> Int -> ST s () #-} mergeNonContiguous !src !dst !startA !endA !startB !endB !startDst = if startB < endB then stepA startA startB startDst- else if startA < endA- then stepB startA startB startDst- else return ()- where+ else+ if startA < endA+ then stepB startA startB startDst+ else return ()+ where continue :: Int -> Int -> Int -> ST s () continue !ixA !ixB !ixDst = do !a <- C.read src ixA@@ -418,37 +452,42 @@ C.write dst ixDst b stepB ixA (ixB + 1) (ixDst + 1) stepB :: Int -> Int -> Int -> ST s ()- stepB !ixA !ixB !ixDst = if ixB < endB- then continue ixA ixB ixDst- else finishA ixA ixDst+ stepB !ixA !ixB !ixDst =+ if ixB < endB+ then continue ixA ixB ixDst+ else finishA ixA ixDst stepA :: Int -> Int -> Int -> ST s ()- stepA !ixA !ixB !ixDst = if ixA < endA- then continue ixA ixB ixDst- else finishB ixB ixDst+ stepA !ixA !ixB !ixDst =+ if ixA < endA+ then continue ixA ixB ixDst+ else finishB ixB ixDst finishB :: Int -> Int -> ST s () finishB !ixB !ixDst = C.copyMut dst ixDst (C.sliceMut src ixB (endB - ixB)) finishA :: Int -> Int -> ST s () finishA !ixA !ixDst = C.copyMut dst ixDst (C.sliceMut src ixA (endA - ixA)) -mergeNonContiguousTagged :: forall karr varr k v s. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => Mutable karr s k -- source- -> Mutable karr s k -- dest- -> Mutable varr s v -- source tags- -> Mutable varr s v -- dest tags- -> Int -- start A- -> Int -- end A- -> Int -- start B- -> Int -- end B- -> Int -- start destination- -> ST s ()-{-# inlineable mergeNonContiguousTagged #-}+mergeNonContiguousTagged ::+ forall karr varr k v s.+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ Mutable karr s k -> -- source+ Mutable karr s k -> -- dest+ Mutable varr s v -> -- source tags+ Mutable varr s v -> -- dest tags+ Int -> -- start A+ Int -> -- end A+ Int -> -- start B+ Int -> -- end B+ Int -> -- start destination+ ST s ()+{-# INLINEABLE mergeNonContiguousTagged #-} mergeNonContiguousTagged !src !dst !srcTags !dstTags !startA !endA !startB !endB !startDst = if startB < endB then stepA startA startB startDst- else if startA < endA- then stepB startA startB startDst- else return ()- where+ else+ if startA < endA+ then stepB startA startB startDst+ else return ()+ where continue :: Int -> Int -> Int -> ST s () continue ixA ixB ixDst = do !a <- C.read src ixA@@ -463,13 +502,15 @@ (C.read srcTags ixB :: ST s v) >>= C.write dstTags ixDst stepB ixA (ixB + 1) (ixDst + 1) stepB :: Int -> Int -> Int -> ST s ()- stepB !ixA !ixB !ixDst = if ixB < endB- then continue ixA ixB ixDst- else finishA ixA ixDst+ stepB !ixA !ixB !ixDst =+ if ixB < endB+ then continue ixA ixB ixDst+ else finishA ixA ixDst stepA :: Int -> Int -> Int -> ST s ()- stepA !ixA !ixB !ixDst = if ixA < endA- then continue ixA ixB ixDst- else finishB ixB ixDst+ stepA !ixA !ixB !ixDst =+ if ixA < endA+ then continue ixA ixB ixDst+ else finishB ixB ixDst finishB :: Int -> Int -> ST s () finishB !ixB !ixDst = do C.copyMut dst ixDst (C.sliceMut src ixB (endB - ixB))@@ -485,116 +526,119 @@ thresholdTagged :: Int thresholdTagged = 16 -insertionSortRange :: forall s a. (Prim a, Ord a)- => MutablePrimArray s a- -> Int -- start- -> Int -- end- -> ST s ()-{-# inlineable insertionSortRange #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Double -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Int -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Int64 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Int32 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Int16 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Int8 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Word -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Word64 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Word32 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Word16 -> Int -> Int -> ST s () #-}-{-# specialize insertionSortRange :: forall s. C.MutablePrimArray s Word8 -> Int -> Int -> ST s () #-}+insertionSortRange ::+ forall s a.+ (Prim a, Ord a) =>+ MutablePrimArray s a ->+ Int -> -- start+ Int -> -- end+ ST s ()+{-# INLINEABLE insertionSortRange #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Double -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Int64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Int32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Int16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Int8 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Word -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Word64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Word32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Word16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertionSortRange :: forall s. C.MutablePrimArray s Word8 -> Int -> Int -> ST s () #-} insertionSortRange !arr !start !end = go start- where+ where go :: Int -> ST s ()- go !ix = if ix < end- then do- !a <- C.read arr ix- insertElement arr (a :: a) start ix- go (ix + 1)- else return ()- -insertElement :: forall arr s a. (Contiguous arr, Element arr a, Ord a)- => Mutable arr s a- -> a- -> Int- -> Int- -> ST s ()-{-# specialize insertElement :: forall s. C.MutablePrimArray s Double -> Double -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Int -> Int -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Int64 -> Int64 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Int32 -> Int32 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Int16 -> Int16 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Int8 -> Int8 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Word -> Word -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Word64 -> Word64 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Word32 -> Word32 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Word16 -> Word16 -> Int -> Int -> ST s () #-}-{-# specialize insertElement :: forall s. C.MutablePrimArray s Word8 -> Word8 -> Int -> Int -> ST s () #-}+ go !ix =+ if ix < end+ then do+ !a <- C.read arr ix+ insertElement arr (a :: a) start ix+ go (ix + 1)+ else return ()++insertElement ::+ forall arr s a.+ (Contiguous arr, Element arr a, Ord a) =>+ Mutable arr s a ->+ a ->+ Int ->+ Int ->+ ST s ()+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Double -> Double -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Int -> Int -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Int64 -> Int64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Int32 -> Int32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Int16 -> Int16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Int8 -> Int8 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Word -> Word -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Word64 -> Word64 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Word32 -> Word32 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Word16 -> Word16 -> Int -> Int -> ST s () #-}+{-# SPECIALIZE insertElement :: forall s. C.MutablePrimArray s Word8 -> Word8 -> Int -> Int -> ST s () #-} insertElement !arr !a !start !end = go end- where+ where go :: Int -> ST s ()- go !ix = if ix > start- then do- !b <- C.read arr (ix - 1)- if b <= a- then do- C.copyMut arr (ix + 1) (C.sliceMut arr ix (end - ix))- C.write arr ix a- else go (ix - 1)- else do- C.copyMut arr (ix + 1) (C.sliceMut arr ix (end - ix))- C.write arr ix a+ go !ix =+ if ix > start+ then do+ !b <- C.read arr (ix - 1)+ if b <= a+ then do+ C.copyMut arr (ix + 1) (C.sliceMut arr ix (end - ix))+ C.write arr ix a+ else go (ix - 1)+ else do+ C.copyMut arr (ix + 1) (C.sliceMut arr ix (end - ix))+ C.write arr ix a -insertionSortTaggedRange :: forall karr varr s k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => Mutable karr s k- -> Mutable varr s v- -> Int -- start- -> Int -- end- -> ST s ()-{-# inlineable insertionSortTaggedRange #-}+insertionSortTaggedRange ::+ forall karr varr s k v.+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ Mutable karr s k ->+ Mutable varr s v ->+ Int -> -- start+ Int -> -- end+ ST s ()+{-# INLINEABLE insertionSortTaggedRange #-} insertionSortTaggedRange !karr !varr !start !end = go start- where+ where go :: Int -> ST s ()- go !ix = if ix < end- then do- !a <- C.read karr ix- !v <- C.read varr ix- insertElementTagged karr varr a v start ix- go (ix + 1)- else return ()- -insertElementTagged :: forall karr varr s k v. (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v)- => Mutable karr s k- -> Mutable varr s v- -> k- -> v- -> Int- -> Int- -> ST s ()-{-# inlineable insertElementTagged #-}+ go !ix =+ if ix < end+ then do+ !a <- C.read karr ix+ !v <- C.read varr ix+ insertElementTagged karr varr a v start ix+ go (ix + 1)+ else return ()++insertElementTagged ::+ forall karr varr s k v.+ (Contiguous karr, Element karr k, Ord k, Contiguous varr, Element varr v) =>+ Mutable karr s k ->+ Mutable varr s v ->+ k ->+ v ->+ Int ->+ Int ->+ ST s ()+{-# INLINEABLE insertElementTagged #-} insertElementTagged !karr !varr !a !v !start !end = go end- where+ where go :: Int -> ST s ()- go !ix = if ix > start- then do- !b <- C.read karr (ix - 1)- if b <= a- then do- C.copyMut karr (ix + 1) (C.sliceMut karr ix (end - ix))- C.write karr ix a- C.copyMut varr (ix + 1) (C.sliceMut varr ix (end - ix))- C.write varr ix v- else go (ix - 1)- else do- C.copyMut karr (ix + 1) (C.sliceMut karr ix (end - ix))- C.write karr ix a- C.copyMut varr (ix + 1) (C.sliceMut varr ix (end - ix))- C.write varr ix v---- $setup------ These are to make doctest work correctly.------ >>> :set -XOverloadedLists--- >>> import Data.Primitive.Array (Array)----+ go !ix =+ if ix > start+ then do+ !b <- C.read karr (ix - 1)+ if b <= a+ then do+ C.copyMut karr (ix + 1) (C.sliceMut karr ix (end - ix))+ C.write karr ix a+ C.copyMut varr (ix + 1) (C.sliceMut varr ix (end - ix))+ C.write varr ix v+ else go (ix - 1)+ else do+ C.copyMut karr (ix + 1) (C.sliceMut karr ix (end - ix))+ C.write karr ix a+ C.copyMut varr (ix + 1) (C.sliceMut varr ix (end - ix))+ C.write varr ix v
− test/Doctest.hs
@@ -1,6 +0,0 @@-import Test.DocTest--main :: IO ()-main = doctest- [ "src/Data/Primitive/Sort.hs"- ]
test/Main.hs view
@@ -1,30 +1,29 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}- {-# OPTIONS_GHC -Wall -fno-warn-orphans #-} import Test.HUnit.Base ((@?=)) import Test.QuickCheck as Q-import Test.SmallCheck.Series (Serial(..))+import Test.SmallCheck.Series (Serial (..)) import Test.Tasty import Test.Tasty.HUnit (testCase) import Test.Tasty.QuickCheck as QC import Test.Tasty.SmallCheck as SC import Control.Applicative (liftA2)-import Control.Exception (Exception,toException)-import Control.Monad.ST (ST,runST)+import Control.Exception (Exception, toException)+import Control.Monad.ST (ST, runST) import Data.Int import Data.List-import Data.Primitive (ByteArray(..),PrimArray(..),Prim,Array)-import Data.Proxy (Proxy(..))+import Data.Primitive (Array, ByteArray (..), Prim, PrimArray (..))+import Data.Proxy (Proxy (..)) import Data.Word-import Type.Reflection (TypeRep,typeRep)+import Type.Reflection (TypeRep, typeRep) import qualified Data.Map as M import qualified Data.Primitive as P@@ -35,43 +34,48 @@ import qualified Test.QuickCheck.Property as QP main :: IO ()-main = defaultMain $ testGroup "Sort"- [ testGroup "Contiguous"- [ tests (typeRep :: TypeRep Int8) (primArrayToByteArray . Data.Primitive.Sort.sort @Int8 . byteArrayToPrimArray)- , tests (typeRep :: TypeRep Word) (primArrayToByteArray . Data.Primitive.Sort.sort @Word . byteArrayToPrimArray)- , SC.testProperty "sortUnique == Set.toList . Set.fromList" $ \(list :: [Int]) ->- let actual = E.toList (Data.Primitive.Sort.sortUnique (E.fromList list :: PrimArray Int))- expected = S.toList (S.fromList list)- in if actual == expected- then Right "unused"- else Left ("expected " ++ show expected ++ " but got " ++ show actual)- , testCase "sortTagged" $- Data.Primitive.Sort.sortTagged- (E.fromList [2, 1, 0] :: PrimArray Int)- (E.fromList [1, 1, 0] :: PrimArray Word8)- @?=- (E.fromList [0,1,2], E.fromList [0,1,1] :: PrimArray Word8)- , testCase "sortUniqueTagged" $- Data.Primitive.Sort.sortUniqueTagged- (E.fromList [2, 1, 0] :: Array Int)- (E.fromList [1, 1, 0] :: PrimArray Word8)- @?=- (E.fromList [0,1,2], E.fromList [0,1,1] :: PrimArray Word8)- , SC.testProperty "sortUniqueTagged == Map.toList . Map.fromList" $ \(list :: [(Int,Word8)]) ->- let keys = E.fromList (map fst list) :: PrimArray Int- vals = E.fromList (map snd list) :: PrimArray Word8- (actualKeys,actualVals) = Data.Primitive.Sort.sortUniqueTagged keys vals- actual = zip (E.toList actualKeys) (E.toList actualVals)- expected = M.toList (M.fromList list)- in if actual == expected- then Right "unused"- else Left ("expected " ++ show expected ++ " but got " ++ show actual)- ]- , testGroup "Tagged"- [ testsTagged (typeRep :: TypeRep Word16) (typeRep :: TypeRep Word32)- (\k v -> pairPrimArrayToByteArray $ uncurry (Data.Primitive.Sort.sortTagged @Word16 @Word32) $ pairByteArrayToPrimArray (k,v))- ]- ]+main =+ defaultMain $+ testGroup+ "Sort"+ [ testGroup+ "Contiguous"+ [ tests (typeRep :: TypeRep Int8) (primArrayToByteArray . Data.Primitive.Sort.sort @Int8 . byteArrayToPrimArray)+ , tests (typeRep :: TypeRep Word) (primArrayToByteArray . Data.Primitive.Sort.sort @Word . byteArrayToPrimArray)+ , SC.testProperty "sortUnique == Set.toList . Set.fromList" $ \(list :: [Int]) ->+ let actual = E.toList (Data.Primitive.Sort.sortUnique (E.fromList list :: PrimArray Int))+ expected = S.toList (S.fromList list)+ in if actual == expected+ then Right "unused"+ else Left ("expected " ++ show expected ++ " but got " ++ show actual)+ , testCase "sortTagged" $+ Data.Primitive.Sort.sortTagged+ (E.fromList [2, 1, 0] :: PrimArray Int)+ (E.fromList [1, 1, 0] :: PrimArray Word8)+ @?= (E.fromList [0, 1, 2], E.fromList [0, 1, 1] :: PrimArray Word8)+ , testCase "sortUniqueTagged" $+ Data.Primitive.Sort.sortUniqueTagged+ (E.fromList [2, 1, 0] :: Array Int)+ (E.fromList [1, 1, 0] :: PrimArray Word8)+ @?= (E.fromList [0, 1, 2], E.fromList [0, 1, 1] :: PrimArray Word8)+ , SC.testProperty "sortUniqueTagged == Map.toList . Map.fromList" $ \(list :: [(Int, Word8)]) ->+ let keys = E.fromList (map fst list) :: PrimArray Int+ vals = E.fromList (map snd list) :: PrimArray Word8+ (actualKeys, actualVals) = Data.Primitive.Sort.sortUniqueTagged keys vals+ actual = zip (E.toList actualKeys) (E.toList actualVals)+ expected = M.toList (M.fromList list)+ in if actual == expected+ then Right "unused"+ else Left ("expected " ++ show expected ++ " but got " ++ show actual)+ ]+ , testGroup+ "Tagged"+ [ testsTagged+ (typeRep :: TypeRep Word16)+ (typeRep :: TypeRep Word32)+ (\k v -> pairPrimArrayToByteArray $ uncurry (Data.Primitive.Sort.sortTagged @Word16 @Word32) $ pairByteArrayToPrimArray (k, v))+ ]+ ] primArrayToByteArray :: PrimArray a -> ByteArray primArrayToByteArray (PrimArray x) = ByteArray x@@ -79,153 +83,224 @@ byteArrayToPrimArray :: ByteArray -> PrimArray a byteArrayToPrimArray (ByteArray x) = PrimArray x -pairPrimArrayToByteArray :: (PrimArray a, PrimArray b) -> (ByteArray,ByteArray)-pairPrimArrayToByteArray (PrimArray x,PrimArray y) = (ByteArray x,ByteArray y)+pairPrimArrayToByteArray :: (PrimArray a, PrimArray b) -> (ByteArray, ByteArray)+pairPrimArrayToByteArray (PrimArray x, PrimArray y) = (ByteArray x, ByteArray y) -pairByteArrayToPrimArray :: (ByteArray,ByteArray) -> (PrimArray a, PrimArray b) -pairByteArrayToPrimArray (ByteArray x,ByteArray y) = (PrimArray x,PrimArray y)+pairByteArrayToPrimArray :: (ByteArray, ByteArray) -> (PrimArray a, PrimArray b)+pairByteArrayToPrimArray (ByteArray x, ByteArray y) = (PrimArray x, PrimArray y) tests :: forall n. (Prim n, Ord n, Show n, Arbitrary n, Serial IO n) => TypeRep n -> (ByteArray -> ByteArray) -> TestTree tests p sortArray = testGroup (show p) [properties (Proxy :: Proxy n) sortArray, unitTests (Proxy :: Proxy n) sortArray] -testsTagged :: forall n a. (Prim a, Ord a, Show a, Arbitrary a, Serial IO a, Prim n, Ord n, Show n, Arbitrary n, Serial IO n, Num n, Enum n)- => TypeRep a -> TypeRep n -> (ByteArray -> ByteArray -> (ByteArray, ByteArray)) -> TestTree-testsTagged p n sortArray = testGroup (show p ++ " tagged with " ++ show n) - [ propertiesTagged (Proxy :: Proxy a) (Proxy :: Proxy n) sortArray- ]+testsTagged ::+ forall n a.+ (Prim a, Ord a, Show a, Arbitrary a, Serial IO a, Prim n, Ord n, Show n, Arbitrary n, Serial IO n, Num n, Enum n) =>+ TypeRep a ->+ TypeRep n ->+ (ByteArray -> ByteArray -> (ByteArray, ByteArray)) ->+ TestTree+testsTagged p n sortArray =+ testGroup+ (show p ++ " tagged with " ++ show n)+ [ propertiesTagged (Proxy :: Proxy a) (Proxy :: Proxy n) sortArray+ ] properties :: (Prim n, Ord n, Show n, Arbitrary n, Serial IO n) => Proxy n -> (ByteArray -> ByteArray) -> TestTree-properties p sortArray = testGroup "Properties"- [ scProps p sortArray- , qcProps p sortArray- ]+properties p sortArray =+ testGroup+ "Properties"+ [ scProps p sortArray+ , qcProps p sortArray+ ] -propertiesTagged :: (Prim a, Ord a, Show a, Arbitrary a, Serial IO a, Prim n, Ord n, Show n, Arbitrary n, Serial IO n, Num n, Enum n)- => Proxy a -> Proxy n -> (ByteArray -> ByteArray -> (ByteArray, ByteArray)) -> TestTree-propertiesTagged p n sortArray = testGroup "Properties"- [ scPropsTagged p n sortArray- , qcPropsTagged p n sortArray- ]+propertiesTagged ::+ (Prim a, Ord a, Show a, Arbitrary a, Serial IO a, Prim n, Ord n, Show n, Arbitrary n, Serial IO n, Num n, Enum n) =>+ Proxy a ->+ Proxy n ->+ (ByteArray -> ByteArray -> (ByteArray, ByteArray)) ->+ TestTree+propertiesTagged p n sortArray =+ testGroup+ "Properties"+ [ scPropsTagged p n sortArray+ , qcPropsTagged p n sortArray+ ] scProps :: forall n. (Prim n, Ord n, Show n, Serial IO n) => Proxy n -> (ByteArray -> ByteArray) -> TestTree-scProps _ sortArray = testGroup "(checked by SmallCheck)"- [ SC.testProperty "sort == sort . reverse" $ \list ->- eqByteArray (sortArray (byteArrayFromList (list :: [n]))) (sortArray (byteArrayFromList (reverse list)))- , SC.testProperty "sort == Data.List.sort" $ \list ->- (==) (byteArrayToList (sortArray (byteArrayFromList (list :: [n])))) (Data.List.sort list)- ]--scPropsTagged :: forall n a. (Prim a, Ord a, Show a, Serial IO a, Prim n, Ord n, Show n, Serial IO n, Num n, Enum n)- => Proxy a -> Proxy n -> (ByteArray -> ByteArray -> (ByteArray,ByteArray)) -> TestTree-scPropsTagged _ _ sortArray = testGroup "(checked by SmallCheck)"- [ SC.testProperty "sort == Data.List.sort" $ \list ->- let taggedList = tagWithIndices list :: [Tag a n]- actual = taggedByteArrayToList (uncurry sortArray (taggedByteArrayFromList (taggedList :: [Tag a n])))- expected = Data.List.sort taggedList- in if actual == expected- then Right "unused"- else Left ("expected " ++ show expected ++ " but got " ++ show actual)- ]+scProps _ sortArray =+ testGroup+ "(checked by SmallCheck)"+ [ SC.testProperty "sort == sort . reverse" $ \list ->+ eqByteArray (sortArray (byteArrayFromList (list :: [n]))) (sortArray (byteArrayFromList (reverse list)))+ , SC.testProperty "sort == Data.List.sort" $ \list ->+ (==) (byteArrayToList (sortArray (byteArrayFromList (list :: [n])))) (Data.List.sort list)+ ] +scPropsTagged ::+ forall n a.+ (Prim a, Ord a, Show a, Serial IO a, Prim n, Ord n, Show n, Serial IO n, Num n, Enum n) =>+ Proxy a ->+ Proxy n ->+ (ByteArray -> ByteArray -> (ByteArray, ByteArray)) ->+ TestTree+scPropsTagged _ _ sortArray =+ testGroup+ "(checked by SmallCheck)"+ [ SC.testProperty "sort == Data.List.sort" $ \list ->+ let taggedList = tagWithIndices list :: [Tag a n]+ actual = taggedByteArrayToList (uncurry sortArray (taggedByteArrayFromList (taggedList :: [Tag a n])))+ expected = Data.List.sort taggedList+ in if actual == expected+ then Right "unused"+ else Left ("expected " ++ show expected ++ " but got " ++ show actual)+ ] qcProps :: forall n. (Prim n, Arbitrary n, Show n, Ord n) => Proxy n -> (ByteArray -> ByteArray) -> TestTree-qcProps p sortArray = testGroup "(checked by QuickCheck)"- [ testGroup "sort == sort . reverse"- [ sizedQuickCheckReverse p sortArray "small" 20 10 100- , sizedQuickCheckReverse p sortArray "medium" 5 10000 100000- , sizedQuickCheckReverse p sortArray "large" 2 100000 200000- ]- , testGroup "sort == Data.List.sort"- [ sizedQuickCheckCorrect p sortArray "small" 20 10 100- , sizedQuickCheckCorrect p sortArray "medium" 5 10000 100000- , sizedQuickCheckCorrect p sortArray "large" 2 100000 200000+qcProps p sortArray =+ testGroup+ "(checked by QuickCheck)"+ [ testGroup+ "sort == sort . reverse"+ [ sizedQuickCheckReverse p sortArray "small" 20 10 100+ , sizedQuickCheckReverse p sortArray "medium" 5 10000 100000+ , sizedQuickCheckReverse p sortArray "large" 2 100000 200000+ ]+ , testGroup+ "sort == Data.List.sort"+ [ sizedQuickCheckCorrect p sortArray "small" 20 10 100+ , sizedQuickCheckCorrect p sortArray "medium" 5 10000 100000+ , sizedQuickCheckCorrect p sortArray "large" 2 100000 200000+ ] ]- ] -qcPropsTagged :: forall n a. (Prim a, Arbitrary a, Show a, Ord a, Prim n, Arbitrary n, Show n, Ord n)- => Proxy a -> Proxy n -> (ByteArray -> ByteArray -> (ByteArray,ByteArray)) -> TestTree-qcPropsTagged p n sortArray = testGroup "(checked by QuickCheck)"- [ testGroup "sort == Data.List.sort"- [ sizedQuickCheckCorrectTagged p n sortArray "small" 20 10 100- , sizedQuickCheckCorrectTagged p n sortArray "medium" 5 10000 100000- , sizedQuickCheckCorrectTagged p n sortArray "large" 2 100000 200000+qcPropsTagged ::+ forall n a.+ (Prim a, Arbitrary a, Show a, Ord a, Prim n, Arbitrary n, Show n, Ord n) =>+ Proxy a ->+ Proxy n ->+ (ByteArray -> ByteArray -> (ByteArray, ByteArray)) ->+ TestTree+qcPropsTagged p n sortArray =+ testGroup+ "(checked by QuickCheck)"+ [ testGroup+ "sort == Data.List.sort"+ [ sizedQuickCheckCorrectTagged p n sortArray "small" 20 10 100+ , sizedQuickCheckCorrectTagged p n sortArray "medium" 5 10000 100000+ , sizedQuickCheckCorrectTagged p n sortArray "large" 2 100000 200000+ ] ]- ] -sizedQuickCheckReverse :: forall n. (Arbitrary n, Prim n)- => Proxy n -> (ByteArray -> ByteArray) -> String -> Int -> Int -> Int -> TestTree-sizedQuickCheckReverse _ sortArray szName countTests szMin szMax = +sizedQuickCheckReverse ::+ forall n.+ (Arbitrary n, Prim n) =>+ Proxy n ->+ (ByteArray -> ByteArray) ->+ String ->+ Int ->+ Int ->+ Int ->+ TestTree+sizedQuickCheckReverse _ sortArray szName countTests szMin szMax = adjustOption (\_ -> QC.QuickCheckTests countTests) $ QC.testProperty szName $ do- sz <- Q.choose (szMin,szMax)+ sz <- Q.choose (szMin, szMax) list <- Q.vector sz return (eqByteArray (sortArray (byteArrayFromList (list :: [n]))) (sortArray (byteArrayFromList (reverse list)))) -sizedQuickCheckCorrect :: forall n. (Arbitrary n, Prim n, Ord n, Show n)- => Proxy n -> (ByteArray -> ByteArray) -> String -> Int -> Int -> Int -> TestTree-sizedQuickCheckCorrect _ sortArray szName countTests szMin szMax = +sizedQuickCheckCorrect ::+ forall n.+ (Arbitrary n, Prim n, Ord n, Show n) =>+ Proxy n ->+ (ByteArray -> ByteArray) ->+ String ->+ Int ->+ Int ->+ Int ->+ TestTree+sizedQuickCheckCorrect _ sortArray szName countTests szMin szMax = adjustOption (\_ -> QC.QuickCheckTests countTests) $ QC.testProperty szName $ do- sz <- Q.choose (szMin,szMax)+ sz <- Q.choose (szMin, szMax) list <- Q.vector sz let actual = byteArrayToList (sortArray (byteArrayFromList (list :: [n]))) expected = Data.List.sort list- return $ if actual == expected- then property QP.succeeded- else if sz < 100- then property (QP.exception ("expected " ++ show expected ++ " but got " ++ show actual) (toException MyException))- else property QP.failed+ return $+ if actual == expected+ then property QP.succeeded+ else+ if sz < 100+ then property (QP.exception ("expected " ++ show expected ++ " but got " ++ show actual) (toException MyException))+ else property QP.failed -sizedQuickCheckCorrectTagged :: forall n a. (Arbitrary a, Prim a, Ord a, Show a, Arbitrary n, Prim n, Ord n, Show n)- => Proxy a -> Proxy n -> (ByteArray -> ByteArray -> (ByteArray,ByteArray)) -> String -> Int -> Int -> Int -> TestTree-sizedQuickCheckCorrectTagged _ _ sortArray szName countTests szMin szMax = +sizedQuickCheckCorrectTagged ::+ forall n a.+ (Arbitrary a, Prim a, Ord a, Show a, Arbitrary n, Prim n, Ord n, Show n) =>+ Proxy a ->+ Proxy n ->+ (ByteArray -> ByteArray -> (ByteArray, ByteArray)) ->+ String ->+ Int ->+ Int ->+ Int ->+ TestTree+sizedQuickCheckCorrectTagged _ _ sortArray szName countTests szMin szMax = adjustOption (\_ -> QC.QuickCheckTests countTests) $ QC.testProperty szName $ do- sz <- Q.choose (szMin,szMax)+ sz <- Q.choose (szMin, szMax) list <- Q.vector sz let actual = taggedByteArrayToList (uncurry sortArray (taggedByteArrayFromList (list :: [Tag a n]))) expected = Data.List.sort list- return $ if actual == expected- then property QP.succeeded- else if sz < 100- then property (QP.exception ("expected " ++ show expected ++ " but got " ++ show actual) (toException MyException))- else property QP.failed+ return $+ if actual == expected+ then property QP.succeeded+ else+ if sz < 100+ then property (QP.exception ("expected " ++ show expected ++ " but got " ++ show actual) (toException MyException))+ else property QP.failed data MyException = MyException- deriving (Show,Eq)+ deriving (Show, Eq) instance Exception MyException -unitTests :: forall n. Prim n => Proxy n -> (ByteArray -> ByteArray) -> TestTree-unitTests _ _ = testGroup "Unit Tests"- [ -- testCase "List comparison (different length)" $- -- [1, 2, 3] `compare` [1,2] @?= GT- ]+unitTests :: forall n. (Prim n) => Proxy n -> (ByteArray -> ByteArray) -> TestTree+unitTests _ _ =+ testGroup+ "Unit Tests"+ [] +-- testCase "List comparison (different length)" $+-- [1, 2, 3] `compare` [1,2] @?= GT -byteArrayToList :: forall a. Prim a => ByteArray -> [a]-byteArrayToList arr = go 0 where+byteArrayToList :: forall a. (Prim a) => ByteArray -> [a]+byteArrayToList arr = go 0+ where !len = div (P.sizeofByteArray arr) (P.sizeOf (undefined :: a)) go :: Int -> [a]- go !ix = if ix < len- then P.indexByteArray arr ix : go (ix + 1)- else []+ go !ix =+ if ix < len+ then P.indexByteArray arr ix : go (ix + 1)+ else [] taggedByteArrayToList :: forall n a. (Prim a, Prim n) => (ByteArray, ByteArray) -> [Tag a n]-taggedByteArrayToList (arr,tags) = go 0 where+taggedByteArrayToList (arr, tags) = go 0+ where !len = div (P.sizeofByteArray arr) (P.sizeOf (undefined :: a)) go :: Int -> [Tag a n]- go !ix = if ix < len- then Tag (P.indexByteArray arr ix) (P.indexByteArray tags ix) : go (ix + 1)- else []+ go !ix =+ if ix < len+ then Tag (P.indexByteArray arr ix) (P.indexByteArray tags ix) : go (ix + 1)+ else [] -byteArrayFromList :: Prim a => [a] -> ByteArray+byteArrayFromList :: (Prim a) => [a] -> ByteArray byteArrayFromList xs = byteArrayFromListN (L.length xs) xs -taggedByteArrayFromList :: (Prim a, Prim n) => [Tag a n] -> (ByteArray,ByteArray)+taggedByteArrayFromList :: (Prim a, Prim n) => [Tag a n] -> (ByteArray, ByteArray) taggedByteArrayFromList xs = taggedByteArrayFromListN (L.length xs) xs -byteArrayFromListN :: forall a. Prim a => Int -> [a] -> ByteArray-byteArrayFromListN len vs = runST run where+byteArrayFromListN :: forall a. (Prim a) => Int -> [a] -> ByteArray+byteArrayFromListN len vs = runST run+ where run :: forall s. ST s ByteArray run = do arr <- P.newByteArray (len * P.sizeOf (undefined :: a))@@ -238,10 +313,15 @@ go vs 0 P.unsafeFreezeByteArray arr -taggedByteArrayFromListN :: forall n a. (Prim a, Prim n)- => Int -> [Tag a n] -> (ByteArray,ByteArray)-taggedByteArrayFromListN len vs = runST run where- run :: forall s. ST s (ByteArray,ByteArray)+taggedByteArrayFromListN ::+ forall n a.+ (Prim a, Prim n) =>+ Int ->+ [Tag a n] ->+ (ByteArray, ByteArray)+taggedByteArrayFromListN len vs = runST run+ where+ run :: forall s. ST s (ByteArray, ByteArray) run = do arr <- P.newByteArray (len * P.sizeOf (undefined :: a)) tags <- P.newByteArray (len * P.sizeOf (undefined :: n))@@ -255,27 +335,28 @@ go vs 0 liftA2 (,) (P.unsafeFreezeByteArray arr) (P.unsafeFreezeByteArray tags) - eqByteArray :: ByteArray -> ByteArray -> Bool eqByteArray paA paB = let !sizA = P.sizeofByteArray paA !sizB = P.sizeofByteArray paB- go !ix = if ix < sizA- then if P.indexByteArray paA ix == (P.indexByteArray paB ix :: Word8)- then go (ix + 1)- else False- else True- in if sizA == sizB- then go 0- else False+ go !ix =+ if ix < sizA+ then+ if P.indexByteArray paA ix == (P.indexByteArray paB ix :: Word8)+ then go (ix + 1)+ else False+ else True+ in if sizA == sizB+ then go 0+ else False data Tag a b = Tag a b deriving (Show) -instance Eq a => Eq (Tag a b) where+instance (Eq a) => Eq (Tag a b) where Tag a1 _ == Tag a2 _ = a1 == a2 -instance Ord a => Ord (Tag a b) where+instance (Ord a) => Ord (Tag a b) where compare (Tag a1 _) (Tag a2 _) = compare a1 a2 instance (Serial m a, Serial m b) => Serial m (Tag a b) where@@ -284,11 +365,8 @@ instance (Arbitrary a, Arbitrary b) => Arbitrary (Tag a b) where arbitrary = liftA2 Tag arbitrary arbitrary -tagFromTuple :: (a,b) -> Tag a b-tagFromTuple (a,b) = Tag a b+tagFromTuple :: (a, b) -> Tag a b+tagFromTuple (a, b) = Tag a b tagWithIndices :: (Num n, Enum n) => [a] -> [Tag a n]-tagWithIndices xs = map tagFromTuple (zip xs [0,1..])---+tagWithIndices xs = map tagFromTuple (zip xs [0, 1 ..])