e056318 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Refactor ToJSONKeyFunction, add some docs

e056318Oleg Grenrus10 years ago

Data/Aeson/Types.hs+3

compare with master

unifiedsplit

@@ -40,10 +40,13 @@ module Data.Aeson.Types

40 -- ** Keys for maps

41 , ToJSONKey(..)

42 , ToJSONKeyFunction(..)

43+ , toJSONKeyText

44+ , contramapToJSONKeyFunction

43 , FromJSONKey(..)

45 , FromJSONKey(..)

44 , FromJSONKeyFunction(..)

46 , FromJSONKeyFunction(..)

45 , fromJSONKeyCoerce

47 , fromJSONKeyCoerce

46 , coerceFromJSONKeyFunction

48 , coerceFromJSONKeyFunction

49+ , mapFromJSONKeyFunction

48 -- ** Liftings to unary and binary type constructors

51 -- ** Liftings to unary and binary type constructors

49 , FromJSON1(..)

52 , FromJSON1(..)

Data/Aeson/Types/Class.hs+1

@@ -51,6 +51,7 @@ module Data.Aeson.Types.Class

51 -- * Classes and types for map keys

52 , ToJSONKey(..)

53 , ToJSONKeyFunction(..)

54+ , toJSONKeyText

54 , contramapToJSONKeyFunction

55 , contramapToJSONKeyFunction

55 , FromJSONKey(..)

56 , FromJSONKey(..)

56 , FromJSONKeyFunction(..)

57 , FromJSONKeyFunction(..)

Data/Aeson/Types/FromJSON.hs+16−6

@@ -127,9 +127,8 @@ import qualified Data.Vector.Unboxed as VU

127

128import Unsafe.Coerce (unsafeCoerce)

129

130−-- Coercible derivations aren't as powerful on GHC 7.8, though supported.

131#ifndef HAS_COERCIBLE

130#ifndef HAS_COERCIBLE

132−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 709)

131+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)

133#endif

132#endif

134

133

135#if HAS_COERCIBLE

134#if HAS_COERCIBLE

@@ -325,6 +324,7 @@ class FromJSONKey a where

325 fromJSONKey :: FromJSONKeyFunction a

324 fromJSONKey :: FromJSONKeyFunction a

326 default fromJSONKey :: FromJSON a => FromJSONKeyFunction a

325 default fromJSONKey :: FromJSON a => FromJSONKeyFunction a

327 fromJSONKey = FromJSONKeyValue parseJSON

326 fromJSONKey = FromJSONKeyValue parseJSON

327+

328 fromJSONKeyList :: FromJSONKeyFunction [a]

329 default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]

330 fromJSONKeyList = FromJSONKeyValue parseJSON

@@ -343,10 +343,10 @@ data CoerceText a where

343#endif

344

345data FromJSONKeyFunction a

346− = FromJSONKeyCoerce (CoerceText a)

346+ = FromJSONKeyCoerce !(CoerceText a)

347− | FromJSONKeyText (Text -> a)

347+ | FromJSONKeyText !(Text -> a)

348− | FromJSONKeyTextParser (Text -> Parser a)

348+ | FromJSONKeyTextParser !(Text -> Parser a)

349− | FromJSONKeyValue (Value -> Parser a)

349+ | FromJSONKeyValue !(Value -> Parser a)

350

351instance Functor FromJSONKeyFunction where

352 fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

@@ -357,6 +357,8 @@ instance Functor FromJSONKeyFunction where

357-- | Construct 'FromJSONKeyFunction' for types coercible from 'Text'. This

358-- conversion is still unsafe, as 'Hashable' and 'Eq' instances of @a@ should be

359-- compatible with 'Text' i.e. hash values be equal for wrapped values as well.

360+--

361+-- On pre GHC 7.8 this is unconstrainted function.

360fromJSONKeyCoerce ::

362fromJSONKeyCoerce ::

361#if HAS_COERCIBLE

363#if HAS_COERCIBLE

362 Coercible Text a =>

364 Coercible Text a =>

@@ -364,15 +366,22 @@ fromJSONKeyCoerce ::

364 FromJSONKeyFunction a

366 FromJSONKeyFunction a

365fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

367fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

366

368

369+-- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.

370+--

