{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module       : Data.Wedge.Aeson
-- Copyright    : (c) 2020 Emily Pillmore
-- License      : BSD-3-Clause
--
-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability    : Experimental
-- Portability  : portable
--
-- This module contains the Aeson instances for the 'Wedge' datatype.
--
module Data.Wedge.Aeson where


import Data.Aeson
import Data.Aeson.Encoding (emptyObject_, pair)
import qualified Data.HashMap.Lazy as HM
import Data.Wedge (Wedge(..))


instance (ToJSON a, ToJSON b) => ToJSON (Wedge a b) where
    toJSON :: Wedge a b -> Value
toJSON Wedge a b
Nowhere = [Pair] -> Value
object []
    toJSON (Here a
a) = [Pair] -> Value
object [ Text
"Here" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a ]
    toJSON (There b
b) = [Pair] -> Value
object [ Text
"There" Text -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b ]

    toEncoding :: Wedge a b -> Encoding
toEncoding (Here a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"Here" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a
    toEncoding (There b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"There" Text -> b -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b
    toEncoding Wedge a b
Nowhere = Encoding
emptyObject_

instance (FromJSON a, FromJSON b) => FromJSON (Wedge a b) where
    parseJSON :: Value -> Parser (Wedge a b)
parseJSON = String
-> (Object -> Parser (Wedge a b)) -> Value -> Parser (Wedge a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Wedge a b" ([Pair] -> Parser (Wedge a b)
forall a a b.
(Eq a, IsString a, FromJSON a, FromJSON b) =>
[(a, Value)] -> Parser (Wedge a b)
go ([Pair] -> Parser (Wedge a b))
-> (Object -> [Pair]) -> Object -> Parser (Wedge a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList)
      where
        go :: [(a, Value)] -> Parser (Wedge a b)
go [(a
"Here", Value
a)] = a -> Wedge a b
forall a b. a -> Wedge a b
Here (a -> Wedge a b) -> Parser a -> Parser (Wedge a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a
        go [(a
"There", Value
b)] = b -> Wedge a b
forall a b. b -> Wedge a b
There (b -> Wedge a b) -> Parser b -> Parser (Wedge a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b
        go [] = Wedge a b -> Parser (Wedge a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wedge a b
forall a b. Wedge a b
Nowhere
        go [(a, Value)]
_  = String -> Parser (Wedge a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or one with 'Here' or 'There' keys only"


instance ToJSON2 Wedge where
    liftToJSON2 :: (a -> Value)
-> ([a] -> Value)
-> (b -> Value)
-> ([b] -> Value)
-> Wedge a b
-> Value
liftToJSON2 a -> Value
f [a] -> Value
_ b -> Value
_ [b] -> Value
_ (Here a
a) = [Pair] -> Value
object [ Text
"Here" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
f a
a ]
    liftToJSON2 a -> Value
_ [a] -> Value
_ b -> Value
g [b] -> Value
_ (There b
b) = [Pair] -> Value
object [ Text
"There" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b -> Value
g b
b ]
    liftToJSON2 a -> Value
_ [a] -> Value
_ b -> Value
_ [b] -> Value
_ Wedge a b
Nowhere = [Pair] -> Value
object []

    liftToEncoding2 :: (a -> Encoding)
-> ([a] -> Encoding)
-> (b -> Encoding)
-> ([b] -> Encoding)
-> Wedge a b
-> Encoding
liftToEncoding2 a -> Encoding
f [a] -> Encoding
_ b -> Encoding
_ [b] -> Encoding
_ (Here a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"Here" (a -> Encoding
f a
a)
    liftToEncoding2 a -> Encoding
_ [a] -> Encoding
_ b -> Encoding
g [b] -> Encoding
_ (There b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"There" (b -> Encoding
g b
b)
    liftToEncoding2 a -> Encoding
_ [a] -> Encoding
_ b -> Encoding
_ [b] -> Encoding
_ Wedge a b
Nowhere = Encoding
emptyObject_


instance ToJSON a => ToJSON1 (Wedge a) where
    liftToJSON :: (a -> Value) -> ([a] -> Value) -> Wedge a a -> Value
liftToJSON a -> Value
_ [a] -> Value
_ (Here a
a) = [Pair] -> Value
object [ Text
"Here" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a ]
    liftToJSON a -> Value
g [a] -> Value
_ (There a
b) = [Pair] -> Value
object [ Text
"There" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
g a
b ]
    liftToJSON a -> Value
_ [a] -> Value
_ Wedge a a
Nowhere = [Pair] -> Value
object []

    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> Wedge a a -> Encoding
liftToEncoding a -> Encoding
_ [a] -> Encoding
_ (Here a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"Here" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a
    liftToEncoding a -> Encoding
g [a] -> Encoding
_ (There a
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"There" (a -> Encoding
g a
b)
    liftToEncoding a -> Encoding
_ [a] -> Encoding
_ Wedge a a
Nowhere = Encoding
emptyObject_

instance FromJSON2 Wedge where
    liftParseJSON2 :: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value
-> Parser (Wedge a b)
liftParseJSON2 Value -> Parser a
f Value -> Parser [a]
_ Value -> Parser b
g Value -> Parser [b]
_ = String
-> (Object -> Parser (Wedge a b)) -> Value -> Parser (Wedge a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Wedge a b" ([Pair] -> Parser (Wedge a b)
forall a. (Eq a, IsString a) => [(a, Value)] -> Parser (Wedge a b)
go ([Pair] -> Parser (Wedge a b))
-> (Object -> [Pair]) -> Object -> Parser (Wedge a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList)
      where
        go :: [(a, Value)] -> Parser (Wedge a b)
go [] = Wedge a b -> Parser (Wedge a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wedge a b
forall a b. Wedge a b
Nowhere
        go [(a
"Here", Value
a)] = a -> Wedge a b
forall a b. a -> Wedge a b
Here (a -> Wedge a b) -> Parser a -> Parser (Wedge a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
a
        go [(a
"There", Value
b)] = b -> Wedge a b
forall a b. b -> Wedge a b
There (b -> Wedge a b) -> Parser b -> Parser (Wedge a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
g Value
b
        go [(a, Value)]
_  = String -> Parser (Wedge a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or one with 'Here' or 'There' keys only"

instance FromJSON a => FromJSON1 (Wedge a) where
    liftParseJSON :: (Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (Wedge a a)
liftParseJSON Value -> Parser a
f Value -> Parser [a]
_ = String
-> (Object -> Parser (Wedge a a)) -> Value -> Parser (Wedge a a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Wedge a b" ([Pair] -> Parser (Wedge a a)
forall a a.
(Eq a, IsString a, FromJSON a) =>
[(a, Value)] -> Parser (Wedge a a)
go ([Pair] -> Parser (Wedge a a))
-> (Object -> [Pair]) -> Object -> Parser (Wedge a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> [Pair]
forall k v. HashMap k v -> [(k, v)]
HM.toList)
      where
        go :: [(a, Value)] -> Parser (Wedge a a)
go [] = Wedge a a -> Parser (Wedge a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Wedge a a
forall a b. Wedge a b
Nowhere
        go [(a
"Here", Value
a)] = a -> Wedge a a
forall a b. a -> Wedge a b
Here (a -> Wedge a a) -> Parser a -> Parser (Wedge a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
a
        go [(a
"There", Value
b)] = a -> Wedge a a
forall a b. b -> Wedge a b
There (a -> Wedge a a) -> Parser a -> Parser (Wedge a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
b
        go [(a, Value)]
_  = String -> Parser (Wedge a a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or one with 'Here' or 'There' keys only"