{-
(c) The University of Glasgow 2011

The deriving code for the Functor, Foldable, and Traversable classes
(equivalent to the code in TcGenDeriv, for other classes)
-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

module TcGenFunctor (
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,

        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds
    ) where

import GhcPrelude

import Bag
import DataCon
import FastString
import HsSyn
import Panic
import PrelNames
import RdrName
import SrcLoc
import State
import TcGenDeriv
import TcType
import TyCon
import TyCoRep
import Type
import Util
import Var
import VarSet
import MkId (coerceId)
import TysWiredIn (true_RDR, false_RDR)

import Data.Maybe (catMaybes, isJust)

{-
************************************************************************
*                                                                      *
                        Functor instances

 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html

*                                                                      *
************************************************************************

For the data type:

  data T a = T1 Int a | T2 (T a)

We generate the instance:

  instance Functor T where
      fmap f (T1 b1 a) = T1 b1 (f a)
      fmap f (T2 ta)   = T2 (fmap f ta)

Notice that we don't simply apply 'fmap' to the constructor arguments.
Rather
  - Do nothing to an argument whose type doesn't mention 'a'
  - Apply 'f' to an argument of type 'a'
  - Apply 'fmap f' to other arguments
That's why we have to recurse deeply into the constructor argument types,
rather than just one level, as we typically do.

What about types with more than one type parameter?  In general, we only
derive Functor for the last position:

  data S a b = S1 [b] | S2 (a, T a b)
  instance Functor (S a) where
    fmap f (S1 bs)    = S1 (fmap f bs)
    fmap f (S2 (p,q)) = S2 (a, fmap f q)

However, we have special cases for
         - tuples
         - functions

More formally, we write the derivation of fmap code over type variable
'a for type 'b as ($fmap 'a 'b).  In this general notation the derived
instance for T is:

  instance Functor T where
      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)

  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
  $(fmap 'a 'a)          =  f
  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))

For functions, the type parameter 'a can occur in a contravariant position,
which means we need to derive a function like:

  cofmap :: (a -> b) -> (f b -> f a)

This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:

  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))

Note that the code produced by $(fmap _ _) is always a higher order function,
with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
matching on the type, this means create a lambda function (see the (,) case above).
The resulting code for fmap can look a bit weird, for example:

  data X a = X (a,Int)
  -- generated instance
  instance Functor X where
      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x

The optimizer should be able to simplify this code by simple inlining.

An older version of the deriving code tried to avoid these applied
lambda functions by producing a meta level function. But the function to
be mapped, `f`, is a function on the code level, not on the meta level,
so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
It is better to produce too many lambdas than to eta expand, see ticket #7436.
-}

gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use  fmap _ = coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Functor_binds loc tycon
  | Phantom <- last (tyConRoles tycon)
  = (unitBag fmap_bind, emptyBag)
  where
    fmap_name = L loc fmap_RDR
    fmap_bind = mkRdrFunBind fmap_name fmap_eqns
    fmap_eqns = [mkSimpleMatch fmap_match_ctxt
                               [nlWildPat]
                               coerce_Expr]
    fmap_match_ctxt = mkPrefixFunRhs fmap_name

gen_Functor_binds loc tycon
  = (listToBag [fmap_bind, replace_bind], emptyBag)
  where
    data_cons = tyConDataCons tycon
    fmap_name = L loc fmap_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
    fmap_match_ctxt = mkPrefixFunRhs fmap_name

    fmap_eqn con = flip evalState bs_RDRs $
                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts
      where
        parts = sequence $ foldDataConArgs ft_fmap con

    fmap_eqns = map fmap_eqn data_cons

    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))
    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
                   -- fmap f = \x -> x
                 , ft_var  = return f_Expr
                   -- fmap f = f
                 , ft_fun  = \g h -> do
                     gg <- g
                     hh <- h
                     mkSimpleLam2 $ \x b -> return $
                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
                   -- fmap f = \x b -> h (x (g b))
                 , ft_tup = \t gs -> do
                     gg <- sequence gs
                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg
                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
                   -- fmap f = fmap g
                 , ft_forall = \_ g -> g
                 , ft_bad_app = panic "in other argument in ft_fmap"
                 , ft_co_var = panic "contravariant in ft_fmap" }

    -- See Note [Deriving <$]
    replace_name = L loc replace_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
    replace_match_ctxt = mkPrefixFunRhs replace_name

    replace_eqn con = flip evalState bs_RDRs $
        match_for_con replace_match_ctxt [z_Pat] con =<< parts
      where
        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con

    replace_eqns = map replace_eqn data_cons

    ft_replace :: FFoldType (State [RdrName] Replacer)
    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x
                   -- (p <$) = \x -> x
                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr
                   -- (p <$) = const p
                 , ft_fun  = \g h -> do
                     gg <- replace <$> g
                     hh <- replace <$> h
                     fmap Nested $ mkSimpleLam2 $ \x b -> return $
                       nlHsApp hh (nlHsApp x (nlHsApp gg b))
                   -- (<$) p = \x b -> h (x (g b))
                 , ft_tup = \t gs -> do
                     gg <- traverse (fmap replace) gs
                     fmap Nested . mkSimpleLam $
                          mkSimpleTupleCase (match_for_con CaseAlt) t gg
                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                 , ft_ty_app = \_ gm -> do
                       g <- gm
                       case g of
                         Nested g' -> pure . Nested $
                                          nlHsApp fmap_Expr $ g'
                         Immediate _ -> pure . Nested $
                                          nlHsApp replace_Expr z_Expr
                   -- (p <$) = fmap (p <$)
                 , ft_forall = \_ g -> g
                 , ft_bad_app = panic "in other argument in ft_replace"
                 , ft_co_var = panic "contravariant in ft_replace" }

    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
    match_for_con :: HsMatchContext RdrName
                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]
                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
    match_for_con ctxt = mkSimpleConMatch ctxt $
        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..

-- See Note [Deriving <$]
data Replacer = Immediate {replace :: LHsExpr GhcPs}
              | Nested {replace :: LHsExpr GhcPs}

{- Note [Deriving <$]
   ~~~~~~~~~~~~~~~~~~

We derive the definition of <$. Allowing this to take the default definition
can lead to memory leaks: mapping over a structure with a constant function can
fill the result structure with trivial thunks that retain the values from the
original structure. The simplifier seems to handle this all right for simple
types, but not for recursive ones. Consider

data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor

-- fmap _ Tip = Tip
-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)

Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
simplifies no further. Why is that? `fmap` is defined recursively, so GHC
cannot inline it. The static argument transformation would turn the definition
into a non-recursive one

-- fmap f = go where
--   go Tip = Tip
--   go (Bin l v r) = Bin (go l) (f v) (go r)

which GHC could inline, producing an efficient definion of `<$`. But there are
several problems. First, GHC does not perform the static argument transformation
by default, even with -O2. Second, even when it does perform the static argument
transformation, it does so only when there are at least two static arguments,
which is not the case for fmap. Finally, when the type in question is
non-regular, such as

data Nesty a = Z a | S (Nesty a) (Nest (a, a))

the function argument is no longer (entirely) static, so the static argument
transformation will do nothing for us.

Applying the default definition of `<$` will produce a tree full of thunks that
look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
also retention of the previous value, potentially leaking memory. Instead, we
derive <$ separately. Two aspects are different from fmap: the case of the
sought type variable (ft_var) and the case of a type application (ft_ty_app).
The interesting one is ft_ty_app. We have to distinguish two cases: the
"immediate" case where the type argument *is* the sought type variable, and
the "nested" case where the type argument *contains* the sought type variable.

The immediate case:

Suppose we have

data Imm a = Imm (F ... a)

Then we want to define

x <$ Imm q = Imm (x <$ q)

The nested case:

Suppose we have

data Nes a = Nes (F ... (G a))

Then we want to define

x <$ Nes q = Nes (fmap (x <$) q)

We use the Replacer type to tag whether the expression derived for applying
<$ to the last type variable was the ft_var case (immediate) or one of the
others (letting ft_forall pass through as usual).

We could, but do not, give tuples special treatment to improve efficiency
in some cases. Suppose we have

data Nest a = Z a | S (Nest (a,a))

The optimal definition would be

x <$ Z _ = Z x
x <$ S t = S ((x, x) <$ t)

which produces a result with maximal internal sharing. The reason we do not
attempt to treat this case specially is that we have no way to give
user-provided tuple-like types similar treatment. If the user changed the
definition to

data Pair a = Pair a a
data Nest a = Z a | S (Nest (Pair a))

they would experience a surprising degradation in performance. -}

{-
Utility functions related to Functor deriving.

Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
This function works like a fold: it makes a value of type 'a' in a bottom up way.
-}

