{-# 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 (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
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 { 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 { 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 { 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
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
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
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