Util.lhs 26.9 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
        -- * List operations controlled by another list
        takeList, dropList, splitAtList, split,
35
        dropTail,
batterseapower's avatar
batterseapower committed
36 37

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

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

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

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

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

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

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

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

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

68
        global, consIORef, globalMVar, globalEmptyMVar,
batterseapower's avatar
batterseapower committed
69 70

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

78 79
#include "HsVersions.h"

80
import Panic
81

Thomas Schilling's avatar
Thomas Schilling committed
82
import Data.IORef       ( IORef, newIORef, atomicModifyIORef )
Ian Lynagh's avatar
Ian Lynagh committed
83
import System.IO.Unsafe ( unsafePerformIO )
84
import Data.List        hiding (group)
85
import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
86

87
#ifdef DEBUG
88
import qualified Data.List as List ( elem, 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
389 390
isIn    _msg x ys = x `elem` ys
isn'tIn _msg x ys = x `notElem` ys
391

ross's avatar
ross committed
392
# else /* DEBUG */
393
isIn msg x ys
394
  = elem100 (_ILIT(0)) x ys
395
  where
396 397
    elem100 _ _ []        = False
    elem100 i x (y:ys)
398
      | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
399 400
                                (x `elem` (y:ys))
      | otherwise       = x == y || elem100 (i +# _ILIT(1)) x ys
401 402

isn'tIn msg x ys
403
  = notElem100 (_ILIT(0)) x ys
404
  where
405 406
    notElem100 _ _ [] =  True
    notElem100 i x (y:ys)
407
      | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
408 409
                                (x `notElem` (y:ys))
      | otherwise      =  x /= y && notElem100 (i +# _ILIT(1)) x ys
ross's avatar
ross committed
410
# endif /* DEBUG */
411 412 413
\end{code}

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

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

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

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

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

450
have fun
451 452 453 454 455
Carsten
\end{display}

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

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

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

-- gamma is now called balancedFold

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

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

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

500 501 502 503 504 505
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]

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

mergeSortLe le = generalMergeSort le
506 507
#endif

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

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

Simon Marlow's avatar
Simon Marlow committed
516
on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
517 518
on cmp sel = \x y -> sel x `cmp` sel y

519 520 521
\end{code}

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

This algorithm for transitive closure is straightforward, albeit quadratic.

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

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

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

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

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

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

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

602 603 604 605
-- drop from the end of a list
dropTail :: Int -> [a] -> [a]
dropTail n = reverse . drop n . reverse

606
snocView :: [a] -> Maybe ([a],a)
Ian Lynagh's avatar
Ian Lynagh committed
607
        -- Split off the last element
608 609
snocView [] = Nothing
snocView xs = go [] xs
Ian Lynagh's avatar
Ian Lynagh committed
610 611 612 613 614
            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"
615

616 617
split :: Char -> String -> [String]
split c s = case rest of
Ian Lynagh's avatar
Ian Lynagh committed
618 619
                []     -> [chunk]
                _:rest -> chunk : split c rest
620
  where (chunk, rest) = break (==c) s
sof's avatar
sof committed
621 622
\end{code}

623

624
%************************************************************************
Ian Lynagh's avatar
Ian Lynagh committed
625
%*                                                                      *
626
\subsection[Utils-comparison]{Comparisons}
Ian Lynagh's avatar
Ian Lynagh committed
627
%*                                                                      *
628 629
%************************************************************************

630
\begin{code}
631 632 633 634 635 636 637 638
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
639 640
thenCmp EQ       ordering = ordering
thenCmp ordering _        = ordering
641

642
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
643
eqListBy _  []     []     = True
644
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
Ian Lynagh's avatar
Ian Lynagh committed
645
eqListBy _  _      _      = False
646

647
cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
648 649
    -- `cmpList' uses a user-specified comparer

Ian Lynagh's avatar
Ian Lynagh committed
650 651 652
cmpList _   []     [] = EQ
cmpList _   []     _  = LT
cmpList _   _      [] = GT
653
cmpList cmp (a:as) (b:bs)
654
  = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
655 656
\end{code}

657
\begin{code}
658 659
removeSpaces :: String -> String
removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
660 661 662
\end{code}

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

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

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

Global variables:

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

686 687 688
\begin{code}
consIORef :: IORef [a] -> a -> IO ()
consIORef var x = do
Thomas Schilling's avatar
Thomas Schilling committed
689
  atomicModifyIORef var (\xs -> (x:xs,()))
690 691
\end{code}

692 693 694 695 696 697 698 699
\begin{code}
globalMVar :: a -> MVar a
globalMVar a = unsafePerformIO (newMVar a)

globalEmptyMVar :: MVar a
globalEmptyMVar = unsafePerformIO newEmptyMVar
\end{code}

700 701 702
Module names:

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

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

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

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

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

     readExp (e:s) | e `elem` "eE" = readExp' s
Ian Lynagh's avatar
Ian Lynagh committed
775
     readExp s                     = return (0,s)
776 777

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

     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
803 804 805
          [x] -> x
          []  -> error ("readRational: no parse:"        ++ top_s)
          _   -> error ("readRational: ambiguous parse:" ++ top_s)
806 807 808 809 810 811


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

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

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

826 827 828 829 830 831
-- --------------------------------------------------------------
-- 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
832 833 834
        `IO.catch` \e -> if isDoesNotExistError e
                         then return Nothing
                         else ioError e
835

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

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

Ian Lynagh's avatar
Ian Lynagh committed
855
type Suffix = String
856

857 858 859 860 861 862 863 864 865 866 867 868
--------------------------------------------------------------
-- * 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
869
        []     -> [chunk]
870 871
        _:rest -> chunk : split rest
      where
Ian Lynagh's avatar
Ian Lynagh committed
872
        chunk =
873 874 875 876 877 878
          case chunk' of
#ifdef mingw32_HOST_OS
            ('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
            _                                 -> chunk'

879
        (chunk', rest') = break isSearchPathSeparator s
880 881 882 883 884 885 886 887 888 889 890 891

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 -> '\\'
892
\end{code}
893