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