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 foldl1' was added in GHC 6.4
 409
 410 \begin{code}
 411 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604
 412 foldl1'          :: (a -> a -> a) -> [a] -> a
 413 foldl1' f (x:xs) =  foldl' f x xs
 414 foldl1' _ []     =  panic "foldl1'"
 415 #endif
 416 \end{code}
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 \begin{display}
 425 Date: Mon, 3 May 93 20:45:23 +0200
 426 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 427 To: partain@dcs.gla.ac.uk
 428 Subject: natural merge sort beats quick sort [ and it is prettier ]
 429
 430 Here is a piece of Haskell code that I'm rather fond of. See it as an
 431 attempt to get rid of the ridiculous quick-sort routine. group is
 432 quite useful by itself I think it was John's idea originally though I
 433 believe the lazy version is due to me [surprisingly complicated].
 434 gamma [used to be called] is called gamma because I got inspired by
 435 the Gamma calculus. It is not very close to the calculus but does
 436 behave less sequentially than both foldr and foldl. One could imagine
 437 a version of gamma that took a unit element as well thereby avoiding
 438 the problem with empty lists.
 439
 440 I've tried this code against
 441
 442    1) insertion sort - as provided by haskell
 443    2) the normal implementation of quick sort
 444    3) a deforested version of quick sort due to Jan Sparud
 445    4) a super-optimized-quick-sort of Lennart's
 446
 447 If the list is partially sorted both merge sort and in particular
 448 natural merge sort wins. If the list is random [ average length of
 449 rising subsequences = approx 2 ] mergesort still wins and natural
 450 merge sort is marginally beaten by Lennart's soqs. The space
 451 consumption of merge sort is a bit worse than Lennart's quick sort
 452 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 453 fpca article ] isn't used because of group.
 454
 455 have fun
 456 Carsten
 457 \end{display}
 458
 459 \begin{code}
 460 group :: (a -> a -> Bool) -> [a] -> [[a]]
 461 -- Given a <= function, group finds maximal contiguous up-runs
 462 -- or down-runs in the input list.
 463 -- It's stable, in the sense that it never re-orders equal elements
 464 --
 465 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 466 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 467 -- Here is a `better' definition of group.
 468
 469 group _ []     = []
 470 group p (x:xs) = group' xs x x (x :)
 471   where
 472     group' []     _     _     s  = [s []]
 473     group' (x:xs) x_min x_max s
 474         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 475         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 476         | otherwise         = s [] : group' xs x x (x :)
 477         -- NB: the 'not' is essential for stablity
 478         --     x `p` x_min would reverse equal elements
 479
 480 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 481 generalMerge _ xs [] = xs
 482 generalMerge _ [] ys = ys
 483 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 484                              | otherwise = y : generalMerge p (x:xs) ys
 485
 486 -- gamma is now called balancedFold
 487
 488 balancedFold :: (a -> a -> a) -> [a] -> a
 489 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 490 balancedFold _ [x] = x
 491 balancedFold f l  = balancedFold f (balancedFold' f l)
 492
 493 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 494 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 495 balancedFold' _ xs = xs
 496
 497 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 498 generalNaturalMergeSort _ [] = []
 499 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 500
 501 #if NOT_USED
 502 generalMergeSort p [] = []
 503 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 504
 505 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 506
 507 mergeSort = generalMergeSort (<=)
 508 naturalMergeSort = generalNaturalMergeSort (<=)
 509
 510 mergeSortLe le = generalMergeSort le
 511 #endif
 512
 513 sortLe :: (a->a->Bool) -> [a] -> [a]
 514 sortLe le = generalNaturalMergeSort le
 515
 516 sortWith :: Ord b => (a->b) -> [a] -> [a]
 517 sortWith get_key xs = sortLe le xs
 518   where
 519     x `le` y = get_key x < get_key y
 520
 521 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 522 on cmp sel = \x y -> sel x `cmp` sel y
 523
 524 \end{code}
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection[Utils-transitive-closure]{Transitive closure}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 This algorithm for transitive closure is straightforward, albeit quadratic.
 533
 534 \begin{code}
 535 transitiveClosure :: (a -> [a])         -- Successor function
 536                   -> (a -> a -> Bool)   -- Equality predicate
 537                   -> [a]
 538                   -> [a]                -- The transitive closure
 539
 540 transitiveClosure succ eq xs
 541  = go [] xs
 542  where
 543    go done []                      = done
 544    go done (x:xs) | x `is_in` done = go done xs
 545                   | otherwise      = go (x:done) (succ x ++ xs)
 546
 547    _ `is_in` []                 = False
 548    x `is_in` (y:ys) | eq x y    = True
 549                     | otherwise = x `is_in` ys
 550 \end{code}
 551
 552 %************************************************************************
 553 %*                                                                      *
 554 \subsection[Utils-accum]{Accumulating}
 555 %*                                                                      *
 556 %************************************************************************
 557
 558 A combination of foldl with zip.  It works with equal length lists.
 559
 560 \begin{code}
 561 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 562 foldl2 _ z [] [] = z
 563 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 564 foldl2 _ _ _      _      = panic "Util: foldl2"
 565
 566 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 567 -- True if the lists are the same length, and
 568 -- all corresponding elements satisfy the predicate
 569 all2 _ []     []     = True
 570 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 571 all2 _ _      _      = False
 572 \end{code}
 573
 574 Count the number of times a predicate is true
 575
 576 \begin{code}
 577 count :: (a -> Bool) -> [a] -> Int
 578 count _ [] = 0
 579 count p (x:xs) | p x       = 1 + count p xs
 580                | otherwise = count p xs
 581 \end{code}
 582
 583 @splitAt@, @take@, and @drop@ but with length of another
 584 list giving the break-off point:
 585
 586 \begin{code}
 587 takeList :: [b] -> [a] -> [a]
 588 takeList [] _ = []
 589 takeList (_:xs) ls =
 590    case ls of
 591      [] -> []
 592      (y:ys) -> y : takeList xs ys
 593
 594 dropList :: [b] -> [a] -> [a]
 595 dropList [] xs    = xs
 596 dropList _  xs@[] = xs
 597 dropList (_:xs) (_:ys) = dropList xs ys
 598
 599
 600 splitAtList :: [b] -> [a] -> ([a], [a])
 601 splitAtList [] xs     = ([], xs)
 602 splitAtList _ xs@[]   = (xs, xs)
 603 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 604     where
 605       (ys', ys'') = splitAtList xs ys
 606
 607 snocView :: [a] -> Maybe ([a],a)
 608         -- Split off the last element
 609 snocView [] = Nothing
 610 snocView xs = go [] xs
 611             where
 612                 -- Invariant: second arg is non-empty
 613               go acc [x]    = Just (reverse acc, x)
 614               go acc (x:xs) = go (x:acc) xs
 615               go _   []     = panic "Util: snocView"
 616
 617 split :: Char -> String -> [String]
 618 split c s = case rest of
 619                 []     -> [chunk]
 620                 _:rest -> chunk : split c rest
 621   where (chunk, rest) = break (==c) s
 622 \end{code}
 623
 624
 625 %************************************************************************
 626 %*                                                                      *
 627 \subsection[Utils-comparison]{Comparisons}
 628 %*                                                                      *
 629 %************************************************************************
 630
 631 \begin{code}
 632 isEqual :: Ordering -> Bool
 633 -- Often used in (isEqual (a `compare` b))
 634 isEqual GT = False
 635 isEqual EQ = True
 636 isEqual LT = False
 637
 638 thenCmp :: Ordering -> Ordering -> Ordering
 639 {-# INLINE thenCmp #-}
 640 thenCmp EQ       ordering = ordering
 641 thenCmp ordering _        = ordering
 642
 643 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 644 eqListBy _  []     []     = True
 645 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 646 eqListBy _  _      _      = False
 647
 648 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 649     -- `cmpList' uses a user-specified comparer
 650
 651 cmpList _   []     [] = EQ
 652 cmpList _   []     _  = LT
 653 cmpList _   _      [] = GT
 654 cmpList cmp (a:as) (b:bs)
 655   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 656 \end{code}
 657
 658 \begin{code}
 659 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
 660 -- This definition can be removed once we require at least 6.8 to build.
 661 maybePrefixMatch :: String -> String -> Maybe String
 662 maybePrefixMatch []    rest = Just rest
 663 maybePrefixMatch (_:_) []   = Nothing
 664 maybePrefixMatch (p:pat) (r:rest)
 665   | p == r    = maybePrefixMatch pat rest
 666   | otherwise = Nothing
 667
 668 removeSpaces :: String -> String
 669 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 670 \end{code}
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsection[Utils-pairs]{Pairs}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 \begin{code}
 679 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 680 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 681 \end{code}
 682
 683 \begin{code}
 684 seqList :: [a] -> b -> b
 685 seqList [] b = b
 686 seqList (x:xs) b = x `seq` seqList xs b
 687 \end{code}
 688
 689 Global variables:
 690
 691 \begin{code}
 692 global :: a -> IORef a
 693 global a = unsafePerformIO (newIORef a)
 694 \end{code}
 695
 696 \begin{code}
 697 consIORef :: IORef [a] -> a -> IO ()
 698 consIORef var x = do
 699   xs <- readIORef var
 700   writeIORef var (x:xs)
 701 \end{code}
 702
 703 Module names:
 704
 705 \begin{code}
 706 looksLikeModuleName :: String -> Bool
 707 looksLikeModuleName [] = False
 708 looksLikeModuleName (c:cs) = isUpper c && go cs
 709   where go [] = True
 710         go ('.':cs) = looksLikeModuleName cs
 711         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 712 \end{code}
 713
 714 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 715 quoted strings as Haskell Strings, and also parses Haskell [String]
 716 syntax.
 717
 718 \begin{code}
 719 getCmd :: String -> Either String             -- Error
 720                            (String, String) -- (Cmd, Rest)
 721 getCmd s = case break isSpace $ dropWhile isSpace s of
 722            ([], _) -> Left ("Couldn't find command in " ++ show s)
 723            res -> Right res
 724
 725 toCmdArgs :: String -> Either String             -- Error
 726                               (String, [String]) -- (Cmd, Args)
 727 toCmdArgs s = case getCmd s of
 728               Left err -> Left err
 729               Right (cmd, s') -> case toArgs s' of
 730                                  Left err -> Left err
 731                                  Right args -> Right (cmd, args)
 732
 733 toArgs :: String -> Either String   -- Error
 734                            [String] -- Args
 735 toArgs str
 736     = case dropWhile isSpace str of
 737       s@('[':_) -> case reads s of
 738                    [(args, spaces)]
 739                     | all isSpace spaces ->
 740                        Right args
 741                    _ ->
 742                        Left ("Couldn't read " ++ show str ++ "as [String]")
 743       s -> toArgs' s
 744  where
 745   toArgs' s = case dropWhile isSpace s of
 746               [] -> Right []
 747               ('"' : _) -> case reads s of
 748                            [(arg, rest)]
 749                               -- rest must either be [] or start with a space
 750                             | all isSpace (take 1 rest) ->
 751                                case toArgs' rest of
 752                                Left err -> Left err
 753                                Right args -> Right (arg : args)
 754                            _ ->
 755                                Left ("Couldn't read " ++ show s ++ "as String")
 756               s' -> case break isSpace s' of
 757                     (arg, s'') -> case toArgs' s'' of
 758                                   Left err -> Left err
 759                                   Right args -> Right (arg : args)
 760 \end{code}
 761
 762 -- -----------------------------------------------------------------------------
 763 -- Floats
 764
 765 \begin{code}
 766 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 767 readRational__ r = do
 768      (n,d,s) <- readFix r
 769      (k,t)   <- readExp s
 770      return ((n%1)*10^^(k-d), t)
 771  where
 772      readFix r = do
 773         (ds,s)  <- lexDecDigits r
 774         (ds',t) <- lexDotDigits s
 775         return (read (ds++ds'), length ds', t)
 776
 777      readExp (e:s) | e `elem` "eE" = readExp' s
 778      readExp s                     = return (0,s)
 779
 780      readExp' ('+':s) = readDec s
 781      readExp' ('-':s) = do (k,t) <- readDec s
 782                            return (-k,t)
 783      readExp' s       = readDec s
 784
 785      readDec s = do
 786         (ds,r) <- nonnull isDigit s
 787         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 788                 r)
 789
 790      lexDecDigits = nonnull isDigit
 791
 792      lexDotDigits ('.':s) = return (span isDigit s)
 793      lexDotDigits s       = return ("",s)
 794
 795      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 796                       return (cs,t)
 797
 798 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 799 readRational top_s
 800   = case top_s of
 801       '-' : xs -> - (read_me xs)
 802       xs       -> read_me xs
 803   where
 804     read_me s
 805       = case (do { (x,"") <- readRational__ s ; return x }) of
 806           [x] -> x
 807           []  -> error ("readRational: no parse:"        ++ top_s)
 808           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 809
 810
 811 -----------------------------------------------------------------------------
 812 -- Create a hierarchy of directories
 813
 814 createDirectoryHierarchy :: FilePath -> IO ()
 815 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 816 createDirectoryHierarchy dir = do
 817   b <- doesDirectoryExist dir
 818   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 819                 createDirectory dir
 820
 821 -----------------------------------------------------------------------------
 822 -- Verify that the 'dirname' portion of a FilePath exists.
 823 --
 824 doesDirNameExist :: FilePath -> IO Bool
 825 doesDirNameExist fpath = case takeDirectory fpath of
 826                          "" -> return True -- XXX Hack
 827                          _  -> doesDirectoryExist (takeDirectory fpath)
 828
 829 -- -----------------------------------------------------------------------------
 830 -- Exception utils
 831
 832 later :: IO b -> IO a -> IO a
 833 later = flip finally
 834
 835 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 836 handleDyn = flip catchDyn
 837
 838 handle :: (Exception -> IO a) -> IO a -> IO a
 839 handle h f = f `Exception.catch` \e -> case e of
 840     ExitException _ -> throw e
 841     _               -> h e
 842
 843 -- --------------------------------------------------------------
 844 -- check existence & modification time at the same time
 845
 846 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 847 modificationTimeIfExists f = do
 848   (do t <- getModificationTime f; return (Just t))
 849         `IO.catch` \e -> if isDoesNotExistError e
 850                          then return Nothing
 851                          else ioError e
 852
 853 -- split a string at the last character where 'pred' is True,
 854 -- returning a pair of strings. The first component holds the string
 855 -- up (but not including) the last character for which 'pred' returned
 856 -- True, the second whatever comes after (but also not including the
 857 -- last character).
 858 --
 859 -- If 'pred' returns False for all characters in the string, the original
 860 -- string is returned in the first component (and the second one is just
 861 -- empty).
 862 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 863 splitLongestPrefix str pred
 864   | null r_pre = (str,           [])
 865   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 866                            -- 'tail' drops the char satisfying 'pred'
 867   where (r_suf, r_pre) = break pred (reverse str)
 868
 869 escapeSpaces :: String -> String
 870 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 871
 872 type Suffix = String
 873
 874 --------------------------------------------------------------
 875 -- * Search path
 876 --------------------------------------------------------------
 877
 878 -- | The function splits the given string to substrings
 879 -- using the 'searchPathSeparator'.
 880 parseSearchPath :: String -> [FilePath]
 881 parseSearchPath path = split path
 882   where
 883     split :: String -> [String]
 884     split s =
 885       case rest' of
 886         []     -> [chunk]
 887         _:rest -> chunk : split rest
 888       where
 889         chunk =
 890           case chunk' of
 891 #ifdef mingw32_HOST_OS
 892             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 893 #endif
 894             _                                 -> chunk'
 895
 896         (chunk', rest') = break (==searchPathSeparator) s
 897
 898 -- | A platform-specific character used to separate search path strings in
 899 -- environment variables. The separator is a colon (\":\") on Unix and
 900 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
 901 searchPathSeparator :: Char
 902 #if mingw32_HOST_OS || mingw32_TARGET_OS
 903 searchPathSeparator = ';'
 904 #else
 905 searchPathSeparator = ':'
 906 #endif
 907
 908 data Direction = Forwards | Backwards
 909
 910 reslash :: Direction -> FilePath -> FilePath
 911 reslash d = f
 912     where f ('/'  : xs) = slash : f xs
 913           f ('\\' : xs) = slash : f xs
 914           f (x    : xs) = x     : f xs
 915           f ""          = ""
 916           slash = case d of
 917                   Forwards -> '/'
 918                   Backwards -> '\\'
 919 \end{code}
 920