Util.lhs 27.2 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The University of Glasgow 1992-2002
4
5
6
%

\begin{code}
batterseapower's avatar
batterseapower committed
7
-- | Highly random utility functions
8
module Util (
batterseapower's avatar
batterseapower committed
9
        -- * Flags dependent on the compiler build
10
        ghciSupported, debugIsOn, ghciTablesNextToCode, picIsOn,
Ian Lynagh's avatar
Ian Lynagh committed
11
        isWindowsHost, isWindowsTarget, isDarwinTarget,
sof's avatar
sof committed
12

batterseapower's avatar
batterseapower committed
13
        -- * General list processing
Ian Lynagh's avatar
Ian Lynagh committed
14
        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
15
        zipLazy, stretchZipWith,
batterseapower's avatar
batterseapower committed
16
17
18
        
        unzipWith,
        
Ian Lynagh's avatar
Ian Lynagh committed
19
20
21
        mapFst, mapSnd,
        mapAndUnzip, mapAndUnzip3,
        nOfThem, filterOut, partitionWith, splitEithers,
batterseapower's avatar
batterseapower committed
22
23
        
        foldl1', foldl2, count, all2,
24

Ian Lynagh's avatar
Ian Lynagh committed
25
26
27
28
29
30
31
        lengthExceeds, lengthIs, lengthAtLeast,
        listLengthCmp, atLength, equalLength, compareLength,

        isSingleton, only, singleton,
        notNull, snocView,

        isIn, isn'tIn,
32

batterseapower's avatar
batterseapower committed
33
34
35
36
        -- * List operations controlled by another list
        takeList, dropList, splitAtList, split,

        -- * For loop
Ian Lynagh's avatar
Ian Lynagh committed
37
        nTimes,
sof's avatar
sof committed
38

batterseapower's avatar
batterseapower committed
39
        -- * Sorting
Ian Lynagh's avatar
Ian Lynagh committed
40
        sortLe, sortWith, on,
41

batterseapower's avatar
batterseapower committed
42
        -- * Comparisons
Ian Lynagh's avatar
Ian Lynagh committed
43
44
45
        isEqual, eqListBy,
        thenCmp, cmpList, maybePrefixMatch,
        removeSpaces,
46

batterseapower's avatar
batterseapower committed
47
48
        -- * Transitive closures
        transitiveClosure,
49

batterseapower's avatar
batterseapower committed
50
51
        -- * Strictness
        seqList,
52

batterseapower's avatar
batterseapower committed
53
        -- * Module names
Ian Lynagh's avatar
Ian Lynagh committed
54
        looksLikeModuleName,
55

batterseapower's avatar
batterseapower committed
56
        -- * Argument processing
Ian Lynagh's avatar
Ian Lynagh committed
57
        getCmd, toCmdArgs, toArgs,
58

batterseapower's avatar
batterseapower committed
59
        -- * Floating point
Ian Lynagh's avatar
Ian Lynagh committed
60
        readRational,
61

batterseapower's avatar
batterseapower committed
62
        -- * IO-ish utilities
Ian Lynagh's avatar
Ian Lynagh committed
63
64
65
        createDirectoryHierarchy,
        doesDirNameExist,
        modificationTimeIfExists,
66

batterseapower's avatar
batterseapower committed
67
68
69
        global, consIORef,

        -- * Filenames and paths
Ian Lynagh's avatar
Ian Lynagh committed
70
71
72
73
        Suffix,
        splitLongestPrefix,
        escapeSpaces,
        parseSearchPath,
74
        Direction(..), reslash,
75
76
    ) where

77
78
#include "HsVersions.h"

79
import Panic
80

