Fix aeson ToJSONKey/FromJSONKey derivation

In Haskell, we have aeson which is a library providing reading and writing JSON.

It's mainly done through two type classes: ToJSON/FromJSON.

We can easily create a simple type and use it:

data RegularWeekend = RSaturday | RSunday
  deriving stock (Eq, Ord, Show, Generic)
  deriving anyclass (FromJSON, FromJSONKey, ToJSON, ToJSONKey)

encode RSunday -- "RSunday"

Now if we try to use it on the key part:

encode (Map.singleton RSunday ("Happy day" :: String)) -- "[[\"RSunday\",\"Happy day\"]]"

What happened here!?

Let's see how the derivation is done in ToJSONKey/FromJSONKey (instances responsible for JSON keys generation/rendering):

class ToJSONKey a where
    -- | Strategy for rendering the key for a map-like container.
    toJSONKey :: ToJSONKeyFunction a
    default toJSONKey :: ToJSON a => ToJSONKeyFunction a
    toJSONKey = ToJSONKeyValue toJSON toEncoding

The reason is clear, everything is based on ToJSON's toJSON' which produces a Value`, which can be any JSON types, so we cannot treat it as a string key.

To mitigate it, we have to create a derivation with produce only JSON strings, but to abstract this a bit, let's start with a simple pair oftype classes:

class ToSumText a where
  toSumText :: a -> T.Text

class FromSumText a where
  fromSumText :: T.Text -> Maybe a

Also, we provide a newtype which allows proper DerivingVia behavior:

newtype PureSum a = PureSum {unPureSum :: a}
  deriving stock (Eq, Ord, Show)

The Generics, machinery is beyond the scope of this log, but it prevents misuses:

data X0
  deriving stock (Generic)

deriving via (PureSum X0) instance ToSumText X0

being and empty datatype it yields a compile-time error:

    • Only pure sum types are supported (constructor(s) without values)
    • In the third argument of ‘ghc-prim-0.10.0:GHC.Prim.coerce’, namely
        ‘(toSumText @(PureSum X0))’
      In the expression:
        ghc-prim-0.10.0:GHC.Prim.coerce
          @(PureSum X0 -> Data.Text.Internal.Text)
          @(X0 -> Data.Text.Internal.Text) (toSumText @(PureSum X0))
      In an equation for ‘toSumText’:
          toSumText
            = ghc-prim-0.10.0:GHC.Prim.coerce
                @(PureSum X0 -> Data.Text.Internal.Text)
                @(X0 -> Data.Text.Internal.Text) (toSumText @(PureSum X0))
      When typechecking the code for ‘toSumText’
        in a derived instance for ‘ToSumText X0’:
        To see the code I am typechecking, use -ddump-deriv
   |
   | deriving via (PureSum X0) instance ToSumText X0

Given the previous type classses, we can implement aeson instances properly:

instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSON (PureSumWith transformation a) where
  parseJSON = withText (unConstructionName $ (to @a) <$> gConstructorName) pureSumWithParser

instance (FromSumText a, Generic a, GConstructorName (Rep a)) => FromJSONKey (PureSumWith transformation a) where
  fromJSONKey = FromJSONKeyTextParser pureSumWithParser

pureSumWithParser :: (FromSumText a) => T.Text -> Parser (PureSumWith transformation a)
pureSumWithParser x =
  maybe (fail $ "unknown value: " <> show x) (pure . PureSumWith) $
    fromSumText x

newtype ConstructorName x = ConstructorName {unConstructionName :: String}

instance Functor ConstructorName where
  fmap _ (ConstructorName x) = ConstructorName x

class GConstructorName f where
  gConstructorName :: ConstructorName (f a)

instance (KnownSymbol typeName) => GConstructorName (M1 D ('MetaData typeName c i b) a) where -- base type
  gConstructorName = ConstructorName $ symbolVal (Proxy @typeName)

instance (ToSumText a) => ToJSON (PureSumWith transformation a) where
  toJSON = toJSON . toSumText . unPureSumWith
  toEncoding = toEncoding . toSumText . unPureSumWith

instance (ToSumText a) => ToJSONKey (PureSumWith transformation a) where
  toJSONKey = toJSONKeyText (toSumText . unPureSumWith)

There are two important points in the code above:

• aeson provides toJSONKeyText/FromJSONKeyTextParser which narrows down parsing to Text Value, this is why we can easily plug FromSumText/ToSumText
• All the GConstructorName part is leveraging GHC's Generics, which is a way to represent values structure at type-level, feel free to have a look at the haddock page, the snippet only focuses on extracting the type name present in one of the structure type's metadata (note: the deriving mechanics skipped earlier is way more complex)

Let see it in action:

data BetterWeekend = BSaturday | BSunday
  deriving stock (Eq, Ord, Show, Generic)
  deriving (ToSumText, FromSumText, FromJSON, FromJSONKey, ToJSON, ToJSONKey) via (PureSum BetterWeekend)

And how it runs:

encode (Map.singleton BSunday ("Happy day" :: String)) -- "{\"BSunday\":\"Happy day\"}"
eitherDecode "{\"BSunday\":\"Happy day\"}" -- Right (Map.singleton BSunday ("Happy day" :: String))