compiler/utils/Util.lhs

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