57cddd0 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #711 from Lysxia/generic-key

57cddd0Adam Bergmark7 years ago

Data/Aeson.hs+9

compare with master

unifiedsplit

@@ -70,6 +70,11 @@ module Data.Aeson

70 , ToJSONKeyFunction(..)

71 , FromJSONKey(..)

72 , FromJSONKeyFunction(..)

73+ -- *** Generic keys

74+ , GToJSONKey()

75+ , genericToJSONKey

76+ , GFromJSONKey()

77+ , genericFromJSONKey

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

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

74 , FromJSON1(..)

79 , FromJSON1(..)

75 , parseJSON1

80 , parseJSON1

@@ -111,6 +116,10 @@ module Data.Aeson

111 , SumEncoding(..)

116 , SumEncoding(..)

112 , camelTo2

117 , camelTo2

113 , defaultTaggedObject

118 , defaultTaggedObject

119+ -- ** Options for object keys

120+ , JSONKeyOptions

121+ , keyModifier

122+ , defaultJSONKeyOptions

114

123

115 -- * Inspecting @'Value's@

124 -- * Inspecting @'Value's@

116 , withObject

125 , withObject

Data/Aeson/Types.hs+11

@@ -53,6 +53,12 @@ module Data.Aeson.Types

53 , coerceFromJSONKeyFunction

54 , mapFromJSONKeyFunction

56+ -- *** Generic keys

57+ , GToJSONKey()

58+ , genericToJSONKey

59+ , GFromJSONKey()

60+ , genericFromJSONKey

61+

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

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

57 , FromJSON1(..)

63 , FromJSON1(..)

58 , parseJSON1

64 , parseJSON1

@@ -125,6 +131,11 @@ module Data.Aeson.Types

125 , camelTo2

131 , camelTo2

126 , defaultOptions

132 , defaultOptions

127 , defaultTaggedObject

133 , defaultTaggedObject

134+

135+ -- ** Options for object keys

136+ , JSONKeyOptions

137+ , keyModifier

138+ , defaultJSONKeyOptions

128 ) where

139 ) where

129

140

130import Prelude.Compat

141import Prelude.Compat

Data/Aeson/Types/Class.hs+5

@@ -58,6 +58,11 @@ module Data.Aeson.Types.Class

58 , fromJSONKeyCoerce

59 , coerceFromJSONKeyFunction

60 , mapFromJSONKeyFunction

61+ -- ** Generic keys

62+ , GToJSONKey()

63+ , genericToJSONKey

64+ , GFromJSONKey()

65+ , genericFromJSONKey

61 -- * Object key-value pairs

66 -- * Object key-value pairs

62 , KeyValue(..)

67 , KeyValue(..)

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

@@ -45,6 +45,9 @@ module Data.Aeson.Types.FromJSON

45 , coerceFromJSONKeyFunction

46 , mapFromJSONKeyFunction

48+ , GFromJSONKey()

49+ , genericFromJSONKey

50+

48 -- * List functions

51 -- * List functions

49 , listParser

52 , listParser

@@ -406,6 +409,16 @@ class FromJSON a where

406-- > newtype SomeId = SomeId { getSomeId :: Text }

409-- > newtype SomeId = SomeId { getSomeId :: Text }

407-- > deriving (Eq,Ord,Hashable,FromJSONKey)

410-- > deriving (Eq,Ord,Hashable,FromJSONKey)

408--

411--

412+-- If you have a sum of nullary constructors, you may use the generic

413+-- implementation:

414+--

415+-- @

416+-- data Color = Red | Green | Blue

417+-- deriving Generic

418+--

419+-- instance 'FromJSONKey' Color where

420+-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

421+-- @

409class FromJSONKey a where

422class FromJSONKey a where

410 -- | Strategy for parsing the key of a map-like container.

423 -- | Strategy for parsing the key of a map-like container.

411 fromJSONKey :: FromJSONKeyFunction a

424 fromJSONKey :: FromJSONKeyFunction a

@@ -504,6 +517,35 @@ coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fma

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

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

505mapFromJSONKeyFunction = fmap

518mapFromJSONKeyFunction = fmap

506

519

520+-- | 'fromJSONKey' for 'Generic' types.

521+-- These types must be sums of nullary constructors, whose names will be used

522+-- as keys for JSON objects.

523+--

524+-- See also 'genericToJSONKey'.

525+--

526+-- === __Example__

527+--

528+-- @

529+-- data Color = Red | Green | Blue

530+-- deriving 'Generic'

531+--

532+-- instance 'FromJSONKey' Color where

533+-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

534+-- @

535+genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))

536+ => JSONKeyOptions

537+ -> FromJSONKeyFunction a

538+genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->