371+-- See note on 'fromJSONKeyCoerce'.

367coerceFromJSONKeyFunction ::

372coerceFromJSONKeyFunction ::

368#if HAS_COERCIBLE

373#if HAS_COERCIBLE

369 Coercible a b =>

374 Coercible a b =>

370#endif

375#endif

371 FromJSONKeyFunction a -> FromJSONKeyFunction b

376 FromJSONKeyFunction a -> FromJSONKeyFunction b

377+#if HAS_COERCIBLE

378+coerceFromJSONKeyFunction = coerce

379+#else

372coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

380coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

373coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

381coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

374coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

382coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

375coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

383coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

384+#endif

376

385

377{-# RULES

386{-# RULES

378 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

387 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

@@ -385,6 +394,7 @@ coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fma

385 #-}

394 #-}

386#endif

395#endif

387

396

397+-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

388mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

398mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

389mapFromJSONKeyFunction = fmap

399mapFromJSONKeyFunction = fmap

390

400

Data/Aeson/Types/ToJSON.hs+41−30

@@ -43,6 +43,7 @@ module Data.Aeson.Types.ToJSON (

43 -- * Classes and types for map keys

44 , ToJSONKey(..)

45 , ToJSONKeyFunction(..)

46+ , toJSONKeyText

46 , contramapToJSONKeyFunction

47 , contramapToJSONKeyFunction

47 -- * Object key-value pairs

48 -- * Object key-value pairs

48 , KeyValue(..)

49 , KeyValue(..)

@@ -413,22 +414,44 @@ class ToJSONKey a where

413 -- container.

414 -- container.

414 toJSONKey :: ToJSONKeyFunction a

415 toJSONKey :: ToJSONKeyFunction a

415 default toJSONKey :: ToJSON a => ToJSONKeyFunction a

416 default toJSONKey :: ToJSON a => ToJSONKeyFunction a

416− toJSONKey = ToJSONKeyValue (toJSON, toEncoding)

417+ toJSONKey = ToJSONKeyValue toJSON toEncoding

418+

417 -- | This is similar in spirit to the 'showsList' method of 'Show'.

419 -- | This is similar in spirit to the 'showsList' method of 'Show'.

418 -- It makes it possible to give 'String' keys special treatment

420 -- It makes it possible to give 'String' keys special treatment

419 -- without using @OverlappingInstances@.

421 -- without using @OverlappingInstances@.

420 toJSONKeyList :: ToJSONKeyFunction [a]

422 toJSONKeyList :: ToJSONKeyFunction [a]

421 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]

423 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]

422− toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)

424+ toJSONKeyList = ToJSONKeyValue toJSON toEncoding

423

425

424data ToJSONKeyFunction a

426data ToJSONKeyFunction a

427+ = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)

425− = ToJSONKeyText (a -> Text, a -> Encoding' Text) -- ^ key is encoded to string, produces object

428+ -- ^ key is encoded to string, produces object

429+ | ToJSONKeyValue !(a -> Value) !(a -> Encoding)

426− | ToJSONKeyValue (a -> Value, a -> Encoding) -- ^ key is encoded to value, produces array

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)

427

442

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.

428contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b

451contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b

429contramapToJSONKeyFunction h x = case x of

452contramapToJSONKeyFunction h x = case x of

430− ToJSONKeyText (f,g) -> ToJSONKeyText (f . h, g . h)

453+ ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

431− ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)

454+ ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

432

455

433-------------------------------------------------------------------------------

456-------------------------------------------------------------------------------

434-- Lifings of FromJSON and ToJSON to unary and binary type constructors

457-- Lifings of FromJSON and ToJSON to unary and binary type constructors

@@ -1231,10 +1254,7 @@ instance ToJSON Bool where

