[commit: ghc] wip/T13351: Revise list fusion for and, or, all, any, elem, notElem (#13351) (5abc4f4)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T13351
Link       : http://ghc.haskell.org/trac/ghc/changeset/5abc4f4bdbc5fb6a08eb7e0cf73e7daccbdc084e/ghc

>---------------------------------------------------------------

commit 5abc4f4bdbc5fb6a08eb7e0cf73e7daccbdc084e
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Feb 28 12:20:02 2017 -0800

    Revise list fusion for and, or, all, any, elem, notElem (#13351)
    
    to make sure their list fusion is implemented in terms of foldr (and not
    build directly), with proper writing-back rules.
    
    This ensures that, for example,
    
        c `elem` "!@#$%^&*()"
    
    works without actual list code.
    
    Differential Revision: https://phabricator.haskell.org/D3246


>---------------------------------------------------------------

5abc4f4bdbc5fb6a08eb7e0cf73e7daccbdc084e
 libraries/base/GHC/List.hs          | 52 +++++++++++++++++++++++++++----------
 testsuite/tests/th/TH_Roles2.stderr |  4 +--
 2 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/libraries/base/GHC/List.hs b/libraries/base/GHC/List.hs
index 3eab407..7b6c059 100644
--- a/libraries/base/GHC/List.hs
+++ b/libraries/base/GHC/List.hs
@@ -730,9 +730,13 @@ and []          =  True
 and (x:xs)      =  x && and xs
 {-# NOINLINE [1] and #-}
 
+andFB :: Bool -> Bool -> Bool
+andFB x r = x && r
+{-# NOINLINE [0] andFB #-}
+
 {-# RULES
-"and/build"     forall (g::forall b.(Bool->b->b)->b->b) .
-                and (build g) = g (&&) True
+"and"     [~1] forall xs. and xs = foldr andFB True xs
+"andList"  [1]            foldr andFB True = and
  #-}
 #endif
 
@@ -747,9 +751,13 @@ or []           =  False
 or (x:xs)       =  x || or xs
 {-# NOINLINE [1] or #-}
 
+orFB :: Bool -> Bool -> Bool
+orFB x r = x || r
+{-# NOINLINE [0] orFB #-}
+
 {-# RULES
-"or/build"      forall (g::forall b.(Bool->b->b)->b->b) .
-                or (build g) = g (||) False
+"or"     [~1] forall xs. or xs = foldr orFB False xs
+"orList"  [1]            foldr orFB False = or
  #-}
 #endif
 
@@ -764,12 +772,15 @@ any p                   =  or . map p
 #else
 any _ []        = False
 any p (x:xs)    = p x || any p xs
-
 {-# NOINLINE [1] any #-}
 
+anyFB :: (t -> Bool) -> t -> Bool -> Bool
+anyFB p x r = p x || r
+{-# NOINLINE [0] anyFB #-}
+
 {-# RULES
-"any/build"     forall p (g::forall b.(a->b->b)->b->b) .
-                any p (build g) = g ((||) . p) False
+"any"     [~1] forall p xs. any p xs = foldr (anyFB p) False xs
+"anyList"  [1] forall p.    foldr (anyFB p) False = any p
  #-}
 #endif
 
@@ -783,12 +794,15 @@ all p                   =  and . map p
 #else
 all _ []        =  True
 all p (x:xs)    =  p x && all p xs
-
 {-# NOINLINE [1] all #-}
 
+allFB :: (t -> Bool) -> t -> Bool -> Bool
+allFB p x r = p x && r
+{-# NOINLINE [0] allFB #-}
+
 {-# RULES
-"all/build"     forall p (g::forall b.(a->b->b)->b->b) .
-                all p (build g) = g ((&&) . p) True
+"all"     [~1] forall p xs. all p xs = foldr (allFB p) True xs
+"allList"  [1] forall p.    foldr (allFB p) True = all p
  #-}
 #endif
 
@@ -803,9 +817,14 @@ elem x                  =  any (== x)
 elem _ []       = False
 elem x (y:ys)   = x==y || elem x ys
 {-# NOINLINE [1] elem #-}
+
+elemFB :: Eq a => a -> a -> Bool -> Bool
+elemFB x y r = (x == y) || r
+{-# NOINLINE [0] elemFB #-}
+
 {-# RULES
-"elem/build"    forall x (g :: forall b . Eq a => (a -> b -> b) -> b -> b)
-   . elem x (build g) = g (\ y r -> (x == y) || r) False
+"elem"     [~1] forall x xs. elem x xs = foldr (elemFB x) False xs
+"elemList"  [1] forall x.    foldr (elemFB x) False = elem x
  #-}
 #endif
 
@@ -817,9 +836,14 @@ notElem x               =  all (/= x)
 notElem _ []    =  True
 notElem x (y:ys)=  x /= y && notElem x ys
 {-# NOINLINE [1] notElem #-}
+
+notElemFB :: Eq a => a -> a -> Bool -> Bool
+notElemFB x y r = (x /= y) && r
+{-# NOINLINE [0] notElemFB #-}
+
 {-# RULES
-"notElem/build" forall x (g :: forall b . Eq a => (a -> b -> b) -> b -> b)
-   . notElem x (build g) = g (\ y r -> (x /= y) && r) True
+"notElem"     [~1] forall x xs. notElem x xs = foldr (notElemFB x) False xs
+"notElemList"  [1] forall x.    foldr (notElemFB x) True = notElem x
  #-}
 #endif
 
diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr
index 54841e7..bd2945e 100644
--- a/testsuite/tests/th/TH_Roles2.stderr
+++ b/testsuite/tests/th/TH_Roles2.stderr
@@ -16,8 +16,8 @@ TH_Roles2.$tcT
       TH_Roles2.$trModule
       (GHC.Types.TrNameS "T"#)
       1
-      $krep_a40L
-$krep_a40L [InlPrag=[~]]
+      krep_a4ik
+krep_a4ik [InlPrag=[~]]
   = GHC.Types.KindRepFun
       (GHC.Types.KindRepVar 0)
       (GHC.Types.KindRepTYPE GHC.Types.LiftedRep)