X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FListSetOps.lhs;h=b93a0458320d4ba70633df6cd19fd9b024c2fb47;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=3be4d8932564cacfd7f8c0092e8d37e79e099c19;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs
index 3be4d89..b93a045 100644
--- a/ghc/compiler/utils/ListSetOps.lhs
+++ b/ghc/compiler/utils/ListSetOps.lhs
@@ -1,77 +1,226 @@
 %
-% (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, assocElts,
+
+	-- Duplicate handling
+	hasNoDups, runs, removeDups, removeDupsEq, 
+	equivClasses, equivClassesByUniq
+
    ) where
 
-#if defined(COMPILING_GHC)
-import Ubiq{-uitous-}
+#include "HsVersions.h"
 
-import Util	( isIn, isn'tIn )
-#endif
+import Outputable
+import Unique	( Unique )
+import UniqFM	( eltsUFM, emptyUFM, addToUFM_C )
+import Util	( isn'tIn, isIn, mapAccumR, sortLe )
+import List	( union )
 \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
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[Utils-dups]{Duplicate-handling}
+%*									*
+%************************************************************************
+
+\begin{code}
+hasNoDups :: (Eq a) => [a] -> Bool
+
+hasNoDups xs = f [] xs
+  where
+    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}
+equivClasses :: (a -> a -> Ordering) 	-- Comparison
+	     -> [a]
+	     -> [[a]]
+
+equivClasses cmp stuff@[]     = []
+equivClasses cmp stuff@[item] = [stuff]
+equivClasses cmp items
+  = runs eq (sortLe le items)
   where
-#if defined(COMPILING_GHC)
-    not_elem = isn'tIn "minusList"
-#else
-    not_elem = notElem
-#endif
+    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}
-#if ! defined(COMPILING_GHC)
+runs :: (a -> a -> Bool) 	-- Equality
+     -> [a]
+     -> [[a]]
 
-disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool
+runs p []     = []
+runs p (x:xs) = case (span (p x) xs) of
+		  (first, rest) -> (x:first) : (runs p rest)
+\end{code}
 
-disjointLists []     bs = True
-disjointLists (a:as) bs
-  | a `elem` bs = False
-  | otherwise   = disjointLists as bs
+\begin{code}
+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
 
-intersectingLists xs ys = not (disjointLists xs ys)
-#endif
+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)
+
+removeDupsEq :: Eq a => [a] -> ([a], [[a]])
+-- Same, but with only equality
+-- It's worst case quadratic, but we only use it on short lists
+removeDupsEq [] = ([], [])
+removeDupsEq (x:xs) | x `elem` xs = (ys, (x : filter (== x) xs) : zs)
+				  where
+				    (ys,zs) = removeDupsEq (filter (/= x) xs)
+removeDupsEq (x:xs) | otherwise   = (x:ys, zs)
+				  where
+				    (ys,zs) = removeDupsEq xs
 \end{code}
+
+
+\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}
+
+