{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------
-- | Type-directed aeson instance CustomJSONisation
--------------------
module Deriving.Aeson
  ( CustomJSON(..)
  , FieldLabelModifier
  , ConstrctorTagModifier
  , OmitNothingFields
  , TagSingleConstructors
  , NoAllNullaryToStringTag
  -- * Name modifiers
  , StripPrefix
  , CamelToKebab
  , CamelToSnake
  -- * Interface
  , AesonOptions(..)
  , StringModifier(..)
  -- * Reexports
  , FromJSON
  , ToJSON
  , Generic
  )where

import Data.Aeson
import Data.Coerce
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)
forall a b. Coercible a b => a -> b
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)) => 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 #-}

-- | 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 ConstrctorTagModifier t

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

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

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

-- | CamelCase to snake_case
data CamelToSnake

-- | CamelCase to kebab-case
data CamelToKebab

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

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

instance StringModifier CamelToKebab where
  getStringModifier :: String -> String
getStringModifier = Char -> String -> String
camelTo2 '-'

instance StringModifier CamelToSnake where
  getStringModifier :: String -> String
getStringModifier = Char -> String -> String
camelTo2 '_'

-- | 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 (OmitNothingFields ': xs) where
  aesonOptions :: Options
aesonOptions = (AesonOptions xs => Options
forall k (xs :: k). AesonOptions xs => Options
aesonOptions @xs) { omitNothingFields :: Bool
omitNothingFields = 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 (ConstrctorTagModifier 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 }