diff --git a/changelog.md b/changelog.md index 4d6df2c45..9694baeab 100644 --- a/changelog.md +++ b/changelog.md @@ -2,6 +2,8 @@ For the latest version of this document, please see [https://github.com/haskell/ ### Unreleased - Future date +* Remove unsound rewrite rule on `FromJSONKey` (`fmap coerce = coerce`) + ### 2.3.1.0 - 2026-07-05 * Add `FromJSONKey` instance for `Data.Fixed`. diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index 146482403..9528f6093 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -470,11 +470,10 @@ instance Functor FromJSONKeyFunction where fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f) -- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This --- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be +-- conversion is still unsafe, as 'Hashable', 'Eq', and 'Ord' instances of @a@ should be -- compatible with 'Text' i.e. hash values should be equal for wrapped values as well. --- This property will always be maintained if the 'Hashable' and 'Eq' instances +-- This property will always be maintained if the 'Hashable', 'Eq', and 'Ord' instances -- are derived with generalized newtype deriving. --- compatible with 'Text' i.e. hash values be equal for wrapped values as well. -- -- On pre GHC 7.8 this is unconstrained function. fromJSONKeyCoerce :: @@ -482,19 +481,16 @@ fromJSONKeyCoerce :: FromJSONKeyFunction a fromJSONKeyCoerce = FromJSONKeyCoerce --- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@. +-- | Coerce the result of a 'FromJSONKeyFunction'. -- --- See note on 'fromJSONKeyCoerce'. +-- __Warning__: This function is unsafe when the argument is +-- 'fromJSONKeyCoerce'. It can break internal invariants of maps. +-- See also the note on 'fromJSONKeyCoerce'. coerceFromJSONKeyFunction :: Coercible a b => FromJSONKeyFunction a -> FromJSONKeyFunction b coerceFromJSONKeyFunction = coerce -{-# RULES - "FromJSONKeyCoerce: fmap coerce" forall x . - fmap coerce x = coerceFromJSONKeyFunction x - #-} - -- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'. mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b mapFromJSONKeyFunction = fmap @@ -2491,7 +2487,7 @@ instance FromJSON b => FromJSON (Tagged a b) where instance FromJSONKey b => FromJSONKey (Tagged a b) where fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b) - fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList + fromJSONKeyList = coerce (fromJSONKeyList @b) ------------------------------------------------------------------------------- -- these diff --git a/tests/UnitTests/FromJSONKey.hs b/tests/UnitTests/FromJSONKey.hs index f53956b73..7eb5e0d1a 100644 --- a/tests/UnitTests/FromJSONKey.hs +++ b/tests/UnitTests/FromJSONKey.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DerivingVia, GADTs, GeneralizedNewtypeDeriving, OverloadedStrings #-} module UnitTests.FromJSONKey (fromJSONKeyTests) where import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, Assertion, assertFailure) +import Test.Tasty.HUnit (testCase, Assertion, assertFailure, (@?=)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Ord (Down(..)) import Data.Text (Text) import Data.Tagged (Tagged) import Control.Applicative (Const) @@ -18,6 +21,15 @@ instance FromJSONKey MyText' where fromJSONKey = fmap MyText' fromJSONKey fromJSONKeyList = error "not used" +newtype DownText = DownText Text + deriving (Eq, Ord) via (Down Text) + deriving FromJSON via Text + +-- Regression test for #1169: don't rewrite fmap coerce to coerce +instance FromJSONKey DownText where + fromJSONKey = fmap w fromJSONKey + where w = DownText ; {-# NOINLINE w #-} + fromJSONKeyTests :: TestTree fromJSONKeyTests = testGroup "FromJSONKey" $ fmap (testCase "-") fromJSONKeyAssertions @@ -27,23 +39,22 @@ fromJSONKeyAssertions = , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text)) , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText) - , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') + , assertIsText "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText') , assertIsCoerce "Const Text" (fromJSONKey :: FromJSONKeyFunction (Const Text ())) + + , assertDecodedMapIsValid ] where assertIsCoerce :: String -> FromJSONKeyFunction a -> Assertion assertIsCoerce _ FromJSONKeyCoerce = pure () assertIsCoerce n _ = assertFailure n - assertIsCoerce' :: String -> FromJSONKeyFunction a -> Assertion - assertIsCoerce' _ FromJSONKeyCoerce = pure () - assertIsCoerce' n _ = pickWithRules (assertFailure n) (pure ()) - --- | Pick the first when RULES are enabled, e.g. optimisations are on -pickWithRules - :: a -- ^ Pick this when RULES are on - -> a -- ^ use this otherwise - -> a -pickWithRules _ = id -{-# NOINLINE pickWithRules #-} -{-# RULES "pickWithRules/rule" [0] forall x. pickWithRules x = const x #-} + assertIsText :: String -> FromJSONKeyFunction a -> Assertion + assertIsText _ (FromJSONKeyText _) = pure () + assertIsText n _ = assertFailure n + +-- Regression test for #1169 (see FromJSONKey DownText) +assertDecodedMapIsValid :: Assertion +assertDecodedMapIsValid = fmap Map.valid decodedMap @?= Just True + where + decodedMap = decode "{\"a\":\"a\",\"b\":\"b\"}" :: Maybe (Map DownText Text)