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 of records which contain JSON encoders for each element of @rs@.
type ToJsonFormatField rs = Rec ToJson rs

-- |Type of records which contain JSON decoders for each element of @rs@.
type FromJsonFormatField e rs = Rec (FromJson e) rs

-- |Type of records which contain JSON formats for each element of @rs@.
type JsonFormatField e rs = Rec (JsonFormat e) rs

-- |Class which makes up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.
class DefaultJsonFormatField (rs :: [*]) where
  -- |Make up a 'JsonFormatField' for some @rs@ where each @r ~ s :-> a@ by using the 'DefaultJsonFormat' instance for each @a@.
  defaultJsonFormatField :: JsonFormatField e rs

instance DefaultJsonFormatField '[] where
  defaultJsonFormatField :: JsonFormatField e '[]
defaultJsonFormatField = JsonFormatField e '[]
forall u (a :: u -> *). Rec a '[]
RNil

instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where
  defaultJsonFormatField :: JsonFormatField e ((s :-> a) : rs)
defaultJsonFormatField = JsonFormat e (Unwrapped (s :-> a)) -> JsonFormat e (s :-> a)
forall a e.
Wrapped a =>
JsonFormat e (Unwrapped a) -> JsonFormat e a
wrappedJsonFormat JsonFormat e (Unwrapped (s :-> a))
forall a e. DefaultJsonFormat a => JsonFormat e a
defaultJsonFormat JsonFormat e (s :-> a)
-> Rec (JsonFormat e) rs -> JsonFormatField e ((s :-> a) : rs)
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
forall e. JsonFormatField e rs
defaultJsonFormatField :: JsonFormatField e rs)

-- |Make a @'Field' rs -> 'Value'@ given how to map the sum type to JSON along with a record with encoders for each value the field could have.
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 -> ToJsonFormatField rs -> Field rs -> Value
fieldToJson SumStyle
sumStyle ToJsonFormatField rs
fmts = SumStyle -> (Field rs -> (Text, Value)) -> Field rs -> Value
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 = ToJsonFormatField rs -> Rec ((,) Text :. ToJson) rs
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 = (Text, Value) -> Maybe (Text, Value) -> (Text, Value)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (Text, Value)
forall a. HasCallStack => [Char] -> a
error [Char]
"fieldToRec somehow produced all Nothings")
      (Maybe (Text, Value) -> (Text, Value))
-> (Field rs -> Maybe (Text, Value)) -> Field rs -> (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Maybe (Text, Value)
forall a. [a] -> Maybe a
listToMaybe ([(Text, Value)] -> Maybe (Text, Value))
-> (Field rs -> [(Text, Value)]) -> Field rs -> Maybe (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
catMaybes
      ([Maybe (Text, Value)] -> [(Text, Value)])
-> (Field rs -> [Maybe (Text, Value)])
-> Field rs
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)]
forall u (rs :: [u]) a. RecordToList rs => Rec (Const a) rs -> [a]
recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
      (Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
-> (Field rs -> Rec (Const (Maybe (Text, Value))) rs)
-> Field rs
-> [Maybe (Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
-> Rec Maybe rs -> Rec (Const (Maybe (Text, Value))) rs
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
      (Rec Maybe rs -> Rec (Const (Maybe (Text, Value))) rs)
-> (Field rs -> Rec Maybe rs)
-> Field rs
-> Rec (Const (Maybe (Text, Value))) rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rs -> Rec Maybe rs
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 Rec ((,) Text :. ToJson) rs
-> (forall x.
    (:.) ((,) Text) ToJson x
    -> Lift (->) Maybe (Const (Maybe (Text, Value))) x)
-> Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
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)) ->
      (Maybe x -> Const (Maybe (Text, Value)) x)
-> Lift (->) Maybe (Const (Maybe (Text, Value))) 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 ((Maybe x -> Const (Maybe (Text, Value)) x)
 -> Lift (->) Maybe (Const (Maybe (Text, Value))) x)
-> (Maybe x -> Const (Maybe (Text, Value)) x)
-> Lift (->) Maybe (Const (Maybe (Text, Value))) x
forall a b. (a -> b) -> a -> b
$ Maybe (Text, Value) -> Const (Maybe (Text, Value)) x
forall k a (b :: k). a -> Const a b
Const (Maybe (Text, Value) -> Const (Maybe (Text, Value)) x)
-> (Maybe x -> Maybe (Text, Value))
-> Maybe x
-> Const (Maybe (Text, Value)) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> (Text, Value)) -> Maybe x -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
name,) (Value -> (Text, Value)) -> (x -> Value) -> x -> (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Value
oa)

