{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Parse JSON using finally-tagless style.
--
-- This provides JSON parsing as an abstract interface.
-- This interface provides a way to parse JSON that is *inspectable*
-- and has some nice properties: for example, we can use it to build a parser that
-- directly parses your data structure, without building some intermediate value type!
module Jordan.FromJSON.Class where

import Control.Applicative (Alternative (..))
import Data.Coerce
import Data.Functor (($>))
import qualified Data.Int as I
import Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import qualified Data.Monoid as Monoid
import Data.Proxy (Proxy (..))
import qualified Data.Ratio as Ratio
import Data.Scientific (Scientific)
import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Read as TR
import Data.Typeable
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)
import Jordan.Generic.Options

-- | A class for parsing JSON objects.
class (Applicative f, Representational f) => JSONObjectParser f where
  -- | Parse an object field with a given label, using a parser.
  --
  -- Note: in order to enable the generation of better documentation, use 'parseField' instead if at all possible!
  parseFieldWith ::
    -- | Label of the field.
    -- Will be parsed into escaped text, if need be.
    T.Text ->
    -- | How to parse the field.
    -- Note the forall in this type signature: you cannot have this be specific to
    -- any particular implementation of parsing, to keep the parsing of a JSON abstract.
    (forall valueParser. JSONParser valueParser => valueParser a) ->
    f a

  parseDescribeFieldWith ::
    -- | Field key to parse
    T.Text ->
    -- | Description of the field
    T.Text ->
    -- | Parser for the field
    (forall valueParser. JSONParser valueParser => valueParser a) ->
    f a
  parseDescribeFieldWith Text
field Text
_ = Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseFieldWith Text
field
  parseField ::
    (FromJSON v) =>
    T.Text ->
    f v
  parseField Text
t = Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser v)
-> f v
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseFieldWith Text
t forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (valueParser :: * -> *).
JSONParser valueParser =>
valueParser v
fromJSON
  {-# INLINE parseField #-}
  parseDescribeField ::
    (FromJSON v) =>
    T.Text ->
    T.Text ->
    f v
  parseDescribeField Text
key Text
desc = Text
-> Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser v)
-> f v
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseDescribeFieldWith Text
key Text
desc forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (valueParser :: * -> *).
JSONParser valueParser =>
valueParser v
fromJSON
  parseFieldWithDefault ::
    -- | Label of the field.
    T.Text ->
    -- | Parse the value from the field
    (forall valueParser. JSONParser valueParser => valueParser a) ->
    -- | Default value for the field
    a ->
    -- | Field in the object.
    f a
  parseDescribeFieldWithDefault ::
    -- | Label of the field
    T.Text ->
    -- | Description of the field
    T.Text ->
    -- | Parser for the field
    (forall valueParser. JSONParser valueParser => valueParser a) ->
    a ->
    f a
  parseDescribeFieldWithDefault Text
field Text
_ = Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> a
-> f a
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> a
-> f a
parseFieldWithDefault Text
field

-- | A class for parsing JSON arrays.
class (Applicative f, Representational f) => JSONTupleParser f where
  -- | Use a JSON parser to consume a single item of an array, then move onto the next one.
  --
  -- Note: you should prefer 'consumeItem' as it enables better documentation generation.
  consumeItemWith ::
    (forall valueParser. JSONParser valueParser => valueParser a) ->
    f a

  -- | Consume a single array item.
  consumeItem ::
    (FromJSON v) =>
    f v
  consumeItem = (forall (valueParser :: * -> *).
 JSONParser valueParser =>
 valueParser v)
-> f v
forall (f :: * -> *) a.
JSONTupleParser f =>
(forall (valueParser :: * -> *).
 JSONParser valueParser =>
 valueParser a)
-> f a
consumeItemWith forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (valueParser :: * -> *).
JSONParser valueParser =>
valueParser v
fromJSON

