module Composite.Aeson.CoRecord
( ToJsonFormatField, FromJsonFormatField, JsonFormatField
, DefaultJsonFormatField(defaultJsonFormatField)
, fieldToJson, fieldFromJson, fieldJsonFormat
) where
import Composite.Aeson.Base (FromJson(FromJson), JsonFormat(JsonFormat), JsonProfunctor(JsonProfunctor), ToJson(ToJson), wrappedJsonFormat)
import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat)
import Composite.Aeson.Formats.Generic (SumStyle, jsonSumFormat, sumToJson, sumFromJson)
import Composite.CoRecord (CoRec(CoVal), Field, fieldToRec)
import Composite.Record ((:->), Rec((:&), RNil), RecWithContext(rmapWithContext), recordToNonEmpty, ReifyNames, reifyNames)
import Data.Aeson (Value)
import qualified Data.Aeson.BetterErrors as ABE
import Data.Functor.Identity (Identity(Identity))
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (catMaybes, fromMaybe, listToMaybe)
import Data.Text (Text)
import Data.Vinyl (RApply, RMap, RecApplicative, RecordToList, rapply, recordToList, (<<&>>))
import Data.Vinyl.Functor (Compose(Compose), (:.), Const(Const), Lift(Lift))
import Data.Vinyl.Lens (type (∈))
import Data.Proxy (Proxy(Proxy))
type ToJsonFormatField rs = Rec ToJson rs
type FromJsonFormatField e rs = Rec (FromJson e) rs
type JsonFormatField e rs = Rec (JsonFormat e) rs
class DefaultJsonFormatField (rs :: [*]) where
defaultJsonFormatField :: JsonFormatField e rs
instance DefaultJsonFormatField '[] where
defaultJsonFormatField :: forall e. JsonFormatField e '[]
defaultJsonFormatField = forall {u} (a :: u -> *). Rec a '[]
RNil
instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where
defaultJsonFormatField :: forall e. JsonFormatField e ((s :-> a) : rs)
defaultJsonFormatField = forall a e.
Wrapped a =>
JsonFormat e (Unwrapped a) -> JsonFormat e a
wrappedJsonFormat forall a e. DefaultJsonFormat a => JsonFormat e a
defaultJsonFormat forall {u} (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& (forall (rs :: [*]) e.
DefaultJsonFormatField rs =>
JsonFormatField e rs
defaultJsonFormatField :: JsonFormatField e rs)
fieldToJson
:: forall (rs :: [*]) r' (rs' :: [*]).
( rs ~ (r' ': rs'), RApply rs, RMap rs
, RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )
=> SumStyle -> ToJsonFormatField rs -> Field rs -> Value
fieldToJson :: forall (rs :: [*]) r' (rs' :: [*]).
(rs ~ (r' : rs'), RApply rs, RMap rs, RecApplicative rs,
RecWithContext rs rs, RecordToList rs', ReifyNames rs) =>
SumStyle -> ToJsonFormatField rs -> Field rs -> Value
fieldToJson SumStyle
sumStyle ToJsonFormatField rs
fmts = forall a. SumStyle -> (a -> (Text, Value)) -> a -> Value
sumToJson SumStyle
sumStyle Field rs -> (Text, Value)
o
where
namedFmts :: Rec ((,) Text :. ToJson) rs
namedFmts :: Rec ((,) Text :. ToJson) rs
namedFmts = forall (rs :: [*]) (f :: * -> *).
ReifyNames rs =>
Rec f rs -> Rec ((,) Text :. f) rs
reifyNames ToJsonFormatField rs
fmts
o :: Field rs -> (Text, Value)
o :: Field rs -> (Text, Value)
o = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"fieldToRec somehow produced all Nothings")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {u} (rs :: [u]) a.
RecordToList rs =>
Rec (Const a) rs -> [a]
recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
rapply Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs = Rec ((,) Text :. ToJson) rs
namedFmts forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
Rec f rs -> (forall (x :: u). f x -> g x) -> Rec g rs
<<&>> \ (Compose (Text
name, ToJson x -> Value
oa)) ->
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
(x :: k).
op (f x) (g x) -> Lift op f g x
Lift forall a b. (a -> b) -> a -> b
$ forall k a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
name,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Value
oa)
fieldFromJson
:: forall (rs :: [*]) r' (rs' :: [*]) e.
( rs ~ (r' ': rs'), RApply rs, RMap rs
, RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )
=> SumStyle -> FromJsonFormatField e rs -> ABE.Parse e (Field rs)
fieldFromJson :: forall (rs :: [*]) r' (rs' :: [*]) e.
(rs ~ (r' : rs'), RApply rs, RMap rs, RecApplicative rs,
RecWithContext rs rs, RecordToList rs', ReifyNames rs) =>
SumStyle -> FromJsonFormatField e rs -> Parse e (Field rs)
fieldFromJson SumStyle
sumStyle FromJsonFormatField e rs
fmts = forall e a. SumStyle -> NonEmpty (Text, FromJson e a) -> Parse e a
sumFromJson SumStyle
sumStyle NonEmpty (Text, FromJson e (Field rs))
i
where
namedFmts :: Rec ((,) Text :. FromJson e) rs
namedFmts :: Rec ((,) Text :. FromJson e) rs
namedFmts = forall (rs :: [*]) (f :: * -> *).
ReifyNames rs =>
Rec f rs -> Rec ((,) Text :. f) rs
reifyNames FromJsonFormatField e rs
fmts
i :: NonEmpty (Text, FromJson e (Field rs))
i :: NonEmpty (Text, FromJson e (Field rs))
i = forall {u} (rs :: [u]) a (r :: u).
RecordToList rs =>
Rec (Const a) (r : rs) -> NonEmpty a
recordToNonEmpty forall a b. (a -> b) -> a -> b
$ forall (ss :: [*]) (ts :: [*]) (proxy :: [*] -> *) (f :: * -> *)
(g :: * -> *).
RecWithContext ss ts =>
proxy ss
-> (forall r. (r ∈ ss) => f r -> g r) -> Rec f ts -> Rec g ts
rmapWithContext (forall {k} (t :: k). Proxy t
Proxy @rs) forall r.
(r ∈ rs) =>
(:.) ((,) Text) (FromJson e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase Rec ((,) Text :. FromJson e) rs
namedFmts
where
oneCase :: forall r. r ∈ rs => ((,) Text :. FromJson e) r -> Const (Text, FromJson e (Field rs)) r
oneCase :: forall r.
(r ∈ rs) =>
(:.) ((,) Text) (FromJson e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (Text
name, FromJson Parse e r
ia)) =
forall k a (b :: k). a -> Const a b
Const (Text
name, forall e a. Parse e a -> FromJson e a
FromJson (forall {u} (r :: u) (b :: [u]) (a :: u -> *).
(r ∈ b) =>
a r -> CoRec a b
CoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse e r
ia))
fieldJsonFormat
:: forall (rs :: [*]) r' (rs' :: [*]) e.
( rs ~ (r' ': rs'), RApply rs, RMap rs
, RecApplicative rs, RecWithContext rs rs, RecordToList rs', ReifyNames rs )
=> SumStyle -> JsonFormatField e rs -> JsonFormat e (Field rs)
fieldJsonFormat :: forall (rs :: [*]) r' (rs' :: [*]) e.
(rs ~ (r' : rs'), RApply rs, RMap rs, RecApplicative rs,
RecWithContext rs rs, RecordToList rs', ReifyNames rs) =>
SumStyle -> JsonFormatField e rs -> JsonFormat e (Field rs)
fieldJsonFormat SumStyle
sumStyle JsonFormatField e rs
fmts = forall a e.
SumStyle
-> (a -> (Text, Value))
-> NonEmpty (Text, FromJson e a)
-> JsonFormat e a
jsonSumFormat SumStyle
sumStyle Field rs -> (Text, Value)
o NonEmpty (Text, FromJson e (Field rs))
i
where
namedFmts :: Rec ((,) Text :. JsonFormat e) rs
namedFmts :: Rec ((,) Text :. JsonFormat e) rs
namedFmts = forall (rs :: [*]) (f :: * -> *).
ReifyNames rs =>
Rec f rs -> Rec ((,) Text :. f) rs
reifyNames JsonFormatField e rs
fmts
o :: Field rs -> (Text, Value)
o :: Field rs -> (Text, Value)
o = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"fieldToRec somehow produced all Nothings")
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe a
listToMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall {u} (rs :: [u]) a.
RecordToList rs =>
Rec (Const a) rs -> [a]
recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
rapply Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [*]).
(RMap rs, RecApplicative rs) =>
Field rs -> Rec Maybe rs
fieldToRec
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs = Rec ((,) Text :. JsonFormat e) rs
namedFmts forall {u} (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
Rec f rs -> (forall (x :: u). f x -> g x) -> Rec g rs
<<&>> \ (Compose (Text
name, JsonFormat (JsonProfunctor x -> Value
oa Parse e x
_))) ->
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
(x :: k).
op (f x) (g x) -> Lift op f g x
Lift forall a b. (a -> b) -> a -> b
$ forall k a (b :: k). a -> Const a b
Const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
name,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Value
oa)
i :: NonEmpty (Text, FromJson e (Field rs))
i :: NonEmpty (Text, FromJson e (Field rs))
i = forall {u} (rs :: [u]) a (r :: u).
RecordToList rs =>
Rec (Const a) (r : rs) -> NonEmpty a
recordToNonEmpty forall a b. (a -> b) -> a -> b
$ forall (ss :: [*]) (ts :: [*]) (proxy :: [*] -> *) (f :: * -> *)
(g :: * -> *).
RecWithContext ss ts =>
proxy ss
-> (forall r. (r ∈ ss) => f r -> g r) -> Rec f ts -> Rec g ts
rmapWithContext (forall {k} (t :: k). Proxy t
Proxy @rs) forall r.
(r ∈ rs) =>
(:.) ((,) Text) (JsonFormat e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase Rec ((,) Text :. JsonFormat e) rs
namedFmts
where
oneCase :: forall r. r ∈ rs => ((,) Text :. JsonFormat e) r -> Const (Text, FromJson e (Field rs)) r
oneCase :: forall r.
(r ∈ rs) =>
(:.) ((,) Text) (JsonFormat e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (Text
name, JsonFormat (JsonProfunctor r -> Value
_ Parse e r
ia))) =
forall k a (b :: k). a -> Const a b
Const (Text
name, forall e a. Parse e a -> FromJson e a
FromJson (forall {u} (r :: u) (b :: [u]) (a :: u -> *).
(r ∈ b) =>
a r -> CoRec a b
CoVal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Identity a
Identity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse e r
ia))