Ian Lynagh's avatar
Ian Lynagh committed
81
82
83
import Data.IORef       ( IORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef       ( readIORef, writeIORef )
84
import Data.List        hiding (group)
85

86
import qualified Data.List as List ( elem )
87
#ifdef DEBUG
88
import qualified Data.List as List ( notElem )
89
import FastTypes
90
#endif
sof's avatar
sof committed
91

Ian Lynagh's avatar
Ian Lynagh committed
92
import Control.Monad    ( unless )
93
import System.IO.Error as IO ( catch, isDoesNotExistError )
Ian Lynagh's avatar
Ian Lynagh committed
94
import System.Directory ( doesDirectoryExist, createDirectory,
Simon Marlow's avatar
Simon Marlow committed
95
                          getModificationTime )
96
import System.FilePath
Ian Lynagh's avatar
Ian Lynagh committed
97
98
99
import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Ratio       ( (%) )
import System.Time      ( ClockTime )
100

101
infixr 9 `thenCmp`
102
103
\end{code}

104
105
%************************************************************************
%*                                                                      *
106
\subsection{Is DEBUG on, are we on Windows, etc?}
107
108
109
%*                                                                      *
%************************************************************************

110
111
112
113
114
115
116
117
118
These booleans are global constants, set by CPP flags.  They allow us to
recompile a single module (this one) to change whether or not debug output
appears. They sometimes let us avoid even running CPP elsewhere.

It's important that the flags are literal constants (True/False). Then,
with -0, tests of the flags in other modules will simplify to the correct
branch of the conditional, thereby dropping debug code altogether when
the flags are off.

119
\begin{code}
120
121
122
123
124
125
126
ghciSupported :: Bool
#ifdef GHCI
ghciSupported = True
#else
ghciSupported = False
#endif

127
128
129
130
131
132
debugIsOn :: Bool
#ifdef DEBUG
debugIsOn = True
#else
debugIsOn = False
#endif
133

Ian Lynagh's avatar
Ian Lynagh committed
134
135
136
137
138
139
140
ghciTablesNextToCode :: Bool
#ifdef GHCI_TABLES_NEXT_TO_CODE
ghciTablesNextToCode = True
#else
ghciTablesNextToCode = False
#endif

Ian Lynagh's avatar
Ian Lynagh committed
141
142
143
144
145
146
147
picIsOn :: Bool
#ifdef __PIC__
picIsOn = True
#else
picIsOn = False
#endif

148
149
150
151
152
153
isWindowsHost :: Bool
#ifdef mingw32_HOST_OS
isWindowsHost = True
#else
isWindowsHost = False
#endif
Ian Lynagh's avatar
Ian Lynagh committed
154
155
156
157
158
159
160
161
162
163
164
165
166
167

isWindowsTarget :: Bool
#ifdef mingw32_TARGET_OS
isWindowsTarget = True
#else
isWindowsTarget = False
#endif

isDarwinTarget :: Bool
#ifdef darwin_TARGET_OS
isDarwinTarget = True
#else
isDarwinTarget = False
#endif
168
169
\end{code}

170
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
171
%*                                                                      *
172
\subsection{A for loop}
Ian Lynagh's avatar
Ian Lynagh committed
173
%*                                                                      *
174
175
176
%************************************************************************

\begin{code}
batterseapower's avatar
batterseapower committed
177
-- | Compose a function with itself n times.  (nth rather than twice)
178
179
180
181
182
183
nTimes :: Int -> (a -> a) -> (a -> a)
nTimes 0 _ = id
nTimes 1 f = f
nTimes n f = f . nTimes (n-1) f
\end{code}

184
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
185
%*                                                                      *
186
\subsection[Utils-lists]{General list processing}
Ian Lynagh's avatar
Ian Lynagh committed
187
%*                                                                      *
188
189
%************************************************************************

190
191
\begin{code}
filterOut :: (a->Bool) -> [a] -> [a]
batterseapower's avatar
batterseapower committed
192
-- ^ Like filter, only it reverses the sense of the test
Ian Lynagh's avatar
Ian Lynagh committed
193
filterOut _ [] = []
194
filterOut p (x:xs) | p x       = filterOut p xs
Ian Lynagh's avatar
Ian Lynagh committed
195
                   | otherwise = x : filterOut p xs
196
197

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
batterseapower's avatar
batterseapower committed
198
-- ^ Uses a function to determine which of two output lists an input element should join
Ian Lynagh's avatar
Ian Lynagh committed
199
partitionWith _ [] = ([],[])
200
partitionWith f (x:xs) = case f x of
Ian Lynagh's avatar
Ian Lynagh committed
201
202
203
                         Left  b -> (b:bs, cs)
                         Right c -> (bs, c:cs)
    where (bs,cs) = partitionWith f xs
204

205
splitEithers :: [Either a b] -> ([a], [b])
batterseapower's avatar
batterseapower committed
206
-- ^ Teases a list of 'Either's apart into two lists
207
208
splitEithers [] = ([],[])
splitEithers (e : es) = case e of
Ian Lynagh's avatar
Ian Lynagh committed
209
210
211
                        Left x -> (x:xs, ys)
                        Right y -> (xs, y:ys)
    where (xs,ys) = splitEithers es
212
213
\end{code}

214
215
216
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?
217
218

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
219
220
221
222
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]
223
224

