{-# LANGUAGE CPP #-}
module Composite.Aeson.Formats.Generic
  ( abeJsonFormat, aesonJsonFormat, jsonArrayFormat, jsonObjectFormat
  , SumStyle(..), sumFromJson, sumToJson, jsonSumFormat
  ) where

import Composite.Aeson.Base (JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), FromJson(FromJson))
import Control.Arrow (first, second)
import Control.Lens (_Wrapped, over, unsnoc)
import Control.Monad.Error.Class (throwError)
import Data.Aeson (FromJSON, ToJSON, (.=), toJSON)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.BetterErrors as ABE
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as Aeson.KeyMap
#else
import qualified Data.HashMap.Strict as StrictHashMap
#endif
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NEL
import Data.Text (Text, intercalate, unpack)
import qualified Data.Vector as Vector
import Language.Haskell.TH.Syntax
  ( Lift, lift, liftString
#if MIN_VERSION_template_haskell(2,16,0)
  , liftTyped, TExp(TExp)
#endif
#if MIN_VERSION_template_haskell(2,17,0)
  , liftCode
#endif
  )

-- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'ToJSON' instance and an explicit @aeson-better-errors@ 'ABE.Parse'.
abeJsonFormat :: ToJSON a => ABE.Parse e a -> JsonFormat e a
abeJsonFormat :: forall a e. ToJSON a => Parse e a -> JsonFormat e a
abeJsonFormat Parse e a
p = forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat forall a b. (a -> b) -> a -> b
$ forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor forall a. ToJSON a => a -> Value
toJSON Parse e a
p

-- |Produce an explicit 'JsonFormat' by using the implicit Aeson 'FromJSON' and 'ToJSON' instances.
--
-- If an @aeson-better-errors@ parser is available for @a@, it's probably better to use 'abeJsonFormat' to get the enhanced error reporting.
aesonJsonFormat :: (ToJSON a, FromJSON a) => JsonFormat e a
aesonJsonFormat :: forall a e. (ToJSON a, FromJSON a) => JsonFormat e a
aesonJsonFormat = forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat forall a b. (a -> b) -> a -> b
$ forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor forall a. ToJSON a => a -> Value
toJSON forall (m :: * -> *) a e.
(Functor m, Monad m, FromJSON a) =>
ParseT e m a
ABE.fromAesonParser


-- |'JsonFormat' for any type which can be converted to/from a list which maps to a JSON array.
jsonArrayFormat :: (t -> [a]) -> ([a] -> ABE.Parse e t) -> JsonFormat e a -> JsonFormat e t
jsonArrayFormat :: forall t a e.
(t -> [a])
-> ([a] -> Parse e t) -> JsonFormat e a -> JsonFormat e t
jsonArrayFormat t -> [a]
oToList [a] -> Parse e t
iFromList =
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall a b. (a -> b) -> a -> b
$ \ (JsonProfunctor a -> Value
o Parse e a
i) ->
    forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (Array -> Value
Aeson.Array forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> Value
o forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [a]
oToList)
                   (forall (m :: * -> *) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [a]
ABE.eachInArray Parse e a
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [a] -> Parse e t
iFromList)

-- |'JsonFormat' for any type which can be converted to/from a list of pairs which maps to a JSON object.
jsonObjectFormat :: (t -> [(Text, a)]) -> ([(Text, a)] -> ABE.Parse e t) -> JsonFormat e a -> JsonFormat e t
jsonObjectFormat :: forall t a e.
(t -> [(Text, a)])
-> ([(Text, a)] -> Parse e t) -> JsonFormat e a -> JsonFormat e t
jsonObjectFormat t -> [(Text, a)]
oToList [(Text, a)] -> Parse e t
iFromList =
  forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped forall a b. (a -> b) -> a -> b
$ \ (JsonProfunctor a -> Value
o Parse e a
i) ->
#if MIN_VERSION_aeson(2,0,0)
    forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (Object -> Value
Aeson.Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. [(Key, v)] -> KeyMap v
Aeson.KeyMap.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> Key
Aeson.Key.fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second a -> Value
o) forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [(Text, a)]
oToList)
#else
    JsonProfunctor (Aeson.Object . StrictHashMap.fromList . map (second o) . oToList)
