Ticket #7436: 0001ChangedderivingofFunctorFoldableTraversableto.patch
File 0001ChangedderivingofFunctorFoldableTraversableto.patch, 19.2 KB (added by twanvl, 3 years ago) 


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 etaexpand 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, 349 349 gHC_MAGIC, 350 350 gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, 351 351 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, 353 353 gHC_CONC, gHC_IO, gHC_IO_Exception, 354 354 gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, 355 355 gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, … … dATA_EITHER = mkBaseModule (fsLit "Data.Either") 377 377 dATA_STRING = mkBaseModule (fsLit "Data.String") 378 378 dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") 379 379 dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") 380 dATA_MONOID = mkBaseModule (fsLit "Data.Monoid") 380 381 gHC_CONC = mkBaseModule (fsLit "GHC.Conc") 381 382 gHC_IO = mkBaseModule (fsLit "GHC.IO") 382 383 gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") … … rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") 678 679 notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") 679 680 680 681 681 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName 682 fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, foldMap_RDR, 683 traverse_RDR, mempty_RDR, mappend_RDR :: RdrName 682 684 fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") 683 685 pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") 684 686 ap_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "<*>") 685 687 foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") 688 foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") 686 689 traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") 690 mempty_RDR = varQual_RDR dATA_MONOID (fsLit "mempty") 691 mappend_RDR = varQual_RDR dATA_MONOID (fsLit "mappend") 687 692 688 693  689 694 varQual_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: 1444 1444 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) 1445 1445 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) 1446 1446 1447 $(fmap 'a 'b) x =x  when b does not contain a1448 $(fmap 'a 'a) x = f x1449 $(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, b21451 $(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)) 1452 1452 1453 1453 For functions, the type parameter 'a can occur in a contravariant position, 1454 1454 which means we need to derive a function like: … … which means we need to derive a function like: 1457 1457 1458 1458 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case: 1459 1459 1460 $(cofmap 'a 'b) x =x  when b does not contain a1461 $(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) x1464 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x when a only occurs in the last parameter, b21465 $(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)) 1466 1466 1467 1467 \begin{code} 1468 1468 gen_Functor_binds :: SrcSpan > TyCon > (LHsBinds RdrName, BagDerivStuff) … … gen_Functor_binds loc tycon 1472 1472 data_cons = tyConDataCons tycon 1473 1473 fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns 1474 1474 1475 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs1475 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs 1476 1476 where 1477 parts = foldDataConArgs ft_fmap con1477 parts = sequence $ foldDataConArgs ft_fmap con 1478 1478 1479 1479 eqns  null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat] 1480 1480 (error_Expr "Void fmap")] 1481 1481  otherwise = map fmap_eqn data_cons 1482 1482 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 1493 1495 , ft_bad_app = panic "in other argument" 1494 1496 , ft_co_var = panic "contravariant" } 1495 1497 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)) 1496 1501 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 .. 1499 1503 \end{code} 1500 1504 1501 1505 Utility functions related to Functor deriving. … … deepSubtypesContaining tv 1564 1568 = functorLikeTraverse tv 1565 1569 (FT { ft_triv = [] 1566 1570 , ft_var = [] 1567 , ft_fun = (++), ft_tup = \_ xs > concat xs 1571 , ft_fun = (++) 1572 , ft_tup = \_ xs > concat xs 1568 1573 , ft_ty_app = (:) 1569 1574 , ft_bad_app = panic "in other argument" 1570 1575 , ft_co_var = panic "contravariant" … … mkSimpleLam2 lam = do 1598 1603 return (mkHsLam [nlVarPat n1,nlVarPat n2] body) 1599 1604 1600 1605  "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)) 1606 mkSimpleConMatch :: Monad m => (RdrName > [LHsExpr RdrName] > m (LHsExpr RdrName)) 1607 > [LPat RdrName] 1608 > DataCon 1609 > [LHsExpr RdrName] 1610 > m (LMatch RdrName (LHsExpr RdrName)) 1603 1611 mkSimpleConMatch fold extra_pats con insides = do 1604 1612 let con_name = getRdrName con 1605 1613 let vars_needed = takeList insides as_RDRs 1606 1614 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)) 1608 1616 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds 1609 1617 1610 1618  "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)1619 mkSimpleTupleCase :: Monad m => ([LPat RdrName] > DataCon > [a] 1620 > m (LMatch RdrName (LHsExpr RdrName))) 1621 > TupleSort > [a] > LHsExpr RdrName > m (LHsExpr RdrName) 1614 1622 mkSimpleTupleCase match_for_con sort insides x = do 1615 1623 let con = tupleCon sort (length insides) 1616 1624 match < match_for_con [] con insides … … Here the derived instance for the type T above is: 1636 1644 1637 1645 The cases are: 1638 1646 1639 $(foldr 'a 'b) x z =z  when b does not contain a1640 $(foldr 'a 'a) x z = f x z1641 $(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, b21647 $(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 1643 1651 1644 1652 Note that the arguments to the real foldr function are the wrong way around, 1645 1653 since (f :: a > b > b), while (foldr f :: b > t a > b). … … since (f :: a > b > b), while (foldr f :: b > t a > b). 1647 1655 \begin{code} 1648 1656 gen_Foldable_binds :: SrcSpan > TyCon > (LHsBinds RdrName, BagDerivStuff) 1649 1657 gen_Foldable_binds loc tycon 1650 = ( unitBag foldr_bind, emptyBag)1658 = (listToBag [foldr_bind, foldMap_bind], emptyBag) 1651 1659 where 1652 1660 data_cons = tyConDataCons tycon 1653 1661 1654 1662 foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns 1655 1663 eqns = map foldr_eqn data_cons 1656 foldr_eqn con = evalState (match_fo r_con z_Expr [f_Pat,z_Pat] conparts) bs_RDRs1664 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs 1657 1665 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" 1669 1683 , ft_bad_app = panic "in other argument" } 1670 1684 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 1672 1703 \end{code} 1673 1704 1674 1705 … … Again, Traversable is much like Functor and Foldable. 1684 1715 1685 1716 The cases are: 1686 1717 1687 $(traverse 'a 'b) x = pure x when b does not contain a1688 $(traverse 'a 'a) x = f x1689 $(traverse 'a '(b1,b2)) x =case x of (x1,x2) > (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x21690 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x when a only occurs in the last parameter, b21718 $(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 1691 1722 1692 1723 Note that the generated code is not as efficient as it could be. For instance: 1693 1724 … … gen_Traversable_binds loc tycon 1705 1736 1706 1737 traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns 1707 1738 eqns = map traverse_eqn data_cons 1708 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs1739 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs 1709 1740 where 1710 parts = foldDataConArgs ft_trav con1711 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 x1715 , ft_var = \x > return (nlHsApps f_RDR [x])  travese f x= f x1716 , ft_tup = mkSimpleTupleCase match_for_con  travese f x z =case x of (a1,a2,..) >1717 1718 , ft_ty_app = \_ g x > do gg < mkSimpleLam g  travese f x = travese (\xx > g xx) x1719 return $ nlHsApps traverse_RDR [gg,x]1720 , ft_forall = \_ g x > g x1721 , 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" 1723 1754 , ft_bad_app = panic "in other argument" } 1724 1755 1756  Con a1 a2 ... > Con <$> g1 a1 <*> g2 a2 <*> ... 1725 1757 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 1728 1759 1729 1760  ((Con <$> x1) <*> x2) <*> .. 1730 1761 mkApCon con [] = nlHsApps pure_RDR [con] … … bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i))  i < [(1::Int) .. 2030 2061 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i))  i < [(1::Int) .. ] ] 2031 2062 2032 2063 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, 2033 false_Expr, true_Expr :: LHsExpr RdrName2064 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName 2034 2065 a_Expr = nlHsVar a_RDR 2035 2066  b_Expr = nlHsVar b_RDR 2036 2067 c_Expr = nlHsVar c_RDR … … eqTag_Expr = nlHsVar eqTag_RDR 2041 2072 gtTag_Expr = nlHsVar gtTag_RDR 2042 2073 false_Expr = nlHsVar false_RDR 2043 2074 true_Expr = nlHsVar true_RDR 2075 fmap_Expr = nlHsVar fmap_RDR 2076 pure_Expr = nlHsVar pure_RDR 2077 mempty_Expr = nlHsVar mempty_RDR 2078 foldMap_Expr = nlHsVar foldMap_RDR 2079 traverse_Expr = nlHsVar traverse_RDR 2044 2080 2045 2081 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName 2046 2082 a_Pat = nlVarPat a_RDR