Remove unsound rewrite rule on FromJSONKey

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`.

src/Data/Aeson/Types/FromJSON.hs

@@ -470,31 +470,27 @@ 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 ::
     Coercible Text a =>
     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

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)