module Calamity.Internal.AesonThings
    ( WithSpecialCases(..)
    , IfNoneThen
    , ExtractFieldFrom
    , ExtractFieldInto
    , ExtractFields
    , ExtractArrayField
    , DefaultToEmptyArray
    , DefaultToZero
    , DefaultToFalse
    , 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.Text             ( Text )
import           Data.Text.Strict.Lens
import           Data.Typeable

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

textSymbolVal :: forall n. KnownSymbol n => Text
textSymbolVal :: Text
textSymbolVal = Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal @n Proxy n
forall k (t :: k). Proxy t
Proxy String -> Getting Text String Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text String Text
Iso' String Text
packed

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

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 _ o :: Object
o = do
    Value
v <- Object
o Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? KnownSymbol label => Text
forall (n :: Symbol). KnownSymbol n => Text
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 (KnownSymbol label => Text
forall (n :: Symbol). KnownSymbol n => Text
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 _ o :: 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 (KnownSymbol label => Text
forall (n :: Symbol). KnownSymbol n => Text
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 (KnownSymbol field => Text
forall (n :: Symbol). KnownSymbol n => Text
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 (KnownSymbol target => Text
forall (n :: Symbol). KnownSymbol n => Text
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 _ = 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 (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 _ o :: Object
o = do
    Maybe Array
a :: Maybe Array <- Object
o Object -> Text -> Parser (Maybe Array)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? KnownSymbol label => Text
forall (n :: Symbol). KnownSymbol n => Text
textSymbolVal @label
    case Maybe Array
a of
      Just a' :: 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 "extracting field" (Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: KnownSymbol field => Text
forall (n :: Symbol). KnownSymbol n => Text
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 (KnownSymbol label => Text
forall (n :: Symbol). KnownSymbol n => Text
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''
      Nothing -> Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
o

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 _ = Object -> Parser Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Parser Object)
-> (Object -> Object) -> Object -> Parser Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Object
forall a. a -> a
id

instance (RunSpecialCase xs, PerformAction action) => RunSpecialCase (action : xs) where
  runSpecialCases :: Proxy (action : xs) -> Object -> Parser Object
runSpecialCases _ o :: 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
$ \o :: 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 _ = Array -> Value
Array Array
forall a. Monoid a => a
mempty

data DefaultToZero

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

data DefaultToFalse

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

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 '_' (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
/= '_')
                             , 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 '_' (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
/= '_')
                                        , omitNothingFields :: Bool
omitNothingFields  = Bool
False }