never executed always true always false
1 {-# LANGUAGE CPP #-}
2
3 {-
4 (c) The University of Glasgow 2006
5 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6
7 -}
8
9
10
11 -- | Set-like operations on lists
12 --
13 -- Avoid using them as much as possible
14 module GHC.Data.List.SetOps (
15 unionLists, minusList,
16
17 -- Association lists
18 Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
19
20 -- Duplicate handling
21 hasNoDups, removeDups, nubOrdBy, findDupsEq,
22 equivClasses,
23
24 -- Indexing
25 getNth,
26
27 -- Membership
28 isIn, isn'tIn,
29 ) where
30
31 import GHC.Prelude
32
33 import GHC.Utils.Outputable
34 import GHC.Utils.Panic
35 import GHC.Utils.Misc
36 import GHC.Utils.Trace
37
38 import qualified Data.List as L
39 import qualified Data.List.NonEmpty as NE
40 import Data.List.NonEmpty (NonEmpty(..))
41 import qualified Data.Set as S
42
43 getNth :: Outputable a => [a] -> Int -> a
44 getNth xs n = assertPpr (xs `lengthExceeds` n) (ppr n $$ ppr xs) $
45 xs !! n
46
47 {-
48 ************************************************************************
49 * *
50 Treating lists as sets
51 Assumes the lists contain no duplicates, but are unordered
52 * *
53 ************************************************************************
54 -}
55
56
57 -- | Assumes that the arguments contain no duplicates
58 unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]
59 -- We special case some reasonable common patterns.
60 unionLists xs [] = xs
61 unionLists [] ys = ys
62 unionLists [x] ys
63 | isIn "unionLists" x ys = ys
64 | otherwise = x:ys
65 unionLists xs [y]
66 | isIn "unionLists" y xs = xs
67 | otherwise = y:xs
68 unionLists xs ys
69 = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) (ppr xs $$ ppr ys) $
70 [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
71
72 -- | Calculate the set difference of two lists. This is
73 -- /O((m + n) log n)/, where we subtract a list of /n/ elements
74 -- from a list of /m/ elements.
75 --
76 -- Extremely short cases are handled specially:
77 -- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1,
78 -- it takes /O(n)/ time.
79 minusList :: Ord a => [a] -> [a] -> [a]
80 -- There's no point building a set to perform just one lookup, so we handle
81 -- extremely short lists specially. It might actually be better to use
82 -- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5).
83 -- The tipping point will be somewhere in the area of where /m/ and /log n/
84 -- become comparable, but we probably don't want to work too hard on this.
85 minusList [] _ = []
86 minusList xs@[x] ys
87 | x `elem` ys = []
88 | otherwise = xs
89 -- Using an empty set or a singleton would also be silly, so let's not.
90 minusList xs [] = xs
91 minusList xs [y] = filter (/= y) xs
92 -- When each list has at least two elements, we build a set from the
93 -- second argument, allowing us to filter the first argument fairly
94 -- efficiently.
95 minusList xs ys = filter (`S.notMember` yss) xs
96 where
97 yss = S.fromList ys
98
99 {-
100 ************************************************************************
101 * *
102 \subsection[Utils-assoc]{Association lists}
103 * *
104 ************************************************************************
105
106 Inefficient finite maps based on association lists and equality.
107 -}
108
109 -- | A finite mapping based on equality and association lists.
110 type Assoc a b = [(a,b)]
111
112 assoc :: (Eq a) => String -> Assoc a b -> a -> b
113 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
114 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
115 -- | Lookup key, fail gracefully using Nothing if not found.
116 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
117 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
118
119 assocDefaultUsing _ deflt [] _ = deflt
120 assocDefaultUsing eq deflt ((k,v) : rest) key
121 | k `eq` key = v
122 | otherwise = assocDefaultUsing eq deflt rest key
123
124 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
125 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
126 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
127
128 assocMaybe alist key
129 = lookup alist
130 where
131 lookup [] = Nothing
132 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
133
134 {-
135 ************************************************************************
136 * *
137 \subsection[Utils-dups]{Duplicate-handling}
138 * *
139 ************************************************************************
140 -}
141
142 hasNoDups :: (Eq a) => [a] -> Bool
143
144 hasNoDups xs = f [] xs
145 where
146 f _ [] = True
147 f seen_so_far (x:xs) = if x `is_elem` seen_so_far
148 then False
149 else f (x:seen_so_far) xs
150
151 is_elem = isIn "hasNoDups"
152
153 equivClasses :: (a -> a -> Ordering) -- Comparison
154 -> [a]
155 -> [NonEmpty a]
156
157 equivClasses _ [] = []
158 equivClasses _ [stuff] = [stuff :| []]
159 equivClasses cmp items = NE.groupBy eq (L.sortBy cmp items)
160 where
161 eq a b = case cmp a b of { EQ -> True; _ -> False }
162
163 -- | Remove the duplicates from a list using the provided
164 -- comparison function.
165 --
166 -- Returns the list without duplicates, and accumulates
167 -- all the duplicates in the second component of its result.
168 removeDups :: (a -> a -> Ordering) -- Comparison function
169 -> [a]
170 -> ([a], -- List with no duplicates
171 [NonEmpty a]) -- List of duplicate groups. One representative
172 -- from each group appears in the first result
173
174 removeDups _ [] = ([], [])
175 removeDups _ [x] = ([x],[])
176 removeDups cmp xs
177 = case L.mapAccumR collect_dups [] (equivClasses cmp xs) of { (dups, xs') ->
178 (xs', dups) }
179 where
180 collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
181 collect_dups dups_so_far (x :| []) = (dups_so_far, x)
182 collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
183
184 -- | Remove the duplicates from a list using the provided
185 -- comparison function.
186 nubOrdBy :: (a -> a -> Ordering) -> [a] -> [a]
187 nubOrdBy cmp xs = fst (removeDups cmp xs)
188
189 findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
190 findDupsEq _ [] = []
191 findDupsEq eq (x:xs) | L.null eq_xs = findDupsEq eq xs
192 | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs
193 where (eq_xs, neq_xs) = L.partition (eq x) xs
194
195 -- Debugging/specialising versions of \tr{elem} and \tr{notElem}
196
197 # if !defined(DEBUG)
198 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
199 isIn _msg x ys = x `elem` ys
200 isn'tIn _msg x ys = x `notElem` ys
201
202 # else /* DEBUG */
203 isIn, isn'tIn :: (HasDebugCallStack, Eq a) => String -> a -> [a] -> Bool
204 isIn msg x ys
205 = elem100 0 x ys
206 where
207 elem100 :: Eq a => Int -> a -> [a] -> Bool
208 elem100 _ _ [] = False
209 elem100 i x (y:ys)
210 | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
211 | otherwise = x == y || elem100 (i + 1) x ys
212
213 isn'tIn msg x ys
214 = notElem100 0 x ys
215 where
216 notElem100 :: Eq a => Int -> a -> [a] -> Bool
217 notElem100 _ _ [] = True
218 notElem100 i x (y:ys)
219 | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
220 | otherwise = x /= y && notElem100 (i + 1) x ys
221 # endif /* DEBUG */