1231 {-# INLINE toEncoding #-}

1254 {-# INLINE toEncoding #-}

1232

1255

1233instance ToJSONKey Bool where

1256instance ToJSONKey Bool where

1234− toJSONKey = ToJSONKeyText

1235− ( (\x -> if x then "true" else "false")

1236− , (\x -> E.text $ if x then "true"else "false")

1257+ toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"

1237− )

1238

1258

1239

1259

1240instance ToJSON Ordering where

1260instance ToJSON Ordering where

@@ -1479,7 +1499,7 @@ instance ToJSON Text where

1479 {-# INLINE toEncoding #-}

1499 {-# INLINE toEncoding #-}

1480

1500

1481instance ToJSONKey Text where

1501instance ToJSONKey Text where

1482− toJSONKey = ToJSONKeyText (id, E.text)

1502+ toJSONKey = toJSONKeyText id

1483 {-# INLINE toJSONKey #-}

1503 {-# INLINE toJSONKey #-}

1484

1504

1485instance ToJSON LT.Text where

1505instance ToJSON LT.Text where

@@ -1611,14 +1631,14 @@ instance ToJSON a => ToJSON (IntMap.IntMap a) where

1611

1631

1612instance ToJSONKey k => ToJSON1 (M.Map k) where

1632instance ToJSONKey k => ToJSON1 (M.Map k) where

1613 liftToJSON g _ = case toJSONKey of

1633 liftToJSON g _ = case toJSONKey of

1614− ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g

1634+ ToJSONKeyText f _ -> Object . mapHashKeyVal f g

1615− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList

1635+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList

1616 {-# INLINE liftToJSON #-}

1636 {-# INLINE liftToJSON #-}

1617

1637

1618 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding

1638 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding

1619 liftToEncoding g _ = case toJSONKey of

1639 liftToEncoding g _ = case toJSONKey of

1620− ToJSONKeyText (_,f) -> dict f g M.foldrWithKey

1640+ ToJSONKeyText _ f -> dict f g M.foldrWithKey

1621− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . M.toList

1641+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList

1622 where

1642 where

1623 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

1643 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

1624 pairEncoding f (a, b) = tuple $ f a >*< g b

1644 pairEncoding f (a, b) = tuple $ f a >*< g b

@@ -1730,14 +1750,14 @@ instance (ToJSON a) => ToJSON (HashSet.HashSet a) where

1730

1750

1731instance ToJSONKey k => ToJSON1 (H.HashMap k) where

1751instance ToJSONKey k => ToJSON1 (H.HashMap k) where

1732 liftToJSON g _ = case toJSONKey of

1752 liftToJSON g _ = case toJSONKey of

1733− ToJSONKeyText (f,_) -> Object . mapKeyVal f g

1753+ ToJSONKeyText f _ -> Object . mapKeyVal f g

1734− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . H.toList

1754+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList

1735 {-# INLINE liftToJSON #-}

1755 {-# INLINE liftToJSON #-}

1736

1756

1737 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding

1757 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding

1738 liftToEncoding g _ = case toJSONKey of

1758 liftToEncoding g _ = case toJSONKey of

1739− ToJSONKeyText (_,f) -> dict f g H.foldrWithKey

1759+ ToJSONKeyText _ f -> dict f g H.foldrWithKey

1740− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . H.toList

1760+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList

1741 where

1761 where

1742 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

1762 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding

1743 pairEncoding f (a, b) = tuple $ f a >*< g b

1763 pairEncoding f (a, b) = tuple $ f a >*< g b

@@ -1915,22 +1935,13 @@ instance ToJSONKey b => ToJSONKey (Tagged a b) where

1915-- Instances for converting t map keys

1935-- Instances for converting t map keys

1916-------------------------------------------------------------------------------

1936-------------------------------------------------------------------------------

1917

1937

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−

1927instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)

1938instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)

1928instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)

1939instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)

1929instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)

1940instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)

1930

1941

1931instance ToJSONKey Char where

1942instance ToJSONKey Char where

1932− toJSONKey = ToJSONKeyText (T.singleton, E.string . (:[]))

1943+ toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))

1933− toJSONKeyList = ToJSONKeyText (T.pack, E.text . T.pack)

1944+ toJSONKeyList = toJSONKeyText T.pack

1934

1945

1935instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where

1946instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where

1936 toJSONKey = toJSONKeyList

1947 toJSONKey = toJSONKeyList

tests/UnitTests.hs−1

@@ -322,7 +322,6 @@ fromJSONKeyAssertions =

322 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))

323 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)

324

325−-- Why this doesn't work on older GHC?

326#if __GLASGOW_HASKELL__ >= 710

325#if __GLASGOW_HASKELL__ >= 710

327 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')

326 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')

328#endif

327#endif