packages feed

discrimination (empty) → 0

raw patch · 12 files changed

+1037/−0 lines, 12 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, contravariant, deepseq, ghc-prim, profunctors, semigroups, transformers, vector, void

Files

+ .gitignore view
@@ -0,0 +1,18 @@+dist/+.hsenv/+docs+wiki+TAGS+tags+wip+old+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox/+cabal.sandbox.config+codex.tags
+ CHANGELOG.markdown view
@@ -0,0 +1,3 @@+0+-+* Initialized repository
+ HLint.hs view
@@ -0,0 +1,1 @@+ignore "Eta reduce"
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (C) 2014 Edward Kmett (ekmett@gmail.com)++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ README.markdown view
@@ -0,0 +1,18 @@+discrimination+==============++[![Build Status](https://secure.travis-ci.org/ekmett/discrimination.png?branch=master)](http://travis-ci.org/ekmett/discrimination)++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://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011a.pdf) [papers](http://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011c.pdf) and [talks](https://www.youtube.com/watch?v=sz9ZlZIRDAg) by [Fritz Henglein](http://www.diku.dk/hjemmesider/ansatte/henglein/).++By adopting a final encoding we can enjoy many instances for standard classes, lawfully, without quotienting.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ discrimination.cabal view
@@ -0,0 +1,54 @@+name:          discrimination+category:      Data, Sorting+version:       0+license:       BSD3+cabal-version: >= 1.10+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/discrimination/+bug-reports:   http://github.com/ekmett/discrimination/issues+copyright:     Copyright (C) 2014-2015 Edward A. Kmett+build-type:    Simple+tested-with:   GHC == 7.8.4+synopsis:      Fast generic linear-time sorting, joins and container construction.+description:+  This package provides fast, generic, linear-time discrimination and sorting.+  .+  The techniques applied are based on <http://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011a.pdf multiple> <http://www.diku.dk/hjemmesider/ansatte/henglein/papers/henglein2011c.pdf papers> and <https://www.youtube.com/watch?v=sz9ZlZIRDAg talks> by <http://www.diku.dk/hjemmesider/ansatte/henglein/ Fritz Henglein>.++extra-source-files:+  .gitignore+  README.markdown+  CHANGELOG.markdown+  HLint.hs++source-repository head+  type: git+  location: git://github.com/ekmett/discrimination.git++library+  default-language: Haskell2010+  ghc-options: -Wall -O2+  hs-source-dirs: src++  exposed-modules:+    Data.Discrimination+    Data.Discrimination.Class+    Data.Discrimination.Grouping+    Data.Discrimination.Internal+    Data.Discrimination.Sorting++  build-depends:+    array         >= 0.5    && < 0.6,+    base          >= 4.7    && < 5,+    containers    >= 0.5    && < 0.6,+    contravariant >= 1.3.1  && < 2,+    deepseq       >= 1.4    && < 1.5,+    ghc-prim,+    profunctors   >= 5      && < 6,+    semigroups    >= 0.16.2 && < 1,+    transformers  >= 0.2    && < 0.5,+    vector        >= 0.10   && < 0.11,+    void          >= 0.6    && < 1
+ src/Data/Discrimination.hs view
@@ -0,0 +1,45 @@+module Data.Discrimination+  ( +  -- * Discrimination+    Discriminating(..)+  -- * Unordered+  , Group(..)+  , Grouping(..)+  , Grouping1(..)+  , nub+  , nubWith+  , group+  , groupWith+  , groupingBag+  , groupingSet+  , groupingEq+  -- * Ordered+  , Sort(..)+  , Sorting(..)+  , Sorting1(..)+  , desc+  , sort+  , sortWith+  , sortingBag+  , sortingSet+  , sortingCompare+  -- * Container Construction+  , toMap+  , toMapWith+  , toMapWithKey+  , toIntMap+  , toIntMapWith+  , toIntMapWithKey+  , toSet+  , toIntSet+  -- * Joins+  , joining+  , inner+  , outer+  , leftOuter+  , rightOuter+  ) where++import Data.Discrimination.Class+import Data.Discrimination.Grouping+import Data.Discrimination.Sorting
+ src/Data/Discrimination/Class.hs view
@@ -0,0 +1,128 @@+module Data.Discrimination.Class+  ( Discriminating(..)+  -- * Joins+  , joining+  , inner+  , outer+  , leftOuter+  , rightOuter+  ) where++import Control.Applicative+import Control.Arrow+import Data.Functor.Contravariant.Divisible+import Data.Discrimination.Grouping+import Data.Discrimination.Internal+import Data.Discrimination.Sorting+import Data.Maybe (catMaybes)++class Decidable f => Discriminating f where+  disc :: f a -> [(a, b)] -> [[b]]++instance Discriminating Sort where+  disc = runSort++instance Discriminating Group where+  disc = runGroup++--------------------------------------------------------------------------------+-- * Joins+--------------------------------------------------------------------------------++-- | /O(n)/. Perform a full outer join while explicit merging of the two result tables a table at a time.+--+-- The results are grouped by the discriminator.+joining+  :: Discriminating f+  => f d            -- ^ the discriminator to use+  -> ([a] -> [b] -> c) -- ^ how to join two tables+  -> (a -> d)          -- ^ selector for the left table+  -> (b -> d)          -- ^ selector for the right table+  -> [a]               -- ^ left table+  -> [b]               -- ^ right table+  -> [c]               +joining m abc ad bd as bs = spanEither abc <$> disc m (((ad &&& Left) <$> as) ++ ((bd &&& Right) <$> bs))+{-# INLINE joining #-}++-- | /O(n)/. Perform an inner join, with operations defined one row at a time.+--+-- The results are grouped by the discriminator.+--+-- This takes operation time linear in both the input and result sets.+inner+  :: Discriminating f+  => f d           -- ^ the discriminator to use+  -> (a -> b -> c) -- ^ how to join two rows+  -> (a -> d)      -- ^ selector for the left table+  -> (b -> d)      -- ^ selector for the right table+  -> [a]           -- ^ left table+  -> [b]           -- ^ right table+  -> [[c]]+inner m abc ad bd as bs = catMaybes $ joining m go ad bd as bs where+  go ap bp+    | Prelude.null ap || Prelude.null bp = Nothing+    | otherwise = Just (liftA2 abc ap bp)++-- | /O(n)/. Perform a full outer join with operations defined one row at a time.+--+-- The results are grouped by the discriminator.+--+-- This takes operation time linear in both the input and result sets.+outer+  :: Discriminating f+  => f d           -- ^ the discriminator to use+  -> (a -> b -> c) -- ^ how to join two rows+  -> (a -> c)      -- ^ row present on the left, missing on the right+  -> (b -> c)      -- ^ row present on the right, missing on the left+  -> (a -> d)      -- ^ selector for the left table+  -> (b -> d)      -- ^ selector for the right table+  -> [a]           -- ^ left table+  -> [b]           -- ^ right table+  -> [[c]]+outer m abc ac bc ad bd as bs = joining m go ad bd as bs where+  go ap bp+    | Prelude.null ap = bc <$> bp+    | Prelude.null bp = ac <$> ap+    | otherwise = liftA2 abc ap bp++-- | /O(n)/. Perform a left outer join with operations defined one row at a time.+--+-- The results are grouped by the discriminator.+--+-- This takes operation time linear in both the input and result sets.+leftOuter+  :: Discriminating f+  => f d           -- ^ the discriminator to use+  -> (a -> b -> c) -- ^ how to join two rows+  -> (a -> c)      -- ^ row present on the left, missing on the right+  -> (a -> d)      -- ^ selector for the left table+  -> (b -> d)      -- ^ selector for the right table+  -> [a]           -- ^ left table+  -> [b]           -- ^ right table+  -> [[c]]+leftOuter m abc ac ad bd as bs = catMaybes $ joining m go ad bd as bs where+  go ap bp+    | Prelude.null ap = Nothing+    | Prelude.null bp = Just (ac <$> ap)+    | otherwise = Just (liftA2 abc ap bp)++-- | /O(n)/. Perform a right outer join with operations defined one row at a time.+--+-- The results are grouped by the discriminator.+--+-- This takes operation time linear in both the input and result sets.+rightOuter+  :: Discriminating f+  => f d        -- ^ the discriminator to use+  -> (a -> b -> c) -- ^ how to join two rows+  -> (b -> c)      -- ^ row present on the right, missing on the left+  -> (a -> d)      -- ^ selector for the left table+  -> (b -> d)      -- ^ selector for the right table+  -> [a]           -- ^ left table+  -> [b]           -- ^ right table+  -> [[c]]+rightOuter m abc bc ad bd as bs = catMaybes $ joining m go ad bd as bs where+  go ap bp+    | Prelude.null bp = Nothing+    | Prelude.null ap = Just (bc <$> bp)+    | otherwise = Just (liftA2 abc ap bp)
+ src/Data/Discrimination/Grouping.hs view
@@ -0,0 +1,329 @@+{-# 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 #-}+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}++module Data.Discrimination.Grouping+  ( Group(..)+  , Grouping(..)+  , Grouping1(..)+  -- * Combinators+  , nub, nubWith+  , group, groupWith+  , groupingEq+  -- * Internals+  , groupingBag+  , groupingSet+  , groupingShort+  , groupingNat+  ) where++import Control.Arrow+import Control.Monad+import Data.Bits+import Data.Complex+import Data.Discrimination.Internal+import Data.Foldable hiding (concat)+import Data.Functor+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Functor.Contravariant.Generic+import Data.IORef (IORef, newIORef, atomicModifyIORef)+import Data.Int+import Data.Monoid hiding (Any)+import Data.Proxy+import Data.Ratio+import Data.Typeable+import qualified Data.Vector.Mutable as UM+import Data.Void+import Data.Word+import GHC.Prim (Any, RealWorld)+import Prelude hiding (read, concat)+import System.IO.Unsafe+import Unsafe.Coerce+{-+import Data.Coerce+import Data.Primitive.Types (Addr(..))+import GHC.IO (IO(IO))+import qualified Data.Vector.Primitive as P+import qualified Data.Vector.Primitive.Mutable as PM+import Data.Primitive.ByteArray (MutableByteArray(MutableByteArray))+import GHC.Prim (Any, State#, RealWorld, MutableByteArray#, Int#)+import GHC.IORef (IORef(IORef))+import GHC.STRef (STRef(STRef))+-}++-- | Discriminator++-- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety?+newtype Group a = Group { runGroup :: forall b. [(a,b)] -> [[b]] }+  deriving Typeable++#ifndef HLINT+type role Group representational+#endif++instance Contravariant Group where+  contramap f (Group g) = Group $ g . map (first f)++instance Divisible Group where+  conquer = Group $ return . fmap snd+  divide k (Group l) (Group r) = Group $ \xs ->+    l [ (b, (c, d)) | (a,d) <- xs, let (b, c) = k a] >>= r++instance Decidable Group where+  lose k = Group $ fmap (absurd.k.fst)+  choose f (Group l) (Group r) = Group $ \xs -> let+      ys = zipWith (\n (a,d) -> (f a, (n, d))) [0..] xs+    in l [ (k,p) | (Left k, p) <- ys ] `mix`+       r [ (k,p) | (Right k, p) <- ys ]++mix :: [[(Int,b)]] -> [[(Int,b)]] -> [[b]]+mix [] bs = fmap snd <$> bs+mix as [] = fmap snd <$> as+mix asss@(((n,a):as):ass) bsss@(((m,b):bs):bss)+  | n < m     = (a:fmap snd as) : mix ass bsss+  | otherwise = (b:fmap snd bs) : mix asss bss+mix _ _ = error "bad discriminator"++instance Monoid (Group a) where+  mempty = conquer+  mappend (Group l) (Group r) = Group $ \xs -> l [ (fst x, x) | x <- xs ] >>= r++--------------------------------------------------------------------------------+-- Primitives+--------------------------------------------------------------------------------++-- | Perform stable unordered discrimination by bucket.+--+-- This reuses arrays unlike the more obvious ST implementation, so it wins by+-- a huge margin in a race, especially when we have a large+-- keyspace, sparsely used, with low contention.+-- This will leak a number of arrays equal to the maximum concurrent+-- contention for this resource. If this becomes a bottleneck we can+-- make multiple stacks of working pads and index the stack with the+-- hash of the current thread id to reduce contention at the expense+-- of taking more memory.+--+-- You should create a thunk that holds the discriminator from @groupingNat n@+-- for a known @n@ and then reuse it.+groupingNat :: Int -> Group Int+groupingNat n = unsafePerformIO $ do+    ts <- newIORef ([] :: [UM.MVector RealWorld [Any]])+    return $ Group $ go ts+  where+    step1 t keys (k, v) = UM.read t k >>= \vs -> case vs of+      [] -> (k:keys) <$ UM.write t k [v]+      _  -> keys     <$ UM.write t k (v:vs)+    step2 t vss k = do+      es <- UM.read t k+      (reverse es : vss) <$ UM.write t k []+    go :: IORef [UM.MVector RealWorld [Any]] -> [(Int, b)] -> [[b]]+    go ts xs = unsafePerformIO $ do+      mt <- atomicModifyIORef ts $ \case+        (y:ys) -> (ys, Just y)+        []     -> ([], Nothing)+      t <- maybe (UM.replicate n []) (return . unsafeCoerce) mt+      ys <- foldM (step1 t) [] xs+      zs <- foldM (step2 t) [] ys+      atomicModifyIORef ts $ \ws -> (unsafeCoerce t:ws, ())+      return zs+    {-# NOINLINE go #-}+{-# NOINLINE groupingNat #-}++-- | Shared bucket set for small integers+groupingShort :: Group Int+groupingShort = groupingNat 65536+{-# NOINLINE groupingShort #-}++{-+foreign import prim "walk" walk :: Any -> MutableByteArray# s -> State# s -> (# State# s, Int# #)++groupingSTRef :: Group Addr -> Group (STRef s a)+groupingSTRef (Group f) = Group $ \xs ->+  let force !n !(!(STRef !_,_):ys) = force (n + 1) ys+      force !n [] = n+  in case force 0 xs of+   !n -> unsafePerformIO $ do+     mv@(PM.MVector _ _ (MutableByteArray mba)) <- PM.new n :: IO (PM.MVector RealWorld Addr)+     IO $ \s -> case walk (unsafeCoerce xs) mba s of (# s', _ #) -> (# s', () #)+     ys <- P.freeze mv+     return $ f [ (a,snd kv) | kv <- xs | a <- P.toList ys ]+{-# NOINLINE groupingSTRef #-}++groupingIORef :: forall a. Group Addr -> Group (IORef a)+groupingIORef = coerce (groupingSTRef :: Group Addr -> Group (STRef RealWorld a))+-}++--------------------------------------------------------------------------------+-- * Unordered Discrimination (for partitioning)+--------------------------------------------------------------------------------++-- | 'Eq' equipped with a compatible stable unordered discriminator.+class Grouping a where+  -- | For every surjection @f@,+  --+  -- @+  -- 'contramap' f 'grouping' ≡ 'grouping'+  -- @++  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 Word8 where+  grouping = contramap fromIntegral groupingShort++instance Grouping Word16 where+  grouping = contramap fromIntegral groupingShort++instance Grouping Word32 where+  grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . map radices) where+    radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16), (x,b)))++instance Grouping Word64 where+  grouping = Group (runs <=< runGroup groupingShort . join . runGroup groupingShort . join+                          . runGroup groupingShort . join . runGroup groupingShort . map radices)+    where+      radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16) .&. 0xffff+                    , (fromIntegral (unsafeShiftR x 32) .&. 0xffff, (fromIntegral (unsafeShiftR x 48)+                    , (x,b)))))+++instance Grouping Word where+  grouping+    | (maxBound :: Word) == 4294967295 = contramap (fromIntegral :: Word -> Word32) grouping+    | otherwise                        = contramap (fromIntegral :: Word -> Word64) grouping++instance Grouping Int8 where+  grouping = contramap (\x -> fromIntegral x + 128) groupingShort++instance Grouping Int16 where+  grouping = contramap (\x -> fromIntegral x + 32768) groupingShort++instance Grouping Int32 where+  grouping = contramap (\x -> fromIntegral (x - minBound) :: Word32) grouping++instance Grouping Int64 where+  grouping = contramap (\x -> fromIntegral (x - minBound) :: Word64) grouping++instance Grouping Int where+  grouping = contramap (\x -> fromIntegral (x - minBound) :: Word) grouping++instance Grouping Bool+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 (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 a, Integral a) => Grouping (Ratio a) where+  grouping = divide (\r -> (numerator r, denominator r)) grouping grouping+instance (Grouping1 f, Grouping1 g, Grouping a) => Grouping (Compose f g a) where+  grouping = getCompose `contramap` grouping1 (grouping1 grouping)++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 Grouping a => Grouping1 (Either a)+instance Grouping a => Grouping1 ((,) a)+instance (Grouping a, Grouping b) => Grouping1 ((,,) a b)+instance (Grouping a, Grouping b, Grouping c) => Grouping1 ((,,,) a b c)+instance (Grouping1 f, Grouping1 g) => Grouping1 (Compose f g) where+  grouping1 f = getCompose `contramap` grouping1 (grouping1 f)+instance Grouping1 Complex where+  grouping1 f = divide (\(a :+ b) -> (a, b)) f f++-- | Valid definition for @('==')@ in terms of 'Grouping'.+groupingEq :: Grouping a => a -> a -> Bool+groupingEq a b = case runGroup grouping [(a,()),(b,())] of+  _:_:_ -> False+  _ -> True+{-# INLINE groupingEq #-}++--------------------------------------------------------------------------------+-- * Combinators+--------------------------------------------------------------------------------++-- | /O(n)/. Similar to 'Data.List.group', except we do not require groups to be clustered.+--+-- This combinator still operates in linear time, at the expense of productivity.+--+-- The result equivalence classes are _not_ sorted, but the grouping is stable.+--+-- @+-- 'group' = 'groupWith' 'id'+-- @+group :: Grouping a => [a] -> [[a]]+group as = runGroup grouping [(a, a) | a <- as]++-- | /O(n)/. This is a replacement for 'GHC.Exts.groupWith' using discrimination.+--+-- The result equivalence classes are _not_ sorted, but the grouping is stable.+groupWith :: Grouping b => (a -> b) -> [a] -> [[a]]+groupWith f as = runGroup grouping [(f a, a) | a <- as]++-- | /O(n)/. This upgrades 'Data.List.nub' from @Data.List@ from /O(n^2)/ to /O(n)/ by using+-- unordered discrimination.+--+-- @+-- 'nub' = 'nubWith' 'id'+-- 'nub' as = 'head' 'Control.Applicative.<$>' 'group' as+-- @+nub :: Grouping a => [a] -> [a]+nub as = head <$> group as++-- | /O(n)/. 'nub' with a Schwartzian transform.+--+-- @+-- 'nubWith' f as = 'head' 'Control.Applicative.<$>' 'groupWith' f as+-- @+nubWith :: Grouping b => (a -> b) -> [a] -> [a]+nubWith f as = head <$> groupWith f as++--------------------------------------------------------------------------------+-- * Collections+--------------------------------------------------------------------------------++-- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a multiset.+groupingBag :: Foldable f => Group k -> Group (f k)+groupingBag = groupingColl updateBag++-- | Construct an stable unordered discriminator that partitions into equivalence classes based on the equivalence of keys as a set.+groupingSet :: Foldable f => Group k -> Group (f k)+groupingSet = groupingColl updateSet++groupingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Group k -> Group (f k)+groupingColl update r = Group $ \xss -> let+    (kss, vs)           = unzip xss+    elemKeyNumAssocs    = groupNum (toList <$> kss)+    keyNumBlocks        = runGroup r elemKeyNumAssocs+    keyNumElemNumAssocs = groupNum keyNumBlocks+    sigs                = bdiscNat (length kss) update keyNumElemNumAssocs+    yss                 = zip sigs vs+  in filter (not . null) $ grouping1 (groupingNat (length keyNumBlocks)) `runGroup` yss
+ src/Data/Discrimination/Internal.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ParallelListComp #-}+module Data.Discrimination.Internal+  ( runs+  , groupNum+  , bdiscNat+  , updateBag+  , updateSet+  , spanEither+  ) where++import Data.Array as Array+import Data.Functor+import Data.Int+import qualified Data.List as List+import Prelude hiding (read, concat)++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++bdiscNat :: Int -> ([v] -> v -> [v]) -> [(Int,v)] -> [[v]]+bdiscNat n update xs = reverse <$> Array.elems (Array.accumArray update [] (0,n) xs)+{-# INLINE bdiscNat #-}++runs :: Eq a => [(a,b)] -> [[b]]+runs [] = []+runs ((a,b):xs0) = (b:ys0) : runs zs0+  where+    (ys0,zs0) = go xs0+    go [] = ([],[])+    go xs@((a', b'):xs')+      | a == a' = case go xs' of+         (ys, zs) -> (b':ys,zs)+      | otherwise = ([], xs)++groupNum :: [[k]] -> [(k,Int)]+groupNum kss = List.concat [ (,n) <$> ks | n <- [0..] | ks <- kss ]++updateBag :: [Int] -> Int -> [Int]+updateBag vs v = v : vs++updateSet :: [Int] -> Int -> [Int]+updateSet [] w = [w]+updateSet vs@(v:_) w+  | v == w    = vs+  | otherwise = w : vs++-- | Optimized and CPS'd version of 'Data.Either.partitionEithers', where all lefts are known to come before all rights+spanEither :: ([a] -> [b] -> c) -> [Either a b] -> c+spanEither k xs0 = go [] xs0 where+  go acc (Left x:xs) = go (x:acc) xs+  go acc rights = k (reverse acc) (fromRight <$> rights)++fromRight :: Either a b -> b+fromRight (Right y) = y+fromRight _ = error "unstable discriminator"
+ src/Data/Discrimination/Sorting.hs view
@@ -0,0 +1,356 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}+module Data.Discrimination.Sorting+  ( Sort(..)+  -- * Sorting+  , Sorting(..)+  , Sorting1(..)+  -- * Combinators+  -- $common+  , sort, sortWith, desc+  , sortingCompare+  -- * Container Construction+  , toMap+  , toMapWith+  , toMapWithKey+  , toIntMap+  , toIntMapWith+  , toIntMapWithKey+  , toSet+  , toIntSet+  -- * Internals+  , sortingNat+  , sortingBag+  , sortingSet+  ) where++import Control.Applicative+import Control.Arrow+import Control.Monad+import Data.Bits+import Data.Discrimination.Grouping+import Data.Discrimination.Internal+import Data.Foldable as Foldable hiding (concat)+import Data.Functor.Compose+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import Data.Functor.Contravariant.Generic+import Data.Int+import Data.IntMap.Lazy as IntMap+import Data.IntSet as IntSet+import qualified Data.List as List+import Data.Map as Map+import Data.Monoid hiding (Any)+import Data.Proxy+import Data.Set as Set+import Data.Typeable+import Data.Void+import Data.Word+import Prelude hiding (read, concat)++--------------------------------------------------------------------------------+-- * Common+--------------------------------------------------------------------------------+++-- | Stable Ordered Discriminator++-- TODO: use [(a,b)] -> [NonEmpty b] to better indicate safety?+newtype Sort a = Sort { runSort :: forall b. [(a,b)] -> [[b]] }+  deriving Typeable++#ifndef HLINT+type role Sort representational+#endif++instance Contravariant Sort where+  contramap f (Sort g) = Sort $ g . fmap (first f)++instance Divisible Sort where+  conquer = Sort $ return . fmap snd+  divide k (Sort l) (Sort r) = Sort $ \xs ->+    l [ (b, (c, d)) | (a,d) <- xs, let (b, c) = k a] >>= r++instance Decidable Sort where+  lose k = Sort $ fmap (absurd.k.fst)+  choose f (Sort l) (Sort r) = Sort $ \xs -> let +      ys = fmap (first f) xs+    in l [ (k,v) | (Left k, v) <- ys]+    ++ r [ (k,v) | (Right k, v) <- ys]++instance Monoid (Sort a) where+  mempty = conquer+  mappend (Sort l) (Sort r) = Sort $ \xs -> l [ (fst x, x) | x <- xs ] >>= r++--------------------------------------------------------------------------------+-- * Ordered Discrimination+--------------------------------------------------------------------------------++-- | 'Ord' equipped with a compatible stable, ordered discriminator.+class Grouping a => Sorting a where+  -- | For every strictly monotone-increasing function @f@:+  --+  -- @+  -- '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 Word8 where+  sorting = contramap fromIntegral (sortingNat 256)++instance Sorting Word16 where+  sorting = contramap fromIntegral (sortingNat 65536)++instance Sorting Word32 where+  sorting = Sort (runs <=< runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . fmap radices) where+    radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16), (x,b)))+++instance Sorting Word64 where+  sorting = Sort (runs <=< runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . join+                         . runSort (sortingNat 65536) . join . runSort (sortingNat 65536) . fmap radices)+    where+      radices (x,b) = (fromIntegral x .&. 0xffff, (fromIntegral (unsafeShiftR x 16) .&. 0xffff+                    , (fromIntegral (unsafeShiftR x 32) .&. 0xffff, (fromIntegral (unsafeShiftR x 48)+                    , (x,b)))))+++instance Sorting Word where+  sorting+    | (maxBound :: Word) == 4294967295 = contramap (fromIntegral :: Word -> Word32) sorting+    | otherwise                        = contramap (fromIntegral :: Word -> Word64) sorting++instance Sorting Int8 where+  sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 256)++instance Sorting Int16 where+  sorting = contramap (\x -> fromIntegral (x - minBound)) (sortingNat 65536)++instance Sorting Int32 where+  sorting = contramap (\x -> fromIntegral (x - minBound) :: Word32) sorting++instance Sorting Int64 where+  sorting = contramap (\x -> fromIntegral (x - minBound) :: Word64) sorting++instance Sorting Int where+  sorting = contramap (\x -> fromIntegral (x - minBound) :: Word) sorting++-- TODO: Integer and Natural?++instance Sorting Void+instance Sorting Bool+instance Sorting a => Sorting [a]+instance Sorting a => Sorting (Maybe a)+instance (Sorting a, Sorting b) => Sorting (Either a b)+instance (Sorting a, Sorting b) => Sorting (a, b)+instance (Sorting a, Sorting b, Sorting c) => Sorting (a, b, c)+instance (Sorting a, Sorting b, Sorting c, Sorting d) => Sorting (a, b, c, d)+instance (Sorting1 f, Sorting1 g, Sorting a) => Sorting (Compose f g a) where+  sorting = getCompose `contramap` sorting1 (sorting1 sorting)++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 Maybe+instance Sorting a => Sorting1 (Either a)++-- | Valid definition for 'compare' in terms of 'Sorting'.+sortingCompare :: Sorting a => a -> a -> Ordering+sortingCompare a b = case runSort sorting [(a,LT),(b,GT)] of+  [r]:_ -> r+  _     -> EQ+{-# INLINE sortingCompare #-}++--------------------------------------------------------------------------------+-- * Utilities+--------------------------------------------------------------------------------++sortingNat :: Int -> Sort Int+sortingNat n = Sort $ \xs -> List.filter (not . List.null) (bdiscNat n upd xs) where+  upd vs v = v : vs+{-# INLINE sortingNat #-}++--------------------------------------------------------------------------------+-- * Collections+--------------------------------------------------------------------------------++-- | Construct a stable ordered discriminator that sorts a list as multisets of elements from another stable ordered discriminator.+--+-- The resulting discriminator only cares about the set of keys and their multiplicity, and is sorted as if we'd+-- sorted each key in turn before comparing.+sortingBag :: Foldable f => Sort k -> Sort (f k)+sortingBag = sortingColl updateBag++-- | Construct a stable ordered discriminator that sorts a list as sets of elements from another stable ordered discriminator.+--+-- The resulting discriminator only cares about the set of keys, and is sorted as if we'd+-- sorted each key in turn before comparing.+sortingSet :: Foldable f => Sort k -> Sort (f k)+sortingSet = sortingColl updateSet++sortingColl :: Foldable f => ([Int] -> Int -> [Int]) -> Sort k -> Sort (f k)+sortingColl upd r = Sort $ \xss -> let+    (kss, vs)           = unzip xss+    elemKeyNumAssocs    = groupNum (Foldable.toList <$> kss)+    keyNumBlocks        = runSort r elemKeyNumAssocs+    keyNumElemNumAssocs = groupNum keyNumBlocks+    sigs                = bdiscNat (length kss) upd keyNumElemNumAssocs+    yss                 = zip sigs vs+  in List.filter (not . List.null) $ sorting1 (sortingNat (length keyNumBlocks)) `runSort` yss++--------------------------------------------------------------------------------+-- * Combinators+--------------------------------------------------------------------------------++desc :: Sort a -> Sort a+desc (Sort l) = Sort (reverse . l)++-- $common+-- Useful combinators.++-- | / O(n)/. Sort a list using discrimination.+--+-- @+-- 'sort' = 'sortWith' 'id'+-- @+sort :: Sorting a => [a] -> [a]+sort as = List.concat $ runSort sorting [ (a,a) | a <- as ]++-- | /O(n)/. Sort a list with a Schwartzian transformation by using discrimination. +--+-- This linear time replacement for 'GHC.Exts.sortWith' and 'Data.List.sortOn' uses discrimination.+sortWith :: Sorting b => (a -> b) -> [a] -> [a]+sortWith f as = List.concat $ runSort sorting [ (f a, a) | a <- as ]++--------------------------------------------------------------------------------+-- * Containers+--------------------------------------------------------------------------------++-- | /O(n)/. Construct a 'Map'.+--+-- This is an asymptotically faster version of 'Data.Map.fromList', which exploits ordered discrimination.+--+-- >>> toMap [] == empty+-- True+--+-- >>> toMap [(5,"a"), (3 :: Int,"b"), (5, "c")]+-- fromList [(5,"c"), (3,"b")]+--+-- >>> toMap [(5,"c"), (3,"b"), (5 :: Int, "a")]+-- fromList [(5,"a"), (3,"b")]+toMap :: Sorting k => [(k, v)] -> Map k v+toMap kvs = Map.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ]++-- | /O(n)/. Construct a 'Map', combining values.+--+-- This is an asymptotically faster version of 'Data.Map.fromListWith', which exploits ordered discrimination.+--+-- (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")]+--+-- >>> toMapWith (++) [] == empty+-- True+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)+  go []          = error "bad sort"++-- | /O(n)/. Construct a 'Map', combining values with access to the key.+--+-- This is an asymptotically faster version of 'Data.Map.fromListWithKey', which exploits ordered discrimination.+--+-- (Note: the values combine in anti-stable order for compatibility with 'Data.Map.fromListWithKey')+--+-- >>> 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")]+--+-- >>> toMapWithKey f [] == empty+-- True+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)+  go []          = error "bad sort"++-- | /O(n)/. Construct an 'IntMap'.+--+-- >>> toIntMap [] == empty+-- True+--+-- >>> toIntMap [(5,"a"), (3,"b"), (5, "c")]+-- fromList [(5,"c"), (3,"b")]+--+-- >>> toIntMap [(5,"c"), (3,"b"), (5, "a")]+-- fromList [(5,"a"), (3,"b")]+toIntMap :: [(Int, v)] -> IntMap v+toIntMap kvs = IntMap.fromDistinctAscList $ last <$> runSort sorting [ (fst kv, kv) | kv <- kvs ]++-- | /O(n)/. Construct an 'IntMap', combining values.+--+-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWith', which exploits ordered discrimination.+--+-- (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")]+--+-- >>> toIntMapWith (++) [] == empty+-- True+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)+  go []          = error "bad sort"++-- | /O(n)/. Construct a 'Map', combining values with access to the key.+--+-- This is an asymptotically faster version of 'Data.IntMap.Lazy.fromListWithKey', which exploits ordered discrimination.+--+-- (Note: the values combine in anti-stable order for compatibility with 'Data.IntMap.Lazy.fromListWithKey')+--+-- >>> 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")]+--+-- >>> toIntMapWithKey f [] == empty+-- True+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)+  go []          = error "bad sort"++-- | /O(n)/. Construct a 'Set' in linear time.+--+-- This is an asymptotically faster version of 'Data.Set.fromList', which exploits ordered discrimination.+toSet :: Sorting k => [k] -> Set k+toSet kvs = Set.fromDistinctAscList $ last <$> runSort sorting [ (kv, kv) | kv <- kvs ]++-- | /O(n)/. Construct an 'IntSet' in linear time.+--+-- This is an asymptotically faster version of 'Data.IntSet.fromList', which exploits ordered discrimination.+toIntSet :: [Int] -> IntSet+toIntSet kvs = IntSet.fromDistinctAscList $ last <$> runSort sorting [ (kv, kv) | kv <- kvs ]