539+ case parseSumFromString (keyModifier opts) t of

540+ Nothing -> fail $

541+ "invalid key " ++ show t ++ ", expected one of " ++ show cnames

542+ Just k -> pure (to k)

543+ where

544+ cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])

545+

546+class (ConstructorNames f, SumFromString f) => GFromJSONKey f where

547+instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where

548+

507-------------------------------------------------------------------------------

549-------------------------------------------------------------------------------

508-- Functions needed for documentation

550-- Functions needed for documentation

509-------------------------------------------------------------------------------

551-------------------------------------------------------------------------------

@@ -1020,41 +1062,46 @@ parseAllNullarySum :: (SumFromString f, ConstructorNames f)

1020parseAllNullarySum tname opts =

1062parseAllNullarySum tname opts =

1021 withText tname $ \tag ->

1063 withText tname $ \tag ->

1022 maybe (badTag tag) return $

1064 maybe (badTag tag) return $

1023− parseSumFromString opts tag

1065+ parseSumFromString modifier tag

1024 where

1066 where

1025− badTag tag = failWithCTags tname opts $ \cnames ->

1067+ badTag tag = failWithCTags tname modifier $ \cnames ->

1026 "expected one of the tags " ++ show cnames ++

1068 "expected one of the tags " ++ show cnames ++

1027 ", but found tag " ++ show tag

1069 ", but found tag " ++ show tag

1070+ modifier = constructorTagModifier opts

1028

1071

1029-- | Fail with an informative error message about a mismatched tag.

1072-- | Fail with an informative error message about a mismatched tag.

1030-- The error message is parameterized by the list of expected tags,

1073-- The error message is parameterized by the list of expected tags,

1031-- to be inferred from the result type of the parser.

1074-- to be inferred from the result type of the parser.

1032failWithCTags

1075failWithCTags

1033− :: forall f a. ConstructorNames f

1076+ :: forall f a t. ConstructorNames f

1034− => TypeName -> Options -> ([String] -> String) -> Parser (f a)

1077+ => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)

1035−failWithCTags tname opts f =

1078+failWithCTags tname modifier f =

1036 contextType tname . fail $ f cnames

1079 contextType tname . fail $ f cnames

1037 where

1080 where

1038− cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])

1081+ cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])

1039

1082

1040class SumFromString f where

1083class SumFromString f where

1041− parseSumFromString :: Options -> Text -> Maybe (f a)

1084+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)

1042

1085

1043instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

1086instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

1044 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

1087 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

1045 (R1 <$> parseSumFromString opts key)

1088 (R1 <$> parseSumFromString opts key)

1046

1089

1047instance (Constructor c) => SumFromString (C1 c U1) where

1090instance (Constructor c) => SumFromString (C1 c U1) where

1048− parseSumFromString opts key | key == name = Just $ M1 U1

1091+ parseSumFromString modifier key

1092+ | key == name = Just $ M1 U1

1049− | otherwise = Nothing

1093+ | otherwise = Nothing

1050− where

1094+ where

1051− name = pack $ constructorTagModifier opts $

1052− conName (undefined :: M1 _i c _f _p)

1095+ name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)

1096+

1097+-- For genericFromJSONKey

1098+instance SumFromString a => SumFromString (D1 d a) where

1099+ parseSumFromString modifier key = M1 <$> parseSumFromString modifier key

1053

1100

1054-- | List of all constructor tags.

1101-- | List of all constructor tags.

1055−constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]

1102+constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]

1056−constructorTags opts =

1103+constructorTags modifier =

