module Calamity.Internal.AesonThings (
  WithSpecialCases (..),
  IfNoneThen,
  ExtractFieldFrom,
  ExtractFieldInto,
  ExtractFields,
  ExtractArrayField,
  DefaultToEmptyArray,
  DefaultToZero,
  DefaultToFalse,
  DefaultToTrue,
  CalamityJSON (..),
  CalamityJSONKeepNothing (..),
  jsonOptions,
  jsonOptionsKeepNothing,
) where

import Control.Lens

import Data.Aeson
import Data.Aeson.Lens
import Data.Aeson.Types (Parser)
import Data.Kind
import Data.Reflection (Reifies (..))
import Data.String (IsString (fromString))
import Data.Typeable

import Control.Monad ((>=>))
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)

textSymbolVal :: forall n s. (KnownSymbol n, IsString s) => s
textSymbolVal :: s
textSymbolVal = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> String -> s
forall a b. (a -> b) -> a -> b
$ Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @n Proxy n
forall k (t :: k). Proxy t
Proxy

data IfNoneThen label def
data ExtractFieldInto label field target
type ExtractFieldFrom label field = ExtractFieldInto label field label
data ExtractFields label fields
data ExtractArrayField label field
data MapFieldWith field ty

class PerformAction action where
  runAction :: Proxy action -> Object -> Parser Object

instance (Reifies d Value, KnownSymbol label) => PerformAction (IfNoneThen label d) where
  runAction :: Proxy (IfNoneThen label d) -> Object -> Parser Object
runAction Proxy (IfNoneThen label d)
_ Object
o = do
    Value
v <- Object
o Object -> Key -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? forall s. (KnownSymbol label, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @label Parser (Maybe Value) -> Value -> Parser Value
forall a. Parser (Maybe a) -> a -> Parser a
.!= Proxy d -> Value
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect @d Proxy d
forall k (t :: k). Proxy t
Proxy
    Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Parser Object) -> Object -> Parser Object
forall a b. (a -> b) -> a -> b
$ Object
o Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (forall s. (KnownSymbol label, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @label) ((Maybe Value -> Identity (Maybe Value))
 -> Object -> Identity Object)
-> Value -> Object -> Object
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
v

instance (KnownSymbol label, KnownSymbol field, KnownSymbol target) => PerformAction (ExtractFieldInto label field target) where
  runAction :: Proxy (ExtractFieldInto label field target)
-> Object -> Parser Object
runAction Proxy (ExtractFieldInto label field target)
_ Object
o =
    let Maybe Value
v :: Maybe Value = Object
o Object -> Getting (First Value) Object Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index Object -> Traversal' Object (IxValue Object)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (forall s. (KnownSymbol label, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @label) Getting (First Value) Object Value
-> ((Value -> Const (First Value) Value)
    -> Value -> Const (First Value) Value)
-> Getting (First Value) Object Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Object -> Const (First Value) Object)
-> Value -> Const (First Value) Value
forall t. AsValue t => Prism' t Object
_Object ((Object -> Const (First Value) Object)
 -> Value -> Const (First Value) Value)
-> Getting (First Value) Object Value
-> (Value -> Const (First Value) Value)
-> Value
-> Const (First Value) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Object -> Traversal' Object (IxValue Object)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (forall s. (KnownSymbol field, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @field)
     in Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Parser Object) -> Object -> Parser Object