#ifndef DEBUG
225
226
227
228
zipEqual      _ = zip
zipWithEqual  _ = zipWith
zipWith3Equal _ = zipWith3
zipWith4Equal _ = zipWith4
229
#else
230
zipEqual _   []     []     = []
231
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
232
zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
233
234

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
235
zipWithEqual _   _ [] []        =  []
Ian Lynagh's avatar
Ian Lynagh committed
236
zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
237
238

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
Ian Lynagh's avatar
Ian Lynagh committed
239
                                =  z a b c : zipWith3Equal msg z as bs cs
240
zipWith3Equal _   _ [] []  []   =  []
Ian Lynagh's avatar
Ian Lynagh committed
241
zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
242
243

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
Ian Lynagh's avatar
Ian Lynagh committed
244
                                =  z a b c d : zipWith4Equal msg z as bs cs ds
245
zipWith4Equal _   _ [] [] [] [] =  []
Ian Lynagh's avatar
Ian Lynagh committed
246
zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
247
248
249
#endif
\end{code}

250
\begin{code}
batterseapower's avatar
batterseapower committed
251
-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
252
zipLazy :: [a] -> [b] -> [(a,b)]
Ian Lynagh's avatar
Ian Lynagh committed
253
zipLazy []     _       = []
254
255
256
257
258
259
-- We want to write this, but with GHC 6.4 we get a warning, so it
-- doesn't validate:
-- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
-- so we write this instead:
zipLazy (x:xs) zs = let y : ys = zs
                    in (x,y) : zipLazy xs ys
260
261
\end{code}

262
263

\begin{code}
264
stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
batterseapower's avatar
batterseapower committed
265
266
-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
-- the places where @p@ returns @True@
267

Ian Lynagh's avatar
Ian Lynagh committed
268
stretchZipWith _ _ _ []     _ = []
269
270
271
stretchZipWith p z f (x:xs) ys
  | p x       = f x z : stretchZipWith p z f xs ys
  | otherwise = case ys of
Ian Lynagh's avatar
Ian Lynagh committed
272
273
                []     -> []
                (y:ys) -> f x y : stretchZipWith p z f xs ys
274
275
276
\end{code}


277
\begin{code}
278
279
280
281
282
283
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]

284
285
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])

Ian Lynagh's avatar
Ian Lynagh committed
286
mapAndUnzip _ [] = ([], [])
287
mapAndUnzip f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
288
289
  = let (r1,  r2)  = f x
        (rs1, rs2) = mapAndUnzip f xs
290
291
    in
    (r1:rs1, r2:rs2)
292
293
294

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

Ian Lynagh's avatar
Ian Lynagh committed
295
mapAndUnzip3 _ [] = ([], [], [])
296
mapAndUnzip3 f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
297
298
  = let (r1,  r2,  r3)  = f x
        (rs1, rs2, rs3) = mapAndUnzip3 f xs
