{-# 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 :: Value -> Parser (TaggedObject typeName tagKey contentsKey tag f)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @typeName) forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tagKey)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Some tag a
tag) ->
      forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
        forall k (typeName :: Symbol) (tagKey :: Symbol)
       (contentsKey :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TaggedObject typeName tagKey contentsKey tag f
TaggedObject forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
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 typeName tagKey contentsKey tag f -> Value
toJSON (TaggedObject (tag a
tag :=> f a
fa)) =
    [Pair] -> Value
object
      [ forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tagKey)) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag,
        forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @contentsKey)) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa
      ]

  toEncoding :: TaggedObject typeName tagKey contentsKey tag f -> Encoding
toEncoding (TaggedObject (tag a
tag :=> f a
fa)) =
    Series -> Encoding
E.pairs forall a b. (a -> b) -> a -> b
$
      forall a. Monoid a => [a] -> a
mconcat
        [ forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tagKey)) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag,
          forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
            forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @contentsKey)) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
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 :: Value -> Parser (TaggedObjectInline typeName tagKey tag f)
parseJSON Value
v = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @typeName)) Value
v forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tagKey)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Some tag a
tag) ->
      forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
        forall k (typeName :: Symbol) (tagKey :: Symbol) (tag :: k -> *)
       (f :: k -> *).
DSum tag f -> TaggedObjectInline typeName tagKey tag f
TaggedObjectInline forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
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 typeName tagKey tag f -> Value
toJSON (TaggedObjectInline (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
    case forall a. ToJSON a => a -> Value
toJSON f a
fa of
      Object Object
o ->
        Object -> Value
Object forall a b. (a -> b) -> a -> b
$
          forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert
            (forall a. IsString a => String -> a
fromString (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @tagKey)))
            (forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)
            Object
o
      Value
_ ->
        forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$
          forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @typeName) forall a. Semigroup a => a -> a -> a
<> String
"#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 :: Value -> Parser (ObjectWithSingleField typeName tag f)
parseJSON Value
j =
    case Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
tagParser of
      Left Value -> Parser (Some tag)
valueParser ->
        forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseArray Value -> Parser (Some tag)
valueParser Value
j,
            (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject Value -> Parser (Some tag)
valueParser Value
j,
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
              [String] -> String
unwords
                [ String
"Cannot parse",
                  String
typeName,
                  String
"into a dependent sum: not an object or array"
                ]
          ]
      Right Key -> Parser (Some tag)
keyParser -> (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject (forall a. (Key -> Parser a) -> Value -> Parser a
liftKeyParser Key -> Parser (Some tag)
keyParser) Value
j
    where
      typeName :: String
typeName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
Proxy @typeName

      tagParser :: Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
tagParser = case forall a. FromJSONKey a => FromJSONKeyFunction a
fromJSONKey @(Some tag) of
        FromJSONKeyFunction (Some tag)
FromJSONKeyCoerce -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyText Text -> Some tag
fromText -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Some tag
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyTextParser Text -> Parser (Some tag)
parseText -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Parser (Some tag)
parseText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyValue Value -> Parser (Some tag)
valueParser -> forall a b. a -> Either a b
Left Value -> Parser (Some tag)
valueParser

      liftKeyParser :: (Key -> Parser a) -> Value -> Parser a
      liftKeyParser :: forall a. (Key -> Parser a) -> Value -> Parser a
liftKeyParser Key -> Parser a
f = forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Key" (Key -> Parser a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText)

      parseArray ::
        (Value -> Parser (Some tag)) ->
        Value ->
        Parser (ObjectWithSingleField typeName tag f)
      parseArray :: (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseArray Value -> Parser (Some tag)
keyParser = forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
typeName forall a b. (a -> b) -> a -> b
$ \Array
a ->
        case forall a. Vector a -> Int
V.length Array
a of
          Int
2 -> do
            Some tag a
tag <- Value -> Parser (Some tag)
keyParser forall a b. (a -> b) -> a -> b
$ Array
a forall a. Vector a -> Int -> a
! Int
0
            forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
              forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a forall a. Vector a -> Int -> a
! Int
1)
          Int
n ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
              [String] -> String
unwords
                [ String
"Cannot unpack array of length",
                  forall a. Show a => a -> String
show Int
n,
                  String
"into a dependent sum"
                ]

      parseObject ::
        (Value -> Parser (Some tag)) ->
        Value ->
        Parser (ObjectWithSingleField typeName tag f)
      parseObject :: (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject Value -> Parser (Some tag)
keyParser = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
typeName forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o of
          [] -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty object"
          [(Key
k, Value
v)] -> do
            Some tag a
tag <- Value -> Parser (Some tag)
keyParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText Key
k
            forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
              forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
          [Pair]
_ ->
            forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
              [String] -> String
unwords
                [ String
"Cannot unpack object with",
                  forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v -> [Key]
KM.keys Object
o,
                  String
"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 typeName tag f -> Value
toJSON (ObjectWithSingleField (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
    case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey @(Some tag) of
      ToJSONKeyText Some tag -> Key
toKey Some tag -> Encoding' Key
_ -> [Pair] -> Value
object [Some tag -> Key
toKey (forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa]
      ToJSONKeyValue Some tag -> Value
toValue Some tag -> Encoding
_ -> case Some tag -> Value
toValue (forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) of
        String Text
t -> [Pair] -> Value
object [Text -> Key
K.fromText Text
t forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa]
        Value
v -> forall a. ToJSON a => a -> Value
toJSON [Value
v, forall a. ToJSON a => a -> Value
toJSON f a
fa]

  toEncoding :: ObjectWithSingleField typeName tag f -> Encoding
toEncoding (ObjectWithSingleField (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
    case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey @(Some tag) of
      ToJSONKeyText Some tag -> Key
_ Some tag -> Encoding' Key
toKeyEncoding ->
        Series -> Encoding
E.pairs (Encoding' Key -> Encoding -> Series
E.pair' (Some tag -> Encoding' Key
toKeyEncoding (forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)) (forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
      ToJSONKeyValue Some tag -> Value
toValue Some tag -> Encoding
_ -> case Some tag -> Value
toValue (forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) of
        String Text
t -> Series -> Encoding
E.pairs (Encoding' Key -> Encoding -> Series
E.pair' (forall a. Text -> Encoding' a
E.text Text
t) (forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
        Value
v -> forall a. ToJSON a => a -> Encoding
toEncoding [Value
v, forall a. ToJSON a => a -> Value
toJSON f a
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 :: Value -> Parser (TwoElemArray typeName tag f)
parseJSON = forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @typeName)) forall a b. (a -> b) -> a -> b
$ \Array
a ->
    case forall a. Vector a -> Int
V.length Array
a of
      Int
2 -> do
        Some tag a
tag <- forall a. FromJSON a => Value -> Parser a
parseJSON forall a b. (a -> b) -> a -> b
$ Array
a forall a. Vector a -> Int -> a
! Int
0
        forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$
          forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TwoElemArray typeName tag f
TwoElemArray forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a forall a. Vector a -> Int -> a
! Int
1)
      Int
n ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
          [String] -> String
unwords
            [ String
"Cannot unpack array of length",
              forall a. Show a => a -> String
show Int
n,
              String
"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 typeName tag f -> Value
toJSON (TwoElemArray (tag a
tag :=> f a
fa)) =
    forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON [forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, forall a. ToJSON a => a -> Value
toJSON f a
fa]

  toEncoding :: TwoElemArray typeName tag f -> Encoding
toEncoding (TwoElemArray (tag a
tag :=> f a
fa)) =
    forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
       (f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
toEncoding [forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, forall a. ToJSON a => a -> Value
toJSON f a
fa]