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