{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module       : Data.Can.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 'Can' datatype.
--
module Data.Can.Aeson where


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


instance (ToJSON a, ToJSON b) => ToJSON (Can a b) where
    toJSON :: Can a b -> Value
toJSON Can a b
Non = [Pair] -> Value
object []
    toJSON (One a
a) = [Pair] -> Value
object [ Text
"One" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a ]
    toJSON (Eno b
b) = [Pair] -> Value
object [ Text
"Eno" Text -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b ]
    toJSON (Two a
a b
b) = [Pair] -> Value
object [ Text
"One" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a, Text
"Eno" Text -> b -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b ]

    toEncoding :: Can a b -> Encoding
toEncoding (One a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"One" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a
    toEncoding (Eno b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"Eno" Text -> b -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b
    toEncoding (Two a
a b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"One" 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
"Eno" Text -> b -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b
b
    toEncoding Can a b
Non = Encoding
emptyObject_

instance (FromJSON a, FromJSON b) => FromJSON (Can a b) where
    parseJSON :: Value -> Parser (Can a b)
parseJSON = String -> (Object -> Parser (Can a b)) -> Value -> Parser (Can a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Can a b" ([Pair] -> Parser (Can a b)
forall a a b.
(Eq a, IsString a, FromJSON a, FromJSON b) =>
[(a, Value)] -> Parser (Can a b)
go ([Pair] -> Parser (Can a b))
-> (Object -> [Pair]) -> Object -> Parser (Can 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 (Can a b)
go [(a
"One", Value
a)] = a -> Can a b
forall a b. a -> Can a b
One (a -> Can a b) -> Parser a -> Parser (Can 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
"Eno", Value
b)] = b -> Can a b
forall a b. b -> Can a b
Eno (b -> Can a b) -> Parser b -> Parser (Can 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 [(a
"One", Value
a), (a
"Eno", Value
b)] = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a -> b -> Can a b) -> Parser a -> Parser (b -> Can 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 Parser (b -> Can a b) -> Parser b -> Parser (Can a b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser b
forall a. FromJSON a => Value -> Parser a
parseJSON Value
b
        go [] = Can a b -> Parser (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can a b
forall a b. Can a b
Non
        go [(a, Value)]
_  = String -> Parser (Can a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only"


instance ToJSON2 Can where
    liftToJSON2 :: (a -> Value)
-> ([a] -> Value)
-> (b -> Value)
-> ([b] -> Value)
-> Can a b
-> Value
liftToJSON2 a -> Value
f [a] -> Value
_ b -> Value
_ [b] -> Value
_ (One a
a) = [Pair] -> Value
object [ Text
"One" 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
_ (Eno b
b) = [Pair] -> Value
object [ Text
"Eno" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= b -> Value
g b
b ]
    liftToJSON2 a -> Value
f [a] -> Value
_ b -> Value
g [b] -> Value
_ (Two a
a b
b) = [Pair] -> Value
object [ Text
"One" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
f a
a, Text
"Eno" 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
_ Can a b
Non = [Pair] -> Value
object []

    liftToEncoding2 :: (a -> Encoding)
-> ([a] -> Encoding)
-> (b -> Encoding)
-> ([b] -> Encoding)
-> Can a b
-> Encoding
liftToEncoding2 a -> Encoding
f [a] -> Encoding
_ b -> Encoding
_ [b] -> Encoding
_ (One a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"One" (a -> Encoding
f a
a)
    liftToEncoding2 a -> Encoding
_ [a] -> Encoding
_ b -> Encoding
g [b] -> Encoding
_ (Eno b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"Eno" (b -> Encoding
g b
b)
    liftToEncoding2 a -> Encoding
f [a] -> Encoding
_ b -> Encoding
g [b] -> Encoding
_ (Two a
a b
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"One" (a -> Encoding
f a
a) Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding -> Series
pair Text
"Eno" (b -> Encoding
g b
b)
    liftToEncoding2 a -> Encoding
_ [a] -> Encoding
_ b -> Encoding
_ [b] -> Encoding
_ Can a b
Non = Encoding
emptyObject_


instance ToJSON a => ToJSON1 (Can a) where
    liftToJSON :: (a -> Value) -> ([a] -> Value) -> Can a a -> Value
liftToJSON a -> Value
_ [a] -> Value
_ (One a
a) = [Pair] -> Value
object [ Text
"One" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a ]
    liftToJSON a -> Value
g [a] -> Value
_ (Eno a
b) = [Pair] -> Value
object [ Text
"Eno" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
g a
b ]
    liftToJSON a -> Value
g [a] -> Value
_ (Two a
a a
b) = [Pair] -> Value
object [ Text
"One" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a, Text
"Eno" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a -> Value
g a
b ]
    liftToJSON a -> Value
_ [a] -> Value
_ Can a a
Non = [Pair] -> Value
object []

    liftToEncoding :: (a -> Encoding) -> ([a] -> Encoding) -> Can a a -> Encoding
liftToEncoding a -> Encoding
_ [a] -> Encoding
_ (One a
a) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"One" Text -> a -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= a
a
    liftToEncoding a -> Encoding
g [a] -> Encoding
_ (Eno a
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text -> Encoding -> Series
pair Text
"Eno" (a -> Encoding
g a
b)
    liftToEncoding a -> Encoding
g [a] -> Encoding
_ (Two a
a a
b) = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$ Text
"One" 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
"Eno" (a -> Encoding
g a
b)
    liftToEncoding a -> Encoding
_ [a] -> Encoding
_ Can a a
Non = Encoding
emptyObject_

instance FromJSON2 Can where
    liftParseJSON2 :: (Value -> Parser a)
-> (Value -> Parser [a])
-> (Value -> Parser b)
-> (Value -> Parser [b])
-> Value
-> Parser (Can a b)
liftParseJSON2 Value -> Parser a
f Value -> Parser [a]
_ Value -> Parser b
g Value -> Parser [b]
_ = String -> (Object -> Parser (Can a b)) -> Value -> Parser (Can a b)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Can a b" ([Pair] -> Parser (Can a b)
forall a. (Eq a, IsString a) => [(a, Value)] -> Parser (Can a b)
go ([Pair] -> Parser (Can a b))
-> (Object -> [Pair]) -> Object -> Parser (Can 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 (Can a b)
go [] = Can a b -> Parser (Can a b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can a b
forall a b. Can a b
Non
        go [(a
"One", Value
a)] = a -> Can a b
forall a b. a -> Can a b
One (a -> Can a b) -> Parser a -> Parser (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
a
        go [(a
"Eno", Value
b)] = b -> Can a b
forall a b. b -> Can a b
Eno (b -> Can a b) -> Parser b -> Parser (Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser b
g Value
b
        go [(a
"One", Value
a), (a
"Eno", Value
b)] = a -> b -> Can a b
forall a b. a -> b -> Can a b
Two (a -> b -> Can a b) -> Parser a -> Parser (b -> Can a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
a Parser (b -> Can a b) -> Parser b -> Parser (Can 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 (Can a b)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only"

instance FromJSON a => FromJSON1 (Can a) where
    liftParseJSON :: (Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (Can a a)
liftParseJSON Value -> Parser a
f Value -> Parser [a]
_ = String -> (Object -> Parser (Can a a)) -> Value -> Parser (Can a a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Can a b" ([Pair] -> Parser (Can a a)
forall a a.
(Eq a, IsString a, FromJSON a) =>
[(a, Value)] -> Parser (Can a a)
go ([Pair] -> Parser (Can a a))
-> (Object -> [Pair]) -> Object -> Parser (Can 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 (Can a a)
go [] = Can a a -> Parser (Can a a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Can a a
forall a b. Can a b
Non
        go [(a
"One", Value
a)] = a -> Can a a
forall a b. a -> Can a b
One (a -> Can a a) -> Parser a -> Parser (Can 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
"Eno", Value
b)] = a -> Can a a
forall a b. b -> Can a b
Eno (a -> Can a a) -> Parser a -> Parser (Can a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
f Value
b
        go [(a
"One", Value
a), (a
"Eno", Value
b)] = a -> a -> Can a a
forall a b. a -> b -> Can a b
Two (a -> a -> Can a a) -> Parser a -> Parser (a -> Can 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 -> Can a a) -> Parser a -> Parser (Can 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 (Can a a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected either empty object, or 'One' and 'Eno' keys, 'One' or 'Eno' keys only"