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