CoRecord.hs

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 = RNil

instance forall s a rs. (DefaultJsonFormat a, DefaultJsonFormatField rs) => DefaultJsonFormatField (s :-> a ': rs) where
  defaultJsonFormatField = wrappedJsonFormat defaultJsonFormat :& (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 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)

-- |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 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))

-- |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 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))