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 = RNil
instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where
defaultJsonFormatField = wrappedJsonFormat defaultJsonFormat :& (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 sumStyle fmts = sumToJson sumStyle o
where
namedFmts :: Rec ((,) Text :. ToJson) rs
namedFmts = reifyNames fmts
o :: Field rs -> (Text, Value)
o = fromMaybe (error "fieldToRec somehow produced all Nothings")
. listToMaybe . catMaybes
. (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
. rapply outputs
. fieldToRec
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs = namedFmts <<&>> \ (Compose (name, ToJson oa)) ->
Lift $ Const . fmap ((name,) . 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 sumStyle fmts = sumFromJson sumStyle i
where
namedFmts :: Rec ((,) Text :. FromJson e) rs
namedFmts = reifyNames fmts
i :: NonEmpty (Text, FromJson e (Field rs))
i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts
where
oneCase :: forall r. r ∈ rs => ((,) Text :. FromJson e) r -> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (name, FromJson ia)) =
Const (name, FromJson (CoVal . Identity <$> 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 sumStyle fmts = jsonSumFormat sumStyle o i
where
namedFmts :: Rec ((,) Text :. JsonFormat e) rs
namedFmts = reifyNames fmts
o :: Field rs -> (Text, Value)
o = fromMaybe (error "fieldToRec somehow produced all Nothings")
. listToMaybe . catMaybes
. (recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
. rapply outputs
. fieldToRec
outputs :: Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
outputs = namedFmts <<&>> \ (Compose (name, JsonFormat (JsonProfunctor oa _))) ->
Lift $ Const . fmap ((name,) . oa)
i :: NonEmpty (Text, FromJson e (Field rs))
i = recordToNonEmpty $ rmapWithContext (Proxy @rs) oneCase namedFmts
where
oneCase :: forall r. r ∈ rs => ((,) Text :. JsonFormat e) r -> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (name, JsonFormat (JsonProfunctor _ ia))) =
Const (name, FromJson (CoVal . Identity <$> ia))