{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Row.Aeson () where
import Data.Aeson
import Data.Aeson.Encoding (pairStr)
import Data.Aeson.Types (typeMismatch)
import Data.List (intercalate)
import Data.Text (Text)
import qualified Data.Text as Text (pack)
import Data.Row
import qualified Data.Row.Records as Rec
import qualified Data.Row.Variants as Var
instance Forall r ToJSON => ToJSON (Rec r) where
toJSON :: Rec r -> Value
toJSON = Object -> Value
Object (Object -> Value) -> (Rec r -> Object) -> Rec r -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToJSON a => a -> Value) -> Rec r -> Object
forall (c :: * -> Constraint) (r :: Row *) s b.
(IsString s, Eq s, Hashable s, Forall r c) =>
(forall a. c a => a -> b) -> Rec r -> HashMap s b
Rec.eraseToHashMap @ToJSON forall a. ToJSON a => a -> Value
toJSON
toEncoding :: Rec r -> Encoding
toEncoding =
Series -> Encoding
pairs (Series -> Encoding) -> (Rec r -> Series) -> Rec r -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Encoding) -> Series) -> [(String, Encoding)] -> Series
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((String -> Encoding -> Series) -> (String, Encoding) -> Series
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Encoding -> Series
pairStr) ([(String, Encoding)] -> Series)
-> (Rec r -> [(String, Encoding)]) -> Rec r -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToJSON a => a -> Encoding)
-> Rec r -> [(String, Encoding)]
forall (c :: * -> Constraint) (ρ :: Row *) s b.
(Forall ρ c, IsString s) =>
(forall a. c a => a -> b) -> Rec ρ -> [(s, b)]
Rec.eraseWithLabels @ToJSON forall a. ToJSON a => a -> Encoding
toEncoding
instance (AllUniqueLabels r, Forall r FromJSON) => FromJSON (Rec r) where
parseJSON :: Value -> Parser (Rec r)
parseJSON (Object Object
o) = do
Rec r
r <- forall (f :: * -> *) (ρ :: Row *).
(Applicative f, Forall ρ FromJSON, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> f a)
-> f (Rec ρ)
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 @FromJSON ((forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> Parser a)
-> Parser (Rec r))
-> (forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> Parser a)
-> Parser (Rec r)
forall a b. (a -> b) -> a -> b
$ \ Label l
l -> do a
x <- Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: (Label l -> Text
forall a. Show a => a -> Text
show' Label l
l)
a
x a -> Parser a -> Parser a
`seq` a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Rec r
r Rec r -> Parser (Rec r) -> Parser (Rec r)
`seq` Rec r -> Parser (Rec r)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Rec r
r
parseJSON Value
v = String -> Value -> Parser (Rec r)
forall a. String -> Value -> Parser a
typeMismatch String
msg Value
v
where msg :: String
msg = String
"REC: {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall s. (IsString s, Forall r FromJSON) => [s]
forall k (ρ :: Row k) (c :: k -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
labels @r @FromJSON) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
instance Forall r ToJSON => ToJSON (Var r) where
toJSON :: Var r -> Value
toJSON Var r
v = [Pair] -> Value
object [Text -> Pair
foo Text
l]
where (Text
l, Text -> Pair
foo) = (forall a. ToJSON a => a -> Text -> Pair)
-> Var r -> (Text, Text -> Pair)
forall (c :: * -> Constraint) (ρ :: Row *) s b.
(Forall ρ c, IsString s) =>
(forall a. c a => a -> b) -> Var ρ -> (s, b)
Var.eraseWithLabels @ToJSON (\a
v Text
l -> Text
l Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
v) Var r
v
instance (AllUniqueLabels r, Forall r FromJSON) => FromJSON (Var r) where
parseJSON :: Value -> Parser (Var r)
parseJSON (Object Object
o) = forall (ρ :: Row *) (f :: * -> *).
(Alternative f, Forall ρ FromJSON, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> f a)
-> f (Var ρ)
forall (c :: * -> Constraint) (ρ :: Row *) (f :: * -> *).
(Alternative f, Forall ρ c, AllUniqueLabels ρ) =>
(forall (l :: Symbol) a. (KnownSymbol l, c a) => Label l -> f a)
-> f (Var ρ)
Var.fromLabels @FromJSON ((forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> Parser a)
-> Parser (Var r))
-> (forall (l :: Symbol) a.
(KnownSymbol l, FromJSON a) =>
Label l -> Parser a)
-> Parser (Var r)
forall a b. (a -> b) -> a -> b
$ \ Label l
l -> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
.: (Label l -> Text
forall a. Show a => a -> Text
show' Label l
l)
parseJSON Value
v = String -> Value -> Parser (Var r)
forall a. String -> Value -> Parser a
typeMismatch String
msg Value
v
where msg :: String
msg = String
"VAR: {" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall s. (IsString s, Forall r FromJSON) => [s]
forall k (ρ :: Row k) (c :: k -> Constraint) s.
(IsString s, Forall ρ c) =>
[s]
labels @r @FromJSON) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
show' :: Show a => a -> Text
show' :: a -> Text
show' = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show