Ticket #7436: 0001-Changed-deriving-of-Functor-Foldable-Traversable-to-.patch

File 0001-Changed-deriving-of-Functor-Foldable-Traversable-to-.patch, 19.2 KB (added by twanvl, 3 years ago)

[PATCH] Changed deriving of Functor, Foldable, Traversable to fix #7436. Added foldMap to derived Foldable instance.

  • compiler/prelude/PrelNames.lhs

    From 9f1933a3a7b0e71e652cb409651551280cb355a9 Mon Sep 17 00:00:00 2001
    From: Twan van Laarhoven <[email protected]>
    Date: Fri, 23 Nov 2012 15:03:45 +0100
    Subject: [PATCH] Changed deriving of Functor, Foldable, Traversable to fix #7436. Added foldMap to derived Foldable instance.
    
    The derived instances will no longer eta-expand the function. I.e. instead of
        fmap f (Foo a) = Foo (fmap (\x -> f x) a)
    we now derive
        fmap f (Foo a) = Foo (fmap f a)
    
    Some superflous lambdas are generated as a result. For example
        data X a = X (a,a)
        fmap f (X x) = (\y -> case y of (a,b) -> (f a, f b)) x
    The optimizer should be able to simplify this code, as it is just beta reduction.
    
    The derived Foldable instance now includes foldMap in addition to foldr.
    ---
     compiler/prelude/PrelNames.lhs    |    9 ++-
     compiler/typecheck/TcGenDeriv.lhs |  178 ++++++++++++++++++++++---------------
     2 files changed, 114 insertions(+), 73 deletions(-)
    
    diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
    index 4394309..591b40f 100644
    a b gHC_PRIM, gHC_TYPES, gHC_GENERICS, 
    349349    gHC_MAGIC,
    350350    gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
    351351    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_LIST,
    352     gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE,
     352    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, dATA_MONOID,
    353353    gHC_CONC, gHC_IO, gHC_IO_Exception,
    354354    gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
    355355    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS,
    dATA_EITHER = mkBaseModule (fsLit "Data.Either") 
    377377dATA_STRING     = mkBaseModule (fsLit "Data.String")
    378378dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")
    379379dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")
     380dATA_MONOID     = mkBaseModule (fsLit "Data.Monoid")
    380381gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")
    381382gHC_IO          = mkBaseModule (fsLit "GHC.IO")
    382383gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")
    rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") 
    678679notAssocDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative")
    679680
    680681
    681 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName
     682fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR,
     683    traverse_RDR, mempty_RDR, mappend_RDR :: RdrName
    682684fmap_RDR                = varQual_RDR gHC_BASE (fsLit "fmap")
    683685pure_RDR                = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure")
    684686ap_RDR                  = varQual_RDR cONTROL_APPLICATIVE (fsLit "<*>")
    685687foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")
     688foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
    686689traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
     690mempty_RDR              = varQual_RDR dATA_MONOID         (fsLit "mempty")
     691mappend_RDR             = varQual_RDR dATA_MONOID         (fsLit "mappend")
    687692
    688693----------------------
    689694varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR
  • compiler/typecheck/TcGenDeriv.lhs

    diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
    index 2ae812e..f8c40b3 100644
    a b instance for T is: 
    14441444      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
    14451445      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)
    14461446
    1447   $(fmap 'a 'b)         x  = x     -- when b does not contain a
    1448   $(fmap 'a 'a)         x  =  f x
    1449   $(fmap 'a '(b1,b2))   x  = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
    1450   $(fmap 'a '(T b1 b2)) x  =  fmap $(fmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
    1451   $(fmap 'a '(b -> c))  x  =  \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
     1447  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a
     1448  $(fmap 'a 'a)          =  f
     1449  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
     1450  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2
     1451  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
    14521452
    14531453For functions, the type parameter 'a can occur in a contravariant position,
    14541454which means we need to derive a function like:
    which means we need to derive a function like: 
    14571457
    14581458This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
    14591459
    1460   $(cofmap 'a 'b)         x  = x     -- when b does not contain a
    1461   $(cofmap 'a 'a)         x =  error "type variable in contravariant position"
    1462   $(cofmap 'a '(b1,b2))   x  = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
    1463   $(cofmap 'a '[b])       x  =  map $(cofmap 'a 'b) x
    1464   $(cofmap 'a '(T b1 b2)) x  =  fmap $(cofmap 'a 'b2) x   -- when a only occurs in the last parameter, b2
    1465   $(cofmap 'a '(b -> c))  x  =  \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
     1460  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a
     1461  $(cofmap 'a 'a)          =  error "type variable in contravariant position"
     1462  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
     1463  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)
     1464  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2
     1465  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
    14661466
    14671467\begin{code}
    14681468gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
    gen_Functor_binds loc tycon 
    14721472    data_cons = tyConDataCons tycon
    14731473    fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
    14741474
    1475     fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
     1475    fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
    14761476      where
    1477         parts = foldDataConArgs ft_fmap con
     1477        parts = sequence $ foldDataConArgs ft_fmap con
    14781478
    14791479    eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
    14801480                                           (error_Expr "Void fmap")]
    14811481         | otherwise      = map fmap_eqn data_cons
    14821482
    1483     ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
    1484     -- Tricky higher order type; I can't say I fully understand this code :-(
    1485     ft_fmap = FT { ft_triv = \x -> return x                    -- fmap f x = x
    1486                  , ft_var  = \x -> return (nlHsApp f_Expr x)   -- fmap f x = f x
    1487                  , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
    1488                                                                -- fmap f x = \b -> h (x (g b))
    1489                  , ft_tup = mkSimpleTupleCase match_for_con    -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
    1490                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g      -- fmap f x = fmap g x
    1491                                              return $ nlHsApps fmap_RDR [gg,x]
    1492                  , ft_forall = \_ g  x -> g x
     1483    ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
     1484    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x    -- fmap f = \x -> x
     1485                 , ft_var  = return f_Expr                   -- fmap f = f
     1486                 , ft_fun  = \g h -> do                      -- fmap f = \x b -> h (x (g b))
     1487                                 gg <- g
     1488                                 hh <- h
     1489                                 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
     1490                 , ft_tup = \t gs -> do                      -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
     1491                                 gg <- sequence gs
     1492                                 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
     1493                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g  -- fmap f = fmap g
     1494                 , ft_forall = \_ g -> g
    14931495                 , ft_bad_app = panic "in other argument"
    14941496                 , ft_co_var = panic "contravariant" }
    14951497
     1498    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
     1499    match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
     1500                  -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
    14961501    match_for_con = mkSimpleConMatch $
    1497         \con_name xsM -> do xs <- sequence xsM
    1498                             return (nlHsApps con_name xs)  -- Con (g1 v1) (g2 v2) ..
     1502        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..
    14991503\end{code}
    15001504
    15011505Utility functions related to Functor deriving.
    deepSubtypesContaining tv 
    15641568  = functorLikeTraverse tv
    15651569        (FT { ft_triv = []
    15661570            , ft_var = []
    1567             , ft_fun = (++), ft_tup = \_ xs -> concat xs
     1571            , ft_fun = (++)
     1572            , ft_tup = \_ xs -> concat xs
    15681573            , ft_ty_app = (:)
    15691574            , ft_bad_app = panic "in other argument"
    15701575            , ft_co_var = panic "contravariant"
    mkSimpleLam2 lam = do 
    15981603    return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
    15991604
    16001605-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
    1601 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName]
    1602                  -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName (LHsExpr RdrName))
     1606mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
     1607                 -> [LPat RdrName]
     1608                 -> DataCon
     1609                 -> [LHsExpr RdrName]
     1610                 -> m (LMatch RdrName (LHsExpr RdrName))
    16031611mkSimpleConMatch fold extra_pats con insides = do
    16041612    let con_name = getRdrName con
    16051613    let vars_needed = takeList insides as_RDRs
    16061614    let pat = nlConVarPat con_name vars_needed
    1607     rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
     1615    rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
    16081616    return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
    16091617
    16101618-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
    1611 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a]
    1612                   -> m (LMatch RdrName (LHsExpr RdrName)))
    1613                   -> TupleSort -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
     1619mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
     1620                                 -> m (LMatch RdrName (LHsExpr RdrName)))
     1621                  -> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
    16141622mkSimpleTupleCase match_for_con sort insides x = do
    16151623    let con = tupleCon sort (length insides)
    16161624    match <- match_for_con [] con insides
    Here the derived instance for the type T above is: 
    16361644
    16371645The cases are:
    16381646
    1639   $(foldr 'a 'b)         x z  = z     -- when b does not contain a
    1640   $(foldr 'a 'a)         x z  =  f x z
    1641   $(foldr 'a '(b1,b2))   x z  = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
    1642   $(foldr 'a '(T b1 b2)) x z  =  foldr $(foldr 'a 'b2) x z  -- when a only occurs in the last parameter, b2
     1647  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a
     1648  $(foldr 'a 'a)         =  f
     1649  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
     1650  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2
    16431651
    16441652Note that the arguments to the real foldr function are the wrong way around,
    16451653since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
    since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). 
    16471655\begin{code}
    16481656gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
    16491657gen_Foldable_binds loc tycon
    1650   = (unitBag foldr_bind, emptyBag)
     1658  = (listToBag [foldr_bind, foldMap_bind], emptyBag)
    16511659  where
    16521660    data_cons = tyConDataCons tycon
    16531661
    16541662    foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
    16551663    eqns = map foldr_eqn data_cons
    1656     foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
     1664    foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
    16571665      where
    1658         parts = foldDataConArgs ft_foldr con
    1659 
    1660     ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
    1661     ft_foldr = FT { ft_triv = \_ z -> return z                        -- foldr f z x = z
    1662                   , ft_var  = \x z -> return (nlHsApps f_RDR [x,z])   -- foldr f z x = f x z
    1663                   , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
    1664                   , ft_ty_app = \_ g  x z -> do gg <- mkSimpleLam2 g   -- foldr f z x = foldr (\xx zz -> g xx zz) z x
    1665                                                 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
    1666                   , ft_forall = \_ g  x z -> g x z
    1667                   , ft_co_var = panic "covariant"
    1668                   , ft_fun = panic "function"
     1666        parts = sequence $ foldDataConArgs ft_foldr con
     1667
     1668    foldMap_bind = L loc $ mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
     1669    foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
     1670      where
     1671        parts = sequence $ foldDataConArgs ft_foldMap con
     1672
     1673    ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
     1674    ft_foldr = FT { ft_triv    = mkSimpleLam2 $ \_ z -> return z       -- foldr f = \x z -> z
     1675                  , ft_var     = return f_Expr                         -- foldr f = f
     1676                  , ft_tup     = \t g -> do gg <- sequence g           -- foldr f = (\x z -> case x of ...)
     1677                                            mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
     1678                  , ft_ty_app  = \_ g -> do gg <- g                    -- foldr f = (\x z -> foldr g z x)
     1679                                            mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
     1680                  , ft_forall  = \_ g -> g
     1681                  , ft_co_var  = panic "contravariant"
     1682                  , ft_fun     = panic "function"
    16691683                  , ft_bad_app = panic "in other argument" }
    16701684
    1671     match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
     1685    match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
     1686
     1687    ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
     1688    ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr  -- foldMap f = \x -> mempty
     1689                    , ft_var  = return f_Expr                           -- foldMap f = f
     1690                    , ft_tup  = \t g -> do gg <- sequence g             -- foldMap f = \x -> case x of (..,)
     1691                                           mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
     1692                    , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g    -- foldMap f = foldMap g
     1693                    , ft_forall = \_ g -> g
     1694                    , ft_co_var = panic "contravariant"
     1695                    , ft_fun = panic "function"
     1696                    , ft_bad_app = panic "in other argument" }
     1697   
     1698    match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
     1699        case xs of
     1700            [] -> mempty_Expr
     1701            xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
     1702
    16721703\end{code}
    16731704
    16741705
    Again, Traversable is much like Functor and Foldable. 
    16841715
    16851716The cases are:
    16861717
    1687   $(traverse 'a 'b)         x  =  pure x     -- when b does not contain a
    1688   $(traverse 'a 'a)         x  =  f x
    1689   $(traverse 'a '(b1,b2))   x  = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
    1690   $(traverse 'a '(T b1 b2)) x  =  traverse $(traverse 'a 'b2) x  -- when a only occurs in the last parameter, b2
     1718  $(traverse 'a 'b)          =  pure     -- when b does not contain a
     1719  $(traverse 'a 'a)          =  f
     1720  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
     1721  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2
    16911722
    16921723Note that the generated code is not as efficient as it could be. For instance:
    16931724
    gen_Traversable_binds loc tycon 
    17051736
    17061737    traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
    17071738    eqns = map traverse_eqn data_cons
    1708     traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
     1739    traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
    17091740      where
    1710         parts = foldDataConArgs ft_trav con
    1711 
    1712 
    1713     ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
    1714     ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])   -- traverse f x = pure x
    1715                  , ft_var = \x -> return (nlHsApps f_RDR [x])       -- travese f x = f x
    1716                  , ft_tup = mkSimpleTupleCase match_for_con         -- travese f x z = case x of (a1,a2,..) ->
    1717                                                                     --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
    1718                  , ft_ty_app = \_ g  x -> do gg <- mkSimpleLam g    -- travese f x = travese (\xx -> g xx) x
    1719                                              return $ nlHsApps traverse_RDR [gg,x]
    1720                  , ft_forall = \_ g  x -> g x
    1721                  , ft_co_var = panic "covariant"
    1722                  , ft_fun = panic "function"
     1741        parts = sequence $ foldDataConArgs ft_trav con
     1742
     1743
     1744    ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
     1745    ft_trav = FT { ft_triv    = return pure_Expr                  -- traverse f = pure x
     1746                 , ft_var     = return f_Expr                     -- traverse f = f x
     1747                 , ft_tup     = \t gs -> do                       -- traverse f = \x -> case x of (a1,a2,..) ->
     1748                                    gg <- sequence gs             --                   (,,) <$> g1 a1 <*> g2 a2 <*> ..
     1749                                    mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
     1750                 , ft_ty_app  = \_ g -> nlHsApp traverse_Expr <$> g  -- traverse f = travese g
     1751                 , ft_forall  = \_ g -> g
     1752                 , ft_co_var  = panic "contravariant"
     1753                 , ft_fun     = panic "function"
    17231754                 , ft_bad_app = panic "in other argument" }
    17241755
     1756    -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
    17251757    match_for_con = mkSimpleConMatch $
    1726         \con_name xsM -> do xs <- sequence xsM
    1727                             return (mkApCon (nlHsVar con_name) xs)
     1758        \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
    17281759
    17291760    -- ((Con <$> x1) <*> x2) <*> ..
    17301761    mkApCon con []     = nlHsApps pure_RDR [con]
    bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. 
    20302061cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
    20312062
    20322063a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
    2033     false_Expr, true_Expr :: LHsExpr RdrName
     2064    false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
    20342065a_Expr          = nlHsVar a_RDR
    20352066-- b_Expr       = nlHsVar b_RDR
    20362067c_Expr          = nlHsVar c_RDR
    eqTag_Expr = nlHsVar eqTag_RDR 
    20412072gtTag_Expr      = nlHsVar gtTag_RDR
    20422073false_Expr      = nlHsVar false_RDR
    20432074true_Expr       = nlHsVar true_RDR
     2075fmap_Expr       = nlHsVar fmap_RDR
     2076pure_Expr       = nlHsVar pure_RDR
     2077mempty_Expr     = nlHsVar mempty_RDR
     2078foldMap_Expr    = nlHsVar foldMap_RDR
     2079traverse_Expr   = nlHsVar traverse_RDR
    20442080
    20452081a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
    20462082a_Pat           = nlVarPat a_RDR