diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +- 0.2.2 + - Add `Data.HashSet.InsOrd` + - 0.2.1.0 - Fix `Traversable`, `TraversableWithIndex`, `FoldableWithIndex` to traverse in insertion order diff --git a/insert-ordered-containers.cabal b/insert-ordered-containers.cabal --- a/insert-ordered-containers.cabal +++ b/insert-ordered-containers.cabal @@ -1,56 +1,76 @@ -name: insert-ordered-containers -version: 0.2.1.0 -synopsis: Associative containers retating insertion order for traversals. -description: Associative containers retating insertion order for traversals. -category: Web -homepage: https://github.com/phadej/insert-ordered-containers#readme -bug-reports: https://github.com/phadej/insert-ordered-containers/issues -author: Oleg Grenrus -maintainer: Oleg Grenrus -license: BSD3 -license-file: LICENSE -tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 -build-type: Simple -cabal-version: >= 1.10 +name: insert-ordered-containers +version: 0.2.2 +synopsis: + Associative containers retaining insertion order for traversals. +description: + Associative containers retaining insertion order for traversals. + . + The implementation is based on `unordered-containers`. + +category: Web +homepage: https://github.com/phadej/insert-ordered-containers#readme +bug-reports: https://github.com/phadej/insert-ordered-containers/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >=1.10 +tested-with: + GHC==7.6.3, + GHC==7.8.4, + GHC==7.10.3, + GHC==8.0.1, + GHC==8.2.2, + GHC==8.4.4, + GHC==8.6.5, + GHC==8.8.1 + extra-source-files: - CHANGELOG.md - README.md + CHANGELOG.md + README.md source-repository head - type: git + type: git location: https://github.com/phadej/insert-ordered-containers library - hs-source-dirs: - src - ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall build-depends: - base >=4.6 && <4.10 - , aeson >=1.0.0.0 && <1.2 - , base-compat >=0.6.0 && <0.10 - , hashable >=1.2.3.3 && <1.4 - , lens >=4.7 && <4.16 - , semigroupoids >=4.3 && <5.2 - , semigroups >=0.16.2.2 && <0.19 - , text >=1.2.0.6 && <1.3 + aeson >=1.4.2.0 && <1.5 + , base >=4.6 && <4.13 + , base-compat >=0.10.5 && <0.11 + , hashable >=1.2.6.1 && <1.4 + , lens >=4.17 && <4.18 + , semigroupoids >=5.3.2 && <5.4 + , semigroups >=0.18.5 && <0.20 + , text >=1.2.3.0 && <1.3 , transformers >=0.3.0.0 && <0.6 - , unordered-containers >=0.2.7.0 && <0.3 + , unordered-containers >=0.2.8.0 && <0.3 + exposed-modules: - Data.HashMap.Strict.InsOrd - default-language: Haskell2010 + Data.HashMap.Strict.InsOrd + Data.HashSet.InsOrd + other-modules: Data.HashMap.InsOrd.Internal + test-suite ins-ord-containers-tests - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: - test - ghc-options: -Wall + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: test + ghc-options: -Wall + + -- inherited from library build-depends: - base - , aeson + aeson + , base , base-compat , hashable + , insert-ordered-containers , lens , semigroupoids , semigroups @@ -59,7 +79,7 @@ , unordered-containers , base , insert-ordered-containers - , tasty >= 0.10.1.2 && <0.12 - , tasty-quickcheck >= 0.8.3.2 && <0.9 - , QuickCheck >=2.7.6 && <2.10 - default-language: Haskell2010 + , tasty >= 0.10.1.2 && <1.3 + , tasty-quickcheck >= 0.8.3.2 && <0.11 + , QuickCheck >=2.7.6 && <2.14 + diff --git a/src/Data/HashMap/InsOrd/Internal.hs b/src/Data/HashMap/InsOrd/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashMap/InsOrd/Internal.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE GADTs #-} +module Data.HashMap.InsOrd.Internal where + +import Prelude () +import Prelude.Compat hiding (filter, foldr, lookup, map, null) + +import Control.Applicative ((<**>)) + +------------------------------------------------------------------------------- +-- SortedAp +------------------------------------------------------------------------------- + +-- Sort using insertion sort +-- Hopefully it's fast enough for where we need it +-- otherwise: https://gist.github.com/treeowl/9621f58d55fe0c4f9162be0e074b1b29 +-- http://elvishjerricco.github.io/2017/03/23/applicative-sorting.html also related + +-- Free applicative which re-orders effects +-- Mostly from Edward Kmett's `free` package. +data SortedAp f a where + Pure :: a -> SortedAp f a + SortedAp :: !Int -> f a -> SortedAp f (a -> b) -> SortedAp f b + +instance Functor (SortedAp f) where + fmap f (Pure a) = Pure (f a) + fmap f (SortedAp i x y) = SortedAp i x ((f .) <$> y) + +instance Applicative (SortedAp f) where + pure = Pure + Pure f <*> y = fmap f y + -- This is different from real Ap + f <*> Pure y = fmap ($ y) f + f@(SortedAp i x y) <*> z@(SortedAp j u v) + | i < j = SortedAp i x (flip <$> y <*> z) + | otherwise = SortedAp j u ((.) <$> f <*> v) + +liftSortedAp :: Int -> f a -> SortedAp f a +liftSortedAp i x = SortedAp i x (Pure id) + +retractSortedAp :: Applicative f => SortedAp f a -> f a +retractSortedAp (Pure x) = pure x +retractSortedAp (SortedAp _ f x) = f <**> retractSortedAp x diff --git a/src/Data/HashMap/Strict/InsOrd.hs b/src/Data/HashMap/Strict/InsOrd.hs --- a/src/Data/HashMap/Strict/InsOrd.hs +++ b/src/Data/HashMap/Strict/InsOrd.hs @@ -84,7 +84,7 @@ import Prelude () import Prelude.Compat hiding (filter, foldr, lookup, map, null) -import Control.Applicative (Const (..), (<**>)) +import Control.Applicative (Const (..)) import Control.Arrow (first, second) import Data.Aeson import qualified Data.Aeson.Encoding as E @@ -114,6 +114,8 @@ import qualified GHC.Exts as Exts #endif +import Data.HashMap.InsOrd.Internal + ------------------------------------------------------------------------------- -- Strict Pair Int a ------------------------------------------------------------------------------- @@ -419,37 +421,6 @@ traverseWithKey :: Applicative f => (k -> a -> f b) -> InsOrdHashMap k a -> f (InsOrdHashMap k b) traverseWithKey f (InsOrdHashMap n m) = InsOrdHashMap n <$> retractSortedAp (HashMap.traverseWithKey (\k (P i v) -> liftSortedAp i (P i <$> f k v)) m) - --- Sort using insertion sort --- Hopefully it's fast enough for where we need it --- otherwise: https://gist.github.com/treeowl/9621f58d55fe0c4f9162be0e074b1b29 --- http://elvishjerricco.github.io/2017/03/23/applicative-sorting.html also related - --- Free applicative which re-orders effects --- Mostly from Edward Kmett's `free` package. -data SortedAp f a where - Pure :: a -> SortedAp f a - SortedAp :: !Int -> f a -> SortedAp f (a -> b) -> SortedAp f b - -instance Functor (SortedAp f) where - fmap f (Pure a) = Pure (f a) - fmap f (SortedAp i x y) = SortedAp i x ((f .) <$> y) - -instance Applicative (SortedAp f) where - pure = Pure - Pure f <*> y = fmap f y - -- This is different from real Ap - f <*> Pure y = fmap ($ y) f - f@(SortedAp i x y) <*> z@(SortedAp j u v) - | i < j = SortedAp i x (flip <$> y <*> z) - | otherwise = SortedAp j u ((.) <$> f <*> v) - -liftSortedAp :: Int -> f a -> SortedAp f a -liftSortedAp i x = SortedAp i x (Pure id) - -retractSortedAp :: Applicative f => SortedAp f a -> f a -retractSortedAp (Pure x) = pure x -retractSortedAp (SortedAp _ f x) = f <**> retractSortedAp x ------------------------------------------------------------------------------- -- Unordered diff --git a/src/Data/HashSet/InsOrd.hs b/src/Data/HashSet/InsOrd.hs new file mode 100644 --- /dev/null +++ b/src/Data/HashSet/InsOrd.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +-- | 'InsOrdHashSet' is like 'HashMap', but it folds in insertion order. +-- +-- This module interface mimics "Data.HashSet", with some additions. +module Data.HashSet.InsOrd ( + InsOrdHashSet, + -- * Construction + empty, + singleton, + -- * Basic interface + null, + size, + member, + insert, + delete, + -- * Combine + union, + -- * Transformations + map, + -- ** Unordered + -- * Difference and intersection + difference, + intersection, + -- * Folds + -- ** Unordered + -- * Filter + filter, + -- * Conversions + toList, + fromList, + toHashSet, + fromHashSet, + -- * Lenses + hashSet, + -- * Debugging + valid, + )where + +import Prelude () +import Prelude.Compat hiding (filter, foldr, lookup, map, null) + +import Control.Arrow (first) +import Data.Aeson +import Data.Data (Data, Typeable) +import Data.Hashable (Hashable (..)) +import Data.List (nub, sortBy) +import Data.Ord (comparing) +import Data.Semigroup (Semigroup (..)) +import Text.ParserCombinators.ReadPrec (prec) +import Text.Read + (Lexeme (..), Read (..), lexP, parens, readListPrecDefault) + +import Control.Lens + (At (..), Contains (..), Index, Iso', IxValue, Ixed (..), iso, (<&>)) +import Control.Monad.Trans.State.Strict (State, runState, state) + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +#if MIN_VERSION_base(4,7,0) +import qualified GHC.Exts as Exts +#endif + +#if MIN_VERSION_base(4,8,0) +import qualified Data.Foldable +#endif + +import Data.HashMap.InsOrd.Internal + +------------------------------------------------------------------------------- +-- InsOrdHashSet +------------------------------------------------------------------------------- + +-- | 'HashSet' which tries it's best to remember insertion order of elements. + +data InsOrdHashSet k = InsOrdHashSet + { _getIndex :: !Int + , getInsOrdHashSet :: !(HashMap k Int) + } + deriving (Typeable, Data) + +instance Eq k => Eq (InsOrdHashSet k) where + InsOrdHashSet _ a == InsOrdHashSet _ b = a == b + +instance Show k => Show (InsOrdHashSet k) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . showsPrec 11 (toList m) + +instance (Eq k, Hashable k, Read k) => Read (InsOrdHashSet k) where + readPrec = parens $ prec 10 $ do + Ident "fromList" <- lexP + xs <- readPrec + return (fromList xs) + + readListPrec = readListPrecDefault + +instance (Eq k, Hashable k) => Semigroup (InsOrdHashSet k) where + (<>) = union + +instance (Eq k, Hashable k) => Monoid (InsOrdHashSet k) where + mempty = empty + mappend = union + +instance Foldable InsOrdHashSet where + -- in newer base only + -- length = length . getInsOrdHashSet + foldMap f = foldMap f . toList + +#if MIN_VERSION_base(4,8,0) + null = null + toList = toList + length = size +#endif + +-- | @'hashWithSalt' salt . 'toHashSet' = 'hashWithSalt' salt@. +instance Hashable k => Hashable (InsOrdHashSet k) where + hashWithSalt salt (InsOrdHashSet _ m) = + hashWithSalt salt m + +#if MIN_VERSION_base(4,7,0) +instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashSet k) where + type Item (InsOrdHashSet k) = k + fromList = fromList + toList = toList +#endif + +------------------------------------------------------------------------------- +-- Aeson +------------------------------------------------------------------------------- + +instance ToJSON a => ToJSON (InsOrdHashSet a) where + toJSON = toJSON . toList + toEncoding = toEncoding . toList + +instance (Eq a, Hashable a, FromJSON a) => FromJSON (InsOrdHashSet a) where + parseJSON v = fromList <$> parseJSON v + +------------------------------------------------------------------------------- +-- Lens +------------------------------------------------------------------------------- + +type instance Index (InsOrdHashSet a) = a +type instance IxValue (InsOrdHashSet a) = () + +instance (Eq k, Hashable k) => Ixed (InsOrdHashSet k) where + ix k f (InsOrdHashSet i m) = InsOrdHashSet i <$> ix k (\j -> j <$ f ()) m + {-# INLINE ix #-} + +instance (Eq k, Hashable k) => At (InsOrdHashSet k) where + at k f m = f mv <&> \r -> case r of + Nothing -> maybe m (const (delete k m)) mv + Just () -> insert k m + where mv = if member k m then Just () else Nothing + {-# INLINE at #-} + +instance (Eq a, Hashable a) => Contains (InsOrdHashSet a) where + contains k f s = f (member k s) <&> \b -> + if b then insert k s else delete k s + {-# INLINE contains #-} + +-- | This is a slight lie, as roundtrip doesn't preserve ordering. +hashSet :: Iso' (InsOrdHashSet a) (HashSet a) +hashSet = iso toHashSet fromHashSet + +------------------------------------------------------------------------------- +-- Construction +------------------------------------------------------------------------------- + +empty :: InsOrdHashSet k +empty = InsOrdHashSet 0 HashMap.empty +{-# INLINABLE empty #-} + +singleton :: Hashable k => k -> InsOrdHashSet k +singleton k = InsOrdHashSet 1 (HashMap.singleton k 0) +{-# INLINABLE singleton #-} + +------------------------------------------------------------------------------- +-- Basic interface +------------------------------------------------------------------------------- + +null :: InsOrdHashSet k -> Bool +null = HashMap.null . getInsOrdHashSet +{-# INLINABLE null #-} + +size :: InsOrdHashSet k -> Int +size = HashMap.size . getInsOrdHashSet +{-# INLINABLE size #-} + +member :: (Eq k, Hashable k) => k -> InsOrdHashSet k -> Bool +member k = HashMap.member k . getInsOrdHashSet +{-# INLINABLE member #-} + +insert :: (Eq k, Hashable k) => k -> InsOrdHashSet k -> InsOrdHashSet k +insert k (InsOrdHashSet i m) = InsOrdHashSet (i + 1) (HashMap.insert k i m) + +delete :: (Eq k, Hashable k) => k -> InsOrdHashSet k -> InsOrdHashSet k +delete k (InsOrdHashSet i m) = InsOrdHashSet i (HashMap.delete k m) + +------------------------------------------------------------------------------- +-- Combine +------------------------------------------------------------------------------- + +union + :: (Eq k, Hashable k) + => InsOrdHashSet k -> InsOrdHashSet k -> InsOrdHashSet k +union (InsOrdHashSet i a) (InsOrdHashSet j b) = + mk $ HashMap.union a b' + where + mk | i >= 0xfffff || j >= 0xfffff = fromHashMapInt + | otherwise = InsOrdHashSet (i + j) + + b' = fmap (\k -> k + i + 1) b + +------------------------------------------------------------------------------- +-- Transformations +------------------------------------------------------------------------------- + +map :: (Hashable b, Eq b) => (a -> b) -> InsOrdHashSet a -> InsOrdHashSet b +map f (InsOrdHashSet i m) = InsOrdHashSet i + $ HashMap.fromList . fmap (first f) . HashMap.toList + $ m + +------------------------------------------------------------------------------- +-- Difference and intersection +------------------------------------------------------------------------------- + +difference :: (Eq a, Hashable a) => InsOrdHashSet a -> InsOrdHashSet a -> InsOrdHashSet a +difference (InsOrdHashSet i a) (InsOrdHashSet _ b) = + InsOrdHashSet i $ HashMap.difference a b + +intersection :: (Eq a, Hashable a) => InsOrdHashSet a -> InsOrdHashSet a -> InsOrdHashSet a +intersection (InsOrdHashSet i a) (InsOrdHashSet _ b) = + InsOrdHashSet i $ HashMap.intersection a b + +------------------------------------------------------------------------------- +-- Filter +------------------------------------------------------------------------------- + +filter :: (a -> Bool) -> InsOrdHashSet a -> InsOrdHashSet a +filter p (InsOrdHashSet i m) = InsOrdHashSet i $ + HashMap.filterWithKey (\k _ -> p k) m + +------------------------------------------------------------------------------- +-- Conversions +------------------------------------------------------------------------------- + +fromList :: (Eq k, Hashable k) => [k] -> InsOrdHashSet k +fromList = mk . flip runState 0 . traverse newInt where + mk (m, i) = InsOrdHashSet i (HashMap.fromList m) + +toList :: InsOrdHashSet k -> [k] +toList + = fmap fst + . sortBy (comparing snd) + . HashMap.toList + . getInsOrdHashSet + +fromHashSet :: HashSet k -> InsOrdHashSet k +fromHashSet = mk . flip runState 0 . traverse (const newInt') . HashSet.toMap where + mk (m, i) = InsOrdHashSet i m + +toHashSet :: InsOrdHashSet k -> HashSet k +toHashSet (InsOrdHashSet _ m) = +#if MIN_VERSION_unordered_containers(0,2,10) + HashMap.keysSet m +#else + HashSet.fromMap (fmap (const ()) m) +#endif + +------------------------------------------------------------------------------- +-- Internal +------------------------------------------------------------------------------- + +fromHashMapInt :: HashMap k Int -> InsOrdHashSet k +fromHashMapInt = mk . flip runState 0 . retractSortedAp . traverse f + where + mk (m, i) = InsOrdHashSet i m + f i = liftSortedAp i newInt' + +newInt :: a -> State Int (a, Int) +newInt a = state $ \s -> ((a, s), s + 1) + +newInt' :: State Int Int +newInt' = state $ \s -> (s, s + 1) + +------------------------------------------------------------------------------- +-- Valid +------------------------------------------------------------------------------- + +-- | Test if the internal map structure is valid. +valid :: InsOrdHashSet a -> Bool +valid (InsOrdHashSet i m) = indexesDistinct && indexesSmaller + where + indexes :: [Int] + indexes = HashMap.elems m + + indexesDistinct = indexes == nub indexes + indexesSmaller = all (< i) indexes