aeson-dependent-sum-0.1.0.1: src/Data/Aeson/Dependent/Sum.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
-- |
-- Module : Data.Aeson.Dependent.Sum
-- Description : newtype wrappers for dependent sums, for use with @-XDerivingVia@
-- Copyright : (c) 2022 Jack Kelly
-- License : GPL-3.0-or-later
-- Maintainer : jack@jackkelly.name
-- Stability : experimental
-- Portability : non-portable
--
-- When reading/writing JSON, you sometimes want to handle structures
-- where the value at one key determines the type of the entire
-- record. (In OpenAPI, they are sometimes called [polymorphic
-- structures](https://swagger.io/docs/specification/data-models/inheritance-and-polymorphism/)
-- and are specified using a @oneOf@ schema with the
-- @discriminator/propertyName@ keyword.)
--
-- A naive approach would use a sum-of-records, and either @aeson@'s
-- built-in @anyclass@ deriving or a manual two-step parse:
--
-- @
-- data Fighter = F { ... } deriving anyclass (FromJSON, ToJSON)
-- data Rogue = R { ... } deriving anyclass (FromJSON, ToJSON)
-- data Wizard = W { ... } deriving anyclass (FromJSON, ToJSON)
--
-- data Character = Fighter Fighter | Rogue Rogue | Wizard Wizard
-- instance FromJSON Character where
-- parseJSON = withObject \"Character\" $ \\o ->
-- charClass <- o .: "class" :: Parser Text
-- case charClass of
-- "fighter" -> do
-- favouredWeapon <- o .: "favouredWeapon"
-- attackBonus <- o .: "attackBonus"
-- -- etc.
-- @
--
-- This works, but sometimes you want to manipulate the tag itself as
-- a first-class value. In these instances, the
-- [@dependent-sum@](https://hackage.haskell.org/package/dependent-sum)
-- library can help, and we can also use
-- [@deriving via@](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/deriving_via.html#extension-DerivingVia)
-- to derive JSON instances on the @Character@ newtype:
--
-- @
-- data CharacterClass a where
-- Fighter :: CharacterClass Fighter
-- Rogue :: CharacterClass Rogue
-- Wizard :: CharacterClass Wizard
--
-- -- From the "constraints-extras" package:
-- \$(deriveArgDict ''CharacterClass)
-- -- From the "dependent-sum-template" package. Not required, but useful:
-- \$(deriveGShow ''CharacterClass)
-- \$(deriveGEq ''CharacterClass)
-- \$(deriveGCompare ''CharacterClass)
--
-- newtype Character = Character (DSum CharacterClass 'Data.Functor.Identity.Identity')
-- deriving (FromJSON, ToJSON)
-- via ('TaggedObjectInline' \"Character\" "class" CharacterClass 'Data.Functor.Identity.Identity')
-- @
--
-- To derive JSON instances on @Character@, we need to provide
-- 'FromJSON' and 'ToJSON' instances for the @CharacterClass@ tag as
-- well as for each record type. The 'Data.Some.Some' wrapper from the
-- [@some@](https://hackage.haskell.org/package/some) package lets us
-- wrap @CharacterClass@ so that its kind matches what 'FromJSON'
-- expects:
--
-- @
-- instance FromJSON (Some CharacterClass) where
-- parseJSON = withText \"CharacterClass\" $ \\t ->
-- case t of
-- "fighter" -> pure $ Some Fighter
-- "rogue" -> pure $ Some Rogue
-- "wizard" -> pure $ Some Wizard
-- @
--
-- The @newtype@s in this module implement several different
-- encoding/decoding strategies which roughly parallel the ones in
-- [@aeson@](https://hackage.haskell.org/package/aeson).
module Data.Aeson.Dependent.Sum where
import Data.Aeson
( FromJSON (..),
FromJSONKey (..),
FromJSONKeyFunction (..),
Key,
ToJSON (..),
ToJSONKey (..),
ToJSONKeyFunction (..),
Value (..),
object,
withArray,
withObject,
withText,
(.:),
(.=),
)
import qualified Data.Aeson.Encoding as E
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Parser)
import Data.Coerce (coerce)
import Data.Constraint.Extras (Has', has')
import Data.Dependent.Sum (DSum (..))
import Data.Foldable (asum)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Some (Some (..))
import Data.String (fromString)
import Data.Vector ((!))
import qualified Data.Vector as V
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
-- | Newtype for 'DSum's representing JSON objects where one field
-- determines the "type" of the object, and all the other data fields
-- are stored under a distinct key. Analogous to the
-- 'Data.Aeson.TaggedObject' constructor in 'Data.Aeson.SumEncoding'.
--
-- To derive 'FromJSON' and 'ToJSON' instances for JSON like this:
--
-- @
-- {
-- "class": "fighter", -- or "rogue", or "wizard"
-- "data": { ... } -- the exact fields differ depending on the value at "class".
-- }
-- @
--
-- You would derive the instance like this:
--
-- @
-- newtype Character = Character ('DSum' CharacterClass 'Data.Functor.Identity.Identity')
-- deriving (FromJSON, ToJSON)
-- via (TaggedObject \"Character\" "class" "data" CharacterClass 'Data.Functor.Identity.Identity')
-- @
--
-- @since 0.1.0.0
newtype
TaggedObject
(typeName :: Symbol)
(tagKey :: Symbol)
(contentsKey :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TaggedObject (DSum tag f)
-- | @since 0.1.0.0
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
KnownSymbol contentsKey,
FromJSON (Some tag),
Has' FromJSON tag f
) =>
FromJSON (TaggedObject typeName tagKey contentsKey tag f)
where
parseJSON = withObject (symbolVal $ Proxy @typeName) $ \o ->
o .: fromString (symbolVal (Proxy @tagKey)) >>= \(Some tag) ->
has' @FromJSON @f tag $
TaggedObject . (tag :=>)
<$> o .: fromString (symbolVal (Proxy @contentsKey))
-- | @since 0.1.0.0
instance
( KnownSymbol tagKey,
KnownSymbol contentsKey,
ToJSON (Some tag),
Has' ToJSON tag f
) =>
ToJSON (TaggedObject typeName tagKey contentsKey tag f)
where
toJSON (TaggedObject (tag :=> fa)) =
object
[ fromString (symbolVal (Proxy @tagKey)) .= Some tag,
has' @ToJSON @f tag $ fromString (symbolVal (Proxy @contentsKey)) .= fa
]
toEncoding (TaggedObject (tag :=> fa)) =
E.pairs $
mconcat
[ fromString (symbolVal (Proxy @tagKey)) .= Some tag,
has' @ToJSON @f tag $
fromString (symbolVal (Proxy @contentsKey)) .= fa
]
-- | Newtype for 'DSum's representing JSON objects where one field
-- determines the "type" of the object, and all the other data fields
-- are stored at the same level.
--
-- To derive 'FromJSON' and 'ToJSON' instances for JSON like this:
--
-- @
-- {
-- "class": "wizard", -- or "fighter", or "rogue"
-- -- These fields will differ depending on the value at "class".
-- "frogsLegs": 42,
-- "eyesOfNewt": 9001
-- }
-- @
--
-- You would derive the instance like this:
--
-- @
-- newtype Character = Character ('DSum' CharacterClass 'Data.Functor.Identity.Identity')
-- deriving (FromJSON, ToJSON)
-- via (TaggedObjectInline \"Character\" "class" CharacterClass 'Data.Functor.Identity.Identity')
-- @
--
-- @since 0.1.0.0
newtype
TaggedObjectInline
(typeName :: Symbol)
(tagKey :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TaggedObjectInline (DSum tag f)
-- | @since 0.1.0.0
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
Has' FromJSON tag f,
FromJSON (Some tag)
) =>
FromJSON (TaggedObjectInline typeName tagKey tag f)
where
parseJSON v = flip (withObject (symbolVal $ Proxy @typeName)) v $ \o ->
o .: fromString (symbolVal (Proxy @tagKey)) >>= \(Some tag) ->
has' @FromJSON @f tag $
TaggedObjectInline . (tag :=>) <$> parseJSON v
-- | @since 0.1.0.0
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
Has' ToJSON tag f,
ToJSON (Some tag)
) =>
ToJSON (TaggedObjectInline typeName tagKey tag f)
where
toJSON (TaggedObjectInline (tag :=> fa)) = has' @ToJSON @f tag $
case toJSON fa of
Object o ->
Object $
KM.insert
(fromString (symbolVal (Proxy @tagKey)))
(toJSON $ Some tag)
o
_ ->
error $
symbolVal (Proxy @typeName) <> "#toJSON: did not serialise to Object"
-- | Newtype for 'DSum's representing JSON objects where the object
-- has exactly one key, and the name of that key one field determines
-- the "type" of the object. All the other data fields are stored in
-- the corresponding value. Analogous to the
-- 'Data.Aeson.ObjectWithSingleField' constructor in
-- 'Data.Aeson.SumEncoding'.
--
-- To derive 'FromJSON' and 'ToJSON' instances for JSON like this:
--
-- @
-- {
-- "wizard": { -- or "fighter", or "rogue"
-- -- The contents of this object will differ depending on the key.
-- "frogsLegs": 42,
-- "eyesOfNewt": 9001
-- }
-- }
-- @
--
-- You would derive the instance like this:
--
-- @
-- newtype Character = Character ('DSum' CharacterClass 'Data.Functor.Identity.Identity')
-- deriving (FromJSON, ToJSON)
-- via (ObjectWithSingleField \"Character\" CharacterClass 'Data.Functor.Identity.Identity')
-- @
--
-- If the 'FromJSONKey'/'ToJSONKey' instances for @'Some' tag@ encode
-- to something other than a JSON string, then a two-element array
-- will be parsed/generated instead, like in 'TwoElemArray'.
--
-- @since 0.1.0.0
newtype
ObjectWithSingleField
(typeName :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= ObjectWithSingleField (DSum tag f)
-- | @since 0.1.0.0
instance
( KnownSymbol typeName,
Has' FromJSON tag f,
FromJSONKey (Some tag)
) =>
FromJSON (ObjectWithSingleField typeName tag f)
where
parseJSON j =
case tagParser of
Left valueParser ->
asum
[ parseArray valueParser j,
parseObject valueParser j,
fail $
unwords
[ "Cannot parse",
typeName,
"into a dependent sum: not an object or array"
]
]
Right keyParser -> parseObject (liftKeyParser keyParser) j
where
typeName = symbolVal $ Proxy @typeName
tagParser = case fromJSONKey @(Some tag) of
FromJSONKeyCoerce -> Right $ pure . coerce . K.toText
FromJSONKeyText fromText -> Right $ pure . fromText . K.toText
FromJSONKeyTextParser parseText -> Right $ parseText . K.toText
FromJSONKeyValue valueParser -> Left valueParser
liftKeyParser :: (Key -> Parser a) -> Value -> Parser a
liftKeyParser f = withText "Key" (f . K.fromText)
parseArray ::
(Value -> Parser (Some tag)) ->
Value ->
Parser (ObjectWithSingleField typeName tag f)
parseArray keyParser = withArray typeName $ \a ->
case V.length a of
2 -> do
Some tag <- keyParser $ a ! 0
has' @FromJSON @f tag $
ObjectWithSingleField . (tag :=>) <$> parseJSON (a ! 1)
n ->
fail $
unwords
[ "Cannot unpack array of length",
show n,
"into a dependent sum"
]
parseObject ::
(Value -> Parser (Some tag)) ->
Value ->
Parser (ObjectWithSingleField typeName tag f)
parseObject keyParser = withObject typeName $ \o ->
case KM.toList o of
[] -> fail "Empty object"
[(k, v)] -> do
Some tag <- keyParser . String $ K.toText k
has' @FromJSON @f tag $
ObjectWithSingleField . (tag :=>) <$> parseJSON v
_ ->
fail $
unwords
[ "Cannot unpack object with",
show . length $ KM.keys o,
"into a dependent sum"
]
-- | @since 0.1.0.0
instance
( Has' ToJSON tag f,
ToJSONKey (Some tag)
) =>
ToJSON (ObjectWithSingleField typeName tag f)
where
toJSON (ObjectWithSingleField (tag :=> fa)) = has' @ToJSON @f tag $
case toJSONKey @(Some tag) of
ToJSONKeyText toKey _ -> object [toKey (Some tag) .= fa]
ToJSONKeyValue toValue _ -> case toValue (Some tag) of
String t -> object [K.fromText t .= fa]
v -> toJSON [v, toJSON fa]
toEncoding (ObjectWithSingleField (tag :=> fa)) = has' @ToJSON @f tag $
case toJSONKey @(Some tag) of
ToJSONKeyText _ toKeyEncoding ->
E.pairs (E.pair' (toKeyEncoding (Some tag)) (toEncoding fa))
ToJSONKeyValue toValue _ -> case toValue (Some tag) of
String t -> E.pairs (E.pair' (E.text t) (toEncoding fa))
v -> toEncoding [v, toJSON fa]
-- | Newtype for 'DSum's representing serialisation to/from a
-- two-element array. The @tag@ is stored in the first elemnt, and the
-- serialised value is stored in the second. Analogous to the
-- 'Data.Aeson.TwoElemArray' constructor in 'Data.Aeson.SumEncoding'.
--
-- To derive 'FromJSON' and 'ToJSON' instances for JSON like this:
--
-- @
-- [
-- "wizard", -- or "fighter", or "rogue"
-- -- The contents of this object will differ depending on the previous element.
-- {
-- "frogsLegs": 42,
-- "eyesOfNewt": 9001
-- }
-- ]
-- @
--
-- You would derive the instance like this:
--
-- @
-- newtype Character = Character ('DSum' CharacterClass 'Data.Functor.Identity.Identity')
-- deriving (FromJSON, ToJSON)
-- via (TwoElemArray \"Character\" CharacterClass 'Data.Functor.Identity.Identity')
-- @
--
-- @since 0.1.0.0
newtype
TwoElemArray
(typeName :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TwoElemArray (DSum tag f)
-- | @since 0.1.0.0
instance
( KnownSymbol typeName,
Has' FromJSON tag f,
FromJSON (Some tag)
) =>
FromJSON (TwoElemArray typeName tag f)
where
parseJSON = withArray (symbolVal (Proxy @typeName)) $ \a ->
case V.length a of
2 -> do
Some tag <- parseJSON $ a ! 0
has' @FromJSON @f tag $
TwoElemArray . (tag :=>) <$> parseJSON (a ! 1)
n ->
fail $
unwords
[ "Cannot unpack array of length",
show n,
"into a dependent sum"
]
-- | @since 0.1.0.0
instance
( Has' ToJSON tag f,
ToJSON (Some tag)
) =>
ToJSON (TwoElemArray typeName tag f)
where
toJSON (TwoElemArray (tag :=> fa)) =
has' @ToJSON @f tag $ toJSON [toJSON $ Some tag, toJSON fa]
toEncoding (TwoElemArray (tag :=> fa)) =
has' @ToJSON @f tag $ toEncoding [toJSON $ Some tag, toJSON fa]