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