{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Row.Aeson
--
-- This module adds orphan Aeson instances for 'Rec' and 'Var'.
--
-----------------------------------------------------------------------------

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