-- Generic traversal for Functor deriving
-- See Note [FFoldType and functorLikeTraverse]
data FFoldType a      -- Describes how to fold over a Type in a functor like way
   = FT { ft_triv    :: a
          -- ^ Does not contain variable
        , ft_var     :: a
          -- ^ The variable itself
        , ft_co_var  :: a
          -- ^ The variable itself, contravariantly
        , ft_fun     :: a -> a -> a
          -- ^ Function type
        , ft_tup     :: TyCon -> [a] -> a
          -- ^ Tuple type
        , ft_ty_app  :: Type -> a -> a
          -- ^ Type app, variable only in last argument
        , ft_bad_app :: a
          -- ^ Type app, variable other than in last argument
        , ft_forall  :: TcTyVar -> a -> a
          -- ^ Forall type
     }

functorLikeTraverse :: forall a.
                       TyVar         -- ^ Variable to look for
                    -> FFoldType a   -- ^ How to fold
                    -> Type          -- ^ Type to process
                    -> a
functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
                            , ft_co_var = caseCoVar,     ft_fun = caseFun
                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp
                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
                    ty
  = fst (go False ty)
  where
    go :: Bool        -- Covariant or contravariant context
       -> Type
       -> (a, Bool)   -- (result of type a, does type contain var)

    go co ty | Just ty' <- tcView ty = go co ty'
    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
    go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })
       | InvisArg <- af = go co y
       | xc || yc       = (caseFun xr yr,True)
       where (xr,xc) = go (not co) x
             (yr,yc) = go co       y
    go co (AppTy    x y) | xc = (caseWrongArg,   True)
                         | yc = (caseTyApp x yr, True)
        where (_, xc) = go co x
              (yr,yc) = go co y
    go co ty@(TyConApp con args)
       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
       -- At this point we know that xrs, xcs is not empty,
       -- and at least one xr is True
       | isTupleTyCon con = (caseTuple con xrs, True)
       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty
                          = (caseTyApp fun_ty (last xrs), True)
       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
       where
         -- When folding over an unboxed tuple, we must explicitly drop the
         -- runtime rep arguments, or else GHC will generate twice as many
         -- variables in a unboxed tuple pattern match and expression as it
         -- actually needs. See Trac #12399
         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
    go co (ForAllTy (Bndr v vis) x)
       | isVisibleArgFlag vis = panic "unexpected visible binder"
       | v /= var && xc       = (caseForAll v xr,True)
       where (xr,xc) = go co x

    go _ _ = (caseTrivial,False)

-- Return all syntactic subterms of ty that contain var somewhere
-- These are the things that should appear in instance constraints
deepSubtypesContaining :: TyVar -> Type -> [TcType]
deepSubtypesContaining tv
  = functorLikeTraverse tv
        (FT { ft_triv = []
            , ft_var = []
            , ft_fun = (++)
            , ft_tup = \_ xs -> concat xs
            , ft_ty_app = (:)
            , ft_bad_app = panic "in other argument in deepSubtypesContaining"
            , ft_co_var = panic "contravariant in deepSubtypesContaining"
            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })

foldDataConArgs :: FFoldType a -> DataCon -> [a]
-- Fold over the arguments of the datacon
foldDataConArgs ft con
  = map foldArg (dataConOrigArgTys con)
  where
    foldArg
      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
             Just tv -> functorLikeTraverse tv ft
             Nothing -> const (ft_triv ft)
    -- If we are deriving Foldable for a GADT, there is a chance that the last
    -- type variable in the data type isn't actually a type variable at all.
    -- (for example, this can happen if the last type variable is refined to
    -- be a concrete type such as Int). If the last type variable is refined
    -- to be a specific type, then getTyVar_maybe will return Nothing.
    -- See Note [DeriveFoldable with ExistentialQuantification]
    --
    -- The kind checks have ensured the last type parameter is of kind *.

-- Make a HsLam using a fresh variable from a State monad
mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
            -> State [RdrName] (LHsExpr GhcPs)
-- (mkSimpleLam fn) returns (\x. fn(x))
mkSimpleLam lam =
    get >>= \case
      n:names -> do
        put names
        body <- lam (nlHsVar n)
        return (mkHsLam [nlVarPat n] body)
      _ -> panic "mkSimpleLam"

mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
             -> State [RdrName] (LHsExpr GhcPs))
             -> State [RdrName] (LHsExpr GhcPs)
mkSimpleLam2 lam =
    get >>= \case
      n1:n2:names -> do
        put names
        body <- lam (nlHsVar n1) (nlHsVar n2)
        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
      _ -> panic "mkSimpleLam2"

-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
--
-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
-- which the LHS pattern-matches on @extra_pats@, followed by a match on the
-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
-- and its arguments, applying an expression (from @insides@) to each of the
-- respective arguments of @con@.
mkSimpleConMatch :: Monad m => HsMatchContext RdrName
                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))
                 -> [LPat GhcPs]
                 -> DataCon
                 -> [LHsExpr GhcPs]
                 -> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch ctxt fold extra_pats con insides = do
    let con_name = getRdrName con
    let vars_needed = takeList insides as_RDRs
    let bare_pat = nlConVarPat con_name vars_needed
    let pat = if null vars_needed
          then bare_pat
          else nlParPat bare_pat
    rhs <- fold con_name
                (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)
    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
                     (noLoc emptyLocalBinds)

-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
--
-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
-- 'mkSimpleConMatch', with two key differences:
--
-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
--    @[LHsExpr RdrName]@. 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., the
--    'Nothing' elements of @insides@).
--
-- 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.
--
-- See Note [Generated code for DeriveFoldable and DeriveTraversable]
mkSimpleConMatch2 :: Monad m
                  => HsMatchContext RdrName
                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
                                      -> m (LHsExpr GhcPs))
                  -> [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 ctxt fold extra_pats con insides = do
    let con_name = getRdrName con
        vars_needed = takeList insides as_RDRs
        pat = nlConVarPat con_name vars_needed
        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
        -- indicies in each expression to match up with the argument indices
        -- in con_expr (defined below).
        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
                                   insides vars_needed
        -- An element of argTysTyVarInfo is True if the constructor argument
        -- with the same index has a type which mentions the last type
        -- variable.
        argTysTyVarInfo = map isJust insides
        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars

        con_expr
          | null asWithTyVar = nlHsApps con_name asWithoutTyVar
          | otherwise =
              let bs   = filterByList  argTysTyVarInfo bs_RDRs
                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)

    rhs <- fold con_expr exps
    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
                     (noLoc emptyLocalBinds)

-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))
                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
mkSimpleTupleCase match_for_con tc insides x
  = do { let data_con = tyConSingleDataCon tc
       ; match <- match_for_con [] data_con insides
       ; return $ nlHsCase x [match] }

{-
************************************************************************
*                                                                      *
                        Foldable instances

 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html

*                                                                      *
************************************************************************

Deriving Foldable instances works the same way as Functor instances,
only Foldable instances are not possible for function types at all.
Given (data T a = T a a (T a) deriving Foldable), we get:

  instance Foldable T where
      foldr f z (T x1 x2 x3) =
        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )

-XDeriveFoldable is different from -XDeriveFunctor in that it filters out
arguments to the constructor that would produce useless code in a Foldable
instance. For example, the following datatype:

  data Foo a = Foo Int a Int deriving Foldable

would have the following generated Foldable instance:

  instance Foldable Foo where
    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2

since neither of the two Int arguments are folded over.

The cases are:

  $(foldr 'a 'a)         =  f
  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2

Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).

One can envision a case for types that don't contain the last type variable:

  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a

But this case will never materialize, since the aforementioned filtering
removes all such types from consideration.
See Note [Generated code for DeriveFoldable and DeriveTraversable].

Foldable instances differ from Functor and Traversable instances in that
Foldable instances can be derived for data types in which the last type
variable is existentially quantified. In particular, if the last type variable
is refined to a more specific type in a GADT:

  data GADT a where
      G :: a ~ Int => a -> G Int

then the deriving machinery does not attempt to check that the type a contains
Int, since it is not syntactically equal to a type variable. That is, the
derived Foldable instance for GADT is:

  instance Foldable GADT where
      foldr _ z (GADT _) = z

See Note [DeriveFoldable with ExistentialQuantification].

Note [Deriving null]
~~~~~~~~~~~~~~~~~~~~

In some cases, deriving the definition of 'null' can produce much better
results than the default definition. For example, with

  data SnocList a = Nil | Snoc (SnocList a) a

the default definition of 'null' would walk the entire spine of a
nonempty snoc-list before concluding that it is not null. But looking at
the Snoc constructor, we can immediately see that it contains an 'a', and
so 'null' can return False immediately if it matches on Snoc. When we
derive 'null', we keep track of things that cannot be null. The interesting
case is type application. Given

  data Wrap a = Wrap (Foo (Bar a))

we use

  null (Wrap fba) = all null fba

but if we see

  data Wrap a = Wrap (Foo a)

we can just use

  null (Wrap fa) = null fa

Indeed, we allow this to happen even for tuples:

  data Wrap a = Wrap (Foo (a, Int))

produces

  null (Wrap fa) = null fa

