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