@@ -43,6 +43,7 @@ module Data.Aeson.Types.ToJSON (
4343 -- * Classes and types for map keys
4444 , ToJSONKey(..)
4545 , ToJSONKeyFunction(..)
46+ , toJSONKeyText
4647 , contramapToJSONKeyFunction
4748 -- * Object key-value pairs
4849 , KeyValue(..)
@@ -413,22 +414,44 @@ class ToJSONKey a where
413414 -- container.
414415 toJSONKey :: ToJSONKeyFunction a
415416 default toJSONKey :: ToJSON a => ToJSONKeyFunction a
416− toJSONKey = ToJSONKeyValue (toJSON, toEncoding)
417+ toJSONKey = ToJSONKeyValue toJSON toEncoding
418+
417419 -- | This is similar in spirit to the 'showsList' method of 'Show'.
418420 -- It makes it possible to give 'String' keys special treatment
419421 -- without using @OverlappingInstances@.
420422 toJSONKeyList :: ToJSONKeyFunction [a]
421423 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]
422− toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)
424+ toJSONKeyList = ToJSONKeyValue toJSON toEncoding
423425
424426data ToJSONKeyFunction a
425− = ToJSONKeyText (a -> Text, a -> Encoding' Text) -- ^ key is encoded to string, produces object
426− | ToJSONKeyValue (a -> Value, a -> Encoding) -- ^ key is encoded to value, produces array
427+ = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)
428+ -- ^ key is encoded to string, produces object
429+ | ToJSONKeyValue !(a -> Value) !(a -> Encoding)
430+ -- ^ key is encoded to value, produces array
431+
432+-- | Helper for creating textual keys.
433+--
434+-- @
435+-- instance 'ToJSONKey' MyKey where
436+-- 'toJSONKey' = 'toJSONKeyText' myKeyToText
437+-- where
438+-- myKeyToText = Text.pack . show -- or showt from text-show
439+-- @
440+toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a
441+toJSONKeyText f = ToJSONKeyText f (E.text . f)
427442
443+-- | TODO: should this be exported?
444+toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a
445+toJSONKeyTextEnc e = ToJSONKeyText tot e
446+ where
447+ -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
448+ tot = T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . E.encodingToLazyByteString . e
449+
450+-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.
428451contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
429452contramapToJSONKeyFunction h x = case x of
430− ToJSONKeyText (f,g) -> ToJSONKeyText (f . h, g . h)
431− ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)
453+ ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)
454+ ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)
432455
433456-------------------------------------------------------------------------------
434457-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -1231,10 +1254,7 @@ instance ToJSON Bool where
12311254 {-# INLINE toEncoding #-}
12321255
12331256instance ToJSONKey Bool where
1234− toJSONKey = ToJSONKeyText
1235− ( (\x -> if x then "true" else "false")
1236− , (\x -> E.text $ if x then "true"else "false")
1237− )
1257+ toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"
12381258
12391259
12401260instance ToJSON Ordering where
@@ -1479,7 +1499,7 @@ instance ToJSON Text where
14791499 {-# INLINE toEncoding #-}
14801500
14811501instance ToJSONKey Text where
1482− toJSONKey = ToJSONKeyText (id, E.text)
1502+ toJSONKey = toJSONKeyText id
14831503 {-# INLINE toJSONKey #-}
14841504
14851505instance ToJSON LT.Text where
@@ -1611,14 +1631,14 @@ instance ToJSON a => ToJSON (IntMap.IntMap a) where
16111631
16121632instance ToJSONKey k => ToJSON1 (M.Map k) where
16131633 liftToJSON g _ = case toJSONKey of
1614− ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
1615− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
1634+ ToJSONKeyText f _ -> Object . mapHashKeyVal f g
1635+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList
16161636 {-# INLINE liftToJSON #-}
16171637
16181638 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
16191639 liftToEncoding g _ = case toJSONKey of
1620− ToJSONKeyText (_,f) -> dict f g M.foldrWithKey
1621− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . M.toList
1640+ ToJSONKeyText _ f -> dict f g M.foldrWithKey
1641+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList
16221642 where
16231643 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
16241644 pairEncoding f (a, b) = tuple $ f a >*< g b
@@ -1730,14 +1750,14 @@ instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
17301750
17311751instance ToJSONKey k => ToJSON1 (H.HashMap k) where
17321752 liftToJSON g _ = case toJSONKey of
1733− ToJSONKeyText (f,_) -> Object . mapKeyVal f g
1734− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . H.toList
1753+ ToJSONKeyText f _ -> Object . mapKeyVal f g
1754+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList
17351755 {-# INLINE liftToJSON #-}
17361756
17371757 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
17381758 liftToEncoding g _ = case toJSONKey of
1739− ToJSONKeyText (_,f) -> dict f g H.foldrWithKey
1740− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . H.toList
1759+ ToJSONKeyText _ f -> dict f g H.foldrWithKey
1760+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList
17411761 where
17421762 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
17431763 pairEncoding f (a, b) = tuple $ f a >*< g b
@@ -1915,22 +1935,13 @@ instance ToJSONKey b => ToJSONKey (Tagged a b) where
19151935-- Instances for converting t map keys
19161936-------------------------------------------------------------------------------
19171937
1918−-- | TODO: Move ToJSONKEyFunction to .Types(.Internal),
1919−-- export and document this function from there
1920−toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a
1921−toJSONKeyTextEnc e = ToJSONKeyText
1922− -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
1923− ( T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . E.encodingToLazyByteString . e
1924− , e
1925− )
1926−
19271938instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)
19281939instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)
19291940instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)
19301941
19311942instance ToJSONKey Char where
1932− toJSONKey = ToJSONKeyText (T.singleton, E.string . (:[]))
1933− toJSONKeyList = ToJSONKeyText (T.pack, E.text . T.pack)
1943+ toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))
1944+ toJSONKeyList = toJSONKeyText T.pack
19341945
19351946instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where
19361947 toJSONKey = toJSONKeyList