never executed always true always false
    1 {-
    2 (c) The University of Glasgow 2011
    3 
    4 -}
    5 
    6 
    7 {-# LANGUAGE ScopedTypeVariables #-}
    8 {-# LANGUAGE TypeFamilies #-}
    9 {-# LANGUAGE FlexibleContexts #-}
   10 {-# LANGUAGE LambdaCase #-}
   11 
   12 -- | The deriving code for the Functor, Foldable, and Traversable classes
   13 module GHC.Tc.Deriv.Functor
   14    ( FFoldType(..)
   15    , functorLikeTraverse
   16    , deepSubtypesContaining
   17    , foldDataConArgs
   18 
   19    , gen_Functor_binds
   20    , gen_Foldable_binds
   21    , gen_Traversable_binds
   22    )
   23 where
   24 
   25 import GHC.Prelude
   26 
   27 import GHC.Data.Bag
   28 import GHC.Core.DataCon
   29 import GHC.Data.FastString
   30 import GHC.Hs
   31 import GHC.Utils.Panic
   32 import GHC.Builtin.Names
   33 import GHC.Types.Name.Reader
   34 import GHC.Types.SrcLoc
   35 import GHC.Utils.Monad.State.Strict
   36 import GHC.Tc.Deriv.Generate
   37 import GHC.Tc.Utils.TcType
   38 import GHC.Core.TyCon
   39 import GHC.Core.TyCo.Rep
   40 import GHC.Core.Type
   41 import GHC.Utils.Misc
   42 import GHC.Types.Var
   43 import GHC.Types.Var.Set
   44 import GHC.Types.Id.Make (coerceId)
   45 import GHC.Builtin.Types (true_RDR, false_RDR)
   46 
   47 import Data.Maybe (catMaybes, isJust)
   48 
   49 {-
   50 ************************************************************************
   51 *                                                                      *
   52                         Functor instances
   53 
   54  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
   55 
   56 *                                                                      *
   57 ************************************************************************
   58 
   59 For the data type:
   60 
   61   data T a = T1 Int a | T2 (T a)
   62 
   63 We generate the instance:
   64 
   65   instance Functor T where
   66       fmap f (T1 b1 a) = T1 b1 (f a)
   67       fmap f (T2 ta)   = T2 (fmap f ta)
   68 
   69 Notice that we don't simply apply 'fmap' to the constructor arguments.
   70 Rather
   71   - Do nothing to an argument whose type doesn't mention 'a'
   72   - Apply 'f' to an argument of type 'a'
   73   - Apply 'fmap f' to other arguments
   74 That's why we have to recurse deeply into the constructor argument types,
   75 rather than just one level, as we typically do.
   76 
   77 What about types with more than one type parameter?  In general, we only
   78 derive Functor for the last position:
   79 
   80   data S a b = S1 [b] | S2 (a, T a b)
   81   instance Functor (S a) where
   82     fmap f (S1 bs)    = S1 (fmap f bs)
   83     fmap f (S2 (p,q)) = S2 (a, fmap f q)
   84 
   85 However, we have special cases for
   86          - tuples
   87          - functions
   88 
   89 More formally, we write the derivation of fmap code over type variable
   90 'a for type 'b as ($fmap 'a 'b x).  In this general notation the derived
   91 instance for T is:
   92 
   93   instance Functor T where
   94       fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
   95       fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
   96 
   97   $(fmap 'a 'b x)          = x     -- when b does not contain a
   98   $(fmap 'a 'a x)          = f x
   99   $(fmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2))
  100   $(fmap 'a '(T b1 a) x)   = fmap f x -- when a only occurs directly as the last argument of T
  101   $(fmap 'a '(T b1 b2) x)  = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  102   $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y)))
  103 
  104 For functions, the type parameter 'a can occur in a contravariant position,
  105 which means we need to derive a function like:
  106 
  107   cofmap :: (a -> b) -> (f b -> f a)
  108 
  109 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and
  110 $(cofmap 'a '(T b1 a) x) cases:
  111 
  112   $(cofmap 'a 'b x)          = x     -- when b does not contain a
  113   $(cofmap 'a 'a x)          = error "type variable in contravariant position"
  114   $(cofmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
  115   $(cofmap 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
  116   $(cofmap 'a '(T b1 b2) x)  = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  117   $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y)))
  118 
  119 Note that the code produced by $(fmap _ _ _) is always a higher order function,
  120 with type `(a -> b) -> (g a -> g b)` for some g.
  121 
  122 Note that there are two distinct cases in $fmap (and $cofmap) that match on an
  123 application of some type constructor T (where T is not a tuple type
  124 constructor):
  125 
  126   $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
  127   $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  128 
  129 While the latter case technically subsumes the former case, it is important to
  130 give special treatment to the former case to avoid unnecessary eta expansion.
  131 See Note [Avoid unnecessary eta expansion in derived fmap implementations].
  132 
  133 We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for
  134 an explanation of why this is important. Just like $fmap/$cofmap above, there
  135 is a similar algorithm for generating `p <$ x` (for some constant `p`):
  136 
  137   $(replace 'a 'b x)          = x      -- when b does not contain a
  138   $(replace 'a 'a x)          = p
  139   $(replace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2))
  140   $(replace 'a '(T b1 a) x)   = p <$ x -- when a only occurs directly as the last argument of T
  141   $(replace 'a '(T b1 b2) x)  = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  142   $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y)))
  143 
  144   $(coreplace 'a 'b x)          = x      -- when b does not contain a
  145   $(coreplace 'a 'a x)          = error "type variable in contravariant position"
  146   $(coreplace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2))
  147   $(coreplace 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
  148   $(coreplace 'a '(T b1 b2) x)  = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  149   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
  150 -}
  151 
  152 gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
  153 -- When the argument is phantom, we can use  fmap _ = coerce
  154 -- See Note [Phantom types with Functor, Foldable, and Traversable]
  155 gen_Functor_binds loc tycon _
  156   | Phantom <- last (tyConRoles tycon)
  157   = (unitBag fmap_bind, emptyBag)
  158   where
  159     fmap_name = L (noAnnSrcSpan loc) fmap_RDR
  160     fmap_bind = mkRdrFunBind fmap_name fmap_eqns
  161     fmap_eqns = [mkSimpleMatch fmap_match_ctxt
  162                                [nlWildPat]
  163                                coerce_Expr]
  164     fmap_match_ctxt = mkPrefixFunRhs fmap_name
  165 
  166 gen_Functor_binds loc tycon tycon_args
  167   = (listToBag [fmap_bind, replace_bind], emptyBag)
  168   where
  169     data_cons = getPossibleDataCons tycon tycon_args
  170     fmap_name = L (noAnnSrcSpan loc) fmap_RDR
  171 
  172     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
  173     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns
  174     fmap_match_ctxt = mkPrefixFunRhs fmap_name
  175 
  176     fmap_eqn con = flip evalState bs_RDRs $
  177                      match_for_con fmap_match_ctxt [f_Pat] con parts
  178       where
  179         parts = foldDataConArgs ft_fmap con
  180 
  181     fmap_eqns = map fmap_eqn data_cons
  182 
  183     ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
  184     ft_fmap = FT { ft_triv = \x -> pure x
  185                    -- fmap f x = x
  186                  , ft_var  = \x -> pure $ nlHsApp f_Expr x
  187                    -- fmap f x = f x
  188                  , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
  189                      gg <- g b
  190                      h $ nlHsApp x gg
  191                    -- fmap f x = \b -> h (x (g b))
  192                  , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
  193                    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
  194                  , ft_ty_app = \_ arg_ty g x ->
  195                      -- If the argument type is a bare occurrence of the
  196                      -- data type's last type variable, then we can generate
  197                      -- more efficient code.
  198                      -- See Note [Avoid unnecessary eta expansion in derived fmap implementations]
  199                      if tcIsTyVarTy arg_ty
  200                        then pure $ nlHsApps fmap_RDR [f_Expr,x]
  201                        else do gg <- mkSimpleLam g
  202                                pure $ nlHsApps fmap_RDR [gg,x]
  203                    -- fmap f x = fmap g x
  204                  , ft_forall = \_ g x -> g x
  205                  , ft_bad_app = panic "in other argument in ft_fmap"
  206                  , ft_co_var = panic "contravariant in ft_fmap" }
  207 
  208     -- See Note [Deriving <$]
  209     replace_name = L (noAnnSrcSpan loc) replace_RDR
  210 
  211     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
  212     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns
  213     replace_match_ctxt = mkPrefixFunRhs replace_name
  214 
  215     replace_eqn con = flip evalState bs_RDRs $
  216         match_for_con replace_match_ctxt [z_Pat] con parts
  217       where
  218         parts = foldDataConArgs ft_replace con
  219 
  220     replace_eqns = map replace_eqn data_cons
  221 
  222     ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
  223     ft_replace = FT { ft_triv = \x -> pure x
  224                    -- p <$ x = x
  225                  , ft_var  = \_ -> pure z_Expr
  226                    -- p <$ _ = p
  227                  , ft_fun  = \g h x -> mkSimpleLam $ \b -> do
  228                      gg <- g b
  229                      h $ nlHsApp x gg
  230                    -- p <$ x = \b -> h (x (g b))
  231                  , ft_tup = mkSimpleTupleCase (match_for_con CaseAlt)
  232                    -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
  233                  , ft_ty_app = \_ arg_ty g x ->
  234                        -- If the argument type is a bare occurrence of the
  235                        -- data type's last type variable, then we can generate
  236                        -- more efficient code.
  237                        -- See [Deriving <$]
  238                        if tcIsTyVarTy arg_ty
  239                          then pure $ nlHsApps replace_RDR [z_Expr,x]
  240                          else do gg <- mkSimpleLam g
  241                                  pure $ nlHsApps fmap_RDR [gg,x]
  242                    -- p <$ x = fmap (p <$) x
  243                  , ft_forall = \_ g x -> g x
  244                  , ft_bad_app = panic "in other argument in ft_replace"
  245                  , ft_co_var = panic "contravariant in ft_replace" }
  246 
  247     -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
  248     match_for_con :: Monad m
  249                   => HsMatchContext GhcPs
  250                   -> [LPat GhcPs] -> DataCon
  251                   -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
  252                   -> m (LMatch GhcPs (LHsExpr GhcPs))
  253     match_for_con ctxt = mkSimpleConMatch ctxt $
  254         \con_name xsM -> do xs <- sequence xsM
  255                             pure $ nlHsApps con_name xs  -- Con x1 x2 ..
  256 
  257 {-
  258 Note [Avoid unnecessary eta expansion in derived fmap implementations]
  259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  260 For the sake of simplicity, the algorithm that derived implementations of
  261 fmap used to have a single case that dealt with applications of some type
  262 constructor T (where T is not a tuple type constructor):
  263 
  264   $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  265 
  266 This generated less than optimal code in certain situations, however. Consider
  267 this example:
  268 
  269   data List a = Nil | Cons a (List a) deriving Functor
  270 
  271 This would generate the following Functor instance:
  272 
  273   instance Functor List where
  274     fmap f Nil = Nil
  275     fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)
  276 
  277 The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application
  278 of `f`. What's worse, this eta expansion actually degrades performance! To see
  279 why, we can trace an invocation of fmap on a small List:
  280 
  281   fmap id     $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil
  282 
  283   Cons (id 0) $ fmap (\y -> id y)
  284               $ Cons 0 $ Cons 0 $ Cons 0 Nil
  285 
  286   Cons (id 0) $ Cons ((\y -> id y) 0)
  287               $ fmap (\y' -> (\y -> id y) y')
  288               $ Cons 0 $ Cons 0 Nil
  289 
  290   Cons (id 0) $ Cons ((\y -> id y) 0)
  291               $ Cons ((\y' -> (\y -> id y) y') 0)
  292               $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'')
  293               $ Cons 0 Nil
  294 
  295   Cons (id 0) $ Cons ((\y -> id y) 0)
  296               $ Cons ((\y' -> (\y -> id y) y') 0)
  297               $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
  298               $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''')
  299               $ Nil
  300 
  301   Cons (id 0) $ Cons ((\y -> id y) 0)
  302               $ Cons ((\y' -> (\y -> id y) y') 0)
  303               $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
  304               $ Nil
  305 
  306 Notice how the number of lambdas—and hence, the number of closures—one
  307 needs to evaluate grows very quickly. In general, a List with N cons cells will
  308 require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is
  309 what caused the performance issues observed in #7436.
  310 
  311 But hold on a second: shouldn't GHC's optimizer be able to eta reduce
  312 `\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not
  313 the case. In general, eta reduction can change the semantics of a program. For
  314 instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so
  315 happens that the fmap implementation above would have the same semantics
  316 regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is
  317 not yet smart enough to realize this (see #17881).
  318 
  319 To avoid this quadratic blowup, we add a special case to $fmap that applies
  320 `fmap f` directly:
  321 
  322   $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
  323   $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  324 
  325 With this modified algorithm, the derived Functor List instance becomes:
  326 
  327   instance Functor List where
  328     fmap f Nil = Nil
  329     fmap f (Cons x xs) = Cons (f x) (fmap f xs)
  330 
  331 No lambdas in sight, just the way we like it.
  332 
  333 This special case does not prevent all sources quadratic closure buildup,
  334 however. In this example:
  335 
  336   data PolyList a = PLNil | PLCons a (PolyList (PolyList a))
  337     deriving Functor
  338 
  339 We would derive the following code:
  340 
  341   instance Functor PolyList where
  342     fmap f PLNil = PLNil
  343     fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs)
  344 
  345 The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way
  346 as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced
  347 to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are
  348 recursively invoking fmap with a different argument (fmap f). Since we end up
  349 paying the price of building a closure either way, we do not extend the special
  350 case in $fmap any further, since it wouldn't buy us anything.
  351 
  352 The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by
  353 inspecting the argument type. If the argument type is a bare type variable,
  354 then we can conclude the type variable /must/ be the same as the data type's
  355 last type parameter. We know that this must be the case since there is an
  356 invariant that the argument type in ft_ty_app will always contain the last
  357 type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so
  358 if the argument type is a bare variable, then that must be exactly the last
  359 type parameter.
  360 
  361 Note that the ft_ty_app case of ft_replace (which derives implementations of
  362 (<$)) also inspects the argument type to generate more efficient code.
  363 See Note [Deriving <$].
  364 
  365 Note [Deriving <$]
  366 ~~~~~~~~~~~~~~~~~~
  367 
  368 We derive the definition of <$. Allowing this to take the default definition
  369 can lead to memory leaks: mapping over a structure with a constant function can
  370 fill the result structure with trivial thunks that retain the values from the
  371 original structure. The simplifier seems to handle this all right for simple
  372 types, but not for recursive ones. Consider
  373 
  374 data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor
  375 
  376 -- fmap _ Tip = Tip
  377 -- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)
  378 
  379 Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that
  380 simplifies no further. Why is that? `fmap` is defined recursively, so GHC
  381 cannot inline it. The static argument transformation would turn the definition
  382 into a non-recursive one
  383 
  384 -- fmap f = go where
  385 --   go Tip = Tip
  386 --   go (Bin l v r) = Bin (go l) (f v) (go r)
  387 
  388 which GHC could inline, producing an efficient definion of `<$`. But there are
  389 several problems. First, GHC does not perform the static argument transformation
  390 by default, even with -O2. Second, even when it does perform the static argument
  391 transformation, it does so only when there are at least two static arguments,
  392 which is not the case for fmap. Finally, when the type in question is
  393 non-regular, such as
  394 
  395 data Nesty a = Z a | S (Nesty a) (Nest (a, a))
  396 
  397 the function argument is no longer (entirely) static, so the static argument
  398 transformation will do nothing for us.
  399 
  400 Applying the default definition of `<$` will produce a tree full of thunks that
  401 look like ((\_ -> x) x0), which represents unnecessary thunk allocation and
  402 also retention of the previous value, potentially leaking memory. Instead, we
  403 derive <$ separately. Two aspects are different from fmap: the case of the
  404 sought type variable (ft_var) and the case of a type application (ft_ty_app).
  405 The interesting one is ft_ty_app. We have to distinguish two cases: the
  406 "immediate" case where the type argument *is* the sought type variable, and
  407 the "nested" case where the type argument *contains* the sought type variable.
  408 
  409 The immediate case:
  410 
  411 Suppose we have
  412 
  413 data Imm a = Imm (F ... a)
  414 
  415 Then we want to define
  416 
  417 x <$ Imm q = Imm (x <$ q)
  418 
  419 The nested case:
  420 
  421 Suppose we have
  422 
  423 data Nes a = Nes (F ... (G a))
  424 
  425 Then we want to define
  426 
  427 x <$ Nes q = Nes (fmap (x <$) q)
  428 
  429 We inspect the argument type in ft_ty_app
  430 (see Note [FFoldType and functorLikeTraverse]) to distinguish between these
  431 two cases. If the argument type is a bare type variable, then we know that it
  432 must be the same variable as the data type's last type parameter.
  433 This is very similar to a trick that derived fmap implementations
  434 use in their own ft_ty_app case.
  435 See Note [Avoid unnecessary eta expansion in derived fmap implementations],
  436 which explains why checking if the argument type is a bare variable is
  437 the right thing to do.
  438 
  439 We could, but do not, give tuples special treatment to improve efficiency
  440 in some cases. Suppose we have
  441 
  442 data Nest a = Z a | S (Nest (a,a))
  443 
  444 The optimal definition would be
  445 
  446 x <$ Z _ = Z x
  447 x <$ S t = S ((x, x) <$ t)
  448 
  449 which produces a result with maximal internal sharing. The reason we do not
  450 attempt to treat this case specially is that we have no way to give
  451 user-provided tuple-like types similar treatment. If the user changed the
  452 definition to
  453 
  454 data Pair a = Pair a a
  455 data Nest a = Z a | S (Nest (Pair a))
  456 
  457 they would experience a surprising degradation in performance. -}
  458 
  459 
  460 {-
  461 Utility functions related to Functor deriving.
  462 
  463 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
  464 This function works like a fold: it makes a value of type 'a' in a bottom up way.
  465 -}
  466 
  467 -- Generic traversal for Functor deriving
  468 -- See Note [FFoldType and functorLikeTraverse]
  469 data FFoldType a      -- Describes how to fold over a Type in a functor like way
  470    = FT { ft_triv    :: a
  471           -- ^ Does not contain variable
  472         , ft_var     :: a
  473           -- ^ The variable itself
  474         , ft_co_var  :: a
  475           -- ^ The variable itself, contravariantly
  476         , ft_fun     :: a -> a -> a
  477           -- ^ Function type
  478         , ft_tup     :: TyCon -> [a] -> a
  479           -- ^ Tuple type. The @[a]@ is the result of folding over the
  480           --   arguments of the tuple.
  481         , ft_ty_app  :: Type -> Type -> a -> a
  482           -- ^ Type app, variable only in last argument. The two 'Type's are
  483           --   the function and argument parts of @fun_ty arg_ty@,
  484           --   respectively.
  485         , ft_bad_app :: a
  486           -- ^ Type app, variable other than in last argument
  487         , ft_forall  :: TcTyVar -> a -> a
  488           -- ^ Forall type
  489      }
  490 
  491 functorLikeTraverse :: forall a.
  492                        TyVar         -- ^ Variable to look for
  493                     -> FFoldType a   -- ^ How to fold
  494                     -> Type          -- ^ Type to process
  495                     -> a
  496 functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar
  497                             , ft_co_var = caseCoVar,     ft_fun = caseFun
  498                             , ft_tup = caseTuple,        ft_ty_app = caseTyApp
  499                             , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
  500                     ty
  501   = fst (go False ty)
  502   where
  503     go :: Bool        -- Covariant or contravariant context
  504        -> Type
  505        -> (a, Bool)   -- (result of type a, does type contain var)
  506 
  507     go co ty | Just ty' <- tcView ty = go co ty'
  508     go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)
  509     go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })
  510        | InvisArg <- af = go co y
  511        | xc || yc       = (caseFun xr yr,True)
  512        where (xr,xc) = go (not co) x
  513              (yr,yc) = go co       y
  514     go co (AppTy    x y) | xc = (caseWrongArg,   True)
  515                          | yc = (caseTyApp x y yr, True)
  516         where (_, xc) = go co x
  517               (yr,yc) = go co y
  518     go co ty@(TyConApp con args)
  519        | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur
  520        -- At this point we know that xrs, xcs is not empty,
  521        -- and at least one xr is True
  522        | isTupleTyCon con = (caseTuple con xrs, True)
  523        | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty
  524        | Just (fun_ty, arg_ty) <- splitAppTy_maybe ty    -- T (..no var..) ty
  525                           = (caseTyApp fun_ty arg_ty (last xrs), True)
  526        | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)
  527        where
  528          -- When folding over an unboxed tuple, we must explicitly drop the
  529          -- runtime rep arguments, or else GHC will generate twice as many
  530          -- variables in a unboxed tuple pattern match and expression as it
  531          -- actually needs. See #12399
  532          (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
  533     go co (ForAllTy (Bndr v vis) x)
  534        | isVisibleArgFlag vis = panic "unexpected visible binder"
  535        | v /= var && xc       = (caseForAll v xr,True)
  536        where (xr,xc) = go co x
  537 
  538     go _ _ = (caseTrivial,False)
  539 
  540 -- Return all syntactic subterms of ty that contain var somewhere
  541 -- These are the things that should appear in instance constraints
  542 deepSubtypesContaining :: TyVar -> Type -> [TcType]
  543 deepSubtypesContaining tv
  544   = functorLikeTraverse tv
  545         (FT { ft_triv = []
  546             , ft_var = []
  547             , ft_fun = (++)
  548             , ft_tup = \_ xs -> concat xs
  549             , ft_ty_app = \t _ ts -> t:ts
  550             , ft_bad_app = panic "in other argument in deepSubtypesContaining"
  551             , ft_co_var = panic "contravariant in deepSubtypesContaining"
  552             , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
  553 
  554 
  555 foldDataConArgs :: FFoldType a -> DataCon -> [a]
  556 -- Fold over the arguments of the datacon
  557 foldDataConArgs ft con
  558   = map foldArg (map scaledThing $ dataConOrigArgTys con)
  559   where
  560     foldArg
  561       = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
  562              Just tv -> functorLikeTraverse tv ft
  563              Nothing -> const (ft_triv ft)
  564     -- If we are deriving Foldable for a GADT, there is a chance that the last
  565     -- type variable in the data type isn't actually a type variable at all.
  566     -- (for example, this can happen if the last type variable is refined to
  567     -- be a concrete type such as Int). If the last type variable is refined
  568     -- to be a specific type, then getTyVar_maybe will return Nothing.
  569     -- See Note [DeriveFoldable with ExistentialQuantification]
  570     --
  571     -- The kind checks have ensured the last type parameter is of kind *.
  572 
  573 -- Make a HsLam using a fresh variable from a State monad
  574 mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))
  575             -> State [RdrName] (LHsExpr GhcPs)
  576 -- (mkSimpleLam fn) returns (\x. fn(x))
  577 mkSimpleLam lam =
  578     get >>= \case
  579       n:names -> do
  580         put names
  581         body <- lam (nlHsVar n)
  582         return (mkHsLam [nlVarPat n] body)
  583       _ -> panic "mkSimpleLam"
  584 
  585 mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
  586              -> State [RdrName] (LHsExpr GhcPs))
  587              -> State [RdrName] (LHsExpr GhcPs)
  588 mkSimpleLam2 lam =
  589     get >>= \case
  590       n1:n2:names -> do
  591         put names
  592         body <- lam (nlHsVar n1) (nlHsVar n2)
  593         return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
  594       _ -> panic "mkSimpleLam2"
  595 
  596 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
  597 --
  598 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
  599 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
  600 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
  601 -- and its arguments, applying an expression (from @insides@) to each of the
  602 -- respective arguments of @con@.
  603 mkSimpleConMatch :: Monad m => HsMatchContext GhcPs
  604                  -> (RdrName -> [a] -> m (LHsExpr GhcPs))
  605                  -> [LPat GhcPs]
  606                  -> DataCon
  607                  -> [LHsExpr GhcPs -> a]
  608                  -> m (LMatch GhcPs (LHsExpr GhcPs))
  609 mkSimpleConMatch ctxt fold extra_pats con insides = do
  610     let con_name = getRdrName con
  611     let vars_needed = takeList insides as_RDRs
  612     let bare_pat = nlConVarPat con_name vars_needed
  613     let pat = if null vars_needed
  614           then bare_pat
  615           else nlParPat bare_pat
  616     rhs <- fold con_name
  617                 (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)
  618     return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
  619 
  620 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
  621 --
  622 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
  623 -- 'mkSimpleConMatch', with two key differences:
  624 --
  625 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
  626 --    @[LHsExpr RdrName]@. This is because it filters out the expressions
  627 --    corresponding to arguments whose types do not mention the last type
  628 --    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
  629 --    'Nothing' elements of @insides@).
  630 --
  631 -- 2. @fold@ takes an expression as its first argument instead of a
  632 --    constructor name. This is because it uses a specialized
  633 --    constructor function expression that only takes as many parameters as
  634 --    there are argument types that mention the last type variable.
  635 --
  636 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
  637 mkSimpleConMatch2 :: Monad m
  638                   => HsMatchContext GhcPs
  639                   -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
  640                                       -> m (LHsExpr GhcPs))
  641                   -> [LPat GhcPs]
  642                   -> DataCon
  643                   -> [Maybe (LHsExpr GhcPs)]
  644                   -> m (LMatch GhcPs (LHsExpr GhcPs))
  645 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
  646     let con_name = getRdrName con
  647         vars_needed = takeList insides as_RDRs
  648         pat = nlConVarPat con_name vars_needed
  649         -- Make sure to zip BEFORE invoking catMaybes. We want the variable
  650         -- indices in each expression to match up with the argument indices
  651         -- in con_expr (defined below).
  652         exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)
  653                                    insides vars_needed
  654         -- An element of argTysTyVarInfo is True if the constructor argument
  655         -- with the same index has a type which mentions the last type
  656         -- variable.
  657         argTysTyVarInfo = map isJust insides
  658         (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars
  659 
  660         con_expr
  661           | null asWithTyVar = nlHsApps con_name asWithoutTyVar
  662           | otherwise =
  663               let bs   = filterByList  argTysTyVarInfo bs_RDRs
  664                   vars = filterByLists argTysTyVarInfo bs_Vars as_Vars
  665               in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
  666 
  667     rhs <- fold con_expr exps
  668     return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds
  669 
  670 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
  671 mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]
  672                                  -> m (LMatch GhcPs (LHsExpr GhcPs)))
  673                   -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)
  674 mkSimpleTupleCase match_for_con tc insides x
  675   = do { let data_con = tyConSingleDataCon tc
  676        ; match <- match_for_con [] data_con insides
  677        ; return $ nlHsCase x [match] }
  678 
  679 {-
  680 ************************************************************************
  681 *                                                                      *
  682                         Foldable instances
  683 
  684  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
  685 
  686 *                                                                      *
  687 ************************************************************************
  688 
  689 Deriving Foldable instances works the same way as Functor instances,
  690 only Foldable instances are not possible for function types at all.
  691 Given (data T a = T a a (T a) deriving Foldable), we get:
  692 
  693   instance Foldable T where
  694       foldr f z (T x1 x2 x3) =
  695         $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
  696 
  697 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
  698 arguments to the constructor that would produce useless code in a Foldable
  699 instance. For example, the following datatype:
  700 
  701   data Foo a = Foo Int a Int deriving Foldable
  702 
  703 would have the following generated Foldable instance:
  704 
  705   instance Foldable Foo where
  706     foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
  707 
  708 since neither of the two Int arguments are folded over.
  709 
  710 The cases are:
  711 
  712   $(foldr 'a 'a)         =  f
  713   $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
  714   $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
  715 
  716 Note that the arguments to the real foldr function are the wrong way around,
  717 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
  718 
  719 One can envision a case for types that don't contain the last type variable:
  720 
  721   $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
  722 
  723 But this case will never materialize, since the aforementioned filtering
  724 removes all such types from consideration.
  725 See Note [Generated code for DeriveFoldable and DeriveTraversable].
  726 
  727 Foldable instances differ from Functor and Traversable instances in that
  728 Foldable instances can be derived for data types in which the last type
  729 variable is existentially quantified. In particular, if the last type variable
  730 is refined to a more specific type in a GADT:
  731 
  732   data GADT a where
  733       G :: a ~ Int => a -> G Int
  734 
  735 then the deriving machinery does not attempt to check that the type a contains
  736 Int, since it is not syntactically equal to a type variable. That is, the
  737 derived Foldable instance for GADT is:
  738 
  739   instance Foldable GADT where
  740       foldr _ z (GADT _) = z
  741 
  742 See Note [DeriveFoldable with ExistentialQuantification].
  743 
  744 Note [Deriving null]
  745 ~~~~~~~~~~~~~~~~~~~~
  746 
  747 In some cases, deriving the definition of 'null' can produce much better
  748 results than the default definition. For example, with
  749 
  750   data SnocList a = Nil | Snoc (SnocList a) a
  751 
  752 the default definition of 'null' would walk the entire spine of a
  753 nonempty snoc-list before concluding that it is not null. But looking at
  754 the Snoc constructor, we can immediately see that it contains an 'a', and
  755 so 'null' can return False immediately if it matches on Snoc. When we
  756 derive 'null', we keep track of things that cannot be null. The interesting
  757 case is type application. Given
  758 
  759   data Wrap a = Wrap (Foo (Bar a))
  760 
  761 we use
  762 
  763   null (Wrap fba) = all null fba
  764 
  765 but if we see
  766 
  767   data Wrap a = Wrap (Foo a)
  768 
  769 we can just use
  770 
  771   null (Wrap fa) = null fa
  772 
  773 Indeed, we allow this to happen even for tuples:
  774 
  775   data Wrap a = Wrap (Foo (a, Int))
  776 
  777 produces
  778 
  779   null (Wrap fa) = null fa
  780 
  781 As explained in Note [Deriving <$], giving tuples special performance treatment
  782 could surprise users if they switch to other types, but Ryan Scott seems to
  783 think it's okay to do it for now.
  784 -}
  785 
  786 gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
  787 -- When the parameter is phantom, we can use foldMap _ _ = mempty
  788 -- See Note [Phantom types with Functor, Foldable, and Traversable]
  789 gen_Foldable_binds loc tycon _
  790   | Phantom <- last (tyConRoles tycon)
  791   = (unitBag foldMap_bind, emptyBag)
  792   where
  793     foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
  794     foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns
  795     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt
  796                                   [nlWildPat, nlWildPat]
  797                                   mempty_Expr]
  798     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
  799 
  800 gen_Foldable_binds loc tycon tycon_args
  801   | null data_cons  -- There's no real point producing anything but
  802                     -- foldMap for a type with no constructors.
  803   = (unitBag foldMap_bind, emptyBag)
  804 
  805   | otherwise
  806   = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)
  807   where
  808     data_cons = getPossibleDataCons tycon tycon_args
  809 
  810     foldr_name = L (noAnnSrcSpan loc) foldable_foldr_RDR
  811 
  812     foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns
  813     eqns = map foldr_eqn data_cons
  814     foldr_eqn con
  815       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
  816       where
  817         parts = sequence $ foldDataConArgs ft_foldr con
  818     foldr_match_ctxt = mkPrefixFunRhs foldr_name
  819 
  820     foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR
  821 
  822     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
  823     foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)
  824                       foldMap_name foldMap_eqns
  825 
  826     foldMap_eqns = map foldMap_eqn data_cons
  827 
  828     foldMap_eqn con
  829       = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
  830       where
  831         parts = sequence $ foldDataConArgs ft_foldMap con
  832     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name
  833 
  834     -- Given a list of NullM results, produce Nothing if any of
  835     -- them is NotNull, and otherwise produce a list of Maybes
  836     -- with Justs representing unknowns and Nothings representing
  837     -- things that are definitely null.
  838     convert :: [NullM a] -> Maybe [Maybe a]
  839     convert = traverse go where
  840       go IsNull = Just Nothing
  841       go NotNull = Nothing
  842       go (NullM a) = Just (Just a)
  843 
  844     null_name = L (noAnnSrcSpan loc) null_RDR
  845     null_match_ctxt = mkPrefixFunRhs null_name
  846     null_bind = mkRdrFunBind null_name null_eqns
  847     null_eqns = map null_eqn data_cons
  848     null_eqn con
  849       = flip evalState bs_RDRs $ do
  850           parts <- sequence $ foldDataConArgs ft_null con
  851           case convert parts of
  852             Nothing -> return $
  853               mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]
  854                 false_Expr emptyLocalBinds
  855             Just cp -> match_null [] con cp
  856 
  857     -- Yields 'Just' an expression if we're folding over a type that mentions
  858     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
  859     -- See Note [FFoldType and functorLikeTraverse]
  860     ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
  861     ft_foldr
  862       = FT { ft_triv    = return Nothing
  863              -- foldr f = \x z -> z
  864            , ft_var     = return $ Just f_Expr
  865              -- foldr f = f
  866            , ft_tup     = \t g -> do
  867                gg  <- sequence g
  868                lam <- mkSimpleLam2 $ \x z ->
  869                  mkSimpleTupleCase (match_foldr z) t gg x
  870                return (Just lam)
  871              -- foldr f = (\x z -> case x of ...)
  872            , ft_ty_app  = \_ _ g -> do
  873                gg <- g
  874                mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
  875                  nlHsApps foldable_foldr_RDR [gg',z,x]) gg
  876              -- foldr f = (\x z -> foldr g z x)
  877            , ft_forall  = \_ g -> g
  878            , ft_co_var  = panic "contravariant in ft_foldr"
  879            , ft_fun     = panic "function in ft_foldr"
  880            , ft_bad_app = panic "in other argument in ft_foldr" }
  881 
  882     match_foldr :: Monad m
  883                 => LHsExpr GhcPs
  884                 -> [LPat GhcPs]
  885                 -> DataCon
  886                 -> [Maybe (LHsExpr GhcPs)]
  887                 -> m (LMatch GhcPs (LHsExpr GhcPs))
  888     match_foldr z = mkSimpleConMatch2 foldr_match_ctxt $ \_ xs -> return (mkFoldr xs)
  889       where
  890         -- g1 v1 (g2 v2 (.. z))
  891         mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
  892         mkFoldr = foldr nlHsApp z
  893 
  894     -- See Note [FFoldType and functorLikeTraverse]
  895     ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
  896     ft_foldMap
  897       = FT { ft_triv = return Nothing
  898              -- foldMap f = \x -> mempty
  899            , ft_var  = return (Just f_Expr)
  900              -- foldMap f = f
  901            , ft_tup  = \t g -> do
  902                gg  <- sequence g
  903                lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
  904                return (Just lam)
  905              -- foldMap f = \x -> case x of (..,)
  906            , ft_ty_app = \_ _ g -> fmap (nlHsApp foldMap_Expr) <$> g
  907              -- foldMap f = foldMap g
  908            , ft_forall = \_ g -> g
  909            , ft_co_var = panic "contravariant in ft_foldMap"
  910            , ft_fun = panic "function in ft_foldMap"
  911            , ft_bad_app = panic "in other argument in ft_foldMap" }
  912 
  913     match_foldMap :: Monad m
  914                   => [LPat GhcPs]
  915                   -> DataCon
  916                   -> [Maybe (LHsExpr GhcPs)]
  917                   -> m (LMatch GhcPs (LHsExpr GhcPs))
  918     match_foldMap = mkSimpleConMatch2 foldMap_match_ctxt $ \_ xs -> return (mkFoldMap xs)
  919       where
  920         -- mappend v1 (mappend v2 ..)
  921         mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
  922         mkFoldMap [] = mempty_Expr
  923         mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
  924 
  925     -- See Note [FFoldType and functorLikeTraverse]
  926     -- Yields NullM an expression if we're folding over an expression
  927     -- that may or may not be null. Yields IsNull if it's certainly
  928     -- null, and yields NotNull if it's certainly not null.
  929     -- See Note [Deriving null]
  930     ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))
  931     ft_null
  932       = FT { ft_triv = return IsNull
  933              -- null = \_ -> True
  934            , ft_var  = return NotNull
  935              -- null = \_ -> False
  936            , ft_tup  = \t g -> do
  937                gg  <- sequence g
  938                case convert gg of
  939                  Nothing -> pure NotNull
  940                  Just ggg ->
  941                    NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)
  942              -- null = \x -> case x of (..,)
  943            , ft_ty_app = \_ _ g -> flip fmap g $ \nestedResult ->
  944                               case nestedResult of
  945                                 -- If e definitely contains the parameter,
  946                                 -- then we can test if (G e) contains it by
  947                                 -- simply checking if (G e) is null
  948                                 NotNull -> NullM null_Expr
  949                                 -- This case is unreachable--it will actually be
  950                                 -- caught by ft_triv
  951                                 IsNull -> IsNull
  952                                 -- The general case uses (all null),
  953                                 -- (all (all null)), etc.
  954                                 NullM nestedTest -> NullM $
  955                                                     nlHsApp all_Expr nestedTest
  956              -- null fa = null fa, or null fa = all null fa, or null fa = True
  957            , ft_forall = \_ g -> g
  958            , ft_co_var = panic "contravariant in ft_null"
  959            , ft_fun = panic "function in ft_null"
  960            , ft_bad_app = panic "in other argument in ft_null" }
  961 
  962     match_null :: Monad m
  963                => [LPat GhcPs]
  964                -> DataCon
  965                -> [Maybe (LHsExpr GhcPs)]
  966                -> m (LMatch GhcPs (LHsExpr GhcPs))
  967     match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)
  968       where
  969         -- v1 && v2 && ..
  970         mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
  971         mkNull [] = true_Expr
  972         mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs
  973 
  974 data NullM a =
  975     IsNull   -- Definitely null
  976   | NotNull  -- Definitely not null
  977   | NullM a  -- Unknown
  978 
  979 {-
  980 ************************************************************************
  981 *                                                                      *
  982                         Traversable instances
  983 
  984  see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
  985 *                                                                      *
  986 ************************************************************************
  987 
  988 Again, Traversable is much like Functor and Foldable.
  989 
  990 The cases are:
  991 
  992   $(traverse 'a 'a)          =  f
  993   $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->
  994      liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)
  995   $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
  996 
  997 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
  998 do not mention the last type parameter. Therefore, the following datatype:
  999 
 1000   data Foo a = Foo Int a Int
 1001 
 1002 would have the following derived Traversable instance:
 1003 
 1004   instance Traversable Foo where
 1005     traverse f (Foo x1 x2 x3) =
 1006       fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
 1007 
 1008 since the two Int arguments do not produce any effects in a traversal.
 1009 
 1010 One can envision a case for types that do not mention the last type parameter:
 1011 
 1012   $(traverse 'a 'b)          =  pure     -- when b does not contain a
 1013 
 1014 But this case will never materialize, since the aforementioned filtering
 1015 removes all such types from consideration.
 1016 See Note [Generated code for DeriveFoldable and DeriveTraversable].
 1017 -}
 1018 
 1019 gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
 1020 -- When the argument is phantom, we can use traverse = pure . coerce
 1021 -- See Note [Phantom types with Functor, Foldable, and Traversable]
 1022 gen_Traversable_binds loc tycon _
 1023   | Phantom <- last (tyConRoles tycon)
 1024   = (unitBag traverse_bind, emptyBag)
 1025   where
 1026     traverse_name = L (noAnnSrcSpan loc) traverse_RDR
 1027     traverse_bind = mkRdrFunBind traverse_name traverse_eqns
 1028     traverse_eqns =
 1029         [mkSimpleMatch traverse_match_ctxt
 1030                        [nlWildPat, z_Pat]
 1031                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]
 1032     traverse_match_ctxt = mkPrefixFunRhs traverse_name
 1033 
 1034 gen_Traversable_binds loc tycon tycon_args
 1035   = (unitBag traverse_bind, emptyBag)
 1036   where
 1037     data_cons = getPossibleDataCons tycon tycon_args
 1038 
 1039     traverse_name = L (noAnnSrcSpan loc) traverse_RDR
 1040 
 1041     -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
 1042     traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)
 1043                                    traverse_name traverse_eqns
 1044     traverse_eqns = map traverse_eqn data_cons
 1045     traverse_eqn con
 1046       = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
 1047       where
 1048         parts = sequence $ foldDataConArgs ft_trav con
 1049     traverse_match_ctxt = mkPrefixFunRhs traverse_name
 1050 
 1051     -- Yields 'Just' an expression if we're folding over a type that mentions
 1052     -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
 1053     -- See Note [FFoldType and functorLikeTraverse]
 1054     ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))
 1055     ft_trav
 1056       = FT { ft_triv    = return Nothing
 1057              -- traverse f = pure x
 1058            , ft_var     = return (Just f_Expr)
 1059              -- traverse f = f x
 1060            , ft_tup     = \t gs -> do
 1061                gg  <- sequence gs
 1062                lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
 1063                return (Just lam)
 1064              -- traverse f = \x -> case x of (a1,a2,..) ->
 1065              --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..
 1066            , ft_ty_app  = \_ _ g -> fmap (nlHsApp traverse_Expr) <$> g
 1067              -- traverse f = traverse g
 1068            , ft_forall  = \_ g -> g
 1069            , ft_co_var  = panic "contravariant in ft_trav"
 1070            , ft_fun     = panic "function in ft_trav"
 1071            , ft_bad_app = panic "in other argument in ft_trav" }
 1072 
 1073     -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
 1074     --                    (g2 a2) <*> ...
 1075     match_for_con :: Monad m
 1076                   => [LPat GhcPs]
 1077                   -> DataCon
 1078                   -> [Maybe (LHsExpr GhcPs)]
 1079                   -> m (LMatch GhcPs (LHsExpr GhcPs))
 1080     match_for_con = mkSimpleConMatch2 traverse_match_ctxt $
 1081                                              \con xs -> return (mkApCon con xs)
 1082       where
 1083         -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
 1084         mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
 1085         mkApCon con [] = nlHsApps pure_RDR [con]
 1086         mkApCon con [x] = nlHsApps fmap_RDR [con,x]
 1087         mkApCon con (x1:x2:xs) =
 1088             foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs
 1089           where appAp x y = nlHsApps ap_RDR [x,y]
 1090 
 1091 -----------------------------------------------------------------------
 1092 
 1093 f_Expr, z_Expr, mempty_Expr, foldMap_Expr,
 1094     traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
 1095     all_Expr, null_Expr :: LHsExpr GhcPs
 1096 f_Expr        = nlHsVar f_RDR
 1097 z_Expr        = nlHsVar z_RDR
 1098 mempty_Expr   = nlHsVar mempty_RDR
 1099 foldMap_Expr  = nlHsVar foldMap_RDR
 1100 traverse_Expr = nlHsVar traverse_RDR
 1101 coerce_Expr   = nlHsVar (getRdrName coerceId)
 1102 pure_Expr     = nlHsVar pure_RDR
 1103 true_Expr     = nlHsVar true_RDR
 1104 false_Expr    = nlHsVar false_RDR
 1105 all_Expr      = nlHsVar all_RDR
 1106 null_Expr     = nlHsVar null_RDR
 1107 
 1108 f_RDR, z_RDR :: RdrName
 1109 f_RDR = mkVarUnqual (fsLit "f")
 1110 z_RDR = mkVarUnqual (fsLit "z")
 1111 
 1112 as_RDRs, bs_RDRs :: [RdrName]
 1113 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
 1114 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
 1115 
 1116 as_Vars, bs_Vars :: [LHsExpr GhcPs]
 1117 as_Vars = map nlHsVar as_RDRs
 1118 bs_Vars = map nlHsVar bs_RDRs
 1119 
 1120 f_Pat, z_Pat :: LPat GhcPs
 1121 f_Pat = nlVarPat f_RDR
 1122 z_Pat = nlVarPat z_RDR
 1123 
 1124 {-
 1125 Note [DeriveFoldable with ExistentialQuantification]
 1126 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1127 Functor and Traversable instances can only be derived for data types whose
 1128 last type parameter is truly universally polymorphic. For example:
 1129 
 1130   data T a b where
 1131     T1 ::                 b   -> T a b   -- YES, b is unconstrained
 1132     T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)
 1133     T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)
 1134     T4 ::                 Int -> T a Int -- NO, this is just like T3
 1135     T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even
 1136                                          -- though a is existential
 1137     T6 ::                 Int -> T Int b -- YES, b is unconstrained
 1138 
 1139 For Foldable instances, however, we can completely lift the constraint that
 1140 the last type parameter be truly universally polymorphic. This means that T
 1141 (as defined above) can have a derived Foldable instance:
 1142 
 1143   instance Foldable (T a) where
 1144     foldr f z (T1 b)   = f b z
 1145     foldr f z (T2 b)   = f b z
 1146     foldr f z (T3 b)   = f b z
 1147     foldr f z (T4 b)   = z
 1148     foldr f z (T5 a b) = f b z
 1149     foldr f z (T6 a)   = z
 1150 
 1151     foldMap f (T1 b)   = f b
 1152     foldMap f (T2 b)   = f b
 1153     foldMap f (T3 b)   = f b
 1154     foldMap f (T4 b)   = mempty
 1155     foldMap f (T5 a b) = f b
 1156     foldMap f (T6 a)   = mempty
 1157 
 1158 In a Foldable instance, it is safe to fold over an occurrence of the last type
 1159 parameter that is not truly universally polymorphic. However, there is a bit
 1160 of subtlety in determining what is actually an occurrence of a type parameter.
 1161 T3 and T4, as defined above, provide one example:
 1162 
 1163   data T a b where
 1164     ...
 1165     T3 :: b ~ Int => b   -> T a b
 1166     T4 ::            Int -> T a Int
 1167     ...
 1168 
 1169   instance Foldable (T a) where
 1170     ...
 1171     foldr f z (T3 b) = f b z
 1172     foldr f z (T4 b) = z
 1173     ...
 1174     foldMap f (T3 b) = f b
 1175     foldMap f (T4 b) = mempty
 1176     ...
 1177 
 1178 Notice that the argument of T3 is folded over, whereas the argument of T4 is
 1179 not. This is because we only fold over constructor arguments that
 1180 syntactically mention the universally quantified type parameter of that
 1181 particular data constructor. See foldDataConArgs for how this is implemented.
 1182 
 1183 As another example, consider the following data type. The argument of each
 1184 constructor has the same type as the last type parameter:
 1185 
 1186   data E a where
 1187     E1 :: (a ~ Int) => a   -> E a
 1188     E2 ::              Int -> E Int
 1189     E3 :: (a ~ Int) => a   -> E Int
 1190     E4 :: (a ~ Int) => Int -> E a
 1191 
 1192 Only E1's argument is an occurrence of a universally quantified type variable
 1193 that is syntactically equivalent to the last type parameter, so only E1's
 1194 argument will be folded over in a derived Foldable instance.
 1195 
 1196 See #10447 for the original discussion on this feature. Also see
 1197 https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor
 1198 for a more in-depth explanation.
 1199 
 1200 Note [FFoldType and functorLikeTraverse]
 1201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1202 Deriving Functor, Foldable, and Traversable all require generating expressions
 1203 which perform an operation on each argument of a data constructor depending
 1204 on the argument's type. In particular, a generated operation can be different
 1205 depending on whether the type mentions the last type variable of the datatype
 1206 (e.g., if you have data T a = MkT a Int, then a generated foldr expression would
 1207 fold over the first argument of MkT, but not the second).
 1208 
 1209 This pattern is abstracted with the FFoldType datatype, which provides hooks
 1210 for the user to specify how a constructor argument should be folded when it
 1211 has a type with a particular "shape". The shapes are as follows (assume that
 1212 a is the last type variable in a given datatype):
 1213 
 1214 * ft_triv:    The type does not mention the last type variable at all.
 1215               Examples: Int, b
 1216 
 1217 * ft_var:     The type is syntactically equal to the last type variable.
 1218               Moreover, the type appears in a covariant position (see
 1219               the Deriving Functor instances section of the user's guide
 1220               for an in-depth explanation of covariance vs. contravariance).
 1221               Example: a (covariantly)
 1222 
 1223 * ft_co_var:  The type is syntactically equal to the last type variable.
 1224               Moreover, the type appears in a contravariant position.
 1225               Example: a (contravariantly)
 1226 
 1227 * ft_fun:     A function type which mentions the last type variable in
 1228               the argument position, result position or both.
 1229               Examples: a -> Int, Int -> a, Maybe a -> [a]
 1230 
 1231 * ft_tup:     A tuple type which mentions the last type variable in at least
 1232               one of its fields. The TyCon argument of ft_tup represents the
 1233               particular tuple's type constructor.
 1234               Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
 1235 
 1236 * ft_ty_app:  A type is being applied to the last type parameter, where the
 1237               applied type does not mention the last type parameter (if it
 1238               did, it would fall under ft_bad_app) and the argument type
 1239               mentions the last type parameter (if it did not, it would fall
 1240               under ft_triv). The first two Type arguments to
 1241               ft_ty_app represent the applied type and argument type,
 1242               respectively.
 1243 
 1244               Currently, only DeriveFunctor makes use of the argument type.
 1245               It inspects the argument type so that it can generate more
 1246               efficient implementations of fmap
 1247               (see Note [Avoid unnecessary eta expansion in derived fmap implementations])
 1248               and (<$) (see Note [Deriving <$]) in certain cases.
 1249 
 1250               Note that functions, tuples, and foralls are distinct cases
 1251               and take precedence over ft_ty_app. (For example, (Int -> a) would
 1252               fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
 1253               Examples: Maybe a, Either b a
 1254 
 1255 * ft_bad_app: A type application uses the last type parameter in a position
 1256               other than the last argument. This case is singled out because
 1257               Functor, Foldable, and Traversable instances cannot be derived
 1258               for datatypes containing arguments with such types.
 1259               Examples: Either a Int, Const a b
 1260 
 1261 * ft_forall:  A forall'd type mentions the last type parameter on its right-
 1262               hand side (and is not quantified on the left-hand side). This
 1263               case is present mostly for plumbing purposes.
 1264               Example: forall b. Either b a
 1265 
 1266 If FFoldType describes a strategy for folding subcomponents of a Type, then
 1267 functorLikeTraverse is the function that applies that strategy to the entirety
 1268 of a Type, returning the final folded-up result.
 1269 
 1270 foldDataConArgs applies functorLikeTraverse to every argument type of a
 1271 constructor, returning a list of the fold results. This makes foldDataConArgs
 1272 a natural way to generate the subexpressions in a generated fmap, foldr,
 1273 foldMap, or traverse definition (the subexpressions must then be combined in
 1274 a method-specific fashion to form the final generated expression).
 1275 
 1276 Deriving Generic1 also does validity checking by looking for the last type
 1277 variable in certain positions of a constructor's argument types, so it also
 1278 uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics.
 1279 
 1280 Note [Generated code for DeriveFoldable and DeriveTraversable]
 1281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1282 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
 1283 that of -XDeriveFunctor. However, there an important difference between deriving
 1284 the former two typeclasses and the latter one, which is best illustrated by the
 1285 following scenario:
 1286 
 1287   data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
 1288 
 1289 The generated code for the Functor instance is straightforward:
 1290 
 1291   instance Functor WithInt where
 1292     fmap f (WithInt a i) = WithInt (f a) i
 1293 
 1294 But if we use too similar of a strategy for deriving the Foldable and
 1295 Traversable instances, we end up with this code:
 1296 
 1297   instance Foldable WithInt where
 1298     foldMap f (WithInt a i) = f a <> mempty
 1299 
 1300   instance Traversable WithInt where
 1301     traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
 1302 
 1303 This is unsatisfying for two reasons:
 1304 
 1305 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
 1306    expects an argument whose type is of kind *. This effectively prevents
 1307    Traversable from being derived for any datatype with an unlifted argument
 1308    type (#11174).
 1309 
 1310 2. The generated code contains superfluous expressions. By the Monoid laws,
 1311    we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
 1312    reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
 1313 
 1314 We can fix both of these issues by incorporating a slight twist to the usual
 1315 algorithm that we use for -XDeriveFunctor. The differences can be summarized
 1316 as follows:
 1317 
 1318 1. In the generated expression, we only fold over arguments whose types
 1319    mention the last type parameter. Any other argument types will simply
 1320    produce useless 'mempty's or 'pure's, so they can be safely ignored.
 1321 
 1322 2. In the case of -XDeriveTraversable, instead of applying ConName,
 1323    we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
 1324 
 1325    * ConName has n arguments
 1326    * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
 1327      to the arguments whose types mention the last type parameter. As a
 1328      consequence, taking the difference of {a_1, ..., a_n} and
 1329      {b_i, ..., b_k} yields the all the argument values of ConName whose types
 1330      do not mention the last type parameter. Note that [i, ..., k] is a
 1331      strictly increasing—but not necessarily consecutive—integer sequence.
 1332 
 1333      For example, the datatype
 1334 
 1335        data Foo a = Foo Int a Int a
 1336 
 1337      would generate the following Traversable instance:
 1338 
 1339        instance Traversable Foo where
 1340          traverse f (Foo a1 a2 a3 a4) =
 1341            fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
 1342 
 1343 Technically, this approach would also work for -XDeriveFunctor as well, but we
 1344 decide not to do so because:
 1345 
 1346 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
 1347    instead of (WithInt (f a) i).
 1348 
 1349 2. There would be certain datatypes for which the above strategy would
 1350    generate Functor code that would fail to typecheck. For example:
 1351 
 1352      data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
 1353 
 1354    With the conventional algorithm, it would generate something like:
 1355 
 1356      fmap f (Bar a) = Bar (fmap f a)
 1357 
 1358    which typechecks. But with the strategy mentioned above, it would generate:
 1359 
 1360      fmap f (Bar a) = (\b -> Bar b) (fmap f a)
 1361 
 1362    which does not typecheck, since GHC cannot unify the rank-2 type variables
 1363    in the types of b and (fmap f a).
 1364 
 1365 Note [Phantom types with Functor, Foldable, and Traversable]
 1366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1367 
 1368 Given a type F :: * -> * whose type argument has a phantom role, we can always
 1369 produce lawful Functor and Traversable instances using
 1370 
 1371     fmap _ = coerce
 1372     traverse _ = pure . coerce
 1373 
 1374 Indeed, these are equivalent to any *strictly lawful* instances one could
 1375 write, except that this definition of 'traverse' may be lazier.  That is, if
 1376 instances obey the laws under true equality (rather than up to some equivalence
 1377 relation), then they will be essentially equivalent to these. These definitions
 1378 are incredibly cheap, so we want to use them even if it means ignoring some
 1379 non-strictly-lawful instance in an embedded type.
 1380 
 1381 Foldable has far fewer laws to work with, which leaves us unwelcome
 1382 freedom in implementing it. At a minimum, we would like to ensure that
 1383 a derived foldMap is always at least as good as foldMapDefault with a
 1384 derived traverse. To accomplish that, we must define
 1385 
 1386    foldMap _ _ = mempty
 1387 
 1388 in these cases.
 1389 
 1390 This may have different strictness properties from a standard derivation.
 1391 Consider
 1392 
 1393    data NotAList a = Nil | Cons (NotAList a) deriving Foldable
 1394 
 1395 The usual deriving mechanism would produce
 1396 
 1397    foldMap _ Nil = mempty
 1398    foldMap f (Cons x) = foldMap f x
 1399 
 1400 which is strict in the entire spine of the NotAList.
 1401 
 1402 Final point: why do we even care about such types? Users will rarely if ever
 1403 map, fold, or traverse over such things themselves, but other derived
 1404 instances may:
 1405 
 1406    data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable
 1407 
 1408 Note [EmptyDataDecls with Functor, Foldable, and Traversable]
 1409 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1410 
 1411 There are some slightly tricky decisions to make about how to handle
 1412 Functor, Foldable, and Traversable instances for types with no constructors.
 1413 For fmap, the two basic options are
 1414 
 1415    fmap _ _ = error "Sorry, no constructors"
 1416 
 1417 or
 1418 
 1419    fmap _ z = case z of
 1420 
 1421 In most cases, the latter is more helpful: if the thunk passed to fmap
 1422 throws an exception, we're generally going to be much more interested in
 1423 that exception than in the fact that there aren't any constructors.
 1424 
 1425 In order to match the semantics for phantoms (see note above), we need to
 1426 be a bit careful about 'traverse'. The obvious definition would be
 1427 
 1428    traverse _ z = case z of
 1429 
 1430 but this is stricter than the one for phantoms. We instead use
 1431 
 1432    traverse _ z = pure $ case z of
 1433 
 1434 For foldMap, the obvious choices are
 1435 
 1436    foldMap _ _ = mempty
 1437 
 1438 or
 1439 
 1440    foldMap _ z = case z of
 1441 
 1442 We choose the first one to be consistent with what foldMapDefault does for
 1443 a derived Traversable instance.
 1444 -}