{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------
-- | Type-directed aeson instance CustomJSONisation
--------------------
module Deriving.Aeson
  ( CustomJSON(..)
  , FieldLabelModifier
  , ConstructorTagModifier
  , OmitNothingFields
  , RejectUnknownFields
  , TagSingleConstructors
  , NoAllNullaryToStringTag
  , UnwrapUnaryRecords
  -- * Sum encoding
  , SumTaggedObject
  , SumUntaggedValue
  , SumObjectWithSingleField
  , SumTwoElemArray
  -- * Name modifiers
  , StripPrefix
  , CamelTo
  , CamelToKebab
  , CamelToSnake
  , Rename
  -- * Interface
  , AesonOptions(..)
  , StringModifier(..)
  -- * Reexports
  , FromJSON
  , ToJSON
  , Generic
  )where

import Data.Aeson
import Data.Aeson.Types
import Data.Coerce
import Data.Kind
import Data.List (stripPrefix)
import Data.Maybe (fromMaybe)
import Data.Proxy
import GHC.Generics
import GHC.TypeLits

-- | A newtype wrapper which gives FromJSON/ToJSON instances with modified options.
newtype CustomJSON t a = CustomJSON { CustomJSON t a -> a
unCustomJSON :: a }

instance (AesonOptions t, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CustomJSON t a) where
  parseJSON :: Value -> Parser (CustomJSON t a)
parseJSON = (Parser a -> Parser (CustomJSON t a)
coerce (Parser a -> Parser (CustomJSON t a))
-> (Parser a -> Parser (CustomJSON t a))
-> Parser a
-> Parser (CustomJSON t a)
forall a. a -> a -> a
`asTypeOf` (a -> CustomJSON t a) -> Parser a -> Parser (CustomJSON t a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> CustomJSON t a
forall k (t :: k) a. a -> CustomJSON t a
CustomJSON) (Parser a -> Parser (CustomJSON t a))
-> (Value -> Parser a) -> Value -> Parser (CustomJSON t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (AesonOptions t => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @t)
  {-# INLINE parseJSON #-}

instance (AesonOptions t, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CustomJSON t a) where
  toJSON :: CustomJSON t a -> Value
toJSON = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (AesonOptions t => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @t) (a -> Value) -> (CustomJSON t a -> a) -> CustomJSON t a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CustomJSON t a -> a
forall k (t :: k) a. CustomJSON t a -> a
unCustomJSON
  {-# INLINE toJSON #-}
  toEncoding :: CustomJSON t a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (AesonOptions t => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @t) (a -> Encoding)
-> (CustomJSON t a -> a) -> CustomJSON t a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CustomJSON t a -> a
forall k (t :: k) a. CustomJSON t a -> a
unCustomJSON
  {-# INLINE toEncoding #-}

-- | Function applied to field labels. Handy for removing common record prefixes for example.
data FieldLabelModifier t

-- | Function applied to constructor tags which could be handy for lower-casing them for example.
data ConstructorTagModifier t

-- | Record fields with a Nothing value will be omitted from the resulting object.
data OmitNothingFields

-- | JSON Documents mapped to records with unmatched keys will be rejected
data RejectUnknownFields

-- | Encode types with a single constructor as sums, so that allNullaryToStringTag and sumEncoding apply.
data TagSingleConstructors

-- | the encoding will always follow the 'sumEncoding'.
data NoAllNullaryToStringTag

-- | Unpack single-field records
data UnwrapUnaryRecords

-- | Strip prefix @t@. If it doesn't have the prefix, keep it as-is.
data StripPrefix t

-- | Generic CamelTo constructor taking in a separator char
data CamelTo (separator :: Symbol)

-- | CamelCase to snake_case
type CamelToSnake = CamelTo "_"

-- | CamelCase to kebab-case
type CamelToKebab = CamelTo "-"

-- | Rename fields called @from@ to @to@.
data Rename (from :: Symbol) (to :: Symbol)

-- | Reify a function which modifies names
class StringModifier t where
  getStringModifier :: String -> String

instance KnownSymbol k => StringModifier (StripPrefix k) where
  getStringModifier :: String -> String
getStringModifier = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (String -> Maybe String -> String)
-> (String -> Maybe String) -> String -> String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (Proxy k -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy k
forall k (t :: k). Proxy t
Proxy @k))

instance StringModifier '[] where
  getStringModifier :: String -> String
getStringModifier = String -> String
forall a. a -> a
id

-- | Left-to-right (@'foldr' ('flip' ('.')) 'id'@) composition
instance (StringModifier a, StringModifier as) => StringModifier (a ': as) where
  getStringModifier :: String -> String
getStringModifier = StringModifier as => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @as (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier a => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @a

-- | Left-to-right (@'flip' '.'@) composition
instance (StringModifier a, StringModifier b) => StringModifier (a, b) where
  getStringModifier :: String -> String
getStringModifier = StringModifier b => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @b (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier a => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @a

-- | Left-to-right (@'flip' '.'@) composition
instance (StringModifier a, StringModifier b, StringModifier c) => StringModifier (a, b, c) where
  getStringModifier :: String -> String
getStringModifier = StringModifier c => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @c (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier b => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @b (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier a => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @a

-- | Left-to-right (@'flip' '.'@) composition
instance (StringModifier a, StringModifier b, StringModifier c, StringModifier d) => StringModifier (a, b, c, d) where
  getStringModifier :: String -> String
getStringModifier = StringModifier d => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @d (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier c => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @c (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier b => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @b (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StringModifier a => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @a

instance (KnownSymbol separator, NonEmptyString separator) => StringModifier (CamelTo separator) where
  getStringModifier :: String -> String
getStringModifier = Char -> String -> String
camelTo2 Char
char
    where
      char :: Char
char = case Proxy separator -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy separator
forall k (t :: k). Proxy t
Proxy @separator) of
        Char
c : String
_ -> Char
c
        String
_ -> String -> Char
forall a. HasCallStack => String -> a
error String
"Impossible"

instance (KnownSymbol from, KnownSymbol to) => StringModifier (Rename from to) where
  getStringModifier :: String -> String
getStringModifier String
s = if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy from -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy from
forall k (t :: k). Proxy t
Proxy @from) then Proxy to -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy to
forall k (t :: k). Proxy t
Proxy @to) else String
s

type family NonEmptyString (xs :: Symbol) :: Constraint where
  NonEmptyString "" = TypeError ('Text "Empty string separator provided for camelTo separator")
  NonEmptyString _  = ()

-- | @{ "tag": t, "content": c}@
data SumTaggedObject t c

-- | @CONTENT@
data SumUntaggedValue

-- | @{ TAG: CONTENT }@
data SumObjectWithSingleField

-- | @[TAG, CONTENT]@
data SumTwoElemArray

-- | Reify 'Options' from a type-level list
class AesonOptions xs where
  aesonOptions :: Options

instance AesonOptions '[] where
  aesonOptions :: Options
aesonOptions = Options
defaultOptions

instance AesonOptions xs => AesonOptions (UnwrapUnaryRecords ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { unwrapUnaryRecords :: Bool
unwrapUnaryRecords = Bool
True }

instance AesonOptions xs => AesonOptions (OmitNothingFields ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { omitNothingFields :: Bool
omitNothingFields = Bool
True }

instance AesonOptions xs => AesonOptions (RejectUnknownFields ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { rejectUnknownFields :: Bool
rejectUnknownFields = Bool
True }

instance (StringModifier f, AesonOptions xs) => AesonOptions (FieldLabelModifier f ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { fieldLabelModifier :: String -> String
fieldLabelModifier = StringModifier f => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @f }

instance (StringModifier f, AesonOptions xs) => AesonOptions (ConstructorTagModifier f ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { constructorTagModifier :: String -> String
constructorTagModifier = StringModifier f => String -> String
forall k (t :: k). StringModifier t => String -> String
getStringModifier @f }

instance AesonOptions xs => AesonOptions (TagSingleConstructors ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { tagSingleConstructors :: Bool
tagSingleConstructors = Bool
True }

instance AesonOptions xs => AesonOptions (NoAllNullaryToStringTag ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
False }

instance (KnownSymbol t, KnownSymbol c, AesonOptions xs) => AesonOptions (SumTaggedObject t c ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { sumEncoding :: SumEncoding
sumEncoding = String -> String -> SumEncoding
TaggedObject (Proxy t -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy t
forall k (t :: k). Proxy t
Proxy @t)) (Proxy c -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy c
forall k (t :: k). Proxy t
Proxy @c)) }

instance (AesonOptions xs) => AesonOptions (SumUntaggedValue ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue }

instance (AesonOptions xs) => AesonOptions (SumObjectWithSingleField ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
ObjectWithSingleField }

instance (AesonOptions xs) => AesonOptions (SumTwoElemArray ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
TwoElemArray }