{-# LANGUAGE
    CPP
  , FlexibleContexts
  , FlexibleInstances
  , OverloadedStrings
  , ScopedTypeVariables
  , TupleSections
  , TypeOperators
  #-}
#if __GLASGOW_HASKELL__ < 710
{-# LANGUAGE OverlappingInstances #-}
#endif
-- | This module offers generic conversions to and from JSON 'Value's
-- for data types with a 'Generic' instance.
--
-- The structure of the generated JSON is meant to be close to
-- idiomatic JSON. This means:
--
-- * Enumerations are converted to JSON strings.
--
-- * Record fields become JSON keys.
--
-- * Data types with one unlabeled field convert to just that field.
--
-- * Data types with multiple unlabeled fields become arrays.
--
-- * Multiple constructors are represented by keys.
--
-- * 'Maybe' values are either an absent key, or the value.
--
-- See 'tests/Main.hs' for more examples.
module Generics.Generic.Aeson
  ( gtoJson
  , gparseJson
  , GtoJson (..)
  , GfromJson (..)
  , formatLabel
  , Settings (..)
  , defaultSettings
  , gtoJsonWithSettings
  , gparseJsonWithSettings
  ) where

import Control.Applicative
import Control.Monad.State
import Data.Aeson
import Data.Aeson.Types hiding (GFromJSON, GToJSON)
import Data.Proxy
import Data.Text (Text)
import GHC.Generics
import Generics.Deriving.ConNames
import qualified Data.HashMap.Strict as H
import qualified Data.Text           as T
import qualified Data.Vector         as V

import Generics.Generic.Aeson.Util

-- | Class for converting the functors from "GHC.Generics" to JSON.
-- You generally don't need to give any custom instances. Just add
-- 'deriving Generic' and call 'gToJson'.
class GtoJson f where
  -- | Generically show a functor as a JSON value.  The first argument
  -- tells us if there are multiple constructors in the data type. The
  -- second indicates if this data type is an enumeration (only empty
  -- constructors). A functor is then converted to either a list
  -- of values (for non-labeled fields) or a list of String/value
  -- pairs (for labeled fields).
  gtoJSONf :: Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]

-- | Class for parsing the functors from "GHC.Generics" from JSON.
-- You generally don't need to give any custom instances. Just add
-- 'deriving Generic' and call 'gFromJson'.
class GfromJson f where
  -- | Generically read a functor from a JSON value.  The first
  -- argument tells us if there are multiple constructors in the data
  -- type. The second indicates if we've already detected that this
  -- data type has multiple constructors. When this is False, the
  -- (:*:) puts the fields in the state. The third indicates if this
  -- data type is an enumeration (only empty constructors). The third
  -- is a function for parsing the recursive positions. A JSON value
  -- is then parsed to either a functor, or a failure.
  gparseJSONf :: Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)

-- Void: Used for data types without constructors
-- instance GJSON V1

-- Unit: Used for constructors without arguments
instance GtoJson U1 where
  gtoJSONf :: Settings -> Bool -> Bool -> U1 a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
_ Bool
_ Bool
_ U1 a
U1 = [(Text, Value)] -> Either [Value] [(Text, Value)]
forall a b. b -> Either a b
Right []
instance GfromJson U1 where
  gparseJSONf :: Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (U1 a)
gparseJSONf Settings
_ Bool
_ Bool
_ Bool
_ = U1 a -> StateT [Value] Parser (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1

-- | Convert any datatype with a 'Generic' instance to a JSON 'Value'.

gtoJson
  :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))
  => a -> Value
gtoJson :: a -> Value
gtoJson = Settings -> a -> Value
forall a.
(Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a)) =>
Settings -> a -> Value
gtoJsonWithSettings Settings
defaultSettings

gtoJsonWithSettings
  :: forall a. (Generic a, GtoJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))
   => Settings -> a -> Value
gtoJsonWithSettings :: Settings -> a -> Value
gtoJsonWithSettings Settings
settings a
x =
  case Settings
-> Bool -> Bool -> Rep a Any -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
settings ([String] -> Bool
forall a. [a] -> Bool
multipleConstructors ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ a -> [String]
forall a. (Generic a, ConNames (Rep a)) => a -> [String]
conNames a
x) (Proxy a -> Bool
forall a. (Generic a, GIsEnum (Rep a)) => Proxy a -> Bool
isEnum (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from a
x) of
    Left  [Value
v] -> Value
v
    Left  [Value]
_   -> String -> Value
forall a. HasCallStack => String -> a
error String
"The impossible happened: multiple returned values in gtoJSON."
    Right [(Text, Value)]
_   -> String -> Value
forall a. HasCallStack => String -> a
error String
"The impossible happened: labeled values returned in gtoJSON."

-- | Parse any datatype with a 'Generic' instance from a JSON 'Value'.
gparseJson
  :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))
  => Value -> Parser a
gparseJson :: Value -> Parser a
gparseJson = Settings -> Value -> Parser a
forall a.
(Generic a, GfromJson (Rep a), ConNames (Rep a),
 GIsEnum (Rep a)) =>
Settings -> Value -> Parser a
gparseJsonWithSettings Settings
defaultSettings

gparseJsonWithSettings
  :: forall a. (Generic a, GfromJson (Rep a), ConNames (Rep a), GIsEnum (Rep a))
  => Settings -> Value -> Parser a
gparseJsonWithSettings :: Settings -> Value -> Parser a
gparseJsonWithSettings Settings
set
  = (Rep a Any -> a) -> Parser (Rep a Any) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to
  (Parser (Rep a Any) -> Parser a)
-> (Value -> Parser (Rep a Any)) -> Value -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT [Value] Parser (Rep a Any) -> [Value] -> Parser (Rep a Any)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser (Rep a Any)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set ([String] -> Bool
forall a. [a] -> Bool
multipleConstructors ([String] -> Bool) -> [String] -> Bool
forall a b. (a -> b) -> a -> b
$ a -> [String]
forall a. (Generic a, ConNames (Rep a)) => a -> [String]
conNames (a
forall a. HasCallStack => a
undefined :: a)) Bool
False (Proxy a -> Bool
forall a. (Generic a, GIsEnum (Rep a)) => Proxy a -> Bool
isEnum (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)))
  ([Value] -> Parser (Rep a Any))
-> (Value -> [Value]) -> Value -> Parser (Rep a Any)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return

-- Structure type for constant values.
instance ToJSON c => GtoJson (K1 a c) where
  gtoJSONf :: Settings
-> Bool -> Bool -> K1 a c a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
_ Bool
_ Bool
_ (K1 c
a) = [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [c -> Value
forall a. ToJSON a => a -> Value
toJSON c
a]
instance FromJSON c => GfromJson (K1 a c) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser (K1 a c a)
gparseJSONf Settings
_ Bool
_ Bool
_ Bool
_   = Parser (K1 a c a) -> StateT [Value] Parser (K1 a c a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser (K1 a c a) -> StateT [Value] Parser (K1 a c a))
-> (Value -> Parser (K1 a c a))
-> Value
-> StateT [Value] Parser (K1 a c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> K1 a c a) -> Parser c -> Parser (K1 a c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c -> K1 a c a
forall k i c (p :: k). c -> K1 i c p
K1 (Parser c -> Parser (K1 a c a))
-> (Value -> Parser c) -> Value -> Parser (K1 a c a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser c
forall a. FromJSON a => Value -> Parser a
parseJSON (Value -> StateT [Value] Parser (K1 a c a))
-> StateT [Value] Parser Value -> StateT [Value] Parser (K1 a c a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT [Value] Parser Value
pop

instance (GtoJson f, GtoJson g) => GtoJson (f :+: g) where
  gtoJSONf :: Settings
-> Bool -> Bool -> (:+:) f g a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm (L1 f a
x) = Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm f a
x
  gtoJSONf Settings
set Bool
mc Bool
enm (R1 g a
x) = Settings -> Bool -> Bool -> g a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm g a
x
instance (GfromJson f, GfromJson g) => GfromJson (f :+: g) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser ((:+:) f g a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm
    =  f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm
   StateT [Value] Parser ((:+:) f g a)
-> StateT [Value] Parser ((:+:) f g a)
-> StateT [Value] Parser ((:+:) f g a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> (:+:) f g a)
-> StateT [Value] Parser (g a)
-> StateT [Value] Parser ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (g a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm

instance (GtoJson f, GtoJson g) => GtoJson (f :*: g) where
  gtoJSONf :: Settings
-> Bool -> Bool -> (:*:) f g a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm (f a
x :*: g a
y) =
    case (Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm f a
x, Settings -> Bool -> Bool -> g a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm g a
y) of
      (Left  [Value]
xvs, Left  [Value]
yvs) -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left  ([Value]
xvs [Value] -> [Value] -> [Value]
forall a. [a] -> [a] -> [a]
++ [Value]
yvs)
      (Right [(Text, Value)]
xvs, Right [(Text, Value)]
yvs) -> [(Text, Value)] -> Either [Value] [(Text, Value)]
forall a b. b -> Either a b
Right ([(Text, Value)]
xvs [(Text, Value)] -> [(Text, Value)] -> [(Text, Value)]
forall a. [a] -> [a] -> [a]
++ [(Text, Value)]
yvs)
      (Either [Value] [(Text, Value)], Either [Value] [(Text, Value)])
_                      -> String -> Either [Value] [(Text, Value)]
forall a. HasCallStack => String -> a
error String
"The impossible happened: product of mixed label and non-label fields in GJSON instance for (:*:)."
instance (GfromJson f, GfromJson g) => GfromJson (f :*: g) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser ((:*:) f g a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm =
    do Bool -> StateT [Value] Parser () -> StateT [Value] Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
smf StateT [Value] Parser ()
selFields
       f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f a -> g a -> (:*:) f g a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser (g a -> (:*:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
True Bool
enm StateT [Value] Parser (g a -> (:*:) f g a)
-> StateT [Value] Parser (g a)
-> StateT [Value] Parser ((:*:) f g a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (g a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
True Bool
enm
    where
      selFields :: StateT [Value] Parser ()
selFields =
        do Value
v <- StateT [Value] Parser Value
pop
           case Value
v of
             o :: Value
o@Object{} -> [Value] -> StateT [Value] Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Value -> [Value]
forall a. a -> [a]
repeat Value
o)
             Array Array
vs   -> [Value] -> StateT [Value] Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
vs)
             Value
_          -> String -> StateT [Value] Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected object or array in gparseJSONf for (:*:)."

instance GtoJson f => GtoJson (M1 D c f) where
  gtoJSONf :: Settings
-> Bool -> Bool -> M1 D c f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
a Bool
b (M1 f a
x) = Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
a Bool
b f a
x
instance GfromJson f => GfromJson (M1 D c f) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser (M1 D c f a)
gparseJSONf Settings
set Bool
a Bool
b Bool
x = f a -> M1 D c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 D c f a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser (M1 D c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
a Bool
b Bool
x

instance (Constructor c, GtoJson f) => GtoJson (M1 C c f) where
  gtoJSONf :: Settings
-> Bool -> Bool -> M1 C c f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
_  Bool
True  (M1 f a
_) = [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Settings -> M1 C c f Any -> Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (c :: Meta)
       (f :: * -> *) p.
Constructor c =>
Settings -> t i c f p -> Text
conNameT Settings
set (forall p. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p)]
  gtoJSONf Settings
set Bool
mc Bool
False (M1 f a
x) =
    case Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
False f a
x of
      -- Single field constructors are not wrapped in an array.
      Left  [Value
v] -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Value -> Value
wrap Value
v]
      Left  [Value]
vs  -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Value -> Value
wrap (Value -> Value) -> (Array -> Value) -> Array -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Value] -> Array
forall a. [a] -> Vector a
V.fromList [Value]
vs]
      Right [(Text, Value)]
vs  -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Value -> Value
wrap (Value -> Value) -> Value -> Value
forall a b. (a -> b) -> a -> b
$ [(Text, Value)] -> Value
forall v. ToJSON v => [(Text, v)] -> Value
toObject [(Text, Value)]
vs]
    where
      wrap :: Value -> Value
wrap = if Bool
mc
             then [(Text, Value)] -> Value
forall v. ToJSON v => [(Text, v)] -> Value
toObject
                ([(Text, Value)] -> Value)
-> (Value -> [(Text, Value)]) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Value) -> [(Text, Value)]
forall (m :: * -> *) a. Monad m => a -> m a
return
                ((Text, Value) -> [(Text, Value)])
-> (Value -> (Text, Value)) -> Value -> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Settings -> M1 C c f Any -> Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (c :: Meta)
       (f :: * -> *) p.
Constructor c =>
Settings -> t i c f p -> Text
conNameT Settings
set (forall p. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p), )
             else Value -> Value
forall a. a -> a
id
instance (Constructor c, GfromJson f) => GfromJson (M1 C c f) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser (M1 C c f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
True =
    do Value
str    <- StateT [Value] Parser Value
pop
       Text
conStr <- Parser Text -> StateT [Value] Parser Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON Value
str)
       let expectedConStr :: Text
expectedConStr = Settings -> M1 C c f Any -> Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (c :: Meta)
       (f :: * -> *) p.
Constructor c =>
Settings -> t i c f p -> Text
conNameT Settings
set (forall p. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p)
       Bool -> StateT [Value] Parser () -> StateT [Value] Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
conStr Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expectedConStr) (StateT [Value] Parser () -> StateT [Value] Parser ())
-> StateT [Value] Parser () -> StateT [Value] Parser ()
forall a b. (a -> b) -> a -> b
$
         String -> StateT [Value] Parser ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT [Value] Parser ())
-> String -> StateT [Value] Parser ()
forall a b. (a -> b) -> a -> b
$ String
"Error parsing enumeration: expected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
expectedConStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
conStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
       f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
True
  gparseJSONf Settings
set Bool
mc Bool
smf Bool
False =
    do
       Bool -> StateT [Value] Parser () -> StateT [Value] Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
mc (Text -> Maybe Text -> StateT [Value] Parser ()
selProp Text
"C" Maybe Text
propName)
       f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 C c f a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
False
    where
      propName :: Maybe Text
propName = case Settings -> M1 C c f Any -> Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (c :: Meta)
       (f :: * -> *) p.
Constructor c =>
Settings -> t i c f p -> Text
conNameT Settings
set (forall p. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p) of
        Text
"" -> Maybe Text
forall a. Maybe a
Nothing
        Text
n  -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
n

instance (Selector c, GtoJson f) => GtoJson (M1 S c f) where
  gtoJSONf :: Settings
-> Bool -> Bool -> M1 S c f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm (M1 f a
x) =
    case Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm f a
x of
      Left  [Value
v] -> case Settings -> M1 S c f Any -> Maybe Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p.
Selector s =>
Settings -> t i s f p -> Maybe Text
selNameT Settings
set (forall p. M1 S c f p
forall a. HasCallStack => a
undefined :: M1 S c f p) of
        Maybe Text
Nothing -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Value
v]
        Just Text
n  -> [(Text, Value)] -> Either [Value] [(Text, Value)]
forall a b. b -> Either a b
Right [(Text
n, Value
v)]
      Left  [Value]
_   -> String -> Either [Value] [(Text, Value)]
forall a. HasCallStack => String -> a
error String
"The impossible happened: multiple returned values inside label in GJSON instance for S."
      Right [(Text, Value)]
_   -> String -> Either [Value] [(Text, Value)]
forall a. HasCallStack => String -> a
error String
"The impossible happened: label inside a label in GJSON instance for S."
instance (Selector c, GfromJson f) => GfromJson (M1 S c f) where
  gparseJSONf :: Settings
-> Bool -> Bool -> Bool -> StateT [Value] Parser (M1 S c f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm =
    do Text -> Maybe Text -> StateT [Value] Parser ()
selProp Text
"S" Maybe Text
propName
       f a -> M1 S c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S c f a)
-> StateT [Value] Parser (f a)
-> StateT [Value] Parser (M1 S c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm
    where
      propName :: Maybe Text
propName = Settings -> M1 S c f Any -> Maybe Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p.
Selector s =>
Settings -> t i s f p -> Maybe Text
selNameT Settings
set (forall p. M1 S c f p
forall a. HasCallStack => a
undefined :: M1 S c f p)

#if __GLASGOW_HASKELL__ >= 710
instance {-# OVERLAPPING #-} (Selector c, ToJSON a) => GtoJson (M1 S c (K1 i (Maybe a))) where
#else
instance (Selector c, ToJSON a) => GtoJson (M1 S c (K1 i (Maybe a))) where
#endif
  gtoJSONf :: Settings
-> Bool
-> Bool
-> M1 S c (K1 i (Maybe a)) a
-> Either [Value] [(Text, Value)]
gtoJSONf Settings
set   Bool
_  Bool
_   (M1 (K1 n :: Maybe a
n@Maybe a
Nothing)) = case Settings -> M1 S c Any Any -> Maybe Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p.
Selector s =>
Settings -> t i s f p -> Maybe Text
selNameT Settings
set (forall a. HasCallStack => a
forall (f :: * -> *) p. M1 S c f p
undefined :: M1 S c f p) of
    Maybe Text
Nothing -> [Value] -> Either [Value] [(Text, Value)]
forall a b. a -> Either a b
Left [Maybe a -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe a
n]
    Just Text
_  -> [(Text, Value)] -> Either [Value] [(Text, Value)]
forall a b. b -> Either a b
Right []
  gtoJSONf Settings
set Bool
mc Bool
enm (M1 (K1 (Just a
x))) = Settings
-> Bool
-> Bool
-> M1 S c (K1 i a) Any
-> Either [Value] [(Text, Value)]
forall (f :: * -> *) a.
GtoJson f =>
Settings -> Bool -> Bool -> f a -> Either [Value] [(Text, Value)]
gtoJSONf Settings
set Bool
mc Bool
enm (K1 i a p -> M1 S c (K1 i a) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 a
x) :: (M1 S c (K1 i a)) p)

#if __GLASGOW_HASKELL__ >= 710
instance {-# OVERLAPPING #-} (Selector c, FromJSON a) => GfromJson (M1 S c (K1 i (Maybe a))) where
#else
instance (Selector c, FromJSON a) => GfromJson (M1 S c (K1 i (Maybe a))) where
#endif
  gparseJSONf :: Settings
-> Bool
-> Bool
-> Bool
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm =
    do M1 (K1 a
x) <- StateT [Value] Parser (M1 S c (K1 i a) Any)
forall p. StateT [Value] Parser (M1 S c (K1 i a) p)
parser
       M1 S c (K1 i (Maybe a)) a
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe a -> K1 i (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 (a -> Maybe a
forall a. a -> Maybe a
Just a
x)))
    StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    do case Settings -> M1 S c (K1 i a) Any -> Maybe Text
forall (t :: * -> Meta -> (* -> *) -> * -> *) i (s :: Meta)
       (f :: * -> *) p.
Selector s =>
Settings -> t i s f p -> Maybe Text
selNameT Settings
set (forall p. M1 S c (K1 i a) p
forall a. HasCallStack => a
undefined :: M1 S c (K1 i a) p) of
         Maybe Text
Nothing ->
           do Value
o <- StateT [Value] Parser Value
pop
              K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a)
-> (Maybe a -> K1 i (Maybe a) a)
-> Maybe a
-> M1 S c (K1 i (Maybe a)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> K1 i (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe a -> M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (Maybe a)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe a) -> StateT [Value] Parser (Maybe a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Value -> Parser (Maybe a)
forall a. FromJSON a => Value -> Parser a
parseJSON Value
o)
         Just Text
n  ->
           do Value
o <- StateT [Value] Parser Value
pop
              case Value
o of
                Object Object
h | Text -> Object -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
H.member Text
n Object
h -> String -> M1 S c (K1 i a) Any -> M1 S c (K1 i (Maybe a)) a
forall a. HasCallStack => String -> a
error String
impossible (M1 S c (K1 i a) Any -> M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (M1 S c (K1 i a) Any)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT [Value] Parser (M1 S c (K1 i a) Any)
forall p. StateT [Value] Parser (M1 S c (K1 i a) p)
parser
                         | Bool
otherwise    -> M1 S c (K1 i (Maybe a)) a
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (M1 S c (K1 i (Maybe a)) a
 -> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a))
-> M1 S c (K1 i (Maybe a)) a
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall a b. (a -> b) -> a -> b
$ K1 i (Maybe a) a -> M1 S c (K1 i (Maybe a)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Maybe a -> K1 i (Maybe a) a
forall k i c (p :: k). c -> K1 i c p
K1 Maybe a
forall a. Maybe a
Nothing)
                Value
_ -> Parser (M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Parser (M1 S c (K1 i (Maybe a)) a)
 -> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a))
-> Parser (M1 S c (K1 i (Maybe a)) a)
-> StateT [Value] Parser (M1 S c (K1 i (Maybe a)) a)
forall a b. (a -> b) -> a -> b
$ String -> Value -> Parser (M1 S c (K1 i (Maybe a)) a)
forall a. String -> Value -> Parser a
typeMismatch String
"Object" (Array -> Value
Array Array
forall a. Vector a
V.empty)
    where
      parser :: StateT [Value] Parser (M1 S c (K1 i a) p)
parser = Settings
-> Bool
-> Bool
-> Bool
-> StateT [Value] Parser (M1 S c (K1 i a) p)
forall (f :: * -> *) a.
GfromJson f =>
Settings -> Bool -> Bool -> Bool -> StateT [Value] Parser (f a)
gparseJSONf Settings
set Bool
mc Bool
smf Bool
enm :: StateT [Value] Parser (M1 S c (K1 i a) p)
      impossible :: String
impossible = String
"The impossible happened: parser succeeded after failing in GfromJson S Maybe"

selProp :: Text -> Maybe Text -> StateT [Value] Parser ()
selProp :: Text -> Maybe Text -> StateT [Value] Parser ()
selProp Text
cname Maybe Text
propName =
  case Maybe Text
propName of
    Maybe Text
Nothing -> do Value
o <- StateT [Value] Parser Value
pop
                  ([Value] -> [Value]) -> StateT [Value] Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Value
oValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)
    Just Text
