{-
(c) The University of Glasgow 2011

-}


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

-- | The deriving code for the Functor, Foldable, and Traversable classes
module GHC.Tc.Deriv.Functor
   ( FFoldType(..)
   , functorLikeTraverse
   , deepSubtypesContaining
   , foldDataConArgs

   , gen_Functor_binds
   , gen_Foldable_binds
   , gen_Traversable_binds
   )
where

import GHC.Prelude

import GHC.Data.Bag
import GHC.Core.DataCon
import GHC.Data.FastString
import GHC.Hs
import GHC.Utils.Panic
import GHC.Builtin.Names
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Utils.Monad.State.Strict
import GHC.Tc.Deriv.Generate
import GHC.Tc.Utils.TcType
import GHC.Core.TyCon
import GHC.Core.TyCo.Rep
import GHC.Core.Type
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Types.Var.Set
import GHC.Types.Id.Make (coerceId)
import GHC.Builtin.Types (true_RDR, false_RDR)
import GHC.Data.List.Infinite (Infinite (..))
import qualified GHC.Data.List.Infinite as Inf

import Data.Foldable
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 x).  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 x)          = f x
  $(fmap 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2))
  $(fmap 'a '(T b1 a) x)   = fmap f x -- when a only occurs directly as the last argument of T
  $(fmap 'a '(T b1 b2) x)  = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y)))

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 x) and
$(cofmap 'a '(T b1 a) x) cases:

  $(cofmap 'a 'b x)          = x     -- when b does not contain a
  $(cofmap 'a 'a x)          = 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 '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
  $(cofmap 'a '(T b1 b2) x)  = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y)))

Note that the code produced by $(fmap _ _ _) is always a higher order function,
with type `(a -> b) -> (g a -> g b)` for some g.

Note that there are two distinct cases in $fmap (and $cofmap) that match on an
application of some type constructor T (where T is not a tuple type
constructor):

  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2

While the latter case technically subsumes the former case, it is important to
give special treatment to the former case to avoid unnecessary eta expansion.
See Note [Avoid unnecessary eta expansion in derived fmap implementations].

We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for
an explanation of why this is important. Just like $fmap/$cofmap above, there
is a similar algorithm for generating `p <$ x` (for some constant `p`):

  $(replace 'a 'b x)          = x      -- when b does not contain a
  $(replace 'a 'a x)          = p
  $(replace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2))
  $(replace 'a '(T b1 a) x)   = p <$ x -- when a only occurs directly as the last argument of T
  $(replace 'a '(T b1 b2) x)  = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y)))

  $(coreplace 'a 'b x)          = x      -- when b does not contain a
  $(coreplace 'a 'a x)          = error "type variable in contravariant position"
  $(coreplace 'a '(b1,b2) x)    = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2))
  $(coreplace 'a '(T b1 a) x)   = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T
  $(coreplace 'a '(T b1 b2) x)  = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2
  $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y)))
-}

