{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Wrappers to control generic 'ToJSON' and 'FromJSON' derivation with deriving-via.
--   See the test for example definitions and their encoding.
module AesonVia
  ( AesonRecord (..)
  , AesonNewtype (..)
  , AesonTag (..)
  , HasJSONOptions (..)
  , HasTagPrefix (..)
  )
where

import Control.Newtype.Generics (Newtype, O, pack, unpack)
import Data.Aeson
  ( FromJSON (..)
  , GFromJSON
  , GToEncoding
  , GToJSON
  , Options (..)
  , ToJSON (..)
  , Zero
  , defaultOptions
  , genericParseJSON
  , genericToEncoding
  , genericToJSON
  )
import Data.Aeson.Casing (aesonPrefix, snakeCase)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics (Generic, Rep)
import Prelude

-- Options

recordOptions :: Options
recordOptions :: Options
recordOptions = ((String -> String) -> Options
aesonPrefix String -> String
snakeCase) {omitNothingFields :: Bool
omitNothingFields = Bool
True}

tagOptions :: Text -> Options
tagOptions :: Text -> Options
tagOptions Text
prefix =
  let prefixLen :: Int
prefixLen = Text -> Int
Text.length Text
prefix
  in  Options
defaultOptions
        { allNullaryToStringTag :: Bool
allNullaryToStringTag = Bool
True
        , constructorTagModifier :: String -> String
constructorTagModifier = String -> String
snakeCase forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
prefixLen
        }

newtypeOptions :: Options
newtypeOptions :: Options
newtypeOptions =
  Options
defaultOptions
    { unwrapUnaryRecords :: Bool
unwrapUnaryRecords = Bool
True
    }

-- Has classes

-- | Mostly an internal class directing constructor/field conversion.
class HasJSONOptions a where
  getJSONOptions :: Proxy a -> Options

-- | Used with 'AesonTag' to define a prefix to be removed from a 'Bounded' 'Enum'.
-- For example, `data Foo = FooBar | FooBaz` would use the prefix `Foo` to yield converted string
-- values `bar` and `baz`.
class HasTagPrefix a where
  getTagPrefix :: Proxy a -> Text

-- Wrappers

-- | Generic deriving ToJSON/FromJSON via this uses 'HasTagPrefix' to turn 'Bounded' 'Enum' datatypes into enumerated strings.
newtype AesonTag a = AesonTag {forall a. AesonTag a -> a
unAesonTag :: a}

instance HasTagPrefix a => HasJSONOptions (AesonTag a) where
  getJSONOptions :: Proxy (AesonTag a) -> Options
getJSONOptions Proxy (AesonTag a)
_ = Text -> Options
tagOptions (forall a. HasTagPrefix a => Proxy a -> Text
getTagPrefix (forall {k} (t :: k). Proxy t
Proxy :: Proxy a))

instance (HasJSONOptions (AesonTag a), Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (AesonTag a) where
  toJSON :: AesonTag a -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonTag a))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AesonTag a -> a
unAesonTag
  toEncoding :: AesonTag a -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonTag a))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AesonTag a -> a
unAesonTag

instance (HasJSONOptions (AesonTag a), Generic a, GFromJSON Zero (Rep a)) => FromJSON (AesonTag a) where
  parseJSON :: Value -> Parser (AesonTag a)
parseJSON = (forall a. a -> AesonTag a
AesonTag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonTag a)))

-- | Generic deriving ToJSON/FromJSON via this removes the common field name prefix in the encoding.
newtype AesonRecord a = AesonRecord {forall a. AesonRecord a -> a
unAesonRecord :: a}

instance HasJSONOptions (AesonRecord a) where
  getJSONOptions :: Proxy (AesonRecord a) -> Options
getJSONOptions Proxy (AesonRecord a)
_ = Options
recordOptions

instance (HasJSONOptions (AesonRecord a), Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (AesonRecord a) where
  toJSON :: AesonRecord a -> Value
toJSON = forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonRecord a))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AesonRecord a -> a
unAesonRecord
  toEncoding :: AesonRecord a -> Encoding
toEncoding = forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonRecord a))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AesonRecord a -> a
unAesonRecord

instance (HasJSONOptions (AesonRecord a), Generic a, GFromJSON Zero (Rep a)) => FromJSON (AesonRecord a) where
  parseJSON :: Value -> Parser (AesonRecord a)
parseJSON = (forall a. a -> AesonRecord a
AesonRecord forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON (forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonRecord a)))

-- | Generic deriving ToJSON/FromJSON via this yields an encoding equivalent to the wrapped type.
newtype AesonNewtype n o = AesonNewtype {forall n o. AesonNewtype n o -> n
unAesonNewtype :: n}

instance HasJSONOptions (AesonNewtype n o) where
  getJSONOptions :: Proxy (AesonNewtype n o) -> Options
getJSONOptions Proxy (AesonNewtype n o)
_ = Options
newtypeOptions

instance (Newtype n, o ~ O n, ToJSON o) => ToJSON (AesonNewtype n o) where
  toJSON :: AesonNewtype n o -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Newtype n => n -> O n
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n o. AesonNewtype n o -> n
unAesonNewtype
  toEncoding :: AesonNewtype n o -> Encoding
toEncoding = forall a. ToJSON a => a -> Encoding
toEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Newtype n => n -> O n
unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n o. AesonNewtype n o -> n
unAesonNewtype

instance (Newtype n, o ~ O n, FromJSON o) => FromJSON (AesonNewtype n o) where
  parseJSON :: Value -> Parser (AesonNewtype n o)
parseJSON = ((forall n o. n -> AesonNewtype n o
AesonNewtype forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Newtype n => O n -> n
pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON