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 <[email protected]> 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} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