299
300
    in
    (r1:rs1, r2:rs2, r3:rs3)
301
302
\end{code}

303
304
\begin{code}
nOfThem :: Int -> a -> [a]
sof's avatar
sof committed
305
nOfThem n thing = replicate n thing
306

batterseapower's avatar
batterseapower committed
307
-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
sof's avatar
sof committed
308
--
batterseapower's avatar
batterseapower committed
309
-- @
sof's avatar
sof committed
310
311
312
313
--  atLength atLenPred atEndPred ls n
--   | n < 0         = atLenPred n
--   | length ls < n = atEndPred (n - length ls)
--   | otherwise     = atLenPred (drop n ls)
batterseapower's avatar
batterseapower committed
314
-- @
sof's avatar
sof committed
315
316
317
318
319
atLength :: ([a] -> b)
         -> (Int -> b)
         -> [a]
         -> Int
         -> b
Ian Lynagh's avatar
Ian Lynagh committed
320
321
atLength atLenPred atEndPred ls n
  | n < 0     = atEndPred n
sof's avatar
sof committed
322
323
324
325
326
327
  | otherwise = go n ls
  where
    go n [] = atEndPred n
    go 0 ls = atLenPred ls
    go n (_:xs) = go (n-1) xs

batterseapower's avatar
batterseapower committed
328
329
-- Some special cases of atLength:

330
lengthExceeds :: [a] -> Int -> Bool
batterseapower's avatar
batterseapower committed
331
-- ^ > (lengthExceeds xs n) = (length xs > n)
sof's avatar
sof committed
332
lengthExceeds = atLength notNull (const False)
sof's avatar
sof committed
333
334

lengthAtLeast :: [a] -> Int -> Bool
sof's avatar
sof committed
335
lengthAtLeast = atLength notNull (== 0)
sof's avatar
sof committed
336
337
338
339

lengthIs :: [a] -> Int -> Bool
lengthIs = atLength null (==0)

Ian Lynagh's avatar
Ian Lynagh committed
340
341
listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp = atLength atLen atEnd
sof's avatar
sof committed
342
343
344
345
346
347
348
349
 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
350

351
equalLength :: [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
352
equalLength []     []     = True
353
equalLength (_:xs) (_:ys) = equalLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
354
equalLength _      _      = False
355
356

compareLength :: [a] -> [b] -> Ordering
Ian Lynagh's avatar
Ian Lynagh committed
357
compareLength []     []     = EQ
358
compareLength (_:xs) (_:ys) = compareLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
359
360
compareLength []     _      = LT
compareLength _      []     = GT
361
362

----------------------------
363
364
365
singleton :: a -> [a]
singleton x = [x]

366
isSingleton :: [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
367
368
isSingleton [_] = True
isSingleton _   = False
369

sof's avatar
sof committed
370
371
372
373
notNull :: [a] -> Bool
notNull [] = False
notNull _  = True

374
375
376
377
378
379
only :: [a] -> a
#ifdef DEBUG
only [a] = a
#else
only (a:_) = a
#endif
Ian Lynagh's avatar
Ian Lynagh committed
380
only _ = panic "Util: only"
381
382
383
\end{code}

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

385
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
386
isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
387
388

# ifndef DEBUG
Ian Lynagh's avatar
Ian Lynagh committed
389
390
isIn    _msg x ys = elem__    x ys
isn'tIn _msg x ys = notElem__ x ys
391
392

--these are here to be SPECIALIZEd (automagically)
Ian Lynagh's avatar
Ian Lynagh committed
393
394
395
elem__ :: Eq a => a -> [a] -> Bool
elem__ _ []     = False
elem__ x (y:ys) = x == y || elem__ x ys
396

Ian Lynagh's avatar
Ian Lynagh committed
397
398
399
notElem__ :: Eq a => a -> [a] -> Bool
notElem__ _ []     = True
notElem__ x (y:ys) = x /= y && notElem__ x ys
400

ross's avatar
ross committed
401
# else /* DEBUG */
402
isIn msg x ys
403
  = elem (_ILIT(0)) x ys
404
  where
405
    elem _ _ []        = False
406
    elem i x (y:ys)
407
408
409
      | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
                                (x `List.elem` (y:ys))
      | otherwise       = x == y || elem (i +# _ILIT(1)) x ys
410
411

isn'tIn msg x ys
412
  = notElem (_ILIT(0)) x ys
413
  where
414
    notElem _ _ [] =  True
415
    notElem i x (y:ys)
416
417
      | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
                                (x `List.notElem` (y:ys))
418
      | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
ross's avatar
ross committed
419
# endif /* DEBUG */
420
421
422
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
423
%*                                                                      *
424
\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
Ian Lynagh's avatar
Ian Lynagh committed
425
%*                                                                      *
426
427
428
429
430
431
432
433
%************************************************************************

\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 ]

434
Here is a piece of Haskell code that I'm rather fond of. See it as an
435
436
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
437
believe the lazy version is due to me [surprisingly complicated].
438
439
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
440
441
442
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.
443
444
445
446
447
448

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
449
   4) a super-optimized-quick-sort of Lennart's
450
451
452
453

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
454
merge sort is marginally beaten by Lennart's soqs. The space
455
consumption of merge sort is a bit worse than Lennart's quick sort
456
457
458
approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
fpca article ] isn't used because of group.