-- |Make a @'ABE.Parse' e (Field rs)@ given how to map the sum type from JSON along with a record with decoders for each value the field could have.
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 -> FromJsonFormatField e rs -> Parse e (Field rs)
fieldFromJson SumStyle
sumStyle FromJsonFormatField e rs
fmts = SumStyle
-> NonEmpty (Text, FromJson e (Field rs)) -> Parse e (Field rs)
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 = FromJsonFormatField e rs -> Rec ((,) Text :. FromJson e) rs
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 = Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
-> NonEmpty (Text, FromJson e (Field rs))
forall u (rs :: [u]) a (r :: u).
RecordToList rs =>
Rec (Const a) (r : rs) -> NonEmpty a
recordToNonEmpty (Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
 -> NonEmpty (Text, FromJson e (Field rs)))
-> Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
-> NonEmpty (Text, FromJson e (Field rs))
forall a b. (a -> b) -> a -> b
$ Proxy rs
-> (forall r.
    (r ∈ rs) =>
    (:.) ((,) Text) (FromJson e) r
    -> Const (Text, FromJson e (Field rs)) r)
-> Rec ((,) Text :. FromJson e) rs
-> Rec (Const (Text, FromJson e (Field rs))) rs
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 (Proxy rs
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 :: (:.) ((,) Text) (FromJson e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (Text
name, FromJson Parse e r
ia)) =
          (Text, FromJson e (Field rs))
-> Const (Text, FromJson e (Field rs)) r
forall k a (b :: k). a -> Const a b
Const (Text
name, Parse e (Field rs) -> FromJson e (Field rs)
forall e a. Parse e a -> FromJson e a
FromJson (Identity r -> Field rs
forall u (r :: u) (b :: [u]) (a :: u -> *).
(r ∈ b) =>
a r -> CoRec a b
CoVal (Identity r -> Field rs) -> (r -> Identity r) -> r -> Field rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Identity r
forall a. a -> Identity a
Identity (r -> Field rs) -> Parse e r -> Parse e (Field rs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse e r
ia))

-- |Make a @'JsonFormat' e (Field rs)@ given how to map the sum type to JSON along with a record with formatters for each value the field could have.
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 -> JsonFormatField e rs -> JsonFormat e (Field rs)
fieldJsonFormat SumStyle
sumStyle JsonFormatField e rs
fmts = SumStyle
-> (Field rs -> (Text, Value))
-> NonEmpty (Text, FromJson e (Field rs))
-> JsonFormat e (Field rs)
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 = JsonFormatField e rs -> Rec ((,) Text :. JsonFormat e) rs
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 = (Text, Value) -> Maybe (Text, Value) -> (Text, Value)
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> (Text, Value)
forall a. HasCallStack => [Char] -> a
error [Char]
"fieldToRec somehow produced all Nothings")
      (Maybe (Text, Value) -> (Text, Value))
-> (Field rs -> Maybe (Text, Value)) -> Field rs -> (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Value)] -> Maybe (Text, Value)
forall a. [a] -> Maybe a
listToMaybe ([(Text, Value)] -> Maybe (Text, Value))
-> (Field rs -> [(Text, Value)]) -> Field rs -> Maybe (Text, Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
catMaybes
      ([Maybe (Text, Value)] -> [(Text, Value)])
-> (Field rs -> [Maybe (Text, Value)])
-> Field rs
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)]
forall u (rs :: [u]) a. RecordToList rs => Rec (Const a) rs -> [a]
recordToList :: Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
      (Rec (Const (Maybe (Text, Value))) rs -> [Maybe (Text, Value)])
