{-# 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 :: Parse e a -> JsonFormat e a
abeJsonFormat Parse e a
p = JsonProfunctor e a a -> JsonFormat e a
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat (JsonProfunctor e a a -> JsonFormat e a)
-> JsonProfunctor e a a -> JsonFormat e a
forall a b. (a -> b) -> a -> b
$ (a -> Value) -> Parse e a -> JsonProfunctor e a a
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor a -> Value
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 :: JsonFormat e a
aesonJsonFormat = JsonProfunctor e a a -> JsonFormat e a
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat (JsonProfunctor e a a -> JsonFormat e a)
-> JsonProfunctor e a a -> JsonFormat e a
forall a b. (a -> b) -> a -> b
$ (a -> Value) -> Parse e a -> JsonProfunctor e a a
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor a -> Value
forall a. ToJSON a => a -> Value
toJSON Parse e a
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 :: (t -> [a])
-> ([a] -> Parse e t) -> JsonFormat e a -> JsonFormat e t
jsonArrayFormat t -> [a]
oToList [a] -> Parse e t
iFromList =
  ASetter
  (JsonFormat e a)
  (JsonFormat e t)
  (JsonProfunctor e a a)
  (JsonProfunctor e t t)
-> (JsonProfunctor e a a -> JsonProfunctor e t t)
-> JsonFormat e a
-> JsonFormat e t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (JsonFormat e a)
  (JsonFormat e t)
  (JsonProfunctor e a a)
  (JsonProfunctor e t t)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((JsonProfunctor e a a -> JsonProfunctor e t t)
 -> JsonFormat e a -> JsonFormat e t)
-> (JsonProfunctor e a a -> JsonProfunctor e t t)
-> JsonFormat e a
-> JsonFormat e t
forall a b. (a -> b) -> a -> b
$ \ (JsonProfunctor a -> Value
o Parse e a
i) ->
    (t -> Value) -> Parse e t -> JsonProfunctor e t t
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (Array -> Value
Aeson.Array (Array -> Value) -> (t -> Array) -> t -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Array) -> (t -> [Value]) -> t -> Array
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map a -> Value
o ([a] -> [Value]) -> (t -> [a]) -> t -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> [a]
oToList)
                   (Parse e a -> ParseT e Identity [a]
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [a]
ABE.eachInArray Parse e a
i ParseT e Identity [a] -> ([a] -> Parse e t) -> Parse e t
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 :: (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 =
  ASetter
  (JsonFormat e a)
  (JsonFormat e t)
  (JsonProfunctor e a a)
  (JsonProfunctor e t t)
-> (JsonProfunctor e a a -> JsonProfunctor e t t)
-> JsonFormat e a
-> JsonFormat e t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (JsonFormat e a)
  (JsonFormat e t)
  (JsonProfunctor e a a)
  (JsonProfunctor e t t)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
_Wrapped ((JsonProfunctor e a a -> JsonProfunctor e t t)
 -> JsonFormat e a -> JsonFormat e t)
-> (JsonProfunctor e a a -> JsonProfunctor e t t)
-> JsonFormat e a
-> JsonFormat e t
forall a b. (a -> b) -> a -> b
$ \ (JsonProfunctor a -> Value
o Parse e a
i) ->
#if MIN_VERSION_aeson(2,0,0)
    (t -> Value) -> Parse e t -> JsonProfunctor e t t
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (Object -> Value
Aeson.Object (Object -> Value) -> (t -> Object) -> t -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
Aeson.KeyMap.fromList ([(Key, Value)] -> Object) -> (t -> [(Key, Value)]) -> t -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, a) -> (Key, Value)) -> [(Text, a)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Key) -> (Text, Value) -> (Key, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Text -> Key
Aeson.Key.fromText ((Text, Value) -> (Key, Value))
-> ((Text, a) -> (Text, Value)) -> (Text, a) -> (Key, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> (Text, a) -> (Text, Value)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second a -> Value
o) ([(Text, a)] -> [(Key, Value)])
-> (t -> [(Text, a)]) -> t -> [(Key, Value)]
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
                   (Parse e a -> ParseT e Identity [(Text, a)]
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [(Text, a)]
ABE.eachInObject Parse e a
i ParseT e Identity [(Text, a)]
-> ([(Text, a)] -> Parse e t) -> Parse e t
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
(SumStyle -> SumStyle -> Bool)
-> (SumStyle -> SumStyle -> Bool) -> Eq SumStyle
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
(Int -> SumStyle -> ShowS)
-> (SumStyle -> String) -> ([SumStyle] -> ShowS) -> Show SumStyle
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 :: SumStyle -> Q 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 = liftCode . fmap TExp . lift
#elif MIN_VERSION_template_haskell(2,16,0)
  liftTyped :: SumStyle -> Q (TExp SumStyle)
liftTyped = (Exp -> TExp SumStyle) -> Q Exp -> Q (TExp SumStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Exp -> TExp SumStyle
forall a. Exp -> TExp a
TExp (Q Exp -> Q (TExp SumStyle))
-> (SumStyle -> Q Exp) -> SumStyle -> Q (TExp SumStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumStyle -> Q Exp
forall t. Lift t => t -> Q Exp
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 :: NonEmpty (Text, x) -> String
expectedFieldsForInputs ((Text
f, x
_) :| [(Text, x)]
rest) =
  case [(Text, x)] -> Maybe ([(Text, x)], (Text, x))
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 (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
f Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
intercalate Text
", " (((Text, x) -> Text) -> [(Text, x)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, x) -> Text
forall a b. (a, b) -> a
fst [(Text, x)]
prefix) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", or " Text -> Text -> Text
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 :: SumStyle -> NonEmpty (Text, FromJson e a) -> Parse e a
sumFromJson = \ case
  SumStyle
SumStyleFieldName     -> NonEmpty (Text, FromJson e a) -> Parse e a
forall e a. NonEmpty (Text, FromJson e a) -> Parse e a
fieldNameSumFromJson
  SumStyleTypeValue Text
t Text
v -> Text -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
forall e a.
Text -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
typeValueSumFromJson Text
t Text
v
  SumStyleMergeType Text
t   -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
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 :: SumStyle -> (a -> (Text, Value)) -> a -> Value
sumToJson = \ case
  SumStyle
SumStyleFieldName     -> (a -> (Text, Value)) -> a -> Value
forall a. (a -> (Text, Value)) -> a -> Value
fieldNameSumToJson
  SumStyleTypeValue Text
t Text
v -> Text -> Text -> (a -> (Text, Value)) -> a -> Value
forall a. Text -> Text -> (a -> (Text, Value)) -> a -> Value
typeValueSumToJson Text
t Text
v
  SumStyleMergeType Text
t   -> Text -> (a -> (Text, Value)) -> a -> Value
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 :: 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 = JsonProfunctor e a a -> JsonFormat e a
forall e a. JsonProfunctor e a a -> JsonFormat e a
JsonFormat ((a -> Value) -> Parse e a -> JsonProfunctor e a a
forall e a b. (a -> Value) -> Parse e b -> JsonProfunctor e a b
JsonProfunctor (SumStyle -> (a -> (Text, Value)) -> a -> Value
forall a. SumStyle -> (a -> (Text, Value)) -> a -> Value
sumToJson SumStyle
style a -> (Text, Value)
oA) (SumStyle -> NonEmpty (Text, FromJson e a) -> Parse e a
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 :: 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 <- (Object -> Either e [Key]) -> ParseT e Identity [Key]
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
(Object -> Either err a) -> ParseT err m a
ABE.withObject ((Object -> Either e [Key]) -> ParseT e Identity [Key])
-> (Object -> Either e [Key]) -> ParseT e Identity [Key]
forall a b. (a -> b) -> a -> b
$ [Key] -> Either e [Key]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Key] -> Either e [Key])
-> (Object -> [Key]) -> Object -> Either e [Key]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Key]
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 Text -> [(Text, FromJson e a)] -> Maybe (FromJson e a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
ft (NonEmpty (Text, FromJson e a) -> [(Text, FromJson e a)]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Text, FromJson e a)
iAs) of
        Just (FromJson Parse e a
iA) -> Text -> Parse e a -> Parse e a
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 -> ParseError e -> Parse e a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> Parse e a) -> ParseError e -> Parse e a
forall a b. (a -> b) -> a -> b
$ String -> ParseError e
forall err. String -> ParseError err
ABE.InvalidJSON (String -> ParseError e) -> String -> ParseError e
forall a b. (a -> b) -> a -> b
$ String
"unknown field " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
ft String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", expected one of " String -> ShowS
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
    [] ->
      ParseError e -> Parse e a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> Parse e a) -> ParseError e -> Parse e a
forall a b. (a -> b) -> a -> b
$ String -> ParseError e
forall err. String -> ParseError err
ABE.InvalidJSON (String -> ParseError e) -> String -> ParseError e
forall a b. (a -> b) -> a -> b
$ String
"expected an object with one field (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
expected String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") not an empty object"
    [Key]
_ ->
      ParseError e -> Parse e a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> Parse e a) -> ParseError e -> Parse e a
forall a b. (a -> b) -> a -> b
$ String -> ParseError e
forall err. String -> ParseError err
ABE.InvalidJSON (String -> ParseError e) -> String -> ParseError e
forall a b. (a -> b) -> a -> b
$ String
"expected an object with one field (" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
expected String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") not many fields"
  where
    expected :: String
expected = NonEmpty (Text, FromJson e a) -> String
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 :: (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 Key -> Value -> (Key, Value)
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 :: Text -> Text -> NonEmpty (Text, FromJson e a) -> Parse e a
typeValueSumFromJson Text
typeField Text
valueField NonEmpty (Text, FromJson e a)
iAs = do
  Text
t <- Text -> ParseT e Identity Text -> ParseT e Identity Text
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
typeField ParseT e Identity Text
forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
ABE.asText
  case Text -> [(Text, FromJson e a)] -> Maybe (FromJson e a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t (NonEmpty (Text, FromJson e a) -> [(Text, FromJson e a)]
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (Text, FromJson e a)
iAs) of
    Just (FromJson Parse e a
iA) -> Text -> Parse e a -> Parse e a
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 -> String -> Parse e a
forall a. String -> ParseT e Identity a
toss (String -> Parse e a) -> String -> Parse e a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
typeField String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to be one of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
expected
  where
    expected :: String
expected = NonEmpty (Text, FromJson e a) -> String
forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs NonEmpty (Text, FromJson e a)
iAs
    toss :: String -> ParseT e Identity a
toss = ParseError e -> ParseT e Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> ParseT e Identity a)
-> (String -> ParseError e) -> String -> ParseT e Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathPiece] -> ErrorSpecifics e -> ParseError e
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] (ErrorSpecifics e -> ParseError e)
-> (String -> ErrorSpecifics e) -> String -> ParseError e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorSpecifics e
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 :: 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 Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
t, Text -> Key
Aeson.Key.fromText Text
valueField Key -> Value -> (Key, Value)
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 :: Text -> NonEmpty (Text, FromJson e a) -> Parse e a
mergeTypeSumFromJson Text
typeField NonEmpty (Text, FromJson e a)
iAs = do
  Text
t <- Text -> ParseT e Identity Text -> ParseT e Identity Text
forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
ABE.key Text
typeField ParseT e Identity Text
forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
ABE.asText
  case Text -> [(Text, FromJson e a)] -> Maybe (FromJson e a)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t (NonEmpty (Text, FromJson e a) -> [(Text, FromJson e a)]
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 -> String -> Parse e a
forall a. String -> ParseT e Identity a
toss (String -> Parse e a) -> String -> Parse e a
forall a b. (a -> b) -> a -> b
$ String
"expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
typeField String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" to be one of " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
expected
  where
    expected :: String
expected = NonEmpty (Text, FromJson e a) -> String
forall x. NonEmpty (Text, x) -> String
expectedFieldsForInputs NonEmpty (Text, FromJson e a)
iAs
    toss :: String -> ParseT e Identity a
toss = ParseError e -> ParseT e Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ParseError e -> ParseT e Identity a)
-> (String -> ParseError e) -> String -> ParseT e Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PathPiece] -> ErrorSpecifics e -> ParseError e
forall err. [PathPiece] -> ErrorSpecifics err -> ParseError err
ABE.BadSchema [] (ErrorSpecifics e -> ParseError e)
-> (String -> ErrorSpecifics e) -> String -> ParseError e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorSpecifics e
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 :: 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) | Key -> Object -> Bool
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
    String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "
         String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show (Object -> Value
Aeson.Object Object
fields) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") which already contains the field " String -> ShowS
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 (Key -> Value -> Object -> 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) ->
    String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"PRECONDITION VIOLATED: encoding a value with merge type sum style yielded "
         String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"(" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
t String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
", " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
other String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
") which isn't an object"