discrimination 0.4 → 0.4.1

raw patch · 14 files changed

+568/−87 lines, 14 filesdep +QuickCheckdep +ghc-bignumdep +quickcheck-instancesdep −profunctorsdep −transformers-compatdep −voiddep ~arraydep ~basedep ~containersnew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: QuickCheck, ghc-bignum, quickcheck-instances, splitmix, tasty, tasty-quickcheck, vector-algorithms

Dependencies removed: profunctors, transformers-compat, void

Dependency ranges changed: array, base, containers, contravariant, deepseq, hashable, integer-gmp, primitive, promises, semigroups, transformers, vector

API changes (from Hackage documentation)

Files

• .gitignore +3/−0
• CHANGELOG.markdown +8/−0
• HLint.hs +0/−1
• README.markdown +1/−1
• benchmarks/examples.hs +65/−0
• common/Utils.hs +77/−0
• discrimination.cabal +66/−20
• src/Data/Discrimination/Class.hs +1/−1
• src/Data/Discrimination/Grouping.hs +24/−23
• src/Data/Discrimination/Internal.hs +58/−0
• src/Data/Discrimination/Internal/SmallArray.hs +0/−1
• src/Data/Discrimination/Internal/WordMap.hs +0/−2
• src/Data/Discrimination/Sorting.hs +62/−38
• test/tests.hs +203/−0

@@ -1,4 +1,7 @@ dist/+dist-newstyle/+.ghc.environment.*+cabal.project.local .hsenv/ docs wiki

@@ -1,3 +1,11 @@+## 0.4.1 [2021-01-08]++* GHC-9.0 compatibility+* Added `Ordering` discrimination+* Fix `Sorting Int8` and `Sorting Int16` instances+* Fix `Integer` and `Natural` instances+* Add `NonEmpty` discrimination+ ## 0.4  * Added `Natural`, `Integer` and `()` discrimination

@@ -1,1 +0,0 @@-ignore "Eta reduce"

