{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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.
--
-- 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}
--   deriving stock (Read, Show, Eq, Generic)
--   deriving (FromJSON, ToJSON) via (JSONRecord "obj" Foo)
-- instance Aliased JSON Foo where
--   aliases =
--     aliasListBegin
--       $ alias @"aa" "aax"
--       $ alias @"bb" "bbx"
--       $ alias @"cc" "ccx"
--       $ aliasListEnd
-- :}
--
-- Example of use for a sum type:
--
-- >>> :{
-- data Summy
--   = Aa Int
--   | Bb Bool
--   | Cc
--   deriving stock (Read, Show, Eq, Generic)
--   deriving (FromJSON, ToJSON) via (JSONSum "sum" Summy)
-- instance Aliased JSON Summy where
--   aliases =
--     aliasListBegin
--       $ alias @"Aa" "Aax"
--       $ alias @"Bb" "Bbx"
--       $ alias @"Cc" "Ccx"
--       $ aliasListEnd
-- :}
--
-- Some observations:
--
-- - Fields in branches of sum types can't have selectors. When there is more than one field in a branch, they are parsed as a JSON Array.
--
-- - The "object with a single key consisting in the branch tag" style of serialization is used.
--
-- Sometimes we have enum-like sum types without any fields, and want to
-- serialize them to simple JSON strings, instead of to objects. In that case,
-- we can do the following:
--
-- >>> :{
-- data Enumy
--   = Xx
--   | Yy
--   | Zz
--   deriving stock (Read, Show, Eq, Generic)
--   deriving (FromJSON, ToJSON) via (JSONEnum Enumy)
-- instance Aliased JSON Enumy where
--   aliases =
--     aliasListBegin
--       $ alias @"Xx" "x"
--       $ alias @"Yy" "y"
--       $ alias @"Zz" "z"
--       $ aliasListEnd
-- :}
--
--

module ByOtherNames.Aeson
  ( -- * JSON helpers
    JSONRubric (..),
    JSONRecord (..),
    JSONSum (..),
    JSONEnum (..),
    -- ** Advanced JSON helpers
    GeneralJSONRecord (..),
    GeneralJSONSum (..),
    GeneralJSONEnum (..),
    -- * Re-exports from ByOtherNames
    Aliased (aliases),
    aliasListBegin,
    alias,
    aliasListEnd,

    -- * Re-exports from Data.Aeson
    FromJSON,
    ToJSON,
  )
where

import ByOtherNames
import Data.Aeson
import Data.Aeson.Key (fromText, toText)
import Data.Aeson.Types
import Data.Foldable
import Data.Functor.Compose
import Data.Kind
import Data.Proxy
import Data.Void
import GHC.Generics
import GHC.TypeLits
import ByOtherNames.Constraint

-- | 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

-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for record types,
-- using DerivingVia.
--
-- The @objectName@ type parameter of kind 'Symbol' is used in parse error messages.
type JSONRecord :: Symbol -> Type -> Type
newtype JSONRecord objectName r = JSONRecord r

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

-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for sum types,
-- using DerivingVia.
--
-- The 'Symbol' type parameter is used in parse error messages.
type JSONSum :: Symbol -> Type -> Type
newtype JSONSum objectName r = JSONSum r

deriving via (GeneralJSONSum 'JSON objectName r) instance (KnownSymbol objectName, Aliased 'JSON r, GSum FromJSON (Rep r)) => FromJSON (JSONSum objectName r) 
deriving via (GeneralJSONSum 'JSON objectName r) instance (Aliased 'JSON r, GSum ToJSON (Rep r)) => ToJSON (JSONSum objectName r)

-- | Helper newtype for deriving 'FromJSON' and 'ToJSON' for enum-like sum types,
-- using DerivingVia.
--
-- Each constructor is serialized to a JSON string.
type JSONEnum :: Type -> Type
newtype JSONEnum r = JSONEnum r

deriving via (GeneralJSONEnum 'JSON r) instance (Aliased 'JSON r, GSum Impossible (Rep r)) => FromJSON (JSONEnum r) 
deriving via (GeneralJSONEnum 'JSON r) instance (Aliased 'JSON r, GSum Impossible (Rep r)) => ToJSON (JSONEnum r)

