Util.lhs 27.5 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
7
8
%
\section[Util]{Highly random utility functions}

\begin{code}
module Util (
Ian Lynagh's avatar
Ian Lynagh committed
9
10
        debugIsOn, ghciTablesNextToCode,
        isWindowsHost, isWindowsTarget, isDarwinTarget,
sof's avatar
sof committed
11

Ian Lynagh's avatar
Ian Lynagh committed
12
13
        -- general list processing
        zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
14
        zipLazy, stretchZipWith,
Ian Lynagh's avatar
Ian Lynagh committed
15
16
17
        mapFst, mapSnd,
        mapAndUnzip, mapAndUnzip3,
        nOfThem, filterOut, partitionWith, splitEithers,
18
        foldl1',
19

Ian Lynagh's avatar
Ian Lynagh committed
20
21
22
23
24
25
26
        lengthExceeds, lengthIs, lengthAtLeast,
        listLengthCmp, atLength, equalLength, compareLength,

        isSingleton, only, singleton,
        notNull, snocView,

        isIn, isn'tIn,
27

Ian Lynagh's avatar
Ian Lynagh committed
28
29
        -- for-loop
        nTimes,
sof's avatar
sof committed
30

Ian Lynagh's avatar
Ian Lynagh committed
31
32
        -- sorting
        sortLe, sortWith, on,
33

Ian Lynagh's avatar
Ian Lynagh committed
34
35
        -- transitive closures
        transitiveClosure,
36

Ian Lynagh's avatar
Ian Lynagh committed
37
38
        -- accumulating
        foldl2, count, all2,
39

Ian Lynagh's avatar
Ian Lynagh committed
40
        takeList, dropList, splitAtList, split,
41

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

Ian Lynagh's avatar
Ian Lynagh committed
47
48
        -- strictness
        seqList,
49

Ian Lynagh's avatar
Ian Lynagh committed
50
51
        -- pairs
        unzipWith,
52

Ian Lynagh's avatar
Ian Lynagh committed
53
        global, consIORef,
54

Ian Lynagh's avatar
Ian Lynagh committed
55
56
        -- module names
        looksLikeModuleName,
57

Ian Lynagh's avatar
Ian Lynagh committed
58
        getCmd, toCmdArgs, toArgs,
59

Ian Lynagh's avatar
Ian Lynagh committed
60
61
        -- Floating point stuff
        readRational,
62

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

Ian Lynagh's avatar
Ian Lynagh committed
68
        later, handleDyn, handle,
69

Ian Lynagh's avatar
Ian Lynagh committed
70
71
72
73
74
        -- Filename utils
        Suffix,
        splitLongestPrefix,
        escapeSpaces,
        parseSearchPath,
75
        Direction(..), reslash,
76
77
    ) where

78
79
#include "HsVersions.h"

80
import Panic
81

Simon Marlow's avatar
Simon Marlow committed
82
83
import Control.Exception ( Exception(..), finally, catchDyn, throw )
import qualified Control.Exception as Exception
Ian Lynagh's avatar
Ian Lynagh committed
84
85
86
87
import Data.Dynamic     ( Typeable )
import Data.IORef       ( IORef, newIORef )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef       ( readIORef, writeIORef )
88
import Data.List        hiding (group)
89

90
import qualified Data.List as List ( elem )
91
#ifdef DEBUG
92
import qualified Data.List as List ( notElem )
93
import FastTypes
94
#endif
sof's avatar
sof committed
95

Ian Lynagh's avatar
Ian Lynagh committed
96
import Control.Monad    ( unless )
Simon Marlow's avatar
Simon Marlow committed
97
import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
Ian Lynagh's avatar
Ian Lynagh committed
98
import System.Directory ( doesDirectoryExist, createDirectory,
Simon Marlow's avatar
Simon Marlow committed
99
                          getModificationTime )
Ian Lynagh's avatar
Ian Lynagh committed
100
import System.FilePath hiding ( searchPathSeparator )
Ian Lynagh's avatar
Ian Lynagh committed
101
102
103
import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Ratio       ( (%) )
import System.Time      ( ClockTime )
104

105
infixr 9 `thenCmp`
106
107
\end{code}

