{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Row.Aeson where
import Data.Aeson
import Data.Aeson.Types (Parser, typeMismatch)
import Data.List (intercalate)
import Data.Row
import Data.Row.Internal
import Data.Row.Records qualified as Rec
import Data.Bifunctor (second)
import Data.Functor.Const
import Data.Functor.Identity
import Data.Proxy
import Data.String
class ToJSONEntry a where
toJSONEntry :: String -> a -> Object
instance {-# OVERLAPPING #-} ToJSON a => ToJSONEntry (Maybe a) where
toJSONEntry :: String -> Maybe a -> Object
toJSONEntry String
_ Maybe a
Nothing = forall a. Monoid a => a
mempty
toJSONEntry String
k Maybe a
v = forall a. IsString a => String -> a
fromString String
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Maybe a
v
instance {-# OVERLAPPABLE #-} ToJSON a => ToJSONEntry a where
toJSONEntry :: String -> a -> Object
toJSONEntry String
k a
v = forall a. IsString a => String -> a
fromString String
k forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON a
v
class FromJSONEntry a where
parseJSONEntry :: Object -> String -> Parser a
instance {-# OVERLAPPING #-} FromJSON a => FromJSONEntry (Maybe a) where
parseJSONEntry :: Object -> String -> Parser (Maybe a)
parseJSONEntry Object
o String
k = Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? (forall a. IsString a => String -> a
fromString String
k)
instance {-# OVERLAPPABLE #-} FromJSON a => FromJSONEntry a where
parseJSONEntry :: Object -> String -> Parser a
parseJSONEntry Object
o String
k = Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: (forall a. IsString a => String -> a
fromString String
k)
instance Forall r ToJSONEntry => ToJSON (Rec r) where
toJSON :: Rec r -> Value
toJSON Rec r
rc = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ forall {k} a (b :: k). Const a b -> a
getConst forall a b. (a -> b) -> a -> b
$ forall k (r :: Row k) (c :: k -> Constraint) (p :: * -> * -> *)
(f :: Row k -> *) (g :: Row k -> *) (h :: k -> *).
(Forall r c, Bifunctor p) =>
Proxy (Proxy h, Proxy p)
-> (f Empty -> g Empty)
-> (forall (ℓ :: Symbol) (τ :: k) (ρ :: Row k).
(KnownSymbol ℓ, c τ, HasType ℓ τ ρ) =>
Label ℓ -> f ρ -> p (f (ρ .- ℓ)) (h τ))
-> (forall (ℓ :: Symbol) (τ :: k) (ρ :: Row k).
(KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ,
AllUniqueLabels (Extend ℓ τ ρ)) =>
Label ℓ -> p (g ρ) (h τ) -> g (Extend ℓ τ ρ))
-> f r
-> g r
metamorph @_ @r @ToJSONEntry @(,) @Rec @(Const Object) @Identity forall {k} (t :: k). Proxy t
Proxy forall {a}. Rec Empty -> Const Object Empty
doNil forall (l :: Symbol) (r' :: Row (*)).
KnownSymbol l =>
Label l -> Rec r' -> (Rec (r' .- l), Identity (r' .! l))
doUncons forall (l :: Symbol) t (r' :: Row (*)).
(KnownSymbol l, ToJSONEntry t) =>
Label l
-> (Const Object r', Identity t) -> Const Object (Extend l t r')
doCons Rec r
rc
where
doNil :: Rec Empty -> Const Object Empty
doNil :: forall {a}. Rec Empty -> Const Object Empty
doNil Rec Empty
_ = forall {k} a (b :: k). a -> Const a b
Const forall a. Monoid a => a
mempty
doUncons ::
forall l r'.
(KnownSymbol l) =>
Label l ->
Rec r' ->
(Rec (r' .- l), Identity (r' .! l))
doUncons :: forall (l :: Symbol) (r' :: Row (*)).
KnownSymbol l =>
Label l -> Rec r' -> (Rec (r' .- l), Identity (r' .! l))
doUncons Label l
l = forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second forall a. a -> Identity a
Identity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons Label l
l
doCons ::
forall l t r'.
(KnownSymbol l, ToJSONEntry t) =>
Label l ->
(Const Object r', Identity t) ->
Const Object (Extend l t r')
doCons :: forall (l :: Symbol) t (r' :: Row (*)).
(KnownSymbol l, ToJSONEntry t) =>
Label l
-> (Const Object r', Identity t) -> Const Object (Extend l t r')
doCons Label l
l (Const Object
c, Identity t
x) = forall {k} a (b :: k). a -> Const a b
Const forall a b. (a -> b) -> a -> b
$ forall a. ToJSONEntry a => String -> a -> Object
toJSONEntry (forall s a. (IsString s, Show a) => a -> s
show' Label l
l) t
x forall a. Semigroup a => a -> a -> a
<> Object
c
instance (AllUniqueLabels r, Forall r FromJSONEntry) => FromJSON (Rec r) where
parseJSON :: Value -> Parser (Rec r)
parseJSON (Object Object
o) = do
Rec r
r <- forall (c :: * -> Constraint) (f :: * -> *) (ρ :: Row (*)).
(Applicative f, Forall ρ c, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a. (KnownSymbol l, c a) => Label l -> f a)
-> f (Rec ρ)
Rec.fromLabelsA @FromJSONEntry forall a b. (a -> b) -> a -> b
$ \Label l
l -> do
a
x <- forall a. FromJSONEntry a => Object -> String -> Parser a
parseJSONEntry Object
o (forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Label l
l)
a
x seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Rec r
r seq :: forall a b. a -> b -> b
`seq` forall (f :: * -> *) a. Applicative f => a -> f a
pure Rec r
r
parseJSON Value
v = forall a. String -> Value -> Parser a
typeMismatch String
msg Value
v
where
msg :: String
msg = String
"REC: {" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall {k} (ρ :: Row k) (c :: k -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
labels @r @FromJSONEntry) forall a. [a] -> [a] -> [a]
++ String
"}"
lazyUncons :: KnownSymbol l => Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons :: forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> (Rec (r .- l), r .! l)
lazyUncons Label l
l Rec r
r = (forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Label l -> Rec r -> Rec (r .- l)
Rec.lazyRemove Label l
l Rec r
r, Rec r
r forall (l :: Symbol) (r :: Row (*)).
KnownSymbol l =>
Rec r -> Label l -> r .! l
.! Label l
l)