forall a b. (a -> b) -> a -> b
$ Object
o Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (forall s. (KnownSymbol target, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @target) ((Maybe Value -> Identity (Maybe Value))
 -> Object -> Identity Object)
-> Maybe Value -> Object -> Object
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Value
v

instance PerformAction (ExtractFields label '[]) where
  runAction :: Proxy (ExtractFields label '[]) -> Object -> Parser Object
runAction Proxy (ExtractFields label '[])
_ = Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance
  ( KnownSymbol field
  , PerformAction (ExtractFieldInto label field field)
  , PerformAction (ExtractFields label fields)
  ) =>
  PerformAction (ExtractFields label (field : fields))
  where
  runAction :: Proxy (ExtractFields label (field : fields))
-> Object -> Parser Object
runAction Proxy (ExtractFields label (field : fields))
_ = Proxy (ExtractFieldInto label field field)
-> Object -> Parser Object
forall k (action :: k).
PerformAction action =>
Proxy action -> Object -> Parser Object
runAction (Proxy (ExtractFieldInto label field field)
forall k (t :: k). Proxy t
Proxy @(ExtractFieldInto label field field)) (Object -> Parser Object)
-> (Object -> Parser Object) -> Object -> Parser Object
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Proxy (ExtractFields label fields) -> Object -> Parser Object
forall k (action :: k).
PerformAction action =>
Proxy action -> Object -> Parser Object
runAction (Proxy (ExtractFields label fields)
forall k (t :: k). Proxy t
Proxy @(ExtractFields label fields))

instance (KnownSymbol label, KnownSymbol field) => PerformAction (ExtractArrayField label field) where
  runAction :: Proxy (ExtractArrayField label field) -> Object -> Parser Object
runAction Proxy (ExtractArrayField label field)
_ Object
o = do
    Maybe Array
a :: Maybe Array <- Object
o Object -> Key -> Parser (Maybe Array)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? forall s. (KnownSymbol label, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @label
    case Maybe Array
a of
      Just Array
a' -> do
        Value
a'' <- Array -> Value
Array (Array -> Value) -> Parser Array -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser Value) -> Array -> Parser Array
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"extracting field" (Object -> Key -> Parser Value
forall a. FromJSON a => Object -> Key -> Parser a
.: forall s. (KnownSymbol field, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @field)) Array
a'
        Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Parser Object) -> Object -> Parser Object
forall a b. (a -> b) -> a -> b
$ Object
o Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (forall s. (KnownSymbol label, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @label) ((Maybe Value -> Identity (Maybe Value))
 -> Object -> Identity Object)
-> Value -> Object -> Object
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
a''
      Maybe Array
Nothing -> Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
o

instance (KnownSymbol field, Reifies ty (Value -> Value)) => PerformAction (MapFieldWith field ty) where
  runAction :: Proxy (MapFieldWith field ty) -> Object -> Parser Object
runAction Proxy (MapFieldWith field ty)
_ Object
o = Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object
o Object -> (Object -> Object) -> Object
forall a b. a -> (a -> b) -> b
& Index Object -> Traversal' Object (IxValue Object)
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (forall s. (KnownSymbol field, IsString s) => s
forall (n :: Symbol) s. (KnownSymbol n, IsString s) => s
textSymbolVal @field) ((Value -> Identity Value) -> Object -> Identity Object)
-> (Value -> Value) -> Object -> Object
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Proxy ty -> Value -> Value
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect @ty Proxy ty
forall k (t :: k). Proxy t
Proxy)

newtype WithSpecialCases (rules :: [Type]) a = WithSpecialCases a

class RunSpecialCase a where
  runSpecialCases :: Proxy a -> Object -> Parser Object

instance RunSpecialCase '[] where
  runSpecialCases :: Proxy '[] -> Object -> Parser Object
runSpecialCases Proxy '[]
_ = Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where
  runSpecialCases :: Proxy (action : xs) -> Object -> Parser Object
runSpecialCases Proxy (action : xs)
_ Object
o = do
    Object
o' <- Proxy xs -> Object -> Parser Object
forall k (a :: k).
RunSpecialCase a =>
Proxy a -> Object -> Parser Object
runSpecialCases (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs) Object
o
    Proxy action -> Object -> Parser Object
forall k (action :: k).
PerformAction action =>
Proxy action -> Object -> Parser Object
runAction (Proxy action
forall k (t :: k). Proxy t
Proxy @action) Object
o'

instance
  (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a)) =>
  FromJSON (WithSpecialCases rules a)
  where
  parseJSON :: Value -> Parser (WithSpecialCases rules a)
parseJSON = String
-> (Object -> Parser (WithSpecialCases rules a))
-> Value
-> Parser (WithSpecialCases rules a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy a -> TypeRep) -> Proxy a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> String) -> Proxy a -> String
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a) ((Object -> Parser (WithSpecialCases rules a))
 -> Value -> Parser (WithSpecialCases rules a))
-> (Object -> Parser (WithSpecialCases rules a))
-> Value
-> Parser (WithSpecialCases rules a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Object
o' <- Proxy rules -> Object -> Parser Object
forall k (a :: k).
RunSpecialCase a =>
Proxy a -> Object -> Parser Object
runSpecialCases (Proxy rules
forall k (t :: k). Proxy t
Proxy @rules) Object
o
    a -> WithSpecialCases rules a
forall (rules :: [*]) a. a -> WithSpecialCases rules a
WithSpecialCases (a -> WithSpecialCases rules a)
-> Parser a -> Parser (WithSpecialCases rules a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
jsonOptions (Object -> Value
Object Object
o')

data DefaultToEmptyArray

instance Reifies DefaultToEmptyArray Value where
  reflect :: proxy DefaultToEmptyArray -> Value
reflect proxy DefaultToEmptyArray
_ = Array -> Value
Array Array
forall a. Monoid a => a
mempty

data DefaultToZero

instance Reifies DefaultToZero Value where
  reflect :: proxy DefaultToZero -> Value
reflect proxy DefaultToZero
_ = Scientific -> Value
Number Scientific
0

data DefaultToFalse

instance Reifies DefaultToFalse Value where
  reflect :: proxy DefaultToFalse -> Value
reflect proxy DefaultToFalse
_ = Bool -> Value
Bool Bool
False

data DefaultToTrue

instance Reifies DefaultToTrue Value where
  reflect :: proxy DefaultToTrue -> Value
reflect proxy DefaultToTrue
_ = Bool -> Value
Bool Bool
True

newtype CalamityJSON a = CalamityJSON
  { CalamityJSON a -> a
unCalamityJSON :: a
  }

instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where
  toJSON :: CalamityJSON a -> Value
toJSON = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
jsonOptions (a -> Value) -> (CalamityJSON a -> a) -> CalamityJSON a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalamityJSON a -> a
forall a. CalamityJSON a -> a
unCalamityJSON

  toEncoding :: CalamityJSON a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
jsonOptions (a -> Encoding)
-> (CalamityJSON a -> a) -> CalamityJSON a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalamityJSON a -> a
forall a. CalamityJSON a -> a
unCalamityJSON

instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where
  parseJSON :: Value -> Parser (CalamityJSON a)
parseJSON = (a -> CalamityJSON a) -> Parser a -> Parser (CalamityJSON a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> CalamityJSON a
forall a. a -> CalamityJSON a
CalamityJSON (Parser a -> Parser (CalamityJSON a))
-> (Value -> Parser a) -> Value -> Parser (CalamityJSON 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 Options
jsonOptions

-- | version that keeps Nothing fields
newtype CalamityJSONKeepNothing a = CalamityJSONKeepNothing
  { CalamityJSONKeepNothing a -> a
unCalamityJSONKeepNothing :: a
  }

instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSONKeepNothing a) where
  toJSON :: CalamityJSONKeepNothing a -> Value
toJSON = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
jsonOptionsKeepNothing (a -> Value)
-> (CalamityJSONKeepNothing a -> a)
-> CalamityJSONKeepNothing a
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalamityJSONKeepNothing a -> a
forall a. CalamityJSONKeepNothing a -> a
unCalamityJSONKeepNothing

  toEncoding :: CalamityJSONKeepNothing a -> Encoding
toEncoding = Options -> a -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
jsonOptionsKeepNothing (a -> Encoding)
-> (CalamityJSONKeepNothing a -> a)
-> CalamityJSONKeepNothing a
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CalamityJSONKeepNothing a -> a
forall a. CalamityJSONKeepNothing a -> a
unCalamityJSONKeepNothing

instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSONKeepNothing a) where
  parseJSON :: Value -> Parser (CalamityJSONKeepNothing a)
parseJSON = (a -> CalamityJSONKeepNothing a)
-> Parser a -> Parser (CalamityJSONKeepNothing a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> CalamityJSONKeepNothing a
forall a. a -> CalamityJSONKeepNothing a
CalamityJSONKeepNothing (Parser a -> Parser (CalamityJSONKeepNothing a))
-> (Value -> Parser a)
-> Value
-> Parser (CalamityJSONKeepNothing 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 Options
jsonOptionsKeepNothing

jsonOptions :: Options
jsonOptions :: Options
jsonOptions =
  Options
defaultOptions
    { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue
    , fieldLabelModifier :: String -> String
fieldLabelModifier = Char -> String -> String
camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
    , omitNothingFields :: Bool
omitNothingFields = Bool
True
    }

jsonOptionsKeepNothing :: Options
jsonOptionsKeepNothing :: Options
jsonOptionsKeepNothing =
  Options
defaultOptions
    { sumEncoding :: SumEncoding
sumEncoding = SumEncoding
UntaggedValue
    , fieldLabelModifier :: String -> String
fieldLabelModifier = Char -> String -> String
camelTo2 Char
'_' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
    , omitNothingFields :: Bool
omitNothingFields = Bool
False
    }