108
109
%************************************************************************
%*                                                                      *
110
\subsection{Is DEBUG on, are we on Windows?}
111
112
113
114
115
116
117
118
119
120
%*                                                                      *
%************************************************************************

\begin{code}
debugIsOn :: Bool
#ifdef DEBUG
debugIsOn = True
#else
debugIsOn = False
#endif
121

Ian Lynagh's avatar
Ian Lynagh committed
122
123
124
125
126
127
128
ghciTablesNextToCode :: Bool
#ifdef GHCI_TABLES_NEXT_TO_CODE
ghciTablesNextToCode = True
#else
ghciTablesNextToCode = False
#endif

129
130
131
132
133
134
isWindowsHost :: Bool
#ifdef mingw32_HOST_OS
isWindowsHost = True
#else
isWindowsHost = False
#endif
Ian Lynagh's avatar
Ian Lynagh committed
135
136
137
138
139
140
141
142
143
144
145
146
147
148

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

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

151
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
152
%*                                                                      *
153
\subsection{A for loop}
Ian Lynagh's avatar
Ian Lynagh committed
154
%*                                                                      *
155
156
157
158
159
160
161
162
163
164
%************************************************************************

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

165
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
166
%*                                                                      *
167
\subsection[Utils-lists]{General list processing}
Ian Lynagh's avatar
Ian Lynagh committed
168
%*                                                                      *
169
170
%************************************************************************

171
172
173
\begin{code}
filterOut :: (a->Bool) -> [a] -> [a]
-- Like filter, only reverses the sense of the test
Ian Lynagh's avatar
Ian Lynagh committed
174
filterOut _ [] = []
175
filterOut p (x:xs) | p x       = filterOut p xs
Ian Lynagh's avatar
Ian Lynagh committed
176
                   | otherwise = x : filterOut p xs
177
178

partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
Ian Lynagh's avatar
Ian Lynagh committed
179
partitionWith _ [] = ([],[])
180
partitionWith f (x:xs) = case f x of
Ian Lynagh's avatar
Ian Lynagh committed
181
182
183
                         Left  b -> (b:bs, cs)
                         Right c -> (bs, c:cs)
    where (bs,cs) = partitionWith f xs
184

185
186
187
splitEithers :: [Either a b] -> ([a], [b])
splitEithers [] = ([],[])
splitEithers (e : es) = case e of
Ian Lynagh's avatar
Ian Lynagh committed
188
189
190
                        Left x -> (x:xs, ys)
                        Right y -> (xs, y:ys)
    where (xs,ys) = splitEithers es
191
192
\end{code}

193
194
195
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?
196
197

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
198
199
200
201
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]
202
203

#ifndef DEBUG
204
205
206
207
zipEqual      _ = zip
zipWithEqual  _ = zipWith
zipWith3Equal _ = zipWith3
zipWith4Equal _ = zipWith4
208
#else
209
zipEqual _   []     []     = []
210
zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
211
zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
212
213

zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
214
zipWithEqual _   _ [] []        =  []
Ian Lynagh's avatar
Ian Lynagh committed
215
zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
216
217

zipWith3Equal msg z (a:as) (b:bs) (c:cs)
Ian Lynagh's avatar
Ian Lynagh committed
218
                                =  z a b c : zipWith3Equal msg z as bs cs
219
zipWith3Equal _   _ [] []  []   =  []
Ian Lynagh's avatar
Ian Lynagh committed
220
zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
221
222

zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
Ian Lynagh's avatar
Ian Lynagh committed
223
                                =  z a b c d : zipWith4Equal msg z as bs cs ds
224
zipWith4Equal _   _ [] [] [] [] =  []
Ian Lynagh's avatar
Ian Lynagh committed
225
zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
226
227
228
#endif
\end{code}

229
230
231
232
\begin{code}
-- zipLazy is lazy in the second list (observe the ~)

zipLazy :: [a] -> [b] -> [(a,b)]
Ian Lynagh's avatar
Ian Lynagh committed
233
zipLazy []     _       = []
234
235
236
237
238
239
-- 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
240
241
\end{code}

242
243

