{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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