compiler/utils/ListSetOps.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[ListSetOps]{Set-like operations on lists}
   6
   7 \begin{code}
   8 module ListSetOps (
   9         unionLists, minusList, insertList,
  10
  11         -- Association lists
  12         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
  13         emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C,
  14         mkLookupFun, findInList, assocElts,
  15
  16         -- Duplicate handling
  17         hasNoDups, runs, removeDups, findDupsEq,
  18         equivClasses, equivClassesByUniq
  19
  20    ) where
  21
  22 #include "HsVersions.h"
  23
  24 import Outputable
  25 import Unique
  26 import UniqFM
  27 import Util
  28
  29 import Data.List
  30 \end{code}
  31
  32
  33 %************************************************************************
  34 %*                                                                      *
  35         Treating lists as sets
  36         Assumes the lists contain no duplicates, but are unordered
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 \begin{code}
  41 insertList :: Eq a => a -> [a] -> [a]
  42 -- Assumes the arg list contains no dups; guarantees the result has no dups
  43 insertList x xs | isIn "insert" x xs = xs
  44                 | otherwise          = x : xs
  45
  46 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
  47 -- Assumes that the arguments contain no duplicates
  48 unionLists xs ys
  49   = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys)
  50     [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
  51
  52 minusList :: (Eq a) => [a] -> [a] -> [a]
  53 -- Everything in the first list that is not in the second list:
  54 minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]
  55 \end{code}
  56
  57
  58 %************************************************************************
  59 %*                                                                      *
  60 \subsection[Utils-assoc]{Association lists}
  61 %*                                                                      *
  62 %************************************************************************
  63
  64 Inefficient finite maps based on association lists and equality.
  65
  66 \begin{code}
  67 -- A finite mapping based on equality and association lists
  68 type Assoc a b = [(a,b)]
  69
  70 emptyAssoc        :: Assoc a b
  71 unitAssoc         :: a -> b -> Assoc a b
  72 assocElts         :: Assoc a b -> [(a,b)]
  73 assoc             :: (Eq a) => String -> Assoc a b -> a -> b
  74 assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b
  75 assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
  76 assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b
  77 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
  78 mapAssoc          :: (b -> c) -> Assoc a b -> Assoc a c
  79 extendAssoc_C     :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b)     -> Assoc a b
  80 plusAssoc_C       :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b
  81         -- combining fn takes (old->new->result)
  82
  83 emptyAssoc    = []
  84 unitAssoc a b = [(a,b)]
  85 assocElts xs  = xs
  86
  87 assocDefaultUsing _  deflt []             _   = deflt
  88 assocDefaultUsing eq deflt ((k,v) : rest) key
  89   | k `eq` key = v
  90   | otherwise  = assocDefaultUsing eq deflt rest key
  91
  92 assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
  93 assocDefault deflt      list key = assocDefaultUsing (==) deflt list key
  94 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
  95
  96 assocMaybe alist key
  97   = lookup alist
  98   where
  99     lookup []             = Nothing
 100     lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
 101
 102 mapAssoc f alist = [(key, f val) | (key,val) <- alist]
 103
 104 plusAssoc_C _       []  new = new -- Shortcut for common case
 105 plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new
 106
 107 extendAssoc_C combine old_list (new_key, new_val)
 108   = go old_list
 109   where
 110     go [] = [(new_key, new_val)]
 111     go ((old_key, old_val) : old_list)
 112      | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list)
 113      | otherwise          = (old_key, old_val) : go old_list
 114 \end{code}
 115
 116
 117 @mkLookupFun eq alist@ is a function which looks up
 118 its argument in the association list @alist@, returning a Maybe type.
 119 @mkLookupFunDef@ is similar except that it is given a value to return
 120 on failure.
 121
 122 \begin{code}
 123 mkLookupFun :: (key -> key -> Bool)     -- Equality predicate
 124             -> [(key,val)]              -- The assoc list
 125             -> key                      -- The key
 126             -> Maybe val                -- The corresponding value
 127
 128 mkLookupFun eq alist s
 129   = case [a | (s',a) <- alist, s' `eq` s] of
 130       []    -> Nothing
 131       (a:_) -> Just a
 132
 133 findInList :: (a -> Bool) -> [a] -> Maybe a
 134 findInList _ [] = Nothing
 135 findInList p (x:xs) | p x       = Just x
 136                     | otherwise = findInList p xs
 137 \end{code}
 138
 139
 140 %************************************************************************
 141 %*                                                                      *
 142 \subsection[Utils-dups]{Duplicate-handling}
 143 %*                                                                      *
 144 %************************************************************************
 145
 146 \begin{code}
 147 hasNoDups :: (Eq a) => [a] -> Bool
 148
 149 hasNoDups xs = f [] xs
 150   where
 151     f _           []     = True
 152     f seen_so_far (x:xs) = if x `is_elem` seen_so_far
 153                            then False
 154                            else f (x:seen_so_far) xs
 155
 156     is_elem = isIn "hasNoDups"
 157 \end{code}
 158
 159 \begin{code}
 160 equivClasses :: (a -> a -> Ordering) -- Comparison
 161              -> [a]
 162              -> [[a]]
 163
 164 equivClasses _         []  = []
 165 equivClasses _   stuff@[_] = [stuff]
 166 equivClasses cmp items     = runs eq (sortLe le items)
 167   where
 168     eq a b = case cmp a b of { EQ -> True; _ -> False }
 169     le a b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
 170 \end{code}
 171
 172 The first cases in @equivClasses@ above are just to cut to the point
 173 more quickly...
 174
 175 @runs@ groups a list into a list of lists, each sublist being a run of
 176 identical elements of the input list. It is passed a predicate @p@ which
 177 tells when two elements are equal.
 178
 179 \begin{code}
 180 runs :: (a -> a -> Bool) -- Equality
 181      -> [a]
 182      -> [[a]]
 183
 184 runs _ []     = []
 185 runs p (x:xs) = case (span (p x) xs) of
 186                 (first, rest) -> (x:first) : (runs p rest)
 187 \end{code}
 188
 189 \begin{code}
 190 removeDups :: (a -> a -> Ordering) -- Comparison function
 191            -> [a]
 192            -> ([a],     -- List with no duplicates
 193                [[a]])   -- List of duplicate groups.  One representative from
 194                         -- each group appears in the first result
 195
 196 removeDups _   []  = ([], [])
 197 removeDups _   [x] = ([x],[])
 198 removeDups cmp xs
 199   = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
 200     (xs', dups) }
 201   where
 202     collect_dups _           []         = panic "ListSetOps: removeDups"
 203     collect_dups dups_so_far [x]        = (dups_so_far,      x)
 204     collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
 205
 206 findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
 207 findDupsEq _  [] = []
 208 findDupsEq eq (x:xs) | null eq_xs  = findDupsEq eq xs
 209                      | otherwise   = (x:eq_xs) : findDupsEq eq neq_xs
 210     where (eq_xs, neq_xs) = partition (eq x) xs
 211 \end{code}
 212
 213
 214 \begin{code}
 215 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
 216         -- NB: it's *very* important that if we have the input list [a,b,c],
 217         -- where a,b,c all have the same unique, then we get back the list
 218         --      [a,b,c]
 219         -- not
 220         --      [c,b,a]
 221         -- Hence the use of foldr, plus the reversed-args tack_on below
 222 equivClassesByUniq get_uniq xs
 223   = eltsUFM (foldr add emptyUFM xs)
 224   where
 225     add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
 226     tack_on old new = new++old
 227 \end{code}
 228