Revert "Batch merge"
[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,
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 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
56 -- Assumes that the arguments contain no duplicates
57 unionLists xs ys
58 = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)
59 [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
60
61 -- | Calculate the set difference of two lists. This is
62 -- /O((m + n) log n)/, where we subtract a list of /n/ elements
63 -- from a list of /m/ elements.
64 --
65 -- Extremely short cases are handled specially:
66 -- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1,
67 -- it takes /O(n)/ time.
68 minusList :: Ord a => [a] -> [a] -> [a]
69 -- There's no point building a set to perform just one lookup, so we handle
70 -- extremely short lists specially. It might actually be better to use
71 -- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5).
72 -- The tipping point will be somewhere in the area of where /m/ and /log n/
73 -- become comparable, but we probably don't want to work too hard on this.
74 minusList [] _ = []
75 minusList xs@[x] ys
76 | x `elem` ys = []
77 | otherwise = xs
78 -- Using an empty set or a singleton would also be silly, so let's not.
79 minusList xs [] = xs
80 minusList xs [y] = filter (/= y) xs
81 -- When each list has at least two elements, we build a set from the
82 -- second argument, allowing us to filter the first argument fairly
83 -- efficiently.
84 minusList xs ys = filter (`S.notMember` yss) xs
85 where
86 yss = S.fromList ys
87
88 {-
89 ************************************************************************
90 * *
91 \subsection[Utils-assoc]{Association lists}
92 * *
93 ************************************************************************
94
95 Inefficient finite maps based on association lists and equality.
96 -}
97
98 -- A finite mapping based on equality and association lists
99 type Assoc a b = [(a,b)]
100
101 assoc :: (Eq a) => String -> Assoc a b -> a -> b
102 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
103 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
104 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
105 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
106
107 assocDefaultUsing _ deflt [] _ = deflt
108 assocDefaultUsing eq deflt ((k,v) : rest) key
109 | k `eq` key = v
110 | otherwise = assocDefaultUsing eq deflt rest key
111
112 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
113 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
114 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
115
116 assocMaybe alist key
117 = lookup alist
118 where
119 lookup [] = Nothing
120 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
121
122 {-
123 ************************************************************************
124 * *
125 \subsection[Utils-dups]{Duplicate-handling}
126 * *
127 ************************************************************************
128 -}
129
130 hasNoDups :: (Eq a) => [a] -> Bool
131
132 hasNoDups xs = f [] xs
133 where
134 f _ [] = True
135 f seen_so_far (x:xs) = if x `is_elem` seen_so_far
136 then False
137 else f (x:seen_so_far) xs
138
139 is_elem = isIn "hasNoDups"
140
141 equivClasses :: (a -> a -> Ordering) -- Comparison
142 -> [a]
143 -> [NonEmpty a]
144
145 equivClasses _ [] = []
146 equivClasses _ [stuff] = [stuff :| []]
147 equivClasses cmp items = NE.groupBy eq (sortBy cmp items)
148 where
149 eq a b = case cmp a b of { EQ -> True; _ -> False }
150
151 removeDups :: (a -> a -> Ordering) -- Comparison function
152 -> [a]
153 -> ([a], -- List with no duplicates
154 [NonEmpty a]) -- List of duplicate groups. One representative
155 -- from each group appears in the first result
156
157 removeDups _ [] = ([], [])
158 removeDups _ [x] = ([x],[])
159 removeDups cmp xs
160 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
161 (xs', dups) }
162 where
163 collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a)
164 collect_dups dups_so_far (x :| []) = (dups_so_far, x)
165 collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x)
166
167 findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
168 findDupsEq _ [] = []
169 findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
170 | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs
171 where (eq_xs, neq_xs) = partition (eq x) xs