newtype EnumBranchParser v = EnumBranchParser {forall v. EnumBranchParser v -> Value -> Parser v
runEnumBranchParser :: Value -> Parser v}
  deriving stock (forall a b. a -> EnumBranchParser b -> EnumBranchParser a
forall a b. (a -> b) -> EnumBranchParser a -> EnumBranchParser 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 -> EnumBranchParser b -> EnumBranchParser a
$c<$ :: forall a b. a -> EnumBranchParser b -> EnumBranchParser a
fmap :: forall a b. (a -> b) -> EnumBranchParser a -> EnumBranchParser b
$cfmap :: forall a b. (a -> b) -> EnumBranchParser a -> EnumBranchParser b
Functor)

newtype BranchParser v = BranchParser {forall v. BranchParser v -> Object -> Parser v
runBranchParser :: Object -> Parser v}
  deriving stock (forall a b. a -> BranchParser b -> BranchParser a
forall a b. (a -> b) -> BranchParser a -> BranchParser 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 -> BranchParser b -> BranchParser a
$c<$ :: forall a b. a -> BranchParser b -> BranchParser a
fmap :: forall a b. (a -> b) -> BranchParser a -> BranchParser b
$cfmap :: forall a b. (a -> b) -> BranchParser a -> BranchParser b
Functor)

newtype ProductInBranchParser1 v = ProductInBranchParser1 {forall v. ProductInBranchParser1 v -> Value -> Parser v
runProductInBranchParser1 :: Value -> Parser v}
  deriving stock (forall a b.
a -> ProductInBranchParser1 b -> ProductInBranchParser1 a
forall a b.
(a -> b) -> ProductInBranchParser1 a -> ProductInBranchParser1 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 -> ProductInBranchParser1 b -> ProductInBranchParser1 a
$c<$ :: forall a b.
a -> ProductInBranchParser1 b -> ProductInBranchParser1 a
fmap :: forall a b.
(a -> b) -> ProductInBranchParser1 a -> ProductInBranchParser1 b
$cfmap :: forall a b.
(a -> b) -> ProductInBranchParser1 a -> ProductInBranchParser1 b
Functor)
  deriving (Functor ProductInBranchParser1
forall a. a -> ProductInBranchParser1 a
forall a b.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 a
forall a b.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 b
forall a b.
ProductInBranchParser1 (a -> b)
-> ProductInBranchParser1 a -> ProductInBranchParser1 b
forall a b c.
(a -> b -> c)
-> ProductInBranchParser1 a
-> ProductInBranchParser1 b
-> ProductInBranchParser1 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.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 a
$c<* :: forall a b.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 a
*> :: forall a b.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 b
$c*> :: forall a b.
ProductInBranchParser1 a
-> ProductInBranchParser1 b -> ProductInBranchParser1 b
liftA2 :: forall a b c.
(a -> b -> c)
-> ProductInBranchParser1 a
-> ProductInBranchParser1 b
-> ProductInBranchParser1 c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ProductInBranchParser1 a
-> ProductInBranchParser1 b
-> ProductInBranchParser1 c
<*> :: forall a b.
ProductInBranchParser1 (a -> b)
-> ProductInBranchParser1 a -> ProductInBranchParser1 b
$c<*> :: forall a b.
ProductInBranchParser1 (a -> b)
-> ProductInBranchParser1 a -> ProductInBranchParser1 b
pure :: forall a. a -> ProductInBranchParser1 a
$cpure :: forall a. a -> ProductInBranchParser1 a
Applicative) via (Compose ((->) Value) Parser)

newtype ProductInBranchParser v = ProductInBranchParser {forall v. ProductInBranchParser v -> [Value] -> Parser (v, [Value])
runProductInBranchParser :: [Value] -> Parser (v, [Value])}
  deriving stock (forall a b. a -> ProductInBranchParser b -> ProductInBranchParser a
forall a b.
(a -> b) -> ProductInBranchParser a -> ProductInBranchParser 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 -> ProductInBranchParser b -> ProductInBranchParser a
$c<$ :: forall a b. a -> ProductInBranchParser b -> ProductInBranchParser a
fmap :: forall a b.
(a -> b) -> ProductInBranchParser a -> ProductInBranchParser b
$cfmap :: forall a b.
(a -> b) -> ProductInBranchParser a -> ProductInBranchParser b
Functor)