As explained in Note [Deriving <$], giving tuples special performance treatment
could surprise users if they switch to other types, but Ryan Scott seems to
think it's okay to do it for now.
-}

gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-- When the parameter is phantom, we can use foldMap _ _ = mempty
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Foldable_binds loc tycon
  | Phantom <- last (tyConRoles tycon)
  = (unitBag foldMap_bind, emptyBag)
  where
    foldMap_name = L loc foldMap_RDR
    foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
    foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
                                  [nlWildPat, nlWildPat]
                                  mempty_Expr]
    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name

gen_Foldable_binds loc tycon
  | null data_cons  -- There's no real point producing anything but
                    -- foldMap for a type with no constructors.
  = (unitBag foldMap_bind, emptyBag)

  | otherwise
  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
  where
    data_cons = tyConDataCons tycon

    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
    eqns = map foldr_eqn data_cons
    foldr_eqn con
      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
      where
        parts = sequence $ foldDataConArgs ft_foldr con

    foldMap_name = L loc foldMap_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
                      foldMap_name foldMap_eqns

    foldMap_eqns = map foldMap_eqn data_cons

    foldMap_eqn con
      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
      where
        parts = sequence $ foldDataConArgs ft_foldMap con

    -- Given a list of NullM results, produce Nothing if any of
    -- them is NotNull, and otherwise produce a list of Maybes
    -- with Justs representing unknowns and Nothings representing
    -- things that are definitely null.
    convert :: [NullM a] -> Maybe [Maybe a]
    convert = traverse go where
      go IsNull = Just Nothing
      go NotNull = Nothing
      go (NullM a) = Just (Just a)

    null_name = L loc null_RDR
    null_match_ctxt = mkPrefixFunRhs null_name
    null_bind = mkRdrFunBind null_name null_eqns
    null_eqns = map null_eqn data_cons
    null_eqn con
      = flip evalState bs_RDRs $ do
          parts <- sequence $ foldDataConArgs ft_null con
          case convert parts of
            Nothing -> return $
              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
                false_Expr (noLoc emptyLocalBinds)
            Just cp -> match_null [] con cp

    -- Yields 'Just' an expression if we're folding over a type that mentions
    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
    -- See Note [FFoldType and functorLikeTraverse]
    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
    ft_foldr
      = FT { ft_triv    = return Nothing
             -- foldr f = \x z -> z
           , ft_var     = return $ Just f_Expr
             -- foldr f = f
           , ft_tup     = \t g -> do
               gg  <- sequence g
               lam <- mkSimpleLam2 $ \x z ->
                 mkSimpleTupleCase (match_foldr z) t gg x
               return (Just lam)
             -- foldr f = (\x z -> case x of ...)
           , ft_ty_app  = \_ g -> do
               gg <- g
               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
             -- foldr f = (\x z -> foldr g z x)
           , ft_forall  = \_ g -> g
           , ft_co_var  = panic "contravariant in ft_foldr"
           , ft_fun     = panic "function in ft_foldr"
           , ft_bad_app = panic "in other argument in ft_foldr" }

    match_foldr :: LHsExpr GhcPs
                -> [LPat GhcPs]
                -> DataCon
                -> [Maybe (LHsExpr GhcPs)]
                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
      where
        -- g1 v1 (g2 v2 (.. z))
        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkFoldr = foldr nlHsApp z

    -- See Note [FFoldType and functorLikeTraverse]
    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
    ft_foldMap
      = FT { ft_triv = return Nothing
             -- foldMap f = \x -> mempty
           , ft_var  = return (Just f_Expr)
             -- foldMap f = f
           , ft_tup  = \t g -> do
               gg  <- sequence g
               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
               return (Just lam)
             -- foldMap f = \x -> case x of (..,)
           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
             -- foldMap f = foldMap g
           , ft_forall = \_ g -> g
           , ft_co_var = panic "contravariant in ft_foldMap"
           , ft_fun = panic "function in ft_foldMap"
           , ft_bad_app = panic "in other argument in ft_foldMap" }

    match_foldMap :: [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
      where
        -- mappend v1 (mappend v2 ..)
        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkFoldMap [] = mempty_Expr
        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs

    -- See Note [FFoldType and functorLikeTraverse]
    -- Yields NullM an expression if we're folding over an expression
    -- that may or may not be null. Yields IsNull if it's certainly
    -- null, and yields NotNull if it's certainly not null.
    -- See Note [Deriving null]
    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
    ft_null
      = FT { ft_triv = return IsNull
             -- null = \_ -> True
           , ft_var  = return NotNull
             -- null = \_ -> False
           , ft_tup  = \t g -> do
               gg  <- sequence g
               case convert gg of
                 Nothing -> pure NotNull
                 Just ggg ->
                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
             -- null = \x -> case x of (..,)
           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->
                              case 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 -> NullM null_Expr
                                -- This case is unreachable--it will actually be
                                -- caught by ft_triv
                                IsNull -> IsNull
                                -- The general case uses (all null),
                                -- (all (all null)), etc.
                                NullM nestedTest -> NullM $
                                                    nlHsApp all_Expr nestedTest
             -- null fa = null fa, or null fa = all null fa, or null fa = True
           , ft_forall = \_ g -> g
           , ft_co_var = panic "contravariant in ft_null"
           , ft_fun = panic "function in ft_null"
           , ft_bad_app = panic "in other argument in ft_null" }

    match_null :: [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
      where
        -- v1 && v2 && ..
        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkNull [] = true_Expr
        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs

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

{-
************************************************************************
*                                                                      *
                        Traversable instances

 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
*                                                                      *
************************************************************************

Again, Traversable is much like Functor and Foldable.

The cases are:

  $(traverse 'a 'a)          =  f
  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2

Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
do not mention the last type parameter. Therefore, the following datatype:

  data Foo a = Foo Int a Int

would have the following derived Traversable instance:

  instance Traversable Foo where
    traverse f (Foo x1 x2 x3) =
      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )

since the two Int arguments do not produce any effects in a traversal.

One can envision a case for types that do not mention the last type parameter:

  $(traverse 'a 'b)          =  pure     -- when b does not contain a

But this case will never materialize, since the aforementioned filtering
removes all such types from consideration.
See Note [Generated code for DeriveFoldable and DeriveTraversable].
-}

gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
-- When the argument is phantom, we can use traverse = pure . coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Traversable_binds loc tycon
  | Phantom <- last (tyConRoles tycon)
  = (unitBag traverse_bind, emptyBag)
  where
    traverse_name = L loc traverse_RDR
    traverse_bind = mkRdrFunBind traverse_name traverse_eqns
    traverse_eqns =
        [mkSimpleMatch traverse_match_ctxt
                       [nlWildPat, z_Pat]
                       (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
    traverse_match_ctxt = mkPrefixFunRhs traverse_name

gen_Traversable_binds loc tycon
  = (unitBag traverse_bind, emptyBag)
  where
    data_cons = tyConDataCons tycon

    traverse_name = L loc traverse_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
                                   traverse_name traverse_eqns
    traverse_eqns = map traverse_eqn data_cons
    traverse_eqn con
      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
      where
        parts = sequence $ foldDataConArgs ft_trav con

    -- Yields 'Just' an expression if we're folding over a type that mentions
    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
    -- See Note [FFoldType and functorLikeTraverse]
    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
    ft_trav
      = FT { ft_triv    = return Nothing
             -- traverse f = pure x
           , ft_var     = return (Just f_Expr)
             -- traverse f = f x
           , ft_tup     = \t gs -> do
               gg  <- sequence gs
               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
               return (Just lam)
             -- traverse f = \x -> case x of (a1,a2,..) ->
             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
             -- traverse f = traverse g
           , ft_forall  = \_ g -> g
           , ft_co_var  = panic "contravariant in ft_trav"
           , ft_fun     = panic "function in ft_trav"
           , ft_bad_app = panic "in other argument in ft_trav" }

    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
    --                    (g2 a2) <*> ...
    match_for_con :: [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))
    match_for_con = mkSimpleConMatch2 CaseAlt $
                                             \con xs -> return (mkApCon con xs)
      where
        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkApCon con [] = nlHsApps pure_RDR [con]
        mkApCon con [x] = nlHsApps fmap_RDR [con,x]
        mkApCon con (x1:x2:xs) =
            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
          where appAp x y = nlHsApps ap_RDR [x,y]

-----------------------------------------------------------------------

f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,
    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
    all_Expr, null_Expr :: LHsExpr GhcPs
f_Expr        = nlHsVar f_RDR
z_Expr        = nlHsVar z_RDR
fmap_Expr     = nlHsVar fmap_RDR
replace_Expr  = nlHsVar replace_RDR
mempty_Expr   = nlHsVar mempty_RDR
foldMap_Expr  = nlHsVar foldMap_RDR
traverse_Expr = nlHsVar traverse_RDR
coerce_Expr   = nlHsVar (getRdrName coerceId)
pure_Expr     = nlHsVar pure_RDR
true_Expr     = nlHsVar true_RDR
false_Expr    = nlHsVar false_RDR
all_Expr      = nlHsVar all_RDR
null_Expr     = nlHsVar null_RDR

f_RDR, z_RDR :: RdrName
f_RDR = mkVarUnqual (fsLit "f")
z_RDR = mkVarUnqual (fsLit "z")

as_RDRs, bs_RDRs :: [RdrName]
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]

as_Vars, bs_Vars :: [LHsExpr GhcPs]
as_Vars = map nlHsVar as_RDRs
bs_Vars = map nlHsVar bs_RDRs

f_Pat, z_Pat :: LPat GhcPs
f_Pat = nlVarPat f_RDR
z_Pat = nlVarPat z_RDR

{-
Note [DeriveFoldable with ExistentialQuantification]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Functor and Traversable instances can only be derived for data types whose
last type parameter is truly universally polymorphic. For example:

  data T a b where
    T1 ::                 b   -> T a b   -- YES, b is unconstrained
    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
    T4 ::                 Int -> T a Int -- NO, this is just like T3
    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
                                         -- though a is existential
    T6 ::                 Int -> T Int b -- YES, b is unconstrained

For Foldable instances, however, we can completely lift the constraint that
the last type parameter be truly universally polymorphic. This means that T
(as defined above) can have a derived Foldable instance:

  instance Foldable (T a) where
    foldr f z (T1 b)   = f b z
    foldr f z (T2 b)   = f b z
    foldr f z (T3 b)   = f b z
    foldr f z (T4 b)   = z
    foldr f z (T5 a b) = f b z
    foldr f z (T6 a)   = z

    foldMap f (T1 b)   = f b
    foldMap f (T2 b)   = f b
    foldMap f (T3 b)   = f b
    foldMap f (T4 b)   = mempty
    foldMap f (T5 a b) = f b
    foldMap f (T6 a)   = mempty

In a Foldable instance, it is safe to fold over an occurrence of the last type
parameter that is not truly universally polymorphic. However, there is a bit
of subtlety in determining what is actually an occurrence of a type parameter.
T3 and T4, as defined above, provide one example:

  data T a b where
    ...
    T3 :: b ~ Int => b   -> T a b
    T4 ::            Int -> T a Int
    ...

  instance Foldable (T a) where
    ...
    foldr f z (T3 b) = f b z
    foldr f z (T4 b) = z
    ...
    foldMap f (T3 b) = f b
    foldMap f (T4 b) = mempty
    ...

Notice that the argument of T3 is folded over, whereas the argument of T4 is
not. This is because we only fold over constructor arguments that
syntactically mention the universally quantified type parameter of that
particular data constructor. See foldDataConArgs for how this is implemented.

As another example, consider the following data type. The argument of each
constructor has the same type as the last type parameter:

  data E a where
    E1 :: (a ~ Int) => a   -> E a
    E2 ::              Int -> E Int
    E3 :: (a ~ Int) => a   -> E Int
    E4 :: (a ~ Int) => Int -> E a

Only E1's argument is an occurrence of a universally quantified type variable
that is syntactically equivalent to the last type parameter, so only E1's
argument will be folded over in a derived Foldable instance.

See Trac #10447 for the original discussion on this feature. Also see
https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
for a more in-depth explanation.

Note [FFoldType and functorLikeTraverse]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deriving Functor, Foldable, and Traversable all require generating expressions
which perform an operation on each argument of a data constructor depending
on the argument's type. In particular, a generated operation can be different
depending on whether the type mentions the last type variable of the datatype
(e.g., if you have data T a = MkT a Int, then a generated foldr expression would
fold over the first argument of MkT, but not the second).

This pattern is abstracted with the FFoldType datatype, which provides hooks
for the user to specify how a constructor argument should be folded when it
has a type with a particular "shape". The shapes are as follows (assume that
a is the last type variable in a given datatype):

* ft_triv:    The type does not mention the last type variable at all.
              Examples: Int, b

* ft_var:     The type is syntactically equal to the last type variable.
              Moreover, the type appears in a covariant position (see
              the Deriving Functor instances section of the user's guide
              for an in-depth explanation of covariance vs. contravariance).
              Example: a (covariantly)

* ft_co_var:  The type is syntactically equal to the last type variable.
              Moreover, the type appears in a contravariant position.
              Example: a (contravariantly)

* ft_fun:     A function type which mentions the last type variable in
              the argument position, result position or both.
              Examples: a -> Int, Int -> a, Maybe a -> [a]

* ft_tup:     A tuple type which mentions the last type variable in at least
              one of its fields. The TyCon argument of ft_tup represents the
              particular tuple's type constructor.
              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)

* ft_ty_app:  A type is being applied to the last type parameter, where the
              applied type does not mention the last type parameter (if it
              did, it would fall under ft_bad_app). The Type argument to
              ft_ty_app represents the applied type.

              Note that functions, tuples, and foralls are distinct cases
              and take precedence of ft_ty_app. (For example, (Int -> a) would
              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
              Examples: Maybe a, Either b a

* ft_bad_app: A type application uses the last type parameter in a position
              other than the last argument. This case is singled out because
              Functor, Foldable, and Traversable instances cannot be derived
              for datatypes containing arguments with such types.
              Examples: Either a Int, Const a b

* ft_forall:  A forall'd type mentions the last type parameter on its right-
              hand side (and is not quantified on the left-hand side). This
              case is present mostly for plumbing purposes.
              Example: forall b. Either b a

If FFoldType describes a strategy for folding subcomponents of a Type, then
functorLikeTraverse is the function that applies that strategy to the entirety
of a Type, returning the final folded-up result.

foldDataConArgs applies functorLikeTraverse to every argument type of a
constructor, returning a list of the fold results. This makes foldDataConArgs
a natural way to generate the subexpressions in a generated fmap, foldr,
foldMap, or traverse definition (the subexpressions must then be combined in
a method-specific fashion to form the final generated expression).

Deriving Generic1 also does validity checking by looking for the last type
variable in certain positions of a constructor's argument types, so it also
uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.

Note [Generated code for DeriveFoldable and DeriveTraversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
that of -XDeriveFunctor. However, there an important difference between deriving
the former two typeclasses and the latter one, which is best illustrated by the
following scenario:

  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)

The generated code for the Functor instance is straightforward:

  instance Functor WithInt where
    fmap f (WithInt a i) = WithInt (f a) i

But if we use too similar of a strategy for deriving the Foldable and
Traversable instances, we end up with this code:

  instance Foldable WithInt where
    foldMap f (WithInt a i) = f a <> mempty

  instance Traversable WithInt where
    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i

This is unsatisfying for two reasons:

1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
   expects an argument whose type is of kind *. This effectively prevents
   Traversable from being derived for any datatype with an unlifted argument
   type (Trac #11174).

2. The generated code contains superfluous expressions. By the Monoid laws,
   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).

We can fix both of these issues by incorporating a slight twist to the usual
algorithm that we use for -XDeriveFunctor. The differences can be summarized
as follows:

1. In the generated expression, we only fold over arguments whose types
   mention the last type parameter. Any other argument types will simply
   produce useless 'mempty's or 'pure's, so they can be safely ignored.

2. In the case of -XDeriveTraversable, instead of applying ConName,
   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where

   * ConName has n arguments
   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
     to the arguments whose types mention the last type parameter. As a
     consequence, taking the difference of {a_1, ..., a_n} and
     {b_i, ..., b_k} yields the all the argument values of ConName whose types
     do not mention the last type parameter. Note that [i, ..., k] is a
     strictly increasingâ€”but not necessarily consecutiveâ€”integer sequence.

     For example, the datatype

       data Foo a = Foo Int a Int a

     would generate the following Traversable instance:

       instance Traversable Foo where
         traverse f (Foo a1 a2 a3 a4) =
           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4

Technically, this approach would also work for -XDeriveFunctor as well, but we
decide not to do so because:

1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
   instead of (WithInt (f a) i).

2. There would be certain datatypes for which the above strategy would
   generate Functor code that would fail to typecheck. For example:

     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor

   With the conventional algorithm, it would generate something like:

     fmap f (Bar a) = Bar (fmap f a)

   which typechecks. But with the strategy mentioned above, it would generate:

     fmap f (Bar a) = (\b -> Bar b) (fmap f a)

   which does not typecheck, since GHC cannot unify the rank-2 type variables
   in the types of b and (fmap f a).

Note [Phantom types with Functor, Foldable, and Traversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Given a type F :: * -> * whose type argument has a phantom role, we can always
produce lawful Functor and Traversable instances using

    fmap _ = coerce
    traverse _ = pure . coerce

Indeed, these are equivalent to any *strictly lawful* instances one could
write, except that this definition of 'traverse' may be lazier.  That is, if
instances obey the laws under true equality (rather than up to some equivalence
relation), then they will be essentially equivalent to these. These definitions
are incredibly cheap, so we want to use them even if it means ignoring some
non-strictly-lawful instance in an embedded type.

Foldable has far fewer laws to work with, which leaves us unwelcome
freedom in implementing it. At a minimum, we would like to ensure that
a derived foldMap is always at least as good as foldMapDefault with a
derived traverse. To accomplish that, we must define

   foldMap _ _ = mempty

in these cases.

This may have different strictness properties from a standard derivation.
Consider

   data NotAList a = Nil | Cons (NotAList a) deriving Foldable

The usual deriving mechanism would produce

   foldMap _ Nil = mempty
   foldMap f (Cons x) = foldMap f x

which is strict in the entire spine of the NotAList.

Final point: why do we even care about such types? Users will rarely if ever
map, fold, or traverse over such things themselves, but other derived
instances may:

   data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable

Note [EmptyDataDecls with Functor, Foldable, and Traversable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

There are some slightly tricky decisions to make about how to handle
Functor, Foldable, and Traversable instances for types with no constructors.
For fmap, the two basic options are

   fmap _ _ = error "Sorry, no constructors"

or

   fmap _ z = case z of

In most cases, the latter is more helpful: if the thunk passed to fmap
throws an exception, we're generally going to be much more interested in
that exception than in the fact that there aren't any constructors.

In order to match the semantics for phantoms (see note above), we need to
be a bit careful about 'traverse'. The obvious definition would be

   traverse _ z = case z of

but this is stricter than the one for phantoms. We instead use

   traverse _ z = pure $ case z of

For foldMap, the obvious choices are

   foldMap _ _ = mempty

or

   foldMap _ z = case z of

We choose the first one to be consistent with what foldMapDefault does for
a derived Traversable instance.
-}


{-
(c) The University of Glasgow 2011

The deriving code for the Generic class
(equivalent to the code in TcGenDeriv, for other classes)
-}

{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module TcGenGenerics (canDoGenerics, canDoGenerics1,
                      GenericKind(..),
                      gen_Generic_binds, get_gen1_constrained_tys) where

import GhcPrelude

import HsSyn
import Type
import TcType
import TcGenDeriv
import TcGenFunctor
import DataCon
import TyCon
import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
import FamInst
import Module           ( moduleName, moduleNameFS
                        , moduleUnitId, unitIdFS, getModule )
import IfaceEnv         ( newGlobalBinder )
import Name      hiding ( varName )
import RdrName
import BasicTypes
import TysPrim
import TysWiredIn
import PrelNames
import TcEnv
import TcRnMonad
import HscTypes
import ErrUtils( Validity(..), andValid )
import SrcLoc
import Bag
import VarEnv
import VarSet (elemVarSet)
import Outputable
import FastString
import Util

import Control.Monad (mplus)
import Data.List (zip4, partition)
import Data.Maybe (isJust)

#include "HsVersions.h"

{-
************************************************************************
*                                                                      *
\subsection{Bindings for the new generic deriving mechanism}
*                                                                      *
************************************************************************

For the generic representation we need to generate:
\begin{itemize}
\item A Generic instance
\item A Rep type instance
\item Many auxiliary datatypes and instances for them (for the meta-information)
\end{itemize}
-}

gen_Generic_binds :: GenericKind -> TyCon -> [Type]
                 -> TcM (LHsBinds GhcPs, FamInst)
gen_Generic_binds gk tc inst_tys = do
  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys
  return (mkBindsRep gk tc, repTyInsts)

{-
************************************************************************
*                                                                      *
\subsection{Generating representation types}
*                                                                      *
************************************************************************
-}

get_gen1_constrained_tys :: TyVar -> Type -> [Type]
-- called by TcDeriv.inferConstraints; generates a list of types, each of which
-- must be a Functor in order for the Generic1 instance to work.
get_gen1_constrained_tys argVar
  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []
                                , ata_par1 = [], ata_rec1 = const []
                                , ata_comp = (:) }

{-

Note [Requirements for deriving Generic and Rep]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

In the following, T, Tfun, and Targ are "meta-variables" ranging over type
expressions.

(Generic T) and (Rep T) are derivable for some type expression T if the
following constraints are satisfied.

  (a) D is a type constructor *value*. In other words, D is either a type
      constructor or it is equivalent to the head of a data family instance (up to
      alpha-renaming).

  (b) D cannot have a "stupid context".

  (c) The right-hand side of D cannot include existential types, universally
      quantified types, or "exotic" unlifted types. An exotic unlifted type
      is one which is not listed in the definition of allowedUnliftedTy
      (i.e., one for which we have no representation type).
      See Note [Generics and unlifted types]

  (d) T :: *.

(Generic1 T) and (Rep1 T) are derivable for some type expression T if the
following constraints are satisfied.

  (a),(b),(c) As above.

  (d) T must expect arguments, and its last parameter must have kind *.

      We use `a' to denote the parameter of D that corresponds to the last
      parameter of T.

  (e) For any type-level application (Tfun Targ) in the right-hand side of D
      where the head of Tfun is not a tuple constructor:

      (b1) `a' must not occur in Tfun.

      (b2) If `a' occurs in Targ, then Tfun :: * -> *.

-}

canDoGenerics :: TyCon -> Validity
-- canDoGenerics determines if Generic/Rep can be derived.
--
-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken
-- care of because canDoGenerics is applied to rep tycons.
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
canDoGenerics tc
  = mergeErrors (
          -- Check (b) from Note [Requirements for deriving Generic and Rep].
              (if (not (null (tyConStupidTheta tc)))
                then (NotValid (tc_name <+> text "must not have a datatype context"))
                else IsValid)
          -- See comment below
            : (map bad_con (tyConDataCons tc)))
  where
    -- The tc can be a representation tycon. When we want to display it to the
    -- user (in an error message) we should print its parent
    tc_name = ppr $ case tyConFamInst_maybe tc of
        Just (ptc, _) -> ptc
        _             -> tc

        -- Check (c) from Note [Requirements for deriving Generic and Rep].
        --
        -- If any of the constructors has an exotic unlifted type as argument,
        -- then we can't build the embedding-projection pair, because
        -- it relies on instantiating *polymorphic* sum and product types
        -- at the argument types of the constructors
    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))
                  then (NotValid (ppr dc <+> text
                    "must not have exotic unlifted or polymorphic arguments"))
                  else (if (not (isVanillaDataCon dc))
                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))
                          else IsValid)

        -- Nor can we do the job if it's an existential data constructor,
        -- Nor if the args are polymorphic types (I don't think)
    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))
                      || not (isTauTy ty)

-- Returns True the Type argument is an unlifted type which has a
-- corresponding generic representation type. For example,
-- (allowedUnliftedTy Int#) would return True since there is the UInt
-- representation type.
allowedUnliftedTy :: Type -> Bool
allowedUnliftedTy = isJust . unboxedRepRDRs

mergeErrors :: [Validity] -> Validity
mergeErrors []             = IsValid
mergeErrors (NotValid s:t) = case mergeErrors t of
  IsValid     -> NotValid s
  NotValid s' -> NotValid (s <> text ", and" $$ s')
mergeErrors (IsValid : t) = mergeErrors t

-- A datatype used only inside of canDoGenerics1. It's the result of analysing
-- a type term.
data Check_for_CanDoGenerics1 = CCDG1
  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in
                                  -- this type?
  , _ccdg1_errors   :: Validity   -- errors generated by this type
  }

{-

Note [degenerate use of FFoldType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

We use foldDataConArgs here only for its ability to treat tuples
specially. foldDataConArgs also tracks covariance (though it assumes all
higher-order type parameters are covariant) and has hooks for special handling
of functions and polytypes, but we do *not* use those.

The key issue is that Generic1 deriving currently offers no sophisticated
support for functions. For example, we cannot handle

  data F a = F ((a -> Int) -> Int)

even though a is occurring covariantly.

In fact, our rule is harsh: a is simply not allowed to occur within the first
argument of (->). We treat (->) the same as any other non-tuple tycon.

Unfortunately, this means we have to track "the parameter occurs in this type"
explicitly, even though foldDataConArgs is also doing this internally.

-}

-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.
--
-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]
-- are taken care of by the call to canDoGenerics.
--
-- It returns IsValid if deriving is possible. It returns (NotValid reason)
-- if not.
canDoGenerics1 :: TyCon -> Validity
canDoGenerics1 rep_tc =
  canDoGenerics rep_tc `andValid` additionalChecks
  where
    additionalChecks
        -- check (d) from Note [Requirements for deriving Generic and Rep]
      | null (tyConTyVars rep_tc) = NotValid $
          text "Data type" <+> quotes (ppr rep_tc)
      <+> text "must have some type parameters"

      | otherwise = mergeErrors $ concatMap check_con data_cons

    data_cons = tyConDataCons rep_tc
    check_con con = case check_vanilla con of
      j@(NotValid {}) -> [j]
      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con

    bad :: DataCon -> SDoc -> SDoc
    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg

    check_vanilla :: DataCon -> Validity
    check_vanilla con | isVanillaDataCon con = IsValid
                      | otherwise            = NotValid (bad con existential)

    bmzero      = CCDG1 False IsValid
    bmbad con s = CCDG1 True $ NotValid $ bad con s
    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)

    -- check (e) from Note [Requirements for deriving Generic and Rep]
    -- See also Note [degenerate use of FFoldType]
    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1
    ft_check con = FT
      { ft_triv = bmzero

      , ft_var = caseVar, ft_co_var = caseVar

      -- (component_0,component_1,...,component_n)
      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)
                                  then bmbad con wrong_arg
                                  else foldr bmplus bmzero components

      -- (dom -> rng), where the head of ty is not a tuple tycon
      , ft_fun = \dom rng -> -- cf #8516
          if _ccdg1_hasParam dom
          then bmbad con wrong_arg
          else bmplus dom rng

      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and
      -- the parameter of interest does not occur in ty
      , ft_ty_app = \_ arg -> arg

      , ft_bad_app = bmbad con wrong_arg
      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere
      }
      where
        caseVar = CCDG1 True IsValid

    existential = text "must not have existential arguments"
    wrong_arg   = text "applies a type to an argument involving the last parameter"
               $$ text "but the applied type is not of kind * -> *"

{-
************************************************************************
*                                                                      *
\subsection{Generating the RHS of a generic default method}
*                                                                      *
************************************************************************
-}

type US = Int   -- Local unique supply, just a plain Int
type Alt = (LPat GhcPs, LHsExpr GhcPs)

-- GenericKind serves to mark if a datatype derives Generic (Gen0) or
-- Generic1 (Gen1).
data GenericKind = Gen0 | Gen1

-- as above, but with a payload of the TyCon's name for "the" parameter
data GenericKind_ = Gen0_ | Gen1_ TyVar

-- as above, but using a single datacon's name for "the" parameter
data GenericKind_DC = Gen0_DC | Gen1_DC TyVar

forgetArgVar :: GenericKind_DC -> GenericKind
forgetArgVar Gen0_DC   = Gen0
forgetArgVar Gen1_DC{} = Gen1

-- When working only within a single datacon, "the" parameter's name should
-- match that datacon's name for it.
gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC
gk2gkDC Gen0_   _ = Gen0_DC
gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d

-- Bindings for the Generic instance
mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs
mkBindsRep gk tycon =
    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])
  `unionBags`
    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])
      where
        -- The topmost M1 (the datatype metadata) has the exact same type
        -- across all cases of a from/to definition, and can be factored out
        -- to save some allocations during typechecking.
        -- See Note [Generics compilation speed tricks]
        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E
                                       $ nlHsPar $ nlHsCase x_Expr from_matches
        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches

        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]
        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]
        loc           = srcLocSpan (getSrcLoc tycon)
        datacons      = tyConDataCons tycon

        (from01_RDR, to01_RDR) = case gk of
                                   Gen0 -> (from_RDR,  to_RDR)
                                   Gen1 -> (from1_RDR, to1_RDR)

        -- Recurse over the sum first
        from_alts, to_alts :: [Alt]
        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
          where gk_ = case gk of
                  Gen0 -> Gen0_
                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
                          Gen1_ (last tyvars)
                    where tyvars = tyConTyVars tycon

--------------------------------------------------------------------------------
-- The type synonym instance and synonym
--       type instance Rep (D a b) = Rep_D a b
--       type Rep_D a b = ...representation type for D ...
--------------------------------------------------------------------------------

tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1
                 -> TyCon         -- The type to generate representation for
                 -> [Type]        -- The type(s) to which Generic(1) is applied
                                  -- in the generated instance
                 -> TcM FamInst   -- Generated representation0 coercion
tc_mkRepFamInsts gk tycon inst_tys =
       -- Consider the example input tycon `D`, where data D a b = D_ a
       -- Also consider `R:DInt`, where { data family D x y :: * -> *
       --                               ; data instance D Int a b = D_ a }
  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)
       fam_tc <- case gk of
         Gen0 -> tcLookupTyCon repTyConName
         Gen1 -> tcLookupTyCon rep1TyConName

     ; fam_envs <- tcGetFamInstEnvs

     ; let -- If the derived instance is
           --   instance Generic (Foo x)
           -- then:
           --   `arg_ki` = *, `inst_ty` = Foo x :: *
           --
           -- If the derived instance is
           --   instance Generic1 (Bar x :: k -> *)
           -- then:
           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *
           (arg_ki, inst_ty) = case (gk, inst_tys) of
             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)
             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)
             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)

     ; let mbFamInst         = tyConFamInst_maybe tycon
           -- If we're examining a data family instance, we grab the parent
           -- TyCon (ptc) and use it to determine the type arguments
           -- (inst_args) for the data family *instance*'s type variables.
           ptc               = maybe tycon fst mbFamInst
           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd
                                 $ tcSplitTyConApp inst_ty

     ; let -- `tyvars` = [a,b]
           (tyvars, gk_) = case gk of
             Gen0 -> (all_tyvars, Gen0_)
             Gen1 -> ASSERT(not $ null all_tyvars)
                     (init all_tyvars, Gen1_ $ last all_tyvars)
             where all_tyvars = tyConTyVars tycon

       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *
     ; repTy <- tc_mkRepTy gk_ tycon arg_ki

       -- `rep_name` is a name we generate for the synonym
     ; mod <- getModule
     ; loc <- getSrcSpanM
     ; let tc_occ  = nameOccName (tyConName tycon)
           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ
     ; rep_name <- newGlobalBinder mod rep_occ loc

       -- We make sure to substitute the tyvars with their user-supplied
       -- type arguments before generating the Rep/Rep1 instance, since some
       -- of the tyvars might have been instantiated when deriving.
       -- See Note [Generating a correctly typed Rep instance].
     ; let (env_tyvars, env_inst_args)
             = case gk_ of
                 Gen0_ -> (tyvars, inst_args)
                 Gen1_ last_tv
                          -- See the "wrinkle" in
                          -- Note [Generating a correctly typed Rep instance]
                       -> ( last_tv : tyvars
                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )
           env        = zipTyEnv env_tyvars env_inst_args
           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)
           subst      = mkTvSubst in_scope env
           repTy'     = substTy  subst repTy
           tcv'       = tyCoVarsOfTypeList inst_ty
           (tv', cv') = partition isTyVar tcv'
           tvs'       = scopedSort tv'
           cvs'       = scopedSort cv'
           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'
                                        fam_tc inst_tys repTy'

     ; newFamInst SynFamilyInst axiom  }

--------------------------------------------------------------------------------
-- Type representation
--------------------------------------------------------------------------------

-- | See documentation of 'argTyFold'; that function uses the fields of this
-- type to interpret the structure of a type when that type is considered as an
-- argument to a constructor that is being represented with 'Rep1'.
data ArgTyAlg a = ArgTyAlg
  { ata_rec0 :: (Type -> a)
  , ata_par1 :: a, ata_rec1 :: (Type -> a)
  , ata_comp :: (Type -> a -> a)
  }

-- | @argTyFold@ implements a generalised and safer variant of the @arg@
-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@
-- is conceptually equivalent to:
--
-- > arg t = case t of
-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t
-- >   App f [t'] |
-- >     representable1 f &&
-- >     t' == argVar        -> Rec1 f
-- >   App f [t'] |
-- >     representable1 f &&
-- >     t' has tyvars       -> f :.: (arg t')
-- >   _                     -> Rec0 t
--
-- where @argVar@ is the last type variable in the data type declaration we are
-- finding the representation for.
--
-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to
-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and
-- @:.:@.
--
-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for
-- some data types. The problematic case is when @t@ is an application of a
-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the
-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in
-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some
-- representable1 checks have been relaxed, and others were moved to
-- @canDoGenerics1@.
argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a
argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,
                            ata_par1 = mkPar1, ata_rec1 = mkRec1,
                            ata_comp = mkComp}) =
  -- mkRec0 is the default; use it if there is no interesting structure
  -- (e.g. occurrences of parameters or recursive occurrences)
  \t -> maybe (mkRec0 t) id $ go t where
  go :: Type -> -- type to fold through
        Maybe a -- the result (e.g. representation type), unless it's trivial
  go t = isParam `mplus` isApp where

    isParam = do -- handles parameters
      t' <- getTyVar_maybe t
      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter
             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0

    isApp = do -- handles applications
      (phi, beta) <- tcSplitAppTy_maybe t

      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta

      -- Does it have no interesting structure to represent?
      if not interesting then Nothing
        else -- Is the argument the parameter? Special case for mkRec1.
          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi
            else mkComp phi `fmap` go beta -- It must be a composition.

tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1
               GenericKind_
              -- The type to generate representation for
            -> TyCon
              -- The kind of the representation type's argument
              -- See Note [Handling kinds in a Rep instance]
            -> Kind
               -- Generated representation0 type
            -> TcM Type
tc_mkRepTy gk_ tycon k =
  do
    d1      <- tcLookupTyCon d1TyConName
    c1      <- tcLookupTyCon c1TyConName
    s1      <- tcLookupTyCon s1TyConName
    rec0    <- tcLookupTyCon rec0TyConName
    rec1    <- tcLookupTyCon rec1TyConName
    par1    <- tcLookupTyCon par1TyConName
    u1      <- tcLookupTyCon u1TyConName
    v1      <- tcLookupTyCon v1TyConName
    plus    <- tcLookupTyCon sumTyConName
    times   <- tcLookupTyCon prodTyConName
    comp    <- tcLookupTyCon compTyConName
    uAddr   <- tcLookupTyCon uAddrTyConName
    uChar   <- tcLookupTyCon uCharTyConName
    uDouble <- tcLookupTyCon uDoubleTyConName
    uFloat  <- tcLookupTyCon uFloatTyConName
    uInt    <- tcLookupTyCon uIntTyConName
    uWord   <- tcLookupTyCon uWordTyConName

    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon

    md         <- tcLookupPromDataCon metaDataDataConName
    mc         <- tcLookupPromDataCon metaConsDataConName
    ms         <- tcLookupPromDataCon metaSelDataConName
    pPrefix    <- tcLookupPromDataCon prefixIDataConName
    pInfix     <- tcLookupPromDataCon infixIDataConName
    pLA        <- tcLookupPromDataCon leftAssociativeDataConName
    pRA        <- tcLookupPromDataCon rightAssociativeDataConName
    pNA        <- tcLookupPromDataCon notAssociativeDataConName
    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName
    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName
    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName
    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName
    pSStr      <- tcLookupPromDataCon sourceStrictDataConName
    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName
    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName
    pDStr      <- tcLookupPromDataCon decidedStrictDataConName
    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName

    fix_env <- getFixityEnv

    let mkSum' a b = mkTyConApp plus  [k,a,b]
        mkProd a b = mkTyConApp times [k,a,b]
        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a
        mkRec1 a   = mkTyConApp rec1  [k,a]
        mkPar1     = mkTyConTy  par1
        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]
        mkC      a = mkTyConApp c1 [ k
                                   , metaConsTy a
                                   , prod (dataConInstOrigArgTys a
                                            . mkTyVarTys . tyConTyVars $ tycon)
                                          (dataConSrcBangs    a)
                                          (dataConImplBangs   a)
                                          (dataConFieldLabels a)]
        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]

        -- Sums and products are done in the same way for both Rep and Rep1
        sumP [] = mkTyConApp v1 [k]
        sumP l  = foldBal mkSum' . map mkC  $ l
        -- The Bool is True if this constructor has labelled fields
        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
        prod [] _  _  _  = mkTyConApp u1 [k]
        prod l  sb ib fl = foldBal mkProd
                                   [ ASSERT(null fl || lengthExceeds fl j)
                                     arg t sb' ib' (if null fl
                                                       then Nothing
                                                       else Just (fl !! j))
                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]

        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type
        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of
            -- Here we previously used Par0 if t was a type variable, but we
            -- realized that we can't always guarantee that we are wrapping-up
            -- all type variables in Par0. So we decided to stop using Par0
            -- altogether, and use Rec0 all the time.
                      Gen0_        -> mkRec0 t
                      Gen1_ argVar -> argPar argVar t
          where
            -- Builds argument representation for Rep1 (more complicated due to
            -- the presence of composition).
            argPar argVar = argTyFold argVar $ ArgTyAlg
              {ata_rec0 = mkRec0, ata_par1 = mkPar1,
               ata_rec1 = mkRec1, ata_comp = mkComp comp k}

        tyConName_user = case tyConFamInst_maybe tycon of
                           Just (ptycon, _) -> tyConName ptycon
                           Nothing          -> tyConName tycon

        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user
        mdName  = mkStrLitTy . moduleNameFS . moduleName
                . nameModule . tyConName $ tycon
        pkgName = mkStrLitTy . unitIdFS . moduleUnitId
                . nameModule . tyConName $ tycon
        isNT    = mkTyConTy $ if isNewTyCon tycon
                              then promotedTrueDataCon
                              else promotedFalseDataCon

        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName
        ctFix c
            | dataConIsInfix c
            = case lookupFixity fix_env (dataConName c) of
                   Fixity _ n InfixL -> buildFix n pLA
                   Fixity _ n InfixR -> buildFix n pRA
                   Fixity _ n InfixN -> buildFix n pNA
            | otherwise = mkTyConTy pPrefix
        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
                                             , mkNumLitTy (fromIntegral n)]

        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
                              then promotedTrueDataCon
                              else promotedFalseDataCon

        selName = mkStrLitTy . flLabel

        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]
        mbSel (Just s) = mkTyConApp promotedJustDataCon
                                    [typeSymbolKind, selName s]

        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]
        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]
        metaSelTy mlbl su ss ib =
            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]
          where
            pSUpkness = mkTyConTy $ case su of
                                         SrcUnpack   -> pSUpk
                                         SrcNoUnpack -> pSNUpk
                                         NoSrcUnpack -> pNSUpkness

            pSStrness = mkTyConTy $ case ss of
                                         SrcLazy     -> pSLzy
                                         SrcStrict   -> pSStr
                                         NoSrcStrict -> pNSStrness

            pDStrness = mkTyConTy $ case ib of
                                         HsLazy      -> pDLzy
                                         HsStrict    -> pDStr
                                         HsUnpack{}  -> pDUpk

    return (mkD tycon)

mkComp :: TyCon -> Kind -> Type -> Type -> Type
mkComp comp k f g
  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]
  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]
  where
    -- Which of these is the case?
    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...
    -- We want to instantiate with k1=k, and k2=*
    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]
    -- But we need to know which way round!
    k1_first = k_first == p_kind_var
    [k_first,_,_,_,p] = tyConTyVars comp
    Just p_kind_var = getTyVar_maybe (tyVarKind p)

-- Given the TyCons for each URec-related type synonym, check to see if the
-- given type is an unlifted type that generics understands. If so, return
-- its representation type. Otherwise, return Rec0.
-- See Note [Generics and unlifted types]
mkBoxTy :: TyCon -- UAddr
        -> TyCon -- UChar
        -> TyCon -- UDouble
        -> TyCon -- UFloat
        -> TyCon -- UInt
        -> TyCon -- UWord
        -> TyCon -- Rec0
        -> Kind  -- What to instantiate Rec0's kind variable with
        -> Type
        -> Type
mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty
  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]
  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]
  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]
  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]
  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]
  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]
  | otherwise                = mkTyConApp rec0    [k,ty]

--------------------------------------------------------------------------------
-- Dealing with sums
--------------------------------------------------------------------------------

mkSum :: GenericKind_ -- Generic or Generic1?
      -> US          -- Base for generating unique names
      -> [DataCon]   -- The data constructors
      -> ([Alt],     -- Alternatives for the T->Trep "from" function
          [Alt])     -- Alternatives for the Trep->T "to" function

-- Datatype without any constructors
mkSum _ _ [] = ([from_alt], [to_alt])
  where
    from_alt = (x_Pat, nlHsCase x_Expr [])
    to_alt   = (x_Pat, nlHsCase x_Expr [])
               -- These M1s are meta-information for the datatype

-- Datatype with at least one constructor
mkSum gk_ us datacons =
  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric
 unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d
           | (d,i) <- zip datacons [1..] ]

-- Build the sum for a particular constructor
mk1Sum :: GenericKind_DC -- Generic or Generic1?
       -> US        -- Base for generating unique names
       -> Int       -- The index of this constructor
       -> Int       -- Total number of constructors
       -> DataCon   -- The data constructor
       -> (Alt,     -- Alternative for the T->Trep "from" function
           Alt)     -- Alternative for the Trep->T "to" function
mk1Sum gk_ us i n datacon = (from_alt, to_alt)
  where
    gk = forgetArgVar gk_

    -- Existentials already excluded
    argTys = dataConOrigArgTys datacon
    n_args = dataConSourceArity datacon

    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys
    datacon_vars = map fst datacon_varTys
    us'          = us + n_args

    datacon_rdr  = getRdrName datacon

    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)
    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)

    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)
                 , to_alt_rhs
                 ) -- These M1s are meta-information for the datatype
    to_alt_rhs = case gk_ of
      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars
      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys
        where
          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where
            converter = argTyFold argVar $ ArgTyAlg
              {ata_rec0 = nlHsVar . unboxRepRDR,
               ata_par1 = nlHsVar unPar1_RDR,
               ata_rec1 = const $ nlHsVar unRec1_RDR,
               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)
                                    `nlHsCompose` nlHsVar unComp1_RDR}

-- Generates the L1/R1 sum pattern
genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs
genLR_P i n p
  | n == 0       = error "impossible"
  | n == 1       = p
  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]
  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]
                     where m = div n 2

-- Generates the L1/R1 sum expression
genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs
genLR_E i n e
  | n == 0       = error "impossible"
  | n == 1       = e
  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`
                                            nlHsPar (genLR_E i     (div n 2) e)
  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`
                                            nlHsPar (genLR_E (i-m) (n-m)     e)
                     where m = div n 2

--------------------------------------------------------------------------------
-- Dealing with products
--------------------------------------------------------------------------------

-- Build a product expression
mkProd_E :: GenericKind_DC    -- Generic or Generic1?
         -> US                -- Base for unique names
         -> [(RdrName, Type)]
                       -- List of variables matched on the lhs and their types
         -> LHsExpr GhcPs   -- Resulting product expression
mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)
mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)
                     -- These M1s are meta-information for the constructor
  where
    appVars = map (wrapArg_E gk_) varTys
    prod a b = prodDataCon_RDR `nlHsApps` [a,b]

wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs
wrapArg_E Gen0_DC          (var, ty) = mkM1_E $
                            boxRepRDR ty `nlHsVarApps` [var]
                         -- This M1 is meta-information for the selector
wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $
                            converter ty `nlHsApp` nlHsVar var
                         -- This M1 is meta-information for the selector
  where converter = argTyFold argVar $ ArgTyAlg
          {ata_rec0 = nlHsVar . boxRepRDR,
           ata_par1 = nlHsVar par1DataCon_RDR,
           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,
           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`
                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}

boxRepRDR :: Type -> RdrName
boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs

unboxRepRDR :: Type -> RdrName
unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs

-- Retrieve the RDRs associated with each URec data family instance
-- constructor. See Note [Generics and unlifted types]
unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)
unboxedRepRDRs ty
  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)
  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)
  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)
  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)
  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)
  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)
  | otherwise          = Nothing