459
have fun
460
461
462
463
464
Carsten
\end{display}

\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
Ian Lynagh's avatar
Ian Lynagh committed
465
-- Given a <= function, group finds maximal contiguous up-runs
466
467
468
469
470
471
-- 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.
472

Ian Lynagh's avatar
Ian Lynagh committed
473
group _ []     = []
474
475
476
group p (x:xs) = group' xs x x (x :)
  where
    group' []     _     _     s  = [s []]
Ian Lynagh's avatar
Ian Lynagh committed
477
478
479
480
481
482
    group' (x:xs) x_min x_max 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 :)
        -- NB: the 'not' is essential for stablity
        --     x `p` x_min would reverse equal elements
483
484

generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
Ian Lynagh's avatar
Ian Lynagh committed
485
486
487
488
generalMerge _ xs [] = xs
generalMerge _ [] ys = ys
generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
                             | otherwise = y : generalMerge p (x:xs) ys
489
490
491
492

-- gamma is now called balancedFold

balancedFold :: (a -> a -> a) -> [a] -> a
Ian Lynagh's avatar
Ian Lynagh committed
493
494
balancedFold _ [] = error "can't reduce an empty list using balancedFold"
balancedFold _ [x] = x
495
496
497
498
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
Ian Lynagh's avatar
Ian Lynagh committed
499
balancedFold' _ xs = xs
500

Ian Lynagh's avatar
Ian Lynagh committed
501
502
generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
generalNaturalMergeSort _ [] = []
503
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
504

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

509
510
511
512
513
514
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]

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

mergeSortLe le = generalMergeSort le
515
516
#endif

517
518
sortLe :: (a->a->Bool) -> [a] -> [a]
sortLe le = generalNaturalMergeSort le
519
520
521
522

sortWith :: Ord b => (a->b) -> [a] -> [a]
sortWith get_key xs = sortLe le xs
  where
Ian Lynagh's avatar
Ian Lynagh committed
523
    x `le` y = get_key x < get_key y
524
525
526
527

on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
on cmp sel = \x y -> sel x `cmp` sel y

528
529
530
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
531
%*                                                                      *
532
\subsection[Utils-transitive-closure]{Transitive closure}
Ian Lynagh's avatar
Ian Lynagh committed
533
%*                                                                      *
534
535
536
537
538
%************************************************************************