1057− fmap DList.toList (constructorNames' (constructorTagModifier opts))

1104+ fmap DList.toList (constructorNames' modifier)

1058

1105

1059-- | List of all constructor names of an ADT, after a given conversion

1106-- | List of all constructor names of an ADT, after a given conversion

1060-- function. (Better inlining.)

1107-- function. (Better inlining.)

@@ -1075,6 +1122,13 @@ instance Constructor c => ConstructorNames (C1 c a) where

1075 where

1122 where

1076 cname = conName (undefined :: M1 _i c _f _p)

1123 cname = conName (undefined :: M1 _i c _f _p)

1077

1124

1125+-- For genericFromJSONKey

1126+instance ConstructorNames a => ConstructorNames (D1 d a) where

1127+ constructorNames' = retag . constructorNames'

1128+ where

1129+ retag :: Tagged2 a u -> Tagged2 (D1 d a) u

1130+ retag (Tagged2 x) = Tagged2 x

1131+

1078--------------------------------------------------------------------------------

1132--------------------------------------------------------------------------------

1079

1133

1080parseNonAllNullarySum :: ( FromPair arity f

1134parseNonAllNullarySum :: ( FromPair arity f

@@ -1126,7 +1180,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =

1126

1180

1127 UntaggedValue -> parseUntaggedValue p

1181 UntaggedValue -> parseUntaggedValue p

1128 where

1182 where

1129− failWith_ = failWithCTags tname opts

1183+ failWith_ = failWithCTags tname (constructorTagModifier opts)

1130

1184

1131--------------------------------------------------------------------------------

1185--------------------------------------------------------------------------------

1132

1186

Data/Aeson/Types/Internal.hs+39

@@ -65,8 +65,10 @@ module Data.Aeson.Types.Internal

65 )

67 , SumEncoding(..)

68+ , JSONKeyOptions(keyModifier)

68 , defaultOptions

69 , defaultOptions

69 , defaultTaggedObject

70 , defaultTaggedObject

71+ , defaultJSONKeyOptions

71 -- * Used for changing CamelCase names into something else.

73 -- * Used for changing CamelCase names into something else.

72 , camelTo

74 , camelTo

@@ -665,6 +667,33 @@ data SumEncoding =

665 -- contents of the constructor.

667 -- contents of the constructor.

666 deriving (Eq, Show)

668 deriving (Eq, Show)

667

669

670+-- | Options for encoding keys with 'Data.Aeson.Types.genericFromJSONKey' and

671+-- 'Data.Aeson.Types.genericToJSONKey'.

672+data JSONKeyOptions = JSONKeyOptions

673+ { keyModifier :: String -> String

674+ -- ^ Function applied to keys. Its result is what goes into the encoded

675+ -- 'Value'.

676+ --

677+ -- === __Example__

678+ --

679+ -- The following instances encode the constructor @Bar@ to lower-case keys

680+ -- @\"bar\"@.

681+ --

682+ -- @

683+ -- data Foo = Bar

684+ -- deriving 'Generic'

685+ --

686+ -- opts :: 'JSONKeyOptions'

687+ -- opts = 'defaultJSONKeyOptions' { 'keyModifier' = 'toLower' }

688+ --

689+ -- instance 'ToJSONKey' Foo where

690+ -- 'toJSONKey' = 'genericToJSONKey' opts

691+ --

692+ -- instance 'FromJSONKey' Foo where

693+ -- 'fromJSONKey' = 'genericFromJSONKey' opts

694+ -- @

695+ }

696+

668-- | Default encoding 'Options':

697-- | Default encoding 'Options':

669--

698--

670-- @

699-- @

@@ -703,6 +732,16 @@ defaultTaggedObject = TaggedObject

703 , contentsFieldName = "contents"

732 , contentsFieldName = "contents"

704 }

733 }

705

734

735+-- | Default 'JSONKeyOptions':

736+--

737+-- @

738+-- defaultJSONKeyOptions = 'JSONKeyOptions'

739+-- { 'keyModifier' = 'id'

740+-- }

741+-- @

742+defaultJSONKeyOptions :: JSONKeyOptions

743+defaultJSONKeyOptions = JSONKeyOptions id

744+

706-- | Converts from CamelCase to another lower case, interspersing

745-- | Converts from CamelCase to another lower case, interspersing

707-- the character between all capital letters and their previous

746-- the character between all capital letters and their previous

708-- entries, except those capital letters that appear together,

747-- entries, except those capital letters that appear together,

Data/Aeson/Types/ToJSON.hs+43−3

@@ -47,6 +47,10 @@ module Data.Aeson.Types.ToJSON

47 , ToJSONKeyFunction(..)

48 , toJSONKeyText

49 , contramapToJSONKeyFunction

50+

51+ , GToJSONKey()

52+ , genericToJSONKey

53+

50 -- * Object key-value pairs

54 -- * Object key-value pairs

51 , KeyValue(..)

55 , KeyValue(..)

52 , KeyValuePair(..)

56 , KeyValuePair(..)

@@ -411,7 +415,7 @@ instance KeyValue Object where

411-- newtype wrapper around 'Text'. The recommended approach is to use

415-- newtype wrapper around 'Text'. The recommended approach is to use

412-- generalized newtype deriving:

416-- generalized newtype deriving:

413--

417--

414−-- > newtype RecordId = RecordId { getRecordId :: Text}

418+-- > newtype RecordId = RecordId { getRecordId :: Text }

415-- > deriving (Eq,Ord,ToJSONKey)

419-- > deriving (Eq,Ord,ToJSONKey)

416--

420--

417-- Then we may write:

421-- Then we may write:

@@ -426,8 +430,18 @@ instance KeyValue Object where

426--

430--

427-- It is possible to get the 'ToJSONKey' instance for free as we did

431-- It is possible to get the 'ToJSONKey' instance for free as we did

428-- with 'Foo'. However, in this case, we have a natural way to go to

432-- with 'Foo'. However, in this case, we have a natural way to go to

429−-- and from 'Text' that does not require any escape sequences. So, in

433+-- and from 'Text' that does not require any escape sequences. So

430−-- this example, 'ToJSONKeyText' will be used instead of 'ToJSONKeyValue'.

434+-- 'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps

435+-- as objects instead of arrays of pairs. This instance may be

436+-- implemented using generics as follows:

437+--

438+-- @

439+-- instance 'ToJSONKey' Color where

440+-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

441+-- @

442+--

443+-- === __Low-level implementations__

444+--

431-- The 'Show' instance can be used to help write 'ToJSONKey':

445-- The 'Show' instance can be used to help write 'ToJSONKey':

432--

446--

433-- > instance ToJSONKey Color where

447-- > instance ToJSONKey Color where

@@ -515,6 +529,29 @@ contramapToJSONKeyFunction h x = case x of

515 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

529 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

516 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

530 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

517

531

532+-- 'toJSONKey' for 'Generic' types.

533+-- Deriving is supported for enumeration types, i.e. the sums of nullary

534+-- constructors. The names of constructors will be used as keys for JSON

535+-- objects.

536+--

537+-- See also 'genericFromJSONKey'.

538+--

539+-- === __Example__

540+--

541+-- @

542+-- data Color = Red | Green | Blue

543+-- deriving 'Generic'

544+--

545+-- instance 'ToJSONKey' Color where

546+-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

547+-- @

548+genericToJSONKey :: (Generic a, GToJSONKey (Rep a))

549+ => JSONKeyOptions -> ToJSONKeyFunction a

550+genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)

