ghc/compiler/utils/ListSetOps.lhs

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