Util.lhs 20 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
%
\section[Util]{Highly random utility functions}

\begin{code}
7
8
-- IF_NOT_GHC is meant to make this module useful outside the context of GHC
#define IF_NOT_GHC(a)
9
10

module Util (
11
#if NOT_USED
sof's avatar
sof committed
12
	-- The Eager monad
13
	Eager, thenEager, returnEager, mapEager, appEager, runEager,
14
#endif
sof's avatar
sof committed
15

16
	-- general list processing
17
	zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
18
        zipLazy, stretchZipWith,
19
	mapAndUnzip, mapAndUnzip3,
20
	nOfThem, lengthExceeds, isSingleton, only,
21
	snocView,
22
23
	isIn, isn'tIn,

24
25
26
	-- for-loop
	nTimes,

27
28
29
	-- maybe-ish
	unJust,

30
31
32
33
34
35
36
37
38
39
	-- 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)

	-- transitive closures
	transitiveClosure,

	-- accumulating
40
41
	mapAccumL, mapAccumR, mapAccumB, 
	foldl2, count,
42
43

	-- comparisons
44
	eqListBy, thenCmp, cmpList, prefixMatch, suffixMatch,
45

46
	-- strictness
47
	foldl', seqList,
48

49
50
51
	-- pairs
	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
52
	unzipWith
53

54
	, global
55
56
57
58
59
60

#if __GLASGOW_HASKELL__ <= 408
	, catchJust
	, ioErrors
	, throwTo
#endif
61

62
63
    ) where

rrt's avatar
rrt committed
64
#include "../includes/config.h"
65
66
67
#include "HsVersions.h"

import List		( zipWith4 )
68
import Maybe		( Maybe(..) )
69
import Panic		( panic )
70
import IOExts		( IORef, newIORef, unsafePerformIO )
71
import FastTypes
72
#if __GLASGOW_HASKELL__ <= 408
73
74
import Exception	( catchIO, justIoErrors, raiseInThread )
#endif
sof's avatar
sof committed
75

76
infixr 9 `thenCmp`
77
78
\end{code}

sof's avatar
sof committed
79
80
81
82
83
84
85
86
87
88
89
%************************************************************************
%*									*
\subsection{The Eager monad}
%*									*
%************************************************************************

The @Eager@ monad is just an encoding of continuation-passing style,
used to allow you to express "do this and then that", mainly to avoid
space leaks. It's done with a type synonym to save bureaucracy.

\begin{code}
90
91
#if NOT_USED

sof's avatar
sof committed
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
type Eager ans a = (a -> ans) -> ans

runEager :: Eager a a -> a
runEager m = m (\x -> x)

appEager :: Eager ans a -> (a -> ans) -> ans
appEager m cont = m cont

thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
thenEager m k cont = m (\r -> k r cont)

returnEager :: a -> Eager ans a
returnEager v cont = cont v

mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
mapEager f [] = returnEager []
mapEager f (x:xs) = f x			`thenEager` \ y ->
		    mapEager f xs	`thenEager` \ ys ->
		    returnEager (y:ys)
111
#endif
sof's avatar
sof committed
112
113
\end{code}

114
115
116
117
118
119
120
121
122
123
124
125
126
127
%************************************************************************
%*									*
\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}

128
129
130
131
132
133
134
%************************************************************************
%*									*
\subsection{Maybe-ery}
%*									*
%************************************************************************

\begin{code}
135
136
137
unJust :: String -> Maybe a -> a
unJust who (Just x) = x
unJust who Nothing  = panic ("unJust of Nothing, called by " ++ who)
138
\end{code}
139

140
141
142
143
144
145
%************************************************************************
%*									*
\subsection[Utils-lists]{General list processing}
%*									*
%************************************************************************

146
147
148
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?
149
150

\begin{code}
151
152
153
154
zipEqual	:: String -> [a] -> [b] -> [(a,b)]
zipWithEqual	:: String -> (a->b->c) -> [a]->[b]->[c]
zipWith3Equal	:: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith4Equal	:: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
155
156

#ifndef DEBUG
157
158
159
160
zipEqual      _ = zip
zipWithEqual  _ = zipWith
zipWith3Equal _ = zipWith3
zipWith4Equal _ = zipWith4
161
#else
162
163
zipEqual msg []     []     = []
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
164
zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
165
166
167

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
zipWithEqual msg _ [] []	=  []
168
zipWithEqual msg _ _ _		=  panic ("zipWithEqual: unequal lists:"++msg)
169
170
171
172

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
				=  z a b c : zipWith3Equal msg z as bs cs
zipWith3Equal msg _ [] []  []	=  []
173
zipWith3Equal msg _ _  _   _	=  panic ("zipWith3Equal: unequal lists:"++msg)
174
175
176
177

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
				=  z a b c d : zipWith4Equal msg z as bs cs ds
zipWith4Equal msg _ [] [] [] []	=  []
178
zipWith4Equal msg _ _  _  _  _	=  panic ("zipWith4Equal: unequal lists:"++msg)
179
180
181
#endif
\end{code}

182
183
184
185
186
187
188
189
\begin{code}
-- zipLazy is lazy in the second list (observe the ~)

zipLazy :: [a] -> [b] -> [(a,b)]
zipLazy [] ys = []
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
\end{code}

190
191

\begin{code}
192
193
194
195
196
197
198
199
200
201
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
202
203
204
\end{code}


205
206
207
208
209
210
211
212
213
214
\begin{code}
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])

mapAndUnzip f [] = ([],[])
mapAndUnzip f (x:xs)
  = let
	(r1,  r2)  = f x
	(rs1, rs2) = mapAndUnzip f xs
    in
    (r1:rs1, r2:rs2)
215
216
217
218
219
220
221
222
223
224

mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])

mapAndUnzip3 f [] = ([],[],[])
mapAndUnzip3 f (x:xs)
  = let
	(r1,  r2,  r3)  = f x
	(rs1, rs2, rs3) = mapAndUnzip3 f xs
    in
    (r1:rs1, r2:rs2, r3:rs3)
225
226
\end{code}

227
228
\begin{code}
nOfThem :: Int -> a -> [a]
sof's avatar
sof committed
229
nOfThem n thing = replicate n thing
230
231

lengthExceeds :: [a] -> Int -> Bool
232
233
234
-- (lengthExceeds xs n) is True if   length xs > n
(x:xs)	`lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
[]	`lengthExceeds` n = n < 0
235
236
237
238

isSingleton :: [a] -> Bool
isSingleton [x] = True
isSingleton  _  = False
239
240
241
242
243
244
245

only :: [a] -> a
#ifdef DEBUG
only [a] = a
#else
only (a:_) = a
#endif
246
247
\end{code}

248
249
250
251
252
253
254
255
\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}

256
Debugging/specialising versions of \tr{elem} and \tr{notElem}
257

258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
\begin{code}
isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool

# ifndef DEBUG
isIn    msg x ys = elem__    x ys
isn'tIn msg x ys = notElem__ x ys

--these are here to be SPECIALIZEd (automagically)
elem__ _ []	= False
elem__ x (y:ys)	= x==y || elem__ x ys

notElem__ x []	   =  True
notElem__ x (y:ys) =  x /= y && notElem__ x ys

# else {- DEBUG -}
isIn msg x ys
274
  = elem (_ILIT 0) x ys
275
276
277
  where
    elem i _ []	    = False
    elem i x (y:ys)
278
279
      | i ># _ILIT 100 = panic ("Over-long elem in: " ++ msg)
      | otherwise	 = x == y || elem (i +# _ILIT(1)) x ys
280
281

isn'tIn msg x ys
282
  = notElem (_ILIT 0) x ys
283
284
285
  where
    notElem i x [] =  True
    notElem i x (y:ys)
286
287
      | i ># _ILIT 100 = panic ("Over-long notElem in: " ++ msg)
      | otherwise	 =  x /= y && notElem (i +# _ILIT(1)) x ys
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305

# endif {- DEBUG -}

\end{code}

%************************************************************************
%*									*
\subsection[Utils-sorting]{Sorting}
%*									*
%************************************************************************

%************************************************************************
%*									*
\subsubsection[Utils-quicksorting]{Quicksorts}
%*									*
%************************************************************************

\begin{code}
306
307
#if NOT_USED

308
309
310
311
312
313
314
315
316
317
318
319
-- 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
320
#endif
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
\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
346
-- rlt contains things less than x,
347
348
349
350
351
352
353
354
355
356
357
358
-- 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
359
    else
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
	-- 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}
387
#if NOT_USED
388
mergesort :: (a -> a -> Ordering) -> [a] -> [a]
389
390
391

mergesort cmp xs = merge_lists (split_into_runs [] xs)
  where
392
393
    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  }
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408

    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
409
410
411
	  EQ  -> x : y : (merge xs ys)
	  LT  -> x : (merge xs yl)
	  GT -> y : (merge xl ys)
412
#endif
413
414
415
416
417
418
419
420
421
422
423
424
425
426
\end{code}

%************************************************************************
%*									*
\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
%*									*
%************************************************************************

\begin{display}
Date: Mon, 3 May 93 20:45:23 +0200
From: Carsten Kehler Holst <kehler@cs.chalmers.se>
To: partain@dcs.gla.ac.uk
Subject: natural merge sort beats quick sort [ and it is prettier ]

427
Here is a piece of Haskell code that I'm rather fond of. See it as an
428
429
attempt to get rid of the ridiculous quick-sort routine. group is
quite useful by itself I think it was John's idea originally though I
430
believe the lazy version is due to me [surprisingly complicated].
431
432
gamma [used to be called] is called gamma because I got inspired by
the Gamma calculus. It is not very close to the calculus but does
433
434
435
behave less sequentially than both foldr and foldl. One could imagine
a version of gamma that took a unit element as well thereby avoiding
the problem with empty lists.
436
437
438
439
440
441

I've tried this code against

   1) insertion sort - as provided by haskell
   2) the normal implementation of quick sort
   3) a deforested version of quick sort due to Jan Sparud
442
   4) a super-optimized-quick-sort of Lennart's
443
444
445
446

If the list is partially sorted both merge sort and in particular
natural merge sort wins. If the list is random [ average length of
rising subsequences = approx 2 ] mergesort still wins and natural
447
merge sort is marginally beaten by Lennart's soqs. The space
448
consumption of merge sort is a bit worse than Lennart's quick sort
449
450
451
approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
fpca article ] isn't used because of group.

452
have fun
453
454
455
456
457
Carsten
\end{display}

\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
458

459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
{-
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) 
	| 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:
478
group p [] = [[]]
479
group p (x:xs) =
480
481
   let ((h1:t1):tt1) = group p xs
       (t,tt) = if null xs then ([],[]) else
482
483
		if x `p` h1 then (h1:t1,tt1) else
		   ([], (h1:t1):tt1)
484
   in ((x:t):tt)
485
-}
486
487
488
489

generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
generalMerge p xs [] = xs
generalMerge p [] ys = ys
490
generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
491
			     | otherwise = y : generalMerge p (x:xs) ys
492
493
494
495
496
497
498
499
500
501
502
503

-- gamma is now called balancedFold

balancedFold :: (a -> a -> a) -> [a] -> a
balancedFold f [] = error "can't reduce an empty list using balancedFold"
balancedFold f [x] = x
balancedFold f l  = balancedFold f (balancedFold' f l)

balancedFold' :: (a -> a -> a) -> [a] -> [a]
balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
balancedFold' f xs = xs

504
505
506
507
508
generalMergeSort p [] = []
generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs

generalNaturalMergeSort p [] = []
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529

mergeSort, naturalMergeSort :: Ord a => [a] -> [a]

mergeSort = generalMergeSort (<=)
naturalMergeSort = generalNaturalMergeSort (<=)

mergeSortLe le = generalMergeSort le
naturalMergeSortLe le = generalNaturalMergeSort le
\end{code}

%************************************************************************
%*									*
\subsection[Utils-transitive-closure]{Transitive closure}
%*									*
%************************************************************************

This algorithm for transitive closure is straightforward, albeit quadratic.

\begin{code}
transitiveClosure :: (a -> [a])		-- Successor function
		  -> (a -> a -> Bool)	-- Equality predicate
530
		  -> [a]
531
532
533
		  -> [a]		-- The transitive closure

transitiveClosure succ eq xs
534
 = go [] xs
535
 where
536
537
538
   go done [] 			   = done
   go done (x:xs) | x `is_in` done = go done xs
   		  | otherwise      = go (x:done) (succ x ++ xs)
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594

   x `is_in` []                 = False
   x `is_in` (y:ys) | eq x y    = True
  		    | otherwise = x `is_in` ys
\end{code}

%************************************************************************
%*									*
\subsection[Utils-accum]{Accumulating}
%*									*
%************************************************************************

@mapAccumL@ behaves like a combination
of  @map@ and @foldl@;
it applies a function to each element of a list, passing an accumulating
parameter from left to right, and returning a final value of this
accumulator together with the new list.

\begin{code}
mapAccumL :: (acc -> x -> (acc, y)) 	-- Function of elt of input list
					-- and accumulator, returning new
					-- accumulator and elt of result list
	    -> acc 		-- Initial accumulator
	    -> [x] 		-- Input list
	    -> (acc, [y])		-- Final accumulator and result list

mapAccumL f b []     = (b, [])
mapAccumL f b (x:xs) = (b'', x':xs') where
					  (b', x') = f b x
					  (b'', xs') = mapAccumL f b' xs
\end{code}

@mapAccumR@ does the same, but working from right to left instead.  Its type is
the same as @mapAccumL@, though.

\begin{code}
mapAccumR :: (acc -> x -> (acc, y)) 	-- Function of elt of input list
					-- and accumulator, returning new
					-- accumulator and elt of result list
	    -> acc 		-- Initial accumulator
	    -> [x] 		-- Input list
	    -> (acc, [y])		-- Final accumulator and result list

mapAccumR f b []     = (b, [])
mapAccumR f b (x:xs) = (b'', x':xs') where
					  (b'', x') = f b' x
					  (b', xs') = mapAccumR f b xs
\end{code}

Here is the bi-directional version, that works from both left and right.

\begin{code}
mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
      				-- Function of elt of input list
      				-- and accumulator, returning new
      				-- accumulator and elt of result list
595
596
597
598
	  -> accl 			-- Initial accumulator from left
	  -> accr 			-- Initial accumulator from right
	  -> [x] 			-- Input list
	  -> (accl, accr, [y])	-- Final accumulators and result list
599
600
601
602
603
604
605
606

mapAccumB f a b []     = (a,b,[])
mapAccumB f a b (x:xs) = (a'',b'',y:ys)
   where
	(a',b'',y)  = f a b' x
	(a'',b',ys) = mapAccumB f a' b xs
\end{code}

607
608
609
610
611
612
613
614
615
616
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}

617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
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
\end{code}

Count the number of times a predicate is true

\begin{code}
count :: (a -> Bool) -> [a] -> Int
count p [] = 0
count p (x:xs) | p x       = 1 + count p xs
	       | otherwise = count p xs
\end{code}


635
636
637
638
639
640
%************************************************************************
%*									*
\subsection[Utils-comparison]{Comparisons}
%*									*
%************************************************************************

641
\begin{code}
642
643
644
645
646
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

647
thenCmp :: Ordering -> Ordering -> Ordering
648
{-# INLINE thenCmp #-}
649
thenCmp EQ   any = any
650
651
thenCmp other any = other

652
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
653
654
    -- `cmpList' uses a user-specified comparer

655
656
657
cmpList cmp []     [] = EQ
cmpList cmp []     _  = LT
cmpList cmp _      [] = GT
658
cmpList cmp (a:as) (b:bs)
659
  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
660
661
\end{code}

662
\begin{code}
663
664
665
666
667
668
prefixMatch :: Eq a => [a] -> [a] -> Bool
prefixMatch [] _str = True
prefixMatch _pat [] = False
prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
			  | otherwise = False

669
670
suffixMatch :: Eq a => [a] -> [a] -> Bool
suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
\end{code}

%************************************************************************
%*									*
\subsection[Utils-pairs]{Pairs}
%*									*
%************************************************************************

The following are curried versions of @fst@ and @snd@.

\begin{code}
cfst :: a -> b -> a	-- stranal-sem only (Note)
cfst x y = x
\end{code}

The following provide us higher order functions that, when applied
to a function, operate on pairs.

\begin{code}
applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
applyToPair (f,g) (x,y) = (f x, g y)

applyToFst :: (a -> c) -> (a,b)-> (c,b)
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)
702
		       where (u,v) = foldPair fg ab abs
703
704
705
706
707
708
709
\end{code}

\begin{code}
unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
\end{code}

710
711
712
713
\begin{code}
seqList :: [a] -> b -> b
seqList [] b = b
seqList (x:xs) b = x `seq` seqList xs b
714
\end{code}
715
716
717
718
719
720
721
722

Global variables:

\begin{code}
global :: a -> IORef a
global a = unsafePerformIO (newIORef a)
\end{code}

723
724
725
726
727
728
729
730
731
Compatibility stuff:

\begin{code}
#if __GLASGOW_HASKELL__ <= 408
catchJust = catchIO
ioErrors  = justIoErrors
throwTo   = raiseInThread
#endif
\end{code}