module Composite.Aeson.Record
( ToJsonField(..), FromJsonField(..), JsonField(..)
, field, field', fromField, fromField', toField, toField'
, optionalField, optionalField', fromOptionalField, fromOptionalField', toOptionalField, toOptionalField'
, JsonFormatRecord, ToJsonFormatRecord, FromJsonFormatRecord, zipJsonFormatRecord, toJsonFormatRecord, fromJsonFormatRecord
, DefaultJsonFormatRecord, defaultJsonFormatRecord
, RecordToJsonObject, recordToJsonObject, recordToJson
, RecordFromJson, recordFromJson
, recordJsonFormat
) where
import Composite.Aeson.Base
( JsonProfunctor(JsonProfunctor)
, JsonFormat(JsonFormat)
, wrappedJsonFormat
)
import Composite.Aeson.Formats.Default (DefaultJsonFormat(defaultJsonFormat))
import Composite.Record ((:->))
import Control.Lens (Wrapped(type Unwrapped, _Wrapped'), from, review, view)
import Control.Monad (join)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.BetterErrors as ABE
import Data.Functor.Contravariant (Contravariant, contramap)
import Data.Functor.Identity (Identity(Identity))
import qualified Data.HashMap.Strict as HM
import Data.Proxy (Proxy(Proxy))
import Data.Text (Text, pack)
import Data.Vinyl (RApply, RMap, Rec((:&), RNil), rmap, rzipWith)
import GHC.TypeLits (KnownSymbol, symbolVal)
newtype ToJsonField a = ToJsonField { unToJsonField :: a -> Maybe Aeson.Value }
instance Contravariant ToJsonField where
contramap f (ToJsonField g) = ToJsonField (g . f)
newtype FromJsonField e a = FromJsonField { unFromJsonField :: Text -> ABE.Parse e a }
instance Functor (FromJsonField e) where
fmap f (FromJsonField g) = FromJsonField (fmap f . g)
data JsonField e a = JsonField (a -> Maybe Aeson.Value) (Text -> ABE.Parse e a)
field :: (Wrapped a', Unwrapped a' ~ a) => JsonFormat e a -> JsonField e a'
field fmt = field' (wrappedJsonFormat fmt)
field' :: JsonFormat e a -> JsonField e a
field' (JsonFormat (JsonProfunctor o i)) = JsonField (Just . o) (`ABE.key` i)
fromField :: Wrapped a => ABE.Parse e (Unwrapped a) -> FromJsonField e a
fromField = FromJsonField . flip ABE.key . fmap (review _Wrapped')
fromField' :: ABE.Parse e a -> FromJsonField e a
fromField' = FromJsonField . flip ABE.key
toField :: (Wrapped a', Unwrapped a' ~ a) => (a -> Aeson.Value) -> ToJsonField a'
toField o = ToJsonField $ Just . o . view _Wrapped'
toField' :: (a -> Aeson.Value) -> ToJsonField a
toField' = ToJsonField . fmap Just
optionalField :: (Wrapped a', Unwrapped a' ~ Maybe a) => JsonFormat e a -> JsonField e a'
optionalField (JsonFormat (JsonProfunctor o i)) =
JsonField
(fmap o . view _Wrapped')
(\ k -> view (from _Wrapped') . join <$> ABE.keyMay k (ABE.perhaps i))
optionalField' :: JsonFormat e a -> JsonField e (Maybe a)
optionalField' (JsonFormat (JsonProfunctor o i)) =
JsonField
(fmap o)
(\ k -> join <$> ABE.keyMay k (ABE.perhaps i))
fromOptionalField :: (Wrapped a', Unwrapped a' ~ Maybe a) => ABE.Parse e a -> FromJsonField e a'
fromOptionalField i = FromJsonField f
where
f k = view (from _Wrapped') . join <$> ABE.keyMay k (ABE.perhaps i)
fromOptionalField' :: ABE.Parse e a -> FromJsonField e (Maybe a)
fromOptionalField' i = FromJsonField f
where
f k = join <$> ABE.keyMay k (ABE.perhaps i)
toOptionalField :: (Wrapped a', Unwrapped a' ~ Maybe a) => (a -> Aeson.Value) -> ToJsonField a'
toOptionalField o = ToJsonField (fmap o . view _Wrapped')
toOptionalField' :: (a -> Aeson.Value) -> ToJsonField (Maybe a)
toOptionalField' o = ToJsonField (fmap o)
type JsonFormatRecord e rs = Rec (JsonField e) rs
zipJsonFormatRecord :: (RMap rs, RApply rs) => ToJsonFormatRecord rs -> FromJsonFormatRecord e rs -> JsonFormatRecord e rs
zipJsonFormatRecord = rzipWith (\ (ToJsonField o) (FromJsonField i) -> JsonField o i)
type FromJsonFormatRecord e rs = Rec (FromJsonField e) rs
fromJsonFormatRecord :: RMap rs => JsonFormatRecord e rs -> FromJsonFormatRecord e rs
fromJsonFormatRecord = rmap (\ (JsonField _ i) -> FromJsonField i)
type ToJsonFormatRecord rs = Rec ToJsonField rs
toJsonFormatRecord :: RMap rs => JsonFormatRecord e rs -> ToJsonFormatRecord rs
toJsonFormatRecord = rmap (\ (JsonField o _) -> ToJsonField o)
class RecordToJsonObject rs where
recordToJsonObject :: Rec ToJsonField rs -> Rec Identity rs -> Aeson.Object
instance RecordToJsonObject '[] where
recordToJsonObject _ = const mempty
instance forall s a rs. (KnownSymbol s, RecordToJsonObject rs) => RecordToJsonObject (s :-> a ': rs) where
recordToJsonObject (ToJsonField aToField :& fs) (Identity a :& as) =
maybe id (HM.insert (pack . symbolVal $ (Proxy :: Proxy s))) (aToField a) $
recordToJsonObject fs as
recordToJson :: RecordToJsonObject rs => Rec ToJsonField rs -> Rec Identity rs -> Aeson.Value
recordToJson = fmap Aeson.Object . recordToJsonObject
class RecordFromJson rs where
recordFromJson :: Rec (FromJsonField e) rs -> ABE.Parse e (Rec Identity rs)
instance RecordFromJson '[] where
recordFromJson _ = pure RNil
instance forall s a rs. (KnownSymbol s, RecordFromJson rs) => RecordFromJson (s :-> a ': rs) where
recordFromJson (FromJsonField aFromField :& fs) =
(:&)
<$> (Identity <$> aFromField (pack . symbolVal $ (Proxy :: Proxy s)))
<*> recordFromJson fs
recordJsonFormat :: (RMap rs, RecordToJsonObject rs, RecordFromJson rs) => JsonFormatRecord e rs -> JsonFormat e (Rec Identity rs)
recordJsonFormat formatRec =
JsonFormat $ JsonProfunctor
(recordToJson . toJsonFormatRecord $ formatRec)
(recordFromJson . fromJsonFormatRecord $ formatRec)
class DefaultJsonFormatRecord rs where
defaultJsonFormatRecord :: JsonFormatRecord e rs
instance (KnownSymbol s, DefaultJsonFormat a, DefaultJsonFormatRecord rs) => DefaultJsonFormatRecord (s :-> a ': rs) where
defaultJsonFormatRecord = field defaultJsonFormat :& defaultJsonFormatRecord
instance DefaultJsonFormatRecord '[] where
defaultJsonFormatRecord = RNil