{-# 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
)
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
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
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)
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)
data SumStyle
= SumStyleFieldName
| SumStyleTypeValue Text Text
| SumStyleMergeType Text
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
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
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
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
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))
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
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
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
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
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
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"