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