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.Kind (Type)
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 :: [Type]) 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 :: 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)

-- |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 :: [Type]) r' (rs' :: [Type]).
     ( 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)

-- |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 :: [Type]) r' (rs' :: [Type]) 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))

-- |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 :: [Type]) r' (rs' :: [Type]) 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))