2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[ListSetOps]{Set-like operations on lists}
9 unionLists, minusList, insertList,
12 Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
13 emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C,
14 mkLookupFun, findInList, assocElts,
17 hasNoDups, runs, removeDups, findDupsEq,
18 equivClasses, equivClassesByUniq
22 #include "HsVersions.h"
25 import Unique ( Unique )
26 import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
27 import Util ( isn'tIn, isIn, mapAccumR, sortLe )
29 import Data.List ( partition )
33 %************************************************************************
35 Treating lists as sets
36 Assumes the lists contain no duplicates, but are unordered
38 %************************************************************************
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
46 unionLists :: (Eq a) => [a] -> [a] -> [a]
47 -- Assumes that the arguments contain no duplicates
48 unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
50 minusList :: (Eq a) => [a] -> [a] -> [a]
51 -- Everything in the first list that is not in the second list:
52 minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]
56 %************************************************************************
58 \subsection[Utils-assoc]{Association lists}
60 %************************************************************************
62 Inefficient finite maps based on association lists and equality.
65 type Assoc a b = [(a,b)] -- A finite mapping based on equality and association lists
67 emptyAssoc :: Assoc a b
68 unitAssoc :: a -> b -> Assoc a b
69 assocElts :: Assoc a b -> [(a,b)]
70 assoc :: (Eq a) => String -> Assoc a b -> a -> b
71 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
72 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
73 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
74 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
75 mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c
76 extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b
77 plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b
78 -- combining fn takes (old->new->result)
81 unitAssoc a b = [(a,b)]
84 assocDefaultUsing eq deflt ((k,v) : rest) key
86 | otherwise = assocDefaultUsing eq deflt rest key
88 assocDefaultUsing eq deflt [] key = deflt
90 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
91 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
92 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
98 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
100 mapAssoc f alist = [(key, f val) | (key,val) <- alist]
102 plusAssoc_C combine [] new = new -- Shortcut for common case
103 plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new
105 extendAssoc_C combine old_list (new_key, new_val)
108 go [] = [(new_key, new_val)]
109 go ((old_key, old_val) : old_list)
110 | new_key == old_key = ((old_key, old_val `combine` new_val) : old_list)
111 | otherwise = (old_key, old_val) : go old_list
115 @mkLookupFun eq alist@ is a function which looks up
116 its argument in the association list @alist@, returning a Maybe type.
117 @mkLookupFunDef@ is similar except that it is given a value to return
121 mkLookupFun :: (key -> key -> Bool) -- Equality predicate
122 -> [(key,val)] -- The assoc list
124 -> Maybe val -- The corresponding value
126 mkLookupFun eq alist s
127 = case [a | (s',a) <- alist, s' `eq` s] of
131 findInList :: (a -> Bool) -> [a] -> Maybe a
132 findInList p [] = Nothing
133 findInList p (x:xs) | p x = Just x
134 | otherwise = findInList p xs
138 %************************************************************************
140 \subsection[Utils-dups]{Duplicate-handling}
142 %************************************************************************
145 hasNoDups :: (Eq a) => [a] -> Bool
147 hasNoDups xs = f [] xs
149 f seen_so_far [] = True
150 f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
155 is_elem = isIn "hasNoDups"
159 equivClasses :: (a -> a -> Ordering) -- Comparison
163 equivClasses cmp stuff@[] = []
164 equivClasses cmp stuff@[item] = [stuff]
165 equivClasses cmp items
166 = runs eq (sortLe le items)
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 }
172 The first cases in @equivClasses@ above are just to cut to the point
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.
180 runs :: (a -> a -> Bool) -- Equality
185 runs p (x:xs) = case (span (p x) xs) of
186 (first, rest) -> (x:first) : (runs p rest)
190 removeDups :: (a -> a -> Ordering) -- Comparison function
192 -> ([a], -- List with no duplicates
193 [[a]]) -- List of duplicate groups. One representative from
194 -- each group appears in the first result
196 removeDups cmp [] = ([], [])
197 removeDups cmp [x] = ([x],[])
199 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
202 collect_dups dups_so_far [x] = (dups_so_far, x)
203 collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
205 findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
206 findDupsEq eq [] = []
207 findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
208 | otherwise = (x:eq_xs) : findDupsEq eq neq_xs
210 (eq_xs, neq_xs) = partition (eq x) xs
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
221 -- Hence the use of foldr, plus the reversed-args tack_on below
222 equivClassesByUniq get_uniq xs
223 = eltsUFM (foldr add emptyUFM xs)
225 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
226 tack_on old new = new++old