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 :: 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 :: [*]) 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)

-- |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 :: 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 :: [*]) 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))