#endif
                   (forall (m :: * -> *) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [(Text, a)]
ABE.eachInObject Parse e a
i forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [(Text, a)] -> Parse e t
iFromList)


-- Describes how a sum format should map to JSON.
--
-- Summary of the styles:
--
--   * 'SumStyleFieldName' represents alternate sum branches as different mutually exclusive fields in an object, e.g. @{ "first": 123 }@.
--   * 'SumStyleTypeValue' represents alternate sum branches as different two-field objects, e.g. @{ "type": "first", "value": 123 }@.
--   * 'SumStyleMergeType' represents alternate sum branches by an intrinsic type field and only works with objects, e.g. @{ "type": "first", "a": 123 }@
--
-- Given:
--
-- @
--   data MySum
--     = SumFirst Int
--     | SumSecond String
--
--   mySumFormat :: 'SumStyle' -> 'JsonFormat' e MySum
--   mySumFormat style = jsonSumFormat style o i
--     where
--       o = \ case
--         SumFirst  i -> ("first",  'toJsonWithFormat' 'intJsonFormat'    i)
--         SumSecond s -> ("second", 'toJsonWithFormat' 'stringJsonFormat' s)
--       i = \ case
--         "first"  -> SumFirst  <$> 'parseJsonWithFormat' 'intJsonFormat'
--         "second" -> SumSecond <$> 'parseJsonWithFormat' 'stringJsonFormat'
-- @
--
-- For 'SumStyleFieldName', the object will always have a single field whose name is determined by which element of the sum it represents. For example:
--
-- @
--   toJsonWithFormat (mySumFormat SumStyleFieldName) (SumFirst 123)
-- @
--
-- will yield
--
-- @
--   { "first": 123 }
-- @
--
-- For @'SumStyleTypeValue' typeField valueField@, the object will have two fields @typeField@ and @valueField@, the former determining the format of the
-- latter. For example:
--
-- @
--   toJsonWithFormat (mySumFormat (SumStyleTypeValue "typ" "val")) (SumFirst 123)
-- @
--
-- will yield
--
-- @
--   { "typ": "first", "val": 123 }
-- @
--
-- For @'SumStyleMergeType' typeField@, its expected that every branch of the sum maps to an object in JSON, and the sum will add a new field @typeField@
-- to the object. It's fundamentally a bit dangerous as the assertion that each branch maps as an object is not enforced in the type system, so errors will
-- be produced at runtime. The previously given example can't be used as both branches (@Int@ and @String@) map to JSON values other than objects.
--
-- Given:
--
-- @
--   data FirstThing = FirstThing { a :: Int, b :: String }
--   firstThingJsonFormat = ... -- maps as { a: 123, b: "foo" }
--
--   data MySum
--     = SumFirst FirstThing
--     | ...
--
--   mySumFormat :: 'SumStyle' -> 'JsonFormat' e MySum
--   mySumFormat style = jsonSumFormat style o i
--     where
--       o = \ case
--         SumFirst ft -> ("first", 'toJsonWithFormat' 'firstThingJsonFormat' ft)
--         ...
--       i = \ case
--         "first"  -> SumFirst <$> 'parseJsonWithFormat' 'firstThingJsonFormat'
--         ...
-- @
--
-- Then
--
-- @
--   toJsonWithFormat (SumStyleMergeType "typ") (SumFirst (FirstThing 123 "abc"))
-- @
--
-- will yield
--
-- @
--   { "typ": "first", "a": 123, "b": "abc" }
-- @
--
-- __Warning:__ (again) that 'SumStyleMergeType' will trigger __run time errors__ (ala @error@) when converting to JSON if any of the sum branches yields
-- something that isn't an object. It will also yield a run time error if that object already contains a conflicting field.
data SumStyle
  = SumStyleFieldName
  -- ^Map to a single-field object with the field name determined by the sum branch and the field value being the encoded value for that branch.
  | SumStyleTypeValue Text Text
  -- ^Map to a two-field object with fixed field names, the first being the type field and the second beind the value field.
  | SumStyleMergeType Text
  -- ^Given that each sum branch maps to a JSON object, add/parse an additional field to that object with the given name.
  deriving (SumStyle -> SumStyle -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SumStyle -> SumStyle -> Bool
$c/= :: SumStyle -> SumStyle -> Bool
== :: SumStyle -> SumStyle -> Bool
$c== :: SumStyle -> SumStyle -> Bool
Eq, Int -> SumStyle -> ShowS
[SumStyle] -> ShowS
SumStyle -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SumStyle] -> ShowS
$cshowList :: [SumStyle] -> ShowS
show :: SumStyle -> String
$cshow :: SumStyle -> String
showsPrec :: Int -> SumStyle -> ShowS
$cshowsPrec :: Int -> SumStyle -> ShowS
Show)

