X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=11d1b5e545700e1552773d0870de7ecd96aa603c;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=34a5b5309ee9a26b5950d0b4736a633d36b868f7;hpb=59c796f8e77325d35f29ddd3e724bfa780466d40;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 34a5b53..11d1b5e 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -21,7 +21,7 @@ module Util (
 	nTimes,
 
 	-- sorting
-	sortLe,
+	sortLe, sortWith,
 
 	-- transitive closures
 	transitiveClosure,
@@ -33,7 +33,7 @@ module Util (
 	takeList, dropList, splitAtList,
 
 	-- comparisons
-	eqListBy, equalLength, compareLength,
+	isEqual, eqListBy, equalLength, compareLength,
 	thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
 
 	-- strictness
@@ -53,7 +53,6 @@ module Util (
 	readRational,
     ) where
 
-#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import Panic		( panic, trace )
@@ -373,34 +372,24 @@ Carsten
 
 \begin{code}
 group :: (a -> a -> Bool) -> [a] -> [[a]]
+-- Given a <= function, group finds maximal contiguous up-runs 
+-- or down-runs in the input list.
+-- It's stable, in the sense that it never re-orders equal elements
+--
+-- Date: Mon, 12 Feb 1996 15:09:41 +0000
+-- From: Andy Gill <andy@dcs.gla.ac.uk>
+-- Here is a `better' definition of group.
 
-{-
-Date: Mon, 12 Feb 1996 15:09:41 +0000
-From: Andy Gill <andy@dcs.gla.ac.uk>
-
-Here is a `better' definition of group.
--}
 group p []     = []
 group p (x:xs) = group' xs x x (x :)
   where
     group' []     _     _     s  = [s []]
     group' (x:xs) x_min x_max s 
-	| not (x `p` x_max) = group' xs x_min x (s . (x :)) 
-	| x `p` x_min       = group' xs x x_max ((x :) . s) 
+	|      x_max `p` x  = group' xs x_min x (s . (x :)) 
+	| not (x_min `p` x) = group' xs x x_max ((x :) . s) 
 	| otherwise         = s [] : group' xs x x (x :) 
-
--- This one works forwards *and* backwards, as well as also being
--- faster that the one in Util.lhs.
-
-{- ORIG:
-group p [] = [[]]
-group p (x:xs) =
-   let ((h1:t1):tt1) = group p xs
-       (t,tt) = if null xs then ([],[]) else
-		if x `p` h1 then (h1:t1,tt1) else
-		   ([], (h1:t1):tt1)
-   in ((x:t):tt)
--}
+	-- NB: the 'not' is essential for stablity
+	--	x `p` x_min would reverse equal elements
 
 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 generalMerge p xs [] = xs
@@ -436,6 +425,11 @@ mergeSortLe le = generalMergeSort le
 
 sortLe :: (a->a->Bool) -> [a] -> [a]
 sortLe le = generalNaturalMergeSort le
+
+sortWith :: Ord b => (a->b) -> [a] -> [a]
+sortWith get_key xs = sortLe le xs
+  where
+    x `le` y = get_key x < get_key y	
 \end{code}
 
 %************************************************************************
@@ -587,6 +581,17 @@ splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 %************************************************************************
 
 \begin{code}
+isEqual :: Ordering -> Bool
+-- Often used in (isEqual (a `compare` b))
+isEqual GT = False
+isEqual EQ = True
+isEqual LT = False
+
+thenCmp :: Ordering -> Ordering -> Ordering
+{-# INLINE thenCmp #-}
+thenCmp EQ   any = any
+thenCmp other any = other
+
 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 eqListBy eq []     []     = True
 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
@@ -603,11 +608,6 @@ compareLength (_:xs) (_:ys) = compareLength xs ys
 compareLength [] _ys        = LT
 compareLength _xs []        = GT
 
-thenCmp :: Ordering -> Ordering -> Ordering
-{-# INLINE thenCmp #-}
-thenCmp EQ   any = any
-thenCmp other any = other
-
 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
     -- `cmpList' uses a user-specified comparer