551+

552+class GetConName f => GToJSONKey f

553+instance GetConName f => GToJSONKey f

554+

518-------------------------------------------------------------------------------

555-------------------------------------------------------------------------------

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

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

520-------------------------------------------------------------------------------

557-------------------------------------------------------------------------------

@@ -944,6 +981,9 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where

944instance (Constructor c) => GetConName (C1 c a) where

981instance (Constructor c) => GetConName (C1 c a) where

945 getConName = conName

982 getConName = conName

946

983

984+-- For genericToJSONKey

985+instance GetConName a => GetConName (D1 d a) where

986+ getConName (M1 x) = getConName x

947

987

948--------------------------------------------------------------------------------

988--------------------------------------------------------------------------------

949

989

tests/Encoders.hs+13

@@ -6,6 +6,7 @@

6module Encoders (module Encoders) where

8import Prelude.Compat

9+import Data.Text (Text)

10import Data.Aeson.TH

11import Data.Aeson.TH

11import Data.Aeson.Types

12import Data.Aeson.Types

@@ -96,6 +97,18 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle

96gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary

97gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary

97gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

98gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

100+keyOptions :: JSONKeyOptions

101+keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) }

102+

103+gNullaryToJSONKey :: Nullary -> Either String Text

104+gNullaryToJSONKey x = case genericToJSONKey keyOptions of

105+ ToJSONKeyText p _ -> Right (p x)

106+ _ -> Left "Should be a ToJSONKeyText"

107+

108+gNullaryFromJSONKey :: Text -> Parser Nullary

109+gNullaryFromJSONKey t = case genericFromJSONKey keyOptions of

110+ FromJSONKeyTextParser p -> p t

111+ _ -> fail "Not a TextParser"

112

100--------------------------------------------------------------------------------

113--------------------------------------------------------------------------------

101-- SomeType encoders/decoders

114-- SomeType encoders/decoders

tests/UnitTests/NullaryConstructors.hs+5

@@ -14,6 +14,7 @@ import Data.Aeson (decode, eitherDecode, fromEncoding, Value)

14import Data.Aeson.Internal (IResult (..), iparse)

15import Data.Aeson.Types (Parser)

16import Data.ByteString.Builder (toLazyByteString)

17+import Data.Foldable (for_)

17import Data.Maybe (fromJust)

18import Data.Maybe (fromJust)

18import Encoders

19import Encoders

19import Test.Tasty.HUnit ((@=?), Assertion)

20import Test.Tasty.HUnit ((@=?), Assertion)

@@ -52,6 +53,10 @@ nullaryConstructors =

52 -- Make sure that the old `"contents" : []' is still allowed

53 -- Make sure that the old `"contents" : []' is still allowed

53 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

54 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

54 , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

55 , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

56+

57+ , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do

58+ Right jkey @=? gNullaryToJSONKey key

59+ ISuccess key @=? parse gNullaryFromJSONKey jkey

55 ]

60 ]

56 where

61 where

57 enc = eitherDecode . toLazyByteString . fromEncoding

62 enc = eitherDecode . toLazyByteString . fromEncoding