instance Lift SumStyle where
  lift :: forall (m :: * -> *). Quote m => SumStyle -> m Exp
lift = \ case
    SumStyle
SumStyleFieldName     -> [| SumStyleFieldName |]
    SumStyleTypeValue Text
a Text
b -> [| SumStyleTypeValue $(liftString $ unpack a) $(liftString $ unpack b) |]
    SumStyleMergeType Text
a   -> [| SumStyleMergeType $(liftString $ unpack a) |]
#if MIN_VERSION_template_haskell(2,17,0)
  liftTyped :: forall (m :: * -> *). Quote m => SumStyle -> Code m SumStyle
liftTyped = forall a (m :: * -> *). m (TExp a) -> Code m a
liftCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Exp -> TExp a
TExp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped = fmap TExp . lift
#endif


-- |Helper used by the various sum format functions which takes a list of input format pairs and makes an oxford comma list of them.
expectedFieldsForInputs :: NonEmpty (Text, x) -> String
expectedFieldsForInputs :: forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs ((Text
f, x
_) :| [(Text, x)]
rest) =
  case forall s a. Snoc s s a a => s -> Maybe (s, a)
unsnoc [(Text, x)]
rest of
    Just ([(Text, x)]
prefix, (Text
fLast, x
_)) -> Text -> String
unpack forall a b. (a -> b) -> a -> b
$ Text
f forall a. Semigroup a => a -> a -> a
<> Text
", " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, x)]
prefix) forall a. Semigroup a => a -> a -> a
<> Text
", or " forall a. Semigroup a => a -> a -> a
<> Text
fLast
    Maybe ([(Text, x)], (Text, x))
Nothing                   -> Text -> String
unpack Text
f

-- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type.
sumFromJson :: SumStyle -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a
sumFromJson :: forall e a. SumStyle -> NonEmpty (Text, FromJson e a) -> Parse e a
sumFromJson = \ case
  SumStyle
SumStyleFieldName     -> forall e a. NonEmpty (Text, FromJson e a) -> Parse e a
fieldNameSumFromJson
  SumStyleTypeValue Text
t Text
v -> forall e a.
Text -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
typeValueSumFromJson Text
t Text
v
  SumStyleMergeType Text
t   -> forall e a. Text -> NonEmpty (Text, FromJson e a) -> Parse e a
mergeTypeSumFromJson Text
t

-- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type.
sumToJson :: SumStyle -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value
sumToJson :: forall a. SumStyle -> (a -> (Text, Value)) -> a -> Value
sumToJson = \ case
  SumStyle
SumStyleFieldName     -> forall a. (a -> (Text, Value)) -> a -> Value
fieldNameSumToJson
  SumStyleTypeValue Text
t Text
v -> forall a. Text -> Text -> (a -> (Text, Value)) -> a -> Value
typeValueSumToJson Text
t Text
v
  SumStyleMergeType Text
t   -> forall a. Text -> (a -> (Text, Value)) -> a -> Value
mergeTypeSumToJson Text
t