This algorithm for transitive closure is straightforward, albeit quadratic.

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
539
540
541
542
transitiveClosure :: (a -> [a])         -- Successor function
                  -> (a -> a -> Bool)   -- Equality predicate
                  -> [a]
                  -> [a]                -- The transitive closure
543
544

transitiveClosure succ eq xs
545
 = go [] xs
546
 where
Ian Lynagh's avatar
Ian Lynagh committed
547
   go done []                      = done
548
   go done (x:xs) | x `is_in` done = go done xs
Ian Lynagh's avatar
Ian Lynagh committed
549
                  | otherwise      = go (x:done) (succ x ++ xs)
550

Ian Lynagh's avatar
Ian Lynagh committed
551
   _ `is_in` []                 = False
552
   x `is_in` (y:ys) | eq x y    = True
Ian Lynagh's avatar
Ian Lynagh committed
553
                    | otherwise = x `is_in` ys
554
555
556
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
557
%*                                                                      *
558
\subsection[Utils-accum]{Accumulating}
Ian Lynagh's avatar
Ian Lynagh committed
559
%*                                                                      *
560
561
%************************************************************************

562
563
564
565
A combination of foldl with zip.  It works with equal length lists.

\begin{code}
foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
Ian Lynagh's avatar
Ian Lynagh committed
566
foldl2 _ z [] [] = z
567
foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
Ian Lynagh's avatar
Ian Lynagh committed
568
foldl2 _ _ _      _      = panic "Util: foldl2"
569
570

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
571
-- True if the lists are the same length, and
572
-- all corresponding elements satisfy the predicate
Ian Lynagh's avatar
Ian Lynagh committed
573
all2 _ []     []     = True
574
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
Ian Lynagh's avatar
Ian Lynagh committed
575
all2 _ _      _      = False
576
577
578
579
580
581
\end{code}

Count the number of times a predicate is true

\begin{code}
count :: (a -> Bool) -> [a] -> Int
Ian Lynagh's avatar
Ian Lynagh committed
582
count _ [] = 0
583
count p (x:xs) | p x       = 1 + count p xs
Ian Lynagh's avatar
Ian Lynagh committed
584
               | otherwise = count p xs
585
586
\end{code}

sof's avatar
sof committed
587
588
589
590
591
592
@splitAt@, @take@, and @drop@ but with length of another
list giving the break-off point:

\begin{code}
takeList :: [b] -> [a] -> [a]
takeList [] _ = []
Ian Lynagh's avatar
Ian Lynagh committed
593
takeList (_:xs) ls =
sof's avatar
sof committed
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
   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

611
snocView :: [a] -> Maybe ([a],a)
Ian Lynagh's avatar
Ian Lynagh committed
612
        -- Split off the last element
613
614
snocView [] = Nothing
snocView xs = go [] xs
Ian Lynagh's avatar
Ian Lynagh committed
615
616
617
618
619
            where
                -- Invariant: second arg is non-empty
              go acc [x]    = Just (reverse acc, x)
              go acc (x:xs) = go (x:acc) xs
              go _   []     = panic "Util: snocView"
620

621
622
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
623
624
                []     -> [chunk]
                _:rest -> chunk : split c rest
625
  where (chunk, rest) = break (==c) s
sof's avatar
sof committed
626
627
\end{code}

628

629
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
630
%*                                                                      *
631
\subsection[Utils-comparison]{Comparisons}
Ian Lynagh's avatar
Ian Lynagh committed
632
%*                                                                      *
633
634
%************************************************************************

635
\begin{code}
636
637
638
639
640
641
642
643
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 #-}
Ian Lynagh's avatar
Ian Lynagh committed
644
645
thenCmp EQ       ordering = ordering
thenCmp ordering _        = ordering
646

647
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
648
eqListBy _  []     []     = True
649
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
Ian Lynagh's avatar
Ian Lynagh committed
650
eqListBy _  _      _      = False
651

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