instance Applicative ProductInBranchParser where
  pure :: forall a. a -> ProductInBranchParser a
pure a
v = forall v.
([Value] -> Parser (v, [Value])) -> ProductInBranchParser v
ProductInBranchParser \[Value]
vs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
v, [Value]
vs)
  ProductInBranchParser [Value] -> Parser (a -> b, [Value])
left <*> :: forall a b.
ProductInBranchParser (a -> b)
-> ProductInBranchParser a -> ProductInBranchParser b
<*> ProductInBranchParser [Value] -> Parser (a, [Value])
right =
    forall v.
([Value] -> Parser (v, [Value])) -> ProductInBranchParser v
ProductInBranchParser \[Value]
vs0 -> do
      (a -> b
f, [Value]
vs1) <- [Value] -> Parser (a -> b, [Value])
left [Value]
vs0
      (a
x, [Value]
vs2) <- [Value] -> Parser (a, [Value])
right [Value]
vs1
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> b
f a
x, [Value]
vs2)


--
--

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)

-- | A more flexible version of 'JSONSum' that lets you use any 'Rubric' whose
-- 'AliasType' is 'Data.Aeson.Key'.
-- 
-- 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 Summy
--   = Aa Int
--   | Bb Bool
--   | Cc
--   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
-- instance Aliased JSONLocal Summy where
--   aliases =
--     aliasListBegin
--       $ alias @"Aa" "Aax"
--       $ alias @"Bb" "Bbx"
--       $ alias @"Cc" "Cc1"
--       $ aliasListEnd
-- newtype SummyN = SummyN Summy
--     deriving (FromJSON, ToJSON) via (GeneralJSONSum JSONLocal "obj" Summy)
-- :}
--
--
type GeneralJSONSum :: rubric -> Symbol -> Type -> Type
newtype GeneralJSONSum rubric objectName r = GeneralJSONSum r

instance (
  KnownSymbol objectName, 
  Rubric rubric, 
  Aliased rubric r, 
  AliasType rubric ~ Key, 
  GSum FromJSON (Rep r)) => FromJSON (GeneralJSONSum rubric objectName r) where
  parseJSON :: Value -> Parser (GeneralJSONSum rubric objectName r)
parseJSON Value
v =
    let parsers :: Aliases (Rep r) (BranchParser (Rep r Any))
parsers =
          forall (c :: * -> Constraint) (rep :: * -> *) (n :: * -> *)
       (m2 :: * -> *) a (m1 :: * -> *) z.
(GSum c rep, Functor n, Applicative m2) =>
Aliases rep a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases rep (n (rep z))
gToSum @FromJSON
            (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r)
            ( \Key
a -> \case
                ZeroSlots b
v -> forall v. (Object -> Parser v) -> BranchParser v
BranchParser \Object
o -> do
                  Value
Null :: Value <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
a
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v
                SingleSlot ProductInBranchParser1 b
p -> forall v. (Object -> Parser v) -> BranchParser v
BranchParser \Object
o -> do
                  Value
value <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
a
                  forall v. ProductInBranchParser1 v -> Value -> Parser v
runProductInBranchParser1 ProductInBranchParser1 b
p Value
value
                ManySlots ProductInBranchParser b
p -> forall v. (Object -> Parser v) -> BranchParser v
BranchParser \Object
o -> do
                  [Value]
valueList <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
a
                  (b
prod, [Value]
_) <- forall v. ProductInBranchParser v -> [Value] -> Parser (v, [Value])
runProductInBranchParser ProductInBranchParser b
p [Value]
valueList
                  forall (f :: * -> *) a. Applicative f => a -> f a
pure b
prod
            )
            (forall v. (Value -> Parser v) -> ProductInBranchParser1 v
ProductInBranchParser1 forall a. FromJSON a => Value -> Parser a
parseJSON)
            ( forall v.
([Value] -> Parser (v, [Value])) -> ProductInBranchParser v
ProductInBranchParser \case
                [] -> forall a. String -> Parser a
parseFail String
"not enough field values for branch"
                Value
v : [Value]
vs -> do
                  v
r <- forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
                  pure (v
r, [Value]
vs)
            )
        parserForObject :: Object -> Parser (Rep r Any)
