{-# 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 qualified Data.Aeson.KeyMap as KeyMap
import           Data.Aeson.Types    (typeMismatch)
import           Data.List           (intercalate)
import           Data.String         (IsString (fromString))

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
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList ([(Key, Value)] -> Object)
-> (Rec r -> [(Key, Value)]) -> Rec r -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToJSON a => a -> Value) -> Rec r -> [(Key, Value)]
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 -> 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 -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Label l -> Key
forall s a. (IsString s, Show a) => a -> s
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 = [(Key, Value)] -> Value
object [Key -> (Key, Value)
foo Key
l]
    where (Key
l, Key -> (Key, Value)
foo) = (forall a. ToJSON a => a -> Key -> (Key, Value))
-> Var r -> (Key, Key -> (Key, Value))
forall (c :: * -> Constraint) (ρ :: Row *) s b.
(Forall ρ c, IsString s) =>
(forall a. c a => a -> b) -> Var ρ -> (s, b)
Var.eraseWithLabels @ToJSON (\a
v Key
l -> Key
l Key -> a -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> 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 -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Label l -> Key
forall s a. (IsString s, Show a) => a -> s
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' :: (IsString s, Show a) => a -> s
show' :: a -> s
show' = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (a -> String) -> a -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show