{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.Dependent.Sum where
import Data.Aeson
( FromJSON (..),
FromJSONKey (..),
FromJSONKeyFunction (..),
Key,
ToJSON (..),
ToJSONKey (..),
ToJSONKeyFunction (..),
Value (..),
object,
withArray,
withObject,
withText,
(.:),
(.=),
)
import qualified Data.Aeson.Encoding as E
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import Data.Aeson.Types (Parser)
import Data.Coerce (coerce)
import Data.Constraint.Extras (Has', has')
import Data.Dependent.Sum (DSum (..))
import Data.Foldable (asum)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Data.Some (Some (..))
import Data.String (fromString)
import Data.Vector ((!))
import qualified Data.Vector as V
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
newtype
TaggedObject
(typeName :: Symbol)
(tagKey :: Symbol)
(contentsKey :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TaggedObject (DSum tag f)
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
KnownSymbol contentsKey,
FromJSON (Some tag),
Has' FromJSON tag f
) =>
FromJSON (TaggedObject typeName tagKey contentsKey tag f)
where
parseJSON :: Value -> Parser (TaggedObject typeName tagKey contentsKey tag f)
parseJSON = String
-> (Object
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Value
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName) ((Object
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Value
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> (Object
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Value
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
Object
o Object -> Key -> Parser (Some tag)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Parser (Some tag)
-> (Some tag
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Some tag a
tag) ->
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) =>
Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Parser (TaggedObject typeName tagKey contentsKey tag f))
-> (FromJSON (f a) =>
Parser (TaggedObject typeName tagKey contentsKey tag f))
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall a b. (a -> b) -> a -> b
$
DSum tag f -> TaggedObject typeName tagKey contentsKey tag f
forall k (typeName :: Symbol) (tagKey :: Symbol)
(contentsKey :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TaggedObject typeName tagKey contentsKey tag f
TaggedObject (DSum tag f -> TaggedObject typeName tagKey contentsKey tag f)
-> (f a -> DSum tag f)
-> f a
-> TaggedObject typeName tagKey contentsKey tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>)
(f a -> TaggedObject typeName tagKey contentsKey tag f)
-> Parser (f a)
-> Parser (TaggedObject typeName tagKey contentsKey tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (f a)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @contentsKey))
instance
( KnownSymbol tagKey,
KnownSymbol contentsKey,
ToJSON (Some tag),
Has' ToJSON tag f
) =>
ToJSON (TaggedObject typeName tagKey contentsKey tag f)
where
toJSON :: TaggedObject typeName tagKey contentsKey tag f -> Value
toJSON (TaggedObject (tag a
tag :=> f a
fa)) =
[Pair] -> Value
object
[ String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Key -> Some tag -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag,
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Pair) -> Pair) -> (ToJSON (f a) => Pair) -> Pair
forall a b. (a -> b) -> a -> b
$ String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @contentsKey)) Key -> f a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa
]
toEncoding :: TaggedObject typeName tagKey contentsKey tag f -> Encoding
toEncoding (TaggedObject (tag a
tag :=> f a
fa)) =
Series -> Encoding
E.pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
[Series] -> Series
forall a. Monoid a => [a] -> a
mconcat
[ String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Key -> Some tag -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag,
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Series) -> Series)
-> (ToJSON (f a) => Series) -> Series
forall a b. (a -> b) -> a -> b
$
String -> Key
forall a. IsString a => String -> a
fromString (Proxy contentsKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @contentsKey)) Key -> f a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa
]
newtype
TaggedObjectInline
(typeName :: Symbol)
(tagKey :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TaggedObjectInline (DSum tag f)
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
Has' FromJSON tag f,
FromJSON (Some tag)
) =>
FromJSON (TaggedObjectInline typeName tagKey tag f)
where
parseJSON :: Value -> Parser (TaggedObjectInline typeName tagKey tag f)
parseJSON Value
v = ((Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Value -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Value
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Value
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName)) Value
v ((Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f))
-> (Object -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
Object
o Object -> Key -> Parser (Some tag)
forall a. FromJSON a => Object -> Key -> Parser a
.: String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)) Parser (Some tag)
-> (Some tag -> Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Some tag a
tag) ->
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) =>
Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f))
-> (FromJSON (f a) =>
Parser (TaggedObjectInline typeName tagKey tag f))
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall a b. (a -> b) -> a -> b
$
DSum tag f -> TaggedObjectInline typeName tagKey tag f
forall k (typeName :: Symbol) (tagKey :: Symbol) (tag :: k -> *)
(f :: k -> *).
DSum tag f -> TaggedObjectInline typeName tagKey tag f
TaggedObjectInline (DSum tag f -> TaggedObjectInline typeName tagKey tag f)
-> (f a -> DSum tag f)
-> f a
-> TaggedObjectInline typeName tagKey tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> TaggedObjectInline typeName tagKey tag f)
-> Parser (f a)
-> Parser (TaggedObjectInline typeName tagKey tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
instance
( KnownSymbol typeName,
KnownSymbol tagKey,
Has' ToJSON tag f,
ToJSON (Some tag)
) =>
ToJSON (TaggedObjectInline typeName tagKey tag f)
where
toJSON :: TaggedObjectInline typeName tagKey tag f -> Value
toJSON (TaggedObjectInline (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
forall a b. (a -> b) -> a -> b
$
case f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa of
Object Object
o ->
Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert
(String -> Key
forall a. IsString a => String -> a
fromString (Proxy tagKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @tagKey)))
(Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)
Object
o
Value
_ ->
String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$
Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"#toJSON: did not serialise to Object"
newtype
ObjectWithSingleField
(typeName :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= ObjectWithSingleField (DSum tag f)
instance
( KnownSymbol typeName,
Has' FromJSON tag f,
FromJSONKey (Some tag)
) =>
FromJSON (ObjectWithSingleField typeName tag f)
where
parseJSON :: Value -> Parser (ObjectWithSingleField typeName tag f)
parseJSON Value
j =
case Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
tagParser of
Left Value -> Parser (Some tag)
valueParser ->
[Parser (ObjectWithSingleField typeName tag f)]
-> Parser (ObjectWithSingleField typeName tag f)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
[ (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseArray Value -> Parser (Some tag)
valueParser Value
j,
(Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject Value -> Parser (Some tag)
valueParser Value
j,
String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
[String] -> String
unwords
[ String
"Cannot parse",
String
typeName,
String
"into a dependent sum: not an object or array"
]
]
Right Key -> Parser (Some tag)
keyParser -> (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject ((Key -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a. (Key -> Parser a) -> Value -> Parser a
liftKeyParser Key -> Parser (Some tag)
keyParser) Value
j
where
typeName :: String
typeName = Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy typeName -> String) -> Proxy typeName -> String
forall a b. (a -> b) -> a -> b
$ forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName
tagParser :: Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
tagParser = case forall a. FromJSONKey a => FromJSONKeyFunction a
fromJSONKey @(Some tag) of
FromJSONKeyFunction (Some tag)
FromJSONKeyCoerce -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Some tag -> Parser (Some tag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some tag -> Parser (Some tag))
-> (Key -> Some tag) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Some tag
coerce (Text -> Some tag) -> (Key -> Text) -> Key -> Some tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
FromJSONKeyText Text -> Some tag
fromText -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Some tag -> Parser (Some tag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Some tag -> Parser (Some tag))
-> (Key -> Some tag) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Some tag
fromText (Text -> Some tag) -> (Key -> Text) -> Key -> Some tag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
FromJSONKeyTextParser Text -> Parser (Some tag)
parseText -> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. b -> Either a b
Right ((Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag)))
-> (Key -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. (a -> b) -> a -> b
$ Text -> Parser (Some tag)
parseText (Text -> Parser (Some tag))
-> (Key -> Text) -> Key -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Text
K.toText
FromJSONKeyValue Value -> Parser (Some tag)
valueParser -> (Value -> Parser (Some tag))
-> Either (Value -> Parser (Some tag)) (Key -> Parser (Some tag))
forall a b. a -> Either a b
Left Value -> Parser (Some tag)
valueParser
liftKeyParser :: (Key -> Parser a) -> Value -> Parser a
liftKeyParser :: forall a. (Key -> Parser a) -> Value -> Parser a
liftKeyParser Key -> Parser a
f = String -> (Text -> Parser a) -> Value -> Parser a
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Key" (Key -> Parser a
f (Key -> Parser a) -> (Text -> Key) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText)
parseArray ::
(Value -> Parser (Some tag)) ->
Value ->
Parser (ObjectWithSingleField typeName tag f)
parseArray :: (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseArray Value -> Parser (Some tag)
keyParser = String
-> (Array -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
typeName ((Array -> Parser (ObjectWithSingleField typeName tag f))
-> Value -> Parser (ObjectWithSingleField typeName tag f))
-> (Array -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Array
a ->
case Array -> Int
forall a. Vector a -> Int
V.length Array
a of
Int
2 -> do
Some tag a
tag <- Value -> Parser (Some tag)
keyParser (Value -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a b. (a -> b) -> a -> b
$ Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
0
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f))
-> (FromJSON (f a) =>
Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
DSum tag f -> ObjectWithSingleField typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField (DSum tag f -> ObjectWithSingleField typeName tag f)
-> (f a -> DSum tag f)
-> f a
-> ObjectWithSingleField typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> ObjectWithSingleField typeName tag f)
-> Parser (f a) -> Parser (ObjectWithSingleField typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
1)
Int
n ->
String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
[String] -> String
unwords
[ String
"Cannot unpack array of length",
Int -> String
forall a. Show a => a -> String
show Int
n,
String
"into a dependent sum"
]
parseObject ::
(Value -> Parser (Some tag)) ->
Value ->
Parser (ObjectWithSingleField typeName tag f)
parseObject :: (Value -> Parser (Some tag))
-> Value -> Parser (ObjectWithSingleField typeName tag f)
parseObject Value -> Parser (Some tag)
keyParser = String
-> (Object -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
typeName ((Object -> Parser (ObjectWithSingleField typeName tag f))
-> Value -> Parser (ObjectWithSingleField typeName tag f))
-> (Object -> Parser (ObjectWithSingleField typeName tag f))
-> Value
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Object
o ->
case Object -> [Pair]
forall v. KeyMap v -> [(Key, v)]
KM.toList Object
o of
[] -> String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty object"
[(Key
k, Value
v)] -> do
Some tag a
tag <- Value -> Parser (Some tag)
keyParser (Value -> Parser (Some tag))
-> (Text -> Value) -> Text -> Parser (Some tag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
String (Text -> Parser (Some tag)) -> Text -> Parser (Some tag)
forall a b. (a -> b) -> a -> b
$ Key -> Text
K.toText Key
k
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f))
-> (FromJSON (f a) =>
Parser (ObjectWithSingleField typeName tag f))
-> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
DSum tag f -> ObjectWithSingleField typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> ObjectWithSingleField typeName tag f
ObjectWithSingleField (DSum tag f -> ObjectWithSingleField typeName tag f)
-> (f a -> DSum tag f)
-> f a
-> ObjectWithSingleField typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> ObjectWithSingleField typeName tag f)
-> Parser (f a) -> Parser (ObjectWithSingleField typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
[Pair]
_ ->
String -> Parser (ObjectWithSingleField typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (ObjectWithSingleField typeName tag f))
-> String -> Parser (ObjectWithSingleField typeName tag f)
forall a b. (a -> b) -> a -> b
$
[String] -> String
unwords
[ String
"Cannot unpack object with",
Int -> String
forall a. Show a => a -> String
show (Int -> String) -> ([Key] -> Int) -> [Key] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Key] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Key] -> String) -> [Key] -> String
forall a b. (a -> b) -> a -> b
$ Object -> [Key]
forall v. KeyMap v -> [Key]
KM.keys Object
o,
String
"into a dependent sum"
]
instance
( Has' ToJSON tag f,
ToJSONKey (Some tag)
) =>
ToJSON (ObjectWithSingleField typeName tag f)
where
toJSON :: ObjectWithSingleField typeName tag f -> Value
toJSON (ObjectWithSingleField (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
forall a b. (a -> b) -> a -> b
$
case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey @(Some tag) of
ToJSONKeyText Some tag -> Key
toKey Some tag -> Encoding' Key
_ -> [Pair] -> Value
object [Some tag -> Key
toKey (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) Key -> f a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa]
ToJSONKeyValue Some tag -> Value
toValue Some tag -> Encoding
_ -> case Some tag -> Value
toValue (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) of
String Text
t -> [Pair] -> Value
object [Text -> Key
K.fromText Text
t Key -> f a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= f a
fa]
Value
v -> [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value
v, f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa]
toEncoding :: ObjectWithSingleField typeName tag f -> Encoding
toEncoding (ObjectWithSingleField (tag a
tag :=> f a
fa)) = forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Encoding) -> Encoding)
-> (ToJSON (f a) => Encoding) -> Encoding
forall a b. (a -> b) -> a -> b
$
case forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey @(Some tag) of
ToJSONKeyText Some tag -> Key
_ Some tag -> Encoding' Key
toKeyEncoding ->
Series -> Encoding
E.pairs (Encoding' Key -> Encoding -> Series
E.pair' (Some tag -> Encoding' Key
toKeyEncoding (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag)) (f a -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
ToJSONKeyValue Some tag -> Value
toValue Some tag -> Encoding
_ -> case Some tag -> Value
toValue (tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag) of
String Text
t -> Series -> Encoding
E.pairs (Encoding' Key -> Encoding -> Series
E.pair' (Text -> Encoding' Key
forall a. Text -> Encoding' a
E.text Text
t) (f a -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding f a
fa))
Value
v -> [Value] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Value
v, f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa]
newtype
TwoElemArray
(typeName :: Symbol)
(tag :: k -> Type)
(f :: k -> Type)
= TwoElemArray (DSum tag f)
instance
( KnownSymbol typeName,
Has' FromJSON tag f,
FromJSON (Some tag)
) =>
FromJSON (TwoElemArray typeName tag f)
where
parseJSON :: Value -> Parser (TwoElemArray typeName tag f)
parseJSON = String
-> (Array -> Parser (TwoElemArray typeName tag f))
-> Value
-> Parser (TwoElemArray typeName tag f)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray (Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @typeName)) ((Array -> Parser (TwoElemArray typeName tag f))
-> Value -> Parser (TwoElemArray typeName tag f))
-> (Array -> Parser (TwoElemArray typeName tag f))
-> Value
-> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$ \Array
a ->
case Array -> Int
forall a. Vector a -> Int
V.length Array
a of
Int
2 -> do
Some tag a
tag <- Value -> Parser (Some tag)
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> Parser (Some tag)) -> Value -> Parser (Some tag)
forall a b. (a -> b) -> a -> b
$ Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
0
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @FromJSON @f tag a
tag ((FromJSON (f a) => Parser (TwoElemArray typeName tag f))
-> Parser (TwoElemArray typeName tag f))
-> (FromJSON (f a) => Parser (TwoElemArray typeName tag f))
-> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$
DSum tag f -> TwoElemArray typeName tag f
forall k (typeName :: Symbol) (tag :: k -> *) (f :: k -> *).
DSum tag f -> TwoElemArray typeName tag f
TwoElemArray (DSum tag f -> TwoElemArray typeName tag f)
-> (f a -> DSum tag f) -> f a -> TwoElemArray typeName tag f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (tag a
tag tag a -> f a -> DSum tag f
forall {k} (tag :: k -> *) (f :: k -> *) (a :: k).
tag a -> f a -> DSum tag f
:=>) (f a -> TwoElemArray typeName tag f)
-> Parser (f a) -> Parser (TwoElemArray typeName tag f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (f a)
forall a. FromJSON a => Value -> Parser a
parseJSON (Array
a Array -> Int -> Value
forall a. Vector a -> Int -> a
! Int
1)
Int
n ->
String -> Parser (TwoElemArray typeName tag f)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (TwoElemArray typeName tag f))
-> String -> Parser (TwoElemArray typeName tag f)
forall a b. (a -> b) -> a -> b
$
[String] -> String
unwords
[ String
"Cannot unpack array of length",
Int -> String
forall a. Show a => a -> String
show Int
n,
String
"into a dependent sum"
]
instance
( Has' ToJSON tag f,
ToJSON (Some tag)
) =>
ToJSON (TwoElemArray typeName tag f)
where
toJSON :: TwoElemArray typeName tag f -> Value
toJSON (TwoElemArray (tag a
tag :=> f a
fa)) =
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Value) -> Value)
-> (ToJSON (f a) => Value) -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa]
toEncoding :: TwoElemArray typeName tag f -> Encoding
toEncoding (TwoElemArray (tag a
tag :=> f a
fa)) =
forall {k} {k'} (c :: k -> Constraint) (g :: k' -> k)
(f :: k' -> *) (a :: k') r.
Has' c f g =>
f a -> (c (g a) => r) -> r
forall (c :: * -> Constraint) (g :: k -> *) (f :: k -> *) (a :: k)
r.
Has' c f g =>
f a -> (c (g a) => r) -> r
has' @ToJSON @f tag a
tag ((ToJSON (f a) => Encoding) -> Encoding)
-> (ToJSON (f a) => Encoding) -> Encoding
forall a b. (a -> b) -> a -> b
$ [Value] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding [Some tag -> Value
forall a. ToJSON a => a -> Value
toJSON (Some tag -> Value) -> Some tag -> Value
forall a b. (a -> b) -> a -> b
$ tag a -> Some tag
forall {k} (tag :: k -> *) (a :: k). tag a -> Some tag
Some tag a
tag, f a -> Value
forall a. ToJSON a => a -> Value
toJSON f a
fa]