parserForObject Object
o = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a b. (a -> b) -> a -> b
$ Object
o) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. BranchParser v -> Object -> Parser v
runBranchParser) Aliases (Rep r) (BranchParser (Rep r Any))
parsers
     in forall rubric (rubric :: rubric) (objectName :: Symbol) r.
r -> GeneralJSONSum rubric objectName r
GeneralJSONSum 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 (forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
Proxy @objectName)) Object -> Parser (Rep r Any)
parserForObject Value
v


instance (
  Rubric rubric, 
  Aliased rubric r, 
  AliasType rubric ~ Key, 
  GSum ToJSON (Rep r)) => ToJSON (GeneralJSONSum rubric objectName r) where
  toJSON :: GeneralJSONSum rubric objectName r -> Value
toJSON (GeneralJSONSum r
o) =
    let (Key
key, [Value]
slots) = forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GSum c rep =>
Aliases rep a -> (forall v. c v => v -> o) -> rep z -> (a, [o])
gFromSum @ToJSON @(Rep r) @Key @Value @Value (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r) forall a. ToJSON a => a -> Value
toJSON (forall a x. Generic a => a -> Rep a x
from @r r
o)
     in case [Value]
slots of
          [] -> [Pair] -> Value
object [(Key
key, Value
Null)]
          [Value
x] -> [Pair] -> Value
object [(Key
key, forall a. ToJSON a => a -> Value
toJSON Value
x)]
          [Value]
xs -> [Pair] -> Value
object [(Key
key, forall a. ToJSON a => a -> Value
toJSON [Value]
xs)]


