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
10module 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
26import GhcPrelude
27
28import Outputable
29import Util
30
31import qualified Data.List as L
32import qualified Data.List.NonEmpty as NE
33import Data.List.NonEmpty (NonEmpty(..))
34import qualified Data.Set as S
35
36getNth :: Outputable a => [a] -> Int -> a
37getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
38             xs !! n
39
40deleteBys :: (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
43deleteBys eq xs ys = foldl' (flip (L.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
56unionLists :: (HasDebugCallStack, Outputable a, Eq a) => [a] -> [a] -> [a]
57-- We special case some reasonable common patterns.
58unionLists xs [] = xs
59unionLists [] ys = ys
60unionLists [x] ys
61  | isIn "unionLists" x ys = ys
62  | otherwise = x:ys
63unionLists xs [y]
64  | isIn "unionLists" y xs = xs
65  | otherwise = y:xs
66unionLists 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.
77minusList :: 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.
83minusList [] _ = []
84minusList 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.
88minusList xs [] = xs
89minusList 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.
93minusList 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
104Inefficient finite maps based on association lists and equality.
105-}
106
107-- A finite mapping based on equality and association lists
108type Assoc a b = [(a,b)]
109
110assoc             :: (Eq a) => String -> Assoc a b -> a -> b
111assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b
112assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
113assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b
114assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
115
116assocDefaultUsing _  deflt []             _   = deflt
117assocDefaultUsing eq deflt ((k,v) : rest) key
118  | k `eq` key = v
119  | otherwise  = assocDefaultUsing eq deflt rest key
120
121assoc crash_msg         list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
122assocDefault deflt      list key = assocDefaultUsing (==) deflt list key
123assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
124
125assocMaybe 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
139hasNoDups :: (Eq a) => [a] -> Bool
140
141hasNoDups 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
150equivClasses :: (a -> a -> Ordering) -- Comparison
151             -> [a]
152             -> [NonEmpty a]
153
154equivClasses _   []      = []
155equivClasses _   [stuff] = [stuff :| []]
156equivClasses cmp items   = NE.groupBy eq (L.sortBy cmp items)
157  where
158    eq a b = case cmp a b of { EQ -> True; _ -> False }
159
160removeDups :: (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
166removeDups _   []  = ([], [])
167removeDups _   [x] = ([x],[])
168removeDups cmp xs
169  = case L.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
176findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a]
177findDupsEq _  [] = []
178findDupsEq eq (x:xs) | L.null eq_xs  = findDupsEq eq xs
179                     | otherwise     = (x :| eq_xs) : findDupsEq eq neq_xs
180    where (eq_xs, neq_xs) = L.partition (eq x) xs
181