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