{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# 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.Functor (($>))
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 Data.Typeable
import GHC.Generics
import Jordan.Generic.Options

-- | A class for parsing JSON objects.
class (Applicative 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
    ::  T.Text
    -- ^ Label of the field.
    -- Will be parsed into escaped text, if need be.
    -> (forall valueParser. JSONParser valueParser => valueParser a)
    -- ^ 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.
    -> f a
  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

-- | A class for parsing JSON arrays.
class (Applicative 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. Monoid (f a)) => JSONParser f where
  parseObject
    :: T.Text
    -- ^ A label for the object.
    -- This label should, as much as possible, be "globally unique" in some way.
    -- This will enable better generation of documentation.
    -> (forall objectParser. JSONObjectParser objectParser => objectParser a)
    -- ^ 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.
    -> 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
    :: T.Text
    -> (forall objectParser. JSONObjectParser objectParser => objectParser a)
    -> f a
  parseObjectStrict = Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser a)
-> f a
forall (f :: * -> *) a.
JSONParser f =>
Text
-> (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
  parseNull
    :: f ()
  parseBool
    :: f Bool
  validateJSON
    :: f (Either T.Text a)
    -> f 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.
class FromJSON value where
  fromJSON :: (JSONParser f) => f value
  default fromJSON :: (Generic value, GFromJSON (Rep 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

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 = (Maybe a
forall a. Maybe a
Nothing Maybe a -> f () -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull) 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)

-- | 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 = (Scientific -> Int) -> f Scientific -> f Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber

instance FromJSON Float where
  fromJSON :: f Float
fromJSON = 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 = 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 Integer where
  fromJSON :: f Integer
fromJSON = (Scientific -> Integer) -> f Scientific -> f Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round f Scientific
forall (f :: * -> *). JSONParser f => f Scientific
parseNumber

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

instance forall a. (Integral a, FromJSON a, Typeable a) => FromJSON (Ratio.Ratio a) where
  fromJSON :: f (Ratio a)
fromJSON = Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (Ratio a))
-> f (Ratio a)
forall (f :: * -> *) a.
JSONParser f =>
Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser a)
-> f a
parseObject Text
objName ((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 -> objectParser a
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> f v
parseField Text
"num" objectParser (a -> Ratio a)
-> objectParser a -> objectParser (Ratio a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> objectParser a
forall (f :: * -> *) v.
(JSONObjectParser f, FromJSON v) =>
Text -> f v
parseField Text
"denom"
      where
        objName :: Text
objName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
tyName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
".Ratio"
        tyName :: String
tyName = (TyCon -> String
tyConModule (TyCon -> String) -> (TyCon -> String) -> TyCon -> String
forall a. Semigroup a => a -> a -> a
<> String -> TyCon -> String
forall a b. a -> b -> a
const String
"." (TyCon -> String) -> (TyCon -> String) -> TyCon -> String
forall a. Semigroup a => a -> a -> a
<> TyCon -> String
tyConName) (TyCon -> String) -> TyCon -> String
forall a b. (a -> b) -> a -> b
$ TypeRep -> TyCon
typeRepTyCon (TypeRep -> TyCon) -> TypeRep -> TyCon
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 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

data FromJSONOptions
  = FromJSONOptions
  { FromJSONOptions -> SumTypeEncoding
fromJSONEncodeSums :: SumTypeEncoding
  , FromJSONOptions -> String
fromJSONBaseName :: String
  , FromJSONOptions -> String -> String
convertEnum :: String -> String
  }
  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) -> FromJSONOptions
FromJSONOptions SumTypeEncoding
TagInField String
"" String -> String
forall a. a -> a
id

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)

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

instance (GFromJSON f, Datatype t) => GFromJSON (D1 t f) where
  gFromJSON :: FromJSONOptions -> f (D1 t f a)
gFromJSON FromJSONOptions
opts = 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 (String -> FromJSONOptions -> FromJSONOptions
addName String
name FromJSONOptions
opts)
    where
      name :: String
name = M1 D t f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
moduleName M1 D t f Any
forall a. D1 t f a
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"." String -> String -> String
forall a. Semigroup a => a -> a -> a
<> M1 D t f Any -> String
forall k (d :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Datatype d =>
t d f a -> String
datatypeName M1 D t f Any
forall a. D1 t f a
s
      s :: D1 t f a
      s :: D1 t f a
s = D1 t f a
forall a. HasCallStack => a
undefined

instance {-# OVERLAPPABLE #-} forall c i. (GFromJSONObject i, Constructor c) => GFromJSON (C1 c i) where
  gFromJSON :: FromJSONOptions -> f (C1 c i a)
gFromJSON FromJSONOptions
opts = i a -> C1 c i a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (i a -> C1 c i a) -> f (i a) -> f (C1 c i a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (i a))
-> f (i a)
forall (f :: * -> *) a.
JSONParser f =>
Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser a)
-> f a
parseObject (String -> Text
T.pack String
name) (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
<> M1 C c i Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C c i Any
forall a. C1 c i a
n
      n :: C1 c i a
      n :: C1 c i a
n = C1 c i a
forall a. HasCallStack => a
undefined

instance {-# OVERLAPS #-} (FromJSON s) => GFromJSON (C1 c (S1 (MetaSel 'Nothing su ss ds) (Rec0 s))) where
  gFromJSON :: FromJSONOptions
-> f (C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a)
gFromJSON FromJSONOptions
_ = M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a
-> C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a
 -> C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a)
-> (s -> M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a)
-> s
-> C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R s a -> M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (K1 R s a -> M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a)
-> (s -> K1 R s a)
-> s
-> M1 S ('MetaSel 'Nothing su ss ds) (Rec0 s) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> K1 R s a
forall k i c (p :: k). c -> K1 i c p
K1 (s -> C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a)
-> f s -> f (C1 c (S1 ('MetaSel 'Nothing su ss ds) (Rec0 s)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f s
forall value (f :: * -> *).
(FromJSON value, JSONParser f) =>
f value
fromJSON

instance GFromJSON U1 where
  gFromJSON :: FromJSONOptions -> f (U1 a)
gFromJSON FromJSONOptions
opts = U1 a
forall k (p :: k). U1 p
U1 U1 a -> f () -> f (U1 a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
forall (f :: * -> *). JSONParser f => f ()
parseNull

instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (C1 t U1) where
  gFromJSON :: FromJSONOptions -> f (C1 t U1 a)
gFromJSON FromJSONOptions
opts = U1 a -> C1 t 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 t U1 a -> f () -> f (C1 t U1 a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> f ()
forall (f :: * -> *). JSONParser f => Text -> f ()
parseTextConstant Text
conn
    where
      conn :: Text
conn = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ M1 C t U1 Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName M1 C t U1 Any
forall f. C1 t U1 f
c
      c :: C1 t U1 f
      c :: C1 t U1 f
c = C1 t U1 f
forall a. HasCallStack => a
undefined

instance {-# OVERLAPS #-} (Constructor t) => GFromJSON (PartOfSum (C1 t U1)) where
  gFromJSON :: FromJSONOptions -> f (PartOfSum (C1 t U1) a)
gFromJSON FromJSONOptions
opts = M1 C t U1 a -> PartOfSum (C1 t U1) a
forall (f :: * -> *) a. f a -> PartOfSum f a
PartOfSum (U1 a -> M1 C t 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) PartOfSum (C1 t U1) a -> f () -> f (PartOfSum (C1 t U1) a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> f ()
forall (f :: * -> *). JSONParser f => Text -> f ()
parseTextConstant Text
enumValue
    where
      enumValue :: Text
enumValue = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ FromJSONOptions -> String -> String
convertEnum FromJSONOptions
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ M1 C t U1 Any -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName (forall f. M1 C t U1 f
forall a. HasCallStack => a
undefined :: C1 t U1 f)

instance {-# OVERLAPPING #-} (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
PartOfSum (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 = Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (C1 t f a))
-> f (C1 t f a)
forall (f :: * -> *) a.
JSONParser f =>
Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser a)
-> f a
parseObject (Text -> Text
objName Text
name) ((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 = Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser (C1 t f a))
-> f (C1 t f a)
forall (f :: * -> *) a.
JSONParser f =>
Text
-> (forall (objectParser :: * -> *).
    JSONObjectParser objectParser =>
    objectParser a)
-> f a
parseObject (Text -> Text
objName Text
name) ((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 -> Text
objName Text
a = 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
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".Input"

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 (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
PartOfSum ((:+:) 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
<$> FromJSONOptions -> f ((:+:) l r a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
opts

instance {-# OVERLAPPING #-} (Constructor t, Constructor t') =>
  GFromJSON (C1 t U1 :+: C1 t' U1) where
    gFromJSON :: FromJSONOptions -> f ((:+:) (C1 t U1) (C1 t' U1) a)
gFromJSON FromJSONOptions
ops = (C1 t U1 a -> (:+:) (C1 t U1) (C1 t' U1) a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (C1 t U1 a -> (:+:) (C1 t U1) (C1 t' U1) a)
-> f (C1 t U1 a) -> f ((:+:) (C1 t U1) (C1 t' U1) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (C1 t U1 a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
ops) f ((:+:) (C1 t U1) (C1 t' U1) a)
-> f ((:+:) (C1 t U1) (C1 t' U1) a)
-> f ((:+:) (C1 t U1) (C1 t' U1) a)
forall a. Semigroup a => a -> a -> a
<> (C1 t' U1 a -> (:+:) (C1 t U1) (C1 t' U1) a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (C1 t' U1 a -> (:+:) (C1 t U1) (C1 t' U1) a)
-> f (C1 t' U1 a) -> f ((:+:) (C1 t U1) (C1 t' U1) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FromJSONOptions -> f (C1 t' U1 a)
forall (v :: * -> *) (f :: * -> *) a.
(GFromJSON v, JSONParser f) =>
FromJSONOptions -> f (v a)
gFromJSON FromJSONOptions
ops)

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 (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 (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