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