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