{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module       : Data.Smash.Aeson
-- Copyright    : (c) 2020 Emily Pillmore
-- License      : BSD-3-Clause
--
-- Maintainer   : Emily Pillmore <emilypi@cohomolo.gy>
-- Stability    : Experimental
-- Portability  : CPP
--
-- This module contains the Aeson instances for the 'Smash' datatype.
-- The 'Smash' instances,  explicitly naming the tuple entries using `SmashL` and `SmashR`
--
module Data.Smash.Aeson where


import Data.Aeson
import Data.Aeson.Encoding (emptyObject_, pair)
import qualified Data.HashMap.Lazy as HM
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup(..))
#endif
import Data.Smash (Smash(..))


instance (ToJSON a, ToJSON b) => ToJSON (Smash a b) where
    toJSON :: Smash a b -> Value
toJSON Smash a b
Nada = [Pair] -> Value
object []
    toJSON (Smash a
a b
b) = [Pair] -> Value
object [ Text
"SmashL" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a, Text
"SmashR" Text -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b ]

    toEncoding :: Smash a b -> Encoding
toEncoding (Smash a
a b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"SmashL" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"SmashR" Text -> b -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b
    toEncoding Smash a b
Nada = Encoding
emptyObject_

instance (FromJSON a, FromJSON b) => FromJSON (Smash a b) where
    parseJSON :: Value -> Parser (Smash a b)
parseJSON = String
-> (Object -> Parser (Smash a b)) -> Value -> Parser (Smash a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Smash a b" ([Pair] -> Parser (Smash a b)
forall a a a.
(Eq a, IsString a, FromJSON a, FromJSON a) =>
[(a, Value)] -> Parser (Smash a a)
go ([Pair] -> Parser (Smash a b))
-> (Object -> [Pair]) -> Object -> Parser (Smash 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 (Smash a a)
go [(a
"SmashL", Value
a), (a
"SmashR", Value
b)] = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash (a -> a -> Smash a a) -> Parser a -> Parser (a -> Smash 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 Parser (a -> Smash a a) -> Parser a -> Parser (Smash a a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b
        go [] = Smash a a -> Parser (Smash a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash a a
forall a b. Smash a b
Nada
        go [(a, Value)]
_  = String -> Parser (Smash a a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or a 'Smash' pair"


instance ToJSON2 Smash where
    liftToJSON2 :: (a -> Value)
-> ([a] -> Value)
-> (b -> Value)
-> ([b] -> Value)
-> Smash a b
-> Value
liftToJSON2 a -> Value
f [a] -> Value
_ b -> Value
g [b] -> Value
_ (Smash a
a b
b) = [Pair] -> Value
object [ Text
"SmashL" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
f a
a, Text
"SmashR" 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
_ Smash a b
Nada = [Pair] -> Value
object []

    liftToEncoding2 :: (a -> Encoding)
-> ([a] -> Encoding)
-> (b -> Encoding)
-> ([b] -> Encoding)
-> Smash a b
-> Encoding
liftToEncoding2 a -> Encoding
f [a] -> Encoding
_ b -> Encoding
g [b] -> Encoding
_ (Smash a
a b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"SmashL" (a -> Encoding
f a
a) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding -> Series
pair Text
"SmashR" (b -> Encoding
g b
b)
    liftToEncoding2 a -> Encoding
_ [a] -> Encoding
_ b -> Encoding
_ [b] -> Encoding
_ Smash a b
Nada = Encoding
emptyObject_


instance ToJSON a => ToJSON1 (Smash a) where
    liftToJSON :: (a -> Value) -> ([a] -> Value) -> Smash a a -> Value
liftToJSON a -> Value
g [a] -> Value
_ (Smash a
a a
b) = [Pair] -> Value
object [ Text
"SmashL" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a, Text
"SmashR" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
g a
b ]
    liftToJSON a -> Value
_ [a] -> Value
_ Smash a a
Nada = [Pair] -> Value
object []

    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> Smash a a -> Encoding
liftToEncoding a -> Encoding
g [a] -> Encoding
_ (Smash a
a a
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"SmashL" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding -> Series
pair Text
"SmashR" (a -> Encoding
g a
b)
    liftToEncoding a -> Encoding
_ [a] -> Encoding
_ Smash a a
Nada = Encoding
emptyObject_

instance FromJSON2 Smash where
    liftParseJSON2 :: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value
-> Parser (Smash a b)
liftParseJSON2 Value -> Parser a
f Value -> Parser [a]
_ Value -> Parser b
g Value -> Parser [b]
_ = String
-> (Object -> Parser (Smash a b)) -> Value -> Parser (Smash a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Smash a b" ([Pair] -> Parser (Smash a b)
forall a. (Eq a, IsString a) => [(a, Value)] -> Parser (Smash a b)
go ([Pair] -> Parser (Smash a b))
-> (Object -> [Pair]) -> Object -> Parser (Smash 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 (Smash a b)
go [] = Smash a b -> Parser (Smash a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash a b
forall a b. Smash a b
Nada
        go [(a
"SmashL", Value
a), (a
"SmashR", Value
b)] = a -> b -> Smash a b
forall a b. a -> b -> Smash a b
Smash (a -> b -> Smash a b) -> Parser a -> Parser (b -> Smash a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
a Parser (b -> Smash a b) -> Parser b -> Parser (Smash a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser b
g Value
b
        go [(a, Value)]
_ = String -> Parser (Smash a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or a 'Smash' pair"

instance FromJSON a => FromJSON1 (Smash a) where
    liftParseJSON :: (Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (Smash a a)
liftParseJSON Value -> Parser a
f Value -> Parser [a]
_ = String
-> (Object -> Parser (Smash a a)) -> Value -> Parser (Smash a a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Smash a b" ([Pair] -> Parser (Smash a a)
forall a a.
(Eq a, IsString a, FromJSON a) =>
[(a, Value)] -> Parser (Smash a a)
go ([Pair] -> Parser (Smash a a))
-> (Object -> [Pair]) -> Object -> Parser (Smash 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 (Smash a a)
go [] = Smash a a -> Parser (Smash a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Smash a a
forall a b. Smash a b
Nada
        go [(a
"SmashL", Value
a), (a
"SmashR", Value
b)] = a -> a -> Smash a a
forall a b. a -> b -> Smash a b
Smash (a -> a -> Smash a a) -> Parser a -> Parser (a -> Smash 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 Parser (a -> Smash a a) -> Parser a -> Parser (Smash a a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
f Value
b
        go [(a, Value)]
_ = String -> Parser (Smash a a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or a 'Smash' pair"