{-# 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 #-}
module ByOtherNames.Aeson
(
JSONRubric (..),
JSONRecord (..),
JSONSum (..),
JSONEnum (..),
GeneralJSONRecord (..),
GeneralJSONSum (..),
GeneralJSONEnum (..),
Aliased (aliases),
aliasListBegin,
alias,
aliasListEnd,
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
data JSONRubric = JSON
instance Rubric JSON where
type AliasType JSON = Key
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)
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)
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)
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)]
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)
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"