{-# 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 = True}

tagOptions :: Text -> Options
tagOptions :: Text -> Options
tagOptions Text
prefix =
  let prefixLen :: Int
prefixLen = Text -> Int
Text.length Text
prefix
  in  Options
defaultOptions
        { allNullaryToStringTag = True
        , constructorTagModifier = snakeCase . drop prefixLen
        }

newtypeOptions :: Options
newtypeOptions :: Options
newtypeOptions =
  Options
defaultOptions
    { unwrapUnaryRecords = 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 (Proxy a -> Text
forall a. HasTagPrefix a => Proxy a -> Text
getTagPrefix (Proxy a
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 = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Proxy (AesonTag a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonTag a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonTag a))) (a -> Value) -> (AesonTag a -> a) -> AesonTag a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonTag a -> a
forall a. AesonTag a -> a
unAesonTag
  toEncoding :: AesonTag a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (Proxy (AesonTag a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonTag a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonTag a))) (a -> Encoding) -> (AesonTag a -> a) -> AesonTag a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonTag a -> a
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 = (a -> AesonTag a
forall a. a -> AesonTag a
AesonTag (a -> AesonTag a) -> Parser a -> Parser (AesonTag a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser a -> Parser (AesonTag a))
-> (Value -> Parser a) -> Value -> Parser (AesonTag 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 (Proxy (AesonTag a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonTag a)
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 = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON (Proxy (AesonRecord a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonRecord a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonRecord a))) (a -> Value) -> (AesonRecord a -> a) -> AesonRecord a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonRecord a -> a
forall a. AesonRecord a -> a
unAesonRecord
  toEncoding :: AesonRecord a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding (Proxy (AesonRecord a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonRecord a)
forall {k} (t :: k). Proxy t
Proxy :: Proxy (AesonRecord a))) (a -> Encoding)
-> (AesonRecord a -> a) -> AesonRecord a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonRecord a -> a
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 = (a -> AesonRecord a
forall a. a -> AesonRecord a
AesonRecord (a -> AesonRecord a) -> Parser a -> Parser (AesonRecord a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser a -> Parser (AesonRecord a))
-> (Value -> Parser a) -> Value -> Parser (AesonRecord 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 (Proxy (AesonRecord a) -> Options
forall a. HasJSONOptions a => Proxy a -> Options
getJSONOptions (Proxy (AesonRecord a)
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 = o -> Value
forall a. ToJSON a => a -> Value
toJSON (o -> Value)
-> (AesonNewtype n o -> o) -> AesonNewtype n o -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack (n -> o) -> (AesonNewtype n o -> n) -> AesonNewtype n o -> o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonNewtype n o -> n
forall n o. AesonNewtype n o -> n
unAesonNewtype
  toEncoding :: AesonNewtype n o -> Encoding
toEncoding = o -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (o -> Encoding)
-> (AesonNewtype n o -> o) -> AesonNewtype n o -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> o
n -> O n
forall n. Newtype n => n -> O n
unpack (n -> o) -> (AesonNewtype n o -> n) -> AesonNewtype n o -> o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AesonNewtype n o -> n
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 = ((n -> AesonNewtype n o
forall n o. n -> AesonNewtype n o
AesonNewtype (n -> AesonNewtype n o) -> (o -> n) -> o -> AesonNewtype n o
forall b c a. (b -> c) -> (a -> b) -> a -> c
. o -> n
O n -> n
forall n. Newtype n => O n -> n
pack) (o -> AesonNewtype n o) -> Parser o -> Parser (AesonNewtype n o)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser o -> Parser (AesonNewtype n o))
-> (Value -> Parser o) -> Value -> Parser (AesonNewtype n o)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser o
forall a. FromJSON a => Value -> Parser a
parseJSON