-- | This is the internal generic-override-aeson API and should be considered
-- unstable and subject to change. In general, you should prefer to use the
-- public, stable API provided by "Data.Override.Aeson".
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Override.Aeson.Options.Internal where

import Data.Aeson
import Data.Coerce (coerce)
import Data.Proxy (Proxy(..))
import GHC.Generics (Generic, Rep)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)

import qualified Data.Aeson as Aeson

-- | Use with @DerivingVia@ to override Aeson @Options@ with a type-level
-- list of 'AesonOption'.
newtype WithAesonOptions (a :: *) (options :: [AesonOption]) = WithAesonOptions a

instance
  ( ApplyAesonOptions options
  , Generic a
  , Aeson.GToJSON Aeson.Zero (Rep a)
  , Aeson.GToEncoding Aeson.Zero (Rep a)
  ) => ToJSON (WithAesonOptions a options)
  where
  toJSON :: WithAesonOptions a options -> Value
toJSON = (a -> Value) -> WithAesonOptions a options -> Value
coerce ((a -> Value) -> WithAesonOptions a options -> Value)
-> (a -> Value) -> WithAesonOptions a options -> Value
forall a b. (a -> b) -> a -> b
$ (Generic a, GToJSON Zero (Rep a)) => Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON @a (Options -> a -> Value) -> Options -> a -> Value
forall a b. (a -> b) -> a -> b
$ Proxy options -> Options -> Options
forall (options :: [AesonOption]).
ApplyAesonOptions options =>
Proxy options -> Options -> Options
applyAesonOptions (Proxy options
forall k (t :: k). Proxy t
Proxy @options) Options
defaultOptions
  toEncoding :: WithAesonOptions a options -> Encoding
toEncoding = (a -> Encoding) -> WithAesonOptions a options -> Encoding
coerce ((a -> Encoding) -> WithAesonOptions a options -> Encoding)
-> (a -> Encoding) -> WithAesonOptions a options -> Encoding
forall a b. (a -> b) -> a -> b
$ (Generic a, GToEncoding Zero (Rep a)) => Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding @a (Options -> a -> Encoding) -> Options -> a -> Encoding
forall a b. (a -> b) -> a -> b
$ Proxy options -> Options -> Options
forall (options :: [AesonOption]).
ApplyAesonOptions options =>
Proxy options -> Options -> Options
applyAesonOptions (Proxy options
forall k (t :: k). Proxy t
Proxy @options) Options
defaultOptions

instance
  ( ApplyAesonOptions options
  , Generic a
  , Aeson.GFromJSON Aeson.Zero (Rep a)
  ) => FromJSON (WithAesonOptions a options)
  where
  parseJSON :: Value -> Parser (WithAesonOptions a options)
parseJSON = (Value -> Parser a) -> Value -> Parser (WithAesonOptions a options)
coerce ((Value -> Parser a)
 -> Value -> Parser (WithAesonOptions a options))
-> (Value -> Parser a)
-> Value
-> Parser (WithAesonOptions a options)
forall a b. (a -> b) -> a -> b
$ (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON @a (Options -> Value -> Parser a) -> Options -> Value -> Parser a
forall a b. (a -> b) -> a -> b
$ Proxy options -> Options -> Options
forall (options :: [AesonOption]).
ApplyAesonOptions options =>
Proxy options -> Options -> Options
applyAesonOptions (Proxy options
forall k (t :: k). Proxy t
Proxy @options) Options
defaultOptions

-- | Provides a type-level subset of fields from 'Options'
data AesonOption =
    AllNullaryToStringTag Bool -- ^ Equivalient to @'allNullaryToStringTag' = b@
  | OmitNothingFields -- ^ Equivalient to @'omitNothingFields' = True@
  | SumEncodingTaggedObject Symbol Symbol -- ^ Equivalient to @'sumEncoding' = 'TaggedObject' k v@
  | SumEncodingUntaggedValue -- ^ Equivalient to @'sumEncoding' = 'UntaggedValue'@
  | SumEncodingObjectWithSingleField -- ^ Equivalient to @'sumEncoding' = 'ObjectWithSingleField'@
  | SumEncodingTwoElemArray -- ^ Equivalient to @'sumEncoding' = 'TwoElemArray'@
  | UnwrapUnaryRecords -- ^ Equivalient to @'unwrapUnaryRecords' = True@
  | TagSingleConstructors -- ^ Equivalient to @'tagSingleConstructors' = True@

-- | Updates 'Options' given a type-level list of 'AesonOption'.
class ApplyAesonOptions (options :: [AesonOption]) where
  applyAesonOptions :: Proxy options -> Options -> Options

instance ApplyAesonOptions '[] where
  applyAesonOptions :: Proxy '[] -> Options -> Options
applyAesonOptions Proxy '[]
_ = Options -> Options
forall a. a -> a
id

instance
  ( ApplyAesonOption option
  , ApplyAesonOptions options
  ) => ApplyAesonOptions (option ': options)
  where
  applyAesonOptions :: Proxy (option : options) -> Options -> Options
applyAesonOptions Proxy (option : options)
_ =
    Proxy option -> Options -> Options
forall (option :: AesonOption).
ApplyAesonOption option =>
Proxy option -> Options -> Options
applyAesonOption (Proxy option
forall k (t :: k). Proxy t
Proxy @option) (Options -> Options) -> (Options -> Options) -> Options -> Options
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy options -> Options -> Options
forall (options :: [AesonOption]).
ApplyAesonOptions options =>
Proxy options -> Options -> Options
applyAesonOptions (Proxy options
forall k (t :: k). Proxy t
Proxy @options))

-- | Updates 'Options' given a single type-level 'AesonOption'.
class ApplyAesonOption (option :: AesonOption) where
  applyAesonOption :: Proxy option -> Options -> Options

instance ApplyAesonOption ('AllNullaryToStringTag 'True) where
  applyAesonOption :: Proxy ('AllNullaryToStringTag 'True) -> Options -> Options
applyAesonOption Proxy ('AllNullaryToStringTag 'True)
_ Options
o = Options
o { allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True }

instance ApplyAesonOption ('AllNullaryToStringTag 'False) where
  applyAesonOption :: Proxy ('AllNullaryToStringTag 'False) -> Options -> Options
applyAesonOption Proxy ('AllNullaryToStringTag 'False)
_ Options
o = Options
o { allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
False }

instance ApplyAesonOption 'OmitNothingFields where
  applyAesonOption :: Proxy 'OmitNothingFields -> Options -> Options
applyAesonOption Proxy 'OmitNothingFields
_ Options
o = Options
o { omitNothingFields :: Bool
omitNothingFields = Bool
True }

instance (KnownSymbol k, KnownSymbol v) => ApplyAesonOption ('SumEncodingTaggedObject k v) where
  applyAesonOption :: Proxy ('SumEncodingTaggedObject k v) -> Options -> Options
applyAesonOption Proxy ('SumEncodingTaggedObject k v)
_ Options
o = Options
o { sumEncoding :: SumEncoding
sumEncoding = String -> String -> SumEncoding
TaggedObject (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy @k)) (Proxy v -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy v
forall k (t :: k). Proxy t
Proxy @v)) }

instance ApplyAesonOption 'SumEncodingUntaggedValue where
  applyAesonOption :: Proxy 'SumEncodingUntaggedValue -> Options -> Options
applyAesonOption Proxy 'SumEncodingUntaggedValue
_ Options
o = Options
o { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue }

instance ApplyAesonOption 'SumEncodingObjectWithSingleField where
  applyAesonOption :: Proxy 'SumEncodingObjectWithSingleField -> Options -> Options
applyAesonOption Proxy 'SumEncodingObjectWithSingleField
_ Options
o = Options
o { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
ObjectWithSingleField }

instance ApplyAesonOption 'SumEncodingTwoElemArray where
  applyAesonOption :: Proxy 'SumEncodingTwoElemArray -> Options -> Options
applyAesonOption Proxy 'SumEncodingTwoElemArray
_ Options
o = Options
o { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
TwoElemArray }

instance ApplyAesonOption 'UnwrapUnaryRecords where
  applyAesonOption :: Proxy 'UnwrapUnaryRecords -> Options -> Options
applyAesonOption Proxy 'UnwrapUnaryRecords
_ Options
o = Options
o { unwrapUnaryRecords :: Bool
unwrapUnaryRecords = Bool
True }

instance ApplyAesonOption 'TagSingleConstructors where
  applyAesonOption :: Proxy 'TagSingleConstructors -> Options -> Options
applyAesonOption Proxy 'TagSingleConstructors
_ Options
o = Options
o { tagSingleConstructors :: Bool
tagSingleConstructors = Bool
True }