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