%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ListSetOps]{Set-like operations on lists}
\begin{code}
module ListSetOps (
- unionLists,
- intersectLists,
- minusList
-#if ! defined(COMPILING_GHC)
- , disjointLists, intersectingLists
-#endif
+ unionLists, minusList, insertList,
+
+ -- Association lists
+ Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,
+ emptyAssoc, unitAssoc, mapAssoc, plusAssoc_C, extendAssoc_C,
+ mkLookupFun, findInList, assocElts,
+
+ -- Duplicate handling
+ hasNoDups, runs, removeDups, findDupsEq,
+ equivClasses, equivClassesByUniq
+
) where
-#if defined(COMPILING_GHC)
-import Util
-# ifdef USE_ATTACK_PRAGMAS
-import Type
-import Id ( Id )
-# endif
-#endif
+#include "HsVersions.h"
+
+import Outputable
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
+import Util ( isn'tIn, isIn, mapAccumR, sortLe )
+import List ( partition )
\end{code}
+
+%************************************************************************
+%* *
+ Treating lists as sets
+ Assumes the lists contain no duplicates, but are unordered
+%* *
+%************************************************************************
+
\begin{code}
+insertList :: Eq a => a -> [a] -> [a]
+-- Assumes the arg list contains no dups; guarantees the result has no dups
+insertList x xs | isIn "insert" x xs = xs
+ | otherwise = x : xs
+
unionLists :: (Eq a) => [a] -> [a] -> [a]
-unionLists [] [] = []
-unionLists [] b = b
-unionLists a [] = a
-unionLists (a:as) b
- | a `is_elem` b = unionLists as b
- | otherwise = a : unionLists as b
+-- Assumes that the arguments contain no duplicates
+unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
+
+minusList :: (Eq a) => [a] -> [a] -> [a]
+-- Everything in the first list that is not in the second list:
+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)] -- A finite mapping based on equality and association lists
+
+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
+ -- combining fn takes (old->new->result)
+
+emptyAssoc = []
+unitAssoc a b = [(a,b)]
+assocElts xs = xs
+
+assocDefaultUsing eq deflt ((k,v) : rest) key
+ | k `eq` key = v
+ | otherwise = assocDefaultUsing eq deflt rest key
+
+assocDefaultUsing eq deflt [] key = deflt
+
+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
-#if defined(COMPILING_GHC)
- is_elem = isIn "unionLists"
-#else
- is_elem = elem
-#endif
-
-intersectLists :: (Eq a) => [a] -> [a] -> [a]
-intersectLists [] [] = []
-intersectLists [] b = []
-intersectLists a [] = []
-intersectLists (a:as) b
- | a `is_elem` b = a : intersectLists as b
- | otherwise = intersectLists as b
+ 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 combine [] new = new -- Shortcut for common case
+plusAssoc_C combine old new = foldl (extendAssoc_C combine) old new
+
+extendAssoc_C combine old_list (new_key, new_val)
+ = go old_list
where
-#if defined(COMPILING_GHC)
- is_elem = isIn "intersectLists"
-#else
- is_elem = elem
-#endif
+ 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}
-Everything in the first list that is not in the second list:
+
+@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}
-minusList :: (Eq a) => [a] -> [a] -> [a]
-minusList xs ys = [ x | x <- xs, x `not_elem` ys]
+mkLookupFun :: (key -> key -> Bool) -- Equality predicate
+ -> [(key,val)] -- The assoc list
+ -> key -- The key
+ -> Maybe val -- The corresponding value
+
+mkLookupFun eq alist s
+ = case [a | (s',a) <- alist, s' `eq` s] of
+ [] -> Nothing
+ (a:_) -> Just a
+
+findInList :: (a -> Bool) -> [a] -> Maybe a
+findInList p [] = 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
-#if defined(COMPILING_GHC)
- not_elem = isn'tIn "minusList"
-#else
- not_elem = notElem
-#endif
+ f seen_so_far [] = 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}
-#if ! defined(COMPILING_GHC)
+equivClasses :: (a -> a -> Ordering) -- Comparison
+ -> [a]
+ -> [[a]]
-disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool
+equivClasses cmp stuff@[] = []
+equivClasses cmp stuff@[item] = [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...
-disjointLists [] bs = True
-disjointLists (a:as) bs
- | a `elem` bs = False
- | otherwise = disjointLists as bs
+@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.
-intersectingLists xs ys = not (disjointLists xs ys)
-#endif
+\begin{code}
+runs :: (a -> a -> Bool) -- Equality
+ -> [a]
+ -> [[a]]
+
+runs p [] = []
+runs p (x:xs) = case (span (p x) xs) of
+ (first, rest) -> (x:first) : (runs p rest)
\end{code}
\begin{code}
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
+removeDups :: (a -> a -> Ordering) -- Comparison function
+ -> [a]
+ -> ([a], -- List with no duplicates
+ [[a]]) -- List of duplicate groups. One representative from
+ -- each group appears in the first result
+
+removeDups cmp [] = ([], [])
+removeDups cmp [x] = ([x],[])
+removeDups cmp xs
+ = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
+ (xs', dups) }
+ where
+ collect_dups dups_so_far [x] = (dups_so_far, x)
+ collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
-{-# SPECIALIZE unionLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
-{-# SPECIALIZE intersectLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
+findDupsEq :: (a->a->Bool) -> [a] -> [[a]]
+findDupsEq eq [] = []
+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}
-{-# SPECIALIZE minusList :: [TyVar] -> [TyVar] -> [TyVar],
- [Id] -> [Id] -> [Id],
- [Int] -> [Int] -> [Int]
- #-}
-# endif
-#endif
+\begin{code}
+equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
+ -- NB: it's *very* important that if we have the input list [a,b,c],
+ -- where a,b,c all have the same unique, then we get back the list
+ -- [a,b,c]
+ -- not
+ -- [c,b,a]
+ -- Hence the use of foldr, plus the reversed-args tack_on below
+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}
+
+
projects / ghc-hetmet.git / blobdiff