gen_Functor_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
-- When the argument is phantom, we can use  fmap _ = coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Functor_binds :: SrcSpan
-> DerivInstTys -> (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Functor_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  | Role
Phantom <- [Role] -> Role
forall a. HasCallStack => [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
  = ([LHsBind (GhcPass 'Parsed)
fmap_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    fmap_name :: GenLocated SrcSpanAnnN RdrName
fmap_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
fmap_RDR
    fmap_bind :: LHsBind (GhcPass 'Parsed)
fmap_bind = GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind GenLocated SrcSpanAnnN RdrName
fmap_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
fmap_eqns
    fmap_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
fmap_eqns = [HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
fmap_match_ctxt
                               ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat])
                               LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
coerce_Expr]
    fmap_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
fmap_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
fmap_name AnnFunRhs
forall a. NoAnn a => a
noAnn

gen_Functor_binds SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                       , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args })
  = ([LHsBind (GhcPass 'Parsed)
fmap_bind, LHsBind (GhcPass 'Parsed)
replace_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
    fmap_name :: GenLocated SrcSpanAnnN RdrName
fmap_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
fmap_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    fmap_bind :: LHsBind (GhcPass 'Parsed)
fmap_bind = Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
2 LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. a -> a
id GenLocated SrcSpanAnnN RdrName
fmap_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
fmap_eqns
    fmap_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
fmap_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
fmap_name AnnFunRhs
forall a. NoAnn a => a
noAnn

    fmap_eqn :: DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
fmap_eqn DataCon
con = (State
   (Infinite RdrName)
   (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
 -> Infinite RdrName
 -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  (Infinite RdrName)
  (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall s a. State s a -> s -> a
evalState Infinite RdrName
bs_RDRs (State
   (Infinite RdrName)
   (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
 -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$
                     HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
fmap_match_ctxt [LPat (GhcPass 'Parsed)
f_Pat] DataCon
con [LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
[LocatedA (HsExpr (GhcPass 'Parsed))
 -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts
      where
        parts :: [LocatedA (HsExpr (GhcPass 'Parsed))
 -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts = FFoldType
  (LocatedA (HsExpr (GhcPass 'Parsed))
   -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> DataCon
-> DerivInstTys
-> [LocatedA (HsExpr (GhcPass 'Parsed))
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (LHsExpr (GhcPass 'Parsed)
   -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
FFoldType
  (LocatedA (HsExpr (GhcPass 'Parsed))
   -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_fmap DataCon
con DerivInstTys
dit

    fmap_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
fmap_eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
fmap_eqn [DataCon]
data_cons

    ft_fmap :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs))
    ft_fmap :: FFoldType
  (LHsExpr (GhcPass 'Parsed)
   -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
ft_fmap = FT { ft_triv :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_triv = \LHsExpr (GhcPass 'Parsed)
x -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr (GhcPass 'Parsed)
x
                   -- fmap f x = x
                 , ft_var :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_var  = \LHsExpr (GhcPass 'Parsed)
x -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
f_Expr LHsExpr (GhcPass 'Parsed)
x
                   -- fmap f x = f x
                 , ft_fun :: (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_fun  = \LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
h LHsExpr (GhcPass 'Parsed)
x -> (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam ((LHsExpr (GhcPass 'Parsed)
  -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
b -> do
                     gg <- LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
b
                     h $ nlHsApp x gg
                   -- fmap f x = \b -> h (x (g b))
                 , ft_tup :: TyCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_tup = ([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [LocatedA (HsExpr (GhcPass 'Parsed))
     -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [LocatedA (HsExpr (GhcPass 'Parsed))
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a.
Monad m =>
([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [a]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [a]
-> LHsExpr (GhcPass 'Parsed)
-> m (LHsExpr (GhcPass 'Parsed))
mkSimpleTupleCase (HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. HsMatchContext fn
CaseAlt)
                   -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                 , ft_ty_app :: Type
-> Type
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_ty_app = \Type
_ Type
arg_ty LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x ->
                     -- If the argument type is a bare occurrence of the
                     -- data type's last type variable, then we can generate
                     -- more efficient code.
                     -- See Note [Avoid unnecessary eta expansion in derived fmap implementations]
                     if Type -> Bool
tcIsTyVarTy Type
arg_ty
                       then LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
fmap_RDR [LHsExpr (GhcPass 'Parsed)
f_Expr,LHsExpr (GhcPass 'Parsed)
x]
                       else do gg <- (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g
                               pure $ nlHsApps fmap_RDR [gg,x]
                   -- fmap f x = fmap g x
                 , ft_forall :: Id
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_forall = \Id
_ LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x
                 , ft_bad_app :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_bad_app = String
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_fmap"
                 , ft_co_var :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_co_var = String
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_fmap" }

    -- See Note [Deriving <$]
    replace_name :: GenLocated SrcSpanAnnN RdrName
replace_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
replace_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    replace_bind :: LHsBind (GhcPass 'Parsed)
replace_bind = Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
2 LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. a -> a
id GenLocated SrcSpanAnnN RdrName
replace_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
replace_eqns
    replace_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
replace_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
replace_name AnnFunRhs
forall a. NoAnn a => a
noAnn

    replace_eqn :: DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
replace_eqn DataCon
con = (State
   (Infinite RdrName)
   (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
 -> Infinite RdrName
 -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  (Infinite RdrName)
  (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall s a. State s a -> s -> a
evalState Infinite RdrName
bs_RDRs (State
   (Infinite RdrName)
   (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
 -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$
        HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
replace_match_ctxt [LPat (GhcPass 'Parsed)
z_Pat] DataCon
con [LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
[LocatedA (HsExpr (GhcPass 'Parsed))
 -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts
      where
        parts :: [LocatedA (HsExpr (GhcPass 'Parsed))
 -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts = FFoldType
  (LocatedA (HsExpr (GhcPass 'Parsed))
   -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> DataCon
-> DerivInstTys
-> [LocatedA (HsExpr (GhcPass 'Parsed))
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (LHsExpr (GhcPass 'Parsed)
   -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
FFoldType
  (LocatedA (HsExpr (GhcPass 'Parsed))
   -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_replace DataCon
con DerivInstTys
dit

    replace_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
replace_eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
replace_eqn [DataCon]
data_cons

    ft_replace :: FFoldType (LHsExpr GhcPs -> State (Infinite RdrName) (LHsExpr GhcPs))
    ft_replace :: FFoldType
  (LHsExpr (GhcPass 'Parsed)
   -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
ft_replace = FT { ft_triv :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_triv = \LHsExpr (GhcPass 'Parsed)
x -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr (GhcPass 'Parsed)
x
                   -- p <$ x = x
                 , ft_var :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_var  = \LHsExpr (GhcPass 'Parsed)
_ -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LHsExpr (GhcPass 'Parsed)
z_Expr
                   -- p <$ _ = p
                 , ft_fun :: (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_fun  = \LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
h LHsExpr (GhcPass 'Parsed)
x -> (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam ((LHsExpr (GhcPass 'Parsed)
  -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
b -> do
                     gg <- LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
b
                     h $ nlHsApp x gg
                   -- p <$ x = \b -> h (x (g b))
                 , ft_tup :: TyCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_tup = ([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [LocatedA (HsExpr (GhcPass 'Parsed))
     -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [LocatedA (HsExpr (GhcPass 'Parsed))
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a.
Monad m =>
([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [a]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [a]
-> LHsExpr (GhcPass 'Parsed)
-> m (LHsExpr (GhcPass 'Parsed))
mkSimpleTupleCase (HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. HsMatchContext fn
CaseAlt)
                   -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
                 , ft_ty_app :: Type
-> Type
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_ty_app = \Type
_ Type
arg_ty LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x ->
                       -- If the argument type is a bare occurrence of the
                       -- data type's last type variable, then we can generate
                       -- more efficient code.
                       -- See [Deriving <$]
                       if Type -> Bool
tcIsTyVarTy Type
arg_ty
                         then LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
replace_RDR [LHsExpr (GhcPass 'Parsed)
z_Expr,LHsExpr (GhcPass 'Parsed)
x]
                         else do gg <- (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g
                                 pure $ nlHsApps fmap_RDR [gg,x]
                   -- p <$ x = fmap (p <$) x
                 , ft_forall :: Id
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_forall = \Id
_ LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
g LHsExpr (GhcPass 'Parsed)
x
                 , ft_bad_app :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_bad_app = String
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_replace"
                 , ft_co_var :: LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
ft_co_var = String
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_replace" }

    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
    match_for_con :: Monad m
                  => HsMatchContextPs
                  -> [LPat GhcPs] -> DataCon
                  -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)]
                  -> m (LMatch GhcPs (LHsExpr GhcPs))
    match_for_con :: forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con HsMatchContextPs
ctxt = HsMatchContextPs
-> (RdrName
    -> [m (LHsExpr (GhcPass 'Parsed))]
    -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *) a.
Monad m =>
HsMatchContextPs
-> (RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> a]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch HsMatchContextPs
ctxt ((RdrName
  -> [m (LHsExpr (GhcPass 'Parsed))]
  -> m (LHsExpr (GhcPass 'Parsed)))
 -> [LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> (RdrName
    -> [m (LHsExpr (GhcPass 'Parsed))]
    -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$
        \RdrName
con_name [m (LHsExpr (GhcPass 'Parsed))]
xsM -> do xs <- [m (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> m [LocatedA (HsExpr (GhcPass 'Parsed))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [m (LHsExpr (GhcPass 'Parsed))]
[m (LocatedA (HsExpr (GhcPass 'Parsed)))]
xsM
                            pure $ nlHsApps con_name xs  -- Con x1 x2 ..

{-
Note [Avoid unnecessary eta expansion in derived fmap implementations]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the sake of simplicity, the algorithm that derived implementations of
fmap used to have a single case that dealt with applications of some type
constructor T (where T is not a tuple type constructor):

  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2

This generated less than optimal code in certain situations, however. Consider
this example:

  data List a = Nil | Cons a (List a) deriving Functor

This would generate the following Functor instance:

  instance Functor List where
    fmap f Nil = Nil
    fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs)

The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application
of `f`. What's worse, this eta expansion actually degrades performance! To see
why, we can trace an invocation of fmap on a small List:

  fmap id     $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil

  Cons (id 0) $ fmap (\y -> id y)
              $ Cons 0 $ Cons 0 $ Cons 0 Nil

  Cons (id 0) $ Cons ((\y -> id y) 0)
              $ fmap (\y' -> (\y -> id y) y')
              $ Cons 0 $ Cons 0 Nil

  Cons (id 0) $ Cons ((\y -> id y) 0)
              $ Cons ((\y' -> (\y -> id y) y') 0)
              $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'')
              $ Cons 0 Nil

  Cons (id 0) $ Cons ((\y -> id y) 0)
              $ Cons ((\y' -> (\y -> id y) y') 0)
              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
              $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''')
              $ Nil

  Cons (id 0) $ Cons ((\y -> id y) 0)
              $ Cons ((\y' -> (\y -> id y) y') 0)
              $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0)
              $ Nil

Notice how the number of lambdas—and hence, the number of closures—one
needs to evaluate grows very quickly. In general, a List with N cons cells will
require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is
what caused the performance issues observed in #7436.

But hold on a second: shouldn't GHC's optimizer be able to eta reduce
`\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not
the case. In general, eta reduction can change the semantics of a program. For
instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so
happens that the fmap implementation above would have the same semantics
regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is
not yet smart enough to realize this (see #17881).

To avoid this quadratic blowup, we add a special case to $fmap that applies
`fmap f` directly:

  $(fmap 'a '(T b1 a) x)  = fmap f x -- when a only occurs directly as the last argument of T
  $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2

With this modified algorithm, the derived Functor List instance becomes:

  instance Functor List where
    fmap f Nil = Nil
    fmap f (Cons x xs) = Cons (f x) (fmap f xs)

No lambdas in sight, just the way we like it.

This special case does not prevent all sources quadratic closure buildup,
however. In this example:

  data PolyList a = PLNil | PLCons a (PolyList (PolyList a))
    deriving Functor

We would derive the following code:

  instance Functor PolyList where
    fmap f PLNil = PLNil
    fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs)

The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way
as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced
to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are
recursively invoking fmap with a different argument (fmap f). Since we end up
paying the price of building a closure either way, we do not extend the special
case in $fmap any further, since it wouldn't buy us anything.

The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by
inspecting the argument type. If the argument type is a bare type variable,
then we can conclude the type variable /must/ be the same as the data type's
last type parameter. We know that this must be the case since there is an
invariant that the argument type in ft_ty_app will always contain the last
type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so
if the argument type is a bare variable, then that must be exactly the last
type parameter.

Note that the ft_ty_app case of ft_replace (which derives implementations of
(<$)) also inspects the argument type to generate more efficient code.
See Note [Deriving <$].

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 inspect the argument type in ft_ty_app
(see Note [FFoldType and functorLikeTraverse]) to distinguish between these
two cases. If the argument type is a bare type variable, then we know that it
must be the same variable as the data type's last type parameter.
This is very similar to a trick that derived fmap implementations
use in their own ft_ty_app case.
See Note [Avoid unnecessary eta expansion in derived fmap implementations],
which explains why checking if the argument type is a bare variable is
the right thing to do.

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 { forall a. FFoldType a -> a
ft_triv    :: a
          -- ^ Does not contain variable
        , forall a. FFoldType a -> a
ft_var     :: a
          -- ^ The variable itself
        , forall a. FFoldType a -> a
ft_co_var  :: a
          -- ^ The variable itself, contravariantly
        , forall a. FFoldType a -> a -> a -> a
ft_fun     :: a -> a -> a
          -- ^ Function type
        , forall a. FFoldType a -> TyCon -> [a] -> a
ft_tup     :: TyCon -> [a] -> a
          -- ^ Tuple type. The @[a]@ is the result of folding over the
          --   arguments of the tuple.
        , forall a. FFoldType a -> Type -> Type -> a -> a
ft_ty_app  :: Type -> Type -> a -> a
          -- ^ Type app, variable only in last argument. The two 'Type's are
          --   the function and argument parts of @fun_ty arg_ty@,
          --   respectively.
        , forall a. FFoldType a -> a
ft_bad_app :: a
          -- ^ Type app, variable other than in last argument
        , forall a. FFoldType a -> Id -> a -> a
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 :: forall a. Id -> FFoldType a -> Type -> a
functorLikeTraverse Id
var (FT { ft_triv :: forall a. FFoldType a -> a
ft_triv = a
caseTrivial,     ft_var :: forall a. FFoldType a -> a
ft_var = a
caseVar
                            , ft_co_var :: forall a. FFoldType a -> a
ft_co_var = a
caseCoVar,     ft_fun :: forall a. FFoldType a -> a -> a -> a
ft_fun = a -> a -> a
caseFun
                            , ft_tup :: forall a. FFoldType a -> TyCon -> [a] -> a
ft_tup = TyCon -> [a] -> a
caseTuple,        ft_ty_app :: forall a. FFoldType a -> Type -> Type -> a -> a
ft_ty_app = Type -> Type -> a -> a
caseTyApp
                            , ft_bad_app :: forall a. FFoldType a -> a
ft_bad_app = a
caseWrongArg, ft_forall :: forall a. FFoldType a -> Id -> a -> a
ft_forall = Id -> a -> a
caseForAll })
                    Type
ty
  = (a, Bool) -> a
forall a b. (a, b) -> a
fst (Bool -> Type -> (a, Bool)
go Bool
False Type
ty)
  where
    go :: Bool        -- Covariant or contravariant context
       -> Type
       -> (a, Bool)   -- (result of type a, does type contain var)

    go :: Bool -> Type -> (a, Bool)
go Bool
co Type
ty | Just Type
ty' <- Type -> Maybe Type
coreView Type
ty = Bool -> Type -> (a, Bool)
go Bool
co Type
ty'
    go Bool
co (TyVarTy    Id
v) | Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
var = (if Bool
co then a
caseCoVar else a
caseVar,Bool
True)
    go Bool
co (FunTy { ft_arg :: Type -> Type
ft_arg = Type
x, ft_res :: Type -> Type
ft_res = Type
y, ft_af :: Type -> FunTyFlag
ft_af = FunTyFlag
af })
       | FunTyFlag -> Bool
isInvisibleFunArg FunTyFlag
af = Bool -> Type -> (a, Bool)
go Bool
co Type
y
       | Bool
xc Bool -> Bool -> Bool
|| Bool
yc             = (a -> a -> a
caseFun a
xr a
yr,Bool
True)
       where (a
xr,Bool
xc) = Bool -> Type -> (a, Bool)
go (Bool -> Bool
not Bool
co) Type
x
             (a
yr,Bool
yc) = Bool -> Type -> (a, Bool)
go Bool
co       Type
y
    go Bool
co (AppTy    Type
x Type
y) | Bool
xc = (a
caseWrongArg,   Bool
True)
                         | Bool
yc = (Type -> Type -> a -> a
caseTyApp Type
x Type
y a
yr, Bool
True)
        where (a
_, Bool
xc) = Bool -> Type -> (a, Bool)
go Bool
co Type
x
              (a
yr,Bool
yc) = Bool -> Type -> (a, Bool)
go Bool
co Type
y
    go Bool
co ty :: Type
ty@(TyConApp TyCon
con [Type]
args)
       | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
xcs)     = (a
caseTrivial, Bool
False)   -- Variable does not occur
       -- At this point we know that xrs, xcs is not empty,
       -- and at least one xr is True
       | TyCon -> Bool
isTupleTyCon TyCon
con = (TyCon -> [a] -> a
caseTuple TyCon
con [a]
xrs, Bool
True)
       | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> [Bool]
forall a. HasCallStack => [a] -> [a]
init [Bool]
xcs)    = (a
caseWrongArg, Bool
True)         -- T (..var..)    ty
       | Just (Type
fun_ty, Type
arg_ty) <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
ty    -- T (..no var..) ty
                          = (Type -> Type -> a -> a
caseTyApp Type
fun_ty Type
arg_ty ([a] -> a
forall a. HasCallStack => [a] -> a
last [a]
xrs), Bool
True)
       | Bool
otherwise        = (a
caseWrongArg, Bool
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 #12399
         ([a]
xrs,[Bool]
xcs) = [(a, Bool)] -> ([a], [Bool])
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
unzip ((Type -> (a, Bool)) -> [Type] -> [(a, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Type -> (a, Bool)
go Bool
co) ([Type] -> [Type]
dropRuntimeRepArgs [Type]
args))
    go Bool
co (ForAllTy (Bndr Id
v ForAllTyFlag
vis) Type
x)
       | ForAllTyFlag -> Bool
isVisibleForAllTyFlag ForAllTyFlag
vis = String -> (a, Bool)
forall a. HasCallStack => String -> a
panic String
"unexpected visible binder"
       | Id
v Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
/= Id
var Bool -> Bool -> Bool
&& Bool
xc            = (Id -> a -> a
caseForAll Id
v a
xr,Bool
True)
       where (a
xr,Bool
xc) = Bool -> Type -> (a, Bool)
go Bool
co Type
x

    go Bool
_ Type
_ = (a
caseTrivial,Bool
False)

-- | Return all syntactic subterms of a 'Type' that are applied to the 'TyVar'
-- argument. This determines what constraints should be inferred for derived
-- 'Functor', 'Foldable', and 'Traversable' instances in "GHC.Tc.Deriv.Infer".
-- For instance, if we have:
--
-- @
-- data Foo a = MkFoo Int a (Maybe a) (Either Int (Maybe a))
-- @
--
-- Then the following would hold:
--
-- * @'deepSubtypesContaining' a Int@ would return @[]@, since @Int@ does not
--   contain the type variable @a@ at all.
--
-- * @'deepSubtypesContaining' a a@ would return @[]@. Although the type @a@
--   contains the type variable @a@, it is not /applied/ to @a@, which is the
--   criterion that 'deepSubtypesContaining' checks for.
--
-- * @'deepSubtypesContaining' a (Maybe a)@ would return @[Maybe]@, as @Maybe@
--   is applied to @a@.
--
-- * @'deepSubtypesContaining' a (Either Int (Maybe a))@ would return
--   @[Either Int, Maybe]@. Both of these types are applied to @a@ through
--   composition.
--
-- As used in "GHC.Tc.Deriv.Infer", the 'Type' argument will always come from
-- 'derivDataConInstArgTys', so it is important that the 'TyVar' comes from
-- 'dataConUnivTyVars' to match. Make sure /not/ to take the 'TyVar' from
-- 'tyConTyVars', as these differ from the 'dataConUnivTyVars' when the data
-- type is a GADT. (See #22167 for what goes wrong if 'tyConTyVars' is used.)
deepSubtypesContaining :: TyVar -> Type -> [TcType]
deepSubtypesContaining :: Id -> Type -> [Type]
deepSubtypesContaining Id
tv
  = Id -> FFoldType [Type] -> Type -> [Type]
forall a. Id -> FFoldType a -> Type -> a
functorLikeTraverse Id
tv
        (FT { ft_triv :: [Type]
ft_triv = []
            , ft_var :: [Type]
ft_var = []
            , ft_fun :: [Type] -> [Type] -> [Type]
ft_fun = [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
(++)
            , ft_tup :: TyCon -> [[Type]] -> [Type]
ft_tup = \TyCon
_ [[Type]]
xs -> [[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
xs
            , ft_ty_app :: Type -> Type -> [Type] -> [Type]
ft_ty_app = \Type
t Type
_ [Type]
ts -> Type
tType -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[Type]
ts
            , ft_bad_app :: [Type]
ft_bad_app = String -> [Type]
forall a. HasCallStack => String -> a
panic String
"in other argument in deepSubtypesContaining"
            , ft_co_var :: [Type]
ft_co_var = String -> [Type]
forall a. HasCallStack => String -> a
panic String
"contravariant in deepSubtypesContaining"
            , ft_forall :: Id -> [Type] -> [Type]
ft_forall = \Id
v [Type]
xs -> (Type -> Bool) -> [Type] -> [Type]
forall a. (a -> Bool) -> [a] -> [a]
filterOut ((Id
v Id -> VarSet -> Bool
`elemVarSet`) (VarSet -> Bool) -> (Type -> VarSet) -> Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VarSet
tyCoVarsOfType) [Type]
xs })


foldDataConArgs :: FFoldType a -> DataCon -> DerivInstTys -> [a]
-- Fold over the arguments of the datacon
foldDataConArgs :: forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType a
ft DataCon
con DerivInstTys
dit
  = (Type -> a) -> [Type] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Type -> a
foldArg (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
con DerivInstTys
dit)
  where
    foldArg :: Type -> a
foldArg
      = case Type -> Maybe Id
getTyVar_maybe ([Type] -> Type
forall a. HasCallStack => [a] -> a
last (HasDebugCallStack => Type -> [Type]
Type -> [Type]
tyConAppArgs (DataCon -> Type
dataConOrigResTy DataCon
con))) of
             Just Id
tv -> Id -> FFoldType a -> Type -> a
forall a. Id -> FFoldType a -> Type -> a
functorLikeTraverse Id
tv FFoldType a
ft
             Maybe Id
Nothing -> a -> Type -> a
forall a b. a -> b -> a
const (FFoldType a -> a
forall a. FFoldType a -> a
ft_triv FFoldType a
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 (Infinite RdrName) (LHsExpr GhcPs))
            -> State (Infinite RdrName) (LHsExpr GhcPs)
-- (mkSimpleLam fn) returns (\x. fn(x))
mkSimpleLam :: (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
lam =
    State (Infinite RdrName) (Infinite RdrName)
forall s. State s s
get State (Infinite RdrName) (Infinite RdrName)
-> (Infinite RdrName
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b.
State (Infinite RdrName) a
-> (a -> State (Infinite RdrName) b) -> State (Infinite RdrName) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (Inf RdrName
n Infinite RdrName
names) -> do
        Infinite RdrName -> State (Infinite RdrName) ()
forall s. s -> State s ()
put Infinite RdrName
names
        body <- LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
lam (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
n)
        return (mkHsLam (noLocA [nlVarPat n]) body)

mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs
             -> State (Infinite RdrName) (LHsExpr GhcPs))
             -> State (Infinite RdrName) (LHsExpr GhcPs)
mkSimpleLam2 :: (LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam2 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
lam =
    State (Infinite RdrName) (Infinite RdrName)
forall s. State s s
get State (Infinite RdrName) (Infinite RdrName)
-> (Infinite RdrName
    -> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State (Infinite RdrName) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b.
State (Infinite RdrName) a
-> (a -> State (Infinite RdrName) b) -> State (Infinite RdrName) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ (RdrName
n1 `Inf` RdrName
n2 `Inf` Infinite RdrName
names) -> do
        Infinite RdrName -> State (Infinite RdrName) ()
forall s. s -> State s ()
put Infinite RdrName
names
        body <- LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
lam (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
n1) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
n2)
        return (mkHsLam (noLocA [nlVarPat n1,nlVarPat n2]) body)

-- "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 => HsMatchContextPs
                 -> (RdrName -> [a] -> m (LHsExpr GhcPs))
                 -> [LPat GhcPs]
                 -> DataCon
                 -> [LHsExpr GhcPs -> a]
                 -> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch :: forall (m :: * -> *) a.
Monad m =>
HsMatchContextPs
-> (RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [LHsExpr (GhcPass 'Parsed) -> a]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch HsMatchContextPs
ctxt RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed))
fold [LPat (GhcPass 'Parsed)]
extra_pats DataCon
con [LHsExpr (GhcPass 'Parsed) -> a]
insides = do
    let con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
    let vars_needed :: [RdrName]
vars_needed = [LocatedA (HsExpr (GhcPass 'Parsed)) -> a]
-> [RdrName] -> [RdrName]
forall b a. [b] -> [a] -> [a]
takeList [LHsExpr (GhcPass 'Parsed) -> a]
[LocatedA (HsExpr (GhcPass 'Parsed)) -> a]
insides [RdrName]
as_RDRList
    let bare_pat :: LPat (GhcPass 'Parsed)
bare_pat = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
con_name [RdrName]
vars_needed
    let pat :: LPat (GhcPass 'Parsed)
pat = if [RdrName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RdrName]
vars_needed
          then LPat (GhcPass 'Parsed)
bare_pat
          else LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat LPat (GhcPass 'Parsed)
bare_pat
    rhs <- RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed))
fold RdrName
con_name
                (((LocatedA (HsExpr (GhcPass 'Parsed)) -> a) -> RdrName -> a)
-> [LocatedA (HsExpr (GhcPass 'Parsed)) -> a] -> [RdrName] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\LocatedA (HsExpr (GhcPass 'Parsed)) -> a
i RdrName
v -> LocatedA (HsExpr (GhcPass 'Parsed)) -> a
i (LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> LocatedA (HsExpr (GhcPass 'Parsed)) -> a
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
v) [LHsExpr (GhcPass 'Parsed) -> a]
[LocatedA (HsExpr (GhcPass 'Parsed)) -> a]
insides [RdrName]
vars_needed)
    return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs 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
                  => HsMatchContextPs
                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]
                                      -> m (LHsExpr GhcPs))
                  -> [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> m (LMatch GhcPs (LHsExpr GhcPs))
mkSimpleConMatch2 :: forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch2 HsMatchContextPs
ctxt LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))
fold [LPat (GhcPass 'Parsed)]
extra_pats DataCon
con [Maybe (LHsExpr (GhcPass 'Parsed))]
insides = do
    let con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
        vars_needed :: [RdrName]
vars_needed = [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> [RdrName] -> [RdrName]
forall b a. [b] -> [a] -> [a]
takeList [Maybe (LHsExpr (GhcPass 'Parsed))]
[Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
insides (Infinite RdrName -> [RdrName]
forall a. Infinite a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Infinite RdrName
as_RDRs)
        pat :: LPat (GhcPass 'Parsed)
pat = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
con_name [RdrName]
vars_needed
        -- Make sure to zip BEFORE invoking catMaybes. We want the variable
        -- indices in each expression to match up with the argument indices
        -- in con_expr (defined below).
        exps :: [LocatedA (HsExpr (GhcPass 'Parsed))]
exps = [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> [LocatedA (HsExpr (GhcPass 'Parsed))])
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> a -> b
$ (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> RdrName -> Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> [RdrName]
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
i RdrName
v -> (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
v) (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
i)
                                   [Maybe (LHsExpr (GhcPass 'Parsed))]
[Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
insides [RdrName]
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 :: [Bool]
argTysTyVarInfo = (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) -> Bool)
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) -> Bool
forall a. Maybe a -> Bool
isJust [Maybe (LHsExpr (GhcPass 'Parsed))]
[Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
insides
        ([LocatedA (HsExpr (GhcPass 'Parsed))]
asWithTyVar, [LocatedA (HsExpr (GhcPass 'Parsed))]
asWithoutTyVar) = [Bool]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> ([LocatedA (HsExpr (GhcPass 'Parsed))],
    [LocatedA (HsExpr (GhcPass 'Parsed))])
forall a. [Bool] -> [a] -> ([a], [a])
partitionByList [Bool]
argTysTyVarInfo (Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. Infinite a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Infinite (LHsExpr (GhcPass 'Parsed))
Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
as_Vars)

        con_expr :: LHsExpr (GhcPass 'Parsed)
con_expr
          | [LocatedA (HsExpr (GhcPass 'Parsed))] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LocatedA (HsExpr (GhcPass 'Parsed))]
asWithTyVar = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
con_name [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
asWithoutTyVar
          | Bool
otherwise =
              let bs :: [RdrName]
bs   = [Bool] -> [RdrName] -> [RdrName]
forall a. [Bool] -> [a] -> [a]
filterByList  [Bool]
argTysTyVarInfo [RdrName]
bs_RDRList
                  vars :: [LocatedA (HsExpr (GhcPass 'Parsed))]
vars = [Bool]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. [Bool] -> [a] -> [a] -> [a]
filterByLists [Bool]
argTysTyVarInfo [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
bs_VarList [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
as_VarList
              in LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA ((RdrName -> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed)))
-> [RdrName] -> [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
RdrName -> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [RdrName]
bs)) (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
con_name [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
vars)

    rhs <- LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))
fold LHsExpr (GhcPass 'Parsed)
con_expr [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
exps
    return $ mkMatch ctxt (noLocA (extra_pats ++ [pat])) rhs 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 :: forall (m :: * -> *) a.
Monad m =>
([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [a]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [a]
-> LHsExpr (GhcPass 'Parsed)
-> m (LHsExpr (GhcPass 'Parsed))
mkSimpleTupleCase [LPat (GhcPass 'Parsed)]
-> DataCon
-> [a]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con TyCon
tc [a]
insides LHsExpr (GhcPass 'Parsed)
x
  = do { let data_con :: DataCon
data_con = TyCon -> DataCon
tyConSingleDataCon TyCon
tc
       ; match <- [LPat (GhcPass 'Parsed)]
-> DataCon
-> [a]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con [] DataCon
data_con [a]
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 -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
-- When the parameter is phantom, we can use foldMap _ _ = mempty
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Foldable_binds :: SrcSpan
-> DerivInstTys -> (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Foldable_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  | Role
Phantom <- [Role] -> Role
forall a. HasCallStack => [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
  = ([LHsBind (GhcPass 'Parsed)
foldMap_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    foldMap_name :: GenLocated SrcSpanAnnN RdrName
foldMap_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
foldMap_RDR
    foldMap_bind :: LHsBind (GhcPass 'Parsed)
foldMap_bind = GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind GenLocated SrcSpanAnnN RdrName
foldMap_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
foldMap_eqns
    foldMap_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
foldMap_eqns = [HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldMap_match_ctxt
                                  ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat])
                                  LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
mempty_Expr]
    foldMap_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldMap_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
foldMap_name AnnFunRhs
forall a. NoAnn a => a
noAnn

gen_Foldable_binds SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                        , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args })
  | [DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons  -- There's no real point producing anything but
                    -- foldMap for a type with no constructors.
  = ([LHsBind (GhcPass 'Parsed)
foldMap_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)

  | Bool
otherwise
  = ([LHsBind (GhcPass 'Parsed)
foldr_bind, LHsBind (GhcPass 'Parsed)
foldMap_bind, LHsBind (GhcPass 'Parsed)
null_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args

    foldr_name :: GenLocated SrcSpanAnnN RdrName
foldr_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
foldable_foldr_RDR

    foldr_bind :: LHsBind (GhcPass 'Parsed)
foldr_bind = GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind (SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
foldable_foldr_RDR) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
eqns
    eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
foldr_eqn [DataCon]
data_cons
    foldr_eqn :: DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
foldr_eqn DataCon
con
      = State
  (Infinite RdrName)
  (GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> Infinite RdrName
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall s a. State s a -> s -> a
evalState (LHsExpr (GhcPass 'Parsed)
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
LHsExpr (GhcPass 'Parsed)
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_foldr LHsExpr (GhcPass 'Parsed)
z_Expr [LPat (GhcPass 'Parsed)
f_Pat,LPat (GhcPass 'Parsed)
z_Pat] DataCon
con ([Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (GenLocated
         SrcSpanAnnA
         (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))))
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts) Infinite RdrName
bs_RDRs
      where
        parts :: State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts = [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([State
    (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
 -> State
      (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))])
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> a -> b
$ FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> DataCon
-> DerivInstTys
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
ft_foldr DataCon
con DerivInstTys
dit
    foldr_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldr_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
foldr_name AnnFunRhs
forall a. NoAnn a => a
noAnn

    foldMap_name :: GenLocated SrcSpanAnnN RdrName
foldMap_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
foldMap_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    foldMap_bind :: LHsBind (GhcPass 'Parsed)
foldMap_bind = Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
2 (LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
mempty_Expr)
                      GenLocated SrcSpanAnnN RdrName
foldMap_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
foldMap_eqns

    foldMap_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
foldMap_eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
foldMap_eqn [DataCon]
data_cons

    foldMap_eqn :: DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
foldMap_eqn DataCon
con
      = State
  (Infinite RdrName)
  (GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> Infinite RdrName
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall s a. State s a -> s -> a
evalState ([LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_foldMap [LPat (GhcPass 'Parsed)
f_Pat] DataCon
con ([Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (GenLocated
         SrcSpanAnnA
         (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))))
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts) Infinite RdrName
bs_RDRs
      where
        parts :: State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts = [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([State
    (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
 -> State
      (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))])
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> a -> b
$ FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> DataCon
-> DerivInstTys
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
ft_foldMap DataCon
con DerivInstTys
dit
    foldMap_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldMap_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
foldMap_name AnnFunRhs
forall a. NoAnn a => a
noAnn

    -- 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 :: forall a. [NullM a] -> Maybe [Maybe a]
convert = (NullM a -> Maybe (Maybe a)) -> [NullM a] -> Maybe [Maybe a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse NullM a -> Maybe (Maybe a)
forall {a}. NullM a -> Maybe (Maybe a)
go where
      go :: NullM a -> Maybe (Maybe a)
go NullM a
IsNull = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just Maybe a
forall a. Maybe a
Nothing
      go NullM a
NotNull = Maybe (Maybe a)
forall a. Maybe a
Nothing
      go (NullM a
a) = Maybe a -> Maybe (Maybe a)
forall a. a -> Maybe a
Just (a -> Maybe a
forall a. a -> Maybe a
Just a
a)

    null_name :: GenLocated SrcSpanAnnN RdrName
null_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
null_RDR
    null_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
null_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
null_name AnnFunRhs
forall a. NoAnn a => a
noAnn
    null_bind :: LHsBind (GhcPass 'Parsed)
null_bind = GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind GenLocated SrcSpanAnnN RdrName
null_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
null_eqns
    null_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
null_eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
null_eqn [DataCon]
data_cons
    null_eqn :: DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
null_eqn DataCon
con
      = (State
   (Infinite RdrName)
   (GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
 -> Infinite RdrName
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> Infinite RdrName
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a b c. (a -> b -> c) -> b -> a -> c
flip State
  (Infinite RdrName)
  (GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> Infinite RdrName
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall s a. State s a -> s -> a
evalState Infinite RdrName
bs_RDRs (State
   (Infinite RdrName)
   (GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a b. (a -> b) -> a -> b
$ do
          parts <- [State
   (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([State
    (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))]
 -> State
      (Infinite RdrName) [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))])
-> [State
      (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> a -> b
$ FFoldType
  (State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> DataCon
-> DerivInstTys
-> [State
      (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed))))
FFoldType
  (State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))))
ft_null DataCon
con DerivInstTys
dit
          case convert parts of
            Maybe [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
Nothing -> GenLocated
  SrcSpanAnnA
  (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
 -> State
      (Infinite RdrName)
      (GenLocated
         SrcSpanAnnA
         (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))))
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
forall a b. (a -> b) -> a -> b
$
              HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> HsLocalBinds (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
null_match_ctxt ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (DataCon -> LPat (GhcPass 'Parsed)
nlWildConPat DataCon
con)])
                LHsExpr (GhcPass 'Parsed)
false_Expr HsLocalBinds (GhcPass 'Parsed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
            Just [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
cp -> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_null [] DataCon
con [Maybe (LHsExpr (GhcPass 'Parsed))]
[Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
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 (Infinite RdrName) (Maybe (LHsExpr GhcPs)))
    ft_foldr :: FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
ft_foldr
      = FT { ft_triv :: State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_triv    = Maybe (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LHsExpr (GhcPass 'Parsed))
forall a. Maybe a
Nothing
             -- foldr f = \x z -> z
           , ft_var :: State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_var     = Maybe (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (LHsExpr (GhcPass 'Parsed))
 -> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
-> Maybe (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed) -> Maybe (LHsExpr (GhcPass 'Parsed))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Parsed)
f_Expr
             -- foldr f = f
           , ft_tup :: TyCon
-> [State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))]
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_tup     = \TyCon
t [State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))]
g -> do
               gg  <- [State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))]
-> State (Infinite RdrName) [Maybe (LHsExpr (GhcPass 'Parsed))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))]
g
               lam <- mkSimpleLam2 $ \LHsExpr (GhcPass 'Parsed)
x LHsExpr (GhcPass 'Parsed)
z ->
                 ([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LHsExpr (GhcPass 'Parsed))]
 -> State
      (Infinite RdrName)
      (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a.
Monad m =>
([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [a]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [a]
-> LHsExpr (GhcPass 'Parsed)
-> m (LHsExpr (GhcPass 'Parsed))
mkSimpleTupleCase (LHsExpr (GhcPass 'Parsed)
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
LHsExpr (GhcPass 'Parsed)
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_foldr LHsExpr (GhcPass 'Parsed)
z) TyCon
t [Maybe (LHsExpr (GhcPass 'Parsed))]
gg LHsExpr (GhcPass 'Parsed)
x
               return (Just lam)
             -- foldr f = (\x z -> case x of ...)
           , ft_ty_app :: Type
-> Type
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_ty_app  = \Type
_ Type
_ State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
g -> do
               gg <- State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
g
               mapM (\LocatedA (HsExpr (GhcPass 'Parsed))
gg' -> (LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam2 ((LHsExpr (GhcPass 'Parsed)
  -> LHsExpr (GhcPass 'Parsed)
  -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
x LHsExpr (GhcPass 'Parsed)
z -> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$
                 IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
foldable_foldr_RDR [LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
gg',LHsExpr (GhcPass 'Parsed)
z,LHsExpr (GhcPass 'Parsed)
x]) gg
             -- foldr f = (\x z -> foldr g z x)
           , ft_forall :: Id
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_forall  = \Id
_ State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
g -> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
g
           , ft_co_var :: State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_co_var  = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_foldr"
           , ft_fun :: State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_fun     = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"function in ft_foldr"
           , ft_bad_app :: State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed)))
ft_bad_app = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_foldr" }

    match_foldr :: Monad m
                => LHsExpr GhcPs
                -> [LPat GhcPs]
                -> DataCon
                -> [Maybe (LHsExpr GhcPs)]
                -> m (LMatch GhcPs (LHsExpr GhcPs))
    match_foldr :: forall (m :: * -> *).
Monad m =>
LHsExpr (GhcPass 'Parsed)
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_foldr LHsExpr (GhcPass 'Parsed)
z = HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch2 HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldr_match_ctxt ((LHsExpr (GhcPass 'Parsed)
  -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
 -> [LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LHsExpr (GhcPass 'Parsed))]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
_ [LHsExpr (GhcPass 'Parsed)]
xs -> LocatedA (HsExpr (GhcPass 'Parsed))
-> m (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkFoldr [LHsExpr (GhcPass 'Parsed)]
xs)
      where
        -- g1 v1 (g2 v2 (.. z))
        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkFoldr :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkFoldr = (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
z

    -- See Note [FFoldType and functorLikeTraverse]
    ft_foldMap :: FFoldType (State (Infinite RdrName) (Maybe (LHsExpr GhcPs)))
    ft_foldMap :: FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
ft_foldMap
      = FT { ft_triv :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_triv = Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. Maybe a
Nothing
             -- foldMap f = \x -> mempty
           , ft_var :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_var  = Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr (GhcPass 'Parsed))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
f_Expr)
             -- foldMap f = f
           , ft_tup :: TyCon
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_tup  = \TyCon
t [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
g -> do
               gg  <- [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
g
               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
               return (Just lam)
             -- foldMap f = \x -> case x of (..,)
           , ft_ty_app :: Type
-> Type
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_ty_app = \Type
_ Type
_ State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g -> (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
foldMap_Expr) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g
             -- foldMap f = foldMap g
           , ft_forall :: Id
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_forall = \Id
_ State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g -> State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g
           , ft_co_var :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_co_var = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_foldMap"
           , ft_fun :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_fun = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"function in ft_foldMap"
           , ft_bad_app :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_bad_app = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_foldMap" }

    match_foldMap :: Monad m
                  => [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> m (LMatch GhcPs (LHsExpr GhcPs))
    match_foldMap :: forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_foldMap = HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch2 HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
foldMap_match_ctxt ((LHsExpr (GhcPass 'Parsed)
  -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
 -> [LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LHsExpr (GhcPass 'Parsed))]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
_ [LHsExpr (GhcPass 'Parsed)]
xs -> LocatedA (HsExpr (GhcPass 'Parsed))
-> m (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkFoldMap [LHsExpr (GhcPass 'Parsed)]
xs)
      where
        -- mappend v1 (mappend v2 ..)
        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkFoldMap :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkFoldMap = LocatedA (HsExpr (GhcPass 'Parsed))
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> LocatedA (HsExpr (GhcPass 'Parsed))
    -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall (f :: * -> *) a.
Foldable f =>
a -> (a -> a -> a) -> f a -> a
foldr1WithDefault LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
mempty_Expr (\LocatedA (HsExpr (GhcPass 'Parsed))
x LocatedA (HsExpr (GhcPass 'Parsed))
y -> IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
mappend_RDR [LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
x,LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
y])

    -- 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 (Infinite RdrName) (NullM (LHsExpr GhcPs)))
    ft_null :: FFoldType
  (State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed))))
ft_null
      = FT { ft_triv :: State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_triv = NullM (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return NullM (LHsExpr (GhcPass 'Parsed))
forall a. NullM a
IsNull
             -- null = \_ -> True
           , ft_var :: State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_var  = NullM (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return NullM (LHsExpr (GhcPass 'Parsed))
forall a. NullM a
NotNull
             -- null = \_ -> False
           , ft_tup :: TyCon
-> [State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))]
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_tup  = \TyCon
t [State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))]
g -> do
               gg  <- [State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))]
-> State (Infinite RdrName) [NullM (LHsExpr (GhcPass 'Parsed))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))]
g
               case convert gg of
                 Maybe [Maybe (LHsExpr (GhcPass 'Parsed))]
Nothing -> NullM (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall a. a -> State (Infinite RdrName) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NullM (LHsExpr (GhcPass 'Parsed))
forall a. NullM a
NotNull
                 Just [Maybe (LHsExpr (GhcPass 'Parsed))]
ggg ->
                   LHsExpr (GhcPass 'Parsed) -> NullM (LHsExpr (GhcPass 'Parsed))
forall a. a -> NullM a
NullM (LHsExpr (GhcPass 'Parsed) -> NullM (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((LHsExpr (GhcPass 'Parsed)
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
mkSimpleLam ((LHsExpr (GhcPass 'Parsed)
  -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
 -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> (LHsExpr (GhcPass 'Parsed)
    -> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ ([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> LHsExpr (GhcPass 'Parsed)
-> State (Infinite RdrName) (LHsExpr (GhcPass 'Parsed))
forall (m :: * -> *) a.
Monad m =>
([LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [a]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> TyCon
-> [a]
-> LHsExpr (GhcPass 'Parsed)
-> m (LHsExpr (GhcPass 'Parsed))
mkSimpleTupleCase [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_null TyCon
t [Maybe (LHsExpr (GhcPass 'Parsed))]
[Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
ggg)
             -- null = \x -> case x of (..,)
           , ft_ty_app :: Type
-> Type
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_ty_app = \Type
_ Type
_ State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
g -> ((NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
  -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
 -> State
      (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
 -> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
    -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
(NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a b.
(a -> b)
-> State (Infinite RdrName) a -> State (Infinite RdrName) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
State
  (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
g ((NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
  -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
 -> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed))))
-> (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
    -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ \NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
nestedResult ->
                              case NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
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
                                NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
NotNull -> LocatedA (HsExpr (GhcPass 'Parsed))
-> NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> NullM a
NullM LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
null_Expr
                                -- This case is unreachable--it will actually be
                                -- caught by ft_triv
                                NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
IsNull -> NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. NullM a
IsNull
                                -- The general case uses (all null),
                                -- (all (all null)), etc.
                                NullM LocatedA (HsExpr (GhcPass 'Parsed))
nestedTest -> LocatedA (HsExpr (GhcPass 'Parsed))
-> NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> NullM a
NullM (LocatedA (HsExpr (GhcPass 'Parsed))
 -> NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> NullM (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$
                                                    LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
all_Expr LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
nestedTest
             -- null fa = null fa, or null fa = all null fa, or null fa = True
           , ft_forall :: Id
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_forall = \Id
_ State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
g -> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
g
           , ft_co_var :: State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_co_var = String
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_null"
           , ft_fun :: State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
-> State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_fun = String
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"function in ft_null"
           , ft_bad_app :: State (Infinite RdrName) (NullM (LHsExpr (GhcPass 'Parsed)))
ft_bad_app = String
-> State
     (Infinite RdrName) (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_null" }

    match_null :: Monad m
               => [LPat GhcPs]
               -> DataCon
               -> [Maybe (LHsExpr GhcPs)]
               -> m (LMatch GhcPs (LHsExpr GhcPs))
    match_null :: forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_null = HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch2 HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. HsMatchContext fn
CaseAlt ((LHsExpr (GhcPass 'Parsed)
  -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
 -> [LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LHsExpr (GhcPass 'Parsed))]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ \LHsExpr (GhcPass 'Parsed)
_ [LHsExpr (GhcPass 'Parsed)]
xs -> LocatedA (HsExpr (GhcPass 'Parsed))
-> m (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkNull [LHsExpr (GhcPass 'Parsed)]
xs)
      where
        -- v1 && v2 && ..
        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkNull :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkNull = LocatedA (HsExpr (GhcPass 'Parsed))
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> LocatedA (HsExpr (GhcPass 'Parsed))
    -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall (f :: * -> *) a.
Foldable f =>
a -> (a -> a -> a) -> f a -> a
foldr1WithDefault LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
true_Expr (\LocatedA (HsExpr (GhcPass 'Parsed))
x LocatedA (HsExpr (GhcPass 'Parsed))
y -> IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
and_RDR [LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
x,LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
y])

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 -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
-- When the argument is phantom, we can use traverse = pure . coerce
-- See Note [Phantom types with Functor, Foldable, and Traversable]
gen_Traversable_binds :: SrcSpan
-> DerivInstTys -> (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Traversable_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  | Role
Phantom <- [Role] -> Role
forall a. HasCallStack => [a] -> a
last (TyCon -> [Role]
tyConRoles TyCon
tycon)
  = ([LHsBind (GhcPass 'Parsed)
traverse_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    traverse_name :: GenLocated SrcSpanAnnN RdrName
traverse_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
traverse_RDR
    traverse_bind :: LHsBind (GhcPass 'Parsed)
traverse_bind = GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind GenLocated SrcSpanAnnN RdrName
traverse_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
traverse_eqns
    traverse_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
traverse_eqns =
        [HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
traverse_match_ctxt
                       ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
z_Pat])
                       (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
pure_RDR [LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
coerce_Expr LHsExpr (GhcPass 'Parsed)
z_Expr])]
    traverse_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
traverse_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
traverse_name AnnFunRhs
forall a. NoAnn a => a
noAnn

gen_Traversable_binds SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                           , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args })
  = ([LHsBind (GhcPass 'Parsed)
traverse_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args

    traverse_name :: GenLocated SrcSpanAnnN RdrName
traverse_name = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc) RdrName
traverse_RDR

    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]
    traverse_bind :: LHsBind (GhcPass 'Parsed)
traverse_bind = Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
2 (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
                                   GenLocated SrcSpanAnnN RdrName
traverse_name [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
traverse_eqns
    traverse_eqns :: [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
traverse_eqns = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
traverse_eqn [DataCon]
data_cons
    traverse_eqn :: DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
traverse_eqn DataCon
con
      = State
  (Infinite RdrName)
  (GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> Infinite RdrName
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
forall s a. State s a -> s -> a
evalState ([LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> State
     (Infinite RdrName)
     (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con [LPat (GhcPass 'Parsed)
f_Pat] DataCon
con ([Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
 -> State
      (Infinite RdrName)
      (GenLocated
         SrcSpanAnnA
         (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))))
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
-> State
     (Infinite RdrName)
     (GenLocated
        SrcSpanAnnA
        (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts) Infinite RdrName
bs_RDRs
      where
        parts :: State
  (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
parts = [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([State
    (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
 -> State
      (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))])
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> a -> b
$ FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> DataCon
-> DerivInstTys
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. FFoldType a -> DataCon -> DerivInstTys -> [a]
foldDataConArgs FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
FFoldType
  (State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))))
ft_trav DataCon
con DerivInstTys
dit
    traverse_match_ctxt :: HsMatchContext (GenLocated SrcSpanAnnN RdrName)
traverse_match_ctxt = GenLocated SrcSpanAnnN RdrName
-> AnnFunRhs -> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> AnnFunRhs -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
traverse_name AnnFunRhs
forall a. NoAnn a => a
noAnn

    -- 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 (Infinite RdrName) (Maybe (LHsExpr GhcPs)))
    ft_trav :: FFoldType
  (State (Infinite RdrName) (Maybe (LHsExpr (GhcPass 'Parsed))))
ft_trav
      = FT { ft_triv :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_triv    = Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. Maybe a
Nothing
             -- traverse f = pure x
           , ft_var :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_var     = Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. a -> State (Infinite RdrName) a
forall (m :: * -> *) a. Monad m => a -> m a
return (LocatedA (HsExpr (GhcPass 'Parsed))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> Maybe a
Just LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
f_Expr)
             -- traverse f = f x
           , ft_tup :: TyCon
-> [State
      (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_tup     = \TyCon
t [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
gs -> do
               gg  <- [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> State
     (Infinite RdrName) [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [State
   (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))]
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 :: Type
-> Type
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_ty_app  = \Type
_ Type
_ State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g -> (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
-> Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
traverse_Expr) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g
             -- traverse f = traverse g
           , ft_forall :: Id
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_forall  = \Id
_ State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g -> State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
g
           , ft_co_var :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_co_var  = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"contravariant in ft_trav"
           , ft_fun :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_fun     = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"function in ft_trav"
           , ft_bad_app :: State
  (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
ft_bad_app = String
-> State
     (Infinite RdrName) (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a. HasCallStack => String -> a
panic String
"in other argument in ft_trav" }

    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
    --                    (g2 a2) <*> ...
    match_for_con :: Monad m
                  => [LPat GhcPs]
                  -> DataCon
                  -> [Maybe (LHsExpr GhcPs)]
                  -> m (LMatch GhcPs (LHsExpr GhcPs))
    match_for_con :: forall (m :: * -> *).
Monad m =>
[LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
match_for_con = HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall (m :: * -> *).
Monad m =>
HsMatchContextPs
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
mkSimpleConMatch2 HsMatchContextPs
HsMatchContext (GenLocated SrcSpanAnnN RdrName)
traverse_match_ctxt ((LHsExpr (GhcPass 'Parsed)
  -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
 -> [LPat (GhcPass 'Parsed)]
 -> DataCon
 -> [Maybe (LHsExpr (GhcPass 'Parsed))]
 -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> (LHsExpr (GhcPass 'Parsed)
    -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)))
-> [LPat (GhcPass 'Parsed)]
-> DataCon
-> [Maybe (LHsExpr (GhcPass 'Parsed))]
-> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$
                                             \LHsExpr (GhcPass 'Parsed)
con [LHsExpr (GhcPass 'Parsed)]
xs -> LocatedA (HsExpr (GhcPass 'Parsed))
-> m (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkApCon LHsExpr (GhcPass 'Parsed)
con [LHsExpr (GhcPass 'Parsed)]
xs)
      where
        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..
        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
        mkApCon :: LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
mkApCon LHsExpr (GhcPass 'Parsed)
con [] = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
pure_RDR [LHsExpr (GhcPass 'Parsed)
con]
        mkApCon LHsExpr (GhcPass 'Parsed)
con [LHsExpr (GhcPass 'Parsed)
x] = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
fmap_RDR [LHsExpr (GhcPass 'Parsed)
con,LHsExpr (GhcPass 'Parsed)
x]
        mkApCon LHsExpr (GhcPass 'Parsed)
con (LHsExpr (GhcPass 'Parsed)
x1:LHsExpr (GhcPass 'Parsed)
x2:[LHsExpr (GhcPass 'Parsed)]
xs) =
            (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(IdGhcP p ~ RdrName, IsPass p) =>
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
appAp (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
liftA2_RDR [LHsExpr (GhcPass 'Parsed)
con,LHsExpr (GhcPass 'Parsed)
x1,LHsExpr (GhcPass 'Parsed)
x2]) [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
xs
          where appAp :: GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> LHsExpr (GhcPass p)
appAp GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
x GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
y = IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass p)
RdrName
ap_RDR [LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
x,LHsExpr (GhcPass p)
GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
y]

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

f_Expr, z_Expr, mempty_Expr, foldMap_Expr,
    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,
    all_Expr, null_Expr :: LHsExpr GhcPs
f_Expr :: LHsExpr (GhcPass 'Parsed)
f_Expr        = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
f_RDR
z_Expr :: LHsExpr (GhcPass 'Parsed)
z_Expr        = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
z_RDR
mempty_Expr :: LHsExpr (GhcPass 'Parsed)
mempty_Expr   = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
mempty_RDR
foldMap_Expr :: LHsExpr (GhcPass 'Parsed)
foldMap_Expr  = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
foldMap_RDR
traverse_Expr :: LHsExpr (GhcPass 'Parsed)
traverse_Expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
traverse_RDR
coerce_Expr :: LHsExpr (GhcPass 'Parsed)
coerce_Expr   = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
coerceId)
pure_Expr :: LHsExpr (GhcPass 'Parsed)
pure_Expr     = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
pure_RDR
true_Expr :: LHsExpr (GhcPass 'Parsed)
true_Expr     = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
true_RDR
false_Expr :: LHsExpr (GhcPass 'Parsed)
false_Expr    = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
false_RDR
all_Expr :: LHsExpr (GhcPass 'Parsed)
all_Expr      = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
all_RDR
null_Expr :: LHsExpr (GhcPass 'Parsed)
null_Expr     = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
null_RDR

f_RDR, z_RDR :: RdrName
f_RDR :: RdrName
f_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"f")
z_RDR :: RdrName
z_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"z")

as_RDRs, bs_RDRs :: Infinite RdrName
as_RDRs :: Infinite RdrName
as_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)) | Int
i <- Int -> Infinite Int
forall a. Enum a => a -> Infinite a
Inf.enumFrom (Int
1::Int) ]
bs_RDRs :: Infinite RdrName
bs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)) | Int
i <- Int -> Infinite Int
forall a. Enum a => a -> Infinite a
Inf.enumFrom (Int
1::Int) ]

as_Vars, bs_Vars :: Infinite (LHsExpr GhcPs)
as_Vars :: Infinite (LHsExpr (GhcPass 'Parsed))
as_Vars = (RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> Infinite a -> Infinite b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Infinite RdrName
as_RDRs
bs_Vars :: Infinite (LHsExpr (GhcPass 'Parsed))
bs_Vars = (RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> Infinite RdrName
-> Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> Infinite a -> Infinite b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar Infinite RdrName
bs_RDRs

as_RDRList, bs_RDRList :: [RdrName]
as_RDRList :: [RdrName]
as_RDRList = Infinite RdrName -> [RdrName]
forall a. Infinite a -> [a]
Inf.toList Infinite RdrName
as_RDRs
bs_RDRList :: [RdrName]
bs_RDRList = Infinite RdrName -> [RdrName]
forall a. Infinite a -> [a]
Inf.toList Infinite RdrName
bs_RDRs

as_VarList, bs_VarList :: [LHsExpr GhcPs]
as_VarList :: [LHsExpr (GhcPass 'Parsed)]
as_VarList = Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. Infinite a -> [a]
Inf.toList Infinite (LHsExpr (GhcPass 'Parsed))
Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
as_Vars
bs_VarList :: [LHsExpr (GhcPass 'Parsed)]
bs_VarList = Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. Infinite a -> [a]
Inf.toList Infinite (LHsExpr (GhcPass 'Parsed))
Infinite (LocatedA (HsExpr (GhcPass 'Parsed)))
bs_Vars

f_Pat, z_Pat :: LPat GhcPs
f_Pat :: LPat (GhcPass 'Parsed)
f_Pat = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
f_RDR
z_Pat :: LPat (GhcPass 'Parsed)
z_Pat = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
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 #10447 for the original discussion on this feature. Also see
https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor
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) and the argument type
              mentions the last type parameter (if it did not, it would fall
              under ft_triv). The first two Type arguments to
              ft_ty_app represent the applied type and argument type,
              respectively.

              Currently, only DeriveFunctor makes use of the argument type.
              It inspects the argument type so that it can generate more
              efficient implementations of fmap
              (see Note [Avoid unnecessary eta expansion in derived fmap implementations])
              and (<$) (see Note [Deriving <$]) in certain cases.

              Note that functions, tuples, and foralls are distinct cases
              and take precedence over 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 GHC.Tc.Deriv.Generics.

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 (#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.
-}