{-# 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 = String
-> (Object
    -> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Value
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName) ((Object
  -> Parser (TaggedObject typeName tagKey contentsKey tag f))
 -> Value
 -> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> (Object
    -> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Value
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Object
o Object -> Key -> Parser (Some tag)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Parser (Some tag)
-> (Some tag
    -> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) =>
  Parser (TaggedObject typeName tagKey contentsKey tag f))
 -> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> (FromJSON (f a) =>
    Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a b. (a -> b) -> a -> b
$
        DSum tag f -> TaggedObject typeName tagKey contentsKey tag f
forall k (typeName :: Symbol) (tagKey :: Symbol)
       (contentsKey :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TaggedObject typeName tagKey contentsKey tag f
TaggedObject (DSum tag f -> TaggedObject typeName tagKey contentsKey tag f)
-> (f a -> DSum tag f)
-> f a
-> TaggedObject typeName tagKey contentsKey tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>)
          (f a -> TaggedObject typeName tagKey contentsKey tag f)
-> Parser (f a)
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (f a)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. 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
      [ String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Key -> Some tag -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= tag a -> Some tag
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Pair) -> Pair) -> (ToJSON (f a) => Pair) -> Pair
forall a b. (a -> b) -> a -> b
$ String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @contentsKey)) Key -> f a -> Pair
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 (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
      [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
        [ String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Key -> Some tag -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= tag a -> Some tag
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Series) -> Series)
-> (ToJSON (f a) => Series) -> Series
forall a b. (a -> b) -> a -> b
$
            String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @contentsKey)) Key -> f a -> Series
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 = ((Object -> Parser (TaggedObjectInline typeName tagKey tag f))
 -> Value -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Value
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Value
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName)) Value
v ((Object -> Parser (TaggedObjectInline typeName tagKey tag f))
 -> Parser (TaggedObjectInline typeName tagKey tag f))
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Object
o Object -> Key -> Parser (Some tag)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Parser (Some tag)
-> (Some tag -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) =>
  Parser (TaggedObjectInline typeName tagKey tag f))
 -> Parser (TaggedObjectInline typeName tagKey tag f))
-> (FromJSON (f a) =>
    Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b. (a -> b) -> a -> b
$
        DSum tag f -> TaggedObjectInline typeName tagKey tag f
forall k (typeName :: Symbol) (tagKey :: Symbol) (tag :: k -> *)
       (f :: k -> *).
DSum tag f -> TaggedObjectInline typeName tagKey tag f
TaggedObjectInline (DSum tag f -> TaggedObjectInline typeName tagKey tag f)
-> (f a -> DSum tag f)
-> f a
-> TaggedObjectInline typeName tagKey tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> TaggedObjectInline typeName tagKey tag f)
-> Parser (f a)
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
forall a b. (a -> b) -> a -> b
$
    case f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa of
      Object Object
o ->
        Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
          Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert
            (String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)))
            (Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)
            Object
o
      Value
_ ->
        String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$
          Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName) String -> String -> String
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 ->
        [Parser (ObjectWithSingleField typeName tag f)]
