discrimination 0.1 → 0.2.1

raw patch · 8 files changed

+675/−72 lines, 8 filesdep +criteriondep +discriminationdep +hashabledep ~basedep ~containersdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, discrimination, hashable, transformers-compat, unordered-containers

Dependency ranges changed: base, containers, deepseq, primitive, promises, transformers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +12/−0
• README.markdown +1/−1
• benchmarks/wordmap.hs +104/−0
• discrimination.cabal +26/−6
• src/Data/Discrimination/Grouping.hs +39/−60
• src/Data/Discrimination/Internal/SmallArray.hs +232/−0
• src/Data/Discrimination/Internal/WordMap.hs +249/−0
• src/Data/Discrimination/Sorting.hs +12/−5

@@ -1,3 +1,15 @@+## 0.2.1++* `promises` 0.3 support+* `vector` 0.11 support+* `transformers` 0.5 support+* `transformers-compat` support+* ghc 8 support++## 0.2++* `grouping` is now much more efficient.+ ## 0.1  * `grouping` is now productive. This means it can start spitting out results as it goes! To do this I created the `promises` package and switched to using it behind the scenes for many combinators that consume a `Group`. This has a bunch of knock-on effects:

@@ -1,7 +1,7 @@ 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://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/).

@@ -0,0 +1,104 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+{-# OPTIONS_GHC -Wall -funbox-strict-fields -fno-warn-orphans -fno-warn-type-defaults -O2 #-}+{-# OPTIONS_GHC -fno-full-laziness #-}+module Main where++import Control.DeepSeq+import Control.Exception (evaluate)+import Criterion.Main+import Criterion.Types+import Data.Discrimination.Internal.WordMap+import Data.Foldable+import Data.HashMap.Lazy (HashMap)+import Data.Maybe (fromMaybe)+import Data.Word+import Prelude hiding (lookup, length, foldr)+import qualified Data.IntMap as M+import qualified Data.HashMap.Lazy as H++main :: IO ()+main = do+    evaluate $ rnf [denseM, sparseM, sparseM']+    evaluate $ rnf [denseW, sparseW, sparseW']+    evaluate $ rnf [denseH, sparseH, sparseH']+    evaluate $ rnf [elems,  sElems,  sElemsSearch]+    evaluate $ rnf [keys,   sKeys, sKeysSearch]+    evaluate $ rnf [values, sValues]+    evaluate $ rnf [welems,  wsElems,  wsElemsSearch]+    evaluate $ rnf [wkeys,   wsKeys, wsKeysSearch]+    evaluate $ rnf [wvalues, wsValues]+    defaultMainWith (defaultConfig { timeLimit = 1 })+        [ bgroup "lookup"+            [ bgroup "present"+                [ bench "IntMap"  $ whnf (\m -> foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 keys) denseM+                , bench "WordMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (lookup k m)) 0 wkeys) denseW+                , bench "HashMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (H.lookup k m)) 0 wkeys) denseH+                ]+            , bgroup "absent"+                [ bench "IntMap"  $ whnf (\m -> foldl' (\n k -> fromMaybe n (M.lookup k m)) 0 sKeysSearch) sparseM+                , bench "WordMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (lookup k m)) 0 wsKeysSearch) sparseW+                , bench "HashMap" $ whnf (\m -> foldl' (\n k -> fromMaybe n (H.lookup k m)) 0 wsKeysSearch) sparseH+                ]+            ]+        , bgroup "insert"+            [ bgroup "present"+                [ bench "IntMap"  $ whnf (\m0 -> foldl' (\m (k, v) -> M.insert k v m) m0 elems) denseM+                , bench "WordMap" $ whnf (\m0 -> foldl' (\m (k, v) -> insert k v m) m0 welems) denseW+                , bench "HashMap" $ whnf (\m0 -> foldl' (\m (k, v) -> H.insert k v m) m0 welems) denseH+                ]+            , bgroup "absent"+                [ bench "IntMap" $ whnf (\m0 -> foldl' (\m (k, v) -> M.insert k v m) m0 sElemsSearch) sparseM+                , bench "WordMap" $ whnf (\m0 -> foldl' (\m (k, v) -> insert k v m) m0 wsElemsSearch) sparseW+                , bench "HashMap" $ whnf (\m0 -> foldl' (\m (k, v) -> H.insert k v m) m0 wsElemsSearch) sparseH+                ]+            ]+        , bgroup "member"+            [ bgroup "present"+                [ bench "IntMap"  $ whnf (\m -> foldl' (\n x -> if M.member x m then n + 1 else n) (0 :: Int) keys) denseM+                , bench "WordMap" $ whnf (\m -> foldl' (\n x -> if member x m then n + 1 else n) (0 :: Int) wkeys) denseW+                , bench "HashMap" $ whnf (\m -> foldl' (\n x -> if H.member x m then n + 1 else n) (0 :: Int) wkeys) denseH+                ]+            , bgroup "absent"+                [ bench "IntMap"  $ whnf (\m -> foldl' (\n x -> if M.member x m then n + 1 else n) (0 :: Int) sKeysSearch) sparseM+                , bench "WordMap" $ whnf (\m -> foldl' (\n x -> if member x m then n + 1 else n) (0 :: Int) wsKeysSearch) sparseW+                , bench "HashMap" $ whnf (\m -> foldl' (\n x -> if H.member x m then n + 1 else n) (0 :: Int) wsKeysSearch) sparseH+                ]+            ]+        ]+  where+    denseM = M.fromAscList elems :: M.IntMap Int+    denseW = fromList welems :: WordMap Word64+    denseH = H.fromList welems :: HashMap Word64 Word64+    sparseM = M.fromAscList sElems :: M.IntMap Int+    sparseW = fromList wsElems :: WordMap Word64+    sparseH = H.fromList wsElems :: HashMap Word64 Word64+    sparseM' = M.fromAscList sElemsSearch :: M.IntMap Int+    sparseW' = fromList wsElemsSearch :: WordMap Word64+    sparseH' = H.fromList wsElemsSearch :: HashMap Word64 Word64++    elems = zip keys values+    keys = [1..2^12]+    values = [1..2^12]+    sElems = zip sKeys sValues+    sElemsSearch = zip sKeysSearch sValues+    sKeys = [1,3..2^12]+    sKeysSearch = [2,4..2^12]+    sValues = [1,3..2^12]++    welems = zip wkeys wvalues+    wkeys = [1..2^12]+    wvalues = [1..2^12]+    wsElems = zip wsKeys wsValues+    wsElemsSearch = zip wsKeysSearch wsValues+    wsKeys = [1,3..2^12]+    wsKeysSearch = [2,4..2^12]+    wsValues = [1,3..2^12]

@@ -1,8 +1,8 @@ name:          discrimination category:      Data, Sorting-version:       0.1+version:       0.2.1 license:       BSD3-cabal-version: >= 1.10+cabal-version: >= 1.22 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com>@@ -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.8.4+tested-with:   GHC == 7.10.1 synopsis:      Fast generic linear-time sorting, joins and container construction. description:   This package provides fast, generic, linear-time discrimination and sorting.@@ -38,6 +38,8 @@     Data.Discrimination.Class     Data.Discrimination.Grouping     Data.Discrimination.Internal+    Data.Discrimination.Internal.SmallArray+    Data.Discrimination.Internal.WordMap     Data.Discrimination.Sorting    build-depends:@@ -47,10 +49,28 @@     contravariant >= 1.3.1  && < 2,     deepseq       >= 1.3    && < 1.5,     ghc-prim,+    hashable      >= 1.2    && < 1.3,     primitive     >= 0.6    && < 0.7,     profunctors   >= 5      && < 6,-    promises      >= 0.2    && < 0.3,+    promises      >= 0.2    && < 0.4,     semigroups    >= 0.16.2 && < 1,-    transformers  >= 0.2    && < 0.5,-    vector        >= 0.10   && < 0.11,+    transformers  >= 0.2    && < 0.6,+    transformers-compat >= 0.3 && < 1,+    vector        >= 0.10   && < 0.12,     void          >= 0.5    && < 1++benchmark wordmap+  type:             exitcode-stdio-1.0+  main-is:          wordmap.hs+  ghc-options:      -Wall -O2 -threaded +  hs-source-dirs:   benchmarks+  default-language: Haskell2010+  build-depends:+    base >= 4.8,+    containers,+    criterion,+    deepseq,+    discrimination,+    ghc-prim,+    unordered-containers,+    primitive

@@ -24,27 +24,27 @@   , groupingEq   , runGroup   -- * Internals-  , groupingNat+  , hashing   ) where  import Control.Monad hiding (mapM_) import Control.Monad.Primitive import Control.Monad.ST-import Data.Bits import Data.Complex+import Data.Discrimination.Internal.WordMap as WordMap import Data.Foldable hiding (concat) import Data.Functor.Compose import Data.Functor.Contravariant import Data.Functor.Contravariant.Divisible import Data.Functor.Contravariant.Generic+import Data.Hashable import Data.Int-import Data.Monoid hiding (Any)+import Data.Semigroup hiding (Any) import Data.Primitive.MutVar import Data.Promise import Data.Proxy import Data.Ratio import Data.Typeable-import qualified Data.Vector.Mutable as UM import Data.Void import Data.Word import Prelude hiding (read, concat, mapM_)@@ -83,21 +83,35 @@    lose k = Group $ \_ -> return (absurd . k) +instance Semigroup (Group a) where+  (<>) = divide (\a -> (a,a))+ instance Monoid (Group a) where   mempty = conquer-  mappend = divide (\a -> (a,a))+  mappend = (<>)  -------------------------------------------------------------------------------- -- Primitives -------------------------------------------------------------------------------- -groupingNat :: Int -> Group Int-groupingNat = \ n -> Group $ \k -> do-  t <- UM.replicate n Nothing-  return $ \ a b -> UM.read t a >>= \case-    Nothing -> k b >>= UM.write t a . Just-    Just k' -> k' b+groupingWord64 :: Group Word64+groupingWord64 = Group $ \k -> do+  mt <- newMutVar WordMap.empty+  return $ \a b -> readMutVar mt >>= \m -> case WordMap.lookup a m of+    Nothing -> k b >>= \p -> writeMutVar mt (insert a p m)+    Just n -> n b +-- | This may be useful for pragmatically accelerating a grouping structure by+-- preclassifying by a hash function+--+-- Semantically,+--+-- @+-- grouping = hashing <> grouping+-- @+hashing :: Hashable a => Group a+hashing = contramap hash grouping+ -------------------------------------------------------------------------------- -- * Unordered Discrimination (for partitioning) --------------------------------------------------------------------------------@@ -119,52 +133,17 @@ instance Grouping Void where   grouping = lose id -instance Grouping Word8 where-  grouping = contramap fromIntegral (groupingNat 256)--instance Grouping Word16 where-  grouping = divide (\x -> (fromIntegral (unsafeShiftR x 8), fromIntegral x .&. 0xff)) (groupingNat 256) (groupingNat 256)--instance Grouping Word32 where-  grouping = divide (\x -> ( (fromIntegral (unsafeShiftR x 24)        , fromIntegral (unsafeShiftR x 16) .&. 0xff)-                           , (fromIntegral (unsafeShiftR x 8) .&. 0xff, fromIntegral x                   .&. 0xff)-                           )-                    )-    (divide id (groupingNat 256) (groupingNat 256))-    (divide id (groupingNat 256) (groupingNat 256))--instance Grouping Word64 where-  grouping = divide (\x ->-      ( ( (fromIntegral (unsafeShiftR x 56)         , fromIntegral (unsafeShiftR x 48) .&. 0xff)-        , (fromIntegral (unsafeShiftR x 40) .&. 0xff, fromIntegral (unsafeShiftR x 32) .&. 0xff)-        ),-        ( (fromIntegral (unsafeShiftR x 24) .&. 0xff, fromIntegral (unsafeShiftR x 16) .&. 0xff)-        , (fromIntegral (unsafeShiftR x 8)  .&. 0xff, fromIntegral x                   .&. 0xff)-        )-      )-    )-    (divide id (divide id (groupingNat 256) (groupingNat 256)) (divide id (groupingNat 256) (groupingNat 256)))-    (divide id (divide id (groupingNat 256) (groupingNat 256)) (divide id (groupingNat 256) (groupingNat 256)))--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) (groupingNat 256)--instance Grouping Int16 where-  grouping = contramap (\x -> fromIntegral (x - minBound) :: Word16) grouping--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 Word8 where grouping = contramap fromIntegral groupingWord64+instance Grouping Word16 where grouping = contramap fromIntegral groupingWord64+instance Grouping Word32 where grouping = contramap fromIntegral groupingWord64+instance Grouping Word64 where grouping = groupingWord64+instance Grouping Word where grouping = contramap fromIntegral groupingWord64+instance Grouping Int8 where grouping = contramap fromIntegral groupingWord64+instance Grouping Int16 where grouping = contramap fromIntegral groupingWord64+instance Grouping Int32 where grouping = contramap fromIntegral groupingWord64+instance Grouping Int64 where grouping = contramap fromIntegral groupingWord64+instance Grouping Int where grouping = contramap fromIntegral groupingWord64+instance Grouping Char where grouping = contramap (fromIntegral . fromEnum) groupingWord64  instance Grouping Bool instance (Grouping a, Grouping b) => Grouping (a, b)@@ -208,7 +187,7 @@   k a ()   k b ()   n <- readMutVar rn-  return $ n == 2+  return $ n == 1 {-# INLINE groupingEq #-}  runGroup :: Group a -> [(a,b)] -> [[b]]@@ -237,7 +216,7 @@ -- -- This combinator still operates in linear time, at the expense of storing history. ----- The result equivalence classes are _not_ sorted, but the grouping is stable.+-- The result equivalence classes are __not__ sorted, but the grouping is stable. -- -- @ -- 'group' = 'groupWith' 'id'@@ -247,7 +226,7 @@  -- | /O(n)/. This is a replacement for 'GHC.Exts.groupWith' using discrimination. ----- The result equivalence classes are _not_ sorted, but the grouping is stable.+-- 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] 

@@ -0,0 +1,232 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DeriveDataTypeable #-}+--------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Edward Kmett 2015+-- License     : BSD-style+-- Maintainer  : Edward Kmett <ekmett@gmail.com>+-- Portability : non-portable+--+-- Small primitive boxed arrays+--+--------------------------------------------------------------------------------+module Data.Discrimination.Internal.SmallArray (+  SmallArray(..), SmallMutableArray(..),+  newSmallArray, readSmallArray, writeSmallArray, indexSmallArray, indexSmallArrayM,+  unsafeFreezeSmallArray, unsafeThawSmallArray, sameSmallMutableArray,+  copySmallArray, copySmallMutableArray,+  cloneSmallArray, cloneSmallMutableArray+) where++import Control.DeepSeq+import Control.Monad.Primitive+import Data.Foldable as Foldable+import GHC.Exts+import GHC.ST++-- | Boxed arrays+data SmallArray a = SmallArray (SmallArray# a)++-- | Mutable boxed arrays associated with a primitive state token.+data SmallMutableArray s a = SmallMutableArray (SmallMutableArray# s a)++-- | Create a new mutable array of the specified size and initialise all+-- elements with the given value.+newSmallArray :: PrimMonad m => Int -> a -> m (SmallMutableArray (PrimState m) a)+{-# INLINE newSmallArray #-}+newSmallArray (I# n#) x = primitive+   (\s# -> case newSmallArray# n# x s# of+             (# s'#, arr# #) -> (# s'#, SmallMutableArray arr# #))++-- | Read a value from the array at the given index.+readSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> m a+{-# INLINE readSmallArray #-}+readSmallArray (SmallMutableArray arr#) (I# i#) = primitive (readSmallArray# arr# i#)++-- | Write a value to the array at the given index.+writeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> Int -> a -> m ()+{-# INLINE writeSmallArray #-}+writeSmallArray (SmallMutableArray arr#) (I# i#) x = primitive_ (writeSmallArray# arr# i# x)++-- | Read a value from the immutable array at the given index.+indexSmallArray :: SmallArray a -> Int -> a+{-# INLINE indexSmallArray #-}+indexSmallArray (SmallArray arr#) (I# i#) = case indexSmallArray# arr# i# of (# x #) -> x++-- | Monadically read a value from the immutable array at the given index.+-- This allows us to be strict in the array while remaining lazy in the read+-- element which is very useful for collective operations. Suppose we want to+-- copy an array. We could do something like this:+--+-- > copy marr arr ... = do ...+-- >                        writeSmallArray marr i (indexSmallArray arr i) ...+-- >                        ...+--+-- But since primitive arrays are lazy, the calls to 'indexSmallArray' will not be+-- evaluated. Rather, @marr@ will be filled with thunks each of which would+-- retain a reference to @arr@. This is definitely not what we want!+--+-- With 'indexSmallArrayM', we can instead write+--+-- > copy marr arr ... = do ...+-- >                        x <- indexSmallArrayM arr i+-- >                        writeSmallArray marr i x+-- >                        ...+--+-- Now, indexing is executed immediately although the returned element is+-- still not evaluated.+--+indexSmallArrayM :: Monad m => SmallArray a -> Int -> m a+{-# INLINE indexSmallArrayM #-}+indexSmallArrayM (SmallArray arr#) (I# i#)+  = case indexSmallArray# arr# i# of (# x #) -> return x++-- | Convert a mutable array to an immutable one without copying. The+-- array should not be modified after the conversion.+unsafeFreezeSmallArray :: PrimMonad m => SmallMutableArray (PrimState m) a -> m (SmallArray a)+{-# INLINE unsafeFreezeSmallArray #-}+unsafeFreezeSmallArray (SmallMutableArray arr#)+  = primitive (\s# -> case unsafeFreezeSmallArray# arr# s# of+                        (# s'#, arr'# #) -> (# s'#, SmallArray arr'# #))++-- | Convert an immutable array to an mutable one without copying. The+-- immutable array should not be used after the conversion.+unsafeThawSmallArray :: PrimMonad m => SmallArray a -> m (SmallMutableArray (PrimState m) a)+{-# INLINE unsafeThawSmallArray #-}+unsafeThawSmallArray (SmallArray arr#)+  = primitive (\s# -> case unsafeThawSmallArray# arr# s# of+                        (# s'#, arr'# #) -> (# s'#, SmallMutableArray arr'# #))++-- | Check whether the two arrays refer to the same memory block.+sameSmallMutableArray :: SmallMutableArray s a -> SmallMutableArray s a -> Bool+{-# INLINE sameSmallMutableArray #-}+sameSmallMutableArray (SmallMutableArray arr#) (SmallMutableArray brr#)+  = isTrue# (sameSmallMutableArray# arr# brr#)++-- | Copy a slice of an immutable array to a mutable array.+copySmallArray :: PrimMonad m+          => SmallMutableArray (PrimState m) a    -- ^ destination array+          -> Int                             -- ^ offset into destination array+          -> SmallArray a                         -- ^ source array+          -> Int                             -- ^ offset into source array+          -> Int                             -- ^ number of elements to copy+          -> m ()+{-# INLINE copySmallArray #-}+copySmallArray (SmallMutableArray dst#) (I# doff#) (SmallArray src#) (I# soff#) (I# len#)+  = primitive_ (copySmallArray# src# soff# dst# doff# len#)++-- | Copy a slice of a mutable array to another array. The two arrays may+-- not be the same.+copySmallMutableArray :: PrimMonad m+          => SmallMutableArray (PrimState m) a    -- ^ destination array+          -> Int                             -- ^ offset into destination array+          -> SmallMutableArray (PrimState m) a    -- ^ source array+          -> Int                             -- ^ offset into source array+          -> Int                             -- ^ number of elements to copy+          -> m ()+{-# INLINE copySmallMutableArray #-}+-- NOTE: copySmallArray# and copySmallMutableArray# are slightly broken in GHC 7.6.* and earlier+copySmallMutableArray (SmallMutableArray dst#) (I# doff#)+                 (SmallMutableArray src#) (I# soff#) (I# len#)+  = primitive_ (copySmallMutableArray# src# soff# dst# doff# len#)++-- | Return a newly allocated SmallArray with the specified subrange of the+-- provided SmallArray. The provided SmallArray should contain the full subrange+-- specified by the two Ints, but this is not checked.+cloneSmallArray :: SmallArray a -- ^ source array+           -> Int     -- ^ offset into destination array+           -> Int     -- ^ number of elements to copy+           -> SmallArray a+{-# INLINE cloneSmallArray #-}+cloneSmallArray (SmallArray arr#) (I# off#) (I# len#) +  = case cloneSmallArray# arr# off# len# of arr'# -> SmallArray arr'#++-- | Return a newly allocated SmallMutableArray. with the specified subrange of+-- the provided SmallMutableArray. The provided SmallMutableArray should contain the+-- full subrange specified by the two Ints, but this is not checked.+cloneSmallMutableArray :: PrimMonad m+        => SmallMutableArray (PrimState m) a -- ^ source array+        -> Int                          -- ^ offset into destination array+        -> Int                          -- ^ number of elements to copy+        -> m (SmallMutableArray (PrimState m) a)+{-# INLINE cloneSmallMutableArray #-}+cloneSmallMutableArray (SmallMutableArray arr#) (I# off#) (I# len#) = primitive+   (\s# -> case cloneSmallMutableArray# arr# off# len# s# of+             (# s'#, arr'# #) -> (# s'#, SmallMutableArray arr'# #))++instance IsList (SmallArray a) where+  type Item (SmallArray a) = a+  toList = Foldable.toList+  fromListN n xs0 = runST $ do+    arr <- newSmallArray n undefined+    let go !_ []     = return ()+        go k (x:xs) = writeSmallArray arr k x >> go (k+1) xs+    go 0 xs0+    unsafeFreezeSmallArray arr+  fromList xs = fromListN (Prelude.length xs) xs++instance Functor SmallArray where+  fmap f !i = runST $ do+    let n = length i+    o <- newSmallArray n undefined+    let go !k+          | k == n = return ()+          | otherwise = do+            a <- indexSmallArrayM i k+            writeSmallArray o k (f a)+            go (k+1)+    go 0+    unsafeFreezeSmallArray o++instance Foldable SmallArray where+  foldr f z arr = go 0 where+    n = length arr+    go !k+      | k == n    = z+      | otherwise = f (indexSmallArray arr k) (go (k+1))++  foldl f z arr = go (length arr - 1) where+    go !k+      | k < 0 = z+      | otherwise = f (go (k-1)) (indexSmallArray arr k)++  foldr' f z arr = go 0 where+    n = length arr+    go !k+      | k == n    = z+      | r <- indexSmallArray arr k = r `seq` f r (go (k+1))++  foldl' f z arr = go (length arr - 1) where+    go !k+      | k < 0 = z+      | r <- indexSmallArray arr k = r `seq` f (go (k-1)) r++  length (SmallArray ary) = I# (sizeofSmallArray# ary)+  {-# INLINE length #-}++instance Traversable SmallArray where+  traverse f a = fromListN (length a) <$> traverse f (Foldable.toList a)++instance Show a => Show (SmallArray a) where+  showsPrec d as = showParen (d > 10) $+    showString "fromList " . showsPrec 11 (Foldable.toList as)++instance Read a => Read (SmallArray a) where+  readsPrec d = readParen (d > 10) $ \s -> [(fromList m, u) | ("fromList", t) <- lex s, (m,u) <- readsPrec 11 t]++instance Ord a => Ord (SmallArray a) where+  compare as bs = compare (Foldable.toList as) (Foldable.toList bs)++instance Eq a => Eq (SmallArray a) where+  as == bs = Foldable.toList as == Foldable.toList bs++instance NFData a => NFData (SmallArray a) where+  rnf a0 = go a0 (length a0) 0 where+    go !a !n !i+      | i >= n = ()+      | otherwise = rnf (indexSmallArray a i) `seq` go a n (i+1)+  {-# INLINE rnf #-}

@@ -0,0 +1,249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# 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 #-}+#endif+--------------------------------------------------------------------------------+-- |+-- Copyright   : (c) Edward Kmett 2015+-- License     : BSD-style+-- Maintainer  : Edward Kmett <ekmett@gmail.com>+-- Portability : non-portable+--+-- This module suppose a Word64-based array-mapped PATRICIA Trie.+--+-- The most significant nybble is isolated by using techniques based on+-- <https://www.fpcomplete.com/user/edwardk/revisiting-matrix-multiplication/part-4>+-- but modified to work nybble-by-nybble rather than bit-by-bit.+--+--------------------------------------------------------------------------------+module Data.Discrimination.Internal.WordMap+  ( WordMap+  , singleton+  , empty+  , insert+  , lookup+  , member+  , fromList+  ) where++import Control.Applicative hiding (empty)+import Control.DeepSeq+import Control.Monad.ST hiding (runST)+import Data.Bits+import Data.Discrimination.Internal.SmallArray+import Data.Foldable+import Data.Functor+import Data.Monoid+import Data.Traversable+import Data.Word+import qualified GHC.Exts as Exts+import Prelude hiding (lookup, length, foldr)+import GHC.Types+import GHC.ST++type Key = Word64+type Mask = Word16+type Offset = Int++ptrEq :: a -> a -> Bool+ptrEq x y = isTrue# (Exts.reallyUnsafePtrEquality# x y Exts.==# 1#)+{-# INLINEABLE ptrEq #-}++ptrNeq :: a -> a -> Bool+ptrNeq x y = isTrue# (Exts.reallyUnsafePtrEquality# x y Exts./=# 1#)+{-# INLINEABLE ptrNeq #-}++data WordMap v+  = Full !Key !Offset !(SmallArray (WordMap v))+  | Node !Key !Offset !Mask !(SmallArray (WordMap v))+  | Tip  !Key v+  | Nil+  deriving Show++node :: Key -> Offset -> Mask -> SmallArray (WordMap v) -> WordMap v+node k o 0xffff a = Full k o a+node k o m a      = Node k o m a+{-# INLINE node #-}++instance NFData v => NFData (WordMap v) where+  rnf (Full _ _ a)   = rnf a+  rnf (Node _ _ _ a) = rnf a+  rnf (Tip _ v) = rnf v+  rnf Nil = ()++instance Functor WordMap where+  fmap f = go where+    go (Full k o a) = Full k o (fmap go a)+    go (Node k o m a) = Node k o m (fmap go a)+    go (Tip k v) = Tip k (f v)+    go Nil = Nil+  {-# INLINEABLE fmap #-}++instance Foldable WordMap where+  foldMap f = go where+    go (Full _ _ a) = foldMap go a+    go (Node _ _ _ a) = foldMap go a+    go (Tip _ v) = f v+    go Nil = mempty+  {-# INLINEABLE foldMap #-}++instance Traversable WordMap where+  traverse f = go where+    go (Full k o a) = Full k o <$> traverse go a+    go (Node k o m a) = Node k o m <$> traverse go a+    go (Tip k v) = Tip k <$> f v+    go Nil = pure Nil+  {-# INLINEABLE traverse #-}++-- Note: 'level 0' will return a negative shift, don't use it+level :: Key -> Int+level w = 60 - (countLeadingZeros w .&. 0x7c)+{-# INLINE level #-}++maskBit :: Key -> Offset -> Int+maskBit k o = fromIntegral (unsafeShiftR k o .&. 0xf)+{-# INLINE maskBit #-}++mask :: Key -> Offset -> Word16+mask k o = unsafeShiftL 1 (maskBit k o)+{-# INLINE mask #-}++-- offset :: Int -> Word16 -> Int+-- offset k w = popCount $ w .&. (unsafeShiftL 1 k - 1)+-- {-# INLINE offset #-}++fork :: Int -> Key -> WordMap v -> Key -> WordMap v -> WordMap v+fork o k n ok on = Node (k .&. unsafeShiftL 0xfffffffffffffff0 o) o (mask k o .|. mask ok o) $ runST $ do+  arr <- newSmallArray 2 n+  writeSmallArray arr (fromEnum (k < ok)) on+  unsafeFreezeSmallArray arr++insert :: Key -> v -> WordMap v -> WordMap v+insert !k v xs0 = go xs0 where+  go on@(Full ok n as)+    | wd > 0xf = fork (level okk) k (Tip k v) ok on+    | !oz <- indexSmallArray as d+    , !z <- go oz+    , ptrNeq z oz = Full ok n (update16 d z as)+    | otherwise = on+    where+      okk = xor ok k+      wd  = unsafeShiftR okk n+      d   = fromIntegral wd+  go on@(Node ok n m as)+    | wd > 0xf = fork (level okk) k (Tip k v) ok on+    | m .&. b == 0 = node ok n (m .|. b) (insertSmallArray odm (Tip k v) as)+    | !oz <- indexSmallArray as odm+    , !z <- go oz+    , ptrNeq z oz = Node ok n m (updateSmallArray odm z as)+    | otherwise = on+    where+      okk = xor ok k+      wd  = unsafeShiftR okk n+      d   = fromIntegral wd+      b   = unsafeShiftL 1 d+      odm = popCount $ m .&. (b - 1)+  go on@(Tip ok ov)+    | k /= ok    = fork (level (xor ok k)) k (Tip k v) ok on+    | ptrEq v ov = on+    | otherwise  = Tip k v+  go Nil = Tip k v+{-# INLINEABLE insert #-}+++lookup :: Key -> WordMap v -> Maybe v+lookup !k (Full ok o a)+  | z <- unsafeShiftR (xor k ok) o, z <= 0xf = lookup k $ indexSmallArray a (fromIntegral z)+  | otherwise = Nothing+lookup k (Node ok o m a)+  | z <= 0xf && m .&. b /= 0 = lookup k (indexSmallArray a (popCount (m .&. (b - 1))))+  | otherwise = Nothing+  where+    z = unsafeShiftR (xor k ok) o+    b = unsafeShiftL 1 (fromIntegral z)+lookup k (Tip ok ov)+  | k == ok   = Just ov+  | otherwise = Nothing+lookup _ Nil = Nothing+{-# INLINEABLE lookup #-}++member :: Key -> WordMap v -> Bool+member !k (Full ok o a)+  | z <- unsafeShiftR (xor k ok) o = z <= 0xf && member k (indexSmallArray a (fromIntegral z))+member k (Node ok o m a)+  | z <- unsafeShiftR (xor k ok) o+  = z <= 0xf && let b = unsafeShiftL 1 (fromIntegral z) in+    m .&. b /= 0 && member k (indexSmallArray a (popCount (m .&. (b - 1))))+member k (Tip ok _) = k == ok+member _ Nil = False+{-# INLINEABLE member #-}++updateSmallArray :: Int -> a -> SmallArray a -> SmallArray a+updateSmallArray !k a i = runST $ do+  let n = length i+  o <- newSmallArray n undefined+  copySmallArray o 0 i 0 n+  writeSmallArray o k a+  unsafeFreezeSmallArray o+{-# INLINEABLE updateSmallArray #-}++update16 :: Int -> a -> SmallArray a -> SmallArray a+update16 !k a i = runST $ do+  o <- clone16 i+  writeSmallArray o k a+  unsafeFreezeSmallArray o+{-# INLINEABLE update16 #-}++insertSmallArray :: Int -> a -> SmallArray a -> SmallArray a+insertSmallArray !k a i = runST $ do+  let n = length i+  o <- newSmallArray (n + 1) a+  copySmallArray  o 0 i 0 k+  copySmallArray  o (k+1) i k (n-k)+  unsafeFreezeSmallArray o+{-# INLINEABLE insertSmallArray #-}++clone16 :: SmallArray a -> ST s (SmallMutableArray s a)+clone16 i = do+  o <- newSmallArray 16 undefined+  indexSmallArrayM i 0 >>= writeSmallArray o 0+  indexSmallArrayM i 1 >>= writeSmallArray o 1+  indexSmallArrayM i 2 >>= writeSmallArray o 2+  indexSmallArrayM i 3 >>= writeSmallArray o 3+  indexSmallArrayM i 4 >>= writeSmallArray o 4+  indexSmallArrayM i 5 >>= writeSmallArray o 5+  indexSmallArrayM i 6 >>= writeSmallArray o 6+  indexSmallArrayM i 7 >>= writeSmallArray o 7+  indexSmallArrayM i 8 >>= writeSmallArray o 8+  indexSmallArrayM i 9 >>= writeSmallArray o 9+  indexSmallArrayM i 10 >>= writeSmallArray o 10+  indexSmallArrayM i 11 >>= writeSmallArray o 11+  indexSmallArrayM i 12 >>= writeSmallArray o 12+  indexSmallArrayM i 13 >>= writeSmallArray o 13+  indexSmallArrayM i 14 >>= writeSmallArray o 14+  indexSmallArrayM i 15 >>= writeSmallArray o 15+  return o+{-# INLINE clone16 #-}++-- | Build a singleton WordMap+singleton :: Key -> v -> WordMap v+singleton !k v = Tip k v+{-# INLINE singleton #-}++fromList :: [(Word64,v)] -> WordMap v+fromList xs = foldl' (\r (k,v) -> insert k v r) Nil xs+{-# INLINE fromList #-}++empty :: WordMap a+empty = Nil+{-# INLINE empty #-}

@@ -2,7 +2,6 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE RoleAnnotations #-}@@ -51,8 +50,8 @@ 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.Semigroup hiding (Any) import Data.Set as Set import Data.Typeable import Data.Void@@ -84,14 +83,17 @@  instance Decidable Sort where   lose k = Sort $ fmap (absurd.k.fst)-  choose f (Sort l) (Sort r) = Sort $ \xs -> let +  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 Semigroup (Sort a) where+  Sort l <> Sort r = Sort $ \xs -> l [ (fst x, x) | x <- xs ] >>= r+ instance Monoid (Sort a) where   mempty = conquer-  mappend (Sort l) (Sort r) = Sort $ \xs -> l [ (fst x, x) | x <- xs ] >>= r+  mappend = (<>)  -------------------------------------------------------------------------------- -- * Ordered Discrimination@@ -150,6 +152,11 @@ instance Sorting Int where   sorting = contramap (\x -> fromIntegral (x - minBound) :: Word) sorting +instance Sorting Char where+  sorting = Sort (runs <=< runSort (sortingNat 1087) . join . runSort (sortingNat 1024) . fmap radices) where+    radices (c,b) = (x .&. 0x3ff, (unsafeShiftR x 10, (x,b))) where+      x = fromEnum c+ -- TODO: Integer and Natural?  instance Sorting Void@@ -239,7 +246,7 @@ 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. +-- | /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]