X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=e692ff1aa3afcd868b7deaafcf44f9e9ea5bc39e;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=1f7289d2aec90ebd12047763d4e4ccbf9a51ff5b;hpb=ee096783fedf17a078700a106adeefba3e5e9ba6;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 1f7289d..e692ff1 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -1,68 +1,104 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The University of Glasgow 1992-2002
 %
 \section[Util]{Highly random utility functions}
 
 \begin{code}
--- IF_NOT_GHC is meant to make this module useful outside the context of GHC
-#define IF_NOT_GHC(a)
-
 module Util (
-#if NOT_USED
-	-- The Eager monad
-	Eager, thenEager, returnEager, mapEager, appEager, runEager,
-#endif
 
 	-- general list processing
 	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
-        zipLazy, stretchZipEqual,
+        zipLazy, stretchZipWith,
+	mapFst, mapSnd,
 	mapAndUnzip, mapAndUnzip3,
-	nOfThem, lengthExceeds, isSingleton, only,
-	snocView,
-	isIn, isn'tIn,
+	nOfThem, filterOut,
+	lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+	isSingleton, only, singleton,
+	notNull, snocView,
 
-	-- association lists
-	assoc, assocUsing, assocDefault, assocDefaultUsing,
+	isIn, isn'tIn,
 
-	-- duplicate handling
-	hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
+	-- for-loop
+	nTimes,
 
 	-- sorting
-	IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
-	sortLt,
-	IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe,	-- from Carsten
-	IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
+	sortLe, sortWith,
 
 	-- transitive closures
 	transitiveClosure,
 
 	-- accumulating
-	mapAccumL, mapAccumR, mapAccumB, foldl2, count,
+	mapAccumL, mapAccumR, mapAccumB, 
+	foldl2, count, all2,
+	
+	takeList, dropList, splitAtList, split,
 
 	-- comparisons
-	thenCmp, cmpList,
+	isEqual, eqListBy, equalLength, compareLength,
+	thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
+	removeSpaces,
 
 	-- strictness
-	seqList, ($!),
+	foldl', seqList,
 
 	-- pairs
-	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
-	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
-	unzipWith
-
-	-- I/O
-#if __GLASGOW_HASKELL__ < 402
-	, bracket
-#endif
-
+	unzipWith,
+
+	global, consIORef,
+
+	-- module names
+	looksLikeModuleName,
+	
+	toArgs,
+
+	-- Floating point stuff
+	readRational,
+
+	-- IO-ish utilities
+	createDirectoryHierarchy,
+	doesDirNameExist,
+	modificationTimeIfExists,
+
+	later, handleDyn, handle,
+
+	-- Filename utils
+	Suffix,
+	splitFilename, suffixOf, basenameOf, joinFileExt,
+	splitFilenameDir, joinFileName,
+	splitFilename3,
+	splitLongestPrefix,
+	replaceFilenameSuffix, directoryOf, filenameOf,
+	replaceFilenameDirectory,
+	escapeSpaces, isPathSeparator,
+	parseSearchPath,
+	normalisePath, platformPath, pgmPath,
     ) where
 
 #include "HsVersions.h"
 
+import Panic		( panic, trace )
+import FastTypes
+
+import EXCEPTION	( Exception(..), finally, throwDyn, catchDyn, throw )
+import qualified EXCEPTION as Exception
+import DYNAMIC		( Typeable )
+import DATA_IOREF	( IORef, newIORef )
+import UNSAFE_IO	( unsafePerformIO )
+import DATA_IOREF	( readIORef, writeIORef )
+
+import qualified List	( elem, notElem )
+
+#ifndef DEBUG
 import List		( zipWith4 )
-import Panic		( panic )
-import Unique		( Unique )
-import UniqFM		( eltsUFM, emptyUFM, addToUFM_C )
+#endif
+
+import Monad		( when )
+import IO		( catch, isDoesNotExistError )
+import Directory	( doesDirectoryExist, createDirectory )
+import Char		( isUpper, isAlphaNum, isSpace, ord, isDigit )
+import Ratio		( (%) )
+import Time		( ClockTime )
+import Directory	( getModificationTime )
 
 infixr 9 `thenCmp`
 \end{code}
