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

    #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, zipWithM)

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

    import           Language.Haskell.TH.Datatype
    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
    /= :: Options -> Options -> Bool
    $c/= :: Options -> Options -> Bool
    == :: Options -> Options -> Bool
    $c== :: 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
    min :: Options -> Options -> Options
    $cmin :: Options -> Options -> Options
    max :: Options -> Options -> Options
    $cmax :: Options -> Options -> Options
    >= :: Options -> Options -> Bool
    $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
    compare :: Options -> Options -> Ordering
    $ccompare :: Options -> Options -> Ordering
    $cp1Ord :: Eq 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
    readListPrec :: ReadPrec [Options]
    $creadListPrec :: ReadPrec [Options]
    readPrec :: ReadPrec Options
    $creadPrec :: ReadPrec Options
    readList :: ReadS [Options]
    $creadList :: ReadS [Options]
    readsPrec :: Int -> ReadS Options
    $creadsPrec :: Int -> ReadS 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
    showList :: [Options] -> ShowS
    $cshowList :: [Options] -> ShowS
    show :: Options -> String
    $cshow :: Options -> String
    showsPrec :: Int -> Options -> ShowS
    $cshowsPrec :: Int -> 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 :: Bool -> Options
    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 opts :: Options
    opts name :: Name
    name = [Q Exp] -> Q Exp
    appsE [ Options -> Name -> Q Exp
    makeBifoldMapOptions Options
    opts Name
    name
                                        , Name -> Q Exp
    varE Name
    idValName
                                        , Name -> Q 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 opts :: Options
    opts name :: Name
    name = do
      Name
    f <- String -> Q Name
    newName "f"
      Name
    g <- String -> Q Name
    newName "g"
      Name
    z <- String -> Q Name
    newName "z"
      Name
    t <- String -> Q Name
    newName "t"
      [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    f, Name -> PatQ
    varP Name
    g, Name -> PatQ
    varP Name
    z, Name -> PatQ
    varP Name
    t] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
        [Q Exp] -> Q Exp
    appsE [ Name -> Q Exp
    varE Name
    appEndoValName
              , [Q Exp] -> Q Exp
    appsE [ Name -> Q Exp
    varE Name
    getDualValName
                      , [Q Exp] -> Q 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
    varE Name
    t]
                      ]
              , Name -> Q Exp
    varE Name
    z
              ]
      where
        foldFun :: Name -> Q Exp
        foldFun :: Name -> Q Exp
    foldFun n :: Name
    n = Q Exp -> Q Exp -> Q Exp -> Q Exp
    infixApp (Name -> Q Exp
    conE Name
    dualDataName)
                             (Name -> Q Exp
    varE Name
    composeValName)
                             (Q Exp -> Q Exp -> Q Exp -> Q Exp
    infixApp (Name -> Q Exp
    conE Name
    endoDataName)
                                       (Name -> Q Exp
    varE Name
    composeValName)
                                       (Name -> Q Exp
    varE Name
    flipValName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q 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 opts :: Options
    opts name :: Name
    name = [Q Exp] -> Q Exp
    appsE [ Options -> Name -> Q Exp
    makeBitraverseOptions Options
    opts Name
    name
                                             , Name -> Q Exp
    varE Name
    idValName
                                             , Name -> Q 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 opts :: Options
    opts name :: Name
    name = do
      Name
    f <- String -> Q Name
    newName "f"
      Name
    g <- String -> Q Name
    newName "g"
      [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    f, Name -> PatQ
    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
    infixApp (Name -> Q Exp
    varE Name
    unwrapMonadValName) (Name -> Q Exp
    varE Name
    composeValName) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                              [Q Exp] -> Q 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 n :: Name
    n = Q Exp -> Q Exp -> Q Exp -> Q Exp
    infixApp (Name -> Q Exp
    conE Name
    wrapMonadDataName) (Name -> Q Exp
    varE Name
    composeValName) (Name -> Q 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 opts :: Options
    opts name :: Name
    name = [Q Exp] -> Q Exp
    appsE [ Options -> Name -> Q Exp
    makeBimapMOptions Options
    opts Name
    name
                                            , Name -> Q Exp
    varE Name
    idValName
                                            , Name -> Q 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
    biClass opts :: Options
    opts name :: Name
    name = do
      DatatypeInfo
    info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case DatatypeInfo
    info of
        DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
    datatypeContext   = Cxt
    ctxt
                     , datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    parentName
                     , datatypeInstTypes :: DatatypeInfo -> Cxt
    datatypeInstTypes = Cxt
    instTys
                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                     } -> do
          (instanceCxt :: Cxt
    instanceCxt, instanceType :: Type
    instanceType)
              <- BiClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance BiClass
    biClass Name
    parentName Cxt
    ctxt Cxt
    instTys DatatypeVariant
    variant
          (Dec -> [Dec] -> [Dec]
    forall a. a -> [a] -> [a]
    :[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
    instanceD (Cxt -> CxtQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    instanceCxt)
                                 (Type -> TypeQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    instanceType)
                                 (BiClass -> Options -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
    biFunDecs BiClass
    biClass Options
    opts Name
    parentName Cxt
    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 -> Cxt -> [ConstructorInfo] -> [Q Dec]
    biFunDecs biClass :: BiClass
    biClass opts :: Options
    opts parentName :: Name
    parentName instTys :: Cxt
    instTys cons :: [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
    biFun =
          Name -> [ClauseQ] -> Q Dec
    funD (BiFun -> Name
    biFunName BiFun
    biFun)
               [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
    clause []
                        (Q Exp -> BodyQ
    normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons BiFun
    biFun Options
    opts Name
    parentName Cxt
    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
    biFun opts :: Options
    opts name :: Name
    name = do
      DatatypeInfo
    info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case DatatypeInfo
    info of
        DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
    datatypeContext   = Cxt
    ctxt
                     , datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    parentName
                     , datatypeInstTypes :: DatatypeInfo -> Cxt
    datatypeInstTypes = Cxt
    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 -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance (BiFun -> BiClass
    biFunToClass BiFun
    biFun) Name
    parentName Cxt
    ctxt Cxt
    instTys DatatypeVariant
    variant
            Q (Cxt, Type) -> Q Exp -> Q Exp
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> BiFun -> Options -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons BiFun
    biFun Options
    opts Name
    parentName Cxt
    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 -> Cxt -> [ConstructorInfo] -> Q Exp
    makeBiFunForCons biFun :: BiFun
    biFun opts :: Options
    opts _parentName :: Name
    _parentName instTys :: Cxt
    instTys cons :: [ConstructorInfo]
    cons = do
      [Name]
    argNames <- (String -> Q Name) -> [String] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM String -> Q Name
    newName ([String] -> Q [Name]) -> [String] -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ [Maybe String] -> [String]
    forall a. [Maybe a] -> [a]
    catMaybes [ String -> Maybe String
    forall a. a -> Maybe a
    Just "f"
                                           , String -> Maybe String
    forall a. a -> Maybe a
    Just "g"
                                           , 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 String -> Maybe String
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> String -> Maybe String
    forall a. a -> Maybe a
    Just "z"
                                           , String -> Maybe String
    forall a. a -> Maybe a
    Just "value"
                                           ]
      let ([map1 :: Name
    map1, map2 :: Name
    map2], others :: [Name]
    others) = Int -> [Name] -> ([Name], [Name])
    forall a. Int -> [a] -> ([a], [a])
    splitAt 2 [Name]
    argNames
          z :: Name
    z          = [Name] -> Name
    forall a. [a] -> a
    head [Name]
    others -- If we're deriving bifoldr, this will be well defined
                                   -- and useful. Otherwise, it'll be ignored.
          value :: Name
    value      = [Name] -> Name
    forall a. [a] -> a
    last [Name]
    others
          lastTyVars :: [Name]
    lastTyVars = (Type -> Name) -> Cxt -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> Name
    varTToName (Cxt -> [Name]) -> Cxt -> [Name]
    forall a b. (a -> b) -> a -> b
    $ Int -> Cxt -> Cxt
    forall a. Int -> [a] -> [a]
    drop (Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    instTys Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 2) Cxt
    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]
      [PatQ] -> Q Exp -> Q Exp
    lamE ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    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
    appsE
          ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [ Name -> Q 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
    varE [Name]
    argNames
      where
        makeFun :: Name -> Name -> TyVarMap -> Q Exp
        makeFun :: Name -> Name -> Map Name Name -> Q Exp
    makeFun z :: Name
    z value :: Name
    value tvMap :: 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 (rs :: [Role]
    rs, PhantomR) <- [Role] -> Maybe ([Role], Role)
    forall a. [a] -> Maybe ([a], a)
    unsnoc [Role]
    roles
              , Just (_,  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 (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 (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 -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    value)
                      ((ConstructorInfo -> MatchQ) -> [ConstructorInfo] -> [MatchQ]
    forall a b. (a -> b) -> [a] -> [b]
    map (BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
    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 z :: Name
    z value :: Name
    value =
            Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    coerce
                         (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    coerce)
                         BiFun
    biFun Name
    z
          where
            coerce :: Q Exp
            coerce :: Q Exp
    coerce = Name -> Q Exp
    varE Name
    coerceValName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    value
    #endif

    -- | Generates a lambda expression for a single constructor.
    makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match
    makeBiFunForCon :: BiFun -> Name -> Map Name Name -> ConstructorInfo -> MatchQ
    makeBiFunForCon biFun :: BiFun
    biFun z :: Name
    z tvMap :: Map Name Name
    tvMap
      (ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                       , constructorContext :: ConstructorInfo -> Cxt
    constructorContext = Cxt
    ctxt
                       , constructorFields :: ConstructorInfo -> Cxt
    constructorFields  = Cxt
    ts }) = do
        Cxt
    ts'      <- (Type -> TypeQ) -> Cxt -> CxtQ
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Type -> TypeQ
    resolveTypeSynonyms Cxt
    ts
        [Name]
    argNames <- String -> Int -> Q [Name]
    newNameList "_arg" (Int -> Q [Name]) -> Int -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    ts'
        if ((Type -> Bool) -> Cxt -> 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) Cxt
    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
    < 2)
              Bool -> Bool -> Bool
    && Bool -> Bool
    not (BiClass -> Bool
    allowExQuant (BiFun -> BiClass
    biFunToClass BiFun
    biFun))
           then Name -> MatchQ
    forall a. Name -> a
    existentialContextError Name
    conName
           else BiFun -> Name -> Map Name Name -> Name -> Cxt -> [Name] -> MatchQ
    makeBiFunForArgs BiFun
    biFun Name
    z Map Name Name
    tvMap Name
    conName Cxt
    ts' [Name]
    argNames

    -- | Generates a lambda expression for a single constructor's arguments.
    makeBiFunForArgs :: BiFun
                     -> Name
                     -> TyVarMap
                     -> Name
                     -> [Type]
                     -> [Name]
                     -> Q Match
    makeBiFunForArgs :: BiFun -> Name -> Map Name Name -> Name -> Cxt -> [Name] -> MatchQ
    makeBiFunForArgs biFun :: BiFun
    biFun z :: Name
    z tvMap :: Map Name Name
    tvMap conName :: Name
    conName tys :: Cxt
    tys args :: [Name]
    args =
      PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match (Name -> [PatQ] -> PatQ
    conP Name
    conName ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ (Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    args)
            (Q Exp -> BodyQ
    normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    biFunCombine BiFun
    biFun Name
    conName Name
    z [Name]
    args Q [Either Exp Exp]
    mappedArgs)
            []
      where
        mappedArgs :: Q [Either Exp Exp]
        mappedArgs :: Q [Either Exp Exp]
    mappedArgs = (Type -> Name -> Q (Either Exp Exp))
    -> Cxt -> [Name] -> Q [Either Exp Exp]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM (BiFun
    -> Map Name Name -> Name -> Type -> Name -> Q (Either Exp Exp)
    makeBiFunForArg BiFun
    biFun Map Name Name
    tvMap Name
    conName) Cxt
    tys [Name]
    args

    -- | Generates a lambda expression for a single argument of a constructor.
    --  The returned value is 'Right' if its type mentions one of the last two type
    -- parameters. Otherwise, it is 'Left'.
    makeBiFunForArg :: BiFun
                    -> TyVarMap
                    -> Name
                    -> Type
                    -> Name
                    -> Q (Either Exp Exp)
    makeBiFunForArg :: BiFun
    -> Map Name Name -> Name -> Type -> Name -> Q (Either Exp Exp)
    makeBiFunForArg biFun :: BiFun
    biFun tvMap :: Map Name Name
    tvMap conName :: Name
    conName ty :: Type
    ty tyExpName :: Name
    tyExpName =
      BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    True Type
    ty Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    `appEitherE` Name -> Q Exp
    varE Name
    tyExpName

    -- | Generates a lambda expression for a specific type. The returned value is
    -- 'Right' if its type mentions one of the last two type parameters. Otherwise,
    -- it is 'Left'.
    makeBiFunForType :: BiFun
                     -> TyVarMap
                     -> Name
                     -> Bool
                     -> Type
                     -> Q (Either Exp Exp)
    makeBiFunForType :: BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType biFun :: BiFun
    biFun tvMap :: Map Name Name
    tvMap conName :: Name
    conName covariant :: Bool
    covariant (VarT tyName :: Name
    tyName) =
      case Name -> Map Name Name -> Maybe Name
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    tyName Map Name Name
    tvMap of
        Just mapName :: Name
    mapName -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. b -> Either a b
    Right (Q Exp -> Q (Either Exp Exp))
    -> (Name -> Q Exp) -> Name -> Q (Either Exp Exp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Name -> Q Exp
    varE (Name -> Q (Either Exp Exp)) -> Name -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $
                            if Bool
    covariant
                               then Name
    mapName
                               else Name -> Name
    forall a. Name -> a
    contravarianceError Name
    conName
        Nothing -> (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. a -> Either a b
    Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Q Exp
    biFunTriv BiFun
    biFun
    makeBiFunForType biFun :: BiFun
    biFun tvMap :: Map Name Name
    tvMap conName :: Name
    conName covariant :: Bool
    covariant (SigT ty :: Type
    ty _) =
      BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    covariant Type
    ty
    makeBiFunForType biFun :: BiFun
    biFun tvMap :: Map Name Name
    tvMap conName :: Name
    conName covariant :: Bool
    covariant (ForallT _ _ ty :: Type
    ty) =
      BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    covariant Type
    ty
    makeBiFunForType biFun :: BiFun
    biFun tvMap :: Map Name Name
    tvMap conName :: Name
    conName covariant :: Bool
    covariant ty :: Type
    ty =
      let tyCon  :: Type
          tyArgs :: [Type]
          tyCon :: Type
    tyCon:tyArgs :: Cxt
    tyArgs = Type -> Cxt
    unapplyTy Type
    ty

          numLastArgs :: Int
          numLastArgs :: Int
    numLastArgs = Int -> Int -> Int
    forall a. Ord a => a -> a -> a
    min 2 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    tyArgs

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

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

          mentionsTyArgs :: Bool
          mentionsTyArgs :: Bool
    mentionsTyArgs = (Type -> Bool) -> Cxt -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `mentionsName` [Name]
    tyVarNames) Cxt
    tyArgs

          makeBiFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int
                         -> Q (Either Exp Exp)
          makeBiFunTuple :: ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
    makeBiFunTuple mkTupP :: [PatQ] -> PatQ
    mkTupP mkTupleDataName :: Int -> Name
    mkTupleDataName n :: Int
    n = do
            [Name]
    args <- (String -> Q Name) -> [String] -> Q [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM String -> Q Name
    newName ([String] -> Q [Name]) -> [String] -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ [Maybe String] -> [String]
    forall a. [Maybe a] -> [a]
    catMaybes [ String -> Maybe String
    forall a. a -> Maybe a
    Just "x"
                                             , 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 String -> Maybe String
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> String -> Maybe String
    forall a. a -> Maybe a
    Just "z"
                                             ]
            [Name]
    xs <- String -> Int -> Q [Name]
    newNameList "_tup" Int
    n

            let x :: Name
    x = [Name] -> Name
    forall a. [a] -> a
    head [Name]
    args
                z :: Name
    z = [Name] -> Name
    forall a. [a] -> a
    last [Name]
    args
            (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. b -> Either a b
    Right (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $ [PatQ] -> Q Exp -> Q Exp
    lamE ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    args) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Q Exp -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    x)
                 [ PatQ -> BodyQ -> [Q Dec] -> MatchQ
    match ([PatQ] -> PatQ
    mkTupP ([PatQ] -> PatQ) -> [PatQ] -> PatQ
    forall a b. (a -> b) -> a -> b
    $ (Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    xs)
                         (Q Exp -> BodyQ
    normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    biFunCombine BiFun
    biFun
                                                 (Int -> Name
    mkTupleDataName Int
    n)
                                                 Name
    z
                                                 [Name]
    xs
                                                 ((Type -> Name -> Q (Either Exp Exp))
    -> Cxt -> [Name] -> Q [Either Exp Exp]
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m [c]
    zipWithM Type -> Name -> Q (Either Exp Exp)
    makeBiFunTupleField Cxt
    tyArgs [Name]
    xs)
                         )
                         []
                 ]

          makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
          makeBiFunTupleField :: Type -> Name -> Q (Either Exp Exp)
    makeBiFunTupleField fieldTy :: Type
    fieldTy fieldName :: Name
    fieldName =
            BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    covariant Type
    fieldTy
              Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    `appEitherE` Name -> Q Exp
    varE Name
    fieldName

       in case Type
    tyCon of
         ArrowT
           | Bool -> Bool
    not (BiClass -> Bool
    allowFunTys (BiFun -> BiClass
    biFunToClass BiFun
    biFun)) -> Name -> Q (Either Exp Exp)
    forall a. Name -> a
    noFunctionsError Name
    conName
           | Bool
    mentionsTyArgs, [argTy :: Type
    argTy, resTy :: Type
    resTy] <- Cxt
    tyArgs ->
             do Name
    x <- String -> Q Name
    newName "x"
                Name
    b <- String -> Q Name
    newName "b"
                (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. b -> Either a b
    Right (Q Exp -> Q (Either Exp Exp))
    -> (Q Exp -> Q Exp) -> Q Exp -> Q (Either Exp Exp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    x, Name -> PatQ
    varP Name
    b] (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $
                  Bool -> Type -> Q Exp
    covBiFun Bool
    covariant Type
    resTy Q Exp -> Q Exp -> Q Exp
    `appE` (Name -> Q Exp
    varE Name
    x Q Exp -> Q Exp -> Q Exp
    `appE`
                    (Bool -> Type -> Q Exp
    covBiFun (Bool -> Bool
    not Bool
    covariant) Type
    argTy Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    b))
             where
               covBiFun :: Bool -> Type -> Q Exp
               covBiFun :: Bool -> Type -> Q Exp
    covBiFun cov :: Bool
    cov = (Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Either Exp Exp -> Exp
    forall a. Either a a -> a
    fromEither (Q (Either Exp Exp) -> Q Exp)
    -> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    cov
    #if MIN_VERSION_template_haskell(2,6,0)
         UnboxedTupleT n :: Int
    n
           | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 0 Bool -> Bool -> Bool
    && Bool
    mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
    makeBiFunTuple [PatQ] -> PatQ
    unboxedTupP Int -> Name
    unboxedTupleDataName Int
    n
    #endif
         TupleT n :: Int
    n
           | Int
    n Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > 0 Bool -> Bool -> Bool
    && Bool
    mentionsTyArgs -> ([PatQ] -> PatQ) -> (Int -> Name) -> Int -> Q (Either Exp Exp)
    makeBiFunTuple [PatQ] -> PatQ
    tupP Int -> Name
    tupleDataName Int
    n
         _ -> do
             Bool
    itf <- Type -> Q Bool
    isTyFamily Type
    tyCon
             if (Type -> Bool) -> Cxt -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `mentionsName` [Name]
    tyVarNames) Cxt
    lhsArgs Bool -> Bool -> Bool
    || (Bool
    itf Bool -> Bool -> Bool
    && Bool
    mentionsTyArgs)
               then Name -> Q (Either Exp Exp)
    forall a. Name -> a
    outOfPlaceTyVarError Name
    conName
               else if (Type -> Bool) -> Cxt -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `mentionsName` [Name]
    tyVarNames) Cxt
    rhsArgs
                      then (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. b -> Either a b
    Right (Q Exp -> Q (Either Exp Exp))
    -> ([Q Exp] -> Q Exp) -> [Q Exp] -> Q (Either Exp Exp)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BiFun -> Q Exp -> Q Exp
    biFunApp BiFun
    biFun (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
    appsE ([Q Exp] -> Q (Either Exp Exp)) -> [Q Exp] -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $
                             ( Name -> Q Exp
    varE (Maybe Name -> Name
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe Name -> Name) -> Maybe Name -> Name
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Int -> Maybe Name
    biFunArity BiFun
    biFun Int
    numLastArgs)
                             Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    : (Type -> Q Exp) -> Cxt -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Either Exp Exp -> Exp) -> Q (Either Exp Exp) -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Either Exp Exp -> Exp
    forall a. Either a a -> a
    fromEither (Q (Either Exp Exp) -> Q Exp)
    -> (Type -> Q (Either Exp Exp)) -> Type -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . BiFun
    -> Map Name Name -> Name -> Bool -> Type -> Q (Either Exp Exp)
    makeBiFunForType BiFun
    biFun Map Name Name
    tvMap Name
    conName Bool
    covariant)
                                    Cxt
    rhsArgs
                             )
                      else (Exp -> Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> Either Exp Exp
    forall a b. a -> Either a b
    Left (Q Exp -> Q (Either Exp Exp)) -> Q Exp -> Q (Either Exp Exp)
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Q Exp
    biFunTriv BiFun
    biFun

    -------------------------------------------------------------------------------
    -- 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 -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance biClass :: BiClass
    biClass tyConName :: Name
    tyConName dataCxt :: Cxt
    dataCxt instTysOrig :: Cxt
    instTysOrig variant :: 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.)
        Cxt
    varTysExp <- (Type -> TypeQ) -> Cxt -> CxtQ
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Type -> TypeQ
    resolveTypeSynonyms Cxt
    instTysOrig

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

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

            droppedStarKindStati :: [StarKindStatus]
            droppedStarKindStati :: [StarKindStatus]
    droppedStarKindStati = (Type -> StarKindStatus) -> Cxt -> [StarKindStatus]
    forall a b. (a -> b) -> [a] -> [b]
    map Type -> StarKindStatus
    canRealizeKindStar Cxt
    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
    < 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 -> 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 :: Cxt
    varTysExpSubst = (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar [Name]
    droppedKindVarNames) Cxt
    varTysExp

            remainingTysExpSubst, droppedTysExpSubst :: [Type]
            (remainingTysExpSubst :: Cxt
    remainingTysExpSubst, droppedTysExpSubst :: Cxt
    droppedTysExpSubst) =
              Int -> Cxt -> (Cxt, Cxt)
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    remainingLength Cxt
    varTysExpSubst

            -- All of the type variables mentioned in the dropped types
            -- (post-synonym expansion)
            droppedTyVarNames :: [Name]
            droppedTyVarNames :: [Name]
    droppedTyVarNames = Cxt -> [Name]
    forall a. TypeSubstitution a => a -> [Name]
    freeVariables Cxt
    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) -> Cxt -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all Type -> Bool
    hasKindStar Cxt
    droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          BiClass -> Name -> Q ()
    forall a. BiClass -> Name -> 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)
            (preds :: [Maybe Type]
    preds, kvNames :: [[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])) -> Cxt -> [(Maybe Type, [Name])]
    forall a b. (a -> b) -> [a] -> [b]
    map (BiClass -> Type -> (Maybe Type, [Name])
    deriveConstraint BiClass
    biClass) Cxt
    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' :: Cxt
    remainingTysExpSubst' =
              (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar [Name]
    kvNames') Cxt
    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 :: Cxt
    remainingTysOrigSubst =
              (Type -> Type) -> Cxt -> Cxt
    forall a b. (a -> b) -> [a] -> [b]
    map ([Name] -> Type -> Type
    substNamesWithKindStar ([Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    union [Name]
    droppedKindVarNames [Name]
    kvNames'))
                (Cxt -> Cxt) -> Cxt -> Cxt
    forall a b. (a -> b) -> a -> b
    $ Int -> Cxt -> Cxt
    forall a. Int -> [a] -> [a]
    take Int
    remainingLength Cxt
    instTysOrig

            isDataFamily :: Bool
            isDataFamily :: Bool
    isDataFamily = case DatatypeVariant
    variant of
                             Datatype        -> Bool
    False
                             Newtype         -> Bool
    False
                             DataInstance    -> Bool
    True
                             NewtypeInstance -> Bool
    True

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

            instanceCxt :: Cxt
            instanceCxt :: Cxt
    instanceCxt = [Maybe Type] -> Cxt
    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 -> Cxt -> Type
    applyTyCon Name
    tyConName Cxt
    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) -> Cxt -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (Type -> [Name] -> Bool
    `predMentionsName` [Name]
    droppedTyVarNames) Cxt
    dataCxt) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Name -> Type -> Q ()
    forall a. Name -> Type -> 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 (Cxt -> Cxt -> Bool
    canEtaReduce Cxt
    remainingTysExpSubst' Cxt
    droppedTysExpSubst) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $
          Type -> Q ()
    forall a. Type -> a
    etaReductionError Type
    instanceType
        (Cxt, Type) -> Q (Cxt, Type)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Cxt
    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
    biClass t :: 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 1 Type
    t of
          Just ns :: [Name]
    ns -> ((Name -> Name -> Type
    `applyClass` Name
    tName) (Name -> Type) -> Maybe Name -> Maybe Type
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` BiClass -> Int -> Maybe Name
    biClassConstraint BiClass
    biClass 1, [Name]
    ns)
          _ -> case Int -> Type -> Maybe [Name]
    hasKindVarChain 2 Type
    t of
                    Just ns :: [Name]
    ns -> ((Name -> Name -> Type
    `applyClass` Name
    tName) (Name -> Type) -> Maybe Name -> Maybe Type
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` BiClass -> Int -> Maybe Name
    biClassConstraint BiClass
    biClass 2, [Name]
    ns)
                    _       -> (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 -> a
    derivingKindError :: BiClass -> Name -> a
    derivingKindError biClass :: BiClass
    biClass tyConName :: Name
    tyConName = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> ShowS -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "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 ' '
      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 " ..."
        )
      ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "‘\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 " expects an argument of kind * -> * -> *"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ ""
      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 -> a
    contravarianceError :: Name -> a
    contravarianceError conName :: Name
    conName = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> ShowS -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "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 "‘ must not use the last type variable(s) in a function argument"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ ""

    -- | A constructor has a function argument in a derived Bifoldable or Bitraversable
    -- instance.
    noFunctionsError :: Name -> a
    noFunctionsError :: Name -> a
    noFunctionsError conName :: Name
    conName = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> ShowS -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "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 "‘ must not contain function types"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ ""

    -- | The data type has a DatatypeContext which mentions one of the eta-reduced
    -- type variables.
    datatypeContextError :: Name -> Type -> a
    datatypeContextError :: Name -> Type -> a
    datatypeContextError dataName :: Name
    dataName instanceType :: Type
    instanceType = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> ShowS -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "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 "‘:\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 "‘ must not have a class context involving the last type argument(s)"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ ""

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

    -- | 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 -> a
    outOfPlaceTyVarError :: Name -> a
    outOfPlaceTyVarError conName :: Name
    conName = String -> a
    forall a. HasCallStack => String -> a
    error
      (String -> a) -> ShowS -> String -> a
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString "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 "‘ 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 " the last two argument(s) of a data type"
      (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $ ""

    -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce
    -- function for the criteria it would have to meet).
    etaReductionError :: Type -> a
    etaReductionError :: Type -> a
    etaReductionError instanceType :: Type
    instanceType = String -> a
    forall a. HasCallStack => String -> a
    error (String -> a) -> String -> a
    forall a b. (a -> b) -> a -> b
    $
      "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

    -------------------------------------------------------------------------------
    -- 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
    /= :: BiFun -> BiFun -> Bool
    $c/= :: BiFun -> BiFun -> Bool
    == :: BiFun -> BiFun -> Bool
    $c== :: BiFun -> BiFun -> Bool
    Eq

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

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

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

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

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

    biClassConstraint :: BiClass -> Int -> Maybe Name
    biClassConstraint :: BiClass -> Int -> Maybe Name
    biClassConstraint Bifunctor     1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    functorTypeName
    biClassConstraint Bifoldable    1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    foldableTypeName
    biClassConstraint Bitraversable 1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    traversableTypeName
    biClassConstraint biClass :: BiClass
    biClass       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 _             _ = Maybe Name
    forall a. Maybe a
    Nothing

    biFunArity :: BiFun -> Int -> Maybe Name
    biFunArity :: BiFun -> Int -> Maybe Name
    biFunArity Bimap      1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    fmapValName
    biFunArity Bifoldr    1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    foldrValName
    biFunArity BifoldMap  1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    foldMapValName
    biFunArity Bitraverse 1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    traverseValName
    biFunArity biFun :: BiFun
    biFun      2 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Name -> Maybe Name) -> Name -> Maybe Name
    forall a b. (a -> b) -> a -> b
    $ BiFun -> Name
    biFunName BiFun
    biFun
    biFunArity _          _ = Maybe Name
    forall a. Maybe a
    Nothing

    allowFunTys :: BiClass -> Bool
    allowFunTys :: BiClass -> Bool
    allowFunTys Bifunctor = Bool
    True
    allowFunTys _         = Bool
    False

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

    -- See Trac #7436 for why explicit lambdas are used
    biFunTriv :: BiFun -> Q Exp
    biFunTriv :: BiFun -> Q Exp
    biFunTriv Bimap = do
      Name
    x <- String -> Q Name
    newName "x"
      [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    x] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    varE Name
    x
    -- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem
    -- useless, but they do serve a purpose.
    -- See Note [biFunTriv for Bifoldable and Bitraversable]
    biFunTriv Bifoldr = do
      Name
    z <- String -> Q Name
    newName "z"
      [PatQ] -> Q Exp -> Q Exp
    lamE [PatQ
    wildP, Name -> PatQ
    varP Name
    z] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    varE Name
    z
    biFunTriv BifoldMap = [PatQ] -> Q Exp -> Q Exp
    lamE [PatQ
    wildP] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    varE Name
    memptyValName
    biFunTriv Bitraverse = Name -> Q Exp
    varE Name
    pureValName

    biFunApp :: BiFun -> Q Exp -> Q Exp
    biFunApp :: BiFun -> Q Exp -> Q Exp
    biFunApp Bifoldr e :: Q Exp
    e = do
      Name
    x <- String -> Q Name
    newName "x"
      Name
    z <- String -> Q Name
    newName "z"
      [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    x, Name -> PatQ
    varP Name
    z] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Q Exp] -> Q Exp
    appsE [Q Exp
    e, Name -> Q Exp
    varE Name
    z, Name -> Q Exp
    varE Name
    x]
    biFunApp _ e :: Q Exp
    e = Q Exp
    e

    biFunCombine :: BiFun
                 -> Name
                 -> Name
                 -> [Name]
                 -> Q [Either Exp Exp]
                 -> Q Exp
    biFunCombine :: BiFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    biFunCombine Bimap      = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bimapCombine
    biFunCombine Bifoldr    = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bifoldrCombine
    biFunCombine BifoldMap  = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bifoldMapCombine
    biFunCombine Bitraverse = Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bitraverseCombine

    bimapCombine :: Name
                 -> Name
                 -> [Name]
                 -> Q [Either Exp Exp]
                 -> Q Exp
    bimapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bimapCombine conName :: Name
    conName _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' Exp -> Exp -> Exp
    AppE (Name -> Exp
    ConE Name
    conName) ([Exp] -> Exp)
    -> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either Exp Exp -> Exp) -> [Either Exp Exp] -> [Exp]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Either Exp Exp -> Exp
    forall a. Either a a -> a
    fromEither)

    -- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since
    -- they filter out subexpressions whose types do not mention one of the last two
    -- type parameters. See
    -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable
    -- for further discussion.

    bifoldrCombine :: Name
                   -> Name
                   -> [Name]
                   -> Q [Either Exp Exp]
                   -> Q Exp
    bifoldrCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bifoldrCombine _ zName :: Name
    zName _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr Exp -> Exp -> Exp
    AppE (Name -> Exp
    VarE Name
    zName) ([Exp] -> Exp)
    -> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Either Exp Exp] -> [Exp]
    forall a b. [Either a b] -> [b]
    rights)

    bifoldMapCombine :: Name
                     -> Name
                     -> [Name]
                     -> Q [Either Exp Exp]
                     -> Q Exp
    bifoldMapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bifoldMapCombine _ _ _ = ([Either Exp Exp] -> Exp) -> Q [Either Exp Exp] -> Q Exp
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ([Exp] -> Exp
    go ([Exp] -> Exp)
    -> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Either Exp Exp] -> [Exp]
    forall a b. [Either a b] -> [b]
    rights)
      where
        go :: [Exp] -> Exp
        go :: [Exp] -> Exp
    go [] = Name -> Exp
    VarE Name
    memptyValName
        go es :: [Exp]
    es = (Exp -> Exp -> Exp) -> [Exp] -> Exp
    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

    bitraverseCombine :: Name
                      -> Name
                      -> [Name]
                      -> Q [Either Exp Exp]
                      -> Q Exp
    bitraverseCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp
    bitraverseCombine conName :: Name
    conName _ args :: [Name]
    args essQ :: Q [Either Exp Exp]
    essQ = do
        [Either Exp Exp]
    ess <- Q [Either Exp Exp]
    essQ

        let argTysTyVarInfo :: [Bool]
            argTysTyVarInfo :: [Bool]
    argTysTyVarInfo = (Either Exp Exp -> Bool) -> [Either Exp Exp] -> [Bool]
    forall a b. (a -> b) -> [a] -> [b]
    map Either Exp Exp -> Bool
    forall l r. Either l r -> Bool
    isRight [Either Exp Exp]
    ess

            argsWithTyVar, argsWithoutTyVar :: [Name]
            (argsWithTyVar :: [Name]
    argsWithTyVar, argsWithoutTyVar :: [Name]
    argsWithoutTyVar) = [Bool] -> [Name] -> ([Name], [Name])
    forall a. [Bool] -> [a] -> ([a], [a])
    partitionByList [Bool]
    argTysTyVarInfo [Name]
    args

            conExpQ :: Q Exp
            conExpQ :: Q Exp
    conExpQ
              | [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    argsWithTyVar
              = [Q Exp] -> Q Exp
    appsE (Name -> Q 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
    varE [Name]
    argsWithoutTyVar)
              | Bool
    otherwise = do
                  [Name]
    bs <- String -> Int -> Q [Name]
    newNameList "b" (Int -> Q [Name]) -> Int -> Q [Name]
    forall a b. (a -> b) -> a -> b
    $ [Name] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Name]
    args
                  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
    varE [Name]
    bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    varE [Name]
    args)
                  [PatQ] -> Q Exp -> Q Exp
    lamE ((Name -> PatQ) -> [Name] -> [PatQ]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> PatQ
    varP [Name]
    bs') ([Q Exp] -> Q Exp
    appsE (Name -> Q Exp
    conE Name
    conNameQ Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :[Q Exp]
    vars))

        Exp
    conExp <- Q Exp
    conExpQ

        let go :: [Exp] -> Exp
            go :: [Exp] -> Exp
    go []  = Name -> Exp
    VarE Name
    pureValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp
            go [e :: Exp
    e] = Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp Exp -> Exp -> Exp
    `AppE` Exp
    e
            go (e1 :: Exp
    e1:e2 :: Exp
    e2:es :: [Exp]
    es) = (Exp -> Exp -> Exp) -> Exp -> [Exp] -> Exp
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl' (\se1 :: Exp
    se1 se2 :: 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))
              (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

        Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp)
    -> ([Either Exp Exp] -> Exp) -> [Either Exp Exp] -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Exp] -> Exp
    go ([Exp] -> Exp)
    -> ([Either Exp Exp] -> [Exp]) -> [Either Exp Exp] -> Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Either Exp Exp] -> [Exp]
    forall a b. [Either a b] -> [b]
    rights ([Either Exp Exp] -> Q Exp) -> [Either Exp Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Either Exp Exp]
    ess

    biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
    biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp
    biFunEmptyCase biFun :: BiFun
    biFun z :: Name
    z value :: Name
    value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    emptyCase
                     (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    emptyCase)
                     BiFun
    biFun Name
    z
      where
        emptyCase :: Q Exp
        emptyCase :: Q Exp
    emptyCase = Q Exp -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    value) []

    biFunNoCons :: BiFun -> Name -> Name -> Q Exp
    biFunNoCons :: BiFun -> Name -> Name -> Q Exp
    biFunNoCons biFun :: BiFun
    biFun z :: Name
    z value :: Name
    value =
        Q Exp -> Q Exp -> BiFun -> Name -> Q Exp
    biFunTrivial Q Exp
    seqAndError
                     (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    seqAndError)
                     BiFun
    biFun Name
    z
      where
        seqAndError :: Q Exp
        seqAndError :: Q Exp
    seqAndError = Q Exp -> Q Exp -> Q Exp
    appE (Name -> Q Exp
    varE Name
    seqValName) (Name -> Q Exp
    varE Name
    value) Q Exp -> Q Exp -> Q Exp
    `appE`
                      Q Exp -> Q Exp -> Q Exp
    appE (Name -> Q Exp
    varE Name
    errorValName)
                            (String -> Q Exp
    stringE (String -> Q Exp) -> String -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ "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 bimapE :: Q Exp
    bimapE bitraverseE :: Q Exp
    bitraverseE biFun :: BiFun
    biFun z :: Name
    z = BiFun -> Q Exp
    go BiFun
    biFun
      where
        go :: BiFun -> Q Exp
        go :: BiFun -> Q Exp
    go Bimap      = Q Exp
    bimapE
        go Bifoldr    = Name -> Q Exp
    varE Name
    z
        go BifoldMap  = Name -> Q Exp
    varE Name
    memptyValName
        go Bitraverse = Q Exp
    bitraverseE

    {-
    Note [biFunTriv 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 biFunTriv 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 biFunTriv (\_ -> mempty) as the first argument to the recursive
    call to bifoldMap, since that is how the algorithm handles polymorphic recursion.
    -}