-- |'JsonFormat' which maps sum types to JSON according to 'SumStyle', given a pair of functions to decompose and recompose the sum type.
jsonSumFormat :: SumStyle -> (a -> (Text, Aeson.Value)) -> NonEmpty (Text, FromJson e a) -> JsonFormat e a
jsonSumFormat :: forall a e.
SumStyle
-> (a -> (Text, Value))
-> NonEmpty (Text, FromJson e a)
-> JsonFormat e a
jsonSumFormat SumStyle
style a -> (Text, Value)
oA NonEmpty (Text, FromJson e a)
iAs = forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat (forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (forall a. SumStyle -> (a -> (Text, Value)) -> a -> Value
sumToJson SumStyle
style a -> (Text, Value)
oA) (forall e a. SumStyle -> NonEmpty (Text, FromJson e a) -> Parse e a
sumFromJson SumStyle
style NonEmpty (Text, FromJson e a)
iAs))

-- |Map a sum type from JSON in the 'SumStyleFieldName' style.
fieldNameSumFromJson :: NonEmpty (Text, FromJson e a) -> ABE.Parse e a
fieldNameSumFromJson :: forall e a. NonEmpty (Text, FromJson e a) -> Parse e a
fieldNameSumFromJson NonEmpty (Text, FromJson e a)
iAs = do
#if MIN_VERSION_aeson(2,0,0)
  [Key]
fields <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
(Object -> Either err a) -> ParseT err m a
ABE.withObject 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
. forall v. KeyMap v -> [Key]
Aeson.KeyMap.keys
#else
  fields <- ABE.withObject $ pure . StrictHashMap.keys
#endif
  case [Key]
fields of
    [Key
f] ->
#if MIN_VERSION_aeson(2,0,0)
      let ft :: Text
ft = Key -> Text
Aeson.Key.toText Key
f
      in case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ft (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Text, FromJson e a)
iAs) of
        Just (FromJson Parse e a
iA) -> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
ft Parse e a
iA
        Maybe (FromJson e a)
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall err. String -> ParseError err
ABE.InvalidJSON forall a b. (a -> b) -> a -> b
$ String
"unknown field " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
ft forall a. Semigroup a => a -> a -> a
<> String
", expected one of " forall a. Semigroup a => a -> a -> a
<> String
expected
#else
      case lookup f (NEL.toList iAs) of
        Just (FromJson iA) -> ABE.key f iA
        Nothing -> throwError $ ABE.InvalidJSON $ "unknown field " <> unpack f <> ", expected one of " <> expected
#endif
    [] ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall err. String -> ParseError err
ABE.InvalidJSON forall a b. (a -> b) -> a -> b
$ String
"expected an object with one field (" forall a. Semigroup a => a -> a -> a
<> String
expected forall a. Semigroup a => a -> a -> a
<> String
") not an empty object"
    [Key]
_ ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall err. String -> ParseError err
ABE.InvalidJSON forall a b. (a -> b) -> a -> b
$ String
"expected an object with one field (" forall a. Semigroup a => a -> a -> a
<> String
expected forall a. Semigroup a => a -> a -> a
<> String
") not many fields"
  where
    expected :: String
expected = forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs NonEmpty (Text, FromJson e a)
iAs

-- |Map a sum type to JSON in the 'SumStyleFieldName' style.
fieldNameSumToJson :: (a -> (Text, Aeson.Value)) -> a -> Aeson.Value
#if MIN_VERSION_aeson(2,0,0)
fieldNameSumToJson :: forall a. (a -> (Text, Value)) -> a -> Value
fieldNameSumToJson a -> (Text, Value)
oA = \ (a -> (Text, Value)
oA -> (Text
t, Value
v)) -> [(Key, Value)] -> Value
Aeson.object [Text -> Key
Aeson.Key.fromText Text
t forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v]
#else
fieldNameSumToJson oA = \ (oA -> (t, v)) -> Aeson.object [t .= v]
#endif

-- |Map a sum type from JSON in the 'SumStyleTypeValue' style.
typeValueSumFromJson :: Text -> Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a
typeValueSumFromJson :: forall e a.
Text -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
typeValueSumFromJson Text
typeField Text
valueField NonEmpty (Text, FromJson e a)
iAs = do
  Text
t <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
typeField forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
ABE.asText
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Text, FromJson e a)
iAs) of
    Just (FromJson Parse e a
iA) -> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
valueField Parse e a
iA
    Maybe (FromJson e a)