p  -> do Value
o <- StateT [Value] Parser Value
pop
                  Value
v <- Parser Value -> StateT [Value] Parser Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> (Object -> Parser Value) -> Value -> Parser Value
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (String
"Expected property " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Text -> String
forall a. Show a => a -> String
show Maybe Text
propName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in object in gparseJSONf for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".")
                                        (Object -> Text -> Parser Value
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
p) Value
o)
                  ([Value] -> [Value]) -> StateT [Value] Parser ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Value
vValue -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:)

pop :: StateT [Value] Parser Value
pop :: StateT [Value] Parser Value
pop =
  do (Value
v:[Value]
vs) <- StateT [Value] Parser [Value]
forall s (m :: * -> *). MonadState s m => m s
get
     [Value] -> StateT [Value] Parser ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put [Value]
vs
     Value -> StateT [Value] Parser Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

toObject :: ToJSON v => [(Text, v)] -> Value
toObject :: [(Text, v)] -> Value
toObject = [(Text, Value)] -> Value
object ([(Text, Value)] -> Value)
-> ([(Text, v)] -> [(Text, Value)]) -> [(Text, v)] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, v) -> (Text, Value)) -> [(Text, v)] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> v -> (Text, Value)) -> (Text, v) -> (Text, Value)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> v -> (Text, Value)
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
(.=))