    {-# LANGUAGE CPP #-}
    {-# LANGUAGE BangPatterns #-}
    {-# LANGUAGE PatternGuards #-}
    {-# LANGUAGE ScopedTypeVariables #-}

    #if __GLASGOW_HASKELL__ >= 704
    {-# LANGUAGE Unsafe #-}
    #endif

    #ifndef MIN_VERSION_template_haskell
    #define MIN_VERSION_template_haskell(x,y,z) 1
    #endif
    -----------------------------------------------------------------------------
    -- |
    -- Copyright   :  (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
    -- Stability   :  provisional
    -- Portability :  portable
    --
    -- Functions to mechanically derive 'Bifunctor', 'Bifoldable',
    -- or 'Bitraversable' instances, or to splice their functions directly into
    -- source code. You need to enable the @TemplateHaskell@ language extension
    -- in order to use this module.
    ----------------------------------------------------------------------------

    module Data.Bifunctor.TH (
        -- * @derive@- functions
        -- $derive
        -- * @make@- functions
        -- $make
        -- * 'Bifunctor'
        deriveBifunctor
      , deriveBifunctorOptions
      , makeBimap
      , makeBimapOptions
        -- * 'Bifoldable'
      , deriveBifoldable
      , deriveBifoldableOptions
      , makeBifold
      , makeBifoldOptions
      , makeBifoldMap
      , makeBifoldMapOptions
      , makeBifoldr
      , makeBifoldrOptions
      , makeBifoldl
      , makeBifoldlOptions
        -- * 'Bitraversable'
      , deriveBitraversable
      , deriveBitraversableOptions
      , makeBitraverse
      , makeBitraverseOptions
      , makeBisequenceA
      , makeBisequenceAOptions
      , makeBimapM
      , makeBimapMOptions
      , makeBisequence
      , makeBisequenceOptions
        -- * 'Options'
      , Options(..)
      , defaultOptions
      ) where

    import           Control.Monad (guard, unless, when)

    import           Data.Bifunctor.TH.Internal
    import qualified Data.List as List
    import qualified Data.Map as Map ((!), fromList, keys, lookup, member, size)
    import           Data.Maybe

    import           Language.Haskell.TH.Datatype as Datatype
    import           Language.Haskell.TH.Datatype.TyVarBndr
    import           Language.Haskell.TH.Lib
    import           Language.Haskell.TH.Ppr
    import           Language.Haskell.TH.Syntax

    -------------------------------------------------------------------------------
    -- User-facing API
    -------------------------------------------------------------------------------

    -- | Options that further configure how the functions in "Data.Bifunctor.TH"
    -- should behave.
    newtype Options = Options
      { Options -> Bool
    emptyCaseBehavior :: Bool
        -- ^ If 'True', derived instances for empty data types (i.e., ones with
        --   no data constructors) will use the @EmptyCase@ language extension.
        --   If 'False', derived instances will simply use 'seq' instead.
        --   (This has no effect on GHCs before 7.8, since @EmptyCase@ is only
        --   available in 7.8 or later.)
      } deriving (Options -> Options -> Bool
    (Options -> Options -> Bool)
    -> (Options -> Options -> Bool) -> Eq Options
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Options -> Options -> Bool
    == :: Options -> Options -> Bool
    $c/= :: Options -> Options -> Bool
    /= :: Options -> Options -> Bool
    Eq, Eq Options
    Eq Options
    -> (Options -> Options -> Ordering)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Bool)
    -> (Options -> Options -> Options)
    -> (Options -> Options -> Options)
    -> Ord Options
    Options -> Options -> Bool
    Options -> Options -> Ordering
    Options -> Options -> Options
    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 :: Options -> Options -> Ordering
    compare :: Options -> Options -> Ordering
    $c< :: Options -> Options -> Bool
    < :: Options -> Options -> Bool
    $c<= :: Options -> Options -> Bool
    <= :: Options -> Options -> Bool
    $c> :: Options -> Options -> Bool
    > :: Options -> Options -> Bool
    $c>= :: Options -> Options -> Bool
    >= :: Options -> Options -> Bool
    $cmax :: Options -> Options -> Options
    max :: Options -> Options -> Options
    $cmin :: Options -> Options -> Options
    min :: Options -> Options -> Options
    Ord, ReadPrec [Options]
    ReadPrec Options
    Int -> ReadS Options
    ReadS [Options]
    (Int -> ReadS Options)
    -> ReadS [Options]
    -> ReadPrec Options
    -> ReadPrec [Options]
    -> Read Options
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS Options
    readsPrec :: Int -> ReadS Options
    $creadList :: ReadS [Options]
    readList :: ReadS [Options]
    $creadPrec :: ReadPrec Options
    readPrec :: ReadPrec Options
    $creadListPrec :: ReadPrec [Options]
    readListPrec :: ReadPrec [Options]
    Read, Int -> Options -> ShowS
    [Options] -> ShowS
    Options -> String
    (Int -> Options -> ShowS)
    -> (Options -> String) -> ([Options] -> ShowS) -> Show Options
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Options -> ShowS
    showsPrec :: Int -> Options -> ShowS
    $cshow :: Options -> String
    show :: Options -> String
    $cshowList :: [Options] -> ShowS
    showList :: [Options] -> ShowS
    Show)

    -- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to
    -- prevent users from having to enable that extension at use sites.)
    defaultOptions :: Options
    defaultOptions :: Options
    defaultOptions = Options { emptyCaseBehavior :: Bool
    emptyCaseBehavior = Bool
    False }

    {- $derive

    'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically
    generate their respective class instances for a given data type, newtype, or data
    family instance that has at least two type variable. Examples:

    @
    &#123;-&#35; LANGUAGE TemplateHaskell &#35;-&#125;
    import Data.Bifunctor.TH

    data Pair a b = Pair a b
    $('deriveBifunctor' ''Pair) -- instance Bifunctor Pair where ...

    data WrapLeftPair f g a b = WrapLeftPair (f a) (g a b)
    $('deriveBifoldable' ''WrapLeftPair)
    -- instance (Foldable f, Bifoldable g) => Bifoldable (WrapLeftPair f g) where ...
    @

    If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later),
    the @derive@ functions can be used data family instances (which requires the
    @-XTypeFamilies@ extension). To do so, pass the name of a data or newtype instance
    constructor (NOT a data family name!) to a @derive@ function.  Note that the
    generated code may require the @-XFlexibleInstances@ extension. Example:

    @
    &#123;-&#35; LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies &#35;-&#125;
    import Data.Bifunctor.TH

    class AssocClass a b c where
        data AssocData a b c
    instance AssocClass Int b c where
        data AssocData Int b c = AssocDataInt1 Int | AssocDataInt2 b c
    $('deriveBitraversable' 'AssocDataInt1) -- instance Bitraversable (AssocData Int) where ...
    -- Alternatively, one could use $(deriveBitraversable 'AssocDataInt2)
    @

    Note that there are some limitations:

    * The 'Name' argument to a @derive@ function must not be a type synonym.

    * With a @derive@ function, the last two type variables must both be of kind @*@.
      Other type variables of kind @* -> *@ are assumed to require a 'Functor',
      'Foldable', or 'Traversable' constraint (depending on which @derive@ function is
      used), and other type variables of kind @* -> * -> *@ are assumed to require an
      'Bifunctor', 'Bifoldable', or 'Bitraversable' constraint. If your data type
      doesn't meet these assumptions, use a @make@ function.

    * If using the @-XDatatypeContexts@, @-XExistentialQuantification@, or @-XGADTs@
      extensions, a constraint cannot mention either of the last two type variables. For
      example, @data Illegal2 a b where I2 :: Ord a => a -> b -> Illegal2 a b@ cannot
      have a derived 'Bifunctor' instance.

    * If either of the last two type variables is used within a constructor argument's
      type, it must only be used in the last two type arguments. For example,
      @data Legal a b = Legal (Int, Int, a, b)@ can have a derived 'Bifunctor' instance,
      but @data Illegal a b = Illegal (a, b, a, b)@ cannot.

    * Data family instances must be able to eta-reduce the last two type variables. In other
      words, if you have a instance of the form:

      @
      data family Family a1 ... an t1 t2
      data instance Family e1 ... e2 v1 v2 = ...
      @

      Then the following conditions must hold:

      1. @v1@ and @v2@ must be distinct type variables.
      2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@.

    -}

    {- $make

    There may be scenarios in which you want to, say, 'bimap' over an arbitrary data type
    or data family instance without having to make the type an instance of 'Bifunctor'. For
    these cases, this module provides several functions (all prefixed with @make@-) that
    splice the appropriate lambda expression into your source code.

    This is particularly useful for creating instances for sophisticated data types. For
    example, 'deriveBifunctor' cannot infer the correct type context for
    @newtype HigherKinded f a b c = HigherKinded (f a b c)@, since @f@ is of kind
    @* -> * -> * -> *@. However, it is still possible to create a 'Bifunctor' instance for
    @HigherKinded@ without too much trouble using 'makeBimap':

    @
    &#123;-&#35; LANGUAGE FlexibleContexts, TemplateHaskell &#35;-&#125;
    import Data.Bifunctor
    import Data.Bifunctor.TH

    newtype HigherKinded f a b c = HigherKinded (f a b c)

    instance Bifunctor (f a) => Bifunctor (HigherKinded f a) where
        bimap = $(makeBimap ''HigherKinded)
    @

    -}

    -- | Generates a 'Bifunctor' instance declaration for the given data type or data
    -- family instance.
    deriveBifunctor :: Name -> Q [Dec]
    deriveBifunctor :: Name -> Q [Dec]
    deriveBifunctor = Options -> Name -> Q [Dec]
    deriveBifunctorOptions Options
    defaultOptions

    -- | Like 'deriveBifunctor', but takes an 'Options' argument.
    deriveBifunctorOptions :: Options -> Name -> Q [Dec]
    deriveBifunctorOptions :: Options -> Name -> Q [Dec]
    deriveBifunctorOptions = BiClass -> Options -> Name -> Q [Dec]
    deriveBiClass BiClass
    Bifunctor

    -- | Generates a lambda expression which behaves like 'bimap' (without requiring a
    -- 'Bifunctor' instance).
    makeBimap :: Name -> Q Exp
    makeBimap :: Name -> Q Exp
    makeBimap = Options -> Name -> Q Exp
    makeBimapOptions Options
    defaultOptions

    -- | Like 'makeBimap', but takes an 'Options' argument.
    makeBimapOptions :: Options -> Name -> Q Exp
    makeBimapOptions :: Options -> Name -> Q Exp
    makeBimapOptions = BiFun -> Options -> Name -> Q Exp
    makeBiFun BiFun
    Bimap

    -- | Generates a 'Bifoldable' instance declaration for the given data type or data
    -- family instance.
    deriveBifoldable :: Name -> Q [Dec]
    deriveBifoldable :: Name -> Q [Dec]
    deriveBifoldable = Options -> Name -> Q [Dec]
    deriveBifoldableOptions Options
    defaultOptions

    -- | Like 'deriveBifoldable', but takes an 'Options' argument.
    deriveBifoldableOptions :: Options -> Name -> Q [Dec]
    deriveBifoldableOptions :: Options -> Name -> Q [Dec]
    deriveBifoldableOptions = BiClass -> Options -> Name -> Q [Dec]
    deriveBiClass BiClass
    Bifoldable

    --- | Generates a lambda expression which behaves like 'bifold' (without requiring a
    -- 'Bifoldable' instance).
    makeBifold :: Name -> Q Exp
    makeBifold :: Name -> Q Exp
    makeBifold = Options -> Name -> Q Exp
    makeBifoldOptions Options
    defaultOptions

    -- | Like 'makeBifold', but takes an 'Options' argument.
    makeBifoldOptions :: Options -> Name -> Q Exp
    makeBifoldOptions :: Options -> Name -> Q Exp
    makeBifoldOptions Options
    opts Name
    name = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ Options -> Name -> Q Exp
    makeBifoldMapOptions Options
    opts Name
    name
                                        , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                        , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                        ]

    -- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring
    -- a 'Bifoldable' instance).
    makeBifoldMap :: Name -> Q Exp
    makeBifoldMap :: Name -> Q Exp
    makeBifoldMap = Options -> Name -> Q Exp
    makeBifoldMapOptions Options
    defaultOptions

    -- | Like 'makeBifoldMap', but takes an 'Options' argument.
    makeBifoldMapOptions :: Options -> Name -> Q Exp
    makeBifoldMapOptions :: Options -> Name -> Q Exp
    makeBifoldMapOptions = BiFun -> Options -> Name -> Q Exp
    makeBiFun BiFun
    BifoldMap

    -- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a
    -- 'Bifoldable' instance).
    makeBifoldr :: Name -> Q Exp
    makeBifoldr :: Name -> Q Exp
    makeBifoldr = Options -> Name -> Q Exp
    makeBifoldrOptions Options
    defaultOptions

    -- | Like 'makeBifoldr', but takes an 'Options' argument.
    makeBifoldrOptions :: Options -> Name -> Q Exp
    makeBifoldrOptions :: Options -> Name -> Q Exp
    makeBifoldrOptions = BiFun -> Options -> Name -> Q Exp
    makeBiFun BiFun
    Bifoldr

    -- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a
    -- 'Bifoldable' instance).
    makeBifoldl :: Name -> Q Exp
    makeBifoldl :: Name -> Q Exp
    makeBifoldl = Options -> Name -> Q Exp
    makeBifoldlOptions Options
    defaultOptions

    -- | Like 'makeBifoldl', but takes an 'Options' argument.
    makeBifoldlOptions :: Options -> Name -> Q Exp
    makeBifoldlOptions :: Options -> Name -> Q Exp
    makeBifoldlOptions Options
    opts Name
    name = do
      Name
    f <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
      Name
    g <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "g"
      Name
    z <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "z"
      Name
    t <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "t"
      [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    f, Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    g, Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    z, Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    t] (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
    appsE [ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    appEndoValName
              , [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    getDualValName
                      , [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ Options -> Name -> Q Exp
    makeBifoldMapOptions Options
    opts Name
    name
                              , Name -> Q Exp
    foldFun Name
    f
                              , Name -> Q Exp
    foldFun Name
    g
                              , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    t]
                      ]
              , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    z
              ]
      where
        foldFun :: Name -> Q Exp
        foldFun :: Name -> Q Exp
    foldFun Name
    n = 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
    dualDataName)
                             (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    composeValName)
                             (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
    endoDataName)
                                       (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    composeValName)
                                       (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    flipValName 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
    n)
                             )

    -- | Generates a 'Bitraversable' instance declaration for the given data type or data
    -- family instance.
    deriveBitraversable :: Name -> Q [Dec]
    deriveBitraversable :: Name -> Q [Dec]
    deriveBitraversable = Options -> Name -> Q [Dec]
    deriveBitraversableOptions Options
    defaultOptions

    -- | Like 'deriveBitraversable', but takes an 'Options' argument.
    deriveBitraversableOptions :: Options -> Name -> Q [Dec]
    deriveBitraversableOptions :: Options -> Name -> Q [Dec]
    deriveBitraversableOptions = BiClass -> Options -> Name -> Q [Dec]
    deriveBiClass BiClass
    Bitraversable

    -- | Generates a lambda expression which behaves like 'bitraverse' (without
    -- requiring a 'Bitraversable' instance).
    makeBitraverse :: Name -> Q Exp
    makeBitraverse :: Name -> Q Exp
    makeBitraverse = Options -> Name -> Q Exp
    makeBitraverseOptions Options
    defaultOptions

    -- | Like 'makeBitraverse', but takes an 'Options' argument.
    makeBitraverseOptions :: Options -> Name -> Q Exp
    makeBitraverseOptions :: Options -> Name -> Q Exp
    makeBitraverseOptions = BiFun -> Options -> Name -> Q Exp
    makeBiFun BiFun
    Bitraverse

    -- | Generates a lambda expression which behaves like 'bisequenceA' (without
    -- requiring a 'Bitraversable' instance).
    makeBisequenceA :: Name -> Q Exp
    makeBisequenceA :: Name -> Q Exp
    makeBisequenceA = Options -> Name -> Q Exp
    makeBisequenceAOptions Options
    defaultOptions

    -- | Like 'makeBitraverseA', but takes an 'Options' argument.
    makeBisequenceAOptions :: Options -> Name -> Q Exp
    makeBisequenceAOptions :: Options -> Name -> Q Exp
    makeBisequenceAOptions Options
    opts Name
    name = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ Options -> Name -> Q Exp
    makeBitraverseOptions Options
    opts Name
    name
                                             , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                             , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                             ]

    -- | Generates a lambda expression which behaves like 'bimapM' (without
    -- requiring a 'Bitraversable' instance).
    makeBimapM :: Name -> Q Exp
    makeBimapM :: Name -> Q Exp
    makeBimapM = Options -> Name -> Q Exp
    makeBimapMOptions Options
    defaultOptions

    -- | Like 'makeBimapM', but takes an 'Options' argument.
    makeBimapMOptions :: Options -> Name -> Q Exp
    makeBimapMOptions :: Options -> Name -> Q Exp
    makeBimapMOptions Options
    opts Name
    name = do
      Name
    f <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
      Name
    g <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "g"
      [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    f, Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    g] (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . 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
    unwrapMonadValName) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    composeValName) (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
    appsE [ Options -> Name -> Q Exp
    makeBitraverseOptions Options
    opts Name
    name
                                    , Name -> Q Exp
    wrapMonadExp Name
    f
                                    , Name -> Q Exp
    wrapMonadExp Name
    g
                                    ]
      where
        wrapMonadExp :: Name -> Q Exp
        wrapMonadExp :: Name -> Q Exp
    wrapMonadExp Name
    n = 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
    wrapMonadDataName) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    composeValName) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    n)

    -- | Generates a lambda expression which behaves like 'bisequence' (without
    -- requiring a 'Bitraversable' instance).
    makeBisequence :: Name -> Q Exp
    makeBisequence :: Name -> Q Exp
    makeBisequence = Options -> Name -> Q Exp
    makeBisequenceOptions Options
    defaultOptions

    -- | Like 'makeBisequence', but takes an 'Options' argument.
    makeBisequenceOptions :: Options -> Name -> Q Exp
    makeBisequenceOptions :: Options -> Name -> Q Exp
    makeBisequenceOptions Options
    opts Name
    name = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE [ Options -> Name -> Q Exp
    makeBimapMOptions Options
    opts Name
    name
                                            , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                            , Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    idValName
                                            ]

    -------------------------------------------------------------------------------
    -- Code generation
    -------------------------------------------------------------------------------

    -- | Derive a class instance declaration (depending on the BiClass argument's value).
    deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
    deriveBiClass :: BiClass -> Options -> Name -> Q [Dec]
    deriveBiClass BiClass
    biClass Options
    opts Name
    name = do
      DatatypeInfo
    info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case DatatypeInfo
    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
          ([Type]
    instanceCxt, Type
    instanceType)
              <- BiClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance BiClass
    biClass Name
    parentName [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
          (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` Q [Type] -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m [Type] -> m Type -> [m Dec] -> m Dec
    instanceD ([Type] -> Q [Type]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Type]
    instanceCxt)
                                 (Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    instanceType)
                                 (BiClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    biFunDecs BiClass
    biClass Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons)

    -- | Generates a declaration defining the primary function(s) corresponding to a
    -- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and
    -- bitraverse for Bitraversable).
    --
    -- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436.
    biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    biFunDecs :: BiClass
    -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
    biFunDecs BiClass
    biClass Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons =
      (BiFun -> Q Dec) -> [BiFun] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map BiFun -> Q Dec
    makeFunD ([BiFun] -> [Q Dec]) -> [BiFun] -> [Q Dec]
    forall a b. (a -> b) -> a -> b
    $ BiClass -> [BiFun]
    biClassToFuns BiClass
    biClass
      where
        makeFunD :: BiFun -> Q Dec
        makeFunD :: BiFun -> Q Dec
    makeFunD BiFun
    biFun =
          Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD (BiFun -> Name
    biFunName BiFun
    biFun)
               [ [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
    $ BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons BiFun
    biFun Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons)
                        []
               ]

    -- | Generates a lambda expression which behaves like the BiFun argument.
    makeBiFun :: BiFun -> Options -> Name -> Q Exp
    makeBiFun :: BiFun -> Options -> Name -> Q Exp
    makeBiFun BiFun
    biFun Options
    opts Name
    name = do
      DatatypeInfo
    info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case DatatypeInfo
    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
                     } ->
          -- We force buildTypeInstance here since it performs some checks for whether
          -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc.
          -- implemented for it, and produces errors if it can't.
          BiClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance (BiFun -> BiClass
    biFunToClass BiFun
    biFun) Name
    parentName [Type]
    ctxt [Type]
    instTys DatatypeVariant
    variant
            Q ([Type], Type) -> Q Exp -> Q Exp
    forall a b. Q a -> Q b -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons BiFun
    biFun Options
    opts Name
    parentName [Type]
    instTys [ConstructorInfo]
    cons

    -- | Generates a lambda expression for the given constructors.
    -- All constructors must be from the same type.
    makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons BiFun
    biFun Options
    opts Name
    _parentName [Type]
    instTys [ConstructorInfo]
    cons = do
      Name
    map1  <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "f"
      Name
    map2  <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "g"
      Name
    z     <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "z" -- Only used for deriving bifoldr
      Name
    value <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "value"
      let argNames :: [Name]
    argNames   = [Maybe Name] -> [Name]
    forall a. [Maybe a] -> [a]
    catMaybes [ Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    map1
                                 , Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    map2
                                 , Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (BiFun
    biFun BiFun -> BiFun -> Bool
    forall a. Eq a => a -> a -> Bool
    == BiFun
    Bifoldr) Maybe () -> Maybe Name -> Maybe Name
    forall a b. Maybe a -> Maybe b -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    z
                                 , Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    value
                                 ]
          lastTyVars :: [Name]
    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
    - Int
    2) [Type]
    instTys
          tvMap :: Map Name Name
    tvMap      = [(Name, Name)] -> Map Name Name
    forall k a. Ord k => [(k, a)] -> Map k a
    Map.fromList ([(Name, Name)] -> Map Name Name)
    -> [(Name, Name)] -> Map Name Name
    forall a b. (a -> b) -> a -> b
    $ [Name] -> [Name] -> [(Name, Name)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    lastTyVars [Name
    map1, Name
    map2]
      [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP [Name]
    argNames)
          (Q Exp -> Q Exp) -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE
          ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Name -> Q Exp) -> Name -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Name
    biFunConstName BiFun
    biFun
            , Name -> Name -> Map Name Name -> Q Exp
    makeFun Name
    z Name
    value Map Name Name
    tvMap
            ] [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ (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]
    argNames
      where
        makeFun :: Name -> Name -> TyVarMap -> Q Exp
        makeFun :: Name -> Name -> Map Name Name -> Q Exp
    makeFun Name
    z Name
    value Map Name Name
    tvMap = do
    #if MIN_VERSION_template_haskell(2,9,0)
          [Role]
    roles <- Name -> Q [Role]
    reifyRoles Name
    _parentName
    #endif
          case () of
            ()
    _

    #if MIN_VERSION_template_haskell(2,9,0)
              | Just ([Role]
    rs, Role
    PhantomR) <- [Role] -> Maybe ([Role], Role)
    forall a. [a] -> Maybe ([a], a)
    unsnoc [Role]
    roles
              , Just ([Role]
    _,  Role
    PhantomR) <- [Role] -> Maybe ([Role], Role)
    forall a. [a] -> Maybe ([a], a)
    unsnoc [Role]
    rs
             -> Name -> Name -> Q Exp
    biFunPhantom Name
    z Name
    value
    #endif

              | [ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons Bool -> Bool -> Bool
    && Options -> Bool
    emptyCaseBehavior Options
    opts Bool -> Bool -> Bool
    && Bool
    ghc7'8OrLater
             -> BiFun -> Name -> Name -> Q Exp
    biFunEmptyCase BiFun
    biFun Name
    z Name
    value

              | [ConstructorInfo] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons
             -> BiFun -> Name -> Name -> Q Exp
    biFunNoCons BiFun
    biFun Name
    z 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)
                      ((ConstructorInfo -> Q Match) -> [ConstructorInfo] -> [Q Match]
    forall a b. (a -> b) -> [a] -> [b]
    map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
    makeBiFunForCon BiFun
    biFun Name
    z Map Name Name
    tvMap) [ConstructorInfo]
    cons)

        ghc7'8OrLater :: Bool
    #if __GLASGOW_HASKELL__ >= 708
        ghc7'8OrLater :: Bool
    ghc7'8OrLater = Bool
    True
    #else
        ghc7'8OrLater = False
    #endif

    #if MIN_VERSION_template_haskell(2,9,0)
        biFunPhantom :: Name -> Name -> Q Exp
        biFunPhantom :: Name -> Name -> Q Exp
    biFunPhantom Name
    z Name
    value =
            Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    coerce
                         (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    coerce)
                         BiFun
    biFun Name
    z
          where
            coerce :: Q Exp
            coerce :: Q Exp
    coerce = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    coerceValName 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
    value
    #endif

    -- | Generates a match for a single constructor.
    makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
    makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> Q Match
    makeBiFunForCon BiFun
    biFun Name
    z Map Name Name
    tvMap
      con :: ConstructorInfo
    con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                           , constructorContext :: ConstructorInfo -> [Type]
    constructorContext = [Type]
    ctxt }) = do
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `predMentionsName` Map Name Name -> [Name]
    forall k a. Map k a -> [k]
    Map.keys Map Name Name
    tvMap) [Type]
    ctxt
                 Bool -> Bool -> Bool
    || Map Name Name -> Int
    forall k a. Map k a -> Int
    Map.size Map Name Name
    tvMap Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    2)
                 Bool -> Bool -> Bool
    && Bool -> Bool
    not (BiClass -> Bool
    allowExQuant (BiFun -> BiClass
    biFunToClass BiFun
    biFun))) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Name -> Q ()
    forall a. Name -> Q a
    existentialContextError Name
    conName
        case BiFun
    biFun of
          BiFun
    Bimap      -> Map Name Name -> ConstructorInfo -> Q Match
    makeBimapMatch Map Name Name
    tvMap ConstructorInfo
    con
          BiFun
    Bifoldr    -> Name -> Map Name Name -> ConstructorInfo -> Q Match
    makeBifoldrMatch Name
    z Map Name Name
    tvMap ConstructorInfo
    con
          BiFun
    BifoldMap  -> Map Name Name -> ConstructorInfo -> Q Match
    makeBifoldMapMatch Map Name Name
    tvMap ConstructorInfo
    con
          BiFun
    Bitraverse -> Map Name Name -> ConstructorInfo -> Q Match
    makeBitraverseMatch Map Name Name
    tvMap ConstructorInfo
    con

    -- | Generates a match whose right-hand side implements @bimap@.
    makeBimapMatch :: TyVarMap -> ConstructorInfo -> Q Match
    makeBimapMatch :: Map Name Name -> ConstructorInfo -> Q Match
    makeBimapMatch Map Name Name
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Exp -> Q Exp]
    parts <- Map Name Name
    -> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
    forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name Name
    tvMap FFoldType (Exp -> Q Exp)
    ft_bimap ConstructorInfo
    con
      Name -> [Exp -> Q Exp] -> Q Match
    match_for_con Name
    conName [Exp -> Q Exp]
    parts
      where
        ft_bimap :: FFoldType (Exp -> Q Exp)
        ft_bimap :: FFoldType (Exp -> Q Exp)
    ft_bimap = FT { ft_triv :: Exp -> Q Exp
    ft_triv = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                      , ft_var :: Name -> Exp -> Q Exp
    ft_var  = \Name
    v Exp
    x -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE (Map Name Name
    tvMap Map Name Name -> Name -> Name
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v) Exp -> Exp -> Exp
    `AppE` Exp
    x
                      , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_fun  = \Exp -> Q Exp
    g Exp -> Q Exp
    h Exp
    x -> (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    b -> do
                          Exp
    gg <- Exp -> Q Exp
    g Exp
    b
                          Exp -> Q Exp
    h (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp
    x Exp -> Exp -> Exp
    `AppE` Exp
    gg
                      , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    ft_tup  = (Name -> [Exp -> Q Exp] -> Q Match)
    -> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [Exp -> Q Exp] -> Q Match
    match_for_con
                      , ft_ty_app :: [(Type, Exp -> Q Exp)] -> Exp -> Q Exp
    ft_ty_app = \[(Type, Exp -> Q Exp)]
    argGs Exp
    x -> do
                          let inspect :: (Type, Exp -> Q Exp) -> Q Exp
                              inspect :: (Type, Exp -> Q Exp) -> Q Exp
    inspect (Type
    argTy, Exp -> Q Exp
    g)
                                -- If the argument type is a bare occurrence of one
                                -- of the data type's last type variables, then we
                                -- can generate more efficient code.
                                -- This was inspired by GHC#17880.
                                | Just Name
    argVar <- Type -> Maybe Name
    varTToName_maybe Type
    argTy
                                , Just Name
    f <- Name -> Map Name Name -> Maybe Name
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    argVar Map Name Name
    tvMap
                                = Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    f
                                | Bool
    otherwise
                                = (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    g
                          [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    fmapArity ([(Type, Exp -> Q Exp)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Type, Exp -> Q Exp)]
    argGs))
                                Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : ((Type, Exp -> Q Exp) -> Q Exp)
    -> [(Type, Exp -> Q Exp)] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Type, Exp -> Q Exp) -> Q Exp
    inspect [(Type, Exp -> Q Exp)]
    argGs
                               [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ [Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    x]
                      , ft_forall :: [TyVarBndrSpec] -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_forall  = \[TyVarBndrSpec]
    _ Exp -> Q Exp
    g Exp
    x -> Exp -> Q Exp
    g Exp
    x
                      , ft_bad_app :: Exp -> Q Exp
    ft_bad_app = \Exp
    _ -> Name -> Q Exp
    forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName
                      , ft_co_var :: Name -> Exp -> Q Exp
    ft_co_var  = \Name
    _ Exp
    _ -> Name -> Q Exp
    forall a. Name -> Q a
    contravarianceError Name
    conName
                      }

        -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
        match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
        match_for_con :: Name -> [Exp -> Q Exp] -> Q Match
    match_for_con = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
    forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
    mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match)
    -> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> Q Match
    forall a b. (a -> b) -> a -> b
    $ \Name
    conName' [Q Exp]
    xs ->
           [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conName'Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :[Q Exp]
    xs) -- Con x1 x2 ..

    -- | Generates a match whose right-hand side implements @bifoldr@.
    makeBifoldrMatch :: Name -> TyVarMap -> ConstructorInfo -> Q Match
    makeBifoldrMatch :: Name -> Map Name Name -> ConstructorInfo -> Q Match
    makeBifoldrMatch Name
    z Map Name Name
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name Name
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name Name
    tvMap FFoldType (Q (Bool, Exp))
    ft_bifoldr ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    parts
      Exp -> Name -> [(Bool, Exp)] -> Q Match
    match_for_con (Name -> Exp
    VarE Name
    z) Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions of the last two type parameters,
        -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
        -- out expressions that do not mention the last parameters by checking for
        -- False.
        ft_bifoldr :: FFoldType (Q (Bool, Exp))
        ft_bifoldr :: FFoldType (Q (Bool, Exp))
    ft_bifoldr = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                          ft_triv :: Q (Bool, Exp)
    ft_triv = do Exp
    lam <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    _ Exp
    z' -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    z'
                                       (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Exp
    lam)
                        , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \Name
    v -> (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE (Name -> Exp) -> Name -> Exp
    forall a b. (a -> b) -> a -> b
    $ Map Name Name
    tvMap Map Name Name -> Name -> Name
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v)
                        , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \TupleSort
    t [Q (Bool, Exp)]
    gs -> do
                            [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    gs
                            Exp
    lam <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    x Exp
    z' ->
                              (Name -> [(Bool, Exp)] -> Q Match)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> Q Match
    match_for_con Exp
    z') TupleSort
    t [(Bool, Exp)]
    gg Exp
    x
                            (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                        , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
    ft_ty_app = \[(Type, Q (Bool, Exp))]
    gs -> do
                            Exp
    lam <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    x Exp
    z' ->
                                     [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    foldrArity ([(Type, Q (Bool, Exp))] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Type, Q (Bool, Exp))]
    gs))
                                           Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : ((Type, Q (Bool, Exp)) -> Q Exp)
    -> [(Type, Q (Bool, Exp))] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Type
    _, Q (Bool, Exp)
    hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Bool, Exp) -> Exp
    forall a b. (a, b) -> b
    snd Q (Bool, Exp)
    hs) [(Type, Q (Bool, Exp))]
    gs
                                          [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [a] -> [a] -> [a]
    ++ (Exp -> Q Exp) -> [Exp] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Exp
    z', Exp
    x]
                            (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                        , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \[TyVarBndrSpec]
    _ Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                        , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \Name
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                        , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \Q (Bool, Exp)
    _ Q (Bool, Exp)
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                        , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName
                        }

        match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match
    match_for_con Exp
    zExp = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    forall a b. (a -> b) -> a -> b
    $ \Exp
    _ [Exp]
    xs -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Exp] -> Exp
    mkBifoldr [Exp]
    xs
          where
            -- g1 v1 (g2 v2 (.. z))
            mkBifoldr :: [Exp] -> Exp
            mkBifoldr :: [Exp] -> Exp
    mkBifoldr = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Exp -> Exp -> Exp
    AppE Exp
    zExp

    -- | Generates a match whose right-hand side implements @bifoldMap@.
    makeBifoldMapMatch :: TyVarMap -> ConstructorInfo -> Q Match
    makeBifoldMapMatch :: Map Name Name -> ConstructorInfo -> Q Match
    makeBifoldMapMatch Map Name Name
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name Name
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name Name
    tvMap FFoldType (Q (Bool, Exp))
    ft_bifoldMap ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    parts
      Name -> [(Bool, Exp)] -> Q Match
    match_for_con Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions of the last two type parameters,
        -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
        -- out expressions that do not mention the last parameters by checking for
        -- False.
        ft_bifoldMap :: FFoldType (Q (Bool, Exp))
        ft_bifoldMap :: FFoldType (Q (Bool, Exp))
    ft_bifoldMap = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                            ft_triv :: Q (Bool, Exp)
    ft_triv = do Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \Exp
    _ -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    memptyValName
                                         (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Exp
    lam)
                          , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \Name
    v -> (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE (Name -> Exp) -> Name -> Exp
    forall a b. (a -> b) -> a -> b
    $ Map Name Name
    tvMap Map Name Name -> Name -> Name
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v)
                          , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \TupleSort
    t [Q (Bool, Exp)]
    gs -> do
                              [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    gs
                              Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> [(Bool, Exp)] -> Q Match)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
    match_for_con TupleSort
    t [(Bool, Exp)]
    gg
                              (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                          , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
    ft_ty_app = \[(Type, Q (Bool, Exp))]
    gs -> do
                              Exp
    e <- [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    foldMapArity ([(Type, Q (Bool, Exp))] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Type, Q (Bool, Exp))]
    gs))
                                         Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : ((Type, Q (Bool, Exp)) -> Q Exp)
    -> [(Type, Q (Bool, Exp))] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Type
    _, Q (Bool, Exp)
    hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Bool, Exp) -> Exp
    forall a b. (a, b) -> b
    snd Q (Bool, Exp)
    hs) [(Type, Q (Bool, Exp))]
    gs
                              (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    e)
                          , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \[TyVarBndrSpec]
    _ Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                          , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \Name
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                          , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \Q (Bool, Exp)
    _ Q (Bool, Exp)
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                          , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName
                          }

        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    forall a b. (a -> b) -> a -> b
    $ \Exp
    _ [Exp]
    xs -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Exp] -> Exp
    mkBifoldMap [Exp]
    xs
          where
            -- mappend v1 (mappend v2 ..)
            mkBifoldMap :: [Exp] -> Exp
            mkBifoldMap :: [Exp] -> Exp
    mkBifoldMap [] = Name -> Exp
    VarE Name
    memptyValName
            mkBifoldMap [Exp]
    es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
    forall a. (a -> a -> a) -> [a] -> a
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 (Exp -> Exp -> Exp
    AppE (Exp -> Exp -> Exp) -> (Exp -> Exp) -> Exp -> Exp -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    mappendValName)) [Exp]
    es

    -- | Generates a match whose right-hand side implements @bitraverse@.
    makeBitraverseMatch :: TyVarMap -> ConstructorInfo -> Q Match
    makeBitraverseMatch :: Map Name Name -> ConstructorInfo -> Q Match
    makeBitraverseMatch Map Name Name
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name Name
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name Name
    tvMap FFoldType (Q (Bool, Exp))
    ft_bitrav ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    parts
      Name -> [(Bool, Exp)] -> Q Match
    match_for_con Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions of the last two type parameters,
        -- False otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter
        -- out expressions that do not mention the last parameters by checking for
        -- False.
        ft_bitrav :: FFoldType (Q (Bool, Exp))
        ft_bitrav :: FFoldType (Q (Bool, Exp))
    ft_bitrav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                         ft_triv :: Q (Bool, Exp)
    ft_triv = (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Name -> Exp
    VarE Name
    pureValName)
                       , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \Name
    v -> (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE (Name -> Exp) -> Name -> Exp
    forall a b. (a -> b) -> a -> b
    $ Map Name Name
    tvMap Map Name Name -> Name -> Name
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v)
                       , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \TupleSort
    t [Q (Bool, Exp)]
    gs -> do
                           [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [Q (Bool, Exp)]
    gs
                           Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> [(Bool, Exp)] -> Q Match)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [(Bool, Exp)] -> Q Match
    match_for_con TupleSort
    t [(Bool, Exp)]
    gg
                           (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                       , ft_ty_app :: [(Type, Q (Bool, Exp))] -> Q (Bool, Exp)
    ft_ty_app = \[(Type, Q (Bool, Exp))]
    gs -> do
                           Exp
    e <- [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE (Int -> Name
    traverseArity ([(Type, Q (Bool, Exp))] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Type, Q (Bool, Exp))]
    gs))
                                      Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : ((Type, Q (Bool, Exp)) -> Q Exp)
    -> [(Type, Q (Bool, Exp))] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Type
    _, Q (Bool, Exp)
    hs) -> ((Bool, Exp) -> Exp) -> Q (Bool, Exp) -> Q Exp
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Bool, Exp) -> Exp
    forall a b. (a, b) -> b
    snd Q (Bool, Exp)
    hs) [(Type, Q (Bool, Exp))]
    gs
                           (Bool, Exp) -> Q (Bool, Exp)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    e)
                       , ft_forall :: [TyVarBndrSpec] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \[TyVarBndrSpec]
    _ Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                       , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \Name
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                       , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \Q (Bool, Exp)
    _ Q (Bool, Exp)
    _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                       , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName
                       }

        -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
        --                    (g2 a2) <*> ...
        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
    match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    forall a b. (a -> b) -> a -> b
    $ \Exp
    conExp [Exp]
    xs -> Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp -> [Exp] -> Exp
    mkApCon Exp
    conExp [Exp]
    xs
          where
            -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
            mkApCon :: Exp -> [Exp] -> Exp
            mkApCon :: Exp -> [Exp] -> Exp
    mkApCon Exp
    conExp []  = Name -> Exp
    VarE Name
    pureValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp
            mkApCon Exp
    conExp [Exp
    e] = Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp Exp -> Exp -> Exp
    `AppE` Exp
    e
            mkApCon Exp
    conExp (Exp
    e1:Exp
    e2:[Exp]
    es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    List.foldl' Exp -> Exp -> Exp
    appAp
              (Name -> Exp
    VarE Name
    liftA2ValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp Exp -> Exp -> Exp
    `AppE` Exp
    e1 Exp -> Exp -> Exp
    `AppE` Exp
    e2) [Exp]
    es
              where appAp :: Exp -> Exp -> Exp
    appAp Exp
    se1 Exp
    se2 = Maybe Exp -> Exp -> Maybe Exp -> Exp
    InfixE (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    se1) (Name -> Exp
    VarE Name
    apValName) (Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just Exp
    se2)

    -------------------------------------------------------------------------------
    -- Template Haskell reifying and AST manipulation
    -------------------------------------------------------------------------------

    -- For the given Types, generate an instance context and head. Coming up with
    -- the instance type isn't as simple as dropping the last types, as you need to
    -- be wary of kinds being instantiated with *.
    -- See Note [Type inference in derived instances]
    buildTypeInstance :: BiClass
                      -- ^ Bifunctor, Bifoldable, or Bitraversable
                      -> Name
                      -- ^ The type constructor or data family name
                      -> 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 :: BiClass
    -> Name -> [Type] -> [Type] -> DatatypeVariant -> Q ([Type], Type)
    buildTypeInstance BiClass
    biClass Name
    tyConName [Type]
    dataCxt [Type]
    instTysOrig 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.)
        [Type]
    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]
    instTysOrig

        let remainingLength :: Int
            remainingLength :: Int
    remainingLength = [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    instTysOrig Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    2

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

            droppedStarKindStati :: [StarKindStatus]
            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.
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (Int
    remainingLength Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < Int
    0 Bool -> Bool -> Bool
    || (StarKindStatus -> Bool) -> [StarKindStatus] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (StarKindStatus -> StarKindStatus -> Bool
    forall a. Eq a => a -> a -> Bool
    == StarKindStatus
    NotKindStar) [StarKindStatus]
    droppedStarKindStati) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          BiClass -> Name -> Q ()
    forall a. BiClass -> Name -> Q a
    derivingKindError BiClass
    biClass Name
    tyConName

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

            -- Substitute kind * for any dropped kind variables
            varTysExpSubst :: [Type]
            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]
            ([Type]
    remainingTysExpSubst, [Type]
    droppedTysExpSubst) =
              Int -> [Type] -> ([Type], [Type])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    remainingLength [Type]
    varTysExpSubst

            -- All of the type variables mentioned in the dropped types
            -- (post-synonym expansion)
            droppedTyVarNames :: [Name]
            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.
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    hasKindStar [Type]
    droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          BiClass -> Name -> Q ()
    forall a. BiClass -> Name -> Q a
    derivingKindError BiClass
    biClass Name
    tyConName

        let preds    :: [Maybe Pred]
            kvNames  :: [[Name]]
            kvNames' :: [Name]
            -- Derive instance constraints (and any kind variables which are specialized
            -- to * in those constraints)
            ([Maybe Type]
    preds, [[Name]]
    kvNames) = [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
    forall a b. [(a, b)] -> ([a], [b])
    unzip ([(Maybe Type, [Name])] -> ([Maybe Type], [[Name]]))
    -> [(Maybe Type, [Name])] -> ([Maybe Type], [[Name]])
    forall a b. (a -> b) -> a -> b
    $ (Type -> (Maybe Type, [Name])) -> [Type] -> [(Maybe Type, [Name])]
    forall a b. (a -> b) -> [a] -> [b]
    map (BiClass -> Type -> (Maybe Type, [Name])
    deriveConstraint BiClass
    biClass) [Type]
    remainingTysExpSubst
            kvNames' :: [Name]
    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]
    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]
    remainingTysOrigSubst =
              (Type -> Type) -> [Type] -> [Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar ([Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    List.union [Name]
    droppedKindVarNames [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]
    instTysOrig

        Bool
    isDataFamily <-
          case DatatypeVariant
    variant of
            DatatypeVariant
    Datatype        -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
            DatatypeVariant
    Newtype         -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
            DatatypeVariant
    DataInstance    -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
            DatatypeVariant
    NewtypeInstance -> Bool -> Q Bool
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    True
    #if MIN_VERSION_th_abstraction(0,5,0)
            Datatype.TypeData -> typeDataError tyConName
    #endif

        let remainingTysOrigSubst' :: [Type]
            -- See Note [Kind signatures in derived instances] for an explanation
            -- of the isDataFamily check.
            remainingTysOrigSubst' :: [Type]
    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 :: [Type]
    instanceCxt = [Maybe Type] -> [Type]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe Type]
    preds

            instanceType :: Type
            instanceType :: Type
    instanceType = Type -> Type -> Type
    AppT (Name -> Type
    ConT (Name -> Type) -> Name -> Type
    forall a b. (a -> b) -> a -> b
    $ BiClass -> Name
    biClassName BiClass
    biClass)
                         (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.
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ((Type -> Bool) -> [Type] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `predMentionsName` [Name]
    droppedTyVarNames) [Type]
    dataCxt) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Name -> Type -> Q ()
    forall a. Name -> Type -> Q a
    datatypeContextError Name
    tyConName Type
    instanceType
        -- Also ensure the dropped types can be safely eta-reduced. Otherwise,
        -- throw an error.
        Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([Type] -> [Type] -> Bool
    canEtaReduce [Type]
    remainingTysExpSubst' [Type]
    droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Type -> Q ()
    forall a. Type -> Q a
    etaReductionError Type
    instanceType
        ([Type], Type) -> Q ([Type], Type)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Type]
    instanceCxt, Type
    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 :: BiClass -> Type -> (Maybe Pred, [Name])
    deriveConstraint :: BiClass -> Type -> (Maybe Type, [Name])
    deriveConstraint BiClass
    biClass Type
    t
      | Bool -> Bool
    not (Type -> Bool
    isTyVar Type
    t) = (Maybe Type
    forall a. Maybe a
    Nothing, [])
      | Bool
    otherwise = case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    1 Type
    t of
          Just [Name]
    ns -> ((Name -> Name -> Type
    `applyClass` Name
    tName) (Name -> Type) -> Maybe Name -> Maybe Type
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` BiClass -> Int -> Maybe Name
    biClassConstraint BiClass
    biClass Int
    1, [Name]
    ns)
          Maybe [Name]
    _ -> case Int -> Type -> Maybe [Name]
    hasKindVarChain Int
    2 Type
    t of
                    Just [Name]
    ns -> ((Name -> Name -> Type
    `applyClass` Name
    tName) (Name -> Type) -> Maybe Name -> Maybe Type
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` BiClass -> Int -> Maybe Name
    biClassConstraint BiClass
    biClass Int
    2, [Name]
    ns)
                    Maybe [Name]
    _       -> (Maybe Type
    forall a. Maybe a
    Nothing, [])
      where
        tName :: Name
        tName :: Name
    tName = Type -> Name
    varTToName Type
    t

    {-
    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 our type inferencer is pretty
    unsophisticated - see Note [Type inference in derived instances]), 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 make- 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) (c :: 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 k1 -> k2 (where k1/k2 are * or kind
            variables), then generate a Functor 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 :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2)
                = Compose (f (g a b))

            Which would have a derived Bifunctor instance of:

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

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

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

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

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

      instance Bifoldable Both where
        bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2

    This is not an arbitrary choice, as this definition ensures that
    bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both.
    -}

    -------------------------------------------------------------------------------
    -- 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 :: BiClass -> Name -> Q a
    derivingKindError :: forall a. BiClass -> Name -> Q a
    derivingKindError BiClass
    biClass Name
    tyConName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Cannot derive well-kinded instance of form ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    className
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> ShowS
    showChar Char
    ' '
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Bool -> ShowS -> ShowS
    showParen Bool
    True
        ( String -> ShowS
    showString (Name -> String
    nameBase Name
    tyConName)
        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " ..."
        )
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘\n\tClass "
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    className
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " expects an argument of kind * -> * -> *"
      (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
    $ BiClass -> Name
    biClassName BiClass
    biClass

    -- | One of the last two type variables appeard in a contravariant position
    -- when deriving Bifoldable or Bitraversable.
    contravarianceError :: Name -> Q a
    contravarianceError :: forall a. Name -> Q a
    contravarianceError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must not use the last type variable(s) in a function argument"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -- | A constructor has a function argument in a derived Bifoldable or Bitraversable
    -- instance.
    noFunctionsError :: Name -> Q a
    noFunctionsError :: forall a. Name -> Q a
    noFunctionsError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must not contain function types"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -- | 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) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Can't make a derived instance of ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘:\n\tData type ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    dataName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    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 has an existential constraint which mentions one of the
    -- eta-reduced type variables.
    existentialContextError :: Name -> Q a
    existentialContextError :: forall a. Name -> Q a
    existentialContextError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must be truly polymorphic in the last argument(s) of the data type"
      (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 :: Name -> Q a
    outOfPlaceTyVarError :: forall a. Name -> Q a
    outOfPlaceTyVarError Name
    conName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Constructor ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    conName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘ must only use its last two type variable(s) within"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    " the last two argument(s) of a data type"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

    -- | 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 -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Type -> String
    forall a. Ppr a => a -> String
    pprint Type
    instanceType

    typeDataError :: Name -> Q a
    typeDataError :: forall a. Name -> Q a
    typeDataError Name
    dataName = String -> Q a
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail
      (String -> Q a) -> ShowS -> String -> Q a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "Cannot derive instance for ‘"
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString (Name -> String
    nameBase Name
    dataName)
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString String
    "‘, which is a ‘type data‘ declaration"
      (String -> Q a) -> String -> Q a
    forall a b. (a -> b) -> a -> b
    $ String
    ""

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

    -- | A representation of which class is being derived.
    data BiClass = Bifunctor | Bifoldable | Bitraversable

    -- | A representation of which function is being generated.
    data BiFun = Bimap | Bifoldr | BifoldMap | Bitraverse
      deriving BiFun -> BiFun -> Bool
    (BiFun -> BiFun -> Bool) -> (BiFun -> BiFun -> Bool) -> Eq BiFun
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: BiFun -> BiFun -> Bool
    == :: BiFun -> BiFun -> Bool
    $c/= :: BiFun -> BiFun -> Bool
    /= :: BiFun -> BiFun -> Bool
    Eq

    biFunConstName :: BiFun -> Name
    biFunConstName :: BiFun -> Name
    biFunConstName BiFun
    Bimap      = Name
    bimapConstValName
    biFunConstName BiFun
    Bifoldr    = Name
    bifoldrConstValName
    biFunConstName BiFun
    BifoldMap  = Name
    bifoldMapConstValName
    biFunConstName BiFun
    Bitraverse = Name
    bitraverseConstValName

    biClassName :: BiClass -> Name
    biClassName :: BiClass -> Name
    biClassName BiClass
    Bifunctor     = Name
    bifunctorTypeName
    biClassName BiClass
    Bifoldable    = Name
    bifoldableTypeName
    biClassName BiClass
    Bitraversable = Name
    bitraversableTypeName

    biFunName :: BiFun -> Name
    biFunName :: BiFun -> Name
    biFunName BiFun
    Bimap      = Name
    bimapValName
    biFunName BiFun
    Bifoldr    = Name
    bifoldrValName
    biFunName BiFun
    BifoldMap  = Name
    bifoldMapValName
    biFunName BiFun
    Bitraverse = Name
    bitraverseValName

    biClassToFuns :: BiClass -> [BiFun]
    biClassToFuns :: BiClass -> [BiFun]
    biClassToFuns BiClass
    Bifunctor     = [BiFun
    Bimap]
    biClassToFuns BiClass
    Bifoldable    = [BiFun
    Bifoldr, BiFun
    BifoldMap]
    biClassToFuns BiClass
    Bitraversable = [BiFun
    Bitraverse]

    biFunToClass :: BiFun -> BiClass
    biFunToClass :: BiFun -> BiClass
    biFunToClass BiFun
    Bimap      = BiClass
    Bifunctor
    biFunToClass BiFun
    Bifoldr    = BiClass
    Bifoldable
    biFunToClass BiFun
    BifoldMap  = BiClass
    Bifoldable
    biFunToClass BiFun
    Bitraverse = BiClass
    Bitraversable

    biClassConstraint :: BiClass -> Int -> Maybe Name
    biClassConstraint :: BiClass -> Int -> Maybe Name
    biClassConstraint BiClass
    Bifunctor     Int
    1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    functorTypeName
    biClassConstraint BiClass
    Bifoldable    Int
    1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    foldableTypeName
    biClassConstraint BiClass
    Bitraversable Int
    1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    traversableTypeName
    biClassConstraint BiClass
    biClass       Int
    2 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Name -> Maybe Name) -> Name -> Maybe Name
    forall a b. (a -> b) -> a -> b
    $ BiClass -> Name
    biClassName BiClass
    biClass
    biClassConstraint BiClass
    _             Int
    _ = Maybe Name
    forall a. Maybe a
    Nothing

    fmapArity :: Int -> Name
    fmapArity :: Int -> Name
    fmapArity Int
    1 = Name
    fmapValName
    fmapArity Int
    2 = Name
    bimapValName
    fmapArity Int
    n = Int -> Name
    forall a. Int -> a
    arityErr Int
    n

    foldrArity :: Int -> Name
    foldrArity :: Int -> Name
    foldrArity Int
    1 = Name
    foldrValName
    foldrArity Int
    2 = Name
    bifoldrValName
    foldrArity Int
    n = Int -> Name
    forall a. Int -> a
    arityErr Int
    n

    foldMapArity :: Int -> Name
    foldMapArity :: Int -> Name
    foldMapArity Int
    1 = Name
    foldMapValName
    foldMapArity Int
    2 = Name
    bifoldMapValName
    foldMapArity Int
    n = Int -> Name
    forall a. Int -> a
    arityErr Int
    n

    traverseArity :: Int -> Name
    traverseArity :: Int -> Name
    traverseArity Int
    1 = Name
    traverseValName
    traverseArity Int
    2 = Name
    bitraverseValName
    traverseArity Int
    n = Int -> Name
    forall a. Int -> a
    arityErr Int
    n

    arityErr :: Int -> a
    arityErr :: forall a. Int -> a
    arityErr Int
    n = String -> a
    forall a. HasCallStack => String -> a
    error (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ String
    "Unsupported arity: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n

    allowExQuant :: BiClass -> Bool
    allowExQuant :: BiClass -> Bool
    allowExQuant BiClass
    Bifoldable = Bool
    True
    allowExQuant BiClass
    _          = Bool
    False

    biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
    biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
    biFunEmptyCase BiFun
    biFun Name
    z Name
    value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    emptyCase
                     (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    emptyCase)
                     BiFun
    biFun Name
    z
      where
        emptyCase :: Q Exp
        emptyCase :: Q Exp
    emptyCase = 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) []

    biFunNoCons :: BiFun -> Name -> Name -> Q Exp
    biFunNoCons :: BiFun -> Name -> Name -> Q Exp
    biFunNoCons BiFun
    biFun Name
    z Name
    value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    seqAndError
                     (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE` Q Exp
    seqAndError)
                     BiFun
    biFun Name
    z
      where
        seqAndError :: Q Exp
        seqAndError :: Q Exp
    seqAndError = 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
    seqValName) (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    value) Q Exp -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
    `appE`
                      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
    errorValName)
                            (String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ String
    "Void " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    nameBase (BiFun -> Name
    biFunName BiFun
    biFun))

    biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    bimapE Q Exp
    bitraverseE BiFun
    biFun Name
    z = BiFun -> Q Exp
    go BiFun
    biFun
      where
        go :: BiFun -> Q Exp
        go :: BiFun -> Q Exp
    go BiFun
    Bimap      = Q Exp
    bimapE
        go BiFun
    Bifoldr    = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    z
        go BiFun
    BifoldMap  = Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    varE Name
    memptyValName
        go BiFun
    Bitraverse = Q Exp
    bitraverseE

    {-
    Note [ft_triv for Bifoldable and Bitraversable]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose
    type does not mention one of the last two type parameters. From this, you might
    think that we don't need to implement ft_triv for bifoldr, bifoldMap, or
    bitraverse at all, but in fact we do need to. Imagine the following data type:

        data T a b = MkT a (T Int b)

    In a derived Bifoldable T instance, you would generate the following bifoldMap
    definition:

        bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2

    You need to fill in bi_triv (\_ -> mempty) as the first argument to the recursive
    call to bifoldMap, since that is how the algorithm handles polymorphic recursion.
    -}

    -------------------------------------------------------------------------------
    -- Generic traversal for functor-like deriving
    -------------------------------------------------------------------------------

    -- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.

    data FFoldType a      -- Describes how to fold over a Type in a functor like way
       = FT { forall a. FFoldType a -> a
    ft_triv    :: a
              -- ^ Does not contain variables
            , forall a. FFoldType a -> Name -> a
    ft_var     :: Name -> a
              -- ^ A bare variable
            , forall a. FFoldType a -> Name -> a
    ft_co_var  :: Name -> a
              -- ^ A bare variable, contravariantly
            , forall a. FFoldType a -> a -> a -> a
    ft_fun     :: a -> a -> a
              -- ^ Function type
            , forall a. FFoldType a -> TupleSort -> [a] -> a
    ft_tup     :: TupleSort -> [a] -> a
              -- ^ Tuple type. The [a] is the result of folding over the
              --   arguments of the tuple.
            , forall a. FFoldType a -> [(Type, a)] -> a
    ft_ty_app  :: [(Type, a)] -> a
              -- ^ Type app, variables only in last argument. The [(Type, a)]
              --   represents the last argument types. That is, they form the
              --   argument parts of @fun_ty arg_ty_1 ... arg_ty_n@.
            , forall a. FFoldType a -> a
    ft_bad_app :: a
              -- ^ Type app, variable other than in last arguments
            , forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
    ft_forall  :: [TyVarBndrSpec] -> a -> a
              -- ^ Forall type
         }

    -- Note that in GHC, this function is pure. It must be monadic here since we:
    --
    -- (1) Expand type synonyms
    -- (2) Detect type family applications
    --
    -- Which require reification in Template Haskell, but are pure in Core.
    functorLikeTraverse :: forall a.
                           TyVarMap    -- ^ Variables to look for
                        -> FFoldType a -- ^ How to fold
                        -> Type        -- ^ Type to process
                        -> Q a
    functorLikeTraverse :: forall a. Map Name Name -> FFoldType a -> Type -> Q a
    functorLikeTraverse Map Name Name
    tvMap (FT { ft_triv :: forall a. FFoldType a -> a
    ft_triv = a
    caseTrivial,     ft_var :: forall a. FFoldType a -> Name -> a
    ft_var = Name -> a
    caseVar
                                  , ft_co_var :: forall a. FFoldType a -> Name -> a
    ft_co_var = Name -> a
    caseCoVar,     ft_fun :: forall a. FFoldType a -> a -> a -> a
    ft_fun = a -> a -> a
    caseFun
                                  , ft_tup :: forall a. FFoldType a -> TupleSort -> [a] -> a
    ft_tup = TupleSort -> [a] -> a
    caseTuple,        ft_ty_app :: forall a. FFoldType a -> [(Type, a)] -> a
    ft_ty_app = [(Type, a)] -> a
    caseTyApp
                                  , ft_bad_app :: forall a. FFoldType a -> a
    ft_bad_app = a
    caseWrongArg, ft_forall :: forall a. FFoldType a -> [TyVarBndrSpec] -> a -> a
    ft_forall = [TyVarBndrSpec] -> a -> a
    caseForAll })
                        Type
    ty
      = do Type
    ty' <- Type -> Q Type
    resolveTypeSynonyms Type
    ty
           (a
    res, Bool
    _) <- Bool -> Type -> Q (a, Bool)
    go Bool
    False Type
    ty'
           a -> Q a
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return a
    res
      where
        go :: Bool        -- Covariant or contravariant context
           -> Type
           -> Q (a, Bool) -- (result of type a, does type contain var)
        go :: Bool -> Type -> Q (a, Bool)
    go Bool
    co t :: Type
    t@AppT{}
          | (Type
    ArrowT, [Type
    funArg, Type
    funRes]) <- Type -> (Type, [Type])
    unapplyTy Type
    t
          = do (a
    funArgR, Bool
    funArgC) <- Bool -> Type -> Q (a, Bool)
    go (Bool -> Bool
    not Bool
    co) Type
    funArg
               (a
    funResR, Bool
    funResC) <- Bool -> Type -> Q (a, Bool)
    go      Bool
    co  Type
    funRes
               if Bool
    funArgC Bool -> Bool -> Bool
    || Bool
    funResC
                  then (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a -> a -> a
    caseFun a
    funArgR a
    funResR, Bool
    True)
                  else Q (a, Bool)
    trivial
        go Bool
    co t :: Type
    t@AppT{} = do
          let (Type
    f, [Type]
    args) = Type -> (Type, [Type])
    unapplyTy Type
    t
          (a
    _,   Bool
    fc)  <- Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    f
          ([a]
    xrs, [Bool]
    xcs) <- ([(a, Bool)] -> ([a], [Bool])) -> Q [(a, Bool)] -> Q ([a], [Bool])
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [(a, Bool)] -> ([a], [Bool])
    forall a b. [(a, b)] -> ([a], [b])
    unzip (Q [(a, Bool)] -> Q ([a], [Bool]))
    -> Q [(a, Bool)] -> Q ([a], [Bool])
    forall a b. (a -> b) -> a -> b
    $ (Type -> Q (a, Bool)) -> [Type] -> Q [(a, Bool)]
    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 (Bool -> Type -> Q (a, Bool)
    go Bool
    co) [Type]
    args
          let numLastArgs, numFirstArgs :: Int
              numLastArgs :: Int
    numLastArgs  = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min Int
    2 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    args
              numFirstArgs :: Int
    numFirstArgs = [Type] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Type]
    args Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    numLastArgs

              tuple :: TupleSort -> Q (a, Bool)
              tuple :: TupleSort -> Q (a, Bool)
    tuple TupleSort
    tupSort = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TupleSort -> [a] -> a
    caseTuple TupleSort
    tupSort [a]
    xrs, Bool
    True)

              wrongArg :: Q (a, Bool)
              wrongArg :: Q (a, Bool)
    wrongArg = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    caseWrongArg, Bool
    True)

          case () of
            ()
    _ |  Bool -> Bool
    not ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or [Bool]
    xcs)
              -> Q (a, Bool)
    trivial -- Variable does not occur
              -- At this point we know that xrs, xcs is not empty,
              -- and at least one xr is True
              |  TupleT Int
    len <- Type
    f
              -> TupleSort -> Q (a, Bool)
    tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
    forall a b. (a -> b) -> a -> b
    $ Int -> TupleSort
    Boxed Int
    len
    #if MIN_VERSION_template_haskell(2,6,0)
              |  UnboxedTupleT Int
    len <- Type
    f
              -> TupleSort -> Q (a, Bool)
    tuple (TupleSort -> Q (a, Bool)) -> TupleSort -> Q (a, Bool)
    forall a b. (a -> b) -> a -> b
    $ Int -> TupleSort
    Unboxed Int
    len
    #endif
              |  Bool
    fc Bool -> Bool -> Bool
    || [Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    or (Int -> [Bool] -> [Bool]
    forall a. Int -> [a] -> [a]
    take Int
    numFirstArgs [Bool]
    xcs)
              -> Q (a, Bool)
    wrongArg                    -- T (..var..)    ty_1 ... ty_n
              |  Bool
    otherwise                   -- T (..no var..) ty_1 ... ty_n
              -> do Bool
    itf <- [Name] -> Type -> [Type] -> Q Bool
    isInTypeFamilyApp [Name]
    tyVarNames Type
    f [Type]
    args
                    if Bool
    itf -- We can't decompose type families, so
                           -- error if we encounter one here.
                       then Q (a, Bool)
    wrongArg
                       else (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ( [(Type, a)] -> a
    caseTyApp ([(Type, a)] -> a) -> [(Type, a)] -> a
    forall a b. (a -> b) -> a -> b
    $ Int -> [(Type, a)] -> [(Type, a)]
    forall a. Int -> [a] -> [a]
    drop Int
    numFirstArgs ([(Type, a)] -> [(Type, a)]) -> [(Type, a)] -> [(Type, a)]
    forall a b. (a -> b) -> a -> b
    $ [Type] -> [a] -> [(Type, a)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Type]
    args [a]
    xrs
                                   , Bool
    True )
        go Bool
    co (SigT Type
    t Type
    k) = do
          (a
    _, Bool
    kc) <- Bool -> Type -> Q (a, Bool)
    go_kind Bool
    co Type
    k
          if Bool
    kc
             then (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    caseWrongArg, Bool
    True)
             else Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    t
        go Bool
    co (VarT Name
    v)
          | Name -> Map Name Name -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    Map.member Name
    v Map Name Name
    tvMap
          = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (if Bool
    co then Name -> a
    caseCoVar Name
    v else Name -> a
    caseVar Name
    v, Bool
    True)
          | Bool
    otherwise
          = Q (a, Bool)
    trivial
        go Bool
    co (ForallT [TyVarBndrSpec]
    tvbs [Type]
    _ Type
    t) = do
          (a
    tr, Bool
    tc) <- Bool -> Type -> Q (a, Bool)
    go Bool
    co Type
    t
          let tvbNames :: [Name]
    tvbNames = (TyVarBndrSpec -> Name) -> [TyVarBndrSpec] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyVarBndrSpec -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName [TyVarBndrSpec]
    tvbs
          if Bool -> Bool
    not Bool
    tc Bool -> Bool -> Bool
    || (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]
    tvbNames) [Name]
    tyVarNames
             then Q (a, Bool)
    trivial
             else (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([TyVarBndrSpec] -> a -> a
    caseForAll [TyVarBndrSpec]
    tvbs a
    tr, Bool
    True)
        go Bool
    _ Type
    _ = Q (a, Bool)
    trivial

        go_kind :: Bool
                -> Kind
                -> Q (a, Bool)
    #if MIN_VERSION_template_haskell(2,9,0)
        go_kind :: Bool -> Type -> Q (a, Bool)
    go_kind = Bool -> Type -> Q (a, Bool)
    go
    #else
        go_kind _ _ = trivial
    #endif

        trivial :: Q (a, Bool)
        trivial :: Q (a, Bool)
    trivial = (a, Bool) -> Q (a, Bool)
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (a
    caseTrivial, Bool
    False)

        tyVarNames :: [Name]
        tyVarNames :: [Name]
    tyVarNames = Map Name Name -> [Name]
    forall k a. Map k a -> [k]
    Map.keys Map Name Name
    tvMap

    -- Fold over the arguments of a data constructor in a Functor-like way.
    foldDataConArgs :: forall a. TyVarMap -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs :: forall a. Map Name Name -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name Name
    tvMap FFoldType a
    ft ConstructorInfo
    con = do
      [Type]
    fieldTys <- (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] -> Q [Type]) -> [Type] -> Q [Type]
    forall a b. (a -> b) -> a -> b
    $ ConstructorInfo -> [Type]
    constructorFields ConstructorInfo
    con
      (Type -> Q a) -> [Type] -> Q [a]
    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 a
    foldArg [Type]
    fieldTys
      where
        foldArg :: Type -> Q a
        foldArg :: Type -> Q a
    foldArg = Map Name Name -> FFoldType a -> Type -> Q a
    forall a. Map Name Name -> FFoldType a -> Type -> Q a
    functorLikeTraverse Map Name Name
    tvMap FFoldType a
    ft

    -- Make a 'LamE' using a fresh variable.
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    lam = do
      -- Use an underscore in front of the variable name, as it's possible for
      -- certain Bifoldable instances to generate code like this (see #89):
      --
      -- @
      -- bifoldMap (\\_n -> mempty) ...
      -- @
      --
      -- Without the underscore, that code would trigger -Wunused-matches warnings.
      Name
    n <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "_n"
      Exp
    body <- Exp -> Q Exp
    lam (Name -> Exp
    VarE Name
    n)
      Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    n] Exp
    body

    -- Make a 'LamE' using two fresh variables.
    mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 Exp -> Exp -> Q Exp
    lam = do
      -- Use an underscore in front of the variable name, as it's possible for
      -- certain Bifoldable instances to generate code like this (see #89):
      --
      -- @
      -- bifoldr (\\_n1 n2 -> n2) ...
      -- @
      --
      -- Without the underscore, that code would trigger -Wunused-matches warnings.
      Name
    n1 <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "_n1"
      Name
    n2 <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "n2"
      Exp
    body <- Exp -> Exp -> Q Exp
    lam (Name -> Exp
    VarE Name
    n1) (Name -> Exp
    VarE Name
    n2)
      Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    n1, Name -> Pat
    VarP Name
    n2] Exp
    body

    -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
    --
    -- @mkSimpleConMatch fold conName insides@ produces a match clause in
    -- which the LHS pattern-matches on @extraPats@, followed by a match on the
    -- constructor @conName@ and its arguments. The RHS folds (with @fold@) over
    -- @conName@ and its arguments, applying an expression (from @insides@) to each
    -- of the respective arguments of @conName@.
    mkSimpleConMatch :: (Name -> [a] -> Q Exp)
                     -> Name
                     -> [Exp -> a]
                     -> Q Match
    mkSimpleConMatch :: forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> Q Match
    mkSimpleConMatch Name -> [a] -> Q Exp
    fold Name
    conName [Exp -> a]
    insides = do
      [Name]
    varsNeeded <- String -> Int -> Q [Name]
    newNameList String
    "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ [Exp -> a] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Exp -> a]
    insides
      let pat :: Pat
    pat = Name -> [Pat] -> Pat
    conPCompat Name
    conName ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    varsNeeded)
      Exp
    rhs <- Name -> [a] -> Q Exp
    fold Name
    conName (((Exp -> a) -> Name -> a) -> [Exp -> a] -> [Name] -> [a]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Exp -> a
    i Name
    v -> Exp -> a
    i (Exp -> a) -> Exp -> a
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    v) [Exp -> a]
    insides [Name]
    varsNeeded)
      Match -> Q Match
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Match -> Q Match) -> Match -> Q Match
    forall a b. (a -> b) -> a -> b
    $ Pat -> Body -> [Dec] -> Match
    Match Pat
    pat (Exp -> Body
    NormalB Exp
    rhs) []

    -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
    --
    -- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to
    -- 'mkSimpleConMatch', with two key differences:
    --
    -- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it
    --    filters out the expressions corresponding to arguments whose types do not
    --    mention the last type variable in a derived 'Foldable' or 'Traversable'
    --    instance (i.e., those elements of @insides@ containing @False@).
    --
    -- 2. @fold@ takes an expression as its first argument instead of a
    --    constructor name. This is because it uses a specialized
    --    constructor function expression that only takes as many parameters as
    --    there are argument types that mention the last type variable.
    mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)
                      -> Name
                      -> [(Bool, Exp)]
                      -> Q Match
    mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> Q Match
    mkSimpleConMatch2 Exp -> [Exp] -> Q Exp
    fold Name
    conName [(Bool, Exp)]
    insides = do
      [Name]
    varsNeeded <- String -> Int -> Q [Name]
    newNameList String
    "_arg" Int
    lengthInsides
      let pat :: Pat
    pat = Name -> [Pat] -> Pat
    conPCompat Name
    conName ((Name -> Pat) -> [Name] -> [Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Pat
    VarP [Name]
    varsNeeded)
          -- Make sure to zip BEFORE invoking catMaybes. We want the variable
          -- indicies in each expression to match up with the argument indices
          -- in conExpr (defined below).
          exps :: [Exp]
    exps = [Maybe Exp] -> [Exp]
    forall a. [Maybe a] -> [a]
    catMaybes ([Maybe Exp] -> [Exp]) -> [Maybe Exp] -> [Exp]
    forall a b. (a -> b) -> a -> b
    $ ((Bool, Exp) -> Name -> Maybe Exp)
    -> [(Bool, Exp)] -> [Name] -> [Maybe Exp]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\(Bool
    m, Exp
    i) Name
    v -> if Bool
    m then Exp -> Maybe Exp
    forall a. a -> Maybe a
    Just (Exp
    i Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    v)
                                                        else Maybe Exp
    forall a. Maybe a
    Nothing)
                                     [(Bool, Exp)]
    insides [Name]
    varsNeeded
          -- An element of argTysTyVarInfo is True if the constructor argument
          -- with the same index has a type which mentions the last type
          -- variable.
          argTysTyVarInfo :: [Bool]
    argTysTyVarInfo = ((Bool, Exp) -> Bool) -> [(Bool, Exp)] -> [Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Bool
    m, Exp
    _) -> Bool
    m) [(Bool, Exp)]
    insides
          ([Name]
    asWithTyVar, [Name]
    asWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
    forall a. [Bool] -> [a] -> ([a], [a])
    partitionByList [Bool]
    argTysTyVarInfo [Name]
    varsNeeded

          conExpQ :: Q Exp
    conExpQ
            | [Name] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    asWithTyVar = [Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conNameQ Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :(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]
    asWithoutTyVar)
            | Bool
    otherwise = do
                [Name]
    bs <- String -> Int -> Q [Name]
    newNameList String
    "b" Int
    lengthInsides
                let bs' :: [Name]
    bs'  = [Bool] -> [Name] -> [Name]
    forall a. [Bool] -> [a] -> [a]
    filterByList  [Bool]
    argTysTyVarInfo [Name]
    bs
                    vars :: [Q Exp]
    vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [Bool] -> [a] -> [a] -> [a]
    filterByLists [Bool]
    argTysTyVarInfo
                                         ((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]
    bs) ((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]
    varsNeeded)
                [Q Pat] -> Q Exp -> Q Exp
    forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
    lamE ((Name -> Q Pat) -> [Name] -> [Q Pat]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP [Name]
    bs') ([Q Exp] -> Q Exp
    forall (m :: * -> *). Quote m => [m Exp] -> m Exp
    appsE (Name -> Q Exp
    forall (m :: * -> *). Quote m => Name -> m Exp
    conE Name
    conNameQ Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :[Q Exp]
    vars))

      Exp
    conExp <- Q Exp
    conExpQ
      Exp
    rhs <- Exp -> [Exp] -> Q Exp
    fold Exp
    conExp [Exp]
    exps
      Match -> Q Match
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Match -> Q Match) -> Match -> Q Match
    forall a b. (a -> b) -> a -> b
    $ Pat -> Body -> [Dec] -> Match
    Match Pat
    pat (Exp -> Body
    NormalB Exp
    rhs) []
      where
        lengthInsides :: Int
    lengthInsides = [(Bool, Exp)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Bool, Exp)]
    insides

    -- Indicates whether a tuple is boxed or unboxed, as well as its number of
    -- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)
    -- corresponds to @Unboxed 3@.
    data TupleSort
      = Boxed   Int
    #if MIN_VERSION_template_haskell(2,6,0)
      | Unboxed Int
    #endif

    -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
    mkSimpleTupleCase :: (Name -> [a] -> Q Match)
                      -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase :: forall a.
    (Name -> [a] -> Q Match) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [a] -> Q Match
    matchForCon TupleSort
    tupSort [a]
    insides Exp
    x = do
      let tupDataName :: Name
    tupDataName = case TupleSort
    tupSort of
                          Boxed   Int
    len -> Int -> Name
    tupleDataName Int
    len
    #if MIN_VERSION_template_haskell(2,6,0)
                          Unboxed Int
    len -> Int -> Name
    unboxedTupleDataName Int
    len
    #endif
      Match
    m <- Name -> [a] -> Q Match
    matchForCon Name
    tupDataName [a]
    insides
      Exp -> Q Exp
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp -> [Match] -> Exp
    CaseE Exp
    x [Match
    m]

    -- Adapt to the type of ConP changing in template-haskell-2.18.0.0.
    conPCompat :: Name -> [Pat] -> Pat
    conPCompat :: Name -> [Pat] -> Pat
    conPCompat Name
    n [Pat]
    pats = Name -> [Type] -> [Pat] -> Pat
    ConP Name
    n
    #if MIN_VERSION_template_haskell(2,18,0)
                             []
    #endif
                             [Pat]
    pats