-> Parser (ObjectWithSingleField typeName tag f)
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,
            String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
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 ((Key -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a. (Key -> Parser a) -> Value -> Parser a
liftKeyParser Key -> Parser (Some tag)
keyParser) Value
j
    where
      typeName :: String
typeName = Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. 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 -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
 -> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Some tag -> Parser (Some tag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some tag -> Parser (Some tag))
-> (Key -> Some tag) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Some tag
coerce (Text -> Some tag) -> (Key -> Text) -> Key -> Some tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyText Text -> Some tag
fromText -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
 -> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Some tag -> Parser (Some tag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some tag -> Parser (Some tag))
-> (Key -> Some tag) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Some tag
fromText (Text -> Some tag) -> (Key -> Text) -> Key -> Some tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyTextParser Text -> Parser (Some tag)
parseText -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
 -> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Text -> Parser (Some tag)
parseText (Text -> Parser (Some tag))
-> (Key -> Text) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
        FromJSONKeyValue Value -> Parser (Some tag)
valueParser -> (Value -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
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 = String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Key" (Key -> Parser a
f (Key -> Parser a) -> (Text -> Key) -> Text -> Parser a
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 = String
-> (Array -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
typeName ((Array -> Parser (ObjectWithSingleField typeName tag f))
 -> Value -> Parser (ObjectWithSingleField typeName tag f))
-> (Array -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Array
a ->
        case Array -> Int
forall a. Vector a -> Int
V.length Array
a of
          Int
2 -> do
            Some tag a
tag <- Value -> Parser (Some tag)
keyParser (Value -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a b. (a -> b) -> a -> b
$ Array
a Array -> Int -> Value
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (ObjectWithSingleField typeName tag f))
 -> Parser (ObjectWithSingleField typeName tag f))
-> (FromJSON (f a) =>
    Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
              DSum tag f -> ObjectWithSingleField typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField (DSum tag f -> ObjectWithSingleField typeName tag f)
-> (f a -> DSum tag f)
-> f a
-> ObjectWithSingleField typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> ObjectWithSingleField typeName tag f)
-> Parser (f a) -> Parser (ObjectWithSingleField typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
1)
          Int
n ->
            String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
              [String] -> String
unwords
                [ String
"Cannot unpack array of length",
                  Int -> String
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 = String
-> (Object -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
typeName ((Object -> Parser (ObjectWithSingleField typeName tag f))
 -> Value -> Parser (ObjectWithSingleField typeName tag f))
-> (Object -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
        case Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o of
          [] -> String -> Parser (ObjectWithSingleField typeName tag f)
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 (Value -> Parser (Some tag))
-> (Text -> Value) -> Text -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String (Text -> Parser (Some tag)) -> Text -> Parser (Some tag)
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (ObjectWithSingleField typeName tag f))
 -> Parser (ObjectWithSingleField typeName tag f))
-> (FromJSON (f a) =>
    Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
              DSum tag f -> ObjectWithSingleField typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField (DSum tag f -> ObjectWithSingleField typeName tag f)
-> (f a -> DSum tag f)
-> f a
-> ObjectWithSingleField typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> ObjectWithSingleField typeName tag f)
-> Parser (f a) -> Parser (ObjectWithSingleField typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
          [Pair]
_ ->
            String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
              [String] -> String
unwords
                [ String
"Cannot unpack object with",
                  Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([Key] -> Int) -> [Key] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Key] -> String) -> [Key] -> String
forall a b. (a -> b) -> a -> b
$ Object -> [Key]
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
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 (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) Key -> f a -> Pair
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 (tag a -> Some tag
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 Key -> f a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa]
        Value
v -> [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value
v, f a -> Value
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Encoding) -> Encoding)
-> (ToJSON (f a) => Encoding) -> Encoding
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 (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)) (f a -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
      ToJSONKeyValue Some tag -> Value
toValue Some tag -> Encoding
_ -> case Some tag -> Value
toValue (tag a -> Some tag
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' (Text -> Encoding' Key
forall a. Text -> Encoding' a
E.text Text
t) (f a -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
        Value
v -> [Value] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Value
v, f a -> Value
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 = String
-> (Array -> Parser (TwoElemArray typeName tag f))
-> Value
-> Parser (TwoElemArray typeName tag f)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName)) ((Array -> Parser (TwoElemArray typeName tag f))
 -> Value -> Parser (TwoElemArray typeName tag f))
-> (Array -> Parser (TwoElemArray typeName tag f))
-> Value
-> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Array
a ->
    case Array -> Int
forall a. Vector a -> Int
V.length Array
a of
      Int
2 -> do
        Some tag a
tag <- Value -> Parser (Some tag)
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a b. (a -> b) -> a -> b
$ Array
a Array -> Int -> Value
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (TwoElemArray typeName tag f))
 -> Parser (TwoElemArray typeName tag f))
-> (FromJSON (f a) => Parser (TwoElemArray typeName tag f))
-> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$
          DSum tag f -> TwoElemArray typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TwoElemArray typeName tag f
TwoElemArray (DSum tag f -> TwoElemArray typeName tag f)
-> (f a -> DSum tag f) -> f a -> TwoElemArray typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> TwoElemArray typeName tag f)
-> Parser (f a) -> Parser (TwoElemArray typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
1)
      Int
n ->
        String -> Parser (TwoElemArray typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (TwoElemArray typeName tag f))
-> String -> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unwords
            [ String
"Cannot unpack array of length",
              Int -> String
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, f a -> Value
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
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
       r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Encoding) -> Encoding)
-> (ToJSON (f a) => Encoding) -> Encoding
forall a b. (a -> b) -> a -> b
$ [Value] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa]