{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}


-- | A 'Rubric' for JSON serialization using Aeson, along with some helper
-- newtypes and re-exports.
-- 
-- A more versatile version of the functionality provided by
-- "ByOtherNames.Aeson", in that it allows you to manually specify
-- parsers/decoders for each field. But, because of that, it's also more
-- verbose. And the error messages are worse.
-- 
-- If you plan to use both "ByOtherNames.Aeson" and "ByOtherNamesH.Aeson",
-- import this module qualified to avoid name collisions:
-- 
-- > import qualified ByOthernamesH.Aeson as H
--
-- Required extensions:
--
-- - DataKinds
-- - DeriveGeneric
-- - DerivingVia
-- - FlexibleInstances
-- - MultiParamTypeClasses
-- - OverloadedStrings
-- - TypeApplications
-- - ScopedTypeVariables
--
-- Example of use for a record type:
--
-- >>> :{
-- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char, dd :: String, ee :: Int}
--   deriving stock (Read, Show, Eq, Generic)
--   deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)
-- instance Aliased JSON Foo where
--   aliases =
--     aliasListBegin
--       . alias @"aa" "aax" (singleSlot fromToJSON)
--       . alias @"bb" "bbx" (singleSlot fromToJSON)
--       . alias @"cc" "ccx" (singleSlot fromToJSON)
--       . alias @"dd" "ddx" (singleSlot fromToJSON)
--       . alias @"ee" "eex" (singleSlot fromToJSON)
--       $ aliasListEnd
-- :}
--
module ByOtherNamesH.Aeson
  ( -- * JSON helpers
    JSONRubric (..),
    JSONRecord (..),
    FromToJSON (..),
    fromToJSON,
    -- ** Advanced JSON helpers
    GeneralJSONRecord (..),
    -- * Re-exports from ByOtherNames
    Aliased (aliases),
    aliasListBegin,
    alias,
    aliasListEnd,
    SlotList,
    singleSlot,
    slot,
    slotListEnd,
    -- * Re-exports from Data.Aeson
    FromJSON,
    ToJSON,

  )
where

import ByOtherNamesH
import Data.Aeson
import Data.Aeson.Key (fromText, toText)
import Data.Aeson.Types
import Data.Functor.Compose
import Data.Kind
import Data.Proxy
import Data.Void
import GHC.Generics
import GHC.TypeLits
import Data.Functor.Identity
import Data.Functor.Const

-- | Aliases for JSON serialization fall under this 'Rubric'.
-- The constructor 'JSON' is used as a type, with DataKinds.
data JSONRubric = JSON

-- | The aliases will be of type "Data.Aeson.Key".
instance Rubric JSON where
  type AliasType JSON = Key
  type WrapperType JSON = FromToJSON

-- | Packs together a JSON parser and a encoder for some type.
--
data FromToJSON v = FromToJSON { 
    forall v. FromToJSON v -> Value -> Parser v
parseJSON' :: Value -> Parser v, 
    forall v. FromToJSON v -> v -> Value
toJSON' :: v -> Value
  }

fromToJSON :: (ToJSON v, FromJSON v) => FromToJSON v 
fromToJSON :: forall v. (ToJSON v, FromJSON v) => FromToJSON v
fromToJSON = FromToJSON { parseJSON' :: Value -> Parser v
parseJSON' = forall a. FromJSON a => Value -> Parser a
parseJSON, toJSON' :: v -> Value
toJSON' = forall a. ToJSON a => a -> Value
toJSON}

type JSONRecord :: Symbol -> Type -> Type
newtype JSONRecord objectName r = JSONRecord r

deriving via (GeneralJSONRecord 'JSON objectName r) instance (KnownSymbol objectName, Aliased 'JSON r, GRecord (Rep r)) => FromJSON (JSONRecord objectName r) 
deriving via (GeneralJSONRecord 'JSON objectName r) instance (Aliased 'JSON r, GRecord (Rep r)) => ToJSON (JSONRecord objectName r)


-- | A more flexible version of 'JSONRecord' that lets you use any 'Rubric' whose
-- 'AliasType' is 'Data.Aeson.Key' and its 'WrapperType' is 'FromToJSON'.
-- 
-- It allows deriving 'FromJSON' and 'ToJSON' for a newtype, using the generic
-- 'Rep' and the aliases of the underlying type, but __without__ defining
-- 'FromJSON' and 'ToJSON' instances for the underlying type.
-- 
-- >>> :{
-- data Foo = Foo {aa :: Int, bb :: Bool, cc :: Char}
--   deriving (Read, Show, Eq, Generic)
-- data JSONLocal
-- -- We define a local rubric type to avoid colliding "Aliased" instances over Foo.
-- instance Rubric JSONLocal where
--   type AliasType JSONLocal = Key
--   type WrapperType JSONLocal = FromToJSON
-- instance Aliased JSONLocal Foo where
--   aliases =
--     aliasListBegin
--       $ alias @"aa" "aax" (singleSlot fromToJSON)
--       $ alias @"bb" "bbx" (singleSlot fromToJSON)
--       $ alias @"cc" "ccx" (singleSlot fromToJSON)
--       $ aliasListEnd
-- newtype FooN = FooN Foo
--     deriving (FromJSON, ToJSON) via (GeneralJSONRecord JSONLocal "obj" Foo)
-- :}
--
--
type GeneralJSONRecord :: rubric -> Symbol -> Type -> Type
newtype GeneralJSONRecord rubric objectName r = GeneralJSONRecord r

instance (KnownSymbol objectName, 
  Rubric rubric, 
  Aliased rubric r, 
  AliasType rubric ~ Key, 
  WrapperType rubric ~ FromToJSON, 
  GRecord (Rep r)) 
  => FromJSON (GeneralJSONRecord rubric objectName r) where
  parseJSON :: Value -> Parser (GeneralJSONRecord rubric objectName r)
parseJSON Value
v =
    let FieldParser Object -> Parser (Rep r Any)
parser =
          forall (rep :: * -> *) (g :: * -> *) a (h :: * -> *) z.
