%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
module ListSetOps (
unionLists, minusList, insertList,
Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C,
mkLookupFun, findInList, assocElts,
hasNoDups, runs, removeDups, findDupsEq,
equivClasses, equivClassesByUniq
) where
import Outputable
import Unique
import UniqFM
import Util
import Data.List
\end{code}
%************************************************************************
%* *
Treating lists as sets
Assumes the lists contain no duplicates, but are unordered
%* *
%************************************************************************
\begin{code}
insertList :: Eq a => a -> [a] -> [a]
insertList x xs | isIn "insert" x xs = xs
| otherwise = x : xs
unionLists :: (Eq a) => [a] -> [a] -> [a]
unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
minusList :: (Eq a) => [a] -> [a] -> [a]
minusList xs ys = [ x | x <- xs, isn'tIn "minusList" x ys]
\end{code}
%************************************************************************
%* *
\subsection[Utils-assoc]{Association lists}
%* *
%************************************************************************
Inefficient finite maps based on association lists and equality.
\begin{code}
type Assoc a b = [(a,b)]
emptyAssoc :: Assoc a b
unitAssoc :: a -> b -> Assoc a b
assocElts :: Assoc a b -> [(a,b)]
assoc :: (Eq a) => String -> Assoc a b -> a -> b
assocDefault :: (Eq a) => b -> Assoc a b -> a -> b
assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b
assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b
assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b
mapAssoc :: (b -> c) -> Assoc a b -> Assoc a c
extendAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> (a,b) -> Assoc a b
plusAssoc_C :: (Eq a) => (b -> b -> b) -> Assoc a b -> Assoc a b -> Assoc a b
emptyAssoc = []
unitAssoc a b = [(a,b)]
assocElts xs = xs
assocDefaultUsing _ deflt [] _ = deflt
assocDefaultUsing eq deflt ((k,v) : rest) key
| k `eq` key = v
| otherwise = assocDefaultUsing eq deflt rest key
assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
assocDefault deflt list key = assocDefaultUsing (==) deflt list key
assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
assocMaybe alist key
= lookup alist
where
lookup [] = Nothing
lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
mapAssoc f alist = [(key, f val) | (key,val) <- alist]
plusAssoc_C _ [] new = new
plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new
extendAssoc_C combine old_list (new_key, new_val)
= go old_list
where
go [] = [(new_key, new_val)]
go ((old_key, old_val) : old_list)
| new_key == old_key = ((old_key, old_val `combine` new_val) : old_list)
| otherwise = (old_key, old_val) : go old_list
\end{code}
@mkLookupFun eq alist@ is a function which looks up
its argument in the association list @alist@, returning a Maybe type.
@mkLookupFunDef@ is similar except that it is given a value to return
on failure.
\begin{code}
mkLookupFun :: (key -> key -> Bool)
-> [(key,val)]
-> key
-> Maybe val
mkLookupFun eq alist s
= case [a | (s',a) <- alist, s' `eq` s] of
[] -> Nothing
(a:_) -> Just a
findInList :: (a -> Bool) -> [a] -> Maybe a
findInList _ [] = Nothing
findInList p (x:xs) | p x = Just x
| otherwise = findInList p xs
\end{code}
%************************************************************************
%* *
\subsection[Utils-dups]{Duplicate-handling}
%* *
%************************************************************************
\begin{code}
hasNoDups :: (Eq a) => [a] -> Bool
hasNoDups xs = f [] xs
where
f _ [] = True
f seen_so_far (x:xs) = if x `is_elem` seen_so_far
then False
else f (x:seen_so_far) xs
is_elem = isIn "hasNoDups"
\end{code}
\begin{code}
equivClasses :: (a -> a -> Ordering)
-> [a]
-> [[a]]
equivClasses _ [] = []
equivClasses _ stuff@[_] = [stuff]
equivClasses cmp items = runs eq (sortLe le items)
where
eq a b = case cmp a b of { EQ -> True; _ -> False }
le a b = case cmp a b of { LT -> True; EQ -> True; GT -> False }
\end{code}
The first cases in @equivClasses@ above are just to cut to the point
more quickly...
@runs@ groups a list into a list of lists, each sublist being a run of
identical elements of the input list. It is passed a predicate @p@ which
tells when two elements are equal.
\begin{code}
runs :: (a -> a -> Bool)
-> [a]
-> [[a]]
runs _ [] = []
runs p (x:xs) = case (span (p x) xs) of
(first, rest) -> (x:first) : (runs p rest)
\end{code}
\begin{code}
removeDups :: (a -> a -> Ordering)
-> [a]
-> ([a],
[[a]])
removeDups _ [] = ([], [])
removeDups _ [x] = ([x],[])
removeDups cmp xs
= case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
(xs', dups) }
where
collect_dups _ [] = panic "ListSetOps: removeDups"
collect_dups dups_so_far [x] = (dups_so_far, x)
collect_dups dups_so_far dups@(x:_) = (dups:dups_so_far, x)
findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
findDupsEq _ [] = []
findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs
| otherwise = (x:eq_xs) : findDupsEq eq neq_xs
where (eq_xs, neq_xs) = partition (eq x) xs
\end{code}
\begin{code}
equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
equivClassesByUniq get_uniq xs
= eltsUFM (foldr add emptyUFM xs)
where
add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
tack_on old new = new++old
\end{code}