[commit: ghc] master: Add ListSetOps.removeRedundant (c3b793b)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/c3b793b4cb1850a2aa02de3e428bd4a0d4fcd1d7

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

commit c3b793b4cb1850a2aa02de3e428bd4a0d4fcd1d7
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Aug 2 13:35:13 2011 +0100

    Add ListSetOps.removeRedundant
    
    It's needed in ghc/InteractiveUI, although not in the compiler itself

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

 compiler/utils/ListSetOps.lhs |   21 ++++++++++++++++++++-
 1 files changed, 20 insertions(+), 1 deletions(-)

diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs
index 83334fb..334fb59 100644
--- a/compiler/utils/ListSetOps.lhs
+++ b/compiler/utils/ListSetOps.lhs
@@ -15,8 +15,11 @@ module ListSetOps (
 
         -- Duplicate handling
         hasNoDups, runs, removeDups, findDupsEq,
-        equivClasses, equivClassesByUniq
+        equivClasses, equivClassesByUniq,
 
+	-- Remove redudant elts
+	removeRedundant	   -- Used in the ghc/InteractiveUI, 
+			   -- although not in the compiler itself
    ) where
 
 #include "HsVersions.h"
@@ -208,6 +211,22 @@ findDupsEq _  [] = []
 findDupsEq eq (x:xs) | null eq_xs  = findDupsEq eq xs
                      | otherwise   = (x:eq_xs) : findDupsEq eq neq_xs
     where (eq_xs, neq_xs) = partition (eq x) xs
+
+removeRedundant :: (a -> a -> Bool)   -- True <=> discard the *second* argument
+		-> [a] -> [a]
+-- Remove any element y for which 
+--     another element x is in the list
+-- and (x `subsumes` y)
+-- Preserves order
+removeRedundant subsumes xs
+  = WARN( length xs > 10, text "removeRedundant" <+> int (length xs) )
+          -- This is a quadratic algorithm :-) so warn if the list gets long
+    go [] xs
+  where
+    go acc [] = reverse acc
+    go acc (x:xs) 
+       | any (`subsumes` x) acc = go acc xs
+       | otherwise              = go (x : filterOut (x `subsumes`) acc) xs
 \end{code}