module Calamity.Internal.AesonThings
    ( WithSpecialCases
    , WithSpecialCasesInner(..)
    , type IfNoneThen
    , type ExtractField
    , type ExtractFields
    , type InjectID
    , SpecialRule
    , DefaultToEmptyArray
    , DefaultToZero
    , DefaultToFalse
    , CalamityJSON(..)
    , 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 qualified GHC.TypeLits          as TL
import           GHC.TypeLits          ( KnownSymbol, Symbol, symbolVal )

textSymbolVal :: forall n. KnownSymbol n => Proxy n -> Text
textSymbolVal :: Proxy n -> 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 SpecialCaseList
  = SpecialCaseNil
  | forall label action inner. SpecialCaseElem label action inner

data SpecialRule (label :: Symbol) (action :: SpecialRuleAction)

data SpecialRuleAction
  = forall d. IfNoneThen d
  | forall field. ExtractField field
  | forall field. ExtractFields field
  | forall mn idn. InjectID idn mn

type IfNoneThen label d =
  SpecialRule label ('IfNoneThen d)

type ExtractField label field =
  SpecialRule label ('ExtractField field)

type ExtractFields label field =
  SpecialRule label ('ExtractFields field)

type InjectID label mn idn =
  SpecialRule label ('InjectID mn idn)

class PerformAction (action :: SpecialRuleAction) where
  runAction :: Proxy action -> Value -> Parser Value

instance Reifies d Value => PerformAction ('IfNoneThen d) where
  runAction :: Proxy ('IfNoneThen d) -> Value -> Parser Value
runAction _ Null = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ 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
  runAction _ x :: Value
x = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
x

instance (KnownSymbol field) => PerformAction ('ExtractField field) where
  runAction :: Proxy ('ExtractField field) -> Value -> Parser Value
runAction _ Null = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
  runAction _ o :: Value
o = String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (("extracting field " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy field -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @field Proxy field
forall k (t :: k). Proxy t
Proxy) Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Iso' Text String
unpacked)
    (Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Proxy field -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @field Proxy field
forall k (t :: k). Proxy t
Proxy) Value
o

instance (KnownSymbol field) => PerformAction ('ExtractFields field) where
  runAction :: Proxy ('ExtractFields field) -> Value -> Parser Value
runAction _ Null = Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
Null
  runAction _ o :: Value
o = String -> (Array -> Parser Value) -> Value -> Parser Value
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray (("extracting fields " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy field -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @field Proxy field
forall k (t :: k). Proxy t
Proxy) Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Iso' Text String
unpacked)
    ((Array -> Value
Array (Array -> Value) -> Parser Array -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser Array -> Parser Value)
-> (Array -> Parser Array) -> Array -> Parser Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
.: Proxy field -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @field Proxy field
forall k (t :: k). Proxy t
Proxy))) Value
o

instance (KnownSymbol idn, KnownSymbol mn) => PerformAction ('InjectID idn mn) where
  runAction :: Proxy ('InjectID idn mn) -> Value -> Parser Value
runAction _ = String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject
    (("injecting id from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy idn -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @idn Proxy idn
forall k (t :: k). Proxy t
Proxy Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " into " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Proxy mn -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @mn Proxy mn
forall k (t :: k). Proxy t
Proxy) Text -> Getting String Text String -> String
forall s a. s -> Getting a s a -> a
^. Getting String Text String
Iso' Text String
unpacked) ((Object -> Parser Value) -> Value -> Parser Value)
-> (Object -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$ \o :: Object
o -> do
      Value
id <- Object
o Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: "id"

      Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Value
Object Object
o
            Value -> (Value -> Value) -> Value
forall a b. a -> (a -> b) -> b
& Text -> Traversal' Value Value
forall t. AsValue t => Text -> Traversal' t Value
key (Proxy mn -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @mn Proxy mn
forall k (t :: k). Proxy t
Proxy) ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Identity Value) -> Value -> Identity Value
forall t. AsValue t => IndexedTraversal' Int t Value
values ((Value -> Identity Value) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Value -> Identity Value)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Object -> Identity Object) -> Value -> Identity Value
forall t. AsValue t => Prism' t Object
_Object ((Object -> Identity Object) -> Value -> Identity Value)
-> ((Maybe Value -> Identity (Maybe Value))
    -> Object -> Identity Object)
-> (Maybe Value -> Identity (Maybe Value))
-> Value
-> Identity Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index Object -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Proxy idn -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @idn Proxy idn
forall k (t :: k). Proxy t
Proxy) ((Maybe Value -> Identity (Maybe Value))
 -> Value -> Identity Value)
-> Value -> Value -> Value
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value
id)

type family FoldSpecialCases (rules :: [Type]) :: SpecialCaseList where
  FoldSpecialCases '[]                              = 'SpecialCaseNil
  FoldSpecialCases (SpecialRule label action ': xs) = 'SpecialCaseElem label action (FoldSpecialCases xs)
  FoldSpecialCases _ = TL.TypeError ('TL.Text "What did you do?")

newtype WithSpecialCasesInner (rules :: SpecialCaseList) a = WithSpecialCasesInner
  { WithSpecialCasesInner rules a -> a
unwrapWithSpecialCases :: a
  }

type family WithSpecialCases rules a :: Type where
  WithSpecialCases rules a = WithSpecialCasesInner (FoldSpecialCases rules) a

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

instance RunSpecialCase 'SpecialCaseNil where
  runSpecialCases :: Proxy 'SpecialCaseNil -> 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 inner, KnownSymbol label, PerformAction action)
  => RunSpecialCase ('SpecialCaseElem label action inner) where
  runSpecialCases :: Proxy ('SpecialCaseElem label action inner)
-> Object -> Parser Object
runSpecialCases _ o :: Object
o = do
    Object
o' <- Proxy inner -> Object -> Parser Object
forall k (a :: k).
RunSpecialCase a =>
Proxy a -> Object -> Parser Object
runSpecialCases (Proxy inner
forall k (t :: k). Proxy t
Proxy @inner) Object
o
    Value
v <- Object
o' Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Proxy label -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @label Proxy label
forall k (t :: k). Proxy t
Proxy Parser (Maybe Value) -> Value -> Parser Value
forall a. Parser (Maybe a) -> a -> Parser a
.!= Value
Null
    Value
v' <- Proxy action -> Value -> Parser Value
forall (action :: SpecialRuleAction).
PerformAction action =>
Proxy action -> Value -> Parser Value
runAction (Proxy action
forall k (t :: k). Proxy t
Proxy @action) Value
v
    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 -> Lens' Object (Maybe (IxValue Object))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at (Proxy label -> Text
forall (n :: Symbol). KnownSymbol n => Proxy n -> Text
textSymbolVal @label Proxy label
forall k (t :: k). Proxy t
Proxy) ((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 (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a))
  => FromJSON (WithSpecialCasesInner rules a) where
  parseJSON :: Value -> Parser (WithSpecialCasesInner rules a)
parseJSON = String
-> (Object -> Parser (WithSpecialCasesInner rules a))
-> Value
-> Parser (WithSpecialCasesInner 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 (WithSpecialCasesInner rules a))
 -> Value -> Parser (WithSpecialCasesInner rules a))
-> (Object -> Parser (WithSpecialCasesInner rules a))
-> Value
-> Parser (WithSpecialCasesInner 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 -> WithSpecialCasesInner rules a
forall (rules :: SpecialCaseList) a.
a -> WithSpecialCasesInner rules a
WithSpecialCasesInner (a -> WithSpecialCasesInner rules a)
-> Parser a -> Parser (WithSpecialCasesInner 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

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 }