@@ -45,6 +45,9 @@ module Data.Aeson.Types.FromJSON
4545 , coerceFromJSONKeyFunction
4646 , mapFromJSONKeyFunction
4747
48+ , GFromJSONKey()
49+ , genericFromJSONKey
50+
4851 -- * List functions
4952 , listParser
5053
@@ -406,6 +409,16 @@ class FromJSON a where
406409-- > newtype SomeId = SomeId { getSomeId :: Text }
407410-- > deriving (Eq,Ord,Hashable,FromJSONKey)
408411--
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+-- @
409422class FromJSONKey a where
410423 -- | Strategy for parsing the key of a map-like container.
411424 fromJSONKey :: FromJSONKeyFunction a
@@ -504,6 +517,35 @@ coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fma
504517mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
505518mapFromJSONKeyFunction = fmap
506519
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+
507549-------------------------------------------------------------------------------
508550-- Functions needed for documentation
509551-------------------------------------------------------------------------------
@@ -1020,41 +1062,46 @@ parseAllNullarySum :: (SumFromString f, ConstructorNames f)
10201062parseAllNullarySum tname opts =
10211063 withText tname $ \tag ->
10221064 maybe (badTag tag) return $
1023− parseSumFromString opts tag
1065+ parseSumFromString modifier tag
10241066 where
1025− badTag tag = failWithCTags tname opts $ \cnames ->
1067+ badTag tag = failWithCTags tname modifier $ \cnames ->
10261068 "expected one of the tags " ++ show cnames ++
10271069 ", but found tag " ++ show tag
1070+ modifier = constructorTagModifier opts
10281071
10291072-- | Fail with an informative error message about a mismatched tag.
10301073-- The error message is parameterized by the list of expected tags,
10311074-- to be inferred from the result type of the parser.
10321075failWithCTags
1033− :: forall f a. ConstructorNames f
1034− => TypeName -> Options -> ([String] -> String) -> Parser (f a)
1035−failWithCTags tname opts f =
1076+ :: forall f a t. ConstructorNames f
1077+ => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)
1078+failWithCTags tname modifier f =
10361079 contextType tname . fail $ f cnames
10371080 where
1038− cnames = unTagged2 (constructorTags opts :: Tagged2 f [String])
1081+ cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])
10391082
10401083class SumFromString f where
1041− parseSumFromString :: Options -> Text -> Maybe (f a)
1084+ parseSumFromString :: (String -> String) -> Text -> Maybe (f a)
10421085
10431086instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where
10441087 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>
10451088 (R1 <$> parseSumFromString opts key)
10461089
10471090instance (Constructor c) => SumFromString (C1 c U1) where
1048− parseSumFromString opts key | key == name = Just $ M1 U1
1049− | otherwise = Nothing
1050− where
1051− name = pack $ constructorTagModifier opts $
1052− conName (undefined :: M1 _i c _f _p)
1091+ parseSumFromString modifier key
1092+ | key == name = Just $ M1 U1
1093+ | otherwise = Nothing
1094+ where
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
10531100
10541101-- | List of all constructor tags.
1055−constructorTags :: ConstructorNames a => Options -> Tagged2 a [String]
1056−constructorTags opts =
1057− fmap DList.toList (constructorNames' (constructorTagModifier opts))
1102+constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]
1103+constructorTags modifier =
1104+ fmap DList.toList (constructorNames' modifier)
10581105
10591106-- | List of all constructor names of an ADT, after a given conversion
10601107-- function. (Better inlining.)
@@ -1075,6 +1122,13 @@ instance Constructor c => ConstructorNames (C1 c a) where
10751122 where
10761123 cname = conName (undefined :: M1 _i c _f _p)
10771124
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+
10781132--------------------------------------------------------------------------------
10791133
10801134parseNonAllNullarySum :: ( FromPair arity f
@@ -1126,7 +1180,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) =
11261180
11271181 UntaggedValue -> parseUntaggedValue p
11281182 where
1129− failWith_ = failWithCTags tname opts
1183+ failWith_ = failWithCTags tname (constructorTagModifier opts)
11301184
11311185--------------------------------------------------------------------------------
11321186