@@ -1,7 +1,7 @@ discrimination ============== -[![Hackage](https://img.shields.io/hackage/v/discrimination.svg)](https://hackage.haskell.org/package/discrimination) [![Build Status](https://secure.travis-ci.org/ekmett/discrimination.png?branch=master)](http://travis-ci.org/ekmett/discrimination)+[![Hackage](https://img.shields.io/hackage/v/discrimination.svg)](https://hackage.haskell.org/package/discrimination) [![Build Status](https://github.com/ekmett/discrimination/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/discrimination/actions?query=workflow%3AHaskell-CI)  This package provides linear time sorting, partitioning, and joins for a wide array of Haskell data types. This work is based on a "final encoding" of the ideas presented in [multiple](http://hjemmesider.diku.dk/~henglein/papers/henglein2011a.pdf) [papers](http://hjemmesider.diku.dk/~henglein/papers/henglein2011c.pdf) and [talks](https://www.youtube.com/watch?v=sz9ZlZIRDAg) by [Fritz Henglein](http://hjemmesider.diku.dk/~henglein).

@@ -0,0 +1,65 @@+module Main where++import Control.Exception (evaluate)+import Control.DeepSeq (rnf)+import Criterion.Main+import Criterion.Types++import qualified Data.List as L+import qualified System.Random.SplitMix as SM++import Utils++import Data.Discrimination (nub, sort)+++main :: IO ()+main = do+  let gen = SM.mkSMGen 0xc0de++  let xs100   = finiteList gen 100+  let xs1000  = finiteList gen 1000+  let xs10000 = finiteList gen 10000++  evaluate $ rnf xs100+  evaluate $ rnf xs1000+  evaluate $ rnf xs10000++  defaultMainWith (defaultConfig { timeLimit = 1 })+    [ bgroup "nub"+      [ bgroup "List.nub"+        [ bench "100" $ whnf (length . L.nub) xs100+        , bench "1000" $ whnf (length . L.nub) xs1000+        ]+      , bgroup "ordNub"+        [ bench "100" $ whnf (length . ordNub) xs100+        , bench "1000" $ whnf (length . ordNub) xs1000+        , bench "10000" $ whnf (length . ordNub) xs10000+        ]+      , bgroup "hashNub"+        [ bench "100" $ whnf (length . hashNub) xs100+        , bench "1000" $ whnf (length . hashNub) xs1000+        , bench "10000" $ whnf (length . hashNub) xs10000+        ]+      , bgroup "Discrimination.nub"+        [ bench "100" $ whnf (length . nub) xs100+        , bench "1000" $ whnf (length . nub) xs1000+        , bench "10000" $ whnf (length . nub) xs10000+        ]+      ]++    , bgroup "sort"+      [ bgroup "List.sort"+        [ bench "10000" $ whnf (length . L.sort) xs10000+        ]+      , bgroup "mergesort"+        [ bench "10000" $ whnf (length . mergesort) xs10000+        ]+      , bgroup "introsort"+        [ bench "10000" $ whnf (length . introsort) xs10000+        ]+      , bgroup "Discrimination.sort"+        [ bench "10000" $ whnf (length . sort) xs10000+        ]+      ]+    ]

@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+module Utils where++import Data.Word (Word64)+import Data.Hashable (Hashable (..))+import GHC.Generics (Generic)+import Control.DeepSeq (NFData)+import Data.Discrimination (Grouping, Sorting)++import qualified Data.HashSet as HS+import qualified Data.Set as Set+import qualified System.Random.SplitMix as SM++import Control.Monad.ST (runST)+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as Intro+import qualified Data.Vector.Algorithms.Merge as Merge+import qualified Data.Vector.Algorithms.Radix as Radix+++finiteList :: SM.SMGen -> Int -> [Word64]+finiteList gen n = take n $ go gen where+    go g = let (w,g') = SM.nextWord64 g in w : go g'++finiteListU :: SM.SMGen -> Int -> [UUID]+finiteListU gen n = take n $ go gen where+    go g0 = UUID w1 w2 : go g2 where+        (w1,g1) = SM.nextWord64 g0+        (w2,g2) = SM.nextWord64 g1++-- | Remove duplicates but keep elements in order.+--   O(n * log n)+--+-- From GHC's Util module+--+ordNub :: Ord a => [a] -> [a]+ordNub ys = go Set.empty ys+  where+    go _ [] = []+    go s (x:xs)+      | Set.member x s = go s xs+      | otherwise = x : go (Set.insert x s) xs++-- | Like 'ordNub' but using 'HashSet'.+hashNub :: (Eq a, Hashable a) => [a] -> [a]+hashNub ys = go HS.empty ys where+    go _ [] = []+    go s (x:xs)+        | HS.member x s = go s xs+        | otherwise     = x : go (HS.insert x s) xs++ -- | Sort via vector.+introsort :: Ord a => [a] -> [a]+introsort xs = runST $ do+    v <- V.unsafeThaw (V.fromList xs)+    Intro.sort v+    V.toList <$> V.unsafeFreeze v++mergesort :: Ord a => [a] -> [a]+mergesort xs = runST $ do+    v <- V.unsafeThaw (V.fromList xs)+    Merge.sort v+    V.toList <$> V.unsafeFreeze v++radixsort :: Radix.Radix a => [a] -> [a]+radixsort xs = runST $ do+    v <- V.unsafeThaw (V.fromList xs)+    Radix.sort v+    V.toList <$> V.unsafeFreeze v++-------------------------------------------------------------------------------+-- UUID+-------------------------------------------------------------------------------++data UUID = UUID !Word64 !Word64+  deriving (Eq, Ord, Generic, Show, NFData, Hashable, Grouping, Sorting)

@@ -1,6 +1,6 @@ name:          discrimination category:      Data, Sorting-version:       0.4+version:       0.4.1 license:       BSD3 cabal-version: >= 1.10 license-file:  LICENSE@@ -11,7 +11,7 @@ bug-reports:   http://github.com/ekmett/discrimination/issues copyright:     Copyright (C) 2014-2015 Edward A. Kmett build-type:    Simple-tested-with:   GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2+tested-with:   GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.3 synopsis:      Fast generic linear-time sorting, joins and container construction. description:   This package provides fast, generic, linear-time discrimination and sorting.@@ -22,7 +22,6 @@   .gitignore   README.markdown   CHANGELOG.markdown-  HLint.hs  source-repository head   type: git@@ -43,31 +42,59 @@     Data.Discrimination.Sorting    build-depends:-    array         >= 0.5    && < 0.6,-    base          >= 4.8    && < 5,-    containers    >= 0.4    && < 0.7,-    contravariant >= 1.3.1  && < 2,-    deepseq       >= 1.3    && < 1.5,+    array         >= 0.5.1.0 && < 0.6,+    base          >= 4.8     && < 5,+    containers    >= 0.5.6.2 && < 0.7,+    contravariant >= 1.5.3   && < 2,+    deepseq       >= 1.4.1.1 && < 1.5,     ghc-prim,-    hashable      >= 1.2    && < 1.3,-    integer-gmp,-    primitive     >= 0.6.4  && < 0.8,-    profunctors   >= 5      && < 6,-    promises      >= 0.2    && < 0.4,-    semigroups    >= 0.16.2 && < 1,-    transformers  >= 0.2    && < 0.6,-    transformers-compat >= 0.3 && < 1,-    vector        >= 0.10   && < 0.13,-    void          >= 0.5    && < 1+    hashable      >= 1.2.7.0 && < 1.4,+    primitive     >= 0.7.1.0 && < 0.8,+    promises      >= 0.3     && < 0.4,+    transformers  >= 0.4.2.0 && < 0.6 +  if !impl(ghc >=8.0)+    build-depends: semigroups >= 0.18.5 && < 1++  if impl(ghc >= 9.0)+    build-depends: ghc-bignum >= 1.0 && < 1.1+  else+    build-depends: integer-gmp >= 1.0 && < 1.1++test-suite properties+  type:             exitcode-stdio-1.0+  main-is:          tests.hs+  other-modules:    Utils+  ghc-options:      -Wall -O2 -threaded+  hs-source-dirs:   test common+  default-language: Haskell2010+  build-depends:+    base >= 4.8,+    containers,+    criterion,+    deepseq,+    discrimination,+    hashable,+    QuickCheck >=2.14.2,+    quickcheck-instances,+    splitmix >=0.1 && <0.2,+    tasty,+    tasty-quickcheck,+    unordered-containers,+    vector,+    vector-algorithms++  if !impl(ghc >=8.0)+    build-depends: semigroups+ benchmark wordmap   type:             exitcode-stdio-1.0   main-is:          wordmap.hs-  ghc-options:      -Wall -O2 -threaded +  ghc-options:      -Wall -O2 -threaded   hs-source-dirs:   benchmarks   default-language: Haskell2010   build-depends:-    base >= 4.9,+    base >= 4.8,     containers,     criterion,     deepseq,@@ -75,3 +102,22 @@     ghc-prim,     unordered-containers,     primitive++benchmark examples+  type:             exitcode-stdio-1.0+  main-is:          examples.hs+  other-modules:    Utils+  ghc-options:      -Wall -O2 -threaded+  hs-source-dirs:   benchmarks common+  default-language: Haskell2010+  build-depends:+    base >= 4.8,+    containers,+    criterion,+    deepseq,+    discrimination,+    hashable,+    splitmix >=0.1 && <0.2,+    unordered-containers,+    vector,+    vector-algorithms

@@ -20,7 +20,7 @@   disc :: f a -> [(a, b)] -> [[b]]  instance Discriminating Sort where-  disc = runSort+  disc fa ab = runSort fa ab  instance Discriminating Group where   disc = runGroup

@@ -1,14 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ParallelListComp #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -26,15 +21,14 @@   , runGroup   -- * Internals   , hashing-  , word8s   ) where  import Control.Monad hiding (mapM_) import Control.Monad.Primitive import Control.Monad.ST-import Control.Monad.ST.Unsafe import Data.Complex import Data.Discrimination.Internal.WordMap as WordMap+import Data.Discrimination.Internal import Data.Foldable hiding (concat) import Data.Functor.Compose import Data.Functor.Contravariant@@ -42,18 +36,16 @@ import Data.Functor.Contravariant.Generic import Data.Hashable import Data.Int+import Data.List.NonEmpty (NonEmpty) import Data.Semigroup hiding (Any) import Data.Primitive.MutVar-import Data.Primitive.PrimArray import Data.Promise import Data.Proxy import Data.Ratio import Data.Typeable import Data.Void import Data.Word-import GHC.Integer.GMP.Internals-import GHC.Word-import Numeric.Natural+import Numeric.Natural (Natural) import Prelude hiding (read, concat, mapM_)  -- | Productive Stable Unordered Discriminator@@ -63,6 +55,12 @@              => (b -> m (b -> m ())) -> m (a -> b -> m ())   } deriving Typeable +-- Note: Group should be+--+--     type role Group representational+--+-- but it isn't due PrimMonad not implying higher-order Coercible constraint.+ instance Contravariant Group where   contramap f m = Group $ \k -> do     g <- getGroup m k@@ -124,6 +122,15 @@ --------------------------------------------------------------------------------  -- | 'Eq' equipped with a compatible stable unordered discriminator.+--+-- Law:+--+-- @+-- 'groupingEq' x y ≡ (x '==' y)+-- @+--+-- /Note:/ 'Eq' is a moral super class of 'Grouping'.+-- It isn't because of some missing instances. class Grouping a where   -- | For every surjection @f@,   --@@ -132,10 +139,8 @@   -- @    grouping :: Group a-#ifndef HLINT   default grouping :: Deciding Grouping a => Group a   grouping = deciding (Proxy :: Proxy Grouping) grouping-#endif  instance Grouping Void where grouping = lose id instance Grouping () where grouping = conquer@@ -152,25 +157,22 @@ instance Grouping Char where grouping = contramap (fromIntegral . fromEnum) groupingWord64  instance Grouping Bool+instance Grouping Ordering instance (Grouping a, Grouping b) => Grouping (a, b) instance (Grouping a, Grouping b, Grouping c) => Grouping (a, b, c) instance (Grouping a, Grouping b, Grouping c, Grouping d) => Grouping (a, b, c, d) instance Grouping a => Grouping [a]+instance Grouping a => Grouping (NonEmpty a) instance Grouping a => Grouping (Maybe a) instance (Grouping a, Grouping b) => Grouping (Either a b) instance Grouping a => Grouping (Complex a) where   grouping = divide (\(a :+ b) -> (a, b)) grouping grouping  instance Grouping Integer where-  grouping = contramap word8s grouping--word8s :: Integer -> [Word8]-word8s i = runST $ unsafeIOToST $ do-  p@(MutablePrimArray mba) :: MutablePrimArray RealWorld Word8 <- newPrimArray (fromIntegral $ W# (sizeInBaseInteger i 256#))-  _ <- exportIntegerToMutableByteArray i mba 0## 1#-  primArrayToList <$> unsafeFreezePrimArray p+  grouping = choose integerCases grouping (choose id grouping grouping) -instance Grouping Natural where grouping = contramap toInteger grouping+instance Grouping Natural where+  grouping = choose naturalCases grouping grouping  #if __GLASGOW_HASKELL__ >= 800 instance Grouping a => Grouping (Ratio a) where@@ -184,13 +186,12 @@  class Grouping1 f where   grouping1 :: Group a -> Group (f a)-#ifndef HLINT   default grouping1 :: Deciding1 Grouping f => Group a -> Group (f a)   grouping1 = deciding1 (Proxy :: Proxy Grouping) grouping-#endif  instance Grouping1 [] instance Grouping1 Maybe+instance Grouping1 NonEmpty instance Grouping a => Grouping1 (Either a) instance Grouping a => Grouping1 ((,) a) instance (Grouping a, Grouping b) => Grouping1 ((,,) a b)

@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MagicHash #-} module Data.Discrimination.Internal   ( runs   , groupNum@@ -7,6 +9,8 @@   , updateBag   , updateSet   , spanEither+  , integerCases+  , naturalCases   ) where  import Data.Array as Array@@ -15,6 +19,19 @@ import qualified Data.List as List import Prelude hiding (read, concat) +import GHC.Word+import GHC.Exts+import Data.Primitive.Types (Prim)+import Data.Primitive.PrimArray++#ifdef MIN_VERSION_ghc_bignum+import GHC.Num.Integer+import GHC.Num.Natural+#else+import GHC.Natural+import GHC.Integer.GMP.Internals+#endif+ -------------------------------------------------------------------------------- -- * Utilities --------------------------------------------------------------------------------@@ -55,3 +72,44 @@ fromRight :: Either a b -> b fromRight (Right y) = y fromRight _ = error "unstable discriminator"++-------------------------------------------------------------------------------+-- * Integer and Natural+-------------------------------------------------------------------------------++integerCases :: Integer -> Either (Int,[Word]) (Either Int (Int,[Word]))+#ifdef MIN_VERSION_ghc_bignum+integerCases (IN b) = Left          $ decomposeBigNat b+integerCases (IS i) = Right . Left  $ I# i+integerCases (IP b) = Right . Right $ decomposeBigNat b+#else+integerCases (Jn# b) = Left          $ decomposeBigNat b+integerCases (S#  i) = Right . Left  $ I# i+integerCases (Jp# b) = Right . Right $ decomposeBigNat b+#endif+{-# INLINE integerCases #-}++naturalCases :: Natural -> Either Word (Int,[Word])+#ifdef MIN_VERSION_ghc_bignum+naturalCases (NS w) = Left $ W# w+naturalCases (NB b) = Right $ decomposeBigNat b+#else+naturalCases (NatS# w) = Left $ W# w+naturalCases (NatJ# b) = Right $ decomposeBigNat b+#endif+{-# INLINE naturalCases #-}++-- We need to reverse the limb array. Its stored least-significant word first+-- but for comparasion to work right we need most-significant words first.+#ifdef MIN_VERSION_ghc_bignum+decomposeBigNat :: ByteArray# -> (Int, [Word])+decomposeBigNat ba = let pa = PrimArray ba :: PrimArray Word in (sizeofPrimArray pa, primArrayToReverseList pa)+#else+decomposeBigNat :: BigNat -> (Int, [Word])+decomposeBigNat (BN# ba) = let pa = PrimArray ba :: PrimArray Word in (sizeofPrimArray pa, primArrayToReverseList pa)+#endif+{-# INLINE decomposeBigNat #-}++primArrayToReverseList :: Prim a => PrimArray a -> [a]+primArrayToReverseList xs = build (\c n -> foldlPrimArray (flip c) n xs)+{-# INLINE primArrayToReverseList #-}

@@ -3,7 +3,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UnboxedTuples #-}-{-# LANGUAGE DeriveDataTypeable #-} -------------------------------------------------------------------------------- -- | -- Copyright   : (c) Edward Kmett 2015

@@ -3,11 +3,9 @@ {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Trustworthy #-}-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# OPTIONS_GHC -Wall -funbox-strict-fields -fno-warn-orphans -fno-warn-type-defaults -O2 #-} #ifdef ST_HACK {-# OPTIONS_GHC -fno-full-laziness #-}

@@ -1,13 +1,8 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MonoLocalBinds #-} {-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}@@ -50,6 +45,7 @@ import Data.IntMap.Lazy as IntMap import Data.IntSet as IntSet import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty) import Data.Map as Map import Data.Proxy import Data.Semigroup hiding (Any)@@ -57,9 +53,13 @@ import Data.Typeable import Data.Void import Data.Word-import Numeric.Natural+import Numeric.Natural (Natural) import Prelude hiding (read, concat) +-- $setup+-- >>> import qualified Data.Map as Map+-- >>> import qualified Data.IntMap as IntMap+ -------------------------------------------------------------------------------- -- * Common --------------------------------------------------------------------------------@@ -77,9 +77,7 @@   [(_, v)] -> [[v]]   _        -> f xs -#ifndef HLINT type role Sort representational-#endif  instance Contravariant Sort where   contramap f (Sort g) = Sort $ g . fmap (first f)@@ -108,6 +106,12 @@ --------------------------------------------------------------------------------  -- | 'Ord' equipped with a compatible stable, ordered discriminator.+--+-- Law:+--+-- @+-- 'sortingCompare' x y ≡ 'compare' x y+-- @ class Grouping a => Sorting a where   -- | For every strictly monotone-increasing function @f@:   --@@ -115,19 +119,17 @@   -- 'contramap' f 'sorting' ≡ 'sorting'   -- @   sorting :: Sort a-#ifndef HLINT   default sorting :: Deciding Sorting a => Sort a   sorting = deciding (Proxy :: Proxy Sorting) sorting-#endif  instance Sorting () where   sorting = conquer  instance Sorting Integer where-  sorting = contramap word8s sorting+  sorting = choose integerCases (desc sorting) (choose id sorting sorting)  instance Sorting Natural where-  sorting = contramap toInteger sorting+  sorting = choose naturalCases sorting sorting  instance Sorting Word8 where   sorting = contramap fromIntegral (sortingNat 256)@@ -155,10 +157,10 @@     | otherwise                        = contramap (fromIntegral :: Word -> Word64) sorting  instance Sorting Int8 where-  sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 256)+  sorting = contramap (\x -> fromIntegral x + 128) (sortingNat 256)  instance Sorting Int16 where-  sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 65536)+  sorting = contramap (\x -> fromIntegral x + 32768) (sortingNat 65536)  instance Sorting Int32 where   sorting = contramap (\x -> fromIntegral (x - minBound) :: Word32) sorting@@ -174,11 +176,11 @@     radices (c,b) = (x .&. 0x3ff, (unsafeShiftR x 10, (x,b))) where       x = fromEnum c --- TODO: Integer and Natural?- instance Sorting Void instance Sorting Bool+instance Sorting Ordering instance Sorting a => Sorting [a]+instance Sorting a => Sorting (NonEmpty a) instance Sorting a => Sorting (Maybe a) instance (Sorting a, Sorting b) => Sorting (Either a b) instance (Sorting a, Sorting b) => Sorting (a, b)@@ -189,15 +191,14 @@  class Grouping1 f => Sorting1 f  where   sorting1 :: Sort a -> Sort (f a)-#ifndef HLINT   default sorting1 :: Deciding1 Sorting f => Sort a -> Sort (f a)   sorting1 = deciding1 (Proxy :: Proxy Sorting) sorting-#endif  instance (Sorting1 f, Sorting1 g) => Sorting1 (Compose f g) where   sorting1 f = getCompose `contramap` sorting1 (sorting1 f)  instance Sorting1 []+instance Sorting1 NonEmpty instance Sorting1 Maybe instance Sorting a => Sorting1 (Either a) @@ -277,14 +278,21 @@ -- -- This is an asymptotically faster version of 'Data.Map.fromList', which exploits ordered discrimination. ----- >>> toMap [] == empty--- True+-- >>> toMap []+-- fromList [] -- -- >>> toMap [(5,"a"), (3 :: Int,"b"), (5, "c")]--- fromList [(5,"c"), (3,"b")]+-- fromList [(3,"b"),(5,"c")] --+-- >>> Map.fromList [(5,"a"), (3 :: Int,"b"), (5, "c")]+-- fromList [(3,"b"),(5,"c")]+-- -- >>> toMap [(5,"c"), (3,"b"), (5 :: Int, "a")]--- fromList [(5,"a"), (3,"b")]+-- fromList [(3,"b"),(5,"a")]+--+-- >>> Map.fromList [(5,"c"), (3,"b"), (5 :: Int, "a")]+-- fromList [(3,"b"),(5,"a")]+-- toMap :: Sorting k => [(k, v)] -> Map k v toMap kvs = Map.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ] @@ -295,10 +303,13 @@ -- (Note: values combine in anti-stable order for compatibility with 'Data.Map.fromListWith') -- -- >>> toMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]--- fromList [(3, "ab"), (5, "cba")]+-- fromList [(3,"ab"),(5,"cba")] ----- >>> toMapWith (++) [] == empty--- True+-- >>> Map.fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]+-- fromList [(3,"ab"),(5,"cba")]+--+-- >>> toMapWith (++) []+-- fromList [] toMapWith :: Sorting k => (v -> v -> v) -> [(k, v)] -> Map k v toMapWith f kvs0 = Map.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where   go ((k,v):kvs) = (k, Prelude.foldl (flip (f . snd)) v kvs)@@ -312,10 +323,10 @@ -- -- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value -- >>> toMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5 :: Int,"c")]--- fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")] ----- >>> toMapWithKey f [] == empty--- True+-- >>> toMapWithKey f []+-- fromList [] toMapWithKey :: Sorting k => (k -> v -> v -> v) -> [(k, v)] -> Map k v toMapWithKey f kvs0 = Map.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where   go ((k,v):kvs) = (k, Prelude.foldl (flip (f k . snd)) v kvs)@@ -323,14 +334,21 @@  -- | /O(n)/. Construct an 'IntMap'. ----- >>> toIntMap [] == empty--- True+-- >>> toIntMap []+-- fromList [] -- -- >>> toIntMap [(5,"a"), (3,"b"), (5, "c")]--- fromList [(5,"c"), (3,"b")]+-- fromList [(3,"b"),(5,"c")] --+-- >>> IntMap.fromList [(5,"a"), (3,"b"), (5, "c")]+-- fromList [(3,"b"),(5,"c")]+-- -- >>> toIntMap [(5,"c"), (3,"b"), (5, "a")]--- fromList [(5,"a"), (3,"b")]+-- fromList [(3,"b"),(5,"a")]+--+-- >>> IntMap.fromList [(5,"c"), (3,"b"), (5, "a")]+-- fromList [(3,"b"),(5,"a")]+-- toIntMap :: [(Int, v)] -> IntMap v toIntMap kvs = IntMap.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ] @@ -341,10 +359,13 @@ -- (Note: values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWith') -- -- >>> toIntMapWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]--- fromList [(3, "ab"), (5, "cba")]+-- fromList [(3,"ab"),(5,"cba")] ----- >>> toIntMapWith (++) [] == empty--- True+-- >>> IntMap.fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]+-- fromList [(3,"ab"),(5,"cba")]+--+-- >>> toIntMapWith (++) []+-- fromList [] toIntMapWith :: (v -> v -> v) -> [(Int, v)] -> IntMap v toIntMapWith f kvs0 = IntMap.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where   go ((k,v):kvs) = (k, Prelude.foldl (flip (f . snd)) v kvs)@@ -358,10 +379,13 @@ -- -- >>> let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value -- >>> toIntMapWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]--- fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")] ----- >>> toIntMapWithKey f [] == empty--- True+-- >>> IntMap.fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")]+-- fromList [(3,"3:a|b"),(5,"5:c|5:b|a")]+--+-- >>> toIntMapWithKey f []+-- fromList [] toIntMapWithKey :: (Int -> v -> v -> v) -> [(Int, v)] -> IntMap v toIntMapWithKey f kvs0 = IntMap.fromDistinctAscList $ go <$> runSort sorting [ (fst kv, kv) | kv <- kvs0 ] where   go ((k,v):kvs) = (k, Prelude.foldl (flip (f k . snd)) v kvs)

@@ -0,0 +1,203 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Main (main) where++import Data.Complex (Complex)+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List.NonEmpty (NonEmpty)+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable, typeRep)+import Data.Word (Word8, Word16, Word32, Word64)+import Numeric.Natural (Natural)+import Test.QuickCheck (Arbitrary (..), Property, counterexample, label, (===),+                        sized, chooseInt, vectorOf)+import Test.QuickCheck.Instances ()+import Test.Tasty (defaultMain, testGroup, TestTree)+import Test.Tasty.QuickCheck (testProperty)++import qualified Data.List as L++import Data.Discrimination+import Utils++main :: IO ()+main = defaultMain $ testGroup "discrimination"+  [ testGroup "examples"+    [ testGroup "nub"+      [ testProperty "List.nub" $+        let prop :: [Word64] -> Property+            prop xs = L.nub xs === nub xs+        in prop++      , testProperty "ordNub" $+        let prop :: [Word64] -> Property+            prop xs = ordNub xs === nub xs+        in prop++      , testProperty "hashNub" $+        let prop :: [Word64] -> Property+            prop xs = hashNub xs === nub xs+        in prop+      ]++    , testGroup "sort"+      [ testProperty "List.sort" $+        let prop :: [Word64] -> Property+            prop xs = L.sort xs === sort xs+        in prop++      , testProperty "introsort" $+        -- for Word64 unstable sort works too+        let prop :: [Word64] -> Property+            prop xs = introsort xs === sort xs+        in prop++      , testProperty "mergesort" $+        let prop :: [Word64] -> Property+            prop xs = mergesort xs === sort xs+        in prop+      ]+    ]++  , testGroup "Grouping"+    [ testGrouping (Proxy :: Proxy ())+    , testGrouping (Proxy :: Proxy Int)+    , testGrouping (Proxy :: Proxy Int8)+    , testGrouping (Proxy :: Proxy Int16)+    , testGrouping (Proxy :: Proxy Int32)+    , testGrouping (Proxy :: Proxy Int64)+    , testGrouping (Proxy :: Proxy Word)+    , testGrouping (Proxy :: Proxy Word8)+    , testGrouping (Proxy :: Proxy Word16)+    , testGrouping (Proxy :: Proxy Word32)+    , testGrouping (Proxy :: Proxy Word64)+    , testGrouping (Proxy :: Proxy Bool)+    , testGrouping (Proxy :: Proxy Ordering)+    , testGrouping (Proxy :: Proxy (Word8,Word8))+    , testGrouping (Proxy :: Proxy (Word8,Word8,Word8))+    , testGrouping (Proxy :: Proxy (Word8,Word8,Word8,Word8))+    , testGrouping (Proxy :: Proxy Rational)+    , testGrouping (Proxy :: Proxy (Complex Word8))+    , testGrouping (Proxy :: Proxy (Maybe Word8))+    , testGrouping (Proxy :: Proxy (Either Word8 Word8))+    , testGrouping (Proxy :: Proxy Char)+    , testGrouping (Proxy :: Proxy String)+    , testGrouping (Proxy :: Proxy (NonEmpty Int))+    , testGrouping (Proxy :: Proxy Natural)+    , testGrouping (Proxy :: Proxy Integer)++    , testGrouping' listToNatural+    , testGrouping' listToInteger+    ]++  , testGroup "Sorting"+    [ testSorting (Proxy :: Proxy ())+    , testSorting (Proxy :: Proxy Int)+    , testSorting (Proxy :: Proxy Int8)+    , testSorting (Proxy :: Proxy Int16)+    , testSorting (Proxy :: Proxy Int32)+    , testSorting (Proxy :: Proxy Int64)+    , testSorting (Proxy :: Proxy Word)+    , testSorting (Proxy :: Proxy Word8)+    , testSorting (Proxy :: Proxy Word16)+    , testSorting (Proxy :: Proxy Word32)+    , testSorting (Proxy :: Proxy Word64)+    , testSorting (Proxy :: Proxy Bool)+    , testSorting (Proxy :: Proxy Ordering)+    , testSorting (Proxy :: Proxy (Word8,Word8))+    , testSorting (Proxy :: Proxy (Word8,Word8,Word8))+    , testSorting (Proxy :: Proxy (Word8,Word8,Word8,Word8))+    , testSorting (Proxy :: Proxy (Maybe Word8))+    , testSorting (Proxy :: Proxy (Either Word8 Word8))+    , testSorting (Proxy :: Proxy Char)+    , testSorting (Proxy :: Proxy String)+    , testSorting (Proxy :: Proxy (NonEmpty Int))+    , testSorting (Proxy :: Proxy Natural)+    , testSorting (Proxy :: Proxy Integer)++    , testSorting' listToNatural+    , testSorting' listToInteger+    ]+  ]++listToNatural :: SmallList Word64 -> Natural+listToNatural = L.foldl' (\x y -> x * 2 ^ (64 :: Int) + fromIntegral y) 0 . getSmallList++listToInteger :: SmallList Int64 -> Integer+listToInteger = L.foldl' (\x y -> x * 2 ^ (64 :: Int) + fromIntegral y) 0 . getSmallList++newtype SmallList a = SmallList { getSmallList :: [a] } deriving (Eq, Show)++instance Arbitrary a => Arbitrary (SmallList a) where+    arbitrary = sized $ \n -> do+        m <- chooseInt (0, min 10 n)+        SmallList <$> vectorOf m arbitrary++    shrink = fmap SmallList . shrink . getSmallList++testGrouping+  :: forall a. (Grouping a, Typeable a, Arbitrary a, Eq a, Show a)+  => Proxy a+  -> TestTree+testGrouping _ = testGrouping' (id :: a -> a)++testGrouping'+  :: forall a b. (Grouping b, Typeable a, Typeable b, Arbitrary a, Eq b, Show a, Show b)+  => (a -> b)+  -> TestTree+testGrouping' f = testGroup name+    [ testProperty "groupingEq" prop_eq+    , testProperty "nub"        prop_nub+    ]+  where+    tra = typeRep (Proxy :: Proxy a)+    trb = typeRep (Proxy :: Proxy b)+    name = if tra == trb then show tra else show trb ++ " from " ++ show tra++    prop_eq :: a -> a -> Property+    prop_eq x' y' =+        counterexample (show (x,y)) $+        label (show lhs) $+        lhs === groupingEq x y+      where+        x = f x'+        y = f y'+        lhs = x == y++    prop_nub :: [a] -> Property+    prop_nub xs' = L.nub xs === nub xs+      where+        xs = take 100 (map f xs')++testSorting+  :: forall a. (Sorting a, Typeable a, Arbitrary a, Ord a, Show a)+  => Proxy a+  -> TestTree+testSorting _ = testSorting' (id :: a -> a)++testSorting'+  :: forall a b. (Sorting b, Typeable a, Typeable b, Arbitrary a, Ord b, Show a, Show b)+  => (a -> b)+  -> TestTree+testSorting' f = testGroup name+    [ testProperty "sortingCompare" prop_cmp+    , testProperty "sort"           prop_sort+    ]+  where+    tra = typeRep (Proxy :: Proxy a)+    trb = typeRep (Proxy :: Proxy b)+    name = if tra == trb then show tra else show trb ++ " from " ++ show tra++    prop_cmp :: a -> a -> Property+    prop_cmp x' y' =+        counterexample (show (x,y)) $+        label (show lhs) $+        lhs === sortingCompare x y+      where+        x = f x'+        y = f y'+        lhs = compare x y++    prop_sort :: [a] -> Property+    prop_sort xs' = L.sort xs === sort xs+      where+        xs = map f xs'