compiler/utils/Util.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The University of Glasgow 1992-2002
   4 %
   5 \section[Util]{Highly random utility functions}
   6
   7 \begin{code}
   8 module Util (
   9         debugIsOn, ghciTablesNextToCode, picIsOn,
  10         isWindowsHost, isWindowsTarget, isDarwinTarget,
  11
  12         -- general list processing
  13         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
  14         zipLazy, stretchZipWith,
  15         mapFst, mapSnd,
  16         mapAndUnzip, mapAndUnzip3,
  17         nOfThem, filterOut, partitionWith, splitEithers,
  18         foldl1',
  19
  20         lengthExceeds, lengthIs, lengthAtLeast,
  21         listLengthCmp, atLength, equalLength, compareLength,
  22
  23         isSingleton, only, singleton,
  24         notNull, snocView,
  25
  26         isIn, isn'tIn,
  27
  28         -- for-loop
  29         nTimes,
  30
  31         -- sorting
  32         sortLe, sortWith, on,
  33
  34         -- transitive closures
  35         transitiveClosure,
  36
  37         -- accumulating
  38         foldl2, count, all2,
  39
  40         takeList, dropList, splitAtList, split,
  41
  42         -- comparisons
  43         isEqual, eqListBy,
  44         thenCmp, cmpList, maybePrefixMatch,
  45         removeSpaces,
  46
  47         -- strictness
  48         seqList,
  49
  50         -- pairs
  51         unzipWith,
  52
  53         global, consIORef,
  54
  55         -- module names
  56         looksLikeModuleName,
  57
  58         getCmd, toCmdArgs, toArgs,
  59
  60         -- Floating point stuff
  61         readRational,
  62
  63         -- IO-ish utilities
  64         createDirectoryHierarchy,
  65         doesDirNameExist,
  66         modificationTimeIfExists,
  67
  68         later, handleDyn, handle,
  69
  70         -- Filename utils
  71         Suffix,
  72         splitLongestPrefix,
  73         escapeSpaces,
  74         parseSearchPath,
  75         Direction(..), reslash,
  76     ) where
  77
  78 #include "HsVersions.h"
  79
  80 import Panic
  81
  82 import Control.Exception ( Exception(..), finally, catchDyn, throw )
  83 import qualified Control.Exception as Exception
  84 import Data.Dynamic     ( Typeable )
  85 import Data.IORef       ( IORef, newIORef )
  86 import System.IO.Unsafe ( unsafePerformIO )
  87 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
  95
  96 import Control.Monad    ( unless )
  97 import System.IO.Error as IO ( catch, isDoesNotExistError )
  98 import System.Directory ( doesDirectoryExist, createDirectory,
  99                           getModificationTime )
 100 import System.FilePath hiding ( searchPathSeparator )
 101 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
 102 import Data.Ratio       ( (%) )
 103 import System.Time      ( ClockTime )
 104
 105 infixr 9 `thenCmp`
 106 \end{code}
 107
 108 %************************************************************************
 109 %*                                                                      *
 110 \subsection{Is DEBUG on, are we on Windows?}
 111 %*                                                                      *
 112 %************************************************************************
 113
 114 \begin{code}
 115 debugIsOn :: Bool
 116 #ifdef DEBUG
 117 debugIsOn = True
 118 #else
 119 debugIsOn = False
 120 #endif
 121
 122 ghciTablesNextToCode :: Bool
 123 #ifdef GHCI_TABLES_NEXT_TO_CODE
 124 ghciTablesNextToCode = True
 125 #else
 126 ghciTablesNextToCode = False
 127 #endif
 128
 129 picIsOn :: Bool
 130 #ifdef __PIC__
 131 picIsOn = True
 132 #else
 133 picIsOn = False
 134 #endif
 135
 136 isWindowsHost :: Bool
 137 #ifdef mingw32_HOST_OS
 138 isWindowsHost = True
 139 #else
 140 isWindowsHost = False
 141 #endif
 142
 143 isWindowsTarget :: Bool
 144 #ifdef mingw32_TARGET_OS
 145 isWindowsTarget = True
 146 #else
 147 isWindowsTarget = False
 148 #endif
 149
 150 isDarwinTarget :: Bool
 151 #ifdef darwin_TARGET_OS
 152 isDarwinTarget = True
 153 #else
 154 isDarwinTarget = False
 155 #endif
 156 \end{code}
 157
 158 %************************************************************************
 159 %*                                                                      *
 160 \subsection{A for loop}
 161 %*                                                                      *
 162 %************************************************************************
 163
 164 \begin{code}
 165 -- Compose a function with itself n times.  (nth rather than twice)
 166 nTimes :: Int -> (a -> a) -> (a -> a)
 167 nTimes 0 _ = id
 168 nTimes 1 f = f
 169 nTimes n f = f . nTimes (n-1) f
 170 \end{code}
 171
 172 %************************************************************************
 173 %*                                                                      *
 174 \subsection[Utils-lists]{General list processing}
 175 %*                                                                      *
 176 %************************************************************************
 177
 178 \begin{code}
 179 filterOut :: (a->Bool) -> [a] -> [a]
 180 -- Like filter, only reverses the sense of the test
 181 filterOut _ [] = []
 182 filterOut p (x:xs) | p x       = filterOut p xs
 183                    | otherwise = x : filterOut p xs
 184
 185 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 186 partitionWith _ [] = ([],[])
 187 partitionWith f (x:xs) = case f x of
 188                          Left  b -> (b:bs, cs)
 189                          Right c -> (bs, c:cs)
 190     where (bs,cs) = partitionWith f xs
 191
 192 splitEithers :: [Either a b] -> ([a], [b])
 193 splitEithers [] = ([],[])
 194 splitEithers (e : es) = case e of
 195                         Left x -> (x:xs, ys)
 196                         Right y -> (xs, y:ys)
 197     where (xs,ys) = splitEithers es
 198 \end{code}
 199
 200 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 201 are of equal length.  Alastair Reid thinks this should only happen if
 202 DEBUGging on; hey, why not?
 203
 204 \begin{code}
 205 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 206 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 207 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 208 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 209
 210 #ifndef DEBUG
 211 zipEqual      _ = zip
 212 zipWithEqual  _ = zipWith
 213 zipWith3Equal _ = zipWith3
 214 zipWith4Equal _ = zipWith4
 215 #else
 216 zipEqual _   []     []     = []
 217 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 218 zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
 219
 220 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 221 zipWithEqual _   _ [] []        =  []
 222 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 223
 224 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 225                                 =  z a b c : zipWith3Equal msg z as bs cs
 226 zipWith3Equal _   _ [] []  []   =  []
 227 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 228
 229 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 230                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 231 zipWith4Equal _   _ [] [] [] [] =  []
 232 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 233 #endif
 234 \end{code}
 235
 236 \begin{code}
 237 -- zipLazy is lazy in the second list (observe the ~)
 238
 239 zipLazy :: [a] -> [b] -> [(a,b)]
 240 zipLazy []     _       = []
 241 -- We want to write this, but with GHC 6.4 we get a warning, so it
 242 -- doesn't validate:
 243 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 244 -- so we write this instead:
 245 zipLazy (x:xs) zs = let y : ys = zs
 246                     in (x,y) : zipLazy xs ys
 247 \end{code}
 248
 249
 250 \begin{code}
 251 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 252 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
 253 -- the places where p returns *True*
 254
 255 stretchZipWith _ _ _ []     _ = []
 256 stretchZipWith p z f (x:xs) ys
 257   | p x       = f x z : stretchZipWith p z f xs ys
 258   | otherwise = case ys of
 259                 []     -> []
 260                 (y:ys) -> f x y : stretchZipWith p z f xs ys
 261 \end{code}
 262
 263
 264 \begin{code}
 265 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
 266 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
 267
 268 mapFst f xys = [(f x, y) | (x,y) <- xys]
 269 mapSnd f xys = [(x, f y) | (x,y) <- xys]
 270
 271 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 272
 273 mapAndUnzip _ [] = ([], [])
 274 mapAndUnzip f (x:xs)
 275   = let (r1,  r2)  = f x
 276         (rs1, rs2) = mapAndUnzip f xs
 277     in
 278     (r1:rs1, r2:rs2)
 279
 280 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 281
 282 mapAndUnzip3 _ [] = ([], [], [])
 283 mapAndUnzip3 f (x:xs)
 284   = let (r1,  r2,  r3)  = f x
 285         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 286     in
 287     (r1:rs1, r2:rs2, r3:rs3)
 288 \end{code}
 289
 290 \begin{code}
 291 nOfThem :: Int -> a -> [a]
 292 nOfThem n thing = replicate n thing
 293
 294 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
 295 -- specification:
 296 --
 297 --  atLength atLenPred atEndPred ls n
 298 --   | n < 0         = atLenPred n
 299 --   | length ls < n = atEndPred (n - length ls)
 300 --   | otherwise     = atLenPred (drop n ls)
 301 --
 302 atLength :: ([a] -> b)
 303          -> (Int -> b)
 304          -> [a]
 305          -> Int
 306          -> b
 307 atLength atLenPred atEndPred ls n
 308   | n < 0     = atEndPred n
 309   | otherwise = go n ls
 310   where
 311     go n [] = atEndPred n
 312     go 0 ls = atLenPred ls
 313     go n (_:xs) = go (n-1) xs
 314
 315 -- special cases.
 316 lengthExceeds :: [a] -> Int -> Bool
 317 -- (lengthExceeds xs n) = (length xs > n)
 318 lengthExceeds = atLength notNull (const False)
 319
 320 lengthAtLeast :: [a] -> Int -> Bool
 321 lengthAtLeast = atLength notNull (== 0)
 322
 323 lengthIs :: [a] -> Int -> Bool
 324 lengthIs = atLength null (==0)
 325
 326 listLengthCmp :: [a] -> Int -> Ordering
 327 listLengthCmp = atLength atLen atEnd
 328  where
 329   atEnd 0      = EQ
 330   atEnd x
 331    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 332    | otherwise = GT
 333
 334   atLen []     = EQ
 335   atLen _      = GT
 336
 337 equalLength :: [a] -> [b] -> Bool
 338 equalLength []     []     = True
 339 equalLength (_:xs) (_:ys) = equalLength xs ys
 340 equalLength _      _      = False
 341
 342 compareLength :: [a] -> [b] -> Ordering
 343 compareLength []     []     = EQ
 344 compareLength (_:xs) (_:ys) = compareLength xs ys
 345 compareLength []     _      = LT
 346 compareLength _      []     = GT
 347
 348 ----------------------------
 349 singleton :: a -> [a]
 350 singleton x = [x]
 351
 352 isSingleton :: [a] -> Bool
 353 isSingleton [_] = True
 354 isSingleton _   = False
 355
 356 notNull :: [a] -> Bool
 357 notNull [] = False
 358 notNull _  = True
 359
 360 only :: [a] -> a
 361 #ifdef DEBUG
 362 only [a] = a
 363 #else
 364 only (a:_) = a
 365 #endif
 366 only _ = panic "Util: only"
 367 \end{code}
 368
 369 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 370
 371 \begin{code}
 372 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
 373
 374 # ifndef DEBUG
 375 isIn    _msg x ys = elem__    x ys
 376 isn'tIn _msg x ys = notElem__ x ys
 377
 378 --these are here to be SPECIALIZEd (automagically)
 379 elem__ :: Eq a => a -> [a] -> Bool
 380 elem__ _ []     = False
 381 elem__ x (y:ys) = x == y || elem__ x ys
 382
 383 notElem__ :: Eq a => a -> [a] -> Bool
 384 notElem__ _ []     = True
 385 notElem__ x (y:ys) = x /= y && notElem__ x ys
 386
 387 # else /* DEBUG */
 388 isIn msg x ys
 389   = elem (_ILIT(0)) x ys
 390   where
 391     elem _ _ []        = False
 392     elem i x (y:ys)
 393       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
 394                                 (x `List.elem` (y:ys))
 395       | otherwise       = x == y || elem (i +# _ILIT(1)) x ys
 396
 397 isn'tIn msg x ys
 398   = notElem (_ILIT(0)) x ys
 399   where
 400     notElem _ _ [] =  True
 401     notElem i x (y:ys)
 402       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
 403                                 (x `List.notElem` (y:ys))
 404       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 405 # endif /* DEBUG */
 406 \end{code}
 407
 408 %************************************************************************
 409 %*                                                                      *
 410 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 411 %*                                                                      *
 412 %************************************************************************
 413
 414 \begin{display}
 415 Date: Mon, 3 May 93 20:45:23 +0200
 416 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 417 To: partain@dcs.gla.ac.uk
 418 Subject: natural merge sort beats quick sort [ and it is prettier ]
 419
 420 Here is a piece of Haskell code that I'm rather fond of. See it as an
 421 attempt to get rid of the ridiculous quick-sort routine. group is
 422 quite useful by itself I think it was John's idea originally though I
 423 believe the lazy version is due to me [surprisingly complicated].
 424 gamma [used to be called] is called gamma because I got inspired by
 425 the Gamma calculus. It is not very close to the calculus but does
 426 behave less sequentially than both foldr and foldl. One could imagine
 427 a version of gamma that took a unit element as well thereby avoiding
 428 the problem with empty lists.
 429
 430 I've tried this code against
 431
 432    1) insertion sort - as provided by haskell
 433    2) the normal implementation of quick sort
 434    3) a deforested version of quick sort due to Jan Sparud
 435    4) a super-optimized-quick-sort of Lennart's
 436
 437 If the list is partially sorted both merge sort and in particular
 438 natural merge sort wins. If the list is random [ average length of
 439 rising subsequences = approx 2 ] mergesort still wins and natural
 440 merge sort is marginally beaten by Lennart's soqs. The space
 441 consumption of merge sort is a bit worse than Lennart's quick sort
 442 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 443 fpca article ] isn't used because of group.
 444
 445 have fun
 446 Carsten
 447 \end{display}
 448
 449 \begin{code}
 450 group :: (a -> a -> Bool) -> [a] -> [[a]]
 451 -- Given a <= function, group finds maximal contiguous up-runs
 452 -- or down-runs in the input list.
 453 -- It's stable, in the sense that it never re-orders equal elements
 454 --
 455 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 456 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 457 -- Here is a `better' definition of group.
 458
 459 group _ []     = []
 460 group p (x:xs) = group' xs x x (x :)
 461   where
 462     group' []     _     _     s  = [s []]
 463     group' (x:xs) x_min x_max s
 464         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 465         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 466         | otherwise         = s [] : group' xs x x (x :)
 467         -- NB: the 'not' is essential for stablity
 468         --     x `p` x_min would reverse equal elements
 469
 470 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 471 generalMerge _ xs [] = xs
 472 generalMerge _ [] ys = ys
 473 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 474                              | otherwise = y : generalMerge p (x:xs) ys
 475
 476 -- gamma is now called balancedFold
 477
 478 balancedFold :: (a -> a -> a) -> [a] -> a
 479 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 480 balancedFold _ [x] = x
 481 balancedFold f l  = balancedFold f (balancedFold' f l)
 482
 483 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 484 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 485 balancedFold' _ xs = xs
 486
 487 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 488 generalNaturalMergeSort _ [] = []
 489 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 490
 491 #if NOT_USED
 492 generalMergeSort p [] = []
 493 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 494
 495 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 496
 497 mergeSort = generalMergeSort (<=)
 498 naturalMergeSort = generalNaturalMergeSort (<=)
 499
 500 mergeSortLe le = generalMergeSort le
 501 #endif
 502
 503 sortLe :: (a->a->Bool) -> [a] -> [a]
 504 sortLe le = generalNaturalMergeSort le
 505
 506 sortWith :: Ord b => (a->b) -> [a] -> [a]
 507 sortWith get_key xs = sortLe le xs
 508   where
 509     x `le` y = get_key x < get_key y
 510
 511 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 512 on cmp sel = \x y -> sel x `cmp` sel y
 513
 514 \end{code}
 515
 516 %************************************************************************
 517 %*                                                                      *
 518 \subsection[Utils-transitive-closure]{Transitive closure}
 519 %*                                                                      *
 520 %************************************************************************
 521
 522 This algorithm for transitive closure is straightforward, albeit quadratic.
 523
 524 \begin{code}
 525 transitiveClosure :: (a -> [a])         -- Successor function
 526                   -> (a -> a -> Bool)   -- Equality predicate
 527                   -> [a]
 528                   -> [a]                -- The transitive closure
 529
 530 transitiveClosure succ eq xs
 531  = go [] xs
 532  where
 533    go done []                      = done
 534    go done (x:xs) | x `is_in` done = go done xs
 535                   | otherwise      = go (x:done) (succ x ++ xs)
 536
 537    _ `is_in` []                 = False
 538    x `is_in` (y:ys) | eq x y    = True
 539                     | otherwise = x `is_in` ys
 540 \end{code}
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsection[Utils-accum]{Accumulating}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 A combination of foldl with zip.  It works with equal length lists.
 549
 550 \begin{code}
 551 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 552 foldl2 _ z [] [] = z
 553 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 554 foldl2 _ _ _      _      = panic "Util: foldl2"
 555
 556 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 557 -- True if the lists are the same length, and
 558 -- all corresponding elements satisfy the predicate
 559 all2 _ []     []     = True
 560 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 561 all2 _ _      _      = False
 562 \end{code}
 563
 564 Count the number of times a predicate is true
 565
 566 \begin{code}
 567 count :: (a -> Bool) -> [a] -> Int
 568 count _ [] = 0
 569 count p (x:xs) | p x       = 1 + count p xs
 570                | otherwise = count p xs
 571 \end{code}
 572
 573 @splitAt@, @take@, and @drop@ but with length of another
 574 list giving the break-off point:
 575
 576 \begin{code}
 577 takeList :: [b] -> [a] -> [a]
 578 takeList [] _ = []
 579 takeList (_:xs) ls =
 580    case ls of
 581      [] -> []
 582      (y:ys) -> y : takeList xs ys
 583
 584 dropList :: [b] -> [a] -> [a]
 585 dropList [] xs    = xs
 586 dropList _  xs@[] = xs
 587 dropList (_:xs) (_:ys) = dropList xs ys
 588
 589
 590 splitAtList :: [b] -> [a] -> ([a], [a])
 591 splitAtList [] xs     = ([], xs)
 592 splitAtList _ xs@[]   = (xs, xs)
 593 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 594     where
 595       (ys', ys'') = splitAtList xs ys
 596
 597 snocView :: [a] -> Maybe ([a],a)
 598         -- Split off the last element
 599 snocView [] = Nothing
 600 snocView xs = go [] xs
 601             where
 602                 -- Invariant: second arg is non-empty
 603               go acc [x]    = Just (reverse acc, x)
 604               go acc (x:xs) = go (x:acc) xs
 605               go _   []     = panic "Util: snocView"
 606
 607 split :: Char -> String -> [String]
 608 split c s = case rest of
 609                 []     -> [chunk]
 610                 _:rest -> chunk : split c rest
 611   where (chunk, rest) = break (==c) s
 612 \end{code}
 613
 614
 615 %************************************************************************
 616 %*                                                                      *
 617 \subsection[Utils-comparison]{Comparisons}
 618 %*                                                                      *
 619 %************************************************************************
 620
 621 \begin{code}
 622 isEqual :: Ordering -> Bool
 623 -- Often used in (isEqual (a `compare` b))
 624 isEqual GT = False
 625 isEqual EQ = True
 626 isEqual LT = False
 627
 628 thenCmp :: Ordering -> Ordering -> Ordering
 629 {-# INLINE thenCmp #-}
 630 thenCmp EQ       ordering = ordering
 631 thenCmp ordering _        = ordering
 632
 633 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 634 eqListBy _  []     []     = True
 635 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 636 eqListBy _  _      _      = False
 637
 638 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 639     -- `cmpList' uses a user-specified comparer
 640
 641 cmpList _   []     [] = EQ
 642 cmpList _   []     _  = LT
 643 cmpList _   _      [] = GT
 644 cmpList cmp (a:as) (b:bs)
 645   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 646 \end{code}
 647
 648 \begin{code}
 649 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
 650 -- This definition can be removed once we require at least 6.8 to build.
 651 maybePrefixMatch :: String -> String -> Maybe String
 652 maybePrefixMatch []    rest = Just rest
 653 maybePrefixMatch (_:_) []   = Nothing
 654 maybePrefixMatch (p:pat) (r:rest)
 655   | p == r    = maybePrefixMatch pat rest
 656   | otherwise = Nothing
 657
 658 removeSpaces :: String -> String
 659 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection[Utils-pairs]{Pairs}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 \begin{code}
 669 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 670 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 671 \end{code}
 672
 673 \begin{code}
 674 seqList :: [a] -> b -> b
 675 seqList [] b = b
 676 seqList (x:xs) b = x `seq` seqList xs b
 677 \end{code}
 678
 679 Global variables:
 680
 681 \begin{code}
 682 global :: a -> IORef a
 683 global a = unsafePerformIO (newIORef a)
 684 \end{code}
 685
 686 \begin{code}
 687 consIORef :: IORef [a] -> a -> IO ()
 688 consIORef var x = do
 689   xs <- readIORef var
 690   writeIORef var (x:xs)
 691 \end{code}
 692
 693 Module names:
 694
 695 \begin{code}
 696 looksLikeModuleName :: String -> Bool
 697 looksLikeModuleName [] = False
 698 looksLikeModuleName (c:cs) = isUpper c && go cs
 699   where go [] = True
 700         go ('.':cs) = looksLikeModuleName cs
 701         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 702 \end{code}
 703
 704 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 705 quoted strings as Haskell Strings, and also parses Haskell [String]
 706 syntax.
 707
 708 \begin{code}
 709 getCmd :: String -> Either String             -- Error
 710                            (String, String) -- (Cmd, Rest)
 711 getCmd s = case break isSpace $ dropWhile isSpace s of
 712            ([], _) -> Left ("Couldn't find command in " ++ show s)
 713            res -> Right res
 714
 715 toCmdArgs :: String -> Either String             -- Error
 716                               (String, [String]) -- (Cmd, Args)
 717 toCmdArgs s = case getCmd s of
 718               Left err -> Left err
 719               Right (cmd, s') -> case toArgs s' of
 720                                  Left err -> Left err
 721                                  Right args -> Right (cmd, args)
 722
 723 toArgs :: String -> Either String   -- Error
 724                            [String] -- Args
 725 toArgs str
 726     = case dropWhile isSpace str of
 727       s@('[':_) -> case reads s of
 728                    [(args, spaces)]
 729                     | all isSpace spaces ->
 730                        Right args
 731                    _ ->
 732                        Left ("Couldn't read " ++ show str ++ "as [String]")
 733       s -> toArgs' s
 734  where
 735   toArgs' s = case dropWhile isSpace s of
 736               [] -> Right []
 737               ('"' : _) -> case reads s of
 738                            [(arg, rest)]
 739                               -- rest must either be [] or start with a space
 740                             | all isSpace (take 1 rest) ->
 741                                case toArgs' rest of
 742                                Left err -> Left err
 743                                Right args -> Right (arg : args)
 744                            _ ->
 745                                Left ("Couldn't read " ++ show s ++ "as String")
 746               s' -> case break isSpace s' of
 747                     (arg, s'') -> case toArgs' s'' of
 748                                   Left err -> Left err
 749                                   Right args -> Right (arg : args)
 750 \end{code}
 751
 752 -- -----------------------------------------------------------------------------
 753 -- Floats
 754
 755 \begin{code}
 756 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 757 readRational__ r = do
 758      (n,d,s) <- readFix r
 759      (k,t)   <- readExp s
 760      return ((n%1)*10^^(k-d), t)
 761  where
 762      readFix r = do
 763         (ds,s)  <- lexDecDigits r
 764         (ds',t) <- lexDotDigits s
 765         return (read (ds++ds'), length ds', t)
 766
 767      readExp (e:s) | e `elem` "eE" = readExp' s
 768      readExp s                     = return (0,s)
 769
 770      readExp' ('+':s) = readDec s
 771      readExp' ('-':s) = do (k,t) <- readDec s
 772                            return (-k,t)
 773      readExp' s       = readDec s
 774
 775      readDec s = do
 776         (ds,r) <- nonnull isDigit s
 777         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 778                 r)
 779
 780      lexDecDigits = nonnull isDigit
 781
 782      lexDotDigits ('.':s) = return (span isDigit s)
 783      lexDotDigits s       = return ("",s)
 784
 785      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 786                       return (cs,t)
 787
 788 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 789 readRational top_s
 790   = case top_s of
 791       '-' : xs -> - (read_me xs)
 792       xs       -> read_me xs
 793   where
 794     read_me s
 795       = case (do { (x,"") <- readRational__ s ; return x }) of
 796           [x] -> x
 797           []  -> error ("readRational: no parse:"        ++ top_s)
 798           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 799
 800
 801 -----------------------------------------------------------------------------
 802 -- Create a hierarchy of directories
 803
 804 createDirectoryHierarchy :: FilePath -> IO ()
 805 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 806 createDirectoryHierarchy dir = do
 807   b <- doesDirectoryExist dir
 808   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 809                 createDirectory dir
 810
 811 -----------------------------------------------------------------------------
 812 -- Verify that the 'dirname' portion of a FilePath exists.
 813 --
 814 doesDirNameExist :: FilePath -> IO Bool
 815 doesDirNameExist fpath = case takeDirectory fpath of
 816                          "" -> return True -- XXX Hack
 817                          _  -> doesDirectoryExist (takeDirectory fpath)
 818
 819 -- -----------------------------------------------------------------------------
 820 -- Exception utils
 821
 822 later :: IO b -> IO a -> IO a
 823 later = flip finally
 824
 825 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 826 handleDyn = flip catchDyn
 827
 828 handle :: (Exception -> IO a) -> IO a -> IO a
 829 handle h f = f `Exception.catch` \e -> case e of
 830     ExitException _ -> throw e
 831     _               -> h e
 832
 833 -- --------------------------------------------------------------
 834 -- check existence & modification time at the same time
 835
 836 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 837 modificationTimeIfExists f = do
 838   (do t <- getModificationTime f; return (Just t))
 839         `IO.catch` \e -> if isDoesNotExistError e
 840                          then return Nothing
 841                          else ioError e
 842
 843 -- split a string at the last character where 'pred' is True,
 844 -- returning a pair of strings. The first component holds the string
 845 -- up (but not including) the last character for which 'pred' returned
 846 -- True, the second whatever comes after (but also not including the
 847 -- last character).
 848 --
 849 -- 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 -- empty).
 852 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 853 splitLongestPrefix str pred
 854   | null r_pre = (str,           [])
 855   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 856                            -- 'tail' drops the char satisfying 'pred'
 857   where (r_suf, r_pre) = break pred (reverse str)
 858
 859 escapeSpaces :: String -> String
 860 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 861
 862 type Suffix = String
 863
 864 --------------------------------------------------------------
 865 -- * Search path
 866 --------------------------------------------------------------
 867
 868 -- | The function splits the given string to substrings
 869 -- using the 'searchPathSeparator'.
 870 parseSearchPath :: String -> [FilePath]
 871 parseSearchPath path = split path
 872   where
 873     split :: String -> [String]
 874     split s =
 875       case rest' of
 876         []     -> [chunk]
 877         _:rest -> chunk : split rest
 878       where
 879         chunk =
 880           case chunk' of
 881 #ifdef mingw32_HOST_OS
 882             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 883 #endif
 884             _                                 -> chunk'
 885
 886         (chunk', rest') = break (==searchPathSeparator) s
 887
 888 -- | A platform-specific character used to separate search path strings in
 889 -- environment variables. The separator is a colon (\":\") on Unix and
 890 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
 891 searchPathSeparator :: Char
 892 #if mingw32_HOST_OS || mingw32_TARGET_OS
 893 searchPathSeparator = ';'
 894 #else
 895 searchPathSeparator = ':'
 896 #endif
 897
 898 data Direction = Forwards | Backwards
 899
 900 reslash :: Direction -> FilePath -> FilePath
 901 reslash d = f
 902     where f ('/'  : xs) = slash : f xs
 903           f ('\\' : xs) = slash : f xs
 904           f (x    : xs) = x     : f xs
 905           f ""          = ""
 906           slash = case d of
 907                   Forwards -> '/'
 908                   Backwards -> '\\'
 909 \end{code}
 910