diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,10 @@ -- 0.2.6 +- 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 diff --git a/insert-ordered-containers.cabal b/insert-ordered-containers.cabal --- a/insert-ordered-containers.cabal +++ b/insert-ordered-containers.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: insert-ordered-containers -version: 0.2.7 +version: 0.3.0 synopsis: Associative containers retaining insertion order for traversals. @@ -26,8 +26,9 @@ || ==9.4.8 || ==9.6.7 || ==9.8.4 - || ==9.10.1 - || ==9.12.1 + || ==9.10.3 + || ==9.12.2 + || ==9.14.1 extra-source-files: CHANGELOG.md @@ -40,10 +41,10 @@ library default-language: Haskell2010 hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall -Wunused-packages build-depends: , aeson >=2.2.3.0 && <2.3 - , base >=4.12.0.0 && <4.22 + , 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 @@ -51,7 +52,6 @@ , optics-core >=0.4.1.1 && <0.5 , optics-extra >=0.4.2.1 && <0.5 , semigroupoids >=6.0.1 && <6.1 - , text >=1.2.3.0 && <1.3 || >=2.0 && <2.2 , transformers >=0.5.6.2 && <0.7 , unordered-containers >=0.2.20 && <0.3 @@ -76,9 +76,7 @@ , hashable , insert-ordered-containers , lens - , QuickCheck >=2.13.2 && <2.16 - , semigroupoids + , QuickCheck >=2.13.2 && <2.19 , tasty >=0.10.1.2 && <1.6 , tasty-quickcheck >=0.8.3.2 && <0.12 - , text , unordered-containers 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 @@ -109,7 +109,7 @@ import qualified Control.Lens as Lens import qualified Data.Aeson as A -import qualified Data.Aeson.Encoding as E +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 @@ -183,7 +183,7 @@ 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) $ @@ -238,25 +238,37 @@ -- Aeson ------------------------------------------------------------------------------- -instance (A.ToJSONKey k) => A.ToJSON1 (InsOrdHashMap k) where - liftToJSON _ t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of - A.ToJSONKeyText f _ -> A.object . fmap (\(k, v) -> (f k, t v)) . toList - A.ToJSONKeyValue f _ -> A.toJSON . fmap (\(k,v) -> A.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 o t _ = case A.toJSONKey :: A.ToJSONKeyFunction k of - A.ToJSONKeyText _ f -> E.dict f t foldrWithKey - A.ToJSONKeyValue _ f -> E.list (A.liftToEncoding2 (const False) f (E.list f) o 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 (A.ToJSONKey k, A.ToJSON v) => A.ToJSON (InsOrdHashMap k v) where +instance (A.ToJSON k, A.ToJSON v) => A.ToJSON (InsOrdHashMap k v) where toJSON = A.toJSON1 toEncoding = A.toEncoding1 ------------------------------------------------------------------------------- -instance (Eq k, Hashable k, A.FromJSONKey k) => A.FromJSON1 (InsOrdHashMap k) where - liftParseJSON o p pl v = fromList . HashMap.toList <$> A.liftParseJSON o 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, A.FromJSONKey k, A.FromJSON v) => A.FromJSON (InsOrdHashMap k v) where +instance (Eq k, Hashable k, A.FromJSON k, A.FromJSON v) => A.FromJSON (InsOrdHashMap k v) where parseJSON = A.parseJSON1 ------------------------------------------------------------------------------- diff --git a/src/Data/HashSet/InsOrd.hs b/src/Data/HashSet/InsOrd.hs --- a/src/Data/HashSet/InsOrd.hs +++ b/src/Data/HashSet/InsOrd.hs @@ -49,7 +49,7 @@ import Control.Arrow (first) import Control.DeepSeq (NFData (..)) -import Data.Data (Data, Typeable) +import Data.Data (Data) import Data.Foldable (Foldable (foldMap), all) import Data.Hashable (Hashable (..)) import Data.List (nub, sortBy) diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -29,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 @@ -148,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