    {-# LANGUAGE CPP #-}
    {-# LANGUAGE GADTs #-}
    {-# LANGUAGE ScopedTypeVariables #-}
    {-|
    Module:      Data.Functor.Deriving.Internal
    Copyright:   (C) 2015-2017 Ryan Scott
    License:     BSD-style (see the file LICENSE)
    Maintainer:  Ryan Scott
    Portability: Template Haskell

    The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances.

    For more info on how deriving @Functor@ works, see
    <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor this GHC wiki page>.

    Note: this is an internal module, and as such, the API presented here is not
    guaranteed to be stable, even between minor releases of this library.
    -}
    module Data.Functor.Deriving.Internal (
          -- * 'Foldable'
          deriveFoldable
        , deriveFoldableOptions
        , makeFoldMap
        , makeFoldMapOptions
        , makeFoldr
        , makeFoldrOptions
        , makeFold
        , makeFoldOptions
        , makeFoldl
        , makeFoldlOptions
        , makeNull
        , makeNullOptions
          -- * 'Functor'
        , deriveFunctor
        , deriveFunctorOptions
        , makeFmap
        , makeFmapOptions
        , makeReplace
        , makeReplaceOptions
          -- * 'Traversable'
        , deriveTraversable
        , deriveTraversableOptions
        , makeTraverse
        , makeTraverseOptions
        , makeSequenceA
        , makeSequenceAOptions
        , makeMapM
        , makeMapMOptions
        , makeSequence
        , makeSequenceOptions
          -- * 'FFTOptions'
        , FFTOptions(..)
        , defaultFFTOptions
        ) where

    import           Control.Monad (guard)

    import           Data.Deriving.Internal
    import           Data.List
    import qualified Data.Map as Map ((!), keys, lookup, member, singleton)
    import           Data.Maybe

    import           Language.Haskell.TH.Datatype
    import           Language.Haskell.TH.Lib
    import           Language.Haskell.TH.Syntax

    -- | Options that further configure how the functions in "Data.Functor.Deriving"
    -- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.)
    newtype FFTOptions = FFTOptions
      { FFTOptions -> Bool
    fftEmptyCaseBehavior :: 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 (FFTOptions -> FFTOptions -> Bool
    (FFTOptions -> FFTOptions -> Bool)
    -> (FFTOptions -> FFTOptions -> Bool) -> Eq FFTOptions
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: FFTOptions -> FFTOptions -> Bool
    $c/= :: FFTOptions -> FFTOptions -> Bool
    == :: FFTOptions -> FFTOptions -> Bool
    $c== :: FFTOptions -> FFTOptions -> Bool
    Eq, Eq FFTOptions
    Eq FFTOptions =>
    (FFTOptions -> FFTOptions -> Ordering)
    -> (FFTOptions -> FFTOptions -> Bool)
    -> (FFTOptions -> FFTOptions -> Bool)
    -> (FFTOptions -> FFTOptions -> Bool)
    -> (FFTOptions -> FFTOptions -> Bool)
    -> (FFTOptions -> FFTOptions -> FFTOptions)
    -> (FFTOptions -> FFTOptions -> FFTOptions)
    -> Ord FFTOptions
    FFTOptions -> FFTOptions -> Bool
    FFTOptions -> FFTOptions -> Ordering
    FFTOptions -> FFTOptions -> FFTOptions
    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 :: FFTOptions -> FFTOptions -> FFTOptions
    $cmin :: FFTOptions -> FFTOptions -> FFTOptions
    max :: FFTOptions -> FFTOptions -> FFTOptions
    $cmax :: FFTOptions -> FFTOptions -> FFTOptions
    >= :: FFTOptions -> FFTOptions -> Bool
    $c>= :: FFTOptions -> FFTOptions -> Bool
    > :: FFTOptions -> FFTOptions -> Bool
    $c> :: FFTOptions -> FFTOptions -> Bool
    <= :: FFTOptions -> FFTOptions -> Bool
    $c<= :: FFTOptions -> FFTOptions -> Bool
    < :: FFTOptions -> FFTOptions -> Bool
    $c< :: FFTOptions -> FFTOptions -> Bool
    compare :: FFTOptions -> FFTOptions -> Ordering
    $ccompare :: FFTOptions -> FFTOptions -> Ordering
    $cp1Ord :: Eq FFTOptions
    Ord, ReadPrec [FFTOptions]
    ReadPrec FFTOptions
    Int -> ReadS FFTOptions
    ReadS [FFTOptions]
    (Int -> ReadS FFTOptions)
    -> ReadS [FFTOptions]
    -> ReadPrec FFTOptions
    -> ReadPrec [FFTOptions]
    -> Read FFTOptions
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    readListPrec :: ReadPrec [FFTOptions]
    $creadListPrec :: ReadPrec [FFTOptions]
    readPrec :: ReadPrec FFTOptions
    $creadPrec :: ReadPrec FFTOptions
    readList :: ReadS [FFTOptions]
    $creadList :: ReadS [FFTOptions]
    readsPrec :: Int -> ReadS FFTOptions
    $creadsPrec :: Int -> ReadS FFTOptions
    Read, Int -> FFTOptions -> ShowS
    [FFTOptions] -> ShowS
    FFTOptions -> String
    (Int -> FFTOptions -> ShowS)
    -> (FFTOptions -> String)
    -> ([FFTOptions] -> ShowS)
    -> Show FFTOptions
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [FFTOptions] -> ShowS
    $cshowList :: [FFTOptions] -> ShowS
    show :: FFTOptions -> String
    $cshow :: FFTOptions -> String
    showsPrec :: Int -> FFTOptions -> ShowS
    $cshowsPrec :: Int -> FFTOptions -> ShowS
    Show)

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

    -- | Generates a 'Foldable' instance declaration for the given data type or data
    -- family instance.
    deriveFoldable :: Name -> Q [Dec]
    deriveFoldable :: Name -> Q [Dec]
    deriveFoldable = FFTOptions -> Name -> Q [Dec]
    deriveFoldableOptions FFTOptions
    defaultFFTOptions

    -- | Like 'deriveFoldable', but takes an 'FFTOptions' argument.
    deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
    deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec]
    deriveFoldableOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
    deriveFunctorClass FunctorClass
    Foldable

    -- | Generates a lambda expression which behaves like 'foldMap' (without requiring a
    -- 'Foldable' instance).
    makeFoldMap :: Name -> Q Exp
    makeFoldMap :: Name -> Q Exp
    makeFoldMap = FFTOptions -> Name -> Q Exp
    makeFoldMapOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeFoldMap', but takes an 'FFTOptions' argument.
    makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
    makeFoldMapOptions :: FFTOptions -> Name -> Q Exp
    makeFoldMapOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    FoldMap

    -- | Generates a lambda expression which behaves like 'null' (without requiring a
    -- 'Foldable' instance).
    makeNull :: Name -> Q Exp
    makeNull :: Name -> Q Exp
    makeNull = FFTOptions -> Name -> Q Exp
    makeNullOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeNull', but takes an 'FFTOptions' argument.
    makeNullOptions :: FFTOptions -> Name -> Q Exp
    makeNullOptions :: FFTOptions -> Name -> Q Exp
    makeNullOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    Null

    -- | Generates a lambda expression which behaves like 'foldr' (without requiring a
    -- 'Foldable' instance).
    makeFoldr :: Name -> Q Exp
    makeFoldr :: Name -> Q Exp
    makeFoldr = FFTOptions -> Name -> Q Exp
    makeFoldrOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeFoldr', but takes an 'FFTOptions' argument.
    makeFoldrOptions :: FFTOptions -> Name -> Q Exp
    makeFoldrOptions :: FFTOptions -> Name -> Q Exp
    makeFoldrOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    Foldr

    -- | Generates a lambda expression which behaves like 'fold' (without requiring a
    -- 'Foldable' instance).
    makeFold :: Name -> Q Exp
    makeFold :: Name -> Q Exp
    makeFold = FFTOptions -> Name -> Q Exp
    makeFoldOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeFold', but takes an 'FFTOptions' argument.
    makeFoldOptions :: FFTOptions -> Name -> Q Exp
    makeFoldOptions :: FFTOptions -> Name -> Q Exp
    makeFoldOptions opts :: FFTOptions
    opts name :: Name
    name = FFTOptions -> Name -> Q Exp
    makeFoldMapOptions FFTOptions
    opts Name
    name Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    idValName

    -- | Generates a lambda expression which behaves like 'foldl' (without requiring a
    -- 'Foldable' instance).
    makeFoldl :: Name -> Q Exp
    makeFoldl :: Name -> Q Exp
    makeFoldl = FFTOptions -> Name -> Q Exp
    makeFoldlOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeFoldl', but takes an 'FFTOptions' argument.
    makeFoldlOptions :: FFTOptions -> Name -> Q Exp
    makeFoldlOptions :: FFTOptions -> Name -> Q Exp
    makeFoldlOptions opts :: FFTOptions
    opts name :: Name
    name = do
      Name
    f <- String -> Q Name
    newName "f"
      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
    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 [ FFTOptions -> Name -> Q Exp
    makeFoldMapOptions FFTOptions
    opts Name
    name, Name -> Q Exp
    foldFun Name
    f, 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 'Functor' instance declaration for the given data type or data
    -- family instance.
    deriveFunctor :: Name -> Q [Dec]
    deriveFunctor :: Name -> Q [Dec]
    deriveFunctor = FFTOptions -> Name -> Q [Dec]
    deriveFunctorOptions FFTOptions
    defaultFFTOptions

    -- | Like 'deriveFunctor', but takes an 'FFTOptions' argument.
    deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
    deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec]
    deriveFunctorOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
    deriveFunctorClass FunctorClass
    Functor

    -- | Generates a lambda expression which behaves like 'fmap' (without requiring a
    -- 'Functor' instance).
    makeFmap :: Name -> Q Exp
    makeFmap :: Name -> Q Exp
    makeFmap = FFTOptions -> Name -> Q Exp
    makeFmapOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeFmap', but takes an 'FFTOptions' argument.
    makeFmapOptions :: FFTOptions -> Name -> Q Exp
    makeFmapOptions :: FFTOptions -> Name -> Q Exp
    makeFmapOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    Fmap

    -- | Generates a lambda expression which behaves like ('<$') (without requiring a
    -- 'Functor' instance).
    makeReplace :: Name -> Q Exp
    makeReplace :: Name -> Q Exp
    makeReplace = FFTOptions -> Name -> Q Exp
    makeReplaceOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeReplace', but takes an 'FFTOptions' argument.
    makeReplaceOptions :: FFTOptions -> Name -> Q Exp
    makeReplaceOptions :: FFTOptions -> Name -> Q Exp
    makeReplaceOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    Replace

    -- | Generates a 'Traversable' instance declaration for the given data type or data
    -- family instance.
    deriveTraversable :: Name -> Q [Dec]
    deriveTraversable :: Name -> Q [Dec]
    deriveTraversable = FFTOptions -> Name -> Q [Dec]
    deriveTraversableOptions FFTOptions
    defaultFFTOptions

    -- | Like 'deriveTraverse', but takes an 'FFTOptions' argument.
    deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
    deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec]
    deriveTraversableOptions = FunctorClass -> FFTOptions -> Name -> Q [Dec]
    deriveFunctorClass FunctorClass
    Traversable

    -- | Generates a lambda expression which behaves like 'traverse' (without requiring a
    -- 'Traversable' instance).
    makeTraverse :: Name -> Q Exp
    makeTraverse :: Name -> Q Exp
    makeTraverse = FFTOptions -> Name -> Q Exp
    makeTraverseOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeTraverse', but takes an 'FFTOptions' argument.
    makeTraverseOptions :: FFTOptions -> Name -> Q Exp
    makeTraverseOptions :: FFTOptions -> Name -> Q Exp
    makeTraverseOptions = FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun FunctorFun
    Traverse

    -- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a
    -- 'Traversable' instance).
    makeSequenceA :: Name -> Q Exp
    makeSequenceA :: Name -> Q Exp
    makeSequenceA = FFTOptions -> Name -> Q Exp
    makeSequenceAOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeSequenceA', but takes an 'FFTOptions' argument.
    makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
    makeSequenceAOptions :: FFTOptions -> Name -> Q Exp
    makeSequenceAOptions opts :: FFTOptions
    opts name :: Name
    name = FFTOptions -> Name -> Q Exp
    makeTraverseOptions FFTOptions
    opts Name
    name Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    idValName

    -- | Generates a lambda expression which behaves like 'mapM' (without requiring a
    -- 'Traversable' instance).
    makeMapM :: Name -> Q Exp
    makeMapM :: Name -> Q Exp
    makeMapM = FFTOptions -> Name -> Q Exp
    makeMapMOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeMapM', but takes an 'FFTOptions' argument.
    makeMapMOptions :: FFTOptions -> Name -> Q Exp
    makeMapMOptions :: FFTOptions -> Name -> Q Exp
    makeMapMOptions opts :: FFTOptions
    opts name :: Name
    name = do
      Name
    f <- String -> Q Name
    newName "f"
      PatQ -> Q Exp -> Q Exp
    lam1E (Name -> PatQ
    varP Name
    f) (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
    $
                       FFTOptions -> Name -> Q Exp
    makeTraverseOptions FFTOptions
    opts Name
    name Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    wrapMonadExp Name
    f
      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 'sequence' (without requiring a
    -- 'Traversable' instance).
    makeSequence :: Name -> Q Exp
    makeSequence :: Name -> Q Exp
    makeSequence = FFTOptions -> Name -> Q Exp
    makeSequenceOptions FFTOptions
    defaultFFTOptions

    -- | Like 'makeSequence', but takes an 'FFTOptions' argument.
    makeSequenceOptions :: FFTOptions -> Name -> Q Exp
    makeSequenceOptions :: FFTOptions -> Name -> Q Exp
    makeSequenceOptions opts :: FFTOptions
    opts name :: Name
    name = FFTOptions -> Name -> Q Exp
    makeMapMOptions FFTOptions
    opts Name
    name Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    idValName

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

    -- | Derive a class instance declaration (depending on the FunctorClass argument's value).
    deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec]
    deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec]
    deriveFunctorClass fc :: FunctorClass
    fc opts :: FFTOptions
    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
    instTypes
                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                     } -> do
          (instanceCxt :: Cxt
    instanceCxt, instanceType :: Type
    instanceType)
              <- FunctorClass
    -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    forall a.
    ClassRep a =>
    a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance FunctorClass
    fc Name
    parentName Cxt
    ctxt Cxt
    instTypes 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)
                                 (FunctorClass
    -> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
    functorFunDecs FunctorClass
    fc FFTOptions
    opts Name
    parentName Cxt
    instTypes [ConstructorInfo]
    cons)

    -- | Generates a declaration defining the primary function(s) corresponding to a
    -- particular class (fmap for Functor, foldr and foldMap for Foldable, and
    -- traverse for Traversable).
    --
    -- For why both foldr and foldMap are derived for Foldable, see Trac #7436.
    functorFunDecs
      :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
      -> [Q Dec]
    functorFunDecs :: FunctorClass
    -> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> [Q Dec]
    functorFunDecs fc :: FunctorClass
    fc opts :: FFTOptions
    opts parentName :: Name
    parentName instTypes :: Cxt
    instTypes cons :: [ConstructorInfo]
    cons =
      (FunctorFun -> Q Dec) -> [FunctorFun] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map FunctorFun -> Q Dec
    makeFunD ([FunctorFun] -> [Q Dec]) -> [FunctorFun] -> [Q Dec]
    forall a b. (a -> b) -> a -> b
    $ FunctorClass -> [FunctorFun]
    functorClassToFuns FunctorClass
    fc
      where
        makeFunD :: FunctorFun -> Q Dec
        makeFunD :: FunctorFun -> Q Dec
    makeFunD ff :: FunctorFun
    ff =
          Name -> [ClauseQ] -> Q Dec
    funD (FunctorFun -> Name
    functorFunName FunctorFun
    ff)
               [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
    clause []
                        (Q Exp -> BodyQ
    normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ FunctorFun
    -> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
    makeFunctorFunForCons FunctorFun
    ff FFTOptions
    opts Name
    parentName Cxt
    instTypes [ConstructorInfo]
    cons)
                        []
               ]

    -- | Generates a lambda expression which behaves like the FunctorFun argument.
    makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp
    makeFunctorFun ff :: FunctorFun
    ff opts :: FFTOptions
    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
    instTypes
                     , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                     , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons
                     } -> do
          -- We force buildTypeInstance here since it performs some checks for whether
          -- or not the provided datatype can actually have fmap/foldr/traverse/etc.
          -- implemented for it, and produces errors if it can't.
          FunctorClass
    -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    forall a.
    ClassRep a =>
    a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance (FunctorFun -> FunctorClass
    functorFunToClass FunctorFun
    ff) Name
    parentName Cxt
    ctxt Cxt
    instTypes DatatypeVariant
    variant
            Q (Cxt, Type) -> Q Exp -> Q Exp
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> FunctorFun
    -> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
    makeFunctorFunForCons FunctorFun
    ff FFTOptions
    opts Name
    parentName Cxt
    instTypes [ConstructorInfo]
    cons

    -- | Generates a lambda expression for the given constructors.
    -- All constructors must be from the same type.
    makeFunctorFunForCons
      :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]
      -> Q Exp
    makeFunctorFunForCons :: FunctorFun
    -> FFTOptions -> Name -> Cxt -> [ConstructorInfo] -> Q Exp
    makeFunctorFunForCons ff :: FunctorFun
    ff opts :: FFTOptions
    opts _parentName :: Name
    _parentName instTypes :: Cxt
    instTypes cons :: [ConstructorInfo]
    cons = do
      Name
    mapFun <- String -> Q Name
    newName "f"
      Name
    z      <- String -> Q Name
    newName "z" -- Only used for deriving foldr
      Name
    value  <- String -> Q Name
    newName "value"
      let argNames :: [Name]
    argNames  = [Maybe Name] -> [Name]
    forall a. [Maybe a] -> [a]
    catMaybes [ Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (FunctorFun
    ff FunctorFun -> FunctorFun -> Bool
    forall a. Eq a => a -> a -> Bool
    /= FunctorFun
    Null)  Maybe () -> Maybe Name -> Maybe Name
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    mapFun
                                , Bool -> Maybe ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (FunctorFun
    ff FunctorFun -> FunctorFun -> Bool
    forall a. Eq a => a -> a -> Bool
    == FunctorFun
    Foldr) Maybe () -> Maybe Name -> Maybe Name
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    z
                                , Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    value
                                ]
          lastTyVar :: Name
    lastTyVar = Type -> Name
    varTToName (Type -> Name) -> Type -> Name
    forall a b. (a -> b) -> a -> b
    $ Cxt -> Type
    forall a. [a] -> a
    last Cxt
    instTypes
          tvMap :: Map Name (OneOrTwoNames One)
    tvMap     = Name -> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
    forall k a. k -> a -> Map k a
    Map.singleton Name
    lastTyVar (OneOrTwoNames One -> Map Name (OneOrTwoNames One))
    -> OneOrTwoNames One -> Map Name (OneOrTwoNames One)
    forall a b. (a -> b) -> a -> b
    $ Name -> OneOrTwoNames One
    OneName Name
    mapFun
      [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
    $ FunctorFun -> Name
    functorFunConstName FunctorFun
    ff
            , Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
    makeFun Name
    z Name
    value Map Name (OneOrTwoNames One)
    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 -> TyVarMap1 -> Q Exp
        makeFun :: Name -> Name -> Map Name (OneOrTwoNames One) -> Q Exp
    makeFun z :: Name
    z value :: Name
    value tvMap :: Map Name (OneOrTwoNames One)
    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 (_, PhantomR) <- [Role] -> Maybe ([Role], Role)
    forall a. [a] -> Maybe ([a], a)
    unsnoc [Role]
    roles
             -> Name -> Name -> Q Exp
    functorFunPhantom Name
    z Name
    value
    #endif

              | [ConstructorInfo] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons Bool -> Bool -> Bool
    && FFTOptions -> Bool
    fftEmptyCaseBehavior FFTOptions
    opts Bool -> Bool -> Bool
    && Bool
    ghc7'8OrLater
             -> FunctorFun -> Name -> Name -> Q Exp
    functorFunEmptyCase FunctorFun
    ff Name
    z Name
    value

              | [ConstructorInfo] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [ConstructorInfo]
    cons
             -> FunctorFun -> Name -> Name -> Q Exp
    functorFunNoCons FunctorFun
    ff 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 (FunctorFun
    -> Name
    -> Map Name (OneOrTwoNames One)
    -> ConstructorInfo
    -> MatchQ
    makeFunctorFunForCon FunctorFun
    ff Name
    z Map Name (OneOrTwoNames One)
    tvMap) [ConstructorInfo]
    cons)

    #if MIN_VERSION_template_haskell(2,9,0)
        functorFunPhantom :: Name -> Name -> Q Exp
        functorFunPhantom :: Name -> Name -> Q Exp
    functorFunPhantom z :: Name
    z value :: Name
    value =
            Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
    functorFunTrivial Q Exp
    coerce
                              (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    coerce)
                              FunctorFun
    ff 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 match for a single constructor.
    makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match
    makeFunctorFunForCon :: FunctorFun
    -> Name
    -> Map Name (OneOrTwoNames One)
    -> ConstructorInfo
    -> MatchQ
    makeFunctorFunForCon ff :: FunctorFun
    ff z :: Name
    z tvMap :: Map Name (OneOrTwoNames One)
    tvMap
      con :: ConstructorInfo
    con@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    conName
                           , constructorContext :: ConstructorInfo -> Cxt
    constructorContext = Cxt
    ctxt }) = do
        FunctorClass
    -> Map Name (OneOrTwoNames One) -> Cxt -> Name -> MatchQ -> MatchQ
    forall a b c.
    ClassRep a =>
    a -> TyVarMap b -> Cxt -> Name -> Q c -> Q c
    checkExistentialContext (FunctorFun -> FunctorClass
    functorFunToClass FunctorFun
    ff) Map Name (OneOrTwoNames One)
    tvMap Cxt
    ctxt Name
    conName (MatchQ -> MatchQ) -> MatchQ -> MatchQ
    forall a b. (a -> b) -> a -> b
    $
          case FunctorFun
    ff of
            Fmap     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFmapMatch Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con
            Replace  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeReplaceMatch Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con
            Foldr    -> Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFoldrMatch Name
    z Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con
            FoldMap  -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFoldMapMatch Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con
            Null     -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeNullMatch Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con
            Traverse -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeTraverseMatch Map Name (OneOrTwoNames One)
    tvMap ConstructorInfo
    con

    -- | Generates a match whose right-hand side implements @fmap@.
    makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
    makeFmapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFmapMatch tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Exp -> Q Exp]
    parts <- Map Name (OneOrTwoNames One)
    -> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Exp -> Q Exp)
    ft_fmap ConstructorInfo
    con
      Name -> [Exp -> Q Exp] -> MatchQ
    match_for_con_functor Name
    conName [Exp -> Q Exp]
    parts
      where
        ft_fmap :: FFoldType (Exp -> Q Exp)
        ft_fmap :: FFoldType (Exp -> Q Exp)
    ft_fmap = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: Exp -> Q Exp
    ft_triv = Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                     , ft_var :: Name -> Exp -> Q Exp
    ft_var  = \v :: Name
    v x :: Exp
    x -> case Map Name (OneOrTwoNames One)
    tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v of
                                           OneName f :: Name
    f -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    f Exp -> Exp -> Exp
    `AppE` Exp
    x
                     , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_fun  = \g :: Exp -> Q Exp
    g h :: Exp -> Q Exp
    h x :: Exp
    x -> (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \b :: Exp
    b -> do
                         Exp
    gg <- Exp -> Q Exp
    g Exp
    b
                         Exp -> Q Exp
    h (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp
    x Exp -> Exp -> Exp
    `AppE` Exp
    gg
                     , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    ft_tup  = (Name -> [Exp -> Q Exp] -> MatchQ)
    -> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
    match_for_con_functor
                     , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_ty_app = \argTy :: Type
    argTy g :: Exp -> Q Exp
    g x :: Exp
    x -> do
                         case Type -> Maybe Name
    varTToName_maybe Type
    argTy of
                           -- If the argument type is a bare occurrence of the
                           -- data type's last type variable, then we can
                           -- generate more efficient code.
                           -- This was inspired by GHC#17880.
                           Just argVar :: Name
    argVar
                             |  Just (OneName f :: Name
    f) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    argVar Map Name (OneOrTwoNames One)
    tvMap
                             -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    f Exp -> Exp -> Exp
    `AppE` Exp
    x
                           _ -> do Exp
    gg <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    g
                                   Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Exp
    gg Exp -> Exp -> Exp
    `AppE` Exp
    x
                     , ft_forall :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_forall  = \_ g :: Exp -> Q Exp
    g x :: Exp
    x -> Exp -> Q Exp
    g Exp
    x
                     , ft_bad_app :: Exp -> Q Exp
    ft_bad_app = \_ -> FunctorClass -> Name -> Q Exp
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Functor Name
    conName
                     , ft_co_var :: Name -> Exp -> Q Exp
    ft_co_var  = \_ _ -> Name -> Q Exp
    forall a. Name -> Q a
    contravarianceError Name
    conName
                     }

    -- | Generates a match whose right-hand side implements @(<$)@.
    makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
    makeReplaceMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeReplaceMatch tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Exp -> Q Exp]
    parts <- Map Name (OneOrTwoNames One)
    -> FFoldType (Exp -> Q Exp) -> ConstructorInfo -> Q [Exp -> Q Exp]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Exp -> Q Exp)
    ft_replace ConstructorInfo
    con
      Name -> [Exp -> Q Exp] -> MatchQ
    match_for_con_functor Name
    conName [Exp -> Q Exp]
    parts
      where
        ft_replace :: FFoldType (Exp -> Q Exp)
        ft_replace :: FFoldType (Exp -> Q Exp)
    ft_replace = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: Exp -> Q Exp
    ft_triv = Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return
                        , ft_var :: Name -> Exp -> Q Exp
    ft_var  = \v :: Name
    v _ -> case Map Name (OneOrTwoNames One)
    tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v of
                                              OneName z :: Name
    z -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    z
                        , ft_fun :: (Exp -> Q Exp) -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_fun  = \g :: Exp -> Q Exp
    g h :: Exp -> Q Exp
    h x :: Exp
    x -> (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \b :: Exp
    b -> do
                            Exp
    gg <- Exp -> Q Exp
    g Exp
    b
                            Exp -> Q Exp
    h (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp
    x Exp -> Exp -> Exp
    `AppE` Exp
    gg
                        , ft_tup :: TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    ft_tup  = (Name -> [Exp -> Q Exp] -> MatchQ)
    -> TupleSort -> [Exp -> Q Exp] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [Exp -> Q Exp] -> MatchQ
    match_for_con_functor
                        , ft_ty_app :: Type -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_ty_app = \argTy :: Type
    argTy g :: Exp -> Q Exp
    g x :: Exp
    x -> do
                            case Type -> Maybe Name
    varTToName_maybe Type
    argTy of
                              -- If the argument type is a bare occurrence of the
                              -- data type's last type variable, then we can
                              -- generate more efficient code.
                              -- This was inspired by GHC#17880.
                              Just argVar :: Name
    argVar
                                |  Just (OneName z :: Name
    z) <- Name -> Map Name (OneOrTwoNames One) -> Maybe (OneOrTwoNames One)
    forall k a. Ord k => k -> Map k a -> Maybe a
    Map.lookup Name
    argVar Map Name (OneOrTwoNames One)
    tvMap
                                -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    replaceValName Exp -> Exp -> Exp
    `AppE` Name -> Exp
    VarE Name
    z Exp -> Exp -> Exp
    `AppE` Exp
    x
                              _ -> do Exp
    gg <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam Exp -> Q Exp
    g
                                      Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Exp
    gg Exp -> Exp -> Exp
    `AppE` Exp
    x
                        , ft_forall :: [TyVarBndr] -> (Exp -> Q Exp) -> Exp -> Q Exp
    ft_forall  = \_ g :: Exp -> Q Exp
    g x :: Exp
    x -> Exp -> Q Exp
    g Exp
    x
                        , ft_bad_app :: Exp -> Q Exp
    ft_bad_app = \_ -> FunctorClass -> Name -> Q Exp
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Functor Name
    conName
                        , ft_co_var :: Name -> Exp -> Q Exp
    ft_co_var  = \_ _ -> Name -> Q Exp
    forall a. Name -> Q a
    contravarianceError Name
    conName
                        }

    match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match
    match_for_con_functor :: Name -> [Exp -> Q Exp] -> MatchQ
    match_for_con_functor = (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
    forall a. (Name -> [a] -> Q Exp) -> Name -> [Exp -> a] -> MatchQ
    mkSimpleConMatch ((Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ)
    -> (Name -> [Q Exp] -> Q Exp) -> Name -> [Exp -> Q Exp] -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ \conName' :: Name
    conName' xs :: [Q Exp]
    xs ->
      [Q Exp] -> Q Exp
    appsE (Name -> Q Exp
    conE Name
    conName'Q Exp -> [Q Exp] -> [Q Exp]
    forall a. a -> [a] -> [a]
    :[Q Exp]
    xs) -- Con x1 x2 ..

    -- | Generates a match whose right-hand side implements @foldr@.
    makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match
    makeFoldrMatch :: Name -> Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFoldrMatch z :: Name
    z tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name (OneOrTwoNames One)
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Q (Bool, Exp))
    ft_foldr ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    parts
      Exp -> Name -> [(Bool, Exp)] -> MatchQ
    match_for_con (Name -> Exp
    VarE Name
    z) Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions the last type parameter, False
        -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
        -- expressions that do not mention the last parameter by checking for False.
        ft_foldr :: FFoldType (Q (Bool, Exp))
        ft_foldr :: FFoldType (Q (Bool, Exp))
    ft_foldr = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: Q (Bool, Exp)
    ft_triv = do Exp
    lam <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \_ z' :: Exp
    z' -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return Exp
    z'
                                     (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Exp
    lam)
                      , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \v :: Name
    v -> case Map Name (OneOrTwoNames One)
    tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v of
                                          OneName f :: Name
    f -> (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE Name
    f)
                      , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \t :: TupleSort
    t gs :: [Q (Bool, Exp)]
    gs -> do
                          [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    gs
                          Exp
    lam <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \x :: Exp
    x z' :: Exp
    z' ->
                            (Name -> [(Bool, Exp)] -> MatchQ)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase (Exp -> Name -> [(Bool, Exp)] -> MatchQ
    match_for_con Exp
    z') TupleSort
    t [(Bool, Exp)]
    gg Exp
    x
                          (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                      , ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_ty_app = \_ g :: Q (Bool, Exp)
    g -> do
                          (b :: Bool
    b, gg :: Exp
    gg) <- Q (Bool, Exp)
    g
                          Exp
    e <- (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 ((Exp -> Exp -> Q Exp) -> Q Exp) -> (Exp -> Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \x :: Exp
    x z' :: Exp
    z' -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                               Name -> Exp
    VarE Name
    foldrValName Exp -> Exp -> Exp
    `AppE` Exp
    gg Exp -> Exp -> Exp
    `AppE` Exp
    z' Exp -> Exp -> Exp
    `AppE` Exp
    x
                          (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    b, Exp
    e)
                      , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \_ g :: Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                      , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \_ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                      , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                      , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Foldable Name
    conName
                      }

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

    -- | Generates a match whose right-hand side implements @foldMap@.
    makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
    makeFoldMapMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeFoldMapMatch tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name (OneOrTwoNames One)
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Q (Bool, Exp))
    ft_foldMap ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    parts
      Name -> [(Bool, Exp)] -> MatchQ
    match_for_con Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions the last type parameter, False
        -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
        -- expressions that do not mention the last parameter by checking for False.
        ft_foldMap :: FFoldType (Q (Bool, Exp))
        ft_foldMap :: FFoldType (Q (Bool, Exp))
    ft_foldMap = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: Q (Bool, Exp)
    ft_triv = do Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \_ -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    memptyValName
                                       (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Exp
    lam)
                        , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \v :: Name
    v -> case Map Name (OneOrTwoNames One)
    tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v of
                                            OneName f :: Name
    f -> (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE Name
    f)
                        , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \t :: TupleSort
    t gs :: [Q (Bool, Exp)]
    gs -> do
                            [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    gs
                            Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> [(Bool, Exp)] -> MatchQ)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
    match_for_con TupleSort
    t [(Bool, Exp)]
    gg
                            (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                        , ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_ty_app = \_ g :: Q (Bool, Exp)
    g -> do
                            ((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\(b :: Bool
    b, e :: Exp
    e) -> (Bool
    b, Name -> Exp
    VarE Name
    foldMapValName Exp -> Exp -> Exp
    `AppE` Exp
    e)) Q (Bool, Exp)
    g
                        , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \_ g :: Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                        , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \_ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                        , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                        , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Foldable Name
    conName
                        }

        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
    match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ \_ xs :: [Exp]
    xs -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Exp] -> Exp
    mkFoldMap [Exp]
    xs
          where
            -- mappend v1 (mappend v2 ..)
            mkFoldMap :: [Exp] -> Exp
            mkFoldMap :: [Exp] -> Exp
    mkFoldMap [] = Name -> Exp
    VarE Name
    memptyValName
            mkFoldMap 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

    -- | Generates a match whose right-hand side implements @null@.
    makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
    makeNullMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeNullMatch tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (NullM Exp)]
    parts  <- Map Name (OneOrTwoNames One)
    -> FFoldType (Q (NullM Exp))
    -> ConstructorInfo
    -> Q [Q (NullM Exp)]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Q (NullM Exp))
    ft_null ConstructorInfo
    con
      [NullM Exp]
    parts' <- [Q (NullM Exp)] -> Q [NullM Exp]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (NullM Exp)]
    parts
      case [NullM Exp] -> Maybe [(Bool, Exp)]
    forall a. [NullM a] -> Maybe [(Bool, a)]
    convert [NullM Exp]
    parts' of
        Nothing -> Match -> MatchQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Match -> MatchQ) -> Match -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ Pat -> Body -> [Dec] -> Match
    Match (ConstructorInfo -> Pat
    conWildPat ConstructorInfo
    con) (Exp -> Body
    NormalB (Exp -> Body) -> Exp -> Body
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    ConE Name
    falseDataName) []
        Just cp :: [(Bool, Exp)]
    cp -> Name -> [(Bool, Exp)] -> MatchQ
    match_for_con Name
    conName [(Bool, Exp)]
    cp
      where
        ft_null :: FFoldType (Q (NullM Exp))
        ft_null :: FFoldType (Q (NullM Exp))
    ft_null = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { ft_triv :: Q (NullM Exp)
    ft_triv = NullM Exp -> Q (NullM Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (NullM Exp -> Q (NullM Exp)) -> NullM Exp -> Q (NullM Exp)
    forall a b. (a -> b) -> a -> b
    $ Exp -> NullM Exp
    forall a. a -> NullM a
    IsNull (Exp -> NullM Exp) -> Exp -> NullM Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    ConE Name
    trueDataName
                     , ft_var :: Name -> Q (NullM Exp)
    ft_var  = \_ -> NullM Exp -> Q (NullM Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return NullM Exp
    forall a. NullM a
    NotNull
                     , ft_tup :: TupleSort -> [Q (NullM Exp)] -> Q (NullM Exp)
    ft_tup = \t :: TupleSort
    t g :: [Q (NullM Exp)]
    g -> do
                         [NullM Exp]
    gg <- [Q (NullM Exp)] -> Q [NullM Exp]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (NullM Exp)]
    g
                         case [NullM Exp] -> Maybe [(Bool, Exp)]
    forall a. [NullM a] -> Maybe [(Bool, a)]
    convert [NullM Exp]
    gg of
                           Nothing  -> NullM Exp -> Q (NullM Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return NullM Exp
    forall a. NullM a
    NotNull
                           Just ggg :: [(Bool, Exp)]
    ggg ->
                             (Exp -> NullM Exp) -> Q Exp -> Q (NullM Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Exp -> NullM Exp
    forall a. a -> NullM a
    NullM (Q Exp -> Q (NullM Exp)) -> Q Exp -> Q (NullM Exp)
    forall a b. (a -> b) -> a -> b
    $ (Exp -> Q Exp) -> Q Exp
    mkSimpleLam
                                        ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> [(Bool, Exp)] -> MatchQ)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
    match_for_con TupleSort
    t [(Bool, Exp)]
    ggg
                     , ft_ty_app :: Type -> Q (NullM Exp) -> Q (NullM Exp)
    ft_ty_app = \_ g :: Q (NullM Exp)
    g -> ((NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp))
    -> Q (NullM Exp) -> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (NullM Exp -> NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap Q (NullM Exp)
    g ((NullM Exp -> NullM Exp) -> Q (NullM Exp))
    -> (NullM Exp -> NullM Exp) -> Q (NullM Exp)
    forall a b. (a -> b) -> a -> b
    $ \nestedResult :: NullM Exp
    nestedResult ->
                         case NullM Exp
    nestedResult of
                           -- If e definitely contains the parameter, then we can
                           -- test if (G e) contains it by simply checking if (G e)
                           -- is null
                           NotNull -> Exp -> NullM Exp
    forall a. a -> NullM a
    NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Exp
    VarE Name
    nullValName
                           -- This case is unreachable--it will actually be caught
                           -- by ft_triv
                           r :: NullM Exp
    r@IsNull{} -> NullM Exp
    r
                           -- The general case uses (all null), (all (all null)),
                           -- etc.
                           NullM nestedTest :: Exp
    nestedTest -> Exp -> NullM Exp
    forall a. a -> NullM a
    NullM (Exp -> NullM Exp) -> Exp -> NullM Exp
    forall a b. (a -> b) -> a -> b
    $
                                               Name -> Exp
    VarE Name
    allValName Exp -> Exp -> Exp
    `AppE` Exp
    nestedTest
                     , ft_forall :: [TyVarBndr] -> Q (NullM Exp) -> Q (NullM Exp)
    ft_forall = \_ g :: Q (NullM Exp)
    g -> Q (NullM Exp)
    g
                     , ft_co_var :: Name -> Q (NullM Exp)
    ft_co_var  = \_ -> Name -> Q (NullM Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                     , ft_fun :: Q (NullM Exp) -> Q (NullM Exp) -> Q (NullM Exp)
    ft_fun     = \_ _ -> Name -> Q (NullM Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                     , ft_bad_app :: Q (NullM Exp)
    ft_bad_app = FunctorClass -> Name -> Q (NullM Exp)
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Foldable Name
    conName
                     }

        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
    match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ \_ xs :: [Exp]
    xs -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Exp] -> Exp
    mkNull [Exp]
    xs
          where
            -- v1 && v2 && ..
            mkNull :: [Exp] -> Exp
            mkNull :: [Exp] -> Exp
    mkNull [] = Name -> Exp
    ConE Name
    trueDataName
            mkNull xs :: [Exp]
    xs = (Exp -> Exp -> Exp) -> [Exp] -> Exp
    forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
    foldr1 (\x :: Exp
    x y :: Exp
    y -> Name -> Exp
    VarE Name
    andValName Exp -> Exp -> Exp
    `AppE` Exp
    x Exp -> Exp -> Exp
    `AppE` Exp
    y) [Exp]
    xs

    -- Given a list of NullM results, produce Nothing if any of them is NotNull,
    -- and otherwise produce a list of (Bool, a) with True entries representing
    -- unknowns and False entries representing things that are definitely null.
    convert :: [NullM a] -> Maybe [(Bool, a)]
    convert :: [NullM a] -> Maybe [(Bool, a)]
    convert = (NullM a -> Maybe (Bool, a)) -> [NullM a] -> Maybe [(Bool, a)]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM NullM a -> Maybe (Bool, a)
    forall b. NullM b -> Maybe (Bool, b)
    go where
      go :: NullM b -> Maybe (Bool, b)
    go (IsNull a :: b
    a) = (Bool, b) -> Maybe (Bool, b)
    forall a. a -> Maybe a
    Just (Bool
    False, b
    a)
      go NotNull    = Maybe (Bool, b)
    forall a. Maybe a
    Nothing
      go (NullM a :: b
    a)  = (Bool, b) -> Maybe (Bool, b)
    forall a. a -> Maybe a
    Just (Bool
    True, b
    a)

    data NullM a =
        IsNull a -- Definitely null
      | NotNull  -- Definitely not null
      | NullM a  -- Unknown

    -- | Generates a match whose right-hand side implements @traverse@.
    makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match
    makeTraverseMatch :: Map Name (OneOrTwoNames One) -> ConstructorInfo -> MatchQ
    makeTraverseMatch tvMap :: Map Name (OneOrTwoNames One)
    tvMap con :: ConstructorInfo
    con@(ConstructorInfo{constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName}) = do
      [Q (Bool, Exp)]
    parts  <- Map Name (OneOrTwoNames One)
    -> FFoldType (Q (Bool, Exp))
    -> ConstructorInfo
    -> Q [Q (Bool, Exp)]
    forall a.
    Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs Map Name (OneOrTwoNames One)
    tvMap FFoldType (Q (Bool, Exp))
    ft_trav ConstructorInfo
    con
      [(Bool, Exp)]
    parts' <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    parts
      Name -> [(Bool, Exp)] -> MatchQ
    match_for_con Name
    conName [(Bool, Exp)]
    parts'
      where
        -- The Bool is True if the type mentions the last type parameter, False
        -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out
        -- expressions that do not mention the last parameter by checking for False.
        ft_trav :: FFoldType (Q (Bool, Exp))
        ft_trav :: FFoldType (Q (Bool, Exp))
    ft_trav = FT :: forall a.
    a
    -> (Name -> a)
    -> (Name -> a)
    -> (a -> a -> a)
    -> (TupleSort -> [a] -> a)
    -> (Type -> a -> a)
    -> a
    -> ([TyVarBndr] -> a -> a)
    -> FFoldType a
    FT { -- See Note [ft_triv for Bifoldable and Bitraversable]
                       ft_triv :: Q (Bool, Exp)
    ft_triv = (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    False, Name -> Exp
    VarE Name
    pureValName)
                     , ft_var :: Name -> Q (Bool, Exp)
    ft_var  = \v :: Name
    v -> case Map Name (OneOrTwoNames One)
    tvMap Map Name (OneOrTwoNames One) -> Name -> OneOrTwoNames One
    forall k a. Ord k => Map k a -> k -> a
    Map.! Name
    v of
                                         OneName f :: Name
    f -> (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Name -> Exp
    VarE Name
    f)
                     , ft_tup :: TupleSort -> [Q (Bool, Exp)] -> Q (Bool, Exp)
    ft_tup  = \t :: TupleSort
    t gs :: [Q (Bool, Exp)]
    gs -> do
                         [(Bool, Exp)]
    gg  <- [Q (Bool, Exp)] -> Q [(Bool, Exp)]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence [Q (Bool, Exp)]
    gs
                         Exp
    lam <- (Exp -> Q Exp) -> Q Exp
    mkSimpleLam ((Exp -> Q Exp) -> Q Exp) -> (Exp -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (Name -> [(Bool, Exp)] -> MatchQ)
    -> TupleSort -> [(Bool, Exp)] -> Exp -> Q Exp
    forall a.
    (Name -> [a] -> MatchQ) -> TupleSort -> [a] -> Exp -> Q Exp
    mkSimpleTupleCase Name -> [(Bool, Exp)] -> MatchQ
    match_for_con TupleSort
    t [(Bool, Exp)]
    gg
                         (Bool, Exp) -> Q (Bool, Exp)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    True, Exp
    lam)
                     , ft_ty_app :: Type -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_ty_app = \_ g :: Q (Bool, Exp)
    g ->
                         ((Bool, Exp) -> (Bool, Exp)) -> Q (Bool, Exp) -> Q (Bool, Exp)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\(b :: Bool
    b, e :: Exp
    e) -> (Bool
    b, Name -> Exp
    VarE Name
    traverseValName Exp -> Exp -> Exp
    `AppE` Exp
    e)) Q (Bool, Exp)
    g
                     , ft_forall :: [TyVarBndr] -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_forall  = \_ g :: Q (Bool, Exp)
    g -> Q (Bool, Exp)
    g
                     , ft_co_var :: Name -> Q (Bool, Exp)
    ft_co_var  = \_ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    contravarianceError Name
    conName
                     , ft_fun :: Q (Bool, Exp) -> Q (Bool, Exp) -> Q (Bool, Exp)
    ft_fun     = \_ _ -> Name -> Q (Bool, Exp)
    forall a. Name -> Q a
    noFunctionsError Name
    conName
                     , ft_bad_app :: Q (Bool, Exp)
    ft_bad_app = FunctorClass -> Name -> Q (Bool, Exp)
    forall a b. ClassRep a => a -> Name -> Q b
    outOfPlaceTyVarError FunctorClass
    Traversable Name
    conName
                     }

        -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
        --                    (g2 a2) <*> ...
        match_for_con :: Name -> [(Bool, Exp)] -> Q Match
        match_for_con :: Name -> [(Bool, Exp)] -> MatchQ
    match_for_con = (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    mkSimpleConMatch2 ((Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ)
    -> (Exp -> [Exp] -> Q Exp) -> Name -> [(Bool, Exp)] -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ \conExp :: Exp
    conExp xs :: [Exp]
    xs -> Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Exp -> [Exp] -> Exp
    mkApCon Exp
    conExp [Exp]
    xs
          where
            -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
            mkApCon :: Exp -> [Exp] -> Exp
            mkApCon :: Exp -> [Exp] -> Exp
    mkApCon conExp :: Exp
    conExp []  = Name -> Exp
    VarE Name
    pureValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp
            mkApCon conExp :: Exp
    conExp [e :: Exp
    e] = Name -> Exp
    VarE Name
    fmapValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp Exp -> Exp -> Exp
    `AppE` Exp
    e
            mkApCon conExp :: Exp
    conExp (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' Exp -> Exp -> Exp
    appAp
              (Name -> Exp
    VarE Name
    liftA2ValName Exp -> Exp -> Exp
    `AppE` Exp
    conExp Exp -> Exp -> Exp
    `AppE` Exp
    e1 Exp -> Exp -> Exp
    `AppE` Exp
    e2) [Exp]
    es
              where appAp :: Exp -> Exp -> Exp
    appAp 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)

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

    -- | A representation of which class is being derived.
    data FunctorClass = Functor | Foldable | Traversable

    instance ClassRep FunctorClass where
        arity :: FunctorClass -> Int
    arity _ = 1

        allowExQuant :: FunctorClass -> Bool
    allowExQuant Foldable = Bool
    True
        allowExQuant _        = Bool
    False

        fullClassName :: FunctorClass -> Name
    fullClassName Functor     = Name
    functorTypeName
        fullClassName Foldable    = Name
    foldableTypeName
        fullClassName Traversable = Name
    traversableTypeName

        classConstraint :: FunctorClass -> Int -> Maybe Name
    classConstraint fClass :: FunctorClass
    fClass 1 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Name -> Maybe Name) -> Name -> Maybe Name
    forall a b. (a -> b) -> a -> b
    $ FunctorClass -> Name
    forall a. ClassRep a => a -> Name
    fullClassName FunctorClass
    fClass
        classConstraint  _      _ = Maybe Name
    forall a. Maybe a
    Nothing

    -- | A representation of which function is being generated.
    data FunctorFun
      = Fmap
      | Replace -- (<$)
      | Foldr
      | FoldMap
      | Null
      | Traverse
      deriving FunctorFun -> FunctorFun -> Bool
    (FunctorFun -> FunctorFun -> Bool)
    -> (FunctorFun -> FunctorFun -> Bool) -> Eq FunctorFun
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: FunctorFun -> FunctorFun -> Bool
    $c/= :: FunctorFun -> FunctorFun -> Bool
    == :: FunctorFun -> FunctorFun -> Bool
    $c== :: FunctorFun -> FunctorFun -> Bool
    Eq

    instance Show FunctorFun where
        showsPrec :: Int -> FunctorFun -> ShowS
    showsPrec _ Fmap     = String -> ShowS
    showString "fmap"
        showsPrec _ Replace  = String -> ShowS
    showString "(<$)"
        showsPrec _ Foldr    = String -> ShowS
    showString "foldr"
        showsPrec _ FoldMap  = String -> ShowS
    showString "foldMap"
        showsPrec _ Null     = String -> ShowS
    showString "null"
        showsPrec _ Traverse = String -> ShowS
    showString "traverse"

    functorFunConstName :: FunctorFun -> Name
    functorFunConstName :: FunctorFun -> Name
    functorFunConstName Fmap     = Name
    fmapConstValName
    functorFunConstName Replace  = Name
    replaceConstValName
    functorFunConstName Foldr    = Name
    foldrConstValName
    functorFunConstName FoldMap  = Name
    foldMapConstValName
    functorFunConstName Null     = Name
    nullConstValName
    functorFunConstName Traverse = Name
    traverseConstValName

    functorFunName :: FunctorFun -> Name
    functorFunName :: FunctorFun -> Name
    functorFunName Fmap     = Name
    fmapValName
    functorFunName Replace  = Name
    replaceValName
    functorFunName Foldr    = Name
    foldrValName
    functorFunName FoldMap  = Name
    foldMapValName
    functorFunName Null     = Name
    nullValName
    functorFunName Traverse = Name
    traverseValName

    functorClassToFuns :: FunctorClass -> [FunctorFun]
    functorClassToFuns :: FunctorClass -> [FunctorFun]
    functorClassToFuns Functor     = [ FunctorFun
    Fmap, FunctorFun
    Replace ]
    functorClassToFuns Foldable    = [ FunctorFun
    Foldr, FunctorFun
    FoldMap
    #if MIN_VERSION_base(4,8,0)
                                     , FunctorFun
    Null
    #endif
                                     ]
    functorClassToFuns Traversable = [ FunctorFun
    Traverse ]

    functorFunToClass :: FunctorFun -> FunctorClass
    functorFunToClass :: FunctorFun -> FunctorClass
    functorFunToClass Fmap     = FunctorClass
    Functor
    functorFunToClass Replace  = FunctorClass
    Functor
    functorFunToClass Foldr    = FunctorClass
    Foldable
    functorFunToClass FoldMap  = FunctorClass
    Foldable
    functorFunToClass Null     = FunctorClass
    Foldable
    functorFunToClass Traverse = FunctorClass
    Traversable

    -------------------------------------------------------------------------------
    -- Assorted utilities
    -------------------------------------------------------------------------------

    functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
    functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp
    functorFunEmptyCase ff :: FunctorFun
    ff z :: Name
    z value :: Name
    value =
        Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
    functorFunTrivial Q Exp
    emptyCase
                          (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    emptyCase)
                          FunctorFun
    ff Name
    z
      where
        emptyCase :: Q Exp
        emptyCase :: Q Exp
    emptyCase = Q Exp -> [MatchQ] -> Q Exp
    caseE (Name -> Q Exp
    varE Name
    value) []

    functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
    functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp
    functorFunNoCons ff :: FunctorFun
    ff z :: Name
    z value :: Name
    value =
        Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
    functorFunTrivial Q Exp
    seqAndError
                          (Name -> Q Exp
    varE Name
    pureValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    seqAndError)
                          FunctorFun
    ff 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 (FunctorFun -> Name
    functorFunName FunctorFun
    ff))

    functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
    functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp
    functorFunTrivial fmapE :: Q Exp
    fmapE traverseE :: Q Exp
    traverseE ff :: FunctorFun
    ff z :: Name
    z = FunctorFun -> Q Exp
    go FunctorFun
    ff
      where
        go :: FunctorFun -> Q Exp
        go :: FunctorFun -> Q Exp
    go Fmap     = Q Exp
    fmapE
        go Replace  = Q Exp
    fmapE
        go Foldr    = Name -> Q Exp
    varE Name
    z
        go FoldMap  = Name -> Q Exp
    varE Name
    memptyValName
        go Null     = Name -> Q Exp
    conE Name
    trueDataName
        go Traverse = Q Exp
    traverseE

    conWildPat :: ConstructorInfo -> Pat
    conWildPat :: ConstructorInfo -> Pat
    conWildPat (ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName = Name
    conName
                                , constructorFields :: ConstructorInfo -> Cxt
    constructorFields = Cxt
    ts }) =
      Name -> [Pat] -> Pat
    ConP Name
    conName ([Pat] -> Pat) -> [Pat] -> Pat
    forall a b. (a -> b) -> a -> b
    $ Int -> Pat -> [Pat]
    forall a. Int -> a -> [a]
    replicate (Cxt -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length Cxt
    ts) Pat
    WildP

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

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

    data FFoldType a      -- Describes how to fold over a Type in a functor like way
       = FT { FFoldType a -> a
    ft_triv    :: a
              -- ^ Does not contain variable
            , FFoldType a -> Name -> a
    ft_var     :: Name -> a
              -- ^ The variable itself
            , FFoldType a -> Name -> a
    ft_co_var  :: Name -> a
              -- ^ The variable itself, contravariantly
            , FFoldType a -> a -> a -> a
    ft_fun     :: a -> a -> a
              -- ^ Function type
            , FFoldType a -> TupleSort -> [a] -> a
    ft_tup     :: TupleSort -> [a] -> a
              -- ^ Tuple type. The @[a]@ is the result of folding over the
              --   arguments of the tuple.
            , FFoldType a -> Type -> a -> a
    ft_ty_app  :: Type -> a -> a
              -- ^ Type app, variable only in last argument. The 'Type' is the
              --   @arg_ty@ in @fun_ty arg_ty@.
            , FFoldType a -> a
    ft_bad_app :: a
              -- ^ Type app, variable other than in last argument
            , FFoldType a -> [TyVarBndr] -> a -> a
    ft_forall  :: [TyVarBndr] -> a -> a
              -- ^ Forall type
         }

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

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

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

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

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

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

    -- Fold over the arguments of a data constructor in a Functor-like way.
    foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs :: Map Name (OneOrTwoNames One)
    -> FFoldType a -> ConstructorInfo -> Q [a]
    foldDataConArgs tvMap :: Map Name (OneOrTwoNames One)
    tvMap ft :: FFoldType a
    ft con :: ConstructorInfo
    con = do
      Cxt
    fieldTys <- (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 -> CxtQ) -> Cxt -> CxtQ
    forall a b. (a -> b) -> a -> b
    $ ConstructorInfo -> Cxt
    constructorFields ConstructorInfo
    con
      (Type -> Q a) -> Cxt -> Q [a]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    mapM Type -> Q a
    foldArg Cxt
    fieldTys
      where
        foldArg :: Type -> Q a
        foldArg :: Type -> Q a
    foldArg = Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
    forall a.
    Map Name (OneOrTwoNames One) -> FFoldType a -> Type -> Q a
    functorLikeTraverse Map Name (OneOrTwoNames One)
    tvMap FFoldType a
    ft

    -- Make a 'LamE' using a fresh variable.
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam :: (Exp -> Q Exp) -> Q Exp
    mkSimpleLam lam :: Exp -> Q Exp
    lam = do
      Name
    n <- String -> Q Name
    newName "n"
      Exp
    body <- Exp -> Q Exp
    lam (Name -> Exp
    VarE Name
    n)
      Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    n] Exp
    body

    -- Make a 'LamE' using two fresh variables.
    mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp
    mkSimpleLam2 lam :: Exp -> Exp -> Q Exp
    lam = do
      Name
    n1 <- String -> Q Name
    newName "n1"
      Name
    n2 <- String -> Q Name
    newName "n2"
      Exp
    body <- Exp -> Exp -> Q Exp
    lam (Name -> Exp
    VarE Name
    n1) (Name -> Exp
    VarE Name
    n2)
      Exp -> Q Exp
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Exp -> Q Exp) -> Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [Pat] -> Exp -> Exp
    LamE [Name -> Pat
    VarP Name
    n1, Name -> Pat
    VarP Name
    n2] Exp
    body

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

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

          conExpQ :: Q Exp
    conExpQ
            | [Name] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Name]
    asWithTyVar = [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]
    asWithoutTyVar)
            | Bool
    otherwise = do
                [Name]
    bs <- String -> Int -> Q [Name]
    newNameList "b" Int
    lengthInsides
                let bs' :: [Name]
    bs'  = [Bool] -> [Name] -> [Name]
    forall a. [Bool] -> [a] -> [a]
    filterByList  [Bool]
    argTysTyVarInfo [Name]
    bs
                    vars :: [Q Exp]
    vars = [Bool] -> [Q Exp] -> [Q Exp] -> [Q Exp]
    forall a. [Bool] -> [a] -> [a] -> [a]
    filterByLists [Bool]
    argTysTyVarInfo
                                         ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    varE [Name]
    bs) ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    varE [Name]
    varsNeeded)
                [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
      Exp
    rhs <- Exp -> [Exp] -> Q Exp
    fold Exp
    conExp [Exp]
    exps
      Match -> MatchQ
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Match -> MatchQ) -> Match -> MatchQ
    forall a b. (a -> b) -> a -> b
    $ Pat -> Body -> [Dec] -> Match
    Match Pat
    pat (Exp -> Body
    NormalB Exp
    rhs) []
      where
        lengthInsides :: Int
    lengthInsides = [(Bool, Exp)] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Bool, Exp)]
    insides

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

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