-- Build a product pattern
mkProd_P :: GenericKind       -- Gen0 or Gen1
         -> US                -- Base for unique names
         -> [(RdrName, Type)] -- List of variables to match,
                              --   along with their types
         -> LPat GhcPs      -- Resulting product pattern
mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)
mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)
                     -- These M1s are meta-information for the constructor
  where
    appVars = unzipWith (wrapArg_P gk) varTys
    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]

wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs
wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])
                   -- This M1 is meta-information for the selector
wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]

mkGenericLocal :: US -> RdrName
mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))

x_RDR :: RdrName
x_RDR = mkVarUnqual (fsLit "x")

x_Expr :: LHsExpr GhcPs
x_Expr = nlHsVar x_RDR

x_Pat :: LPat GhcPs
x_Pat = nlVarPat x_RDR

mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs
mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e

mkM1_P :: LPat GhcPs -> LPat GhcPs
mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]

nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsCompose x y = compose_RDR `nlHsApps` [x, y]

-- | Variant of foldr1 for producing balanced lists
foldBal :: (a -> a -> a) -> [a] -> a
foldBal op = foldBal' op (error "foldBal: empty list")

foldBal' :: (a -> a -> a) -> a -> [a] -> a
foldBal' _  x []  = x
foldBal' _  _ [y] = y
foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l
                    in foldBal' op x a `op` foldBal' op x b