@@ -104,10 +140,32 @@ mapEager f (x:xs) = f x			`thenEager` \ y ->
 
 %************************************************************************
 %*									*
+\subsection{A for loop}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- Compose a function with itself n times.  (nth rather than twice)
+nTimes :: Int -> (a -> a) -> (a -> a)
+nTimes 0 _ = id
+nTimes 1 f = f
+nTimes n f = f . nTimes (n-1) f
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[Utils-lists]{General list processing}
 %*									*
 %************************************************************************
 
+\begin{code}
+filterOut :: (a->Bool) -> [a] -> [a]
+-- Like filter, only reverses the sense of the test
+filterOut p [] = []
+filterOut p (x:xs) | p x       = filterOut p xs
+		   | otherwise = x : filterOut p xs
+\end{code}
+
 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 are of equal length.  Alastair Reid thinks this should only happen if
 DEBUGging on; hey, why not?
@@ -154,17 +212,26 @@ zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 
 
 \begin{code}
-stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
--- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
-
-stretchZipEqual f [] [] = []
-stretchZipEqual f (x:xs) (y:ys) = case f x y of
-				    Just x' -> x' : stretchZipEqual f xs ys
-				    Nothing -> x  : stretchZipEqual f xs (y:ys)
+stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
+-- (stretchZipWith p z f xs ys) stretches ys by inserting z in 
+-- the places where p returns *True*
+
+stretchZipWith p z f [] ys = []
+stretchZipWith p z f (x:xs) ys
+  | p x       = f x z : stretchZipWith p z f xs ys
+  | otherwise = case ys of
+		  []     -> []
+		  (y:ys) -> f x y : stretchZipWith p z f xs ys
 \end{code}
 
 
 \begin{code}
+mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
+mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
+
+mapFst f xys = [(f x, y) | (x,y) <- xys]
+mapSnd f xys = [(x, f y) | (x,y) <- xys]
+
 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 
 mapAndUnzip f [] = ([],[])
@@ -190,15 +257,69 @@ mapAndUnzip3 f (x:xs)
 nOfThem :: Int -> a -> [a]
 nOfThem n thing = replicate n thing
 
+-- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
+-- specification:
+--
+--  atLength atLenPred atEndPred ls n
+--   | n < 0         = atLenPred n
+--   | length ls < n = atEndPred (n - length ls)
+--   | otherwise     = atLenPred (drop n ls)
+--
+atLength :: ([a] -> b)
+         -> (Int -> b)
+         -> [a]
+         -> Int
+         -> b
+atLength atLenPred atEndPred ls n 
+  | n < 0     = atEndPred n 
+  | otherwise = go n ls
+  where
+    go n [] = atEndPred n
+    go 0 ls = atLenPred ls
+    go n (_:xs) = go (n-1) xs
+
+-- special cases.
 lengthExceeds :: [a] -> Int -> Bool
--- (lengthExceeds xs n) is True if   length xs > n
-(x:xs)	`lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
-[]	`lengthExceeds` n = n < 0
+-- (lengthExceeds xs n) = (length xs > n)
+lengthExceeds = atLength notNull (const False)
+
+lengthAtLeast :: [a] -> Int -> Bool
+lengthAtLeast = atLength notNull (== 0)
+
+lengthIs :: [a] -> Int -> Bool
+lengthIs = atLength null (==0)
+
+listLengthCmp :: [a] -> Int -> Ordering 
+listLengthCmp = atLength atLen atEnd 
+ where
+  atEnd 0      = EQ
+  atEnd x
+   | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
+   | otherwise = GT
+
+  atLen []     = EQ
+  atLen _      = GT
+
+singleton :: a -> [a]
+singleton x = [x]
 
 isSingleton :: [a] -> Bool
 isSingleton [x] = True
 isSingleton  _  = False
 
+notNull :: [a] -> Bool
+notNull [] = False
+notNull _  = True
+
+snocView :: [a] -> Maybe ([a],a)
+	-- Split off the last element
+snocView [] = Nothing
+snocView xs = go [] xs
+	    where
+		-- Invariant: second arg is non-empty
+	      go acc [x]    = Just (reverse acc, x)
+	      go acc (x:xs) = go (x:acc) xs
+
 only :: [a] -> a
 #ifdef DEBUG
 only [a] = a
@@ -207,14 +328,6 @@ only (a:_) = a
 #endif
 \end{code}
 
-\begin{code}
-snocView :: [a] -> ([a], a)	-- Split off the last element
-snocView xs = go xs []
-	    where
-	      go [x]    acc = (reverse acc, x)
-	      go (x:xs) acc = go xs (x:acc)
-\end{code}
-
 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 
 \begin{code}
@@ -231,256 +344,25 @@ elem__ x (y:ys)	= x==y || elem__ x ys
 notElem__ x []	   =  True
 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 
-# else {- DEBUG -}
+# else /* DEBUG */
 isIn msg x ys
-  = elem ILIT(0) x ys
+  = elem (_ILIT 0) x ys
   where
     elem i _ []	    = False
     elem i x (y:ys)
-      | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
-      | otherwise	 = x == y || elem (i _ADD_ ILIT(1)) x ys
+      | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
+			 x `List.elem` (y:ys)
+      | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 
 isn'tIn msg x ys
-  = notElem ILIT(0) x ys
+  = notElem (_ILIT 0) x ys
   where
     notElem i x [] =  True
     notElem i x (y:ys)
-      | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
-      | otherwise	 =  x /= y && notElem (i _ADD_ ILIT(1)) x ys
-
-# endif {- DEBUG -}
-
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection[Utils-assoc]{Association lists}
-%*									*
-%************************************************************************
-
-See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
-
-\begin{code}
-assoc		  :: (Eq a) => String -> [(a, b)] -> a -> b
-assocDefault	  :: (Eq a) => b -> [(a, b)] -> a -> b
-assocUsing	  :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
-assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
-
-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
-\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 (sortLt lt items)
-  where
-    eq a b = case cmp a b of { EQ -> True; _ -> False }
-    lt a b = case cmp a b of { LT -> True; _ -> 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) 	-- 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}
-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)
-\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}
-
-%************************************************************************
-%*									*
-\subsection[Utils-sorting]{Sorting}
-%*									*
-%************************************************************************
-
-%************************************************************************
-%*									*
-\subsubsection[Utils-quicksorting]{Quicksorts}
-%*									*
-%************************************************************************
-
-\begin{code}
-#if NOT_USED
-
--- tail-recursive, etc., "quicker sort" [as per Meira thesis]
-quicksort :: (a -> a -> Bool)		-- Less-than predicate
-	  -> [a]			-- Input list
-	  -> [a]			-- Result list in increasing order
-
-quicksort lt []      = []
-quicksort lt [x]     = [x]
-quicksort lt (x:xs)  = split x [] [] xs
-  where
-    split x lo hi []		     = quicksort lt lo ++ (x : quicksort lt hi)
-    split x lo hi (y:ys) | y `lt` x  = split x (y:lo) hi ys
-			 | True      = split x lo (y:hi) ys
-#endif
-\end{code}
-
-Quicksort variant from Lennart's Haskell-library contribution.  This
-is a {\em stable} sort.
-
-\begin{code}
-stableSortLt = sortLt	-- synonym; when we want to highlight stable-ness
-
-sortLt :: (a -> a -> Bool) 		-- Less-than predicate
-       -> [a] 				-- Input list
-       -> [a]				-- Result list
-
-sortLt lt l = qsort lt   l []
-
--- qsort is stable and does not concatenate.
-qsort :: (a -> a -> Bool)	-- Less-than predicate
-      -> [a]			-- xs, Input list
-      -> [a]			-- r,  Concatenate this list to the sorted input list
-      -> [a]			-- Result = sort xs ++ r
-
-qsort lt []     r = r
-qsort lt [x]    r = x:r
-qsort lt (x:xs) r = qpart lt x xs [] [] r
-
--- qpart partitions and sorts the sublists
--- rlt contains things less than x,
--- rge contains the ones greater than or equal to x.
--- Both have equal elements reversed with respect to the original list.
-
-qpart lt x [] rlt rge r =
-    -- rlt and rge are in reverse order and must be sorted with an
-    -- anti-stable sorting
-    rqsort lt rlt (x : rqsort lt rge r)
-
-qpart lt x (y:ys) rlt rge r =
-    if lt y x then
-	-- y < x
-	qpart lt x ys (y:rlt) rge r
-    else
-	-- y >= x
-	qpart lt x ys rlt (y:rge) r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort lt []     r = r
-rqsort lt [x]    r = x:r
-rqsort lt (x:xs) r = rqpart lt x xs [] [] r
-
-rqpart lt x [] rle rgt r =
-    qsort lt rle (x : qsort lt rgt r)
-
-rqpart lt x (y:ys) rle rgt r =
-    if lt x y then
-	-- y > x
-	rqpart lt x ys rle (y:rgt) r
-    else
-	-- y <= x
-	rqpart lt x ys (y:rle) rgt r
-\end{code}
-
-%************************************************************************
-%*									*
-\subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
-%*									*
-%************************************************************************
-
-\begin{code}
-#if NOT_USED
-mergesort :: (a -> a -> Ordering) -> [a] -> [a]
-
-mergesort cmp xs = merge_lists (split_into_runs [] xs)
-  where
-    a `le` b = case cmp a b of { LT -> True;  EQ -> True; GT -> False }
-    a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True  }
-
-    split_into_runs []        []	    	= []
-    split_into_runs run       []	    	= [run]
-    split_into_runs []        (x:xs)		= split_into_runs [x] xs
-    split_into_runs [r]       (x:xs) | x `ge` r = split_into_runs [r,x] xs
-    split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
-				     | True     = rl : (split_into_runs [x] xs)
-
-    merge_lists []	 = []
-    merge_lists (x:xs)   = merge x (merge_lists xs)
-
-    merge [] ys = ys
-    merge xs [] = xs
-    merge xl@(x:xs) yl@(y:ys)
-      = case cmp x y of
-	  EQ  -> x : y : (merge xs ys)
-	  LT  -> x : (merge xs yl)
-	  GT -> y : (merge xl ys)
-#endif
+      | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
+		         x `List.notElem` (y:ys)
+      | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
+# endif /* DEBUG */
 \end{code}
 
 %************************************************************************
@@ -526,34 +408,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
@@ -572,19 +444,28 @@ balancedFold' :: (a -> a -> a) -> [a] -> [a]
 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 balancedFold' f xs = xs
 
-generalMergeSort p [] = []
-generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
-
 generalNaturalMergeSort p [] = []
 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 
+#if NOT_USED
+generalMergeSort p [] = []
+generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
+
 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 
 mergeSort = generalMergeSort (<=)
 naturalMergeSort = generalNaturalMergeSort (<=)
 
 mergeSortLe le = generalMergeSort le
-naturalMergeSortLe le = generalNaturalMergeSort le
+#endif
+
+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}
 
 %************************************************************************
@@ -675,12 +556,29 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 	(a'',b',ys) = mapAccumB f a' b xs
 \end{code}
 
+A strict version of foldl.
+
+\begin{code}
+foldl'        :: (a -> b -> a) -> a -> [b] -> a
+foldl' f z xs = lgo z xs
+	     where
+		lgo z []     =  z
+		lgo z (x:xs) = (lgo $! (f z x)) xs
+\end{code}
+
 A combination of foldl with zip.  It works with equal length lists.
 
 \begin{code}
 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 foldl2 k z [] [] = z
 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
+
+all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+-- True if the lists are the same length, and 
+-- all corresponding elements satisfy the predicate
+all2 p []     []     = True
+all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
+all2 p xs     ys     = False
 \end{code}
 
 Count the number of times a predicate is true
@@ -692,6 +590,37 @@ count p (x:xs) | p x       = 1 + count p xs
 	       | otherwise = count p xs
 \end{code}
 
+@splitAt@, @take@, and @drop@ but with length of another
+list giving the break-off point:
+
+\begin{code}
+takeList :: [b] -> [a] -> [a]
+takeList [] _ = []
+takeList (_:xs) ls = 
+   case ls of
+     [] -> []
+     (y:ys) -> y : takeList xs ys
+
+dropList :: [b] -> [a] -> [a]
+dropList [] xs    = xs
+dropList _  xs@[] = xs
+dropList (_:xs) (_:ys) = dropList xs ys
+
+
+splitAtList :: [b] -> [a] -> ([a], [a])
+splitAtList [] xs     = ([], xs)
+splitAtList _ xs@[]   = (xs, xs)
+splitAtList (_:xs) (y:ys) = (y:ys', ys'')
+    where
+      (ys', ys'') = splitAtList xs ys
+
+split :: Char -> String -> [String]
+split c s = case rest of
+		[]     -> [chunk] 
+		_:rest -> chunk : split c rest
+  where (chunk, rest) = break (==c) s
+\end{code}
+
 
 %************************************************************************
 %*									*
@@ -700,11 +629,33 @@ count p (x:xs) | p x       = 1 + count p xs
 %************************************************************************
 
 \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
+eqListBy eq xs     ys     = False
+
+equalLength :: [a] -> [b] -> Bool
+equalLength [] []         = True
+equalLength (_:xs) (_:ys) = equalLength xs ys
+equalLength xs    ys      = False
+
+compareLength :: [a] -> [b] -> Ordering
+compareLength [] []         = EQ
+compareLength (_:xs) (_:ys) = compareLength xs ys
+compareLength [] _ys        = LT
+compareLength _xs []        = GT
+
 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
     -- `cmpList' uses a user-specified comparer
 
@@ -716,17 +667,26 @@ cmpList cmp (a:as) (b:bs)
 \end{code}
 
 \begin{code}
-cmpString :: String -> String -> Ordering
-
-cmpString []     []	= EQ
-cmpString (x:xs) (y:ys) = if	  x == y then cmpString xs ys
-			  else if x  < y then LT
-			  else		      GT
-cmpString []     ys	= LT
-cmpString xs     []	= GT
+prefixMatch :: Eq a => [a] -> [a] -> Bool
+prefixMatch [] _str = True
+prefixMatch _pat [] = False
+prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
+			  | otherwise = False
+
+maybePrefixMatch :: String -> String -> Maybe String
+maybePrefixMatch []    rest = Just rest
+maybePrefixMatch (_:_) []   = Nothing
+maybePrefixMatch (p:pat) (r:rest)
+  | p == r    = maybePrefixMatch pat rest
+  | otherwise = Nothing
+
+suffixMatch :: Eq a => [a] -> [a] -> Bool
+suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
+
+removeSpaces :: String -> String
+removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection[Utils-pairs]{Pairs}
@@ -736,14 +696,17 @@ cmpString xs     []	= GT
 The following are curried versions of @fst@ and @snd@.
 
 \begin{code}
+#if NOT_USED
 cfst :: a -> b -> a	-- stranal-sem only (Note)
 cfst x y = x
+#endif
 \end{code}
 
 The following provide us higher order functions that, when applied
 to a function, operate on pairs.
 
 \begin{code}
+#if NOT_USED
 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 applyToPair (f,g) (x,y) = (f x, g y)
 
@@ -752,11 +715,7 @@ applyToFst f (x,y) = (f x,y)
 
 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 applyToSnd f (x,y) = (x,f y)
-
-foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
-foldPair fg ab [] = ab
-foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
-		       where (u,v) = foldPair fg ab abs
+#endif
 \end{code}
 
 \begin{code}
@@ -765,27 +724,306 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 \end{code}
 
 \begin{code}
-#if __HASKELL1__ > 4
 seqList :: [a] -> b -> b
-#else
-seqList :: (Eval a) => [a] -> b -> b
-#endif
 seqList [] b = b
 seqList (x:xs) b = x `seq` seqList xs b
+\end{code}
 
-#if __HASKELL1__ <= 4
-($!)    :: (Eval a) => (a -> b) -> a -> b
-f $! x  = x `seq` f x
-#endif
+Global variables:
+
+\begin{code}
+global :: a -> IORef a
+global a = unsafePerformIO (newIORef a)
 \end{code}
 
 \begin{code}
-#if __GLASGOW_HASKELL__ < 402
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after thing = do
-  a <- before 
-  r <- (thing a) `catch` (\err -> after a >> fail err)
-  after a
-  return r
+consIORef :: IORef [a] -> a -> IO ()
+consIORef var x = do
+  xs <- readIORef var
+  writeIORef var (x:xs)
+\end{code}
+
+Module names:
+
+\begin{code}
+looksLikeModuleName [] = False
+looksLikeModuleName (c:cs) = isUpper c && go cs
+  where go [] = True
+	go ('.':cs) = looksLikeModuleName cs
+	go (c:cs)   = (isAlphaNum c || c == '_') && go cs
+\end{code}
+
+Akin to @Prelude.words@, but sensitive to dquoted entities treating
+them as single words.
+
+\begin{code}
+toArgs :: String -> [String]
+toArgs "" = []
+toArgs s  =
+  case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
+    (w,aft) ->
+       (\ ws -> if null w then ws else w : ws) $
+       case aft of
+	 []           -> []
+	 (x:xs)
+	   | x /= '"'  -> toArgs xs
+	   | otherwise ->
+             case lex aft of
+	       ((str,rs):_) -> stripQuotes str : toArgs rs
+	       _            -> [aft]
+ where
+    -- strip away dquotes; assume first and last chars contain quotes.
+   stripQuotes :: String -> String
+   stripQuotes ('"':xs)  = init xs
+   stripQuotes xs        = xs
+\end{code}
+
+-- -----------------------------------------------------------------------------
+-- Floats
+
+\begin{code}
+readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
+readRational__ r = do 
+     (n,d,s) <- readFix r
+     (k,t)   <- readExp s
+     return ((n%1)*10^^(k-d), t)
+ where
+     readFix r = do
+	(ds,s)  <- lexDecDigits r
+	(ds',t) <- lexDotDigits s
+	return (read (ds++ds'), length ds', t)
+
+     readExp (e:s) | e `elem` "eE" = readExp' s
+     readExp s			   = return (0,s)
+
+     readExp' ('+':s) = readDec s
+     readExp' ('-':s) = do
+			(k,t) <- readDec s
+			return (-k,t)
+     readExp' s	      = readDec s
+
+     readDec s = do
+        (ds,r) <- nonnull isDigit s
+        return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
+                r)
+
+     lexDecDigits = nonnull isDigit
+
+     lexDotDigits ('.':s) = return (span isDigit s)
+     lexDotDigits s       = return ("",s)
+
+     nonnull p s = do (cs@(_:_),t) <- return (span p s)
+                      return (cs,t)
+
+readRational :: String -> Rational -- NB: *does* handle a leading "-"
+readRational top_s
+  = case top_s of
+      '-' : xs -> - (read_me xs)
+      xs       -> read_me xs
+  where
+    read_me s
+      = case (do { (x,"") <- readRational__ s ; return x }) of
+	  [x] -> x
+	  []  -> error ("readRational: no parse:"        ++ top_s)
+	  _   -> error ("readRational: ambiguous parse:" ++ top_s)
+
+
+-----------------------------------------------------------------------------
+-- Create a hierarchy of directories
+
+createDirectoryHierarchy :: FilePath -> IO ()
+createDirectoryHierarchy dir = do
+  b <- doesDirectoryExist dir
+  when (not b) $ do
+	createDirectoryHierarchy (directoryOf dir)
+	createDirectory dir
+
+-----------------------------------------------------------------------------
+-- Verify that the 'dirname' portion of a FilePath exists.
+-- 
+doesDirNameExist :: FilePath -> IO Bool
+doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
+
+-- -----------------------------------------------------------------------------
+-- Exception utils
+
+later = flip finally
+
+handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
+handleDyn = flip catchDyn
+
+handle :: (Exception -> IO a) -> IO a -> IO a
+#if __GLASGOW_HASKELL__ < 501
+handle = flip Exception.catchAllIO
+#else
+handle h f = f `Exception.catch` \e -> case e of
+    ExitException _ -> throw e
+    _               -> h e
+#endif
+
+-- --------------------------------------------------------------
+-- check existence & modification time at the same time
+
+modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
+modificationTimeIfExists f = do
+  (do t <- getModificationTime f; return (Just t))
+	`IO.catch` \e -> if isDoesNotExistError e 
+			then return Nothing 
+			else ioError e
+
+-- --------------------------------------------------------------
+-- Filename manipulation
+		
+-- Filenames are kept "normalised" inside GHC, using '/' as the path
+-- separator.  On Windows these functions will also recognise '\\' as
+-- the path separator, but will generally construct paths using '/'.
+
+type Suffix = String
+
+splitFilename :: String -> (String,Suffix)
+splitFilename f = splitLongestPrefix f (=='.')
+
+basenameOf :: FilePath -> String
+basenameOf = fst . splitFilename
+
+suffixOf :: FilePath -> Suffix
+suffixOf = snd . splitFilename
+
+joinFileExt :: String -> String -> FilePath
+joinFileExt path ""  = path
+joinFileExt path ext = path ++ '.':ext
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
+splitFilenameDir :: String -> (String,String)
+splitFilenameDir str
+   = let (dir, rest) = splitLongestPrefix str isPathSeparator
+	 (dir', rest') | null rest = (".", dir)
+		       | otherwise = (dir, rest)
+     in  (dir', rest')
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,Suffix)
+splitFilename3 str
+   = let (dir, rest) = splitFilenameDir str
+	 (name, ext) = splitFilename rest
+     in  (dir, name, ext)
+
+joinFileName :: String -> String -> FilePath
+joinFileName ""  fname = fname
+joinFileName "." fname = fname
+joinFileName dir ""    = dir
+joinFileName dir fname = dir ++ '/':fname
+
+-- split a string at the last character where 'pred' is True,
+-- returning a pair of strings. The first component holds the string
+-- up (but not including) the last character for which 'pred' returned
+-- True, the second whatever comes after (but also not including the
+-- last character).
+--
+-- If 'pred' returns False for all characters in the string, the original
+-- string is returned in the first component (and the second one is just
+-- empty).
+splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
+splitLongestPrefix str pred
+  | null r_pre = (str,           [])
+  | otherwise  = (reverse (tail r_pre), reverse r_suf)
+	-- 'tail' drops the char satisfying 'pred'
+  where 
+    (r_suf, r_pre) = break pred (reverse str)
+
+replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
+replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
+
+-- directoryOf strips the filename off the input string, returning
+-- the directory.
+directoryOf :: FilePath -> String
+directoryOf = fst . splitFilenameDir
+
+-- filenameOf strips the directory off the input string, returning
+-- the filename.
+filenameOf :: FilePath -> String
+filenameOf = snd . splitFilenameDir
+
+replaceFilenameDirectory :: FilePath -> String -> FilePath
+replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
+
+escapeSpaces :: String -> String
+escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
+
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif
+
+--------------------------------------------------------------
+-- * Search path
+--------------------------------------------------------------
+
+-- | The function splits the given string to substrings
+-- using the 'searchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split path
+  where
+    split :: String -> [String]
+    split s =
+      case rest' of
+        []     -> [chunk] 
+        _:rest -> chunk : split rest
+      where
+        chunk = 
+          case chunk' of
+#ifdef mingw32_HOST_OS
+            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
+#endif
+            _                                 -> chunk'
+
+        (chunk', rest') = break (==searchPathSeparator) s
+
+-- | A platform-specific character used to separate search path strings in 
+-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, 
+-- and a semicolon (\";\") on the Windows operating system.
+searchPathSeparator :: Char
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+searchPathSeparator = ';'
+#else
+searchPathSeparator = ':'
+#endif
+
+-----------------------------------------------------------------------------
+-- Convert filepath into platform / MSDOS form.
+
+-- We maintain path names in Unix form ('/'-separated) right until 
+-- the last moment.  On Windows we dos-ify them just before passing them
+-- to the Windows command.
+-- 
+-- The alternative, of using '/' consistently on Unix and '\' on Windows,
+-- proved quite awkward.  There were a lot more calls to platformPath,
+-- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
+-- interpreted a command line 'foo\baz' as 'foobaz'.
+
+normalisePath :: String -> String
+-- Just changes '\' to '/'
+
+pgmPath :: String		-- Directory string in Unix format
+	-> String		-- Program name with no directory separators
+				--	(e.g. copy /y)
+	-> String		-- Program invocation string in native format
+
+#if defined(mingw32_HOST_OS)
+--------------------- Windows version ------------------
+normalisePath xs = subst '\\' '/' xs
+pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
+platformPath p   = subst '/' '\\' p
+
+subst a b ls = map (\ x -> if x == a then b else x) ls
+#else
+--------------------- Non-Windows version --------------
+normalisePath xs   = xs
+pgmPath dir pgm    = dir ++ '/' : pgm
+platformPath stuff = stuff
+--------------------------------------------------------
 #endif
 \end{code}