Ian Lynagh's avatar
Ian Lynagh committed
655
656
657
cmpList _   []     [] = EQ
cmpList _   []     _  = LT
cmpList _   _      [] = 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
-- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
-- This definition can be removed once we require at least 6.8 to build.
665
666
667
668
669
670
671
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch []    rest = Just rest
maybePrefixMatch (_:_) []   = Nothing
maybePrefixMatch (p:pat) (r:rest)
  | p == r    = maybePrefixMatch pat rest
  | otherwise = Nothing

672
673
removeSpaces :: String -> String
removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
674
675
676
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
677
%*                                                                      *
678
\subsection[Utils-pairs]{Pairs}
Ian Lynagh's avatar
Ian Lynagh committed
679
%*                                                                      *
680
681
682
683
684
685
686
%************************************************************************

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

687
688
689
690
\begin{code}
seqList :: [a] -> b -> b
seqList [] b = b
seqList (x:xs) b = x `seq` seqList xs b
691
\end{code}
692
693
694
695
696
697
698

Global variables:

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

700
701
702
703
704
705
706
\begin{code}
consIORef :: IORef [a] -> a -> IO ()
consIORef var x = do
  xs <- readIORef var
  writeIORef var (x:xs)
\end{code}

707
708
709
Module names:

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
710
looksLikeModuleName :: String -> Bool
711
looksLikeModuleName [] = False
712
713
looksLikeModuleName (c:cs) = isUpper c && go cs
  where go [] = True
Ian Lynagh's avatar
Ian Lynagh committed
714
715
        go ('.':cs) = looksLikeModuleName cs
        go (c:cs)   = (isAlphaNum c || c == '_') && go cs
716
\end{code}
sof's avatar
sof committed
717

718
Akin to @Prelude.words@, but acts like the Bourne shell, treating
Ian Lynagh's avatar
Ian Lynagh committed
719
720
quoted strings as Haskell Strings, and also parses Haskell [String]
syntax.
sof's avatar
sof committed
721
722

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
getCmd :: String -> Either String             -- Error
                           (String, String) -- (Cmd, Rest)
getCmd s = case break isSpace $ dropWhile isSpace s of
           ([], _) -> Left ("Couldn't find command in " ++ show s)
           res -> Right res

toCmdArgs :: String -> Either String             -- Error
                              (String, [String]) -- (Cmd, Args)
toCmdArgs s = case getCmd s of
              Left err -> Left err
              Right (cmd, s') -> case toArgs s' of
                                 Left err -> Left err
                                 Right args -> Right (cmd, args)

toArgs :: String -> Either String   -- Error
                           [String] -- Args
toArgs str
    = case dropWhile isSpace str of
      s@('[':_) -> case reads s of
                   [(args, spaces)]
                    | all isSpace spaces ->
                       Right args
                   _ ->
                       Left ("Couldn't read " ++ show str ++ "as [String]")
      s -> toArgs' s
sof's avatar
sof committed
748
 where
Ian Lynagh's avatar
Ian Lynagh committed
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
  toArgs' s = case dropWhile isSpace s of
              [] -> Right []
              ('"' : _) -> case reads s of
                           [(arg, rest)]
                              -- rest must either be [] or start with a space
                            | all isSpace (take 1 rest) ->
                               case toArgs' rest of
                               Left err -> Left err
                               Right args -> Right (arg : args)
                           _ ->
                               Left ("Couldn't read " ++ show s ++ "as String")
              s' -> case break isSpace s' of
                    (arg, s'') -> case toArgs' s'' of
                                  Left err -> Left err
                                  Right args -> Right (arg : args)
sof's avatar
sof committed
764
\end{code}
765
766
767
768
769
770

-- -----------------------------------------------------------------------------
-- Floats

\begin{code}
readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
Ian Lynagh's avatar
Ian Lynagh committed
771
readRational__ r = do
772
773
774
775
776
     (n,d,s) <- readFix r
     (k,t)   <- readExp s
     return ((n%1)*10^^(k-d), t)
 where
     readFix r = do
Ian Lynagh's avatar
Ian Lynagh committed
777
778
779
        (ds,s)  <- lexDecDigits r
        (ds',t) <- lexDotDigits s
        return (read (ds++ds'), length ds', t)
780
781

     readExp (e:s) | e `elem` "eE" = readExp' s
Ian Lynagh's avatar
Ian Lynagh committed
782
     readExp s                     = return (0,s)
783
784

     readExp' ('+':s) = readDec s
Ian Lynagh's avatar
Ian Lynagh committed
785
786
787
     readExp' ('-':s) = do (k,t) <- readDec s
                           return (-k,t)
     readExp' s       = readDec s
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809

     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
Ian Lynagh's avatar
Ian Lynagh committed
810
811
812
          [x] -> x
          []  -> error ("readRational: no parse:"        ++ top_s)
          _   -> error ("readRational: ambiguous parse:" ++ top_s)
813
814
815
816
817
818


-----------------------------------------------------------------------------
-- Create a hierarchy of directories

createDirectoryHierarchy :: FilePath -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
819
createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
820
821
createDirectoryHierarchy dir = do
  b <- doesDirectoryExist dir
Ian Lynagh's avatar
Ian Lynagh committed
822
823
  unless b $ do createDirectoryHierarchy (takeDirectory dir)
                createDirectory dir
824
825
826

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
Ian Lynagh's avatar
Ian Lynagh committed
827
--
828
doesDirNameExist :: FilePath -> IO Bool
Ian Lynagh's avatar
Ian Lynagh committed
829
doesDirNameExist fpath = case takeDirectory fpath of
Ian Lynagh's avatar
Ian Lynagh committed
830
831
                         "" -> return True -- XXX Hack
                         _  -> doesDirectoryExist (takeDirectory fpath)
832

833
834
835
836
837
838
-- --------------------------------------------------------------
-- check existence & modification time at the same time

modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
modificationTimeIfExists f = do
  (do t <- getModificationTime f; return (Just t))
Ian Lynagh's avatar
Ian Lynagh committed
839
840
841
        `IO.catch` \e -> if isDoesNotExistError e
                         then return Nothing
                         else ioError e
842

843
844
845
846
847
848
849
-- 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
850
-- string is returned in the first component (and the second one is just
851
852
-- empty).
splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
853
854
855
splitLongestPrefix str pred
  | null r_pre = (str,           [])
  | otherwise  = (reverse (tail r_pre), reverse r_suf)
Ian Lynagh's avatar
Ian Lynagh committed
856
857
                           -- 'tail' drops the char satisfying 'pred'
  where (r_suf, r_pre) = break pred (reverse str)
858
859
860
861

escapeSpaces :: String -> String
escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""

Ian Lynagh's avatar
Ian Lynagh committed
862
type Suffix = String
863

864
865
866
867
868
869
870
871
872
873
874
875
--------------------------------------------------------------
-- * 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
Ian Lynagh's avatar
Ian Lynagh committed
876
        []     -> [chunk]
877
878
        _:rest -> chunk : split rest
      where
Ian Lynagh's avatar
Ian Lynagh committed
879
        chunk =
880
881
882
883
884
885
          case chunk' of
#ifdef mingw32_HOST_OS
            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
            _                                 -> chunk'

886
        (chunk', rest') = break isSearchPathSeparator s
887
888
889
890
891
892
893
894
895
896
897
898

data Direction = Forwards | Backwards

reslash :: Direction -> FilePath -> FilePath
reslash d = f
    where f ('/'  : xs) = slash : f xs
          f ('\\' : xs) = slash : f xs
          f (x    : xs) = x     : f xs
          f ""          = ""
          slash = case d of
                  Forwards -> '/'
                  Backwards -> '\\'
899
\end{code}
900