    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE CPP #-}
    {-# LANGUAGE EmptyCase #-}
    {-# LANGUAGE FlexibleInstances #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE UndecidableInstances #-}
    {-# LANGUAGE TemplateHaskellQuotes #-}

    {-|
    Module:      Data.Aeson.TH
    Copyright:   (c) 2011-2016 Bryan O'Sullivan
                 (c) 2011 MailRank, Inc.
    License:     BSD3
    Stability:   experimental
    Portability: portable

    Functions to mechanically derive 'ToJSON' and 'FromJSON' instances. Note that
    you need to enable the @TemplateHaskell@ language extension in order to use this
    module.

    An example shows how instances are generated for arbitrary data types. First we
    define a data type:

    @
    data D a = Nullary
             | Unary Int
             | Product String Char a
             | Record { testOne   :: Double
                      , testTwo   :: Bool
                      , testThree :: D a
                      } deriving Eq
    @

    Next we derive the necessary instances. Note that we make use of the
    feature to change record field names. In this case we drop the first 4
    characters of every field name. We also modify constructor names by
    lower-casing them:

    @
    $('deriveJSON' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D)
    @

    Now we can use the newly created instances.

    @
    d :: D 'Int'
    d = Record { testOne = 3.14159
               , testTwo = 'True'
               , testThree = Product \"test\" \'A\' 123
               }
    @

    @
    fromJSON (toJSON d) == Success d
    @

    This also works for data family instances, but instead of passing in the data
    family name (with double quotes), we pass in a data family instance
    constructor (with a single quote):

    @
    data family DF a
    data instance DF Int = DF1 Int
                         | DF2 Int Int
                         deriving Eq

    $('deriveJSON' 'defaultOptions' 'DF1)
    -- Alternatively, one could pass 'DF2 instead
    @

    Please note that you can derive instances for tuples using the following syntax:

    @
    -- FromJSON and ToJSON instances for 4-tuples.
    $('deriveJSON' 'defaultOptions' ''(,,,))
    @

    If you derive `ToJSON` for a type that has no constructors, the splice will
    require enabling @EmptyCase@ to compile.

    -}
    module Data.Aeson.TH
        (
          -- * Encoding configuration
          Options(..)
        , SumEncoding(..)
        , defaultOptions
        , defaultTaggedObject

         -- * FromJSON and ToJSON derivation
        , deriveJSON
        , deriveJSON1
        , deriveJSON2

        , deriveToJSON
        , deriveToJSON1
        , deriveToJSON2
        , deriveFromJSON
        , deriveFromJSON1
        , deriveFromJSON2

        , mkToJSON
        , mkLiftToJSON
        , mkLiftToJSON2
        , mkToEncoding
        , mkLiftToEncoding
        , mkLiftToEncoding2
        , mkParseJSON
        , mkLiftParseJSON
        , mkLiftParseJSON2
        ) where

    -- We don't have MonadFail Q, so we should use `fail` from real `Prelude`

    import Data.Aeson.Internal.Prelude

    import Data.Char (ord)
    import Data.Aeson (Object, (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
    import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
    import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
    import Data.Aeson.Types.ToJSON (fromPairs, pair)
    import Data.Aeson.Key (Key)
    import qualified Data.Aeson.Key as Key
    import qualified Data.Aeson.KeyMap as KM
    import Data.Foldable (foldr')
    import Data.List (genericLength, intercalate, union)
    import Data.List.NonEmpty ((<|), NonEmpty((:|)))
    import Data.Map (Map)
    import qualified Data.Monoid as Monoid
    import Data.Set (Set)
    import Language.Haskell.TH hiding (Arity)
    import Language.Haskell.TH.Datatype
    import Text.Printf (printf)
    import qualified Data.Aeson.Encoding.Internal as E
    import qualified Data.List.NonEmpty as NE (length, reverse)
    import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
    import qualified Data.Set as Set (empty, insert, member)
    import qualified Data.Text as T (pack, unpack)
    import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)
    import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
    import qualified Data.Text.Short as ST
    import Data.ByteString.Short (ShortByteString)
    import Data.Aeson.Internal.ByteString
    import Data.Aeson.Internal.TH

    --------------------------------------------------------------------------------
    -- Convenience
    --------------------------------------------------------------------------------

    -- | Generates both 'ToJSON' and 'FromJSON' instance declarations for the given
    -- data type or data family instance constructor.
    --
    -- This is a convenience function which is equivalent to calling both
    -- 'deriveToJSON' and 'deriveFromJSON'.
    deriveJSON :: Options
               -- ^ Encoding options.
               -> Name
               -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
               -- instances.
               -> Q [Dec]
    deriveJSON :: Options -> Name -> Q [Dec]
    deriveJSON = (Options -> Name -> Q [Dec])
    -> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
    deriveJSONBoth Options -> Name -> Q [Dec]
    deriveToJSON Options -> Name -> Q [Dec]
    deriveFromJSON

    -- | Generates both 'ToJSON1' and 'FromJSON1' instance declarations for the given
    -- data type or data family instance constructor.
    --
    -- This is a convenience function which is equivalent to calling both
    -- 'deriveToJSON1' and 'deriveFromJSON1'.
    deriveJSON1 :: Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate 'ToJSON1' and 'FromJSON1'
                -- instances.
                -> Q [Dec]
    deriveJSON1 :: Options -> Name -> Q [Dec]
    deriveJSON1 = (Options -> Name -> Q [Dec])
    -> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
    deriveJSONBoth Options -> Name -> Q [Dec]
    deriveToJSON1 Options -> Name -> Q [Dec]
    deriveFromJSON1

    -- | Generates both 'ToJSON2' and 'FromJSON2' instance declarations for the given
    -- data type or data family instance constructor.
    --
    -- This is a convenience function which is equivalent to calling both
    -- 'deriveToJSON2' and 'deriveFromJSON2'.
    deriveJSON2 :: Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the type for which to generate 'ToJSON2' and 'FromJSON2'
                -- instances.
                -> Q [Dec]
    deriveJSON2 :: Options -> Name -> Q [Dec]
    deriveJSON2 = (Options -> Name -> Q [Dec])
    -> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
    deriveJSONBoth Options -> Name -> Q [Dec]
    deriveToJSON2 Options -> Name -> Q [Dec]
    deriveFromJSON2

    --------------------------------------------------------------------------------
    -- ToJSON
    --------------------------------------------------------------------------------

    {-
    TODO: Don't constrain phantom type variables.

    data Foo a = Foo Int
    instance (ToJSON a) ⇒ ToJSON Foo where ...

    The above (ToJSON a) constraint is not necessary and perhaps undesirable.
    -}

    -- | Generates a 'ToJSON' instance declaration for the given data type or
    -- data family instance constructor.
    deriveToJSON :: Options
                 -- ^ Encoding options.
                 -> Name
                 -- ^ Name of the type for which to generate a 'ToJSON' instance
                 -- declaration.
                 -> Q [Dec]
    deriveToJSON :: Options -> Name -> Q [Dec]
    deriveToJSON = JSONClass -> Options -> Name -> Q [Dec]
    deriveToJSONCommon JSONClass
    toJSONClass

    -- | Generates a 'ToJSON1' instance declaration for the given data type or
    -- data family instance constructor.
    deriveToJSON1 :: Options
                  -- ^ Encoding options.
                  -> Name
                  -- ^ Name of the type for which to generate a 'ToJSON1' instance
                  -- declaration.
                  -> Q [Dec]
    deriveToJSON1 :: Options -> Name -> Q [Dec]
    deriveToJSON1 = JSONClass -> Options -> Name -> Q [Dec]
    deriveToJSONCommon JSONClass
    toJSON1Class

    -- | Generates a 'ToJSON2' instance declaration for the given data type or
    -- data family instance constructor.
    deriveToJSON2 :: Options
                  -- ^ Encoding options.
                  -> Name
                  -- ^ Name of the type for which to generate a 'ToJSON2' instance
                  -- declaration.
                  -> Q [Dec]
    deriveToJSON2 :: Options -> Name -> Q [Dec]
    deriveToJSON2 = JSONClass -> Options -> Name -> Q [Dec]
    deriveToJSONCommon JSONClass
    toJSON2Class

    deriveToJSONCommon :: JSONClass
                       -- ^ The ToJSON variant being derived.
                       -> Options
                       -- ^ Encoding options.
                       -> Name
                       -- ^ Name of the type for which to generate an instance.
                       -> Q [Dec]
    deriveToJSONCommon :: JSONClass -> Options -> Name -> Q [Dec]
    deriveToJSONCommon = [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    -> JSONClass -> Options -> Name -> Q [Dec]
    deriveJSONClass [ (JSONFun
    ToJSON,     \JSONClass
    jc Name
    _ -> ToJSONFun
    -> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consToValue ToJSONFun
    Value JSONClass
    jc)
                                         , (JSONFun
    ToEncoding, \JSONClass
    jc Name
    _ -> ToJSONFun
    -> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consToValue ToJSONFun
    Encoding JSONClass
    jc)
                                         ]

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a 'Value'.
    mkToJSON :: Options -- ^ Encoding options.
             -> Name -- ^ Name of the type to encode.
             -> Q Exp
    mkToJSON :: Options -> Name -> Q Exp
    mkToJSON = JSONClass -> Options -> Name -> Q Exp
    mkToJSONCommon JSONClass
    toJSONClass

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a 'Value' by using the given encoding
    -- function on occurrences of the last type parameter.
    mkLiftToJSON :: Options -- ^ Encoding options.
                 -> Name -- ^ Name of the type to encode.
                 -> Q Exp
    mkLiftToJSON :: Options -> Name -> Q Exp
    mkLiftToJSON = JSONClass -> Options -> Name -> Q Exp
    mkToJSONCommon JSONClass
    toJSON1Class

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a 'Value' by using the given encoding
    -- functions on occurrences of the last two type parameters.
    mkLiftToJSON2 :: Options -- ^ Encoding options.
                  -> Name -- ^ Name of the type to encode.
                  -> Q Exp
    mkLiftToJSON2 :: Options -> Name -> Q Exp
    mkLiftToJSON2 = JSONClass -> Options -> Name -> Q Exp
    mkToJSONCommon JSONClass
    toJSON2Class

    mkToJSONCommon :: JSONClass -- ^ Which class's method is being derived.
                   -> Options -- ^ Encoding options.
                   -> Name -- ^ Name of the encoded type.
                   -> Q Exp
    mkToJSONCommon :: JSONClass -> Options -> Name -> Q Exp
    mkToJSONCommon = (JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> JSONClass -> Options -> Name -> Q Exp
    mkFunCommon (\JSONClass
    jc Name
    _ -> ToJSONFun
    -> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consToValue ToJSONFun
    Value JSONClass
    jc)

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a JSON string.
    mkToEncoding :: Options -- ^ Encoding options.
                 -> Name -- ^ Name of the type to encode.
                 -> Q Exp
    mkToEncoding :: Options -> Name -> Q Exp
    mkToEncoding = JSONClass -> Options -> Name -> Q Exp
    mkToEncodingCommon JSONClass
    toJSONClass

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a JSON string by using the given encoding
    -- function on occurrences of the last type parameter.
    mkLiftToEncoding :: Options -- ^ Encoding options.
                     -> Name -- ^ Name of the type to encode.
                     -> Q Exp
    mkLiftToEncoding :: Options -> Name -> Q Exp
    mkLiftToEncoding = JSONClass -> Options -> Name -> Q Exp
    mkToEncodingCommon JSONClass
    toJSON1Class

    -- | Generates a lambda expression which encodes the given data type or
    -- data family instance constructor as a JSON string by using the given encoding
    -- functions on occurrences of the last two type parameters.
    mkLiftToEncoding2 :: Options -- ^ Encoding options.
                      -> Name -- ^ Name of the type to encode.
                      -> Q Exp
    mkLiftToEncoding2 :: Options -> Name -> Q Exp
    mkLiftToEncoding2 = JSONClass -> Options -> Name -> Q Exp
    mkToEncodingCommon JSONClass
    toJSON2Class

    mkToEncodingCommon :: JSONClass -- ^ Which class's method is being derived.
                       -> Options -- ^ Encoding options.
                       -> Name -- ^ Name of the encoded type.
                       -> Q Exp
    mkToEncodingCommon :: JSONClass -> Options -> Name -> Q Exp
    mkToEncodingCommon = (JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> JSONClass -> Options -> Name -> Q Exp
    mkFunCommon (\JSONClass
    jc Name
    _ -> ToJSONFun
    -> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consToValue ToJSONFun
    Encoding JSONClass
    jc)

    type LetInsert = ShortByteString -> ExpQ

    -- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
    -- code to generate a 'Value' or 'Encoding' of a number of constructors. All
    -- constructors must be from the same type.
    consToValue :: ToJSONFun
                -- ^ The method ('toJSON' or 'toEncoding') being derived.
                -> JSONClass
                -- ^ The ToJSON variant being derived.
                -> Options
                -- ^ Encoding options.
                -> [Type]
                -- ^ The types from the data type/data family instance declaration
                -> [ConstructorInfo]
                -- ^ Constructors for which to generate JSON generating code.
                -> Q Exp

    consToValue :: ToJSONFun
    -> JSONClass -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consToValue ToJSONFun
    _ JSONClass
    _ Options
    _ [Type]
    _ [] =
        [| \x -> case x of {} |]

    consToValue ToJSONFun
    target JSONClass
    jc Options
    opts [Type]
    instTys [ConstructorInfo]
    cons = (ShortByteString -> Q Exp)
    -> ((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp
    forall a. Ord a => (a -> Q Exp) -> ((a -> Q Exp) -> Q Exp) -> Q Exp
    autoletE ShortByteString -> Q Exp
    liftSBS (((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp)
    -> ((ShortByteString -> Q Exp) -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \ShortByteString -> Q Exp
    letInsert -> do
        value <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "value"
        os    <- newNameList "_o"   $ arityInt jc
        tjs   <- newNameList "_tj"  $ arityInt jc
        tjls  <- newNameList "_tjl" $ arityInt jc
        let zippedTJs      = [Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [Name]
    os [Name]
    tjs [Name]
    tjls
            interleavedTJs = [(Name, Name, Name)] -> [Name]
    forall a. [(a, a, a)] -> [a]
    flatten3 [(Name, Name, Name)]
    zippedTJs
            lastTyVars     = (Type -> Name) -> [Type] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Name
    varTToName ([Type] -> [Name]) -> [Type] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    drop ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    instTys Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - JSONClass -> Int
    arityInt JSONClass
    jc) [Type]
    instTys
            tvMap          = [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name))
    -> [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [(Name, Name, Name)] -> [(Name, (Name, Name, Name))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    lastTyVars [(Name, Name, Name)]
    zippedTJs
        lamE (map varP $ interleavedTJs ++ [value]) $
            caseE (varE value) (matches letInsert tvMap)
      where
        matches :: (ShortByteString -> Q Exp)
    -> Map Name (Name, Name, Name) -> [Q Match]
    matches ShortByteString -> Q Exp
    letInsert Map Name (Name, Name, Name)
    tvMap = case [ConstructorInfo]
    cons of
          -- A single constructor is directly encoded. The constructor itself may be
          -- forgotten.
          [ConstructorInfo
    con] | Bool -> Bool
    not (Options -> Bool
    tagSingleConstructors Options
    opts) -> [(ShortByteString -> Q Exp)
    -> ToJSONFun
    -> JSONClass
    -> Map Name (Name, Name, Name)
    -> Options
    -> Bool
    -> ConstructorInfo
    -> Q Match
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    False ConstructorInfo
    con]
          [ConstructorInfo]
    _ | Options -> Bool
    allNullaryToStringTag Options
    opts Bool -> Bool -> Bool
    && (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ConstructorInfo -> Bool
    isNullary [ConstructorInfo]
    cons ->
                  [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP Name
    conName []) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ ToJSONFun -> Options -> Name -> Q Exp
    conStr ToJSONFun
    target Options
    opts Name
    conName) []
                  | ConstructorInfo
    con <- [ConstructorInfo]
    cons
                  , let conName :: Name
    conName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    con
                  ]
            | Bool
    otherwise -> [(ShortByteString -> Q Exp)
    -> ToJSONFun
    -> JSONClass
    -> Map Name (Name, Name, Name)
    -> Options
    -> Bool
    -> ConstructorInfo
    -> Q Match
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    True ConstructorInfo
    con | ConstructorInfo
    con <- [ConstructorInfo]
    cons]

    -- | Name of the constructor as a quoted 'Value' or 'Encoding'.
    conStr :: ToJSONFun -> Options -> Name -> Q Exp
    conStr :: ToJSONFun -> Options -> Name -> Q Exp
    conStr ToJSONFun
    Value Options
    opts = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|String|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> Name -> Q Exp
    conTxt Options
    opts
    conStr ToJSONFun
    Encoding Options
    opts = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|E.text|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> Name -> Q Exp
    conTxt Options
    opts

    -- | Name of the constructor as a quoted 'Text'.
    conTxt :: Options -> Name -> Q Exp
    conTxt :: Options -> Name -> Q Exp
    conTxt Options
    opts = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|T.pack|] (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> Q Exp) -> (Name -> String) -> Name -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> Name -> String
    conString Options
    opts

    -- | Name of the constructor.
    conString :: Options -> Name -> String
    conString :: Options -> Name -> String
    conString Options
    opts = Options -> String -> String
    constructorTagModifier Options
    opts (String -> String) -> (Name -> String) -> Name -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase

    -- | If constructor is nullary.
    isNullary :: ConstructorInfo -> Bool
    isNullary :: ConstructorInfo -> Bool
    isNullary ConstructorInfo { constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                              , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    tys } = [Type] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Type]
    tys
    isNullary ConstructorInfo
    _ = Bool
    False

    -- | Wrap fields of a non-record constructor. See 'sumToValue'.
    opaqueSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
    opaqueSumToValue :: (ShortByteString -> Q Exp)
    -> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
    opaqueSumToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target Options
    opts Bool
    multiCons Bool
    nullary Name
    conName Q Exp
    value =
      (ShortByteString -> Q Exp)
    -> ToJSONFun
    -> Options
    -> Bool
    -> Bool
    -> Name
    -> Q Exp
    -> (String -> Q Exp)
    -> Q Exp
    sumToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target Options
    opts Bool
    multiCons Bool
    nullary Name
    conName
        Q Exp
    value
        String -> Q Exp
    pairs
      where
        pairs :: String -> Q Exp
    pairs String
    contentsFieldName = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
    pairE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target String
    contentsFieldName Q Exp
    value

    -- | Wrap fields of a record constructor. See 'sumToValue'.
    recordSumToValue :: LetInsert -> ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
    recordSumToValue :: (ShortByteString -> Q Exp)
    -> ToJSONFun -> Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
    recordSumToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target Options
    opts Bool
    multiCons Bool
    nullary Name
    conName Q Exp
    pairs =
      (ShortByteString -> Q Exp)
    -> ToJSONFun
    -> Options
    -> Bool
    -> Bool
    -> Name
    -> Q Exp
    -> (String -> Q Exp)
    -> Q Exp
    sumToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target Options
    opts Bool
    multiCons Bool
    nullary Name
    conName
        (ToJSONFun -> Q Exp -> Q Exp
    fromPairsE ToJSONFun
    target Q Exp
    pairs)
        (Q Exp -> String -> Q Exp
    forall a b. a -> b -> a
    const Q Exp
    pairs)

    -- | Wrap fields of a constructor.
    sumToValue
      :: LetInsert
      -- ^ Let insertion
      -> ToJSONFun
      -- ^ The method being derived.
      -> Options
      -- ^ Deriving options.
      -> Bool
      -- ^ Does this type have multiple constructors.
      -> Bool
      -- ^ Is this constructor nullary.
      -> Name
      -- ^ Constructor name.
      -> ExpQ
      -- ^ Fields of the constructor as a 'Value' or 'Encoding'.
      -> (String -> ExpQ)
      -- ^ Representation of an 'Object' fragment used for the 'TaggedObject'
      -- variant; of type @[(Text,Value)]@ or @[Encoding]@, depending on the method
      -- being derived.
      --
      -- - For non-records, produces a pair @"contentsFieldName":value@,
      --   given a @contentsFieldName@ as an argument. See 'opaqueSumToValue'.
      -- - For records, produces the list of pairs corresponding to fields of the
      --   encoded value (ignores the argument). See 'recordSumToValue'.
      -> ExpQ
    sumToValue :: (ShortByteString -> Q Exp)
    -> ToJSONFun
    -> Options
    -> Bool
    -> Bool
    -> Name
    -> Q Exp
    -> (String -> Q Exp)
    -> Q Exp
    sumToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target Options
    opts Bool
    multiCons Bool
    nullary Name
    conName Q Exp
    value String -> Q Exp
    pairs
        | Bool
    multiCons =
            case Options -> SumEncoding
    sumEncoding Options
    opts of
              SumEncoding
    TwoElemArray ->
                ToJSONFun -> [Q Exp] -> Q Exp
    array ToJSONFun
    target [ToJSONFun -> Options -> Name -> Q Exp
    conStr ToJSONFun
    target Options
    opts Name
    conName, Q Exp
    value]
              TaggedObject{String
    tagFieldName :: String
    tagFieldName :: SumEncoding -> String
    tagFieldName, String
    contentsFieldName :: String
    contentsFieldName :: SumEncoding -> String
    contentsFieldName} ->
                -- TODO: Maybe throw an error in case
                -- tagFieldName overwrites a field in pairs.
                let tag :: Q Exp
    tag = (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
    pairE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target String
    tagFieldName (ToJSONFun -> Options -> Name -> Q Exp
    conStr ToJSONFun
    target Options
    opts Name
    conName)
                    content :: Q Exp
    content = String -> Q Exp
    pairs String
    contentsFieldName
                in ToJSONFun -> Q Exp -> Q Exp
    fromPairsE ToJSONFun
    target (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                  if Bool
    nullary then Q Exp
    tag else Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    tag [|(Monoid.<>)|] Q Exp
    content
              SumEncoding
    ObjectWithSingleField ->
                (ShortByteString -> Q Exp)
    -> ToJSONFun -> [(String, Q Exp)] -> Q Exp
    objectE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target [(Options -> Name -> String
    conString Options
    opts Name
    conName, Q Exp
    value)]
              SumEncoding
    UntaggedValue | Bool
    nullary -> ToJSONFun -> Options -> Name -> Q Exp
    conStr ToJSONFun
    target Options
    opts Name
    conName
              SumEncoding
    UntaggedValue -> Q Exp
    value
        | Bool
    otherwise = Q Exp
    value

    -- | Generates code to generate the JSON encoding of a single constructor.
    argsToValue :: LetInsert -> ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match

    -- Polyadic constructors with special case for unary constructors.
    argsToValue :: (ShortByteString -> Q Exp)
    -> ToJSONFun
    -> JSONClass
    -> Map Name (Name, Name, Name)
    -> Options
    -> Bool
    -> ConstructorInfo
    -> Q Match
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    multiCons
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys } = do
        argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
        let len = [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    argTys'
        args <- newNameList "arg" len
        let js = case [ ToJSONFun
    -> JSONClass
    -> Name
    -> Map Name (Name, Name, Name)
    -> Type
    -> Q Exp
    dispatchToJSON ToJSONFun
    target JSONClass
    jc Name
    conName Map Name (Name, Name, Name)
    tvMap Type
    argTy
                          Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    arg
                      | (Name
    arg, Type
    argTy) <- [Name] -> [Type] -> [(Name, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    args [Type]
    argTys'
                      ] of
                   -- Single argument is directly converted.
                   [Q Exp
    e] -> Q Exp
    e
                   -- Zero and multiple arguments are converted to a JSON array.
                   [Q Exp]
    es -> ToJSONFun -> [Q Exp] -> Q Exp
    array ToJSONFun
    target [Q Exp]
    es

        match (conP conName $ map varP args)
              (normalB $ opaqueSumToValue letInsert target opts multiCons (null argTys') conName js)
              []

    -- Records.
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    multiCons
      info :: ConstructorInfo
    info@ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                           , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = RecordConstructor [Name]
    fields
                           , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys } =
        case (Options -> Bool
    unwrapUnaryRecords Options
    opts, Bool -> Bool
    not Bool
    multiCons, [Type]
    argTys) of
          (Bool
    True,Bool
    True,[Type
    _]) -> (ShortByteString -> Q Exp)
    -> ToJSONFun
    -> JSONClass
    -> Map Name (Name, Name, Name)
    -> Options
    -> Bool
    -> ConstructorInfo
    -> Q Match
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    multiCons
                                         (ConstructorInfo
    info{constructorVariant = NormalConstructor})
          (Bool, Bool, [Type])
    _ -> do

            argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
            args <- newNameList "arg" $ length argTys'
            let argCons = [Q Exp] -> [Type] -> [Name] -> [(Q Exp, Type, Name)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE [Name]
    args) [Type]
    argTys' [Name]
    fields

                toPair (Q Exp
    arg, Type
    argTy, Name
    fld) =
                  let fieldName :: String
    fieldName = Options -> Name -> String
    fieldLabel Options
    opts Name
    fld
                      toValue :: Q Exp
    toValue = ToJSONFun
    -> JSONClass
    -> Name
    -> Map Name (Name, Name, Name)
    -> Type
    -> Q Exp
    dispatchToJSON ToJSONFun
    target JSONClass
    jc Name
    conName Map Name (Name, Name, Name)
    tvMap Type
    argTy

                      omitFn :: Q Exp
                      omitFn :: Q Exp
    omitFn
                        | Options -> Bool
    omitNothingFields Options
    opts = JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchOmitField JSONClass
    jc Name
    conName Map Name (Name, Name, Name)
    tvMap Type
    argTy
                        | Bool
    otherwise = [| const False |]

                  in Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    condE
                    (Q Exp
    omitFn Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    arg)
                    [| mempty |]
                    ((ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
    pairE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target String
    fieldName (Q Exp
    toValue Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    arg))

                pairs = [Q Exp] -> Q Exp
    mconcatE (((Q Exp, Type, Name) -> Q Exp) -> [(Q Exp, Type, Name)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Q Exp, Type, Name) -> Q Exp
    toPair [(Q Exp, Type, Name)]
    argCons)

            match (conP conName $ map varP args)
                  (normalB $ recordSumToValue letInsert target opts multiCons (null argTys) conName pairs)
                  []

    -- Infix constructors.
    argsToValue ShortByteString -> Q Exp
    letInsert ToJSONFun
    target JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Options
    opts Bool
    multiCons
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    InfixConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys } = do
        [alTy, arTy] <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
        al <- newName "argL"
        ar <- newName "argR"
        match (infixP (varP al) conName (varP ar))
              ( normalB
              $ opaqueSumToValue letInsert target opts multiCons False conName
              $ array target
                  [ dispatchToJSON target jc conName tvMap aTy
                      `appE` varE a
                  | (a, aTy) <- [(al,alTy), (ar,arTy)]
                  ]
              )
              []

    (<^>) :: ExpQ -> ExpQ -> ExpQ
    <^> :: Q Exp -> Q Exp -> Q Exp
    (<^>) Q Exp
    a Q Exp
    b = Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    a [|(E.><)|] Q Exp
    b
    infixr 6 <^>

    (<%>) :: ExpQ -> ExpQ -> ExpQ
    <%> :: Q Exp -> Q Exp -> Q Exp
    (<%>) Q Exp
    a Q Exp
    b = Q Exp
    a Q Exp -> Q Exp -> Q Exp
    <^> [|E.comma|] Q Exp -> Q Exp -> Q Exp
    <^> Q Exp
    b
    infixr 4 <%>

    -- | Wrap a list of quoted 'Value's in a quoted 'Array' (of type 'Value').
    array :: ToJSONFun -> [ExpQ] -> ExpQ
    array :: ToJSONFun -> [Q Exp] -> Q Exp
    array ToJSONFun
    Encoding [] = [|E.emptyArray_|]
    array ToJSONFun
    Value [] = [|Array V.empty|]
    array ToJSONFun
    Encoding [Q Exp]
    es = [|E.wrapArray|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 Q Exp -> Q Exp -> Q Exp
    (<%>) [Q Exp]
    es
    array ToJSONFun
    Value [Q Exp]
    es = do
      mv <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "mv"
      let newMV = Q Pat -> Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Stmt
    bindS (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    mv)
                        ([|VM.unsafeNew|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                          Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    integerL (Integer -> Lit) -> Integer -> Lit
    forall a b. (a -> b) -> a -> b
    $ Int -> Integer
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ([Q Exp] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Q Exp]
    es)))
          stmts = [ Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
    forall a b. (a -> b) -> a -> b
    $
                      [|VM.unsafeWrite|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                        Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    mv Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                          Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    integerL Integer
    ix) Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                            Q Exp
    e
                  | (Integer
    ix, Q Exp
    e) <- [Integer] -> [Q Exp] -> [(Integer, Q Exp)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(Integer
    0::Integer)..] [Q Exp]
    es
                  ]
          ret = Q Exp -> Q Stmt
    forall (m :: * -> *). Quote m => m Exp -> m Stmt
    noBindS (Q Exp -> Q Stmt) -> Q Exp -> Q Stmt
    forall a b. (a -> b) -> a -> b
    $ [|return|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    mv
      [|Array|] `appE`
                 (varE 'V.create `appE`
                   doE (newMV:stmts++[ret]))

    -- | Wrap an associative list of keys and quoted values in a quoted 'Object'.
    objectE :: LetInsert -> ToJSONFun -> [(String, ExpQ)] -> ExpQ
    objectE :: (ShortByteString -> Q Exp)
    -> ToJSONFun -> [(String, Q Exp)] -> Q Exp
    objectE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target = ToJSONFun -> Q Exp -> Q Exp
    fromPairsE ToJSONFun
    target (Q Exp -> Q Exp)
    -> ([(String, Q Exp)] -> Q Exp) -> [(String, Q Exp)] -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Q Exp] -> Q Exp
    mconcatE ([Q Exp] -> Q Exp)
    -> ([(String, Q Exp)] -> [Q Exp]) -> [(String, Q Exp)] -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((String, Q Exp) -> Q Exp) -> [(String, Q Exp)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((String -> Q Exp -> Q Exp) -> (String, Q Exp) -> Q Exp
    forall a b c. (a -> b -> c) -> (a, b) -> c
    uncurry ((ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
    pairE ShortByteString -> Q Exp
    letInsert ToJSONFun
    target))

    -- | 'mconcat' a list of fixed length.
    --
    -- > mconcatE [ [|x|], [|y|], [|z|] ] = [| x <> (y <> z) |]
    mconcatE :: [ExpQ] -> ExpQ
    mconcatE :: [Q Exp] -> Q Exp
    mconcatE [] = [|Monoid.mempty|]
    mconcatE [Q Exp
    x] = Q Exp
    x
    mconcatE (Q Exp
    x : [Q Exp]
    xs) = Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    x [|(Monoid.<>)|] ([Q Exp] -> Q Exp
    mconcatE [Q Exp]
    xs)

    fromPairsE :: ToJSONFun -> ExpQ -> ExpQ
    fromPairsE :: ToJSONFun -> Q Exp -> Q Exp
    fromPairsE ToJSONFun
    _ = ([|fromPairs|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`)

    -- | Create (an encoding of) a key-value pair.
    --
    -- > pairE "k" [|v|] = [| pair "k" v |]
    --
    pairE :: LetInsert -> ToJSONFun -> String -> ExpQ -> ExpQ
    pairE :: (ShortByteString -> Q Exp) -> ToJSONFun -> String -> Q Exp -> Q Exp
    pairE ShortByteString -> Q Exp
    letInsert ToJSONFun
    Encoding String
    k Q Exp
    v = [| E.unsafePairSBS |] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` ShortByteString -> Q Exp
    letInsert ShortByteString
    k' Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    v
      where
        k' :: ShortByteString
    k' = ShortText -> ShortByteString
    ST.toShortByteString (ShortText -> ShortByteString) -> ShortText -> ShortByteString
    forall a b. (a -> b) -> a -> b
    $ String -> ShortText
    ST.pack (String -> ShortText) -> String -> ShortText
    forall a b. (a -> b) -> a -> b
    $ String
    "\"" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Char -> String) -> String -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Char -> String
    escapeAscii String
    k String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\":"

        escapeAscii :: Char -> String
    escapeAscii Char
    '\\' = String
    "\\\\"
        escapeAscii Char
    '\"' = String
    "\\\""
        escapeAscii Char
    '\n' = String
    "\\n"
        escapeAscii Char
    '\r' = String
    "\\r"
        escapeAscii Char
    '\t' = String
    "\\t"
        escapeAscii Char
    c
          | Char -> Int
    ord Char
    c Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0x20 = String
    "\\u" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> Int -> String
    forall r. PrintfType r => String -> r
    printf String
    "%04x" (Char -> Int
    ord Char
    c)
        escapeAscii Char
    c    = [Char
    c]

    pairE ShortByteString -> Q Exp
    _letInsert ToJSONFun
    Value    String
    k Q Exp
    v = [| pair (Key.fromString k) |] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    v

    --------------------------------------------------------------------------------
    -- FromJSON
    --------------------------------------------------------------------------------

    -- | Generates a 'FromJSON' instance declaration for the given data type or
    -- data family instance constructor.
    deriveFromJSON :: Options
                   -- ^ Encoding options.
                   -> Name
                   -- ^ Name of the type for which to generate a 'FromJSON' instance
                   -- declaration.
                   -> Q [Dec]
    deriveFromJSON :: Options -> Name -> Q [Dec]
    deriveFromJSON = JSONClass -> Options -> Name -> Q [Dec]
    deriveFromJSONCommon JSONClass
    fromJSONClass

    -- | Generates a 'FromJSON1' instance declaration for the given data type or
    -- data family instance constructor.
    deriveFromJSON1 :: Options
                    -- ^ Encoding options.
                    -> Name
                    -- ^ Name of the type for which to generate a 'FromJSON1' instance
                    -- declaration.
                    -> Q [Dec]
    deriveFromJSON1 :: Options -> Name -> Q [Dec]
    deriveFromJSON1 = JSONClass -> Options -> Name -> Q [Dec]
    deriveFromJSONCommon JSONClass
    fromJSON1Class

    -- | Generates a 'FromJSON2' instance declaration for the given data type or
    -- data family instance constructor.
    deriveFromJSON2 :: Options
                    -- ^ Encoding options.
                    -> Name
                    -- ^ Name of the type for which to generate a 'FromJSON3' instance
                    -- declaration.
                    -> Q [Dec]
    deriveFromJSON2 :: Options -> Name -> Q [Dec]
    deriveFromJSON2 = JSONClass -> Options -> Name -> Q [Dec]
    deriveFromJSONCommon JSONClass
    fromJSON2Class

    deriveFromJSONCommon :: JSONClass
                         -- ^ The FromJSON variant being derived.
                         -> Options
                         -- ^ Encoding options.
                         -> Name
                         -- ^ Name of the type for which to generate an instance.
                         -- declaration.
                         -> Q [Dec]
    deriveFromJSONCommon :: JSONClass -> Options -> Name -> Q [Dec]
    deriveFromJSONCommon = [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    -> JSONClass -> Options -> Name -> Q [Dec]
    deriveJSONClass [(JSONFun
    ParseJSON, JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consFromJSON)]

    -- | Generates a lambda expression which parses the JSON encoding of the given
    -- data type or data family instance constructor.
    mkParseJSON :: Options -- ^ Encoding options.
                -> Name -- ^ Name of the encoded type.
                -> Q Exp
    mkParseJSON :: Options -> Name -> Q Exp
    mkParseJSON = JSONClass -> Options -> Name -> Q Exp
    mkParseJSONCommon JSONClass
    fromJSONClass

    -- | Generates a lambda expression which parses the JSON encoding of the given
    -- data type or data family instance constructor by using the given parsing
    -- function on occurrences of the last type parameter.
    mkLiftParseJSON :: Options -- ^ Encoding options.
                    -> Name -- ^ Name of the encoded type.
                    -> Q Exp
    mkLiftParseJSON :: Options -> Name -> Q Exp
    mkLiftParseJSON = JSONClass -> Options -> Name -> Q Exp
    mkParseJSONCommon JSONClass
    fromJSON1Class

    -- | Generates a lambda expression which parses the JSON encoding of the given
    -- data type or data family instance constructor by using the given parsing
    -- functions on occurrences of the last two type parameters.
    mkLiftParseJSON2 :: Options -- ^ Encoding options.
                     -> Name -- ^ Name of the encoded type.
                     -> Q Exp
    mkLiftParseJSON2 :: Options -> Name -> Q Exp
    mkLiftParseJSON2 = JSONClass -> Options -> Name -> Q Exp
    mkParseJSONCommon JSONClass
    fromJSON2Class

    mkParseJSONCommon :: JSONClass -- ^ Which class's method is being derived.
                      -> Options -- ^ Encoding options.
                      -> Name -- ^ Name of the encoded type.
                      -> Q Exp
    mkParseJSONCommon :: JSONClass -> Options -> Name -> Q Exp
    mkParseJSONCommon = (JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> JSONClass -> Options -> Name -> Q Exp
    mkFunCommon JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consFromJSON

    -- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
    -- code to parse the JSON encoding of a number of constructors. All constructors
    -- must be from the same type.
    consFromJSON :: JSONClass
                 -- ^ The FromJSON variant being derived.
                 -> Name
                 -- ^ Name of the type to which the constructors belong.
                 -> Options
                 -- ^ Encoding options
                 -> [Type]
                 -- ^ The types from the data type/data family instance declaration
                 -> [ConstructorInfo]
                 -- ^ Constructors for which to generate JSON parsing code.
                 -> Q Exp

    consFromJSON :: JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consFromJSON JSONClass
    _ Name
    _ Options
    _ [Type]
    _ [] =
        [| \_ -> fail "Attempted to parse empty type" |]

    consFromJSON JSONClass
    jc Name
    tName Options
    opts [Type]
    instTys [ConstructorInfo]
    cons = do
      value <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "value"
      os    <- newNameList "_o"   $ arityInt jc
      pjs   <- newNameList "_pj"  $ arityInt jc
      pjls  <- newNameList "_pjl" $ arityInt jc
      let zippedPJs      = [Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
    forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
    zip3 [Name]
    os [Name]
    pjs [Name]
    pjls
          interleavedPJs = [(Name, Name, Name)] -> [Name]
    forall a. [(a, a, a)] -> [a]
    flatten3 [(Name, Name, Name)]
    zippedPJs
          lastTyVars     = (Type -> Name) -> [Type] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Name
    varTToName ([Type] -> [Name]) -> [Type] -> [Name]
    forall a b. (a -> b) -> a -> b
    $ Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    drop ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    instTys Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - JSONClass -> Int
    arityInt JSONClass
    jc) [Type]
    instTys
          tvMap          = [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
    forall k a. Ord k => [(k, a)] -> Map k a
    M.fromList ([(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name))
    -> [(Name, (Name, Name, Name))] -> Map Name (Name, Name, Name)
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [(Name, Name, Name)] -> [(Name, (Name, Name, Name))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    lastTyVars [(Name, Name, Name)]
    zippedPJs
      lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

      where
        checkExi :: Map Name (Name, Name, Name) -> ConstructorInfo -> Q a -> Q a
    checkExi Map Name (Name, Name, Name)
    tvMap ConstructorInfo
    con = JSONClass
    -> Map Name (Name, Name, Name) -> [Type] -> Name -> Q a -> Q a
    forall a.
    JSONClass
    -> Map Name (Name, Name, Name) -> [Type] -> Name -> Q a -> Q a
    checkExistentialContext JSONClass
    jc Map Name (Name, Name, Name)
    tvMap
                                                     (ConstructorInfo -> [Type]
    constructorContext ConstructorInfo
    con)
                                                     (ConstructorInfo -> Name
    constructorName ConstructorInfo
    con)

        lamExpr :: Name -> Map Name (Name, Name, Name) -> Q Exp
    lamExpr Name
    value Map Name (Name, Name, Name)
    tvMap = case [ConstructorInfo]
    cons of
          [ConstructorInfo
    con]
            | Bool -> Bool
    not (Options -> Bool
    tagSingleConstructors Options
    opts)
                -> Map Name (Name, Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
    forall {a}.
    Map Name (Name, Name, Name) -> ConstructorInfo -> Q a -> Q a
    checkExi Map Name (Name, Name, Name)
    tvMap ConstructorInfo
    con (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ JSONClass
    -> Map Name (Name, Name, Name)
    -> Name
    -> Options
    -> ConstructorInfo
    -> Either (String, Name) Name
    -> Q Exp
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    opts ConstructorInfo
    con (Name -> Either (String, Name) Name
    forall a b. b -> Either a b
    Right Name
    value)
          [ConstructorInfo]
    _ | Options -> SumEncoding
    sumEncoding Options
    opts SumEncoding -> SumEncoding -> Bool
    forall a. Eq a => a -> a -> Bool
    == SumEncoding
    UntaggedValue
                -> Map Name (Name, Name, Name) -> [ConstructorInfo] -> Name -> Q Exp
    parseUntaggedValue Map Name (Name, Name, Name)
    tvMap [ConstructorInfo]
    cons Name
    value
            | Bool
    otherwise
                -> Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    value) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                       if Options -> Bool
    allNullaryToStringTag Options
    opts Bool -> Bool -> Bool
    && (ConstructorInfo -> Bool) -> [ConstructorInfo] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ConstructorInfo -> Bool
    isNullary [ConstructorInfo]
    cons
                       then [Q Match]
    allNullaryMatches
                       else Map Name (Name, Name, Name) -> [Q Match]
    mixedMatches Map Name (Name, Name, Name)
    tvMap

        allNullaryMatches :: [Q Match]
    allNullaryMatches =
          [ do txt <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "txtX"
               match (conP 'String [varP txt])
                     (guardedB $
                      [ liftM2 (,) (normalG $
                                      infixApp (varE txt)
                                               [|(==)|]
                                               (conTxt opts conName)
                                   )
                                   ([|pure|] `appE` conE conName)
                      | con <- cons
                      , let conName = ConstructorInfo -> Name
    constructorName ConstructorInfo
    con
                      ]
                      ++
                      [ liftM2 (,)
                          (normalG [|otherwise|])
                          ( [|noMatchFail|]
                            `appE` litE (stringL $ show tName)
                            `appE` ([|T.unpack|] `appE` varE txt)
                          )
                      ]
                     )
                     []
          , do other <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "other"
               match (varP other)
                     (normalB $ [|noStringFail|]
                        `appE` litE (stringL $ show tName)
                        `appE` ([|valueConName|] `appE` varE other)
                     )
                     []
          ]

        mixedMatches :: Map Name (Name, Name, Name) -> [Q Match]
    mixedMatches Map Name (Name, Name, Name)
    tvMap =
            case Options -> SumEncoding
    sumEncoding Options
    opts of
              TaggedObject {String
    tagFieldName :: SumEncoding -> String
    tagFieldName :: String
    tagFieldName, String
    contentsFieldName :: SumEncoding -> String
    contentsFieldName :: String
    contentsFieldName} ->
                (Name -> Q Exp) -> [Q Match]
    forall {m :: * -> *}. Quote m => (Name -> m Exp) -> [m Match]
    parseObject ((Name -> Q Exp) -> [Q Match]) -> (Name -> Q Exp) -> [Q Match]
    forall a b. (a -> b) -> a -> b
    $ Map Name (Name, Name, Name) -> String -> String -> Name -> Q Exp
    parseTaggedObject Map Name (Name, Name, Name)
    tvMap String
    tagFieldName String
    contentsFieldName
              SumEncoding
    UntaggedValue -> String -> [Q Match]
    forall a. HasCallStack => String -> a
    error String
    "UntaggedValue: Should be handled already"
              SumEncoding
    ObjectWithSingleField ->
                (Name -> Q Exp) -> [Q Match]
    forall {m :: * -> *}. Quote m => (Name -> m Exp) -> [m Match]
    parseObject ((Name -> Q Exp) -> [Q Match]) -> (Name -> Q Exp) -> [Q Match]
    forall a b. (a -> b) -> a -> b
    $ Map Name (Name, Name, Name) -> Name -> Q Exp
    parseObjectWithSingleField Map Name (Name, Name, Name)
    tvMap
              SumEncoding
    TwoElemArray ->
                [ do arr <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "array"
                     match (conP 'Array [varP arr])
                           (guardedB
                            [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
                                                             [|(==)|]
                                                             (litE $ integerL 2))
                                         (parse2ElemArray tvMap arr)
                            , liftM2 (,) (normalG [|otherwise|])
                                         ([|not2ElemArray|]
                                           `appE` litE (stringL $ show tName)
                                           `appE` ([|V.length|] `appE` varE arr))
                            ]
                           )
                           []
                , do other <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "other"
                     match (varP other)
                           ( normalB
                             $ [|noArrayFail|]
                                 `appE` litE (stringL $ show tName)
                                 `appE` ([|valueConName|] `appE` varE other)
                           )
                           []
                ]

        parseObject :: (Name -> m Exp) -> [m Match]
    parseObject Name -> m Exp
    f =
            [ do obj <- String -> m Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "obj"
                 match (conP 'Object [varP obj]) (normalB $ f obj) []
            , do other <- String -> m Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "other"
                 match (varP other)
                       ( normalB
                         $ [|noObjectFail|]
                             `appE` litE (stringL $ show tName)
                             `appE` ([|valueConName|] `appE` varE other)
                       )
                       []
            ]

        parseTaggedObject :: Map Name (Name, Name, Name) -> String -> String -> Name -> Q Exp
    parseTaggedObject Map Name (Name, Name, Name)
    tvMap String
    typFieldName String
    valFieldName Name
    obj = do
          conKey <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "conKeyX"
          doE [ bindS (varP conKey)
                      (infixApp (varE obj)
                                [|(.:)|]
                                ([|Key.fromString|] `appE` stringE typFieldName))
              , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|]
              ]

        parseUntaggedValue :: Map Name (Name, Name, Name) -> [ConstructorInfo] -> Name -> Q Exp
    parseUntaggedValue Map Name (Name, Name, Name)
    tvMap [ConstructorInfo]
    cons' Name
    conVal =
            (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 (\Q Exp
    e Q Exp
    e' -> Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    e [|(<|>)|] Q Exp
    e')
                   ((ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\ConstructorInfo
    x -> Map Name (Name, Name, Name) -> ConstructorInfo -> Name -> Q Exp
    parseValue Map Name (Name, Name, Name)
    tvMap ConstructorInfo
    x Name
    conVal) [ConstructorInfo]
    cons')

        parseValue :: Map Name (Name, Name, Name) -> ConstructorInfo -> Name -> Q Exp
    parseValue Map Name (Name, Name, Name)
    _tvMap
            ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                            , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                            , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [] }
            Name
    conVal = do
          str <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "str"
          caseE (varE conVal)
            [ match (conP 'String [varP str])
                    (guardedB
                      [ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)
                                   )
                                   ([|pure|] `appE` conE conName)
                      ]
                    )
                    []
            , matchFailed tName conName "String"
            ]
        parseValue Map Name (Name, Name, Name)
    tvMap ConstructorInfo
    con Name
    conVal =
          Map Name (Name, Name, Name) -> ConstructorInfo -> Q Exp -> Q Exp
    forall {a}.
    Map Name (Name, Name, Name) -> ConstructorInfo -> Q a -> Q a
    checkExi Map Name (Name, Name, Name)
    tvMap ConstructorInfo
    con (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ JSONClass
    -> Map Name (Name, Name, Name)
    -> Name
    -> Options
    -> ConstructorInfo
    -> Either (String, Name) Name
    -> Q Exp
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    opts ConstructorInfo
    con (Name -> Either (String, Name) Name
    forall a b. b -> Either a b
    Right Name
    conVal)

        parse2ElemArray :: Map Name (Name, Name, Name) -> Name -> Q Exp
    parse2ElemArray Map Name (Name, Name, Name)
    tvMap Name
    arr = do
          conKey <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "conKeyY"
          conVal <- newName "conValY"
          let letIx Name
    n Integer
    ix =
                  m Pat -> m Body -> [m Dec] -> m Dec
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Dec
    valD (Name -> m Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    n)
                       (m Exp -> m Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB ([|V.unsafeIndex|] m Exp -> m Exp -> m Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                                   Name -> m Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    arr m Exp -> m Exp -> m Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                                   Lit -> m Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Integer -> Lit
    integerL Integer
    ix)))
                       []
          letE [ letIx conKey 0
               , letIx conVal 1
               ]
               (caseE (varE conKey)
                      [ do txt <- newName "txtY"
                           match (conP 'String [varP txt])
                                 (normalB $ parseContents tvMap
                                                          txt
                                                          (Right conVal)
                                                          'conNotFoundFail2ElemArray
                                                          [|T.pack|] [|T.unpack|]
                                 )
                                 []
                      , do other <- newName "other"
                           match (varP other)
                                 ( normalB
                                   $ [|firstElemNoStringFail|]
                                         `appE` litE (stringL $ show tName)
                                         `appE` ([|valueConName|] `appE` varE other)
                                 )
                                 []
                      ]
               )

        parseObjectWithSingleField :: Map Name (Name, Name, Name) -> Name -> Q Exp
    parseObjectWithSingleField Map Name (Name, Name, Name)
    tvMap Name
    obj = do
          conKey <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "conKeyZ"
          conVal <- newName "conValZ"
          caseE ([e|KM.toList|] `appE` varE obj)
                [ match (listP [tupP [varP conKey, varP conVal]])
                        (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|])
                        []
                , do other <- newName "other"
                     match (varP other)
                           (normalB $ [|wrongPairCountFail|]
                                      `appE` litE (stringL $ show tName)
                                      `appE` ([|show . length|] `appE` varE other)
                           )
                           []
                ]

        parseContents :: Map Name (Name, Name, Name)
    -> Name
    -> Either (String, Name) Name
    -> Name
    -> Q Exp
    -> Q Exp
    -> Q Exp
    parseContents Map Name (Name, Name, Name)
    tvMap Name
    conKey Either (String, Name) Name
    contents Name
    errorFun Q Exp
    pack Q Exp
    unpack=
            Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    conKey)
                  [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP
                          ( [Q (Guard, Exp)] -> Q Body
    forall (m :: * -> *). Quote m => [m (Guard, Exp)] -> m Body
    guardedB ([Q (Guard, Exp)] -> Q Body) -> [Q (Guard, Exp)] -> Q Body
    forall a b. (a -> b) -> a -> b
    $
                            [ do g <- Q Exp -> Q Guard
    forall (m :: * -> *). Quote m => m Exp -> m Guard
    normalG (Q Exp -> Q Guard) -> Q Exp -> Q Guard
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    conKey)
                                                         [|(==)|]
                                                         (Q Exp
    pack Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                                                            Options -> ConstructorInfo -> Q Exp
    conNameExp Options
    opts ConstructorInfo
    con)
                                 e <- checkExi tvMap con $
                                      parseArgs jc tvMap tName opts con contents
                                 return (g, e)
                            | ConstructorInfo
    con <- [ConstructorInfo]
    cons
                            ]
                            [Q (Guard, Exp)] -> [Q (Guard, Exp)] -> [Q (Guard, Exp)]
    forall a. [a] -> [a] -> [a]
    ++
                            [ (Guard -> Exp -> (Guard, Exp))
    -> Q Guard -> Q Exp -> Q (Guard, Exp)
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 (,)
                                     (Q Exp -> Q Guard
    forall (m :: * -> *). Quote m => m Exp -> m Guard
    normalG [e|otherwise|])
                                     ( Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    errorFun
                                       Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (String -> Lit
    stringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    forall a. Show a => a -> String
    show Name
    tName)
                                       Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ((ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map ( Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE
                                                         (Lit -> Q Exp)
    -> (ConstructorInfo -> Lit) -> ConstructorInfo -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Lit
    stringL
                                                         (String -> Lit)
    -> (ConstructorInfo -> String) -> ConstructorInfo -> Lit
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> String -> String
    constructorTagModifier Options
    opts
                                                         (String -> String)
    -> (ConstructorInfo -> String) -> ConstructorInfo -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase
                                                         (Name -> String)
    -> (ConstructorInfo -> Name) -> ConstructorInfo -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConstructorInfo -> Name
    constructorName
                                                         ) [ConstructorInfo]
    cons
                                                    )
                                       Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` (Q Exp
    unpack Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    conKey)
                                     )
                            ]
                          )
                          []
                  ]

    parseNullaryMatches :: Name -> Name -> [Q Match]
    parseNullaryMatches :: Name -> Name -> [Q Match]
    parseNullaryMatches Name
    tName Name
    conName =
        [ do arr <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "arr"
             match (conP 'Array [varP arr])
                   (guardedB
                    [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
                                 ([|pure|] `appE` conE conName)
                    , liftM2 (,) (normalG [|otherwise|])
                                 (parseTypeMismatch tName conName
                                    (litE $ stringL "an empty Array")
                                    (infixApp (litE $ stringL "Array of length ")
                                              [|(++)|]
                                              ([|show . V.length|] `appE` varE arr)
                                    )
                                 )
                    ]
                   )
                   []
        , Name -> Name -> String -> Q Match
    matchFailed Name
    tName Name
    conName String
    "Array"
        ]

    parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
    parseUnaryMatches :: JSONClass
    -> Map Name (Name, Name, Name) -> Type -> Name -> [Q Match]
    parseUnaryMatches JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Type
    argTy Name
    conName =
        [ do arg <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "arg"
             match (varP arg)
                   ( normalB $ infixApp (conE conName)
                                        [|(<$>)|]
                                        (dispatchParseJSON jc conName tvMap argTy
                                          `appE` varE arg)
                   )
                   []
        ]

    parseRecord :: JSONClass
                -> TyVarMap
                -> [Type]
                -> Options
                -> Name
                -> Name
                -> [Name]
                -> Name
                -> Bool
                -> ExpQ
    parseRecord :: JSONClass
    -> Map Name (Name, Name, Name)
    -> [Type]
    -> Options
    -> Name
    -> Name
    -> [Name]
    -> Name
    -> Bool
    -> Q Exp
    parseRecord JSONClass
    jc Map Name (Name, Name, Name)
    tvMap [Type]
    argTys Options
    opts Name
    tName Name
    conName [Name]
    fields Name
    obj Bool
    inTaggedObject =
        (if Options -> Bool
    rejectUnknownFields Options
    opts
         then Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    checkUnknownRecords [|(>>)|]
         else Q Exp -> Q Exp
    forall a. a -> a
    id) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
        (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\Q Exp
    a Q Exp
    b -> Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    a [|(<*>)|] Q Exp
    b)
               (Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName) [|(<$>)|] Q Exp
    x)
               [Q Exp]
    xs
        where
          lookupField :: Type -> Q Exp
          lookupField :: Type -> Q Exp
    lookupField Type
    argTy
            | Options -> Bool
    allowOmittedFields Options
    opts = [| lookupFieldOmit |] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchOmittedField JSONClass
    jc Name
    conName Map Name (Name, Name, Name)
    tvMap Type
    argTy
            | Bool
    otherwise               = [| lookupFieldNoOmit |]

          tagFieldNameAppender :: [String] -> [String]
    tagFieldNameAppender =
              if Bool
    inTaggedObject then (SumEncoding -> String
    tagFieldName (Options -> SumEncoding
    sumEncoding Options
    opts) String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    :) else [String] -> [String]
    forall a. a -> a
    id
          knownFields :: Q Exp
    knownFields = Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|KM.fromList|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
              (String -> Q Exp) -> [String] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\String
    knownName -> [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    tupE [Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|Key.fromString|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    stringL String
    knownName, [|()|]]) ([String] -> [Q Exp]) -> [String] -> [Q Exp]
    forall a b. (a -> b) -> a -> b
    $
                  [String] -> [String]
    tagFieldNameAppender ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ (Name -> String) -> [Name] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Options -> Name -> String
    fieldLabel Options
    opts) [Name]
    fields
          checkUnknownRecords :: Q Exp
    checkUnknownRecords =
              Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|KM.keys|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    obj) [|KM.difference|] Q Exp
    knownFields)
                  [ Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match ([Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => [m Pat] -> m Pat
    listP []) (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB [|return ()|]) []
                  , String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "unknownFields" Q Name -> (Name -> Q Match) -> Q Match
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>=
                      \Name
    unknownFields -> Q Pat -> Q Body -> [Q Dec] -> Q Match
    forall (m :: * -> *).
    Quote m =>
    m Pat -> m Body -> [m Dec] -> m Match
    match (Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    unknownFields)
                          (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|fail|] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp
                              (Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (String -> Lit
    stringL String
    "Unknown fields: "))
                              [|(++)|]
                              (Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE [|show|] (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    unknownFields)))
                          []
                  ]
          Q Exp
    x:[Q Exp]
    xs = [ Type -> Q Exp
    lookupField Type
    argTy
                   Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchParseJSON JSONClass
    jc Name
    conName Map Name (Name, Name, Name)
    tvMap Type
    argTy
                   Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (String -> Lit
    stringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    forall a. Show a => a -> String
    show Name
    tName)
                   Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (String -> Lit
    stringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Options -> String -> String
    constructorTagModifier Options
    opts (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    nameBase Name
    conName)
                   Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    obj
                   Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` ( [|Key.fromString|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Options -> Name -> String
    fieldLabel Options
    opts Name
    field)
                          )
                 | (Name
    field, Type
    argTy) <- [Name] -> [Type] -> [(Name, Type)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    fields [Type]
    argTys
                 ]

    getValField :: Name -> String -> [MatchQ] -> Q Exp
    getValField :: Name -> String -> [Q Match] -> Q Exp
    getValField Name
    obj String
    valFieldName [Q Match]
    matches = do
      val <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "val"
      doE [ bindS (varP val) $ infixApp (varE obj)
                                        [|(.:)|]
                                        ([|Key.fromString|] `appE`
                                           litE (stringL valFieldName))
          , noBindS $ caseE (varE val) matches
          ]

    matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
    matchCases :: Either (String, Name) Name -> [Q Match] -> Q Exp
    matchCases (Left (String
    valFieldName, Name
    obj)) = Name -> String -> [Q Match] -> Q Exp
    getValField Name
    obj String
    valFieldName
    matchCases (Right Name
    valName)            = Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    valName)

    -- | Generates code to parse the JSON encoding of a single constructor.
    parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
              -> TyVarMap -- ^ Maps the last type variables to their decoding
                          --   function arguments.
              -> Name -- ^ Name of the type to which the constructor belongs.
              -> Options -- ^ Encoding options.
              -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
              -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
                                            --   Right valName
              -> Q Exp
    -- Nullary constructors.
    parseArgs :: JSONClass
    -> Map Name (Name, Name, Name)
    -> Name
    -> Options
    -> ConstructorInfo
    -> Either (String, Name) Name
    -> Q Exp
    parseArgs JSONClass
    _ Map Name (Name, Name, Name)
    _ Name
    _ Options
    _
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [] }
      (Left (String, Name)
    _) =
        [|pure|] Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName
    parseArgs JSONClass
    _ Map Name (Name, Name, Name)
    _ Name
    tName Options
    _
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [] }
      (Right Name
    valName) =
        Q Exp -> [Q Match] -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> [m Match] -> m Exp
    caseE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    valName) ([Q Match] -> Q Exp) -> [Q Match] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Name -> [Q Match]
    parseNullaryMatches Name
    tName Name
    conName

    -- Unary constructors.
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    _ Options
    _
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type
    argTy] }
      Either (String, Name) Name
    contents = do
        argTy' <- Type -> Q Type
    resolveTypeSynonyms Type
    argTy
        matchCases contents $ parseUnaryMatches jc tvMap argTy' conName

    -- Polyadic constructors.
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    _
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    NormalConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys }
      Either (String, Name) Name
    contents = do
        argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
        let len = [Type] -> Integer
    forall i a. Num i => [a] -> i
    genericLength [Type]
    argTys'
        matchCases contents $ parseProduct jc tvMap argTys' tName conName len

    -- Records.
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    opts
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = RecordConstructor [Name]
    fields
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys }
      (Left (String
    _, Name
    obj)) = do
        argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
        parseRecord jc tvMap argTys' opts tName conName fields obj True
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    opts
      info :: ConstructorInfo
    info@ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                           , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = RecordConstructor [Name]
    fields
                           , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys }
      (Right Name
    valName) =
        case (Options -> Bool
    unwrapUnaryRecords Options
    opts,[Type]
    argTys) of
          (Bool
    True,[Type
    _])-> JSONClass
    -> Map Name (Name, Name, Name)
    -> Name
    -> Options
    -> ConstructorInfo
    -> Either (String, Name) Name
    -> Q Exp
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    opts
                                 (ConstructorInfo
    info{constructorVariant = NormalConstructor})
                                 (Name -> Either (String, Name) Name
    forall a b. b -> Either a b
    Right Name
    valName)
          (Bool, [Type])
    _ -> do
            obj <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "recObj"
            argTys' <- mapM resolveTypeSynonyms argTys
            caseE (varE valName)
              [ match (conP 'Object [varP obj]) (normalB $
                  parseRecord jc tvMap argTys' opts tName conName fields obj False) []
              , matchFailed tName conName "Object"
              ]

    -- Infix constructors. Apart from syntax these are the same as
    -- polyadic constructors.
    parseArgs JSONClass
    jc Map Name (Name, Name, Name)
    tvMap Name
    tName Options
    _
      ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                      , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    InfixConstructor
                      , constructorFields :: ConstructorInfo -> [Type]
    constructorFields  = [Type]
    argTys }
      Either (String, Name) Name
    contents = do
        argTys' <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    argTys
        matchCases contents $ parseProduct jc tvMap argTys' tName conName 2

    -- | Generates code to parse the JSON encoding of an n-ary
    -- constructor.
    parseProduct :: JSONClass -- ^ The FromJSON variant being derived.
                 -> TyVarMap -- ^ Maps the last type variables to their decoding
                             --   function arguments.
                 -> [Type] -- ^ The argument types of the constructor.
                 -> Name -- ^ Name of the type to which the constructor belongs.
                 -> Name -- ^ 'Con'structor name.
                 -> Integer -- ^ 'Con'structor arity.
                 -> [Q Match]
    parseProduct :: JSONClass
    -> Map Name (Name, Name, Name)
    -> [Type]
    -> Name
    -> Name
    -> Integer
    -> [Q Match]
    parseProduct JSONClass
    jc Map Name (Name, Name, Name)
    tvMap [Type]
    argTys Name
    tName Name
    conName Integer
    numArgs =
        [ do arr <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "arr"
             -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"
             let x:xs = [ dispatchParseJSON jc conName tvMap argTy
                          `appE`
                          infixApp (varE arr)
                                   [|V.unsafeIndex|]
                                   (litE $ integerL ix)
                        | (argTy, ix) <- zip argTys [0 .. numArgs - 1]
                        ]
             match (conP 'Array [varP arr])
                   (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
                                               [|(==)|]
                                               (litE $ integerL numArgs)
                                    )
                                    ( foldl' (\Q Exp
    a Q Exp
    b -> Q Exp -> Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
    infixApp Q Exp
    a [|(<*>)|] Q Exp
    b)
                                             (infixApp (conE conName) [|(<$>)|] x)
                                             xs
                                    )
                                    ( parseTypeMismatch tName conName
                                        (litE $ stringL $ "Array of length " ++ show numArgs)
                                        ( infixApp (litE $ stringL "Array of length ")
                                                   [|(++)|]
                                                   ([|show . V.length|] `appE` varE arr)
                                        )
                                    )
                   )
                   []
        , Name -> Name -> String -> Q Match
    matchFailed Name
    tName Name
    conName String
    "Array"
        ]

    --------------------------------------------------------------------------------
    -- Parsing errors
    --------------------------------------------------------------------------------

    matchFailed :: Name -> Name -> String -> MatchQ
    matchFailed :: Name -> Name -> String -> Q Match
    matchFailed Name
    tName Name
    conName String
    expected = do
      other <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "other"
      match (varP other)
            ( normalB $ parseTypeMismatch tName conName
                          (litE $ stringL expected)
                          ([|valueConName|] `appE` varE other)
            )
            []

    parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ
    parseTypeMismatch :: Name -> Name -> Q Exp -> Q Exp -> Q Exp
    parseTypeMismatch Name
    tName Name
    conName Q Exp
    expected Q Exp
    actual =
        (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> [Q Exp] -> Q Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    appE
              [|parseTypeMismatch'|]
              [ Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    stringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    nameBase Name
    conName
              , Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE (Lit -> Q Exp) -> Lit -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String -> Lit
    stringL (String -> Lit) -> String -> Lit
    forall a b. (a -> b) -> a -> b
    $ Name -> String
    forall a. Show a => a -> String
    show Name
    tName
              , Q Exp
    expected
              , Q Exp
    actual
              ]

    lookupFieldOmit :: Maybe a -> (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
    lookupFieldOmit :: forall a.
    Maybe a
    -> (Value -> Parser a)
    -> String
    -> String
    -> Object
    -> Key
    -> Parser a
    lookupFieldOmit Maybe a
    maybeDefault Value -> Parser a
    pj String
    tName String
    rec Object
    obj Key
    key =
        case Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    KM.lookup Key
    key Object
    obj of
          Maybe Value
    Nothing ->
            case Maybe a
    maybeDefault of
              Maybe a
    Nothing -> String -> String -> String -> Parser a
    forall fail. String -> String -> String -> Parser fail
    unknownFieldFail String
    tName String
    rec (Key -> String
    Key.toString Key
    key)
              Just a
    x -> a -> Parser a
    forall a. a -> Parser a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure a
    x
          Just Value
    v  -> Value -> Parser a
    pj Value
    v Parser a -> JSONPathElement -> Parser a
    forall a. Parser a -> JSONPathElement -> Parser a
    <?> Key -> JSONPathElement
    Key Key
    key

    lookupFieldNoOmit :: (Value -> Parser a) -> String -> String -> Object -> Key -> Parser a
    lookupFieldNoOmit :: forall a.
    (Value -> Parser a)
    -> String -> String -> Object -> Key -> Parser a
    lookupFieldNoOmit Value -> Parser a
    pj String
    tName String
    rec Object
    obj Key
    key =
        case Key -> Object -> Maybe Value
    forall v. Key -> KeyMap v -> Maybe v
    KM.lookup Key
    key Object
    obj of
          Maybe Value
    Nothing -> String -> String -> String -> Parser a
    forall fail. String -> String -> String -> Parser fail
    unknownFieldFail String
    tName String
    rec (Key -> String
    Key.toString Key
    key)
          Just Value
    v  -> Value -> Parser a
    pj Value
    v Parser a -> JSONPathElement -> Parser a
    forall a. Parser a -> JSONPathElement -> Parser a
    <?> Key -> JSONPathElement
    Key Key
    key

    unknownFieldFail :: String -> String -> String -> Parser fail
    unknownFieldFail :: forall fail. String -> String -> String -> Parser fail
    unknownFieldFail String
    tName String
    rec String
    key =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing the record %s of type %s the key %s was not present."
                      String
    rec String
    tName String
    key

    noArrayFail :: String -> String -> Parser fail
    noArrayFail :: forall fail. String -> String -> Parser fail
    noArrayFail String
    t String
    o = String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected Array but got %s." String
    t String
    o

    noObjectFail :: String -> String -> Parser fail
    noObjectFail :: forall fail. String -> String -> Parser fail
    noObjectFail String
    t String
    o = String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected Object but got %s." String
    t String
    o

    firstElemNoStringFail :: String -> String -> Parser fail
    firstElemNoStringFail :: forall fail. String -> String -> Parser fail
    firstElemNoStringFail String
    t String
    o = String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." String
    t String
    o

    wrongPairCountFail :: String -> String -> Parser fail
    wrongPairCountFail :: forall fail. String -> String -> Parser fail
    wrongPairCountFail String
    t String
    n =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."
                      String
    t String
    n

    noStringFail :: String -> String -> Parser fail
    noStringFail :: forall fail. String -> String -> Parser fail
    noStringFail String
    t String
    o = String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected String but got %s." String
    t String
    o

    noMatchFail :: String -> String -> Parser fail
    noMatchFail :: forall fail. String -> String -> Parser fail
    noMatchFail String
    t String
    o =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected a String with the tag of a constructor but got %s." String
    t String
    o

    not2ElemArray :: String -> Int -> Parser fail
    not2ElemArray :: forall fail. String -> Int -> Parser fail
    not2ElemArray String
    t Int
    i = String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> Int -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected an Array of 2 elements but got %i elements" String
    t Int
    i

    conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail
    conNotFoundFail2ElemArray :: forall fail. String -> [String] -> String -> Parser fail
    conNotFoundFail2ElemArray String
    t [String]
    cs String
    o =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."
                      String
    t (String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " [String]
    cs) String
    o

    conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail
    conNotFoundFailObjectSingleField :: forall fail. String -> [String] -> String -> Parser fail
    conNotFoundFailObjectSingleField String
    t [String]
    cs String
    o =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."
                      String
    t (String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " [String]
    cs) String
    o

    conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail
    conNotFoundFailTaggedObject :: forall fail. String -> [String] -> String -> Parser fail
    conNotFoundFailTaggedObject String
    t [String]
    cs String
    o =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."
                      String
    t (String -> [String] -> String
    forall a. [a] -> [[a]] -> [a]
    intercalate String
    ", " [String]
    cs) String
    o

    parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
    parseTypeMismatch' :: forall fail. String -> String -> String -> String -> Parser fail
    parseTypeMismatch' String
    conName String
    tName String
    expected String
    actual =
        String -> Parser fail
    forall a. String -> Parser a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Parser fail) -> String -> Parser fail
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> String -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "When parsing the constructor %s of type %s expected %s but got %s."
                      String
    conName String
    tName String
    expected String
    actual

    --------------------------------------------------------------------------------
    -- Shared ToJSON and FromJSON code
    --------------------------------------------------------------------------------

    -- | Functionality common to 'deriveJSON', 'deriveJSON1', and 'deriveJSON2'.
    deriveJSONBoth :: (Options -> Name -> Q [Dec])
                   -- ^ Function which derives a flavor of 'ToJSON'.
                   -> (Options -> Name -> Q [Dec])
                   -- ^ Function which derives a flavor of 'FromJSON'.
                   -> Options
                   -- ^ Encoding options.
                   -> Name
                   -- ^ Name of the type for which to generate 'ToJSON' and 'FromJSON'
                   -- instances.
                   -> Q [Dec]
    deriveJSONBoth :: (Options -> Name -> Q [Dec])
    -> (Options -> Name -> Q [Dec]) -> Options -> Name -> Q [Dec]
    deriveJSONBoth Options -> Name -> Q [Dec]
    dtj Options -> Name -> Q [Dec]
    dfj Options
    opts Name
    name =
        ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q [Dec] -> Q [Dec]
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 [Dec] -> [Dec] -> [Dec]
    forall a. [a] -> [a] -> [a]
    (++) (Options -> Name -> Q [Dec]
    dtj Options
    opts Name
    name) (Options -> Name -> Q [Dec]
    dfj Options
    opts Name
    name)

    -- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
    deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]
                                            -> [ConstructorInfo] -> Q Exp)]
                    -- ^ The class methods and the functions which derive them.
                    -> JSONClass
                    -- ^ The class for which to generate an instance.
                    -> Options
                    -- ^ Encoding options.
                    -> Name
                    -- ^ Name of the type for which to generate a class instance
                    -- declaration.
                    -> Q [Dec]
    deriveJSONClass :: [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    -> JSONClass -> Options -> Name -> Q [Dec]
    deriveJSONClass [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    consFuns JSONClass
    jc Options
    opts Name
    name = do
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case info of
        DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
    datatypeContext   = [Type]
    ctxt
                     , datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    parentName
                     , datatypeInstTypes :: DatatypeInfo -> [Type]
    datatypeInstTypes = [Type]
    instTys
                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                     } -> do
          (instanceCxt, instanceType)
            <- Name
    -> JSONClass
    -> [Type]
    -> [Type]
    -> DatatypeVariant
    -> Q ([Type], Type)
    buildTypeInstance Name
    parentName JSONClass
    jc [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
          (:[]) <$> instanceD (return instanceCxt)
                              (return instanceType)
                              (methodDecs parentName instTys cons)
      where
        methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
        methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    methodDecs Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons = (((JSONFun,
       JSONClass
       -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
      -> Q Dec)
     -> [(JSONFun,
          JSONClass
          -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
     -> [Q Dec])
    -> [(JSONFun,
         JSONClass
         -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    -> ((JSONFun,
         JSONClass
         -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
        -> Q Dec)
    -> [Q Dec]
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip ((JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
     -> Q Dec)
    -> [(JSONFun,
         JSONClass
         -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map [(JSONFun,
      JSONClass
      -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)]
    consFuns (((JSONFun,
       JSONClass
       -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
      -> Q Dec)
     -> [Q Dec])
    -> ((JSONFun,
         JSONClass
         -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
        -> Q Dec)
    -> [Q Dec]
    forall a b. (a -> b) -> a -> b
    $ \(JSONFun
    jf, JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    jfMaker) ->
          Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD (JSONFun -> Arity -> Name
    jsonFunValName JSONFun
    jf (JSONClass -> Arity
    arity JSONClass
    jc))
               [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause []
                        (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    jfMaker JSONClass
    jc Name
    parentName Options
    opts [Type]
    instTys [ConstructorInfo]
    cons)
                        []
               ]

    mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
                -- ^ The function which derives the expression.
                -> JSONClass
                -- ^ Which class's method is being derived.
                -> Options
                -- ^ Encoding options.
                -> Name
                -- ^ Name of the encoded type.
                -> Q Exp
    mkFunCommon :: (JSONClass
     -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
    -> JSONClass -> Options -> Name -> Q Exp
    mkFunCommon JSONClass
    -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp
    consFun JSONClass
    jc Options
    opts Name
    name = do
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case info of
        DatatypeInfo { datatypeContext :: DatatypeInfo -> [Type]
    datatypeContext   = [Type]
    ctxt
                     , datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    parentName
                     , datatypeInstTypes :: DatatypeInfo -> [Type]
    datatypeInstTypes = [Type]
    instTys
                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                     } -> do
          -- We force buildTypeInstance here since it performs some checks for whether
          -- or not the provided datatype's kind matches the derived method's
          -- typeclass, and produces errors if it can't.
          !_ <- Name
    -> JSONClass
    -> [Type]
    -> [Type]
    -> DatatypeVariant
    -> Q ([Type], Type)
    buildTypeInstance Name
    parentName JSONClass
    jc [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
          consFun jc parentName opts instTys cons

    data FunArg = Omit | Single | Plural deriving (FunArg -> FunArg -> Bool
    (FunArg -> FunArg -> Bool)
    -> (FunArg -> FunArg -> Bool) -> Eq FunArg
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: FunArg -> FunArg -> Bool
    == :: FunArg -> FunArg -> Bool
    $c/= :: FunArg -> FunArg -> Bool
    /= :: FunArg -> FunArg -> Bool
    Eq)

    dispatchFunByType :: JSONClass
                      -> JSONFun
                      -> Name
                      -> TyVarMap
                      -> FunArg -- Plural if we are using the function argument that works
                                -- on lists (e.g., [a] -> Value). Single is we are using
                                -- the function argument that works on single values
                                -- (e.g., a -> Value). Omit if we use it to check omission
                                -- (e.g. a -> Bool)
                      -> Type
                      -> Q Exp
    dispatchFunByType :: JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    _ JSONFun
    jf Name
    _ Map Name (Name, Name, Name)
    tvMap FunArg
    list (VarT Name
    tyName) =
        Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Name -> Q Exp) -> Name -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ case Name -> Map Name (Name, Name, Name) -> Maybe (Name, Name, Name)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup Name
    tyName Map Name (Name, Name, Name)
    tvMap of
                    Just (Name
    tfjoExp, Name
    tfjExp, Name
    tfjlExp) -> case FunArg
    list of
                        FunArg
    Omit -> Name
    tfjoExp
                        FunArg
    Single -> Name
    tfjExp
                        FunArg
    Plural -> Name
    tfjlExp
                    Maybe (Name, Name, Name)
    Nothing                   -> FunArg -> JSONFun -> Arity -> Name
    jsonFunValOrListName FunArg
    list JSONFun
    jf Arity
    Arity0
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap FunArg
    list (SigT Type
    ty Type
    _) =
        JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap FunArg
    list Type
    ty
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap FunArg
    list (ForallT [TyVarBndr Specificity]
    _ [Type]
    _ Type
    ty) =
        JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap FunArg
    list Type
    ty
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap FunArg
    list Type
    ty = do
        let tyCon :: Type
            tyArgs :: [Type]
            Type
    tyCon :| [Type]
    tyArgs = Type -> NonEmpty Type
    unapplyTy Type
    ty

            numLastArgs :: Int
            numLastArgs :: Int
    numLastArgs = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min (JSONClass -> Int
    arityInt JSONClass
    jc) ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    tyArgs)

            lhsArgs, rhsArgs :: [Type]
            ([Type]
    lhsArgs, [Type]
    rhsArgs) = Int -> [Type] -> ([Type], [Type])
    forall a. Int -> [a] -> ([a], [a])
    splitAt ([Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    tyArgs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    numLastArgs) [Type]
    tyArgs

            tyVarNames :: [Name]
            tyVarNames :: [Name]
    tyVarNames = Map Name (Name, Name, Name) -> [Name]
    forall k a. Map k a -> [k]
    M.keys Map Name (Name, Name, Name)
    tvMap

            args :: [Q Exp]
            args :: [Q Exp]
    args
                | FunArg
    list FunArg -> FunArg -> Bool
    forall a. Eq a => a -> a -> Bool
    == FunArg
    Omit = (Type -> Q Exp) -> [Type] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map     (JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap  FunArg
    Omit)                        [Type]
    rhsArgs
                | Bool
    otherwise    = (FunArg -> Type -> Q Exp) -> [FunArg] -> [Type] -> [Q Exp]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    jf Name
    conName Map Name (Name, Name, Name)
    tvMap) ([FunArg] -> [FunArg]
    forall a. HasCallStack => [a] -> [a]
    cycle [FunArg
    Omit,FunArg
    Single,FunArg
    Plural]) ([Type] -> [Type]
    forall a. [a] -> [a]
    triple [Type]
    rhsArgs)

        itf <- [Name] -> Type -> [Type] -> Q Bool
    isInTypeFamilyApp [Name]
    tyVarNames Type
    tyCon [Type]
    tyArgs
        if any (`mentionsName` tyVarNames) lhsArgs || itf
           then outOfPlaceTyVarError jc conName
           else if any (`mentionsName` tyVarNames) rhsArgs
                then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs) : args
                else varE $ jsonFunValOrListName list jf Arity0

    dispatchToJSON :: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
    dispatchToJSON :: ToJSONFun
    -> JSONClass
    -> Name
    -> Map Name (Name, Name, Name)
    -> Type
    -> Q Exp
    dispatchToJSON ToJSONFun
    target JSONClass
    jc Name
    n Map Name (Name, Name, Name)
    tvMap = JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc (ToJSONFun -> JSONFun
    targetToJSONFun ToJSONFun
    target) Name
    n Map Name (Name, Name, Name)
    tvMap FunArg
    Single

    dispatchOmitField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
    dispatchOmitField :: JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchOmitField JSONClass
    jc Name
    n Map Name (Name, Name, Name)
    tvMap = JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    ToJSON Name
    n Map Name (Name, Name, Name)
    tvMap FunArg
    Omit

    dispatchParseJSON :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
    dispatchParseJSON :: JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchParseJSON  JSONClass
    jc Name
    n Map Name (Name, Name, Name)
    tvMap = JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    ParseJSON  Name
    n Map Name (Name, Name, Name)
    tvMap FunArg
    Single

    dispatchOmittedField :: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
    dispatchOmittedField :: JSONClass -> Name -> Map Name (Name, Name, Name) -> Type -> Q Exp
    dispatchOmittedField JSONClass
    jc Name
    n Map Name (Name, Name, Name)
    tvMap = JSONClass
    -> JSONFun
    -> Name
    -> Map Name (Name, Name, Name)
    -> FunArg
    -> Type
    -> Q Exp
    dispatchFunByType JSONClass
    jc JSONFun
    ParseJSON Name
    n Map Name (Name, Name, Name)
    tvMap FunArg
    Omit

    --------------------------------------------------------------------------------
    -- Utility functions
    --------------------------------------------------------------------------------

    -- For the given Types, generate an instance context and head.
    buildTypeInstance :: Name
                      -- ^ The type constructor or data family name
                      -> JSONClass
                      -- ^ The typeclass to derive
                      -> Cxt
                      -- ^ The datatype context
                      -> [Type]
                      -- ^ The types to instantiate the instance with
                      -> DatatypeVariant
                      -- ^ Are we dealing with a data family instance or not
                      -> Q (Cxt, Type)
    buildTypeInstance :: Name
    -> JSONClass
    -> [Type]
    -> [Type]
    -> DatatypeVariant
    -> Q ([Type], Type)
    buildTypeInstance Name
    tyConName JSONClass
    jc [Type]
    dataCxt [Type]
    varTysOrig DatatypeVariant
    variant = do
        -- Make sure to expand through type/kind synonyms! Otherwise, the
        -- eta-reduction check might get tripped up over type variables in a
        -- synonym that are actually dropped.
        -- (See GHC Trac #11416 for a scenario where this actually happened.)
        varTysExp <- (Type -> Q Type) -> [Type] -> Q [Type]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM Type -> Q Type
    resolveTypeSynonyms [Type]
    varTysOrig

        let remainingLength :: Int
            remainingLength = [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    varTysOrig Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - JSONClass -> Int
    arityInt JSONClass
    jc

            droppedTysExp :: [Type]
            droppedTysExp = Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    drop Int
    remainingLength [Type]
    varTysExp

            droppedStarKindStati :: [StarKindStatus]
            droppedStarKindStati = (Type -> StarKindStatus) -> [Type] -> [StarKindStatus]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> StarKindStatus
    canRealizeKindStar [Type]
    droppedTysExp

        -- Check there are enough types to drop and that all of them are either of
        -- kind * or kind k (for some kind variable k). If not, throw an error.
        when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $
          derivingKindError jc tyConName

        let droppedKindVarNames :: [Name]
            droppedKindVarNames = [StarKindStatus] -> [Name]
    catKindVarNames [StarKindStatus]
    droppedStarKindStati

            -- Substitute kind * for any dropped kind variables
            varTysExpSubst :: [Type]
            varTysExpSubst = (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar [Name]
    droppedKindVarNames) [Type]
    varTysExp

            remainingTysExpSubst, droppedTysExpSubst :: [Type]
            (remainingTysExpSubst, droppedTysExpSubst) =
              splitAt remainingLength varTysExpSubst

            -- All of the type variables mentioned in the dropped types
            -- (post-synonym expansion)
            droppedTyVarNames :: [Name]
            droppedTyVarNames = [Type] -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables [Type]
    droppedTysExpSubst

        -- If any of the dropped types were polykinded, ensure that they are of kind *
        -- after substituting * for the dropped kind variables. If not, throw an error.
        unless (all hasKindStar droppedTysExpSubst) $
          derivingKindError jc tyConName

        let preds    :: [Maybe Pred]
            kvNames  :: [[Name]]
            kvNames' :: [Name]
            -- Derive instance constraints (and any kind variables which are specialized
            -- to * in those constraints)
            (preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst
            kvNames' = [[Name]] -> [Name]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Name]]
    kvNames

            -- Substitute the kind variables specialized in the constraints with *
            remainingTysExpSubst' :: [Type]
            remainingTysExpSubst' =
              (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar [Name]
    kvNames') [Type]
    remainingTysExpSubst

            -- We now substitute all of the specialized-to-* kind variable names with
            -- *, but in the original types, not the synonym-expanded types. The reason
            -- we do this is a superficial one: we want the derived instance to resemble
            -- the datatype written in source code as closely as possible. For example,
            -- for the following data family instance:
            --
            --   data family Fam a
            --   newtype instance Fam String = Fam String
            --
            -- We'd want to generate the instance:
            --
            --   instance C (Fam String)
            --
            -- Not:
            --
            --   instance C (Fam [Char])
            remainingTysOrigSubst :: [Type]
            remainingTysOrigSubst =
              (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar ([Name]
    droppedKindVarNames [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    `union` [Name]
    kvNames'))
                ([Type] -> [Type]) -> [Type] -> [Type]
    forall a b. (a -> b) -> a -> b
    $ Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    take Int
    remainingLength [Type]
    varTysOrig

            isDataFamily :: Bool
            isDataFamily = case DatatypeVariant
    variant of
                             DatatypeVariant
    Datatype        -> Bool
    False
                             DatatypeVariant
    Newtype         -> Bool
    False
                             DatatypeVariant
    DataInstance    -> Bool
    True
                             DatatypeVariant
    NewtypeInstance -> Bool
    True
                             DatatypeVariant
    Language.Haskell.TH.Datatype.TypeData -> Bool
    False

            remainingTysOrigSubst' :: [Type]
            -- See Note [Kind signatures in derived instances] for an explanation
            -- of the isDataFamily check.
            remainingTysOrigSubst' =
              if Bool
    isDataFamily
                 then [Type]
    remainingTysOrigSubst
                 else (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Type
    unSigT [Type]
    remainingTysOrigSubst

            instanceCxt :: Cxt
            instanceCxt = [Maybe Type] -> [Type]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Type]
    preds

            instanceType :: Type
            instanceType = Type -> Type -> Type
    AppT (Name -> Type
    ConT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ JSONClass -> Name
    jsonClassName JSONClass
    jc)
                         (Type -> Type) -> Type -> Type
    forall a b. (a -> b) -> a -> b
    $ Name -> [Type] -> Type
    applyTyCon Name
    tyConName [Type]
    remainingTysOrigSubst'

        -- If the datatype context mentions any of the dropped type variables,
        -- we can't derive an instance, so throw an error.
        when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
          datatypeContextError tyConName instanceType
        -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
        -- throw an error.
        unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
          etaReductionError instanceType
        return (instanceCxt, instanceType)

    -- | Attempt to derive a constraint on a Type. If successful, return
    -- Just the constraint and any kind variable names constrained to *.
    -- Otherwise, return Nothing and the empty list.
    --
    -- See Note [Type inference in derived instances] for the heuristics used to
    -- come up with constraints.
    deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])
    deriveConstraint :: JSONClass -> Type -> (Maybe Type, [Name])
    deriveConstraint JSONClass
    jc Type
    t
      | Bool -> Bool
    not (Type -> Bool
    isTyVar Type
    t) = (Maybe Type
    forall a. Maybe a
    Nothing, [])
      | Type -> Bool
    hasKindStar Type
    t   = (Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Name -> Type
    applyCon (Arity -> Name
    jcConstraint Arity
    Arity0) Name
    tName), [])
      | Bool
    otherwise = case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    1 Type
    t of
          Just [Name]
    ns | Arity
    jcArity Arity -> Arity -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Arity
    Arity1
                  -> (Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Name -> Type
    applyCon (Arity -> Name
    jcConstraint Arity
    Arity1) Name
    tName), [Name]
    ns)
          Maybe [Name]
    _ -> case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    2 Type
    t of
               Just [Name]
    ns | Arity
    jcArity Arity -> Arity -> Bool
    forall a. Eq a => a -> a -> Bool
    == Arity
    Arity2
                       -> (Type -> Maybe Type
    forall a. a -> Maybe a
    Just (Name -> Name -> Type
    applyCon (Arity -> Name
    jcConstraint Arity
    Arity2) Name
    tName), [Name]
    ns)
               Maybe [Name]
    _ -> (Maybe Type
    forall a. Maybe a
    Nothing, [])
      where
        tName :: Name
        tName :: Name
    tName = Type -> Name
    varTToName Type
    t

        jcArity :: Arity
        jcArity :: Arity
    jcArity = JSONClass -> Arity
    arity JSONClass
    jc

        jcConstraint :: Arity -> Name
        jcConstraint :: Arity -> Name
    jcConstraint = JSONClass -> Name
    jsonClassName (JSONClass -> Name) -> (Arity -> JSONClass) -> Arity -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Direction -> Arity -> JSONClass
    JSONClass (JSONClass -> Direction
    direction JSONClass
    jc)

    {-
    Note [Kind signatures in derived instances]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    It is possible to put explicit kind signatures into the derived instances, e.g.,

      instance C a => C (Data (f :: * -> *)) where ...

    But it is preferable to avoid this if possible. If we come up with an incorrect
    kind signature (which is entirely possible, since Template Haskell doesn't always
    have the best track record with reifying kind signatures), then GHC will flat-out
    reject the instance, which is quite unfortunate.

    Plain old datatypes have the advantage that you can avoid using any kind signatures
    at all in their instances. This is because a datatype declaration uses all type
    variables, so the types that we use in a derived instance uniquely determine their
    kinds. As long as we plug in the right types, the kind inferencer can do the rest
    of the work. For this reason, we use unSigT to remove all kind signatures before
    splicing in the instance context and head.

    Data family instances are trickier, since a data family can have two instances that
    are distinguished by kind alone, e.g.,

      data family Fam (a :: k)
      data instance Fam (a :: * -> *)
      data instance Fam (a :: *)

    If we dropped the kind signatures for C (Fam a), then GHC will have no way of
    knowing which instance we are talking about. To avoid this scenario, we always
    include explicit kind signatures in data family instances. There is a chance that
    the inferred kind signatures will be incorrect, but if so, we can always fall back
    on the mk- functions.

    Note [Type inference in derived instances]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    Type inference is can be tricky to get right, and we want to avoid recreating the
    entirety of GHC's type inferencer in Template Haskell. For this reason, we will
    probably never come up with derived instance contexts that are as accurate as
    GHC's. But that doesn't mean we can't do anything! There are a couple of simple
    things we can do to make instance contexts that work for 80% of use cases:

    1. If one of the last type parameters is polykinded, then its kind will be
       specialized to * in the derived instance. We note what kind variable the type
       parameter had and substitute it with * in the other types as well. For example,
       imagine you had

         data Data (a :: k) (b :: k)

       Then you'd want to derived instance to be:

         instance C (Data (a :: *))

       Not:

         instance C (Data (a :: k))

    2. We naïvely come up with instance constraints using the following criteria:

       (i)   If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n
             constraint.
       (ii)  If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
             variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if
             k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the
             types. We must consider the case where they are kind variables because
             you might have a scenario like this:

               newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
                 = Compose (f (g a))

             Which would have a derived ToJSON1 instance of:

               instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...
       (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
             * or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint
             and perform kind substitution as in the other cases.
    -}

    checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
                            -> Q a -> Q a
    checkExistentialContext :: forall a.
    JSONClass
    -> Map Name (Name, Name, Name) -> [Type] -> Name -> Q a -> Q a
    checkExistentialContext JSONClass
    jc Map Name (Name, Name, Name)
    tvMap [Type]
    ctxt Name
    conName Q a
    q =
      if ((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `predMentionsName` Map Name (Name, Name, Name) -> [Name]
    forall k a. Map k a -> [k]
    M.keys Map Name (Name, Name, Name)
    tvMap) [Type]
    ctxt
           Bool -> Bool -> Bool
    || Map Name (Name, Name, Name) -> Int
    forall k a. Map k a -> Int
    M.size Map Name (Name, Name, Name)
    tvMap Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < JSONClass -> Int
    arityInt JSONClass
    jc)
           Bool -> Bool -> Bool
    && Bool -> Bool
    not (JSONClass -> Bool
    allowExQuant JSONClass
    jc)
         then Name -> Q a
    forall a. Name -> a
    existentialContextError Name
    conName
         else Q a
    q

    {-
    Note [Matching functions with GADT type variables]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

    When deriving ToJSON2, there is a tricky corner case to consider:

      data Both a b where
        BothCon :: x -> x -> Both x x

    Which encoding functions should be applied to which arguments of BothCon?
    We have a choice, since both the function of type (a -> Value) and of type
    (b -> Value) can be applied to either argument. In such a scenario, the
    second encoding function takes precedence over the first encoding function, so the
    derived ToJSON2 instance would be something like:

      instance ToJSON2 Both where
        liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do
          mv <- unsafeNew 2
          unsafeWrite mv 0 (tj1 x1)
          unsafeWrite mv 1 (tj2 x2)
          return mv

    This is not an arbitrary choice, as this definition ensures that
    liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for
    Both.
    -}

    -- A mapping of type variable Names to their encoding/decoding function Names.
    -- For example, in a ToJSON2 declaration, a TyVarMap might look like
    --
    -- { a ~> (o1, tj1, tjl1)
    -- , b ~> (o2, tj2, tjl2) }
    --
    -- where a and b are the last two type variables of the datatype,
    -- o1 and o2 are function argument of types (a -> Bool),
    -- tj1 and tjl1 are the function arguments of types (a -> Value)
    -- and ([a] -> Value), and tj2 and tjl2 are the function arguments of types (b -> Value) and ([b] -> Value).
    type TyVarMap = Map Name (Name, Name, Name)

    -- | Returns True if a Type has kind *.
    hasKindStar :: Type -> Bool
    hasKindStar :: Type -> Bool
    hasKindStar VarT{}         = Bool
    True
    hasKindStar (SigT Type
    _ Type
    StarT) = Bool
    True
    hasKindStar Type
    _              = Bool
    False

    -- Returns True is a kind is equal to *, or if it is a kind variable.
    isStarOrVar :: Kind -> Bool
    isStarOrVar :: Type -> Bool
    isStarOrVar Type
    StarT  = Bool
    True
    isStarOrVar VarT{} = Bool
    True
    isStarOrVar Type
    _      = Bool
    False

    -- Generate a list of fresh names with a common prefix, and numbered suffixes.
    newNameList :: String -> Int -> Q [Name]
    newNameList :: String -> Int -> Q [Name]
    newNameList String
    prefix Int
    len = (String -> Q Name) -> [String] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName [String
    prefix String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n | Int
    n <- [Int
    1..Int
    len]]

    -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
    -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
    -- kind variables.
    hasKindVarChain :: Int -> Type -> Maybe [Name]
    hasKindVarChain :: Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    kindArrows Type
    t =
      let uk :: NonEmpty Type
    uk = Type -> NonEmpty Type
    uncurryKind (Type -> Type
    tyKind Type
    t)
      in if (NonEmpty Type -> Int
    forall a. NonEmpty a -> Int
    NE.length NonEmpty Type
    uk Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    kindArrows) Bool -> Bool -> Bool
    && (Type -> Bool) -> NonEmpty Type -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    isStarOrVar NonEmpty Type
    uk
            then [Name] -> Maybe [Name]
    forall a. a -> Maybe a
    Just ((Type -> [Name]) -> NonEmpty Type -> [Name]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap Type -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables NonEmpty Type
    uk)
            else Maybe [Name]
    forall a. Maybe a
    Nothing

    -- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
    tyKind :: Type -> Kind
    tyKind :: Type -> Type
    tyKind (SigT Type
    _ Type
    k) = Type
    k
    tyKind Type
    _          = Type
    starK

    -- | Extract Just the Name from a type variable. If the argument Type is not a
    -- type variable, return Nothing.
    varTToNameMaybe :: Type -> Maybe Name
    varTToNameMaybe :: Type -> Maybe Name
    varTToNameMaybe (VarT Name
    n)   = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    varTToNameMaybe (SigT Type
    t Type
    _) = Type -> Maybe Name
    varTToNameMaybe Type
    t
    varTToNameMaybe Type
    _          = Maybe Name
    forall a. Maybe a
    Nothing

    -- | Extract the Name from a type variable. If the argument Type is not a
    -- type variable, throw an error.
    varTToName :: Type -> Name
    varTToName :: Type -> Name
    varTToName = Name -> Maybe Name -> Name
    forall a. a -> Maybe a -> a
    fromMaybe (String -> Name
    forall a. HasCallStack => String -> a
    error String
    "Not a type variable!") (Maybe Name -> Name) -> (Type -> Maybe Name) -> Type -> Name
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Maybe Name
    varTToNameMaybe

    flatten3 :: [(a,a,a)] -> [a]
    flatten3 :: forall a. [(a, a, a)] -> [a]
    flatten3 = ((a, a, a) -> [a] -> [a]) -> [a] -> [(a, a, a)] -> [a]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\(a
    a,a
    b,a
    c) [a]
    xs -> a
    aa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :a
    ba -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :a
    ca -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    xs) []

    triple :: [a] -> [a]
    triple :: forall a. [a] -> [a]
    triple = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\a
    x [a]
    xs -> a
    xa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :a
    xa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :a
    xa -> [a] -> [a]
    forall a. a -> [a] -> [a]
    :[a]
    xs) []

    -- | Fully applies a type constructor to its type variables.
    applyTyCon :: Name -> [Type] -> Type
    applyTyCon :: Name -> [Type] -> Type
    applyTyCon = (Type -> Type -> Type) -> Type -> [Type] -> Type
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Type -> Type -> Type
    AppT (Type -> [Type] -> Type)
    -> (Name -> Type) -> Name -> [Type] -> Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Type
    ConT

    -- | Is the given type a variable?
    isTyVar :: Type -> Bool
    isTyVar :: Type -> Bool
    isTyVar (VarT Name
    _)   = Bool
    True
    isTyVar (SigT Type
    t Type
    _) = Type -> Bool
    isTyVar Type
    t
    isTyVar Type
    _          = Bool
    False

    -- | Detect if a Name in a list of provided Names occurs as an argument to some
    -- type family. This makes an effort to exclude /oversaturated/ arguments to
    -- type families. For instance, if one declared the following type family:
    --
    -- @
    -- type family F a :: Type -> Type
    -- @
    --
    -- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
    -- but not @b@.
    isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
    isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
    isInTypeFamilyApp [Name]
    names Type
    tyFun [Type]
    tyArgs =
      case Type
    tyFun of
        ConT Name
    tcName -> Name -> Q Bool
    go Name
    tcName
        Type
    _           -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
      where
        go :: Name -> Q Bool
        go :: Name -> Q Bool
    go Name
    tcName = do
          info <- Name -> Q Info
    reify Name
    tcName
          case info of
            FamilyI (OpenTypeFamilyD (TypeFamilyHead Name
    _ [TyVarBndr BndrVis]
    bndrs FamilyResultSig
    _ Maybe InjectivityAnn
    _)) [Dec]
    _
              -> [TyVarBndr BndrVis] -> Q Bool
    forall a. [a] -> Q Bool
    withinFirstArgs [TyVarBndr BndrVis]
    bndrs
            FamilyI (ClosedTypeFamilyD (TypeFamilyHead Name
    _ [TyVarBndr BndrVis]
    bndrs FamilyResultSig
    _ Maybe InjectivityAnn
    _) [TySynEqn]
    _) [Dec]
    _
              -> [TyVarBndr BndrVis] -> Q Bool
    forall a. [a] -> Q Bool
    withinFirstArgs [TyVarBndr BndrVis]
    bndrs
            Info
    _ -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
          where
            withinFirstArgs :: [a] -> Q Bool
            withinFirstArgs :: forall a. [a] -> Q Bool
    withinFirstArgs [a]
    bndrs =
              let firstArgs :: [Type]
    firstArgs = Int -> [Type] -> [Type]
    forall a. Int -> [a] -> [a]
    take ([a] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [a]
    bndrs) [Type]
    tyArgs
                  argFVs :: [Name]
    argFVs    = [Type] -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables [Type]
    firstArgs
              in Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool -> Q Bool) -> Bool -> Q Bool
    forall a b. (a -> b) -> a -> b
    $ (Name -> Bool) -> [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Name -> [Name] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    argFVs) [Name]
    names

    -- | Peel off a kind signature from a Type (if it has one).
    unSigT :: Type -> Type
    unSigT :: Type -> Type
    unSigT (SigT Type
    t Type
    _) = Type
    t
    unSigT Type
    t          = Type
    t

    -- | Are all of the items in a list (which have an ordering) distinct?
    --
    -- This uses Set (as opposed to nub) for better asymptotic time complexity.
    allDistinct :: Ord a => [a] -> Bool
    allDistinct :: forall a. Ord a => [a] -> Bool
    allDistinct = Set a -> [a] -> Bool
    forall a. Ord a => Set a -> [a] -> Bool
    allDistinct' Set a
    forall a. Set a
    Set.empty
      where
        allDistinct' :: Ord a => Set a -> [a] -> Bool
        allDistinct' :: forall a. Ord a => Set a -> [a] -> Bool
    allDistinct' Set a
    uniqs (a
    x:[a]
    xs)
            | a
    x a -> Set a -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `Set.member` Set a
    uniqs = Bool
    False
            | Bool
    otherwise            = Set a -> [a] -> Bool
    forall a. Ord a => Set a -> [a] -> Bool
    allDistinct' (a -> Set a -> Set a
    forall a. Ord a => a -> Set a -> Set a
    Set.insert a
    x Set a
    uniqs) [a]
    xs
        allDistinct' Set a
    _ [a]
    _           = Bool
    True

    -- | Does the given type mention any of the Names in the list?
    mentionsName :: Type -> [Name] -> Bool
    mentionsName :: Type -> [Name] -> Bool
    mentionsName = Type -> [Name] -> Bool
    go
      where
        go :: Type -> [Name] -> Bool
        go :: Type -> [Name] -> Bool
    go (AppT Type
    t1 Type
    t2) [Name]
    names = Type -> [Name] -> Bool
    go Type
    t1 [Name]
    names Bool -> Bool -> Bool
    || Type -> [Name] -> Bool
    go Type
    t2 [Name]
    names
        go (SigT Type
    t Type
    _k)  [Name]
    names = Type -> [Name] -> Bool
    go Type
    t [Name]
    names
                                  Bool -> Bool -> Bool
    || Type -> [Name] -> Bool
    go Type
    _k [Name]
    names
        go (VarT Name
    n)     [Name]
    names = Name
    n Name -> [Name] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [Name]
    names
        go Type
    _            [Name]
    _     = Bool
    False

    -- | Does an instance predicate mention any of the Names in the list?
    predMentionsName :: Pred -> [Name] -> Bool
    predMentionsName :: Type -> [Name] -> Bool
    predMentionsName = Type -> [Name] -> Bool
    mentionsName

    -- | Split an applied type into its individual components. For example, this:
    --
    -- @
    -- Either Int Char
    -- @
    --
    -- would split to this:
    --
    -- @
    -- [Either, Int, Char]
    -- @
    unapplyTy :: Type -> NonEmpty Type
    unapplyTy :: Type -> NonEmpty Type
    unapplyTy = NonEmpty Type -> NonEmpty Type
    forall a. NonEmpty a -> NonEmpty a
    NE.reverse (NonEmpty Type -> NonEmpty Type)
    -> (Type -> NonEmpty Type) -> Type -> NonEmpty Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> NonEmpty Type
    go
      where
        go :: Type -> NonEmpty Type
        go :: Type -> NonEmpty Type
    go (AppT Type
    t1 Type
    t2)    = Type
    t2 Type -> NonEmpty Type -> NonEmpty Type
    forall a. a -> NonEmpty a -> NonEmpty a
    <| Type -> NonEmpty Type
    go Type
    t1
        go (SigT Type
    t Type
    _)      = Type -> NonEmpty Type
    go Type
    t
        go (ForallT [TyVarBndr Specificity]
    _ [Type]
    _ Type
    t) = Type -> NonEmpty Type
    go Type
    t
        go Type
    t               = Type
    t Type -> [Type] -> NonEmpty Type
    forall a. a -> [a] -> NonEmpty a
    :| []

    -- | Split a type signature by the arrows on its spine. For example, this:
    --
    -- @
    -- forall a b. (a ~ b) => (a -> b) -> Char -> ()
    -- @
    --
    -- would split to this:
    --
    -- @
    -- (a ~ b, [a -> b, Char, ()])
    -- @
    uncurryTy :: Type -> (Cxt, NonEmpty Type)
    uncurryTy :: Type -> ([Type], NonEmpty Type)
    uncurryTy (AppT (AppT Type
    ArrowT Type
    t1) Type
    t2) =
      let ([Type]
    ctxt, NonEmpty Type
    tys) = Type -> ([Type], NonEmpty Type)
    uncurryTy Type
    t2
      in ([Type]
    ctxt, Type
    t1 Type -> NonEmpty Type -> NonEmpty Type
    forall a. a -> NonEmpty a -> NonEmpty a
    <| NonEmpty Type
    tys)
    uncurryTy (SigT Type
    t Type
    _) = Type -> ([Type], NonEmpty Type)
    uncurryTy Type
    t
    uncurryTy (ForallT [TyVarBndr Specificity]
    _ [Type]
    ctxt Type
    t) =
      let ([Type]
    ctxt', NonEmpty Type
    tys) = Type -> ([Type], NonEmpty Type)
    uncurryTy Type
    t
      in ([Type]
    ctxt [Type] -> [Type] -> [Type]
    forall a. [a] -> [a] -> [a]
    ++ [Type]
    ctxt', NonEmpty Type
    tys)
    uncurryTy Type
    t = ([], Type
    t Type -> [Type] -> NonEmpty Type
    forall a. a -> [a] -> NonEmpty a
    :| [])

    -- | Like uncurryType, except on a kind level.
    uncurryKind :: Kind -> NonEmpty Kind
    uncurryKind :: Type -> NonEmpty Type
    uncurryKind = ([Type], NonEmpty Type) -> NonEmpty Type
    forall a b. (a, b) -> b
    snd (([Type], NonEmpty Type) -> NonEmpty Type)
    -> (Type -> ([Type], NonEmpty Type)) -> Type -> NonEmpty Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> ([Type], NonEmpty Type)
    uncurryTy

    createKindChain :: Int -> Kind
    createKindChain :: Int -> Type
    createKindChain = Type -> Int -> Type
    go Type
    starK
      where
        go :: Kind -> Int -> Kind
        go :: Type -> Int -> Type
    go Type
    k Int
    0 = Type
    k
        go Type
    k !Int
    n = Type -> Int -> Type
    go (Type -> Type -> Type
    AppT (Type -> Type -> Type
    AppT Type
    ArrowT Type
    StarT) Type
    k) (Int
    n Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1)

    -- | Makes a string literal expression from a constructor's name.
    conNameExp :: Options -> ConstructorInfo -> Q Exp
    conNameExp :: Options -> ConstructorInfo -> Q Exp
    conNameExp Options
    opts = Lit -> Q Exp
    forall (m :: * -> *). Quote m => Lit -> m Exp
    litE
                    (Lit -> Q Exp)
    -> (ConstructorInfo -> Lit) -> ConstructorInfo -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Lit
    stringL
                    (String -> Lit)
    -> (ConstructorInfo -> String) -> ConstructorInfo -> Lit
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> String -> String
    constructorTagModifier Options
    opts
                    (String -> String)
    -> (ConstructorInfo -> String) -> ConstructorInfo -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase
                    (Name -> String)
    -> (ConstructorInfo -> Name) -> ConstructorInfo -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ConstructorInfo -> Name
    constructorName

    -- | Extracts a record field label.
    fieldLabel :: Options -- ^ Encoding options
               -> Name
               -> String
    fieldLabel :: Options -> Name -> String
    fieldLabel Options
    opts = Options -> String -> String
    fieldLabelModifier Options
    opts (String -> String) -> (Name -> String) -> Name -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> String
    nameBase

    -- | The name of the outermost 'Value' constructor.
    valueConName :: Value -> String
    valueConName :: Value -> String
    valueConName (Object Object
    _) = String
    "Object"
    valueConName (Array  Array
    _) = String
    "Array"
    valueConName (String Text
    _) = String
    "String"
    valueConName (Number Scientific
    _) = String
    "Number"
    valueConName (Bool   Bool
    _) = String
    "Boolean"
    valueConName Value
    Null       = String
    "Null"

    applyCon :: Name -> Name -> Pred
    applyCon :: Name -> Name -> Type
    applyCon Name
    con Name
    t = Type -> Type -> Type
    AppT (Name -> Type
    ConT Name
    con) (Name -> Type
    VarT Name
    t)

    -- | Checks to see if the last types in a data family instance can be safely eta-
    -- reduced (i.e., dropped), given the other types. This checks for three conditions:
    --
    -- (1) All of the dropped types are type variables
    -- (2) All of the dropped types are distinct
    -- (3) None of the remaining types mention any of the dropped types
    canEtaReduce :: [Type] -> [Type] -> Bool
    canEtaReduce :: [Type] -> [Type] -> Bool
    canEtaReduce [Type]
    remaining [Type]
    dropped =
           (Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    isTyVar [Type]
    dropped
        Bool -> Bool -> Bool
    && [Name] -> Bool
    forall a. Ord a => [a] -> Bool
    allDistinct [Name]
    droppedNames -- Make sure not to pass something of type [Type], since Type
                                    -- didn't have an Ord instance until template-haskell-2.10.0.0
        Bool -> Bool -> Bool
    && Bool -> Bool
    not ((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `mentionsName` [Name]
    droppedNames) [Type]
    remaining)
      where
        droppedNames :: [Name]
        droppedNames :: [Name]
    droppedNames = (Type -> Name) -> [Type] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Name
    varTToName [Type]
    dropped

    -------------------------------------------------------------------------------
    -- Expanding type synonyms
    -------------------------------------------------------------------------------

    applySubstitutionKind :: Map Name Kind -> Type -> Type
    applySubstitutionKind :: Map Name Type -> Type -> Type
    applySubstitutionKind = Map Name Type -> Type -> Type
    forall a. TypeSubstitution a => Map Name Type -> a -> a
    applySubstitution

    substNameWithKind :: Name -> Kind -> Type -> Type
    substNameWithKind :: Name -> Type -> Type -> Type
    substNameWithKind Name
    n Type
    k = Map Name Type -> Type -> Type
    applySubstitutionKind (Name -> Type -> Map Name Type
    forall k a. k -> a -> Map k a
    M.singleton Name
    n Type
    k)

    substNamesWithKindStar :: [Name] -> Type -> Type
    substNamesWithKindStar :: [Name] -> Type -> Type
    substNamesWithKindStar [Name]
    ns Type
    t = (Name -> Type -> Type) -> Type -> [Name] -> Type
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr' (Name -> Type -> Type -> Type
    `substNameWithKind` Type
    starK) Type
    t [Name]
    ns

    -------------------------------------------------------------------------------
    -- Error messages
    -------------------------------------------------------------------------------

    -- | Either the given data type doesn't have enough type variables, or one of
    -- the type variables to be eta-reduced cannot realize kind *.
    derivingKindError :: JSONClass -> Name -> Q a
    derivingKindError :: forall a. JSONClass -> Name -> Q a
    derivingKindError JSONClass
    jc Name
    tyConName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> (String -> String) -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "Cannot derive well-kinded instance of form ‘"
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    className
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    showChar Char
    ' '
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> (String -> String) -> String -> String
    showParen Bool
    True
        ( String -> String -> String
    showString (Name -> String
    nameBase Name
    tyConName)
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    " ..."
        )
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "‘\n\tClass "
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    className
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    " expects an argument of kind "
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString (Type -> String
    forall a. Ppr a => a -> String
    pprint (Type -> String) -> (Int -> Type) -> Int -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> Type
    createKindChain (Int -> String) -> Int -> String
    forall a b. (a -> b) -> a -> b
    $ JSONClass -> Int
    arityInt JSONClass
    jc)
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""
      where
        className :: String
        className :: String
    className = Name -> String
    nameBase (Name -> String) -> Name -> String
    forall a b. (a -> b) -> a -> b
    $ JSONClass -> Name
    jsonClassName JSONClass
    jc

    -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
    -- function for the criteria it would have to meet).
    etaReductionError :: Type -> Q a
    etaReductionError :: forall a. Type -> Q a
    etaReductionError Type
    instanceType = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $
        String
    "Cannot eta-reduce to an instance of form \n\tinstance (...) => "
        String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType

    -- | The data type has a DatatypeContext which mentions one of the eta-reduced
    -- type variables.
    datatypeContextError :: Name -> Type -> Q a
    datatypeContextError :: forall a. Name -> Type -> Q a
    datatypeContextError Name
    dataName Type
    instanceType = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
        (String -> Q a) -> (String -> String) -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "Can't make a derived instance of ‘"
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString (Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType)
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "‘:\n\tData type ‘"
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString (Name -> String
    nameBase Name
    dataName)
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "‘ must not have a class context involving the last type argument(s)"
        (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -- | The data type mentions one of the n eta-reduced type variables in a place other
    -- than the last nth positions of a data type in a constructor's field.
    outOfPlaceTyVarError :: JSONClass -> Name -> a
    outOfPlaceTyVarError :: forall a. JSONClass -> Name -> a
    outOfPlaceTyVarError JSONClass
    jc Name
    conName = String -> a
    forall a. HasCallStack => String -> a
    error
        (String -> a) -> (String -> String) -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "Constructor ‘"
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString (Name -> String
    nameBase Name
    conName)
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "‘ must only use its last "
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    forall a. Show a => a -> String -> String
    shows Int
    n
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    " type variable(s) within the last "
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    forall a. Show a => a -> String -> String
    shows Int
    n
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    " argument(s) of a data type"
        (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ String
    ""
      where
        n :: Int
        n :: Int
    n = JSONClass -> Int
    arityInt JSONClass
    jc

    -- | The data type has an existential constraint which mentions one of the
    -- eta-reduced type variables.
    existentialContextError :: Name -> a
    existentialContextError :: forall a. Name -> a
    existentialContextError Name
    conName = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> (String -> String) -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "Constructor ‘"
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString (Name -> String
    nameBase Name
    conName)
      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    showString String
    "‘ must be truly polymorphic in the last argument(s) of the data type"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -------------------------------------------------------------------------------
    -- Class-specific constants
    -------------------------------------------------------------------------------

    -- | A representation of the arity of the ToJSON/FromJSON typeclass being derived.
    data Arity = Arity0 | Arity1 | Arity2
      deriving (Int -> Arity
    Arity -> Int
    Arity -> [Arity]
    Arity -> Arity
    Arity -> Arity -> [Arity]
    Arity -> Arity -> Arity -> [Arity]
    (Arity -> Arity)
    -> (Arity -> Arity)
    -> (Int -> Arity)
    -> (Arity -> Int)
    -> (Arity -> [Arity])
    -> (Arity -> Arity -> [Arity])
    -> (Arity -> Arity -> [Arity])
    -> (Arity -> Arity -> Arity -> [Arity])
    -> Enum Arity
    forall a.
    (a -> a)
    -> (a -> a)
    -> (Int -> a)
    -> (a -> Int)
    -> (a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> a -> [a])
    -> Enum a
    $csucc :: Arity -> Arity
    succ :: Arity -> Arity
    $cpred :: Arity -> Arity
    pred :: Arity -> Arity
    $ctoEnum :: Int -> Arity
    toEnum :: Int -> Arity
    $cfromEnum :: Arity -> Int
    fromEnum :: Arity -> Int
    $cenumFrom :: Arity -> [Arity]
    enumFrom :: Arity -> [Arity]
    $cenumFromThen :: Arity -> Arity -> [Arity]
    enumFromThen :: Arity -> Arity -> [Arity]
    $cenumFromTo :: Arity -> Arity -> [Arity]
    enumFromTo :: Arity -> Arity -> [Arity]
    $cenumFromThenTo :: Arity -> Arity -> Arity -> [Arity]
    enumFromThenTo :: Arity -> Arity -> Arity -> [Arity]
    Enum, Arity -> Arity -> Bool
    (Arity -> Arity -> Bool) -> (Arity -> Arity -> Bool) -> Eq Arity
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Arity -> Arity -> Bool
    == :: Arity -> Arity -> Bool
    $c/= :: Arity -> Arity -> Bool
    /= :: Arity -> Arity -> Bool
    Eq, Eq Arity
    Eq Arity =>
    (Arity -> Arity -> Ordering)
    -> (Arity -> Arity -> Bool)
    -> (Arity -> Arity -> Bool)
    -> (Arity -> Arity -> Bool)
    -> (Arity -> Arity -> Bool)
    -> (Arity -> Arity -> Arity)
    -> (Arity -> Arity -> Arity)
    -> Ord Arity
    Arity -> Arity -> Bool
    Arity -> Arity -> Ordering
    Arity -> Arity -> Arity
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Arity -> Arity -> Ordering
    compare :: Arity -> Arity -> Ordering
    $c< :: Arity -> Arity -> Bool
    < :: Arity -> Arity -> Bool
    $c<= :: Arity -> Arity -> Bool
    <= :: Arity -> Arity -> Bool
    $c> :: Arity -> Arity -> Bool
    > :: Arity -> Arity -> Bool
    $c>= :: Arity -> Arity -> Bool
    >= :: Arity -> Arity -> Bool
    $cmax :: Arity -> Arity -> Arity
    max :: Arity -> Arity -> Arity
    $cmin :: Arity -> Arity -> Arity
    min :: Arity -> Arity -> Arity
    Ord)

    -- | Whether ToJSON(1)(2) or FromJSON(1)(2) is being derived.
    data Direction = To | From

    -- | A representation of which typeclass method is being spliced in.
    data JSONFun = ToJSON | ToEncoding | ParseJSON

    -- | A refinement of JSONFun to [ToJSON, ToEncoding].
    data ToJSONFun = Value | Encoding

    targetToJSONFun :: ToJSONFun -> JSONFun
    targetToJSONFun :: ToJSONFun -> JSONFun
    targetToJSONFun ToJSONFun
    Value = JSONFun
    ToJSON
    targetToJSONFun ToJSONFun
    Encoding = JSONFun
    ToEncoding

    -- | A representation of which typeclass is being derived.
    data JSONClass = JSONClass { JSONClass -> Direction
    direction :: Direction, JSONClass -> Arity
    arity :: Arity }

    toJSONClass, toJSON1Class, toJSON2Class,
        fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass
    toJSONClass :: JSONClass
    toJSONClass    = Direction -> Arity -> JSONClass
    JSONClass Direction
    To   Arity
    Arity0
    toJSON1Class :: JSONClass
    toJSON1Class   = Direction -> Arity -> JSONClass
    JSONClass Direction
    To   Arity
    Arity1
    toJSON2Class :: JSONClass
    toJSON2Class   = Direction -> Arity -> JSONClass
    JSONClass Direction
    To   Arity
    Arity2
    fromJSONClass :: JSONClass
    fromJSONClass  = Direction -> Arity -> JSONClass
    JSONClass Direction
    From Arity
    Arity0
    fromJSON1Class :: JSONClass
    fromJSON1Class = Direction -> Arity -> JSONClass
    JSONClass Direction
    From Arity
    Arity1
    fromJSON2Class :: JSONClass
    fromJSON2Class = Direction -> Arity -> JSONClass
    JSONClass Direction
    From Arity
    Arity2

    jsonClassName :: JSONClass -> Name
    jsonClassName :: JSONClass -> Name
    jsonClassName (JSONClass Direction
    To   Arity
    Arity0) = ''ToJSON
    jsonClassName (JSONClass Direction
    To   Arity
    Arity1) = ''ToJSON1
    jsonClassName (JSONClass Direction
    To   Arity
    Arity2) = ''ToJSON2
    jsonClassName (JSONClass Direction
    From Arity
    Arity0) = ''FromJSON
    jsonClassName (JSONClass Direction
    From Arity
    Arity1) = ''FromJSON1
    jsonClassName (JSONClass Direction
    From Arity
    Arity2) = ''FromJSON2

    jsonFunOmitName :: JSONFun -> Arity -> Name
    jsonFunOmitName :: JSONFun -> Arity -> Name
    jsonFunOmitName JSONFun
    ToJSON     Arity
    Arity0 = 'omitField
    jsonFunOmitName JSONFun
    ToJSON     Arity
    Arity1 = 'liftOmitField
    jsonFunOmitName JSONFun
    ToJSON     Arity
    Arity2 = 'liftOmitField2
    jsonFunOmitName JSONFun
    ToEncoding Arity
    Arity0 = 'omitField
    jsonFunOmitName JSONFun
    ToEncoding Arity
    Arity1 = 'liftOmitField
    jsonFunOmitName JSONFun
    ToEncoding Arity
    Arity2 = 'liftOmitField2
    jsonFunOmitName JSONFun
    ParseJSON  Arity
    Arity0 = 'omittedField
    jsonFunOmitName JSONFun
    ParseJSON  Arity
    Arity1 = 'liftOmittedField
    jsonFunOmitName JSONFun
    ParseJSON  Arity
    Arity2 = 'liftOmittedField2

    jsonFunValName :: JSONFun -> Arity -> Name
    jsonFunValName :: JSONFun -> Arity -> Name
    jsonFunValName JSONFun
    ToJSON     Arity
    Arity0 = 'toJSON
    jsonFunValName JSONFun
    ToJSON     Arity
    Arity1 = 'liftToJSON
    jsonFunValName JSONFun
    ToJSON     Arity
    Arity2 = 'liftToJSON2
    jsonFunValName JSONFun
    ToEncoding Arity
    Arity0 = 'toEncoding
    jsonFunValName JSONFun
    ToEncoding Arity
    Arity1 = 'liftToEncoding
    jsonFunValName JSONFun
    ToEncoding Arity
    Arity2 = 'liftToEncoding2
    jsonFunValName JSONFun
    ParseJSON  Arity
    Arity0 = 'parseJSON
    jsonFunValName JSONFun
    ParseJSON  Arity
    Arity1 = 'liftParseJSON
    jsonFunValName JSONFun
    ParseJSON  Arity
    Arity2 = 'liftParseJSON2

    jsonFunListName :: JSONFun -> Arity -> Name
    jsonFunListName :: JSONFun -> Arity -> Name
    jsonFunListName JSONFun
    ToJSON     Arity
    Arity0 = 'toJSONList
    jsonFunListName JSONFun
    ToJSON     Arity
    Arity1 = 'liftToJSONList
    jsonFunListName JSONFun
    ToJSON     Arity
    Arity2 = 'liftToJSONList2
    jsonFunListName JSONFun
    ToEncoding Arity
    Arity0 = 'toEncodingList
    jsonFunListName JSONFun
    ToEncoding Arity
    Arity1 = 'liftToEncodingList
    jsonFunListName JSONFun
    ToEncoding Arity
    Arity2 = 'liftToEncodingList2
    jsonFunListName JSONFun
    ParseJSON  Arity
    Arity0 = 'parseJSONList
    jsonFunListName JSONFun
    ParseJSON  Arity
    Arity1 = 'liftParseJSONList
    jsonFunListName JSONFun
    ParseJSON  Arity
    Arity2 = 'liftParseJSONList2

    jsonFunValOrListName :: FunArg -- e.g., toJSONList if True, toJSON if False
                         -> JSONFun -> Arity -> Name
    jsonFunValOrListName :: FunArg -> JSONFun -> Arity -> Name
    jsonFunValOrListName FunArg
    Omit   = JSONFun -> Arity -> Name
    jsonFunOmitName
    jsonFunValOrListName FunArg
    Single = JSONFun -> Arity -> Name
    jsonFunValName
    jsonFunValOrListName FunArg
    Plural = JSONFun -> Arity -> Name
    jsonFunListName

    arityInt :: JSONClass -> Int
    arityInt :: JSONClass -> Int
    arityInt = Arity -> Int
    forall a. Enum a => a -> Int
    fromEnum (Arity -> Int) -> (JSONClass -> Arity) -> JSONClass -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . JSONClass -> Arity
    arity

    allowExQuant :: JSONClass -> Bool
    allowExQuant :: JSONClass -> Bool
    allowExQuant (JSONClass Direction
    To Arity
    _) = Bool
    True
    allowExQuant JSONClass
    _                = Bool
    False

    -------------------------------------------------------------------------------
    -- StarKindStatus
    -------------------------------------------------------------------------------

    -- | Whether a type is not of kind *, is of kind *, or is a kind variable.
    data StarKindStatus = NotKindStar
                        | KindStar
                        | IsKindVar Name
      deriving StarKindStatus -> StarKindStatus -> Bool
    (StarKindStatus -> StarKindStatus -> Bool)
    -> (StarKindStatus -> StarKindStatus -> Bool) -> Eq StarKindStatus
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: StarKindStatus -> StarKindStatus -> Bool
    == :: StarKindStatus -> StarKindStatus -> Bool
    $c/= :: StarKindStatus -> StarKindStatus -> Bool
    /= :: StarKindStatus -> StarKindStatus -> Bool
    Eq

    -- | Does a Type have kind * or k (for some kind variable k)?
    canRealizeKindStar :: Type -> StarKindStatus
    canRealizeKindStar :: Type -> StarKindStatus
    canRealizeKindStar Type
    t = case Type
    t of
        Type
    _ | Type -> Bool
    hasKindStar Type
    t -> StarKindStatus
    KindStar
        SigT Type
    _ (VarT Name
    k) -> Name -> StarKindStatus
    IsKindVar Name
    k
        Type
    _ -> StarKindStatus
    NotKindStar

    -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.
    -- Otherwise, returns 'Nothing'.
    starKindStatusToName :: StarKindStatus -> Maybe Name
    starKindStatusToName :: StarKindStatus -> Maybe Name
    starKindStatusToName (IsKindVar Name
    n) = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    n
    starKindStatusToName StarKindStatus
    _             = Maybe Name
    forall a. Maybe a
    Nothing

    -- | Concat together all of the StarKindStatuses that are IsKindVar and extract
    -- the kind variables' Names out.
    catKindVarNames :: [StarKindStatus] -> [Name]
    catKindVarNames :: [StarKindStatus] -> [Name]
    catKindVarNames = (StarKindStatus -> Maybe Name) -> [StarKindStatus] -> [Name]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe StarKindStatus -> Maybe Name
    starKindStatusToName