{-
Note [Generics and unlifted types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Normally, all constants are marked with K1/Rec0. The exception to this rule is
when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In
that case, we must use a data family instance of URec (from GHC.Generics) to
mark it. As a result, before we can generate K1 or unK1, we must first check
to see if the type is actually one of the unlifted types for which URec has a
data family instance; if so, we generate that instead.

See wiki:Commentary/Compiler/GenericDeriving#Handlingunliftedtypes for more
details on why URec is implemented the way it is.

Note [Generating a correctly typed Rep instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving
Generic(1). That is, it derives the ellipsis in the following:

    instance Generic Foo where
      type Rep Foo = ...

However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which
a Generic(1) instance is being derived, not the fully instantiated type. As a
result, tc_mkRepTy builds the most generalized Rep(1) instance possible using
the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This
can cause problems when the instance has instantiated type variables
(see Trac #11732). As an example:

    data T a = MkT a
    deriving instance Generic (T Int)
    ==>
    instance Generic (T Int) where
      type Rep (T Int) = (... (Rec0 a)) -- wrong!

-XStandaloneDeriving is one way for the type variables to become instantiated.
Another way is when Generic1 is being derived for a datatype with a visible
kind binder, e.g.,

   data P k (a :: k) = MkP k deriving Generic1
   ==>
   instance Generic1 (P *) where
     type Rep1 (P *) = (... (Rec0 k)) -- wrong!

See Note [Unify kinds in deriving] in TcDeriv.

In any such scenario, we must prevent a discrepancy between the LHS and RHS of
a Rep(1) instance. To do so, we create a type variable substitution that maps
the tyConTyVars of the TyCon to their counterparts in the fully instantiated
type. (For example, using T above as example, you'd map a :-> Int.) We then
apply the substitution to the RHS before generating the instance.

A wrinkle in all of this: when forming the type variable substitution for
Generic1 instances, we map the last type variable of the tycon to Any. Why?
It's because of wily data types like this one (#15012):

   data T a = MkT (FakeOut a)
   type FakeOut a = Int

If we ignore a, then we'll produce the following Rep1 instance:

   instance Generic1 T where
     type Rep1 T = ... (Rec0 (FakeOut a))
     ...

Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we
ensure that `a` is mapped to Any:

   instance Generic1 T where
     type Rep1 T = ... (Rec0 (FakeOut Any))
     ...

And now all is good.

Alternatively, we could have avoided this problem by expanding all type
synonyms on the RHSes of Rep1 instances. But we might blow up the size of
these types even further by doing this, so we choose not to do so.

Note [Handling kinds in a Rep instance]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Because Generic1 is poly-kinded, the representation types were generalized to
be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply
the kind of the instance being derived to all the representation type
constructors. For instance, if you have

    data Empty (a :: k) = Empty deriving Generic1

Then the generated code is now approximately (with -fprint-explicit-kinds
syntax):

    instance Generic1 k (Empty k) where
      type Rep1 k (Empty k) = U1 k

Most representation types have only one kind variable, making them easy to deal
with. The only non-trivial case is (:.:), which is only used in Generic1
instances:

    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =
        Comp1 { unComp1 :: f (g p) }

Here, we do something a bit counter-intuitive: we make k1 be the kind of the
instance being derived, and we always make k2 be *. Why *? It's because
the code that GHC generates using (:.:) is always of the form x :.: Rec1 y
for some types x and y. In other words, the second type to which (:.:) is
applied always has kind k -> *, for some kind k, so k2 cannot possibly be
anything other than * in a generated Generic1 instance.

Note [Generics compilation speed tricks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deriving Generic(1) is known to have a large constant factor during
compilation, which contributes to noticeable compilation slowdowns when
deriving Generic(1) for large datatypes (see Trac #5642).

To ease the pain, there is a trick one can play when generating definitions for
to(1) and from(1). If you have a datatype like:

  data Letter = A | B | C | D

then a naÃ¯ve Generic instance for Letter would be:

  instance Generic Letter where
    type Rep Letter = D1 ('MetaData ...) ...

    to (M1 (L1 (L1 (M1 U1)))) = A
    to (M1 (L1 (R1 (M1 U1)))) = B
    to (M1 (R1 (L1 (M1 U1)))) = C
    to (M1 (R1 (R1 (M1 U1)))) = D

    from A = M1 (L1 (L1 (M1 U1)))
    from B = M1 (L1 (R1 (M1 U1)))
    from C = M1 (R1 (L1 (M1 U1)))
    from D = M1 (R1 (R1 (M1 U1)))

Notice that in every LHS pattern-match of the 'to' definition, and in every RHS
expression in the 'from' definition, the topmost constructor is M1. This
corresponds to the datatype-specific metadata (the D1 in the Rep Letter
instance). But this is wasteful from a typechecking perspective, since this
definition requires GHC to typecheck an application of M1 in every single case,
leading to an O(n) increase in the number of coercions the typechecker has to
solve, which in turn increases allocations and degrades compilation speed.

Luckily, since the topmost M1 has the exact same type across every case, we can
factor it out reduce the typechecker's burden:

  instance Generic Letter where
    type Rep Letter = D1 ('MetaData ...) ...

    to (M1 x) = case x of
      L1 (L1 (M1 U1)) -> A
      L1 (R1 (M1 U1)) -> B
      R1 (L1 (M1 U1)) -> C
      R1 (R1 (M1 U1)) -> D

    from x = M1 (case x of
      A -> L1 (L1 (M1 U1))
      B -> L1 (R1 (M1 U1))
      C -> R1 (L1 (M1 U1))
      D -> R1 (R1 (M1 U1)))

A simple change, but one that pays off, since it goes turns an O(n) amount of
coercions to an O(1) amount.
-}