-> (Field rs -> Rec (Const (Maybe (Text, Value))) rs)
-> Field rs
-> [Maybe (Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
-> Rec Maybe rs -> Rec (Const (Maybe (Text, Value))) rs
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
      (Rec Maybe rs -> Rec (Const (Maybe (Text, Value))) rs)
-> (Field rs -> Rec Maybe rs)
-> Field rs
-> Rec (Const (Maybe (Text, Value))) rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field rs -> Rec Maybe rs
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 Rec ((,) Text :. JsonFormat e) rs
-> (forall x.
    (:.) ((,) Text) (JsonFormat e) x
    -> Lift (->) Maybe (Const (Maybe (Text, Value))) x)
-> Rec (Lift (->) Maybe (Const (Maybe (Text, Value)))) rs
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
_))) ->
      (Maybe x -> Const (Maybe (Text, Value)) x)
-> Lift (->) Maybe (Const (Maybe (Text, Value))) 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 ((Maybe x -> Const (Maybe (Text, Value)) x)
 -> Lift (->) Maybe (Const (Maybe (Text, Value))) x)
-> (Maybe x -> Const (Maybe (Text, Value)) x)
-> Lift (->) Maybe (Const (Maybe (Text, Value))) x
forall a b. (a -> b) -> a -> b
$ Maybe (Text, Value) -> Const (Maybe (Text, Value)) x
forall k a (b :: k). a -> Const a b
Const (Maybe (Text, Value) -> Const (Maybe (Text, Value)) x)
-> (Maybe x -> Maybe (Text, Value))
-> Maybe x
-> Const (Maybe (Text, Value)) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (x -> (Text, Value)) -> Maybe x -> Maybe (Text, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
name,) (Value -> (Text, Value)) -> (x -> Value) -> x -> (Text, Value)
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 = Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
-> NonEmpty (Text, FromJson e (Field rs))
forall u (rs :: [u]) a (r :: u).
RecordToList rs =>
Rec (Const a) (r : rs) -> NonEmpty a
recordToNonEmpty (Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
 -> NonEmpty (Text, FromJson e (Field rs)))
-> Rec (Const (Text, FromJson e (Field rs))) (r' : rs')
-> NonEmpty (Text, FromJson e (Field rs))
forall a b. (a -> b) -> a -> b
$ Proxy rs
-> (forall r.
    (r ∈ rs) =>
    (:.) ((,) Text) (JsonFormat e) r
    -> Const (Text, FromJson e (Field rs)) r)
-> Rec ((,) Text :. JsonFormat e) rs
-> Rec (Const (Text, FromJson e (Field rs))) rs
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 (Proxy rs
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 :: (:.) ((,) Text) (JsonFormat e) r
-> Const (Text, FromJson e (Field rs)) r
oneCase (Compose (Text
name, JsonFormat (JsonProfunctor r -> Value
_ Parse e r
ia))) =
          (Text, FromJson e (Field rs))
-> Const (Text, FromJson e (Field rs)) r
forall k a (b :: k). a -> Const a b
Const (Text
name, Parse e (Field rs) -> FromJson e (Field rs)
forall e a. Parse e a -> FromJson e a
FromJson (Identity r -> Field rs
forall u (r :: u) (b :: [u]) (a :: u -> *).
(r ∈ b) =>
a r -> CoRec a b
CoVal (Identity r -> Field rs) -> (r -> Identity r) -> r -> Field rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> Identity r
forall a. a -> Identity a
Identity (r -> Field rs) -> Parse e r -> Parse e (Field rs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parse e r
ia))