\begin{code}
244
stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
Ian Lynagh's avatar
Ian Lynagh committed
245
-- (stretchZipWith p z f xs ys) stretches ys by inserting z in
246
247
-- the places where p returns *True*

Ian Lynagh's avatar
Ian Lynagh committed
248
stretchZipWith _ _ _ []     _ = []
249
250
251
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
252
253
                []     -> []
                (y:ys) -> f x y : stretchZipWith p z f xs ys
254
255
256
\end{code}


257
\begin{code}
258
259
260
261
262
263
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]

264
265
mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])

Ian Lynagh's avatar
Ian Lynagh committed
266
mapAndUnzip _ [] = ([], [])
267
mapAndUnzip f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
268
269
  = let (r1,  r2)  = f x
        (rs1, rs2) = mapAndUnzip f xs
270
271
    in
    (r1:rs1, r2:rs2)
272
273
274

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

Ian Lynagh's avatar
Ian Lynagh committed
275
mapAndUnzip3 _ [] = ([], [], [])
276
mapAndUnzip3 f (x:xs)
Ian Lynagh's avatar
Ian Lynagh committed
277
278
  = let (r1,  r2,  r3)  = f x
        (rs1, rs2, rs3) = mapAndUnzip3 f xs
279
280
    in
    (r1:rs1, r2:rs2, r3:rs3)
281
282
\end{code}

283
284
\begin{code}
nOfThem :: Int -> a -> [a]
sof's avatar
sof committed
285
nOfThem n thing = replicate n thing
286

sof's avatar
sof committed
287
288
289
290
291
292
293
294
295
296
297
298
299
-- '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
Ian Lynagh's avatar
Ian Lynagh committed
300
301
atLength atLenPred atEndPred ls n
  | n < 0     = atEndPred n
sof's avatar
sof committed
302
303
304
305
306
307
308
  | otherwise = go n ls
  where
    go n [] = atEndPred n
    go 0 ls = atLenPred ls
    go n (_:xs) = go (n-1) xs

-- special cases.
309
lengthExceeds :: [a] -> Int -> Bool
310
-- (lengthExceeds xs n) = (length xs > n)
sof's avatar
sof committed
311
lengthExceeds = atLength notNull (const False)
sof's avatar
sof committed
312
313

lengthAtLeast :: [a] -> Int -> Bool
sof's avatar
sof committed
314
lengthAtLeast = atLength notNull (== 0)
sof's avatar
sof committed
315
316
317
318

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

Ian Lynagh's avatar
Ian Lynagh committed
319
320
listLengthCmp :: [a] -> Int -> Ordering
listLengthCmp = atLength atLen atEnd
sof's avatar
sof committed
321
322
323
324
325
326
327
328
 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
329

