Package environments
[ghc.git] / compiler / utils / ListSetOps.hs
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
8 {-# LANGUAGE CPP #-}
9
10 module ListSetOps (
11 unionLists, minusList, insertList,
12
13 -- Association lists
14 Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
15
16 -- Duplicate handling
17 hasNoDups, runs, removeDups, findDupsEq,
18 equivClasses, equivClassesByUniq,
19
20 -- Indexing
21 getNth
22 ) where
23
24 #include "HsVersions.h"
25
26 import Outputable
27 import Unique
28 import UniqFM
29 import Util
30
31 import Data.List
32
33 {-
34 ---------
35 #ifndef DEBUG
36 getNth :: [a] -> Int -> a
37 getNth xs n = xs !! n
38 #else
39 getNth :: Outputable a => [a] -> Int -> a
40 getNth xs n = ASSERT2( xs `lengthAtLeast` n, ppr n $$ ppr xs )
41 xs !! n
42 #endif
43 ----------
44 -}
45
46 getNth :: Outputable a => [a] -> Int -> a
47 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
48 xs !! n
49
50 {-
51 ************************************************************************
52 * *
53 Treating lists as sets
54 Assumes the lists contain no duplicates, but are unordered
55 * *
56 ************************************************************************
57 -}
58
59 insertList :: Eq a => a -> [a] -> [a]
60 -- Assumes the arg list contains no dups; guarantees the result has no dups
61 insertList x xs | isIn "insert" x xs = xs
62 | otherwise = x : xs
63
64 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
65 -- Assumes that the arguments contain no duplicates
66 unionLists xs ys
67 = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys)
68 [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
69
70 minusList :: (Eq a) => [a] -> [a] -> [a]
71 -- Everything in the first list that is not in the second list:
72 minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]
73
74 {-
75 ************************************************************************
76 * *
77 \subsection[Utils-assoc]{Association lists}
78 * *
79 ************************************************************************
80
81 Inefficient finite maps based on association lists and equality.
82 -}
83
84 -- A finite mapping based on equality and association lists
85 type Assoc a b = [(a,b)]
86
87 assoc :: (Eq a) => String -> Assoc a b -> a -> b
88 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
89 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
90 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
91 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
92
93 assocDefaultUsing _ deflt [] _ = deflt
94 assocDefaultUsing eq deflt ((k,v) : rest) key
95 | k `eq` key = v
96 | otherwise = assocDefaultUsing eq deflt rest key
97
98 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
99 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
100 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
101
102 assocMaybe alist key
103 = lookup alist
104 where
105 lookup [] = Nothing
106 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
107
108 {-
109 ************************************************************************
110 * *
111 \subsection[Utils-dups]{Duplicate-handling}
112 * *
113 ************************************************************************
114 -}
115
116 hasNoDups :: (Eq a) => [a] -> Bool
117
118 hasNoDups xs = f [] xs
119 where
120 f _ [] = True
121 f seen_so_far (x:xs) = if x `is_elem` seen_so_far
122 then False
123 else f (x:seen_so_far) xs
124
125 is_elem = isIn "hasNoDups"
126
127 equivClasses :: (a -> a -> Ordering) -- Comparison
128 -> [a]
129 -> [[a]]
130
131 equivClasses _ [] = []
132 equivClasses _ stuff@[_] = [stuff]
133 equivClasses cmp items = runs eq (sortBy cmp items)
134 where
135 eq a b = case cmp a b of { EQ -> True; _ -> False }
136
137 {-
138 The first cases in @equivClasses@ above are just to cut to the point
139 more quickly...
140
141 @runs@ groups a list into a list of lists, each sublist being a run of
142 identical elements of the input list. It is passed a predicate @p@ which
143 tells when two elements are equal.
144 -}
145
146 runs :: (a -> a -> Bool) -- Equality
147 -> [a]
148 -> [[a]]
149
150 runs _ [] = []
151 runs p (x:xs) = case (span (p x) xs) of
152 (first, rest) -> (x:first) : (runs p rest)
153
154 removeDups :: (a -> a -> Ordering) -- Comparison function
155 -> [a]
156 -> ([a], -- List with no duplicates
157 [[a]]) -- List of duplicate groups. One representative from
158 -- each group appears in the first result
159
160 removeDups _ [] = ([], [])
161 removeDups _ [x] = ([x],[])
162 removeDups cmp xs
163 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
164 (xs', dups) }
165 where
166 collect_dups _ [] = panic "ListSetOps: removeDups"
167 collect_dups dups_so_far [x] = (dups_so_far, x)
168 collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
169
170 findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
171 findDupsEq _ [] = []
172 findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
173 | otherwise = (x:eq_xs) : findDupsEq eq neq_xs
174 where (eq_xs, neq_xs) = partition (eq x) xs
175
176 equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
177 -- NB: it's *very* important that if we have the input list [a,b,c],
178 -- where a,b,c all have the same unique, then we get back the list
179 -- [a,b,c]
180 -- not
181 -- [c,b,a]
182 -- Hence the use of foldr, plus the reversed-args tack_on below
183 equivClassesByUniq get_uniq xs
184 = eltsUFM (foldr add emptyUFM xs)
185 where
186 add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
187 tack_on old new = new++old