diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,42 @@ +- 0.3.0 + - Fix ordering when decoding from JSON (with tests) + https://github.com/erikd/insert-ordered-containers/issues/7 + This is a breaking change. + - GHC-9.14.1 support + +- 0.2.7 + - Support GHC-8.6.5...9.12.1 + - Haskell code modernisation + +- 0.2.6 + - Support GHC-8.6.5...9.10.1 + +- 0.2.5.3 + - Support `aeson-2.2` + - Make `Prelude` import explicit (safe guard against additions to `Prelude`). + +- 0.2.5.2 + - Actually drop `semigroups` dependency + - Update bounds + +- 0.2.5.1 + - Drop unnecessary dependencies `semigroups`, `base-compat` + - Update bounds + +- 0.2.5 + - Add `NFData(/1/2)` instances + +- 0.2.4 + - Add `indexed-traversable` instances + - lens-5 and optics-0.4 support + +- 0.2.3 + - Add support for indexed `optics` + - Only support GHC-8.0+ + +- 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,65 +1,82 @@ -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 +cabal-version: 2.2 +name: insert-ordered-containers +version: 0.3.0 +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/erikd/insert-ordered-containers#readme +bug-reports: https://github.com/erikd/insert-ordered-containers/issues +author: Oleg Grenrus +maintainer: Erik de Castro Lopo , Oleg Grenrus +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +tested-with: + GHC ==8.6.5 + || ==8.8.4 + || ==8.10.7 + || ==9.0.2 + || ==9.2.8 + || ==9.4.8 + || ==9.6.7 + || ==9.8.4 + || ==9.10.3 + || ==9.12.2 + || ==9.14.1 + extra-source-files: - CHANGELOG.md - README.md + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/phadej/insert-ordered-containers + type: git + location: https://github.com/erikd/insert-ordered-containers library - hs-source-dirs: - src - ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -Wunused-packages 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 - , transformers >=0.3.0.0 && <0.6 - , unordered-containers >=0.2.7.0 && <0.3 + , aeson >=2.2.3.0 && <2.3 + , base >=4.12.0.0 && <4.23 + , deepseq >=1.4.4.0 && <1.6 + , hashable >=1.4.7.0 && <1.6 + , indexed-traversable >=0.1.4 && <0.2 + , lens >=5.2.3 && <5.4 + , optics-core >=0.4.1.1 && <0.5 + , optics-extra >=0.4.2.1 && <0.5 + , semigroupoids >=6.0.1 && <6.1 + , transformers >=0.5.6.2 && <0.7 + , unordered-containers >=0.2.20 && <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 + , base , base-compat , hashable + , insert-ordered-containers , lens - , semigroupoids - , semigroups - , text - , transformers + , QuickCheck >=2.13.2 && <2.19 + , tasty >=0.10.1.2 && <1.6 + , tasty-quickcheck >=0.8.3.2 && <0.12 , 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 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,41 @@ +{-# LANGUAGE GADTs #-} +module Data.HashMap.InsOrd.Internal where + +import Prelude 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} @@ -77,50 +76,67 @@ valid, ) where -#ifndef MIN_VERSION_aeson -#define MIN_VERSION_aeson(x,y,z) 0 -#endif - -import Prelude () -import Prelude.Compat hiding (filter, foldr, lookup, map, null) +import Prelude + (Bool (..), Eq, Functor, Int, Maybe (..), all, const, flip, fmap, fst, + id, maybe, otherwise, pure, return, snd, uncurry, ($), (&&), (+), (.), + (<$>), (<), (==), (>), (>=), (>>=), (||)) -import Control.Applicative (Const (..), (<**>)) -import Control.Arrow (first, second) -import Data.Aeson -import qualified Data.Aeson.Encoding as E -import Data.Data (Data, Typeable) -import qualified Data.Foldable as F -import Data.Functor.Apply (Apply (..)) -import Data.Functor.Bind (Bind (..)) -import Data.Hashable (Hashable (..)) -import Data.List (nub, sortBy) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Semigroup (Semigroup (..)) -import Text.ParserCombinators.ReadPrec (prec) -import Text.Read (Lexeme (..), Read (..), lexP, - parens, readListPrecDefault) +import Control.Applicative (Applicative, Const (..)) +import Control.Arrow (first, second) +import Control.DeepSeq (NFData (..)) +import Data.Data (Data) +import Data.Foldable (Foldable (foldMap)) +import Data.Foldable.WithIndex (FoldableWithIndex (..)) +import Data.Functor.Apply (Apply (..)) +import Data.Functor.Bind (Bind (..)) +import Data.Functor.WithIndex (FunctorWithIndex (..)) +import Data.Hashable (Hashable (..)) +import Data.List (nub, sortBy) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid, mempty) +import Data.Ord (comparing) +import Data.Semigroup (Semigroup (..)) +import Data.Traversable (Traversable (traverse)) +import Data.Traversable.WithIndex (TraversableWithIndex (..)) +import Text.ParserCombinators.ReadPrec (prec) +import Text.Read + (Lexeme (..), Read (..), lexP, parens, readListPrecDefault) +import Text.Show (Show (..), showParen, showString) -import Control.Lens (At (..), FoldableWithIndex (..), - FunctorWithIndex (..), Index, Iso, IxValue, - Ixed (..), TraversableWithIndex (..), - Traversal, iso, (<&>), _1, _2) +import Control.Lens + (At (..), Index, Iso, IxValue, Ixed (..), Traversal, _1, _2, iso, (<&>)) import Control.Monad.Trans.State.Strict (State, runState, state) +import qualified Control.Lens as Lens +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import qualified Data.Foldable as F +import qualified Optics.At as Optics +import qualified Optics.Core as Optics + import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -#if MIN_VERSION_base(4,7,0) import qualified GHC.Exts as Exts -#endif +import qualified Control.DeepSeq as NF + +import Data.HashMap.InsOrd.Internal + ------------------------------------------------------------------------------- -- Strict Pair Int a ------------------------------------------------------------------------------- data P a = P !Int !a - deriving (Functor, Foldable, Traversable, Typeable, Data) + deriving (Functor, Foldable, Traversable, Data) +instance NFData a => NFData (P a) where + rnf (P _ a) = rnf a + +-- | @since 0.2.5 +instance NF.NFData1 P where + liftRnf rnf1 (P _ a) = rnf1 a + getPK :: P a -> Int getPK (P i _) = i {-# INLINABLE getPK #-} @@ -146,16 +162,28 @@ -- InsOrdHashMap ------------------------------------------------------------------------------- --- | 'HashMap' which tries it's best to remember insertion order of elements. +-- | 'HashMap' which tries its best to remember insertion order of elements. data InsOrdHashMap k v = InsOrdHashMap { _getIndex :: !Int , getInsOrdHashMap :: !(HashMap k (P v)) } - deriving (Functor, Typeable, Data) + deriving (Functor, Data) +-- | @since 0.2.5 +instance (NFData k, NFData v) => NFData (InsOrdHashMap k v) where + rnf (InsOrdHashMap _ hm) = rnf hm + +-- | @since 0.2.5 +instance NFData k => NF.NFData1 (InsOrdHashMap k) where + liftRnf rnf2 = NF.liftRnf2 rnf rnf2 + +-- | @since 0.2.5 +instance NF.NFData2 InsOrdHashMap where + liftRnf2 rnf1 rnf2 (InsOrdHashMap _ m) = NF.liftRnf2 rnf1 (NF.liftRnf rnf2) m + instance (Eq k, Eq v) => Eq (InsOrdHashMap k v) where - InsOrdHashMap _ a == InsOrdHashMap _ b = a == b + a == b = toList a == toList b instance (Show k, Show v) => Show (InsOrdHashMap k v) where showsPrec d m = showParen (d > 10) $ @@ -174,7 +202,6 @@ instance (Eq k, Hashable k) => Monoid (InsOrdHashMap k v) where mempty = empty - mappend = union -- We cannot derive this, as we want to ordered folding and traversing instance Foldable (InsOrdHashMap k) where @@ -182,11 +209,9 @@ -- length = length . getInsOrdHashMap foldMap f = foldMap (f . snd) . toList -#if MIN_VERSION_base(4,8,0) null = null toList = elems length = size -#endif instance Traversable (InsOrdHashMap k) where traverse f m = traverseWithKey (\_ -> f) m @@ -204,39 +229,61 @@ hashWithSalt salt (InsOrdHashMap _ m) = hashWithSalt salt m -#if MIN_VERSION_base(4,7,0) instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashMap k v) where type Item (InsOrdHashMap k v) = (k, v) fromList = fromList toList = toList -#endif ------------------------------------------------------------------------------- -- Aeson ------------------------------------------------------------------------------- -instance (ToJSONKey k) => ToJSON1 (InsOrdHashMap k) where - liftToJSON t _ = case toJSONKey :: ToJSONKeyFunction k of - ToJSONKeyText f _ -> object . fmap (\(k, v) -> (f k, t v)) . toList - ToJSONKeyValue f _ -> toJSON . fmap (\(k,v) -> toJSON (f k, t v)) . toList +instance A.ToJSON2 InsOrdHashMap where + liftToJSON2 omitKey encodeKey encodeKeyList omitVal encodeVal encodeValList = + A.liftToJSON omitNothing encodeKVPair encodeKVPairList . toList + where + omitNothing _ = False + encodeKVPair = A.liftToJSON2 omitKey encodeKey encodeKeyList omitVal encodeVal encodeValList + encodeKVPairList = A.listValue encodeKVPair + liftToEncoding2 omitKey encodeKey encodeKeyList omitVal encodeVal encodeValList = + A.liftToEncoding omitNothing encodeKVPair encodeKVPairList . toList + where + omitNothing _ = False + encodeKVPair = A.liftToEncoding2 omitKey encodeKey encodeKeyList omitVal encodeVal encodeValList + encodeKVPairList = A.listEncoding encodeKVPair - liftToEncoding t _ = case toJSONKey :: ToJSONKeyFunction k of - ToJSONKeyText _ f -> E.dict f t foldrWithKey - ToJSONKeyValue _ f -> E.list (liftToEncoding2 f (E.list f) t (E.list t)) . toList +instance (A.ToJSON k) => A.ToJSON1 (InsOrdHashMap k) where + liftToJSON = A.liftToJSON2 A.omitField A.toJSON A.toJSONList + liftToEncoding = A.liftToEncoding2 A.omitField A.toEncoding A.toEncodingList -instance (ToJSONKey k, ToJSON v) => ToJSON (InsOrdHashMap k v) where - toJSON = toJSON1 - toEncoding = toEncoding1 +instance (A.ToJSON k, A.ToJSON v) => A.ToJSON (InsOrdHashMap k v) where + toJSON = A.toJSON1 + toEncoding = A.toEncoding1 ------------------------------------------------------------------------------- -instance (Eq k, Hashable k, FromJSONKey k) => FromJSON1 (InsOrdHashMap k) where - liftParseJSON p pl v = fromList . HashMap.toList <$> liftParseJSON p pl v +instance (Eq k, Hashable k, A.FromJSON k) => A.FromJSON1 (InsOrdHashMap k) where + liftParseJSON o p pl v = fromList <$> A.liftParseJSON Nothing pkv plkv v + where + pkv = A.liftParseJSON2 A.omittedField A.parseJSON A.parseJSONList o p pl + plkv = A.listParser pkv -instance (Eq k, Hashable k, FromJSONKey k, FromJSON v) => FromJSON (InsOrdHashMap k v) where - parseJSON = parseJSON1 +instance (Eq k, Hashable k, A.FromJSON k, A.FromJSON v) => A.FromJSON (InsOrdHashMap k v) where + parseJSON = A.parseJSON1 ------------------------------------------------------------------------------- +-- indexed-traversals +------------------------------------------------------------------------------- + +instance (Eq k, Hashable k) => FunctorWithIndex k (InsOrdHashMap k) where + imap = mapWithKey +instance (Eq k, Hashable k) => FoldableWithIndex k (InsOrdHashMap k) where + ifoldMap = foldMapWithKey + ifoldr = foldrWithKey +instance (Eq k, Hashable k) => TraversableWithIndex k (InsOrdHashMap k) where + itraverse = traverseWithKey + +------------------------------------------------------------------------------- -- Lens ------------------------------------------------------------------------------- @@ -244,11 +291,21 @@ type instance IxValue (InsOrdHashMap k v) = v instance (Eq k, Hashable k) => Ixed (InsOrdHashMap k v) where - ix k f m = case lookup k m of - Just v -> f v <&> \v' -> insert k v' m - Nothing -> pure m + ix k f m = ixImpl k pure f m {-# INLINABLE ix #-} +ixImpl + :: (Eq k, Hashable k, Functor f) + => k + -> (InsOrdHashMap k v -> f (InsOrdHashMap k v)) + -> (v -> f v) + -> InsOrdHashMap k v + -> f (InsOrdHashMap k v) +ixImpl k point f m = case lookup k m of + Just v -> f v <&> \v' -> insert k v' m + Nothing -> point m +{-# INLINE ixImpl #-} + instance (Eq k, Hashable k) => At (InsOrdHashMap k a) where at k f m = f mv <&> \r -> case r of Nothing -> maybe m (const (delete k m)) mv @@ -256,13 +313,6 @@ where mv = lookup k m {-# INLINABLE at #-} -instance (Eq k, Hashable k) => FunctorWithIndex k (InsOrdHashMap k) where - imap = mapWithKey -instance (Eq k, Hashable k) => FoldableWithIndex k (InsOrdHashMap k) where - ifoldMap = foldMapWithKey -instance (Eq k, Hashable k) => TraversableWithIndex k (InsOrdHashMap k) where - itraverse = traverseWithKey - -- | This is a slight lie, as roundtrip doesn't preserve ordering. hashMap :: Iso (InsOrdHashMap k a) (InsOrdHashMap k b) (HashMap k a) (HashMap k b) hashMap = iso toHashMap fromHashMap @@ -271,6 +321,21 @@ unorderedTraversal = hashMap . traverse ------------------------------------------------------------------------------- +-- Optics +------------------------------------------------------------------------------- + +type instance Optics.Index (InsOrdHashMap k v) = k +type instance Optics.IxValue (InsOrdHashMap k v) = v + +instance (Eq k, Hashable k) => Optics.Ixed (InsOrdHashMap k v) where + ix k = Optics.atraversalVL $ \point f m -> ixImpl k point f m + {-# INLINE ix #-} + +instance (Eq k, Hashable k) => Optics.At (InsOrdHashMap k a) where + at k = Optics.lensVL $ \f m -> Lens.at k f m + {-# INLINE at #-} + +------------------------------------------------------------------------------- -- Construction ------------------------------------------------------------------------------- @@ -419,37 +484,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,335 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +-- | 'InsOrdHashSet' is like 'HashSet', 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 + (Bool, Eq ((==)), Int, Maybe (..), const, flip, fmap, fst, + maybe, otherwise, return, snd, ($), (&&), (+), (.), (<$), (<$>), (<), + (>), (>=), (||)) + +import Control.Arrow (first) +import Control.DeepSeq (NFData (..)) +import Data.Data (Data) +import Data.Foldable (Foldable (foldMap), all) +import Data.Hashable (Hashable (..)) +import Data.List (nub, sortBy) +import Data.Monoid (Monoid (..)) +import Data.Ord (comparing) +import Data.Semigroup (Semigroup (..)) +import Data.Traversable (Traversable (traverse)) +import Text.ParserCombinators.ReadPrec (prec) +import Text.Read + (Lexeme (..), Read (..), lexP, parens, readListPrecDefault) +import Text.Show (Show (..), showParen, showString) + +import Control.Lens + (At (..), Contains (..), Index, Iso', IxValue, Ixed (..), iso, (<&>)) +import Control.Monad.Trans.State.Strict (State, runState, state) + +import qualified Data.Aeson as A +import qualified Control.Lens as Lens +import qualified Optics.At as Optics +import qualified Optics.Core as Optics + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +import qualified Data.Foldable +import qualified GHC.Exts as Exts + +import qualified Control.DeepSeq as NF + +import Data.HashMap.InsOrd.Internal + +------------------------------------------------------------------------------- +-- InsOrdHashSet +------------------------------------------------------------------------------- + +-- | 'HashSet' which tries its best to remember insertion order of elements. + +data InsOrdHashSet k = InsOrdHashSet + { _getIndex :: !Int + , getInsOrdHashSet :: !(HashMap k Int) + } + deriving (Data) + +-- | @since 0.2.5 +instance NFData k => NFData (InsOrdHashSet k) where + rnf (InsOrdHashSet _ hs) = rnf hs + +-- | @since 0.2.5 +instance NF.NFData1 InsOrdHashSet where + liftRnf rnf1 (InsOrdHashSet _ m) = NF.liftRnf2 rnf1 rnf m + +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 + +instance Foldable InsOrdHashSet where + -- in newer base only + -- length = length . getInsOrdHashSet + foldMap f = foldMap f . toList + + null = null + toList = toList + length = size + +-- | @'hashWithSalt' salt . 'toHashSet' = 'hashWithSalt' salt@. +instance Hashable k => Hashable (InsOrdHashSet k) where + hashWithSalt salt (InsOrdHashSet _ m) = + hashWithSalt salt m + +instance (Eq k, Hashable k) => Exts.IsList (InsOrdHashSet k) where + type Item (InsOrdHashSet k) = k + fromList = fromList + toList = toList + +------------------------------------------------------------------------------- +-- Aeson +------------------------------------------------------------------------------- + +instance A.ToJSON a => A.ToJSON (InsOrdHashSet a) where + toJSON = A.toJSON . toList + toEncoding = A.toEncoding . toList + +instance (Eq a, Hashable a, A.FromJSON a) => A.FromJSON (InsOrdHashSet a) where + parseJSON v = fromList <$> A.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 + +------------------------------------------------------------------------------- +-- Optics +------------------------------------------------------------------------------- + +type instance Optics.Index (InsOrdHashSet a) = a +type instance Optics.IxValue (InsOrdHashSet a) = () + +instance (Eq k, Hashable k) => Optics.Ixed (InsOrdHashSet k) where + ix k = Optics.atraversalVL $ \point f (InsOrdHashSet i m) -> + InsOrdHashSet i <$> + Optics.atraverseOf + (Optics.ix k) point (\j -> j <$ f ()) m + {-# INLINE ix #-} + +instance (Eq k, Hashable k) => Optics.At (InsOrdHashSet k) where + at k = Optics.lensVL $ \f m -> Lens.at k f m + {-# INLINE at #-} + +instance (Eq a, Hashable a) => Optics.Contains (InsOrdHashSet a) where + contains k = Optics.lensVL $ \f s -> Lens.contains k f s + {-# INLINE contains #-} + +------------------------------------------------------------------------------- +-- 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) = + HashMap.keysSet m + +------------------------------------------------------------------------------- +-- 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 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -7,7 +7,6 @@ import Data.Function (on) import Data.Hashable (Hashable (..)) import Data.List (nubBy) -import Data.Semigroup ((<>)) import Data.Traversable (foldMapDefault) import Data.Word (Word8) import Text.Read (readMaybe) @@ -30,6 +29,7 @@ , testProperty "Hashable agree" $ hashableProperty , testProperty "aeson roundtrip" $ aesonRoundtrip , testProperty "show . read = id" showReadRoundtrip + , testProperty "Eq respects ordering" eqRespectsOrdering ] , testGroup "Regressions" [ testProperty "issue 10: union overflow" $ issue10 @@ -149,6 +149,12 @@ iom = evalOpInsOrd op rhs = Just iom lhs = readMaybe $ show iom + +eqRespectsOrdering :: Operation Int Int -> Property +eqRespectsOrdering op = iom == iomRev ==> InsOrd.toList iom === InsOrd.toList iomRev + where + iom = evalOpInsOrd op + iomRev = InsOrd.fromList . reverse . InsOrd.toList $ iom ------------------------------------------------------------------------------- -- Regressions