Nothing -> forall {a}. String -> ParseT e Identity a
toss forall a b. (a -> b) -> a -> b
$ String
"expected " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
typeField forall a. Semigroup a => a -> a -> a
<> String
" to be one of " forall a. Semigroup a => a -> a -> a
<> String
expected
  where
    expected :: String
expected = forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs NonEmpty (Text, FromJson e a)
iAs
    toss :: String -> ParseT e Identity a
toss = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. String -> ErrorSpecifics err
ABE.FromAeson

-- |Map a sum type to JSON in the 'SumStyleTypeValue' style.
typeValueSumToJson :: Text -> Text -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value
#if MIN_VERSION_aeson(2,0,0)
typeValueSumToJson :: forall a. Text -> Text -> (a -> (Text, Value)) -> a -> Value
typeValueSumToJson Text
typeField Text
valueField a -> (Text, Value)
oA = \ (a -> (Text, Value)
oA -> (Text
t, Value
v)) -> [(Key, Value)] -> Value
Aeson.object [Text -> Key
Aeson.Key.fromText Text
typeField forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t, Text -> Key
Aeson.Key.fromText Text
valueField forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
v]
#else
typeValueSumToJson typeField valueField oA = \ (oA -> (t, v)) -> Aeson.object [typeField .= t, valueField .= v]
#endif

-- |Map a sum type from JSON in the 'SumStyleMergeType' style.
mergeTypeSumFromJson :: Text -> NonEmpty (Text, FromJson e a) -> ABE.Parse e a
mergeTypeSumFromJson :: forall e a. Text -> NonEmpty (Text, FromJson e a) -> Parse e a
mergeTypeSumFromJson Text
typeField NonEmpty (Text, FromJson e a)
iAs = do
  Text
t <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
typeField forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
ABE.asText
  case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t (forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Text, FromJson e a)
iAs) of
    Just (FromJson Parse e a
iA) -> Parse e a
iA
    Maybe (FromJson e a)
Nothing -> forall {a}. String -> ParseT e Identity a
toss forall a b. (a -> b) -> a -> b
$ String
"expected " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
typeField forall a. Semigroup a => a -> a -> a
<> String
" to be one of " forall a. Semigroup a => a -> a -> a
<> String
expected
  where
    expected :: String
expected = forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs NonEmpty (Text, FromJson e a)
iAs
    toss :: String -> ParseT e Identity a
toss = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall err. String -> ErrorSpecifics err
ABE.FromAeson

-- |Map a sum type to JSON in the 'SumStyleMergeType' style.
mergeTypeSumToJson :: Text -> (a -> (Text, Aeson.Value)) -> a -> Aeson.Value
mergeTypeSumToJson :: forall a. Text -> (a -> (Text, Value)) -> a -> Value
mergeTypeSumToJson Text
typeField a -> (Text, Value)
oA = \ a
a -> case a -> (Text, Value)
oA a
a of
#if MIN_VERSION_aeson(2,0,0)
  (Text
t, Aeson.Object Object
fields) | forall a. Key -> KeyMap a -> Bool
Aeson.KeyMap.member (Text -> Key
Aeson.Key.fromText Text
typeField) Object
fields ->
#else
  (t, Aeson.Object fields) | StrictHashMap.member typeField fields ->
#endif
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "
         forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (Object -> Value
Aeson.Object Object
fields) forall a. Semigroup a => a -> a -> a
<> String
") which already contains the field " forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
typeField
  (Text
t, Aeson.Object Object
fields) ->
#if MIN_VERSION_aeson(2,0,0)
    Object -> Value
Aeson.Object (forall v. Key -> v -> KeyMap v -> KeyMap v
Aeson.KeyMap.insert (Text -> Key
Aeson.Key.fromText Text
typeField) (Text -> Value
Aeson.String Text
t) Object
fields)
#else
    Aeson.Object (StrictHashMap.insert typeField (Aeson.String t) fields)
#endif
  (Text
t, Value
other) ->
    forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "
         forall a. Semigroup a => a -> a -> a
<> String
"(" forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t forall a. Semigroup a => a -> a -> a
<> String
", " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Value
other forall a. Semigroup a => a -> a -> a
<> String
") which isn't an object"