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, 2 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