eaa79bd7fbcfda2d67cd3c9132cdb7d276f8f66c
1 {-
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}
6 -}
8 {-# LANGUAGE CPP #-}
10 module ListSetOps (
11 unionLists, minusList,
13 -- Association lists
14 Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
16 -- Duplicate handling
17 hasNoDups, runs, removeDups, findDupsEq,
18 equivClasses,
20 -- Indexing
21 getNth
22 ) where
24 #include "HsVersions.h"
26 import Outputable
27 import Util
29 import Data.List
31 getNth :: Outputable a => [a] -> Int -> a
32 getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n \$\$ ppr xs )
33 xs !! n
35 {-
36 ************************************************************************
37 * *
38 Treating lists as sets
39 Assumes the lists contain no duplicates, but are unordered
40 * *
41 ************************************************************************
42 -}
45 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
46 -- Assumes that the arguments contain no duplicates
47 unionLists xs ys
48 = WARN(length xs > 100 || length ys > 100, ppr xs \$\$ ppr ys)
49 [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
51 minusList :: (Eq a) => [a] -> [a] -> [a]
52 -- Everything in the first list that is not in the second list:
53 minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]
55 {-
56 ************************************************************************
57 * *
58 \subsection[Utils-assoc]{Association lists}
59 * *
60 ************************************************************************
62 Inefficient finite maps based on association lists and equality.
63 -}
65 -- A finite mapping based on equality and association lists
66 type Assoc a b = [(a,b)]
68 assoc :: (Eq a) => String -> Assoc a b -> a -> b
69 assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
70 assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
71 assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
72 assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
74 assocDefaultUsing _ deflt [] _ = deflt
75 assocDefaultUsing eq deflt ((k,v) : rest) key
76 | k `eq` key = v
77 | otherwise = assocDefaultUsing eq deflt rest key
79 assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
80 assocDefault deflt list key = assocDefaultUsing (==) deflt list key
81 assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
83 assocMaybe alist key
84 = lookup alist
85 where
86 lookup [] = Nothing
87 lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
89 {-
90 ************************************************************************
91 * *
92 \subsection[Utils-dups]{Duplicate-handling}
93 * *
94 ************************************************************************
95 -}
97 hasNoDups :: (Eq a) => [a] -> Bool
99 hasNoDups xs = f [] xs
100 where
101 f _ [] = True
102 f seen_so_far (x:xs) = if x `is_elem` seen_so_far
103 then False
104 else f (x:seen_so_far) xs
106 is_elem = isIn "hasNoDups"
108 equivClasses :: (a -> a -> Ordering) -- Comparison
109 -> [a]
110 -> [[a]]
112 equivClasses _ [] = []
113 equivClasses _ stuff@[_] = [stuff]
114 equivClasses cmp items = runs eq (sortBy cmp items)
115 where
116 eq a b = case cmp a b of { EQ -> True; _ -> False }
118 {-
119 The first cases in @equivClasses@ above are just to cut to the point
120 more quickly...
122 @runs@ groups a list into a list of lists, each sublist being a run of
123 identical elements of the input list. It is passed a predicate @p@ which
124 tells when two elements are equal.
125 -}
127 runs :: (a -> a -> Bool) -- Equality
128 -> [a]
129 -> [[a]]
131 runs _ [] = []
132 runs p (x:xs) = case (span (p x) xs) of
133 (first, rest) -> (x:first) : (runs p rest)
135 removeDups :: (a -> a -> Ordering) -- Comparison function
136 -> [a]
137 -> ([a], -- List with no duplicates
138 [[a]]) -- List of duplicate groups. One representative from
139 -- each group appears in the first result
141 removeDups _ [] = ([], [])
142 removeDups _ [x] = ([x],[])
143 removeDups cmp xs
144 = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
145 (xs', dups) }
146 where
147 collect_dups _ [] = panic "ListSetOps: removeDups"
148 collect_dups dups_so_far [x] = (dups_so_far, x)
149 collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
151 findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
152 findDupsEq _ [] = []
153 findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
154 | otherwise = (x:eq_xs) : findDupsEq eq neq_xs
155 where (eq_xs, neq_xs) = partition (eq x) xs