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