-- | Abstract class representing various parsers.
--
-- All parsers must have a Monoid instance that represents choice with failure as the identity.
class (Functor f, forall a. Semigroup (f a), Representational f) => JSONParser f where
  parseObject ::
    -- | Instructions on how to parse the object.
    -- Note that the actual implementation is kept abstract: you can only use methods found in JSONObjectParser, or
    -- combinators of those methods.
    -- This ensures that we can generate the proper parser in all cases.
    (forall objectParser. JSONObjectParser objectParser => objectParser a) ->
    f a

  -- | Parse an object where you are okay if we parse strictly, IE, do not allow extra fields.
  -- This sometimes enables us to generate parsers that run faster.
  parseObjectStrict ::
    (forall objectParser. JSONObjectParser objectParser => objectParser a) ->
    f a
  parseObjectStrict = (forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
forall (f :: * -> *) a.
JSONParser f =>
(forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
parseObject

  -- | Parse a dictionary of key-value pairs.
  parseDictionary ::
    (forall jsonParser. JSONParser jsonParser => jsonParser a) ->
    f [(T.Text, a)]

  -- | Parse a text field.
  parseText ::
    f T.Text

  parseTextConstant ::
    T.Text ->
    f ()
  parseTextConstant Text
t = f (Either Text ()) -> f ()
forall (f :: * -> *) a. JSONParser f => f (Either Text a) -> f a
validateJSON (Text -> Either Text ()
validated (Text -> Either Text ()) -> f Text -> f (Either Text ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Text
forall (f :: * -> *). JSONParser f => f Text
parseText)
    where
      validated :: Text -> Either Text ()
validated Text
q
        | Text
q Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t = () -> Either Text ()
forall a b. b -> Either a b
Right ()
        | Bool
otherwise = Text -> Either Text ()
forall a b. a -> Either a b
Left (Text -> Either Text ()) -> Text -> Either Text ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"Expected :" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
q

  -- | Use a tuple parser to parse an array.
  parseTuple ::
    (forall arrayParser. JSONTupleParser arrayParser => arrayParser o) ->
    f o

  parseArray ::
    (FromJSON a) =>
    f [a]
  parseArray = (forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [a]
forall (f :: * -> *) a.
JSONParser f =>
(forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [a]
parseArrayWith forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (jsonParser :: * -> *).
JSONParser jsonParser =>
jsonParser a
fromJSON
  parseArrayWith ::
    (forall jsonParser. JSONParser jsonParser => jsonParser a) ->
    f [a]
  parseNumber ::
    f Scientific
  parseInteger ::
    f Integer
  parseInteger = Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Scientific -> Integer) -> f Scientific -> f Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber
  parseNull ::
    f ()
  parseBool ::
    f Bool
  validateJSON ::
    f (Either T.Text a) ->
    f a

  -- | Give a parser a unique name.
  -- May be used for documentation.
  nameParser ::
    T.Text ->
    f a ->
    f a
  nameParser Text
_ f a
a = f a
a

  -- | Add information about the format of a particular parser.
  addFormat ::
    T.Text ->
    f a ->
    f a
  addFormat Text
_ f a
a = f a
a

-- | A class to provide the canonical way to parse a JSON.
-- This class uses finally tagless tyle to keep the instructions for parsing abstract.
-- This allows us to automatically generate documentation, and to generate parsers that do not use intermediate structures.
--
-- This class is derivable generically, and will generate a \"nice\" format.
-- In my opinion, at least.
--
-- If you want to customize this JSON, the newtype 'WithOptions' can be helpful, as it allows you to specify options for the generic serialization.
-- Unfortunately, due to a weird GHC quirk, you need to use it with @ -XStandaloneDeriving @ as well as @ -XDerivingVia @.
-- That is, you should write:
--
--
-- @
-- data PersonFilter = PersonFilter { filterFirstName :: Maybe Text, filterLastName :: Maybe Text }
--   deriving (Show, Read, Eq, Ord, Generic)
--
-- deriving via (WithOptions '[KeepNothingFields] PersonFilter) instance (FromJSON PersonFilter)
-- @
--
-- === __Laws__
--
-- This instance is lawless, unless 'Jordan.ToJSON.Class.ToJSON' is also defined for this type.
-- In that case, the representation parsed by 'FromJSON' should match that of the representation serialized by
-- 'Jordan.ToJSON.Class.ToJSON'.
class FromJSON value where
  fromJSON :: (JSONParser f) => f value
  {-# INLINE fromJSON #-}
  default fromJSON :: (Generic value, GFromJSON (Rep value), Typeable value) => (JSONParser f => f value)
  fromJSON = Rep value Any -> value
forall a x. Generic a => Rep a x -> a
to (Rep value Any -> value) -> f (Rep value Any) -> f value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (Rep value Any)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON @(Rep value) FromJSONOptions
defaultOptions {fromJSONBaseName :: String
fromJSONBaseName = String
bn}
    where
      bn :: String
bn = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
fullyQualifyName (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Proxy value -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy value
forall k (t :: k). Proxy t
Proxy :: Proxy value)

instance (Generic a, GFromJSON (Rep a), Typeable a, SpecifiesFromJSONOptions options) => FromJSON (WithOptions options a) where
  fromJSON :: f (WithOptions options a)
fromJSON = a -> WithOptions options a
forall (options :: [*]) a. a -> WithOptions options a
WithOptions (a -> WithOptions options a)
-> (Rep a Any -> a) -> Rep a Any -> WithOptions options a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> WithOptions options a)
-> f (Rep a Any) -> f (WithOptions options a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (Rep a Any)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON @(Rep a) (SpecifiesFromJSONOptions options => FromJSONOptions
forall (a :: [*]). SpecifiesFromJSONOptions a => FromJSONOptions
specifiedFromJSONOptions @options) {fromJSONBaseName :: String
fromJSONBaseName = String
bn}
    where
      bn :: String
bn = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> Text
fullyQualifyName (TypeRep -> Text) -> TypeRep -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)

instance FromJSON () where
  fromJSON :: f ()
fromJSON = f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull

instance {-# OVERLAPPABLE #-} (FromJSON a) => FromJSON [a] where
  fromJSON :: f [a]
fromJSON = f [a]
forall (f :: * -> *) a. (JSONParser f, FromJSON a) => f [a]
parseArray

instance {-# OVERLAPPING #-} FromJSON String where
  fromJSON :: f String
fromJSON = Text -> String
T.unpack (Text -> String) -> f Text -> f String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Text
forall (f :: * -> *). JSONParser f => f Text
parseText

instance (FromJSON a) => FromJSON (Maybe a) where
  fromJSON :: f (Maybe a)
fromJSON = (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON) f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall a. Semigroup a => a -> a -> a
<> (f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull f () -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe a
forall a. Maybe a
Nothing)

-- | Right-biased: will try to parse a 'Right' value first.
instance (FromJSON l, FromJSON r) => FromJSON (Either l r) where
  fromJSON :: f (Either l r)
fromJSON = (r -> Either l r
forall a b. b -> Either a b
Right (r -> Either l r) -> f r -> f (Either l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f r
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON) f (Either l r) -> f (Either l r) -> f (Either l r)
forall a. Semigroup a => a -> a -> a
<> (l -> Either l r
forall a b. a -> Either a b
Left (l -> Either l r) -> f l -> f (Either l r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f l
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON)

instance (FromJSON Bool) where
  fromJSON :: f Bool
fromJSON = f Bool
forall (f :: * -> *). JSONParser f => f Bool
parseBool

instance FromJSON T.Text where
  fromJSON :: f Text
fromJSON = f Text
forall (f :: * -> *). JSONParser f => f Text
parseText

instance FromJSON Int where
  fromJSON :: f Int
fromJSON = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> f Integer -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Integer
forall (f :: * -> *). JSONParser f => f Integer
parseInteger

instance FromJSON Float where
  fromJSON :: f Float
fromJSON = Text -> f Float -> f Float
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
addFormat Text
"float" (f Float -> f Float) -> f Float -> f Float
forall a b. (a -> b) -> a -> b
$ Scientific -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Scientific -> Float) -> f Scientific -> f Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber

instance FromJSON Double where
  fromJSON :: f Double
fromJSON = Text -> f Double -> f Double
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
addFormat Text
"double" (f Double -> f Double) -> f Double -> f Double
forall a b. (a -> b) -> a -> b
$ Scientific -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Scientific -> Double) -> f Scientific -> f Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber

instance FromJSON I.Int32 where
  fromJSON :: f Int32
fromJSON = Text -> f Int32 -> f Int32
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
addFormat Text
"int32" (f Int32 -> f Int32) -> f Int32 -> f Int32
forall a b. (a -> b) -> a -> b
$ Integer -> Int32
forall a. Num a => Integer -> a
fromInteger (Integer -> Int32) -> f Integer -> f Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Integer
forall (f :: * -> *). JSONParser f => f Integer
parseInteger

instance FromJSON I.Int64 where
  fromJSON :: f Int64
fromJSON = Text -> f Int64 -> f Int64
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
addFormat Text
"int64" (f Int64 -> f Int64) -> f Int64 -> f Int64
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> f Integer -> f Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Integer
forall (f :: * -> *). JSONParser f => f Integer
parseInteger

instance FromJSON Integer where
  fromJSON :: f Integer
fromJSON = f Integer
forall (f :: * -> *). JSONParser f => f Integer
parseInteger

instance FromJSON Scientific where
  fromJSON :: f Scientific
fromJSON = f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber

instance forall a. (Integral a, FromJSON a) => FromJSON (Ratio.Ratio a) where
  fromJSON :: f (Ratio a)
fromJSON =
    (forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser (Ratio a))
-> f (Ratio a)
forall (f :: * -> *) a.
JSONParser f =>
(forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
parseObject ((forall (objectParser :: * -> *).
  JSONObjectParser objectParser =>
  objectParser (Ratio a))
 -> f (Ratio a))
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (Ratio a))
-> f (Ratio a)
forall a b. (a -> b) -> a -> b
$
      a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
(Ratio.%)
        (a -> a -> Ratio a)
-> objectParser a -> objectParser (a -> Ratio a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> objectParser a
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> Text -> f v
parseDescribeField Text
"num" Text
"numerator of the ratio"
        objectParser (a -> Ratio a)
-> objectParser a -> objectParser (Ratio a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> Text -> objectParser a
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> Text -> f v
parseDescribeField Text
"denom" Text
"denominator of the ratio"

instance FromJSON a => FromJSON (Monoid.Dual a) where
  fromJSON :: f (Dual a)
fromJSON = a -> Dual a
forall a. a -> Dual a
Monoid.Dual (a -> Dual a) -> f a -> f (Dual a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON Monoid.All where
  fromJSON :: f All
fromJSON = Bool -> All
Monoid.All (Bool -> All) -> f Bool -> f All
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Bool
forall (f :: * -> *). JSONParser f => f Bool
parseBool

instance FromJSON Monoid.Any where
  fromJSON :: f Any
fromJSON = Bool -> Any
Monoid.Any (Bool -> Any) -> f Bool -> f Any
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Bool
forall (f :: * -> *). JSONParser f => f Bool
parseBool

instance FromJSON a => FromJSON (Monoid.Sum a) where
  fromJSON :: f (Sum a)
fromJSON = a -> Sum a
forall a. a -> Sum a
Monoid.Sum (a -> Sum a) -> f a -> f (Sum a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Monoid.Product a) where
  fromJSON :: f (Product a)
fromJSON = a -> Product a
forall a. a -> Product a
Monoid.Product (a -> Product a) -> f a -> f (Product a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Monoid.First a) where
  fromJSON :: f (First a)
fromJSON = Maybe a -> First a
forall a. Maybe a -> First a
Monoid.First (Maybe a -> First a) -> f (Maybe a) -> f (First a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull f () -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe a
forall a. Maybe a
Nothing) f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall a. Semigroup a => a -> a -> a
<> (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON))

instance FromJSON a => FromJSON (Monoid.Last a) where
  fromJSON :: f (Last a)
fromJSON = Maybe a -> Last a
forall a. Maybe a -> Last a
Monoid.Last (Maybe a -> Last a) -> f (Maybe a) -> f (Last a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull f () -> Maybe a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe a
forall a. Maybe a
Nothing) f (Maybe a) -> f (Maybe a) -> f (Maybe a)
forall a. Semigroup a => a -> a -> a
<> (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON))

instance FromJSON (f a) => FromJSON (Monoid.Alt f a) where
  fromJSON :: f (Alt f a)
fromJSON = f a -> Alt f a
forall k (f :: k -> *) (a :: k). f a -> Alt f a
Monoid.Alt (f a -> Alt f a) -> f (f a) -> f (Alt f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f a)
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON (f a) => FromJSON (Monoid.Ap f a) where
  fromJSON :: f (Ap f a)
fromJSON = f a -> Ap f a
forall k (f :: k -> *) (a :: k). f a -> Ap f a
Monoid.Ap (f a -> Ap f a) -> f (f a) -> f (Ap f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f a)
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Semigroup.Min a) where
  fromJSON :: f (Min a)
fromJSON = a -> Min a
forall a. a -> Min a
Semigroup.Min (a -> Min a) -> f a -> f (Min a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Semigroup.Max a) where
  fromJSON :: f (Max a)
fromJSON = a -> Max a
forall a. a -> Max a
Semigroup.Max (a -> Max a) -> f a -> f (Max a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Semigroup.First a) where
  fromJSON :: f (First a)
fromJSON = a -> First a
forall a. a -> First a
Semigroup.First (a -> First a) -> f a -> f (First a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Semigroup.Last a) where
  fromJSON :: f (Last a)
fromJSON = a -> Last a
forall a. a -> Last a
Semigroup.Last (a -> Last a) -> f a -> f (Last a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

-- containers package
instance (FromJSON a, Ord a) => FromJSON (Set.Set a) where
  fromJSON :: f (Set a)
fromJSON = [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList ([a] -> Set a) -> f [a] -> f (Set a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f [a]
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance FromJSON a => FromJSON (Map.Map T.Text a) where
  fromJSON :: f (Map Text a)
fromJSON = ((Text, a) -> Map Text a) -> [(Text, a)] -> Map Text a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Text -> a -> Map Text a) -> (Text, a) -> Map Text a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> a -> Map Text a
forall k a. k -> a -> Map k a
Map.singleton) ([(Text, a)] -> Map Text a) -> f [(Text, a)] -> f (Map Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [(Text, a)]
forall (f :: * -> *) a.
JSONParser f =>
(forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [(Text, a)]
parseDictionary forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (jsonParser :: * -> *).
JSONParser jsonParser =>
jsonParser a
fromJSON

instance FromJSON a => FromJSON (Map.Map Integer a) where
  fromJSON :: f (Map Integer a)
fromJSON = ((Text, a) -> Map Integer a) -> [(Text, a)] -> Map Integer a
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text, a) -> Map Integer a
forall k a. Integral k => (Text, a) -> Map k a
toSingleDict ([(Text, a)] -> Map Integer a)
-> f [(Text, a)] -> f (Map Integer a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [(Text, a)]
forall (f :: * -> *) a.
JSONParser f =>
(forall (jsonParser :: * -> *).
 JSONParser jsonParser =>
 jsonParser a)
-> f [(Text, a)]
parseDictionary forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
forall (jsonParser :: * -> *).
JSONParser jsonParser =>
jsonParser a
fromJSON
    where
      toSingleDict :: (Text, a) -> Map k a
toSingleDict (Text
k, a
v) = case Reader k -> Reader k
forall a. Num a => Reader a -> Reader a
TR.signed Reader k
forall a. Integral a => Reader a
TR.decimal Text
k of
        Left String
s -> Map k a
forall a. Monoid a => a
mempty
        Right (k
i, Text
rest) -> if Text
rest Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
forall a. Monoid a => a
mempty then k -> a -> Map k a
forall k a. k -> a -> Map k a
Map.singleton k
i a
v else Map k a
forall a. Monoid a => a
mempty

instance (FromJSON a) => FromJSON (NE.NonEmpty a) where
  fromJSON :: f (NonEmpty a)
fromJSON = f (Either Text (NonEmpty a)) -> f (NonEmpty a)
forall (f :: * -> *) a. JSONParser f => f (Either Text a) -> f a
validateJSON (f (Either Text (NonEmpty a)) -> f (NonEmpty a))
-> f (Either Text (NonEmpty a)) -> f (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ ([a] -> Either Text (NonEmpty a))
-> f [a] -> f (Either Text (NonEmpty a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Either Text (NonEmpty a)
forall a a. IsString a => [a] -> Either a (NonEmpty a)
toNonEmpty f [a]
forall (f :: * -> *) a. (JSONParser f, FromJSON a) => f [a]
parseArray
    where
      toNonEmpty :: [a] -> Either a (NonEmpty a)
toNonEmpty [a]
a = case [a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
a of
        Maybe (NonEmpty a)
Nothing -> a -> Either a (NonEmpty a)
forall a b. a -> Either a b
Left a
"Empty list"
        Just NonEmpty a
a -> NonEmpty a -> Either a (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NonEmpty a
a

data FromJSONOptions = FromJSONOptions
  { FromJSONOptions -> SumTypeEncoding
fromJSONEncodeSums :: SumTypeEncoding,
    FromJSONOptions -> String
fromJSONBaseName :: String,
    FromJSONOptions -> String -> String
convertEnum :: String -> String,
    FromJSONOptions -> Bool
fromJSONOmitNothingFields :: Bool
  }
  deriving ((forall x. FromJSONOptions -> Rep FromJSONOptions x)
-> (forall x. Rep FromJSONOptions x -> FromJSONOptions)
-> Generic FromJSONOptions
forall x. Rep FromJSONOptions x -> FromJSONOptions
forall x. FromJSONOptions -> Rep FromJSONOptions x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FromJSONOptions x -> FromJSONOptions
$cfrom :: forall x. FromJSONOptions -> Rep FromJSONOptions x
Generic)

defaultOptions :: FromJSONOptions
defaultOptions :: FromJSONOptions
defaultOptions = SumTypeEncoding
-> String -> (String -> String) -> Bool -> FromJSONOptions
FromJSONOptions SumTypeEncoding
TagInField String
"" String -> String
forall a. a -> a
id Bool
True

class SpecifiesFromJSONOptions (a :: [*]) where
  specifiedFromJSONOptions :: FromJSONOptions

instance SpecifiesFromJSONOptions '[] where
  specifiedFromJSONOptions :: FromJSONOptions
specifiedFromJSONOptions = FromJSONOptions
defaultOptions

instance
  (SpecifiesFromJSONOptions xs) =>
  SpecifiesFromJSONOptions (OmitNothingFields ': xs)
  where
  specifiedFromJSONOptions :: FromJSONOptions
specifiedFromJSONOptions = (SpecifiesFromJSONOptions xs => FromJSONOptions
forall (a :: [*]). SpecifiesFromJSONOptions a => FromJSONOptions
specifiedFromJSONOptions @xs) {fromJSONOmitNothingFields :: Bool
fromJSONOmitNothingFields = Bool
True}

instance
  (SpecifiesFromJSONOptions xs) =>
  SpecifiesFromJSONOptions (KeepNothingFields ': xs)
  where
  specifiedFromJSONOptions :: FromJSONOptions
specifiedFromJSONOptions =
    (SpecifiesFromJSONOptions xs => FromJSONOptions
forall (a :: [*]). SpecifiesFromJSONOptions a => FromJSONOptions
specifiedFromJSONOptions @xs) {fromJSONOmitNothingFields :: Bool
fromJSONOmitNothingFields = Bool
False}

addName :: String -> FromJSONOptions -> FromJSONOptions
addName :: String -> FromJSONOptions -> FromJSONOptions
addName String
s FromJSONOptions
d = FromJSONOptions
d {fromJSONBaseName :: String
fromJSONBaseName = FromJSONOptions -> String
fromJSONBaseName FromJSONOptions
d String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s}

class GFromJSON v where
  gFromJSON :: (JSONParser f) => FromJSONOptions -> f (v a)

-- | Top-level metadata is ignored.
instance (FromJSON c) => GFromJSON (K1 i c) where
  gFromJSON :: FromJSONOptions -> f (K1 i c a)
gFromJSON FromJSONOptions
_ = c -> K1 i c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> K1 i c a) -> f c -> f (K1 i c a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f c
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

-- | Datatype metadata: we name the overall datatype with the baseName
-- provided in the options, then serialize the inner information.
instance (GFromJSON f, Datatype t) => GFromJSON (D1 t f) where
  gFromJSON :: FromJSONOptions -> f (D1 t f a)
gFromJSON FromJSONOptions
opts = Text -> f (D1 t f a) -> f (D1 t f a)
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
nameParser (String -> Text
T.pack (FromJSONOptions -> String
fromJSONBaseName FromJSONOptions
opts)) (f (D1 t f a) -> f (D1 t f a)) -> f (D1 t f a) -> f (D1 t f a)
forall a b. (a -> b) -> a -> b
$ f a -> D1 t f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> D1 t f a) -> f (f a) -> f (D1 t f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (f a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts

-- | If we have a constructor with arguments, and those arguments
-- do not have selectors (IE, this is not a record), then we should parse as a tuple.
instance
  {-# OVERLAPPABLE #-}
  (GFromJSONTuple inner, KnownSymbol n) =>
  GFromJSON (C1 (MetaCons n s 'False) inner)
  where
  gFromJSON :: FromJSONOptions -> f (C1 ('MetaCons n s 'False) inner a)
gFromJSON FromJSONOptions
opts = Text
-> f (C1 ('MetaCons n s 'False) inner a)
-> f (C1 ('MetaCons n s 'False) inner a)
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
nameParser Text
objName (f (C1 ('MetaCons n s 'False) inner a)
 -> f (C1 ('MetaCons n s 'False) inner a))
-> f (C1 ('MetaCons n s 'False) inner a)
-> f (C1 ('MetaCons n s 'False) inner a)
forall a b. (a -> b) -> a -> b
$ inner a -> C1 ('MetaCons n s 'False) inner a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (inner a -> C1 ('MetaCons n s 'False) inner a)
-> f (inner a) -> f (C1 ('MetaCons n s 'False) inner a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (arrayParser :: * -> *).
 JSONTupleParser arrayParser =>
 arrayParser (inner a))
-> f (inner a)
forall (f :: * -> *) o.
JSONParser f =>
(forall (arrayParser :: * -> *).
 JSONTupleParser arrayParser =>
 arrayParser o)
-> f o
parseTuple (FromJSONOptions -> arrayParser (inner a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONTuple v, JSONTupleParser f) =>
FromJSONOptions -> f (v a)
gFromJSONTuple FromJSONOptions
opts)
    where
      objName :: Text
objName = String -> Text
T.pack (FromJSONOptions -> String
fromJSONBaseName FromJSONOptions
opts) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
conName
      conName :: Text
conName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n)

-- | If we have a constructor with arguments, and those arguments
-- do have selectors (IE, this is a record), then we should parse as a record.
instance {-# OVERLAPS #-} forall c i n s. (GFromJSONObject i, KnownSymbol n) => GFromJSON (C1 (MetaCons n s 'True) i) where
  gFromJSON :: FromJSONOptions -> f (C1 ('MetaCons n s 'True) i a)
gFromJSON FromJSONOptions
opts = i a -> C1 ('MetaCons n s 'True) i a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (i a -> C1 ('MetaCons n s 'True) i a)
-> f (i a) -> f (C1 ('MetaCons n s 'True) i a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f (i a) -> f (i a)
forall (f :: * -> *) a. JSONParser f => Text -> f a -> f a
nameParser (String -> Text
T.pack String
name) ((forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser (i a))
-> f (i a)
forall (f :: * -> *) a.
JSONParser f =>
(forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
parseObject ((forall (objectParser :: * -> *).
  JSONObjectParser objectParser =>
  objectParser (i a))
 -> f (i a))
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (i a))
-> f (i a)
forall a b. (a -> b) -> a -> b
$ FromJSONOptions -> objectParser (i a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONObject v, JSONObjectParser f) =>
FromJSONOptions -> f (v a)
gFromJSONObject FromJSONOptions
opts)
    where
      name :: String
name = FromJSONOptions -> String
fromJSONBaseName FromJSONOptions
opts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)

-- | Special-case: a one-argument constructor with no field selector gets its own parser, skipping the tuple entirely.
instance {-# OVERLAPS #-} (FromJSON inner, KnownSymbol n) => GFromJSON (C1 (MetaCons n s 'False) (S1 (MetaSel Nothing ss su dl) (Rec0 inner))) where
  gFromJSON :: FromJSONOptions
-> f (C1
        ('MetaCons n s 'False)
        (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
        a)
gFromJSON FromJSONOptions
opts =
    M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a
-> C1
     ('MetaCons n s 'False)
     (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
     a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a
 -> C1
      ('MetaCons n s 'False)
      (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
      a)
-> (inner -> M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a)
-> inner
-> C1
     ('MetaCons n s 'False)
     (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R inner a -> M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R inner a -> M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a)
-> (inner -> K1 R inner a)
-> inner
-> M1 S ('MetaSel 'Nothing ss su dl) (Rec0 inner) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. inner -> K1 R inner a
forall k i c (p :: k). c -> K1 i c p
K1
      (inner
 -> C1
      ('MetaCons n s 'False)
      (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
      a)
-> f inner
-> f (C1
        ('MetaCons n s 'False)
        (S1 ('MetaSel 'Nothing ss su dl) (Rec0 inner))
        a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f inner
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON
    where
      connName :: Text
connName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy n -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy n -> String) -> Proxy n -> String
forall a b. (a -> b) -> a -> b
$ Proxy n
forall k (t :: k). Proxy t
Proxy @n

-- | When rendering a sum type, if we have a more complex value (IE, maybe
-- this is a constructor that takes arguments), we want to use whatever
-- sum encoding was provided in the options.
instance {-# OVERLAPPABLE #-} (GFromJSON (C1 t f), Constructor t) => GFromJSON (PartOfSum (C1 t f)) where
  gFromJSON :: FromJSONOptions -> f (PartOfSum (C1 t f) a)
gFromJSON FromJSONOptions
opts = C1 t f a -> PartOfSum (C1 t f) a
forall (f :: * -> *) a. f a -> PartOfSum f a
MkPartOfSum (C1 t f a -> PartOfSum (C1 t f) a)
-> f (C1 t f a) -> f (PartOfSum (C1 t f) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (C1 t f a)
encoded
    where
      encoded :: f (C1 t f a)
encoded = case FromJSONOptions -> SumTypeEncoding
fromJSONEncodeSums FromJSONOptions
opts of
        SumTypeEncoding
TagVal -> f (C1 t f a)
tagged
        SumTypeEncoding
TagInField -> f (C1 t f a)
field
      tagged :: f (C1 t f a)
tagged =
        (forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser (C1 t f a))
-> f (C1 t f a)
forall (f :: * -> *) a.
JSONParser f =>
(forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
parseObject ((forall (objectParser :: * -> *).
  JSONObjectParser objectParser =>
  objectParser (C1 t f a))
 -> f (C1 t f a))
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (C1 t f a))
-> f (C1 t f a)
forall a b. (a -> b) -> a -> b
$
          Text
-> (forall (f :: * -> *). JSONParser f => f ()) -> objectParser ()
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseFieldWith Text
"tag" (Text -> valueParser ()
forall (f :: * -> *). JSONParser f => Text -> f ()
parseTextConstant Text
name)
            objectParser ()
-> objectParser (C1 t f a) -> objectParser (C1 t f a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser (C1 t f a))
-> objectParser (C1 t f a)
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseFieldWith Text
"val" (FromJSONOptions -> valueParser (C1 t f a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts)
      field :: f (C1 t f a)
field =
        (forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser (C1 t f a))
-> f (C1 t f a)
forall (f :: * -> *) a.
JSONParser f =>
(forall (objectParser :: * -> *).
 JSONObjectParser objectParser =>
 objectParser a)
-> f a
parseObject ((forall (objectParser :: * -> *).
  JSONObjectParser objectParser =>
  objectParser (C1 t f a))
 -> f (C1 t f a))
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (C1 t f a))
-> f (C1 t f a)
forall a b. (a -> b) -> a -> b
$
          Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser (C1 t f a))
-> objectParser (C1 t f a)
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> f a
parseFieldWith Text
name (FromJSONOptions -> valueParser (C1 t f a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts)
      name :: Text
name = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 C t f Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall a. M1 C t f a
forall a. HasCallStack => a
undefined :: C1 t f a)
      objName :: Text
objName = String -> Text
T.pack (FromJSONOptions -> String
fromJSONBaseName FromJSONOptions
opts String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name

instance {-# OVERLAPPABLE #-} (KnownSymbol connName) => GFromJSON (C1 (MetaCons connName dontCare 'False) U1) where
  gFromJSON :: FromJSONOptions -> f (C1 ('MetaCons connName dontCare 'False) U1 a)
gFromJSON FromJSONOptions
_ = U1 a -> C1 ('MetaCons connName dontCare 'False) U1 a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 U1 a
forall k (p :: k). U1 p
U1 C1 ('MetaCons connName dontCare 'False) U1 a
-> f () -> f (C1 ('MetaCons connName dontCare 'False) U1 a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> f ()
forall (f :: * -> *). JSONParser f => Text -> f ()
parseTextConstant Text
constName
    where
      constName :: Text
constName = String -> Text
T.pack (Proxy connName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy connName -> String) -> Proxy connName -> String
forall a b. (a -> b) -> a -> b
$ Proxy connName
forall k (t :: k). Proxy t
Proxy @connName)

instance {-# OVERLAPS #-} (KnownSymbol connName) => GFromJSON (PartOfSum (C1 (MetaCons connName dontCare 'False) U1)) where
  gFromJSON :: FromJSONOptions
-> f (PartOfSum (C1 ('MetaCons connName dontCare 'False) U1) a)
gFromJSON FromJSONOptions
opts = C1 ('MetaCons connName dontCare 'False) U1 a
-> PartOfSum (C1 ('MetaCons connName dontCare 'False) U1) a
forall (f :: * -> *) a. f a -> PartOfSum f a
MkPartOfSum (C1 ('MetaCons connName dontCare 'False) U1 a
 -> PartOfSum (C1 ('MetaCons connName dontCare 'False) U1) a)
-> f (C1 ('MetaCons connName dontCare 'False) U1 a)
-> f (PartOfSum (C1 ('MetaCons connName dontCare 'False) U1) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (C1 ('MetaCons connName dontCare 'False) U1 a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts

-- | If we can parse both sides of a sum-type, we can parse the entire sum type.
instance {-# OVERLAPS #-} (GFromJSON (PartOfSum l), GFromJSON (PartOfSum r)) => GFromJSON (l :+: r) where
  gFromJSON :: FromJSONOptions -> f ((:+:) l r a)
gFromJSON FromJSONOptions
opts =
    (l a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l a -> (:+:) l r a)
-> (PartOfSum l a -> l a) -> PartOfSum l a -> (:+:) l r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartOfSum l a -> l a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (PartOfSum l a -> (:+:) l r a)
-> f (PartOfSum l a) -> f ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (PartOfSum l a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts) f ((:+:) l r a) -> f ((:+:) l r a) -> f ((:+:) l r a)
forall a. Semigroup a => a -> a -> a
<> (r a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r a -> (:+:) l r a)
-> (PartOfSum r a -> r a) -> PartOfSum r a -> (:+:) l r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartOfSum r a -> r a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (PartOfSum r a -> (:+:) l r a)
-> f (PartOfSum r a) -> f ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (PartOfSum r a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts)

instance {-# OVERLAPS #-} (GFromJSON (PartOfSum l), GFromJSON (PartOfSum r)) => GFromJSON (PartOfSum (l :+: r)) where
  gFromJSON :: FromJSONOptions -> f (PartOfSum (l :+: r) a)
gFromJSON FromJSONOptions
opts =
    (:+:) l r a -> PartOfSum (l :+: r) a
forall (f :: * -> *) a. f a -> PartOfSum f a
MkPartOfSum
      ((:+:) l r a -> PartOfSum (l :+: r) a)
-> f ((:+:) l r a) -> f (PartOfSum (l :+: r) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (l a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (l a -> (:+:) l r a)
-> (PartOfSum l a -> l a) -> PartOfSum l a -> (:+:) l r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartOfSum l a -> l a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (PartOfSum l a -> (:+:) l r a)
-> f (PartOfSum l a) -> f ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (PartOfSum l a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts) f ((:+:) l r a) -> f ((:+:) l r a) -> f ((:+:) l r a)
forall a. Semigroup a => a -> a -> a
<> (r a -> (:+:) l r a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (r a -> (:+:) l r a)
-> (PartOfSum r a -> r a) -> PartOfSum r a -> (:+:) l r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartOfSum r a -> r a
forall (f :: * -> *) a. PartOfSum f a -> f a
getPartOfSum (PartOfSum r a -> (:+:) l r a)
-> f (PartOfSum r a) -> f ((:+:) l r a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (PartOfSum r a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts)

-- | Class that helps us parse JSON objects.
class GFromJSONObject v where
  gFromJSONObject :: (JSONObjectParser f) => FromJSONOptions -> f (v a)

instance GFromJSONObject U1 where
  gFromJSONObject :: FromJSONOptions -> f (U1 a)
gFromJSONObject FromJSONOptions
_ = U1 a -> f (U1 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 a
forall k (p :: k). U1 p
U1

instance {-# OVERLAPPABLE #-} (FromJSON c, Selector t) => GFromJSONObject (S1 t (K1 v c)) where
  gFromJSONObject :: FromJSONOptions -> f (S1 t (K1 v c) a)
gFromJSONObject FromJSONOptions
o =
    K1 v c a -> S1 t (K1 v c) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 v c a -> S1 t (K1 v c) a)
-> (c -> K1 v c a) -> c -> S1 t (K1 v c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> K1 v c a
forall k i c (p :: k). c -> K1 i c p
K1 (c -> S1 t (K1 v c) a) -> f c -> f (S1 t (K1 v c) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f c
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> f v
parseField (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 S t Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S t Any Any
forall (f :: * -> *) a. M1 S t f a
v)
    where
      v :: M1 S t f a
      v :: M1 S t f a
v = M1 S t f a
forall a. HasCallStack => a
undefined

instance {-# OVERLAPS #-} (FromJSON c, Selector t) => GFromJSONObject (S1 t (K1 v (Maybe c))) where
  gFromJSONObject :: FromJSONOptions -> f (S1 t (K1 v (Maybe c)) a)
gFromJSONObject FromJSONOptions
o =
    K1 v (Maybe c) a -> S1 t (K1 v (Maybe c)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 v (Maybe c) a -> S1 t (K1 v (Maybe c)) a)
-> (Maybe c -> K1 v (Maybe c) a)
-> Maybe c
-> S1 t (K1 v (Maybe c)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe c -> K1 v (Maybe c) a
forall k i c (p :: k). c -> K1 i c p
K1 (Maybe c -> S1 t (K1 v (Maybe c)) a)
-> f (Maybe c) -> f (S1 t (K1 v (Maybe c)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Maybe c)
parse
    where
      parse :: f (Maybe c)
parse
        | FromJSONOptions -> Bool
fromJSONOmitNothingFields FromJSONOptions
o = Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser (Maybe c))
-> Maybe c
-> f (Maybe c)
forall (f :: * -> *) a.
JSONObjectParser f =>
Text
-> (forall (valueParser :: * -> *).
    JSONParser valueParser =>
    valueParser a)
-> a
-> f a
parseFieldWithDefault Text
field ((c -> Maybe c
forall a. a -> Maybe a
Just (c -> Maybe c) -> valueParser c -> valueParser (Maybe c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> valueParser c
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON) valueParser (Maybe c)
-> valueParser (Maybe c) -> valueParser (Maybe c)
forall a. Semigroup a => a -> a -> a
<> (valueParser ()
forall (f :: * -> *). JSONParser f => f ()
parseNull valueParser () -> Maybe c -> valueParser (Maybe c)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe c
forall a. Maybe a
Nothing)) Maybe c
forall a. Maybe a
Nothing
        | Bool
otherwise = Text -> f (Maybe c)
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> f v
parseField Text
field
      field :: Text
field = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 S t Any Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName M1 S t Any Any
forall (f :: * -> *) a. M1 S t f a
v
      v :: M1 S t f a
      v :: M1 S t f a
v = M1 S t f a
forall a. HasCallStack => a
undefined

instance (GFromJSONObject lhs, GFromJSONObject rhs) => GFromJSONObject (lhs :*: rhs) where
  gFromJSONObject :: FromJSONOptions -> f ((:*:) lhs rhs a)
gFromJSONObject FromJSONOptions
o = lhs a -> rhs a -> (:*:) lhs rhs a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (lhs a -> rhs a -> (:*:) lhs rhs a)
-> f (lhs a) -> f (rhs a -> (:*:) lhs rhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (lhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONObject v, JSONObjectParser f) =>
FromJSONOptions -> f (v a)
gFromJSONObject FromJSONOptions
o f (rhs a -> (:*:) lhs rhs a) -> f (rhs a) -> f ((:*:) lhs rhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FromJSONOptions -> f (rhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONObject v, JSONObjectParser f) =>
FromJSONOptions -> f (v a)
gFromJSONObject FromJSONOptions
o

class GFromJSONTuple v where
  gFromJSONTuple :: (JSONTupleParser f) => FromJSONOptions -> f (v a)

instance (GFromJSONTuple lhs, GFromJSONTuple rhs) => GFromJSONTuple (lhs :*: rhs) where
  gFromJSONTuple :: FromJSONOptions -> f ((:*:) lhs rhs a)
gFromJSONTuple FromJSONOptions
o = lhs a -> rhs a -> (:*:) lhs rhs a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (lhs a -> rhs a -> (:*:) lhs rhs a)
-> f (lhs a) -> f (rhs a -> (:*:) lhs rhs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (lhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONTuple v, JSONTupleParser f) =>
FromJSONOptions -> f (v a)
gFromJSONTuple FromJSONOptions
o f (rhs a -> (:*:) lhs rhs a) -> f (rhs a) -> f ((:*:) lhs rhs a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> FromJSONOptions -> f (rhs a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSONTuple v, JSONTupleParser f) =>
FromJSONOptions -> f (v a)
gFromJSONTuple FromJSONOptions
o

instance (GFromJSON f) => GFromJSONTuple (S1 (MetaSel Nothing su ss ds) f) where
  gFromJSONTuple :: FromJSONOptions -> f (S1 ('MetaSel 'Nothing su ss ds) f a)
gFromJSONTuple FromJSONOptions
o = f a -> S1 ('MetaSel 'Nothing su ss ds) f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> S1 ('MetaSel 'Nothing su ss ds) f a)
-> f (f a) -> f (S1 ('MetaSel 'Nothing su ss ds) f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (valueParser :: * -> *).
 JSONParser valueParser =>
 valueParser (f a))
-> f (f a)
forall (f :: * -> *) a.
JSONTupleParser f =>
(forall (valueParser :: * -> *).
 JSONParser valueParser =>
 valueParser a)
-> f a
consumeItemWith (FromJSONOptions -> valueParser (f a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
o)