8078d5603e081a22bf834696e189c649ea1705c2
[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, deleteBys,
12
13 -- Association lists
14 Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
15
16 -- Duplicate handling
17 hasNoDups, removeDups, findDupsEq, insertNoDup,
18 equivClasses,
19
20 -- Indexing
21 getNth
22 ) where
23
24 #include "HsVersions.h"
25
26 import GhcPrelude
27
28 import Outputable
29 import Util
30
31 import Data.List
32 import qualified Data.List.NonEmpty as NE
33 import Data.List.NonEmpty (NonEmpty(..))
34 import qualified Data.Set as S
35
36 getNth :: Outputable a => [a] -> Int -> a
37 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
38 xs !! n
39
40 deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a]
41 -- (deleteBys eq xs ys) returns xs-ys, using the given equality function
42 -- Just like 'Data.List.delete' but with an equality function
43 deleteBys eq xs ys = foldl' (flip (deleteBy eq)) xs ys
44
45 {-
46 ************************************************************************
47 * *
48 Treating lists as sets
49 Assumes the lists contain no duplicates, but are unordered
50 * *
51 ************************************************************************
52 -}
53
54
55 -- | Assumes that the arguments contain no duplicates
56 unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]
57 -- We special case some reasonable common patterns.
58 unionLists xs [] = xs
59 unionLists [] ys = ys
60 unionLists [x] ys
61 | isIn "unionLists" x ys = ys
62 | otherwise = x:ys
63 unionLists xs [y]
64 | isIn "unionLists" y xs = xs
65 | otherwise = y:xs
66 unionLists xs ys
67 = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)
68 [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
69
70 -- | Calculate the set difference of two lists. This is
71 -- /O((m + n) log n)/, where we subtract a list of /n/ elements
72 -- from a list of /m/ elements.
73 --
74 -- Extremely short cases are handled specially:
75 -- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1,
76 -- it takes /O(n)/ time.
77 minusList :: Ord a => [a] -> [a] -> [a]
78 -- There's no point building a set to perform just one lookup, so we handle
79 -- extremely short lists specially. It might actually be better to use
80 -- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5).
81 -- The tipping point will be somewhere in the area of where /m/ and /log n/
82 -- become comparable, but we probably don't want to work too hard on this.
83 minusList [] _ = []
84 minusList xs@[x] ys
85 | x `elem` ys = []
86 | otherwise = xs
87 -- Using an empty set or a singleton would also be silly, so let's not.
88 minusList xs [] = xs
89 minusList xs [y] = filter (/= y) xs
90 -- When each list has at least two elements, we build a set from the
91 -- second argument, allowing us to filter the first argument fairly
92 -- efficiently.
93 minusList xs ys = filter (`S.notMember` yss) xs
94 where
95 yss = S.fromList ys
96
97 {-
98 ************************************************************************
99 * *
100 \subsection[Utils-assoc]{Association lists}
101 * *
102 ************************************************************************
103
104 Inefficient finite maps based on association lists and equality.
105 -}
106
107 -- A finite mapping based on equality and association lists
108 type Assoc a b = [(a,b)]
109
110 assoc :: (Eq a) => String -> Assoc a b -> a -> b
111 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
112 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
113 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
114 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
115
116 assocDefaultUsing _ deflt [] _ = deflt
117 assocDefaultUsing eq deflt ((k,v) : rest) key
118 | k `eq` key = v
119 | otherwise = assocDefaultUsing eq deflt rest key
120
121 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
122 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
123 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
124
125 assocMaybe alist key
126 = lookup alist
127 where
128 lookup [] = Nothing
129 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
130
131 {-
132 ************************************************************************
133 * *
134 \subsection[Utils-dups]{Duplicate-handling}
135 * *
136 ************************************************************************
137 -}
138
139 hasNoDups :: (Eq a) => [a] -> Bool
140
141 hasNoDups xs = f [] xs
142 where
143 f _ [] = True
144 f seen_so_far (x:xs) = if x `is_elem` seen_so_far
145 then False
146 else f (x:seen_so_far) xs
147
148 is_elem = isIn "hasNoDups"
149
150 equivClasses :: (a -> a -> Ordering) -- Comparison
151 -> [a]
152 -> [NonEmpty a]
153
154 equivClasses _ [] = []
155 equivClasses _ [stuff] = [stuff :| []]
156 equivClasses cmp items = NE.groupBy eq (sortBy cmp items)
157 where
158 eq a b = case cmp a b of { EQ -> True; _ -> False }
159
160 removeDups :: (a -> a -> Ordering) -- Comparison function
161 -> [a]
162 -> ([a], -- List with no duplicates
163 [NonEmpty a]) -- List of duplicate groups. One representative
164 -- from each group appears in the first result
165
166 removeDups _ [] = ([], [])
167 removeDups _ [x] = ([x],[])
168 removeDups cmp xs
169 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
170 (xs', dups) }
171 where
172 collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
173 collect_dups dups_so_far (x :| []) = (dups_so_far, x)
174 collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
175
176 findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
177 findDupsEq _ [] = []
178 findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
179 | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs
180 where (eq_xs, neq_xs) = partition (eq x) xs
181
182 -- | \( O(n) \). @'insertNoDup' x xs@ treats @xs@ as a set, inserting @x@ only
183 -- when an equal element couldn't be found in @xs@.
184 insertNoDup :: (Eq a) => a -> [a] -> [a]
185 insertNoDup x set
186 | elem x set = set
187 | otherwise = x:set