330
equalLength :: [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
331
equalLength []     []     = True
332
equalLength (_:xs) (_:ys) = equalLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
333
equalLength _      _      = False
334
335

compareLength :: [a] -> [b] -> Ordering
Ian Lynagh's avatar
Ian Lynagh committed
336
compareLength []     []     = EQ
337
compareLength (_:xs) (_:ys) = compareLength xs ys
Ian Lynagh's avatar
Ian Lynagh committed
338
339
compareLength []     _      = LT
compareLength _      []     = GT
340
341

----------------------------
342
343
344
singleton :: a -> [a]
singleton x = [x]

345
isSingleton :: [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
346
347
isSingleton [_] = True
isSingleton _   = False
348

sof's avatar
sof committed
349
350
351
352
notNull :: [a] -> Bool
notNull [] = False
notNull _  = True

353
354
355
356
357
358
only :: [a] -> a
#ifdef DEBUG
only [a] = a
#else
only (a:_) = a
#endif
Ian Lynagh's avatar
Ian Lynagh committed
359
only _ = panic "Util: only"
360
361
362
\end{code}

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

364
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
365
isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
366
367

# ifndef DEBUG
Ian Lynagh's avatar
Ian Lynagh committed
368
369
isIn    _msg x ys = elem__    x ys
isn'tIn _msg x ys = notElem__ x ys
370
371

--these are here to be SPECIALIZEd (automagically)
Ian Lynagh's avatar
Ian Lynagh committed
372
373
374
elem__ :: Eq a => a -> [a] -> Bool
elem__ _ []     = False
elem__ x (y:ys) = x == y || elem__ x ys
375

Ian Lynagh's avatar
Ian Lynagh committed
376
377
378
notElem__ :: Eq a => a -> [a] -> Bool
notElem__ _ []     = True
notElem__ x (y:ys) = x /= y && notElem__ x ys
379

ross's avatar
ross committed
380
# else /* DEBUG */
381
isIn msg x ys
382
  = elem (_ILIT(0)) x ys
383
  where
384
    elem _ _ []        = False
385
    elem i x (y:ys)
386
387
388
      | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
                                (x `List.elem` (y:ys))
      | otherwise       = x == y || elem (i +# _ILIT(1)) x ys
389
390

isn'tIn msg x ys
391
  = notElem (_ILIT(0)) x ys
392
  where
393
    notElem _ _ [] =  True
394
    notElem i x (y:ys)
395
396
      | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
                                (x `List.notElem` (y:ys))
397
      | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
ross's avatar
ross committed
398
# endif /* DEBUG */
399
400
\end{code}

401
402
403
foldl1' was added in GHC 6.4

\begin{code}
404
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604
Ian Lynagh's avatar
Ian Lynagh committed
405
406
407
foldl1'          :: (a -> a -> a) -> [a] -> a
foldl1' f (x:xs) =  foldl' f x xs
foldl1' _ []     =  panic "foldl1'"
408
409
410
#endif
\end{code}

411
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
412
%*                                                                      *
413
\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
Ian Lynagh's avatar
Ian Lynagh committed
414
%*                                                                      *
415
416
417
418
419
420
421
422
%************************************************************************

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

423
Here is a piece of Haskell code that I'm rather fond of. See it as an
424
425
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
426
believe the lazy version is due to me [surprisingly complicated].
427
428
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
429
430
431
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.
432
433
434
435
436
437

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
438
   4) a super-optimized-quick-sort of Lennart's
439
440
441
442

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

448
have fun
449
450
451
452
453
Carsten
\end{display}

\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
Ian Lynagh's avatar
Ian Lynagh committed
454
-- Given a <= function, group finds maximal contiguous up-runs
455
456
457
458
459
460
-- 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.
461

Ian Lynagh's avatar
Ian Lynagh committed
462
group _ []     = []
463
464
465
group p (x:xs) = group' xs x x (x :)
  where
    group' []     _     _     s  = [s []]
Ian Lynagh's avatar
Ian Lynagh committed
466
467
468
469
470
471
    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
472
473

generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
Ian Lynagh's avatar
Ian Lynagh committed
474
475
476
477
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
478
479
480
481

-- gamma is now called balancedFold

balancedFold :: (a -> a -> a) -> [a] -> a
Ian Lynagh's avatar
Ian Lynagh committed
482
483
balancedFold _ [] = error "can't reduce an empty list using balancedFold"
balancedFold _ [x] = x
484
485
486
487
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
488
balancedFold' _ xs = xs
489

Ian Lynagh's avatar
Ian Lynagh committed
490
491
generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
generalNaturalMergeSort _ [] = []
492
generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
493

494
#if NOT_USED
495
496
497
generalMergeSort p [] = []
generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs

498
499
500
501
502
503
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]

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

mergeSortLe le = generalMergeSort le
504
505
#endif

506
507
sortLe :: (a->a->Bool) -> [a] -> [a]
sortLe le = generalNaturalMergeSort le
508
509
510
511

sortWith :: Ord b => (a->b) -> [a] -> [a]
sortWith get_key xs = sortLe le xs
  where
Ian Lynagh's avatar
Ian Lynagh committed
512
    x `le` y = get_key x < get_key y
513
514
515
516

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

517
518
519
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
520
%*                                                                      *
521
\subsection[Utils-transitive-closure]{Transitive closure}
Ian Lynagh's avatar
Ian Lynagh committed
522
%*                                                                      *
523
524
525
526
527
%************************************************************************

This algorithm for transitive closure is straightforward, albeit quadratic.

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
528
529
530
531
transitiveClosure :: (a -> [a])         -- Successor function
                  -> (a -> a -> Bool)   -- Equality predicate
                  -> [a]
                  -> [a]                -- The transitive closure
532
533

transitiveClosure succ eq xs
534
 = go [] xs
535
 where
Ian Lynagh's avatar
Ian Lynagh committed
536
   go done []                      = done
537
   go done (x:xs) | x `is_in` done = go done xs
Ian Lynagh's avatar
Ian Lynagh committed
538
                  | otherwise      = go (x:done) (succ x ++ xs)
539

Ian Lynagh's avatar
Ian Lynagh committed
540
   _ `is_in` []                 = False
541
   x `is_in` (y:ys) | eq x y    = True
Ian Lynagh's avatar
Ian Lynagh committed
542
                    | otherwise = x `is_in` ys
543
544
545
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
546
%*                                                                      *
547
\subsection[Utils-accum]{Accumulating}
Ian Lynagh's avatar
Ian Lynagh committed
548
%*                                                                      *
549
550
%************************************************************************

551
552
553
554
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
555
foldl2 _ z [] [] = z
556
foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
Ian Lynagh's avatar
Ian Lynagh committed
557
foldl2 _ _ _      _      = panic "Util: foldl2"
558
559

all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
560
-- True if the lists are the same length, and
561
-- all corresponding elements satisfy the predicate
Ian Lynagh's avatar
Ian Lynagh committed
562
all2 _ []     []     = True
563
all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
Ian Lynagh's avatar
Ian Lynagh committed
564
all2 _ _      _      = False
565
566
567
568
569
570
\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
571
count _ [] = 0
572
count p (x:xs) | p x       = 1 + count p xs
Ian Lynagh's avatar
Ian Lynagh committed
573
               | otherwise = count p xs
574
575
\end{code}

sof's avatar
sof committed
576
577
578
579
580
581
@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
582
takeList (_:xs) ls =
sof's avatar
sof committed
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
   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

600
snocView :: [a] -> Maybe ([a],a)
Ian Lynagh's avatar
Ian Lynagh committed
601
        -- Split off the last element
602
603
snocView [] = Nothing
snocView xs = go [] xs
Ian Lynagh's avatar
Ian Lynagh committed
604
605
606
607
608
            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"
609

610
611
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
612
613
                []     -> [chunk]
                _:rest -> chunk : split c rest
614
  where (chunk, rest) = break (==c) s
sof's avatar
sof committed
615
616
\end{code}

617

618
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
619
%*                                                                      *
620
\subsection[Utils-comparison]{Comparisons}
Ian Lynagh's avatar
Ian Lynagh committed
621
%*                                                                      *
622
623
%************************************************************************

624
\begin{code}
625
626
627
628
629
630
631
632
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
633
634
thenCmp EQ       ordering = ordering
thenCmp ordering _        = ordering
635

636
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
637
eqListBy _  []     []     = True
638
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
Ian Lynagh's avatar
Ian Lynagh committed
639
eqListBy _  _      _      = False
640

641
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
642
643
    -- `cmpList' uses a user-specified comparer

Ian Lynagh's avatar
Ian Lynagh committed
644
645
646
cmpList _   []     [] = EQ
cmpList _   []     _  = LT
cmpList _   _      [] = GT
647
cmpList cmp (a:as) (b:bs)
648
  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
649
650
\end{code}

651
\begin{code}
652
653
-- 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.
654
655
656
657
658
659
660
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch []    rest = Just rest
maybePrefixMatch (_:_) []   = Nothing
maybePrefixMatch (p:pat) (r:rest)
  | p == r    = maybePrefixMatch pat rest
  | otherwise = Nothing

661
662
removeSpaces :: String -> String
removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
663
664
665
\end{code}

%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
666
%*                                                                      *
667
\subsection[Utils-pairs]{Pairs}
Ian Lynagh's avatar
Ian Lynagh committed
668
%*                                                                      *
669
670
671
672
673
674
675
%************************************************************************

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

676
677
678
679
\begin{code}
seqList :: [a] -> b -> b
seqList [] b = b
seqList (x:xs) b = x `seq` seqList xs b
680
\end{code}
681
682
683
684
685
686
687

Global variables:

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

689
690
691
692
693
694
695
\begin{code}
consIORef :: IORef [a] -> a -> IO ()
consIORef var x = do
  xs <- readIORef var
  writeIORef var (x:xs)
\end{code}

696
697
698
Module names:

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
699
looksLikeModuleName :: String -> Bool
700
looksLikeModuleName [] = False
701
702
looksLikeModuleName (c:cs) = isUpper c && go cs
  where go [] = True
Ian Lynagh's avatar
Ian Lynagh committed
703
704
        go ('.':cs) = looksLikeModuleName cs
        go (c:cs)   = (isAlphaNum c || c == '_') && go cs
705
\end{code}
sof's avatar
sof committed
706

707
Akin to @Prelude.words@, but acts like the Bourne shell, treating
Ian Lynagh's avatar
Ian Lynagh committed
708
709
quoted strings as Haskell Strings, and also parses Haskell [String]
syntax.
sof's avatar
sof committed
710
711

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
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
737
 where
Ian Lynagh's avatar
Ian Lynagh committed
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
  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
753
\end{code}
754
755
756
757
758
759

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

\begin{code}
readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
Ian Lynagh's avatar
Ian Lynagh committed
760
readRational__ r = do
761
762
763
764
765
     (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
766
767
768
        (ds,s)  <- lexDecDigits r
        (ds',t) <- lexDotDigits s
        return (read (ds++ds'), length ds', t)
769
770

     readExp (e:s) | e `elem` "eE" = readExp' s
Ian Lynagh's avatar
Ian Lynagh committed
771
     readExp s                     = return (0,s)
772
773

     readExp' ('+':s) = readDec s
Ian Lynagh's avatar
Ian Lynagh committed
774
775
776
     readExp' ('-':s) = do (k,t) <- readDec s
                           return (-k,t)
     readExp' s       = readDec s
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798

     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
799
800
801
          [x] -> x
          []  -> error ("readRational: no parse:"        ++ top_s)
          _   -> error ("readRational: ambiguous parse:" ++ top_s)
802
803
804
805
806
807


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

createDirectoryHierarchy :: FilePath -> IO ()
Ian Lynagh's avatar
Ian Lynagh committed
808
createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
809
810
createDirectoryHierarchy dir = do
  b <- doesDirectoryExist dir
Ian Lynagh's avatar
Ian Lynagh committed
811
812
  unless b $ do createDirectoryHierarchy (takeDirectory dir)
                createDirectory dir
813
814
815

-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
Ian Lynagh's avatar
Ian Lynagh committed
816
--
817
doesDirNameExist :: FilePath -> IO Bool
Ian Lynagh's avatar
Ian Lynagh committed
818
doesDirNameExist fpath = case takeDirectory fpath of
Ian Lynagh's avatar
Ian Lynagh committed
819
820
                         "" -> return True -- XXX Hack
                         _  -> doesDirectoryExist (takeDirectory fpath)
821
822
823
824

-- -----------------------------------------------------------------------------
-- Exception utils

Ian Lynagh's avatar
Ian Lynagh committed
825
later :: IO b -> IO a -> IO a
826
827
828
829
830
831
832
833
834
835
later = flip finally

handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
handleDyn = flip catchDyn

handle :: (Exception -> IO a) -> IO a -> IO a
handle h f = f `Exception.catch` \e -> case e of
    ExitException _ -> throw e
    _               -> h e

836
837
838
839
840
841
-- --------------------------------------------------------------
-- 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
842
843
844
        `IO.catch` \e -> if isDoesNotExistError e
                         then return Nothing
                         else ioError e
845

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

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

Ian Lynagh's avatar
Ian Lynagh committed
865
type Suffix = String
866

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

        (chunk', rest') = break (==searchPathSeparator) s

Ian Lynagh's avatar
Ian Lynagh committed
891
892
893
-- | 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.
894
895
896
897
898
899
searchPathSeparator :: Char
#if mingw32_HOST_OS || mingw32_TARGET_OS
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif
900
901
902
903
904
905
906
907
908
909
910
911

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 -> '\\'
912
\end{code}
913