-- | A more flexible version of 'JSONRecord' that lets you use any 'Rubric' whose
-- 'AliasType' is 'Data.Aeson.Key'.
-- 
-- 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
-- instance Aliased JSONLocal Foo where
--   aliases =
--     aliasListBegin
--       $ alias @"aa" "aax"
--       $ alias @"bb" "bbx"
--       $ alias @"cc" "ccx"
--       $ 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, 
  GRecord FromJSON (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 (c :: * -> Constraint) (rep :: * -> *) (m :: * -> *) a z.
(GRecord c rep, Applicative m) =>
Aliases rep a -> (forall v. c v => a -> m v) -> m (rep z)
gToRecord @FromJSON
            (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r)
            (\Key
fieldName -> forall a. (Object -> Parser a) -> FieldParser a
FieldParser (\Object
o -> forall a. (Value -> Parser a) -> Object -> Key -> Parser a
explicitParseField forall a. FromJSON a => Value -> Parser a
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

instance (Rubric rubric, 
  Aliased rubric r, 
  AliasType rubric ~ Key, 
  GRecord ToJSON (Rep r)) => ToJSON (GeneralJSONRecord rubric objectName r) where
  toJSON :: GeneralJSONRecord rubric objectName r -> Value
toJSON (GeneralJSONRecord r
o) =
    [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
Data.Foldable.toList forall a b. (a -> b) -> a -> b
$ forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GRecord c rep =>
Aliases rep a
-> (forall v. c v => a -> v -> o) -> rep z -> Aliases rep o
gFromRecord @ToJSON @(Rep r) @Key (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r) (\Key
a v
v -> (Key
a, forall a. ToJSON a => a -> Value
toJSON v
v)) (forall a x. Generic a => a -> Rep a x
from @r r
o)

-- | A more flexible version of 'JSONEnum' that lets you use any 'Rubric' whose
-- 'AliasType' is 'Data.Aeson.Key'.
-- 
-- 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 Enumy
--   = Xx
--   | Yy
--   | Zz
--   deriving (Read, Show, Eq, Generic)
-- data JSONLocal
-- -- We define a local rubric type to avoid colliding "Aliased" instances over Enumy.
-- instance Rubric JSONLocal where
--   type AliasType JSONLocal = Key
-- instance Aliased JSONLocal Enumy where
--   aliases =
--     aliasListBegin
--       $ alias @"Xx" "x"
--       $ alias @"Yy" "y"
--       $ alias @"Zz" "z"
--       $ aliasListEnd
-- -- We use the underlying Enumy type in DerivingVia.
-- newtype EnumyN = EnumyN Enumy
--     deriving (FromJSON, ToJSON) via (GeneralJSONEnum JSONLocal Enumy)
-- :}
--
--
type GeneralJSONEnum :: rubric -> Type -> Type
newtype GeneralJSONEnum rubric r = GeneralJSONEnum r

--
--
instance (
  Rubric rubric, 
  AliasType rubric ~ Key, 
  Aliased rubric r, 
  GSum Impossible (Rep r)) => FromJSON (GeneralJSONEnum rubric r) where
  parseJSON :: Value -> Parser (GeneralJSONEnum rubric r)
parseJSON Value
v =
    let parsers :: Aliases (Rep r) (EnumBranchParser (Rep r Any))
parsers =
          forall (c :: * -> Constraint) (rep :: * -> *) (n :: * -> *)
       (m2 :: * -> *) a (m1 :: * -> *) z.
(GSum c rep, Functor n, Applicative m2) =>
Aliases rep a
-> (forall b. a -> Slots m1 m2 b -> n b)
-> (forall v. c v => m1 v)
-> (forall v. c v => m2 v)
-> Aliases rep (n (rep z))
gToSum @Impossible
            (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r)
            ( \Key
a -> \case
                ZeroSlots b
x -> forall v. (Value -> Parser v) -> EnumBranchParser v
EnumBranchParser \case
                  String Text
a' | Key
a forall a. Eq a => a -> a -> Bool
== Text -> Key
fromText Text
a' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure b
x
                  Value
_ -> forall a. Monoid a => a
mempty
                SingleSlot Proxy b
_ -> forall v. (Value -> Parser v) -> EnumBranchParser v
EnumBranchParser forall a. Monoid a => a
mempty
                ManySlots Proxy b
_ -> forall v. (Value -> Parser v) -> EnumBranchParser v
EnumBranchParser forall a. Monoid a => a
mempty
            )
            forall {k} (t :: k). Proxy t
Proxy
            forall {k} (t :: k). Proxy t
Proxy
        parserForValue :: Value -> Parser (Rep r Any)
parserForValue Value
v = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall a b. (a -> b) -> a -> b
$ Value
v) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. EnumBranchParser v -> Value -> Parser v
runEnumBranchParser) Aliases (Rep r) (EnumBranchParser (Rep r Any))
parsers
     in forall rubric (rubric :: rubric) r. r -> GeneralJSONEnum rubric r
GeneralJSONEnum 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
<$> Value -> Parser (Rep r Any)
parserForValue Value
v

instance (
  Rubric rubric, 
  AliasType rubric ~ Key, 
  Aliased rubric r, 
  GSum Impossible (Rep r)) 
  => ToJSON (GeneralJSONEnum rubric r) where
  toJSON :: GeneralJSONEnum rubric r -> Value
toJSON (GeneralJSONEnum r
o) =
    let (Key
key, [Value]
slots) = forall (c :: * -> Constraint) (rep :: * -> *) a o z.
GSum c rep =>
Aliases rep a -> (forall v. c v => v -> o) -> rep z -> (a, [o])
gFromSum @Impossible @(Rep r) @Key @Value @Value (forall k (k :: k) r. Aliased k r => Aliases (Rep r) (AliasType k)
aliases @_ @rubric @r) forall a. Void -> a
absurd (forall a x. Generic a => a -> Rep a x
from @r r
o)
     in case [Value]
slots of
          [] -> Text -> Value
String (Key -> Text
toText Key
key)
          [Value
_] -> forall a. HasCallStack => String -> a
error String
"never happens"
          [Value]
_ -> forall a. HasCallStack => String -> a
error String
"never happens"

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