(GRecord rep, Applicative g) =>
Aliases rep a h -> (forall v. a -> h v -> g v) -> g (rep z)
gToRecord 
            (forall k (k :: k) r.
Aliased k r =>
Aliases (Rep r) (AliasType k) (WrapperType k)
aliases @_ @rubric @r)
            (\Key
fieldName (FromToJSON {Value -> Parser v
parseJSON' :: Value -> Parser v
parseJSON' :: forall v. FromToJSON v -> Value -> Parser v
parseJSON'}) -> forall a. (Object -> Parser a) -> FieldParser a
FieldParser (\Object
o -> forall a. (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField Value -> Parser v
parseJSON' Object
o Key
fieldName))
        objectName :: String
objectName = forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @objectName)
     in forall rubric (rubric :: rubric) (objectName :: Symbol) r.
r -> GeneralJSONRecord rubric objectName r
GeneralJSONRecord forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a x. Generic a => Rep a x -> a
to forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
objectName Object -> Parser (Rep r Any)
parser Value
v

newtype FieldParser a = FieldParser (Object -> Parser a)
  deriving (forall a b. a -> FieldParser b -> FieldParser a
forall a b. (a -> b) -> FieldParser a -> FieldParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FieldParser b -> FieldParser a
$c<$ :: forall a b. a -> FieldParser b -> FieldParser a
fmap :: forall a b. (a -> b) -> FieldParser a -> FieldParser b
$cfmap :: forall a b. (a -> b) -> FieldParser a -> FieldParser b
Functor, Functor FieldParser
forall a. a -> FieldParser a
forall a b. FieldParser a -> FieldParser b -> FieldParser a
forall a b. FieldParser a -> FieldParser b -> FieldParser b
forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FieldParser a -> FieldParser b -> FieldParser a
$c<* :: forall a b. FieldParser a -> FieldParser b -> FieldParser a
*> :: forall a b. FieldParser a -> FieldParser b -> FieldParser b
$c*> :: forall a b. FieldParser a -> FieldParser b -> FieldParser b
liftA2 :: forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
<*> :: forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
$c<*> :: forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
pure :: forall a. a -> FieldParser a
$cpure :: forall a. a -> FieldParser a
Applicative) via ((->) Object `Compose` Parser)

instance (Rubric rubric, 
  Aliased rubric r, 
  AliasType rubric ~ Key, 
  WrapperType rubric ~ FromToJSON, 
  GRecord (Rep r)) => ToJSON (GeneralJSONRecord rubric objectName r) where
  toJSON :: GeneralJSONRecord rubric objectName r -> Value
toJSON (GeneralJSONRecord r
o) = do
    let plainRecord :: Aliases (Rep r) String Identity
plainRecord = forall (rep :: * -> *) z.
GRecord rep =>
rep z -> Aliases rep String Identity
gFromRecord forall a b. (a -> b) -> a -> b
$ forall a x. Generic a => a -> Rep a x
from @r r
o
        deserializers :: Aliases (Rep r) (AliasType rubric) (WrapperType rubric)
deserializers = forall k (k :: k) r.
Aliased k r =>
Aliases (Rep r) (AliasType k) (WrapperType k)
aliases @_ @rubric @r
        combineAliases :: p -> p -> p
combineAliases p
_ p
k = p
k
        combineWrappers :: Identity v -> FromToJSON v -> Const Value b
combineWrappers (Identity v
v) (FromToJSON {v -> Value
toJSON' :: v -> Value
toJSON' :: forall v. FromToJSON v -> v -> Value
toJSON'}) = forall {k} a (b :: k). a -> Const a b
Const (v -> Value
toJSON' v
v)
        eachFieldRendered :: Aliases (Rep r) Key (Const Value)
eachFieldRendered = forall (rep :: * -> *) a1 a2 ar (h1 :: * -> *) (h2 :: * -> *)
       (hr :: * -> *).
GRecord rep =>
(a1 -> a2 -> ar)
-> (forall v. h1 v -> h2 v -> hr v)
-> Aliases rep a1 h1
-> Aliases rep a2 h2
-> Aliases rep ar hr
gBiliftA2RecordAliases forall {p} {p}. p -> p -> p
combineAliases forall {k} {v} {b :: k}.
Identity v -> FromToJSON v -> Const Value b
combineWrappers Aliases (Rep r) String Identity
plainRecord Aliases (Rep r) (AliasType rubric) (WrapperType rubric)
deserializers
        Const [Pair]
objects = forall (rep :: * -> *) (g :: * -> *) a (h :: * -> *) z.
(GRecord rep, Applicative g) =>
Aliases rep a h -> (forall v. a -> h v -> g v) -> g (rep z)
gToRecord  Aliases (Rep r) Key (Const Value)
eachFieldRendered (\Key
a (Const Value
v) -> forall {k} a (b :: k). a -> Const a b
Const [(Key
a,Value
v)])
    [Pair] -> Value
object [Pair]
objects


-- $setup
--
-- >>> :set -XBlockArguments
-- >>> :set -XTypeApplications
-- >>> :set -XDerivingStrategies
-- >>> :set -XDerivingVia
-- >>> :set -XDataKinds
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XDeriveGeneric
-- >>> :set -XOverloadedStrings
-- >>> :set -XTypeFamilies
-- >>> :set -XDerivingStrategies
-- >>> :set -XDerivingVia
-- >>> import ByOtherNamesH.Aeson
-- >>> import Data.Aeson
-- >>> import Data.Aeson.Types
-- >>> import GHC.Generics
-- >>> import GHC.TypeLits