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 import qualified Data.List as List ( elem )
  88 #ifdef DEBUG
  89 import qualified Data.List as List ( notElem )
  90 import FastTypes
  91 #endif
  92
  93 import Control.Monad    ( unless )
  94 import System.IO.Error as IO ( catch, isDoesNotExistError )
  95 import System.Directory ( doesDirectoryExist, createDirectory,
  96                           getModificationTime )
  97 import System.FilePath
  98 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
  99 import Data.Ratio       ( (%) )
 100 import System.Time      ( ClockTime )
 101
 102 infixr 9 `thenCmp`
 103 \end{code}
 104
 105 %************************************************************************
 106 %*                                                                      *
 107 \subsection{Is DEBUG on, are we on Windows, etc?}
 108 %*                                                                      *
 109 %************************************************************************
 110
 111 These booleans are global constants, set by CPP flags.  They allow us to
 112 recompile a single module (this one) to change whether or not debug output
 113 appears. They sometimes let us avoid even running CPP elsewhere.
 114
 115 It's important that the flags are literal constants (True/False). Then,
 116 with -0, tests of the flags in other modules will simplify to the correct
 117 branch of the conditional, thereby dropping debug code altogether when
 118 the flags are off.
 119
 120 \begin{code}
 121 ghciSupported :: Bool
 122 #ifdef GHCI
 123 ghciSupported = True
 124 #else
 125 ghciSupported = False
 126 #endif
 127
 128 debugIsOn :: Bool
 129 #ifdef DEBUG
 130 debugIsOn = True
 131 #else
 132 debugIsOn = False
 133 #endif
 134
 135 ghciTablesNextToCode :: Bool
 136 #ifdef GHCI_TABLES_NEXT_TO_CODE
 137 ghciTablesNextToCode = True
 138 #else
 139 ghciTablesNextToCode = False
 140 #endif
 141
 142 picIsOn :: Bool
 143 #ifdef __PIC__
 144 picIsOn = True
 145 #else
 146 picIsOn = False
 147 #endif
 148
 149 isWindowsHost :: Bool
 150 #ifdef mingw32_HOST_OS
 151 isWindowsHost = True
 152 #else
 153 isWindowsHost = False
 154 #endif
 155
 156 isWindowsTarget :: Bool
 157 #ifdef mingw32_TARGET_OS
 158 isWindowsTarget = True
 159 #else
 160 isWindowsTarget = False
 161 #endif
 162
 163 isDarwinTarget :: Bool
 164 #ifdef darwin_TARGET_OS
 165 isDarwinTarget = True
 166 #else
 167 isDarwinTarget = False
 168 #endif
 169 \end{code}
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{A for loop}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 -- | Compose a function with itself n times.  (nth rather than twice)
 179 nTimes :: Int -> (a -> a) -> (a -> a)
 180 nTimes 0 _ = id
 181 nTimes 1 f = f
 182 nTimes n f = f . nTimes (n-1) f
 183 \end{code}
 184
 185 %************************************************************************
 186 %*                                                                      *
 187 \subsection[Utils-lists]{General list processing}
 188 %*                                                                      *
 189 %************************************************************************
 190
 191 \begin{code}
 192 filterOut :: (a->Bool) -> [a] -> [a]
 193 -- ^ Like filter, only it reverses the sense of the test
 194 filterOut _ [] = []
 195 filterOut p (x:xs) | p x       = filterOut p xs
 196                    | otherwise = x : filterOut p xs
 197
 198 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 199 -- ^ Uses a function to determine which of two output lists an input element should join
 200 partitionWith _ [] = ([],[])
 201 partitionWith f (x:xs) = case f x of
 202                          Left  b -> (b:bs, cs)
 203                          Right c -> (bs, c:cs)
 204     where (bs,cs) = partitionWith f xs
 205
 206 splitEithers :: [Either a b] -> ([a], [b])
 207 -- ^ Teases a list of 'Either's apart into two lists
 208 splitEithers [] = ([],[])
 209 splitEithers (e : es) = case e of
 210                         Left x -> (x:xs, ys)
 211                         Right y -> (xs, y:ys)
 212     where (xs,ys) = splitEithers es
 213 \end{code}
 214
 215 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 216 are of equal length.  Alastair Reid thinks this should only happen if
 217 DEBUGging on; hey, why not?
 218
 219 \begin{code}
 220 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 221 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 222 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 223 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 224
 225 #ifndef DEBUG
 226 zipEqual      _ = zip
 227 zipWithEqual  _ = zipWith
 228 zipWith3Equal _ = zipWith3
 229 zipWith4Equal _ = zipWith4
 230 #else
 231 zipEqual _   []     []     = []
 232 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 233 zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
 234
 235 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 236 zipWithEqual _   _ [] []        =  []
 237 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 238
 239 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 240                                 =  z a b c : zipWith3Equal msg z as bs cs
 241 zipWith3Equal _   _ [] []  []   =  []
 242 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 243
 244 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 245                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 246 zipWith4Equal _   _ [] [] [] [] =  []
 247 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 248 #endif
 249 \end{code}
 250
 251 \begin{code}
 252 -- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~)
 253 zipLazy :: [a] -> [b] -> [(a,b)]
 254 zipLazy []     _       = []
 255 -- We want to write this, but with GHC 6.4 we get a warning, so it
 256 -- doesn't validate:
 257 -- zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 258 -- so we write this instead:
 259 zipLazy (x:xs) zs = let y : ys = zs
 260                     in (x,y) : zipLazy xs ys
 261 \end{code}
 262
 263
 264 \begin{code}
 265 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 266 -- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in
 267 -- the places where @p@ returns @True@
 268
 269 stretchZipWith _ _ _ []     _ = []
 270 stretchZipWith p z f (x:xs) ys
 271   | p x       = f x z : stretchZipWith p z f xs ys
 272   | otherwise = case ys of
 273                 []     -> []
 274                 (y:ys) -> f x y : stretchZipWith p z f xs ys
 275 \end{code}
 276
 277
 278 \begin{code}
 279 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
 280 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
 281
 282 mapFst f xys = [(f x, y) | (x,y) <- xys]
 283 mapSnd f xys = [(x, f y) | (x,y) <- xys]
 284
 285 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 286
 287 mapAndUnzip _ [] = ([], [])
 288 mapAndUnzip f (x:xs)
 289   = let (r1,  r2)  = f x
 290         (rs1, rs2) = mapAndUnzip f xs
 291     in
 292     (r1:rs1, r2:rs2)
 293
 294 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 295
 296 mapAndUnzip3 _ [] = ([], [], [])
 297 mapAndUnzip3 f (x:xs)
 298   = let (r1,  r2,  r3)  = f x
 299         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 300     in
 301     (r1:rs1, r2:rs2, r3:rs3)
 302 \end{code}
 303
 304 \begin{code}
 305 nOfThem :: Int -> a -> [a]
 306 nOfThem n thing = replicate n thing
 307
 308 -- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely:
 309 --
 310 -- @
 311 --  atLength atLenPred atEndPred ls n
 312 --   | n < 0         = atLenPred n
 313 --   | length ls < n = atEndPred (n - length ls)
 314 --   | otherwise     = atLenPred (drop n ls)
 315 -- @
 316 atLength :: ([a] -> b)
 317          -> (Int -> b)
 318          -> [a]
 319          -> Int
 320          -> b
 321 atLength atLenPred atEndPred ls n
 322   | n < 0     = atEndPred n
 323   | otherwise = go n ls
 324   where
 325     go n [] = atEndPred n
 326     go 0 ls = atLenPred ls
 327     go n (_:xs) = go (n-1) xs
 328
 329 -- Some special cases of atLength:
 330
 331 lengthExceeds :: [a] -> Int -> Bool
 332 -- ^ > (lengthExceeds xs n) = (length xs > n)
 333 lengthExceeds = atLength notNull (const False)
 334
 335 lengthAtLeast :: [a] -> Int -> Bool
 336 lengthAtLeast = atLength notNull (== 0)
 337
 338 lengthIs :: [a] -> Int -> Bool
 339 lengthIs = atLength null (==0)
 340
 341 listLengthCmp :: [a] -> Int -> Ordering
 342 listLengthCmp = atLength atLen atEnd
 343  where
 344   atEnd 0      = EQ
 345   atEnd x
 346    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 347    | otherwise = GT
 348
 349   atLen []     = EQ
 350   atLen _      = GT
 351
 352 equalLength :: [a] -> [b] -> Bool
 353 equalLength []     []     = True
 354 equalLength (_:xs) (_:ys) = equalLength xs ys
 355 equalLength _      _      = False
 356
 357 compareLength :: [a] -> [b] -> Ordering
 358 compareLength []     []     = EQ
 359 compareLength (_:xs) (_:ys) = compareLength xs ys
 360 compareLength []     _      = LT
 361 compareLength _      []     = GT
 362
 363 ----------------------------
 364 singleton :: a -> [a]
 365 singleton x = [x]
 366
 367 isSingleton :: [a] -> Bool
 368 isSingleton [_] = True
 369 isSingleton _   = False
 370
 371 notNull :: [a] -> Bool
 372 notNull [] = False
 373 notNull _  = True
 374
 375 only :: [a] -> a
 376 #ifdef DEBUG
 377 only [a] = a
 378 #else
 379 only (a:_) = a
 380 #endif
 381 only _ = panic "Util: only"
 382 \end{code}
 383
 384 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 385
 386 \begin{code}
 387 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
 388
 389 # ifndef DEBUG
 390 isIn    _msg x ys = elem__    x ys
 391 isn'tIn _msg x ys = notElem__ x ys
 392
 393 --these are here to be SPECIALIZEd (automagically)
 394 elem__ :: Eq a => a -> [a] -> Bool
 395 elem__ _ []     = False
 396 elem__ x (y:ys) = x == y || elem__ x ys
 397
 398 notElem__ :: Eq a => a -> [a] -> Bool
 399 notElem__ _ []     = True
 400 notElem__ x (y:ys) = x /= y && notElem__ x ys
 401
 402 # else /* DEBUG */
 403 isIn msg x ys
 404   = elem (_ILIT(0)) x ys
 405   where
 406     elem _ _ []        = False
 407     elem i x (y:ys)
 408       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
 409                                 (x `List.elem` (y:ys))
 410       | otherwise       = x == y || elem (i +# _ILIT(1)) x ys
 411
 412 isn'tIn msg x ys
 413   = notElem (_ILIT(0)) x ys
 414   where
 415     notElem _ _ [] =  True
 416     notElem i x (y:ys)
 417       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
 418                                 (x `List.notElem` (y:ys))
 419       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 420 # endif /* DEBUG */
 421 \end{code}
 422
 423 %************************************************************************
 424 %*                                                                      *
 425 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 426 %*                                                                      *
 427 %************************************************************************
 428
 429 \begin{display}
 430 Date: Mon, 3 May 93 20:45:23 +0200
 431 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 432 To: partain@dcs.gla.ac.uk
 433 Subject: natural merge sort beats quick sort [ and it is prettier ]
 434
 435 Here is a piece of Haskell code that I'm rather fond of. See it as an
 436 attempt to get rid of the ridiculous quick-sort routine. group is
 437 quite useful by itself I think it was John's idea originally though I
 438 believe the lazy version is due to me [surprisingly complicated].
 439 gamma [used to be called] is called gamma because I got inspired by
 440 the Gamma calculus. It is not very close to the calculus but does
 441 behave less sequentially than both foldr and foldl. One could imagine
 442 a version of gamma that took a unit element as well thereby avoiding
 443 the problem with empty lists.
 444
 445 I've tried this code against
 446
 447    1) insertion sort - as provided by haskell
 448    2) the normal implementation of quick sort
 449    3) a deforested version of quick sort due to Jan Sparud
 450    4) a super-optimized-quick-sort of Lennart's
 451
 452 If the list is partially sorted both merge sort and in particular
 453 natural merge sort wins. If the list is random [ average length of
 454 rising subsequences = approx 2 ] mergesort still wins and natural
 455 merge sort is marginally beaten by Lennart's soqs. The space
 456 consumption of merge sort is a bit worse than Lennart's quick sort
 457 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 458 fpca article ] isn't used because of group.
 459
 460 have fun
 461 Carsten
 462 \end{display}
 463
 464 \begin{code}
 465 group :: (a -> a -> Bool) -> [a] -> [[a]]
 466 -- Given a <= function, group finds maximal contiguous up-runs
 467 -- or down-runs in the input list.
 468 -- It's stable, in the sense that it never re-orders equal elements
 469 --
 470 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 471 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 472 -- Here is a `better' definition of group.
 473
 474 group _ []     = []
 475 group p (x:xs) = group' xs x x (x :)
 476   where
 477     group' []     _     _     s  = [s []]
 478     group' (x:xs) x_min x_max s
 479         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 480         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 481         | otherwise         = s [] : group' xs x x (x :)
 482         -- NB: the 'not' is essential for stablity
 483         --     x `p` x_min would reverse equal elements
 484
 485 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 486 generalMerge _ xs [] = xs
 487 generalMerge _ [] ys = ys
 488 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 489                              | otherwise = y : generalMerge p (x:xs) ys
 490
 491 -- gamma is now called balancedFold
 492
 493 balancedFold :: (a -> a -> a) -> [a] -> a
 494 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 495 balancedFold _ [x] = x
 496 balancedFold f l  = balancedFold f (balancedFold' f l)
 497
 498 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 499 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 500 balancedFold' _ xs = xs
 501
 502 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 503 generalNaturalMergeSort _ [] = []
 504 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 505
 506 #if NOT_USED
 507 generalMergeSort p [] = []
 508 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 509
 510 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 511
 512 mergeSort = generalMergeSort (<=)
 513 naturalMergeSort = generalNaturalMergeSort (<=)
 514
 515 mergeSortLe le = generalMergeSort le
 516 #endif
 517
 518 sortLe :: (a->a->Bool) -> [a] -> [a]
 519 sortLe le = generalNaturalMergeSort le
 520
 521 sortWith :: Ord b => (a->b) -> [a] -> [a]
 522 sortWith get_key xs = sortLe le xs
 523   where
 524     x `le` y = get_key x < get_key y
 525
 526 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 527 on cmp sel = \x y -> sel x `cmp` sel y
 528
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsection[Utils-transitive-closure]{Transitive closure}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 This algorithm for transitive closure is straightforward, albeit quadratic.
 538
 539 \begin{code}
 540 transitiveClosure :: (a -> [a])         -- Successor function
 541                   -> (a -> a -> Bool)   -- Equality predicate
 542                   -> [a]
 543                   -> [a]                -- The transitive closure
 544
 545 transitiveClosure succ eq xs
 546  = go [] xs
 547  where
 548    go done []                      = done
 549    go done (x:xs) | x `is_in` done = go done xs
 550                   | otherwise      = go (x:done) (succ x ++ xs)
 551
 552    _ `is_in` []                 = False
 553    x `is_in` (y:ys) | eq x y    = True
 554                     | otherwise = x `is_in` ys
 555 \end{code}
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsection[Utils-accum]{Accumulating}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 A combination of foldl with zip.  It works with equal length lists.
 564
 565 \begin{code}
 566 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 567 foldl2 _ z [] [] = z
 568 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 569 foldl2 _ _ _      _      = panic "Util: foldl2"
 570
 571 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 572 -- True if the lists are the same length, and
 573 -- all corresponding elements satisfy the predicate
 574 all2 _ []     []     = True
 575 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 576 all2 _ _      _      = False
 577 \end{code}
 578
 579 Count the number of times a predicate is true
 580
 581 \begin{code}
 582 count :: (a -> Bool) -> [a] -> Int
 583 count _ [] = 0
 584 count p (x:xs) | p x       = 1 + count p xs
 585                | otherwise = count p xs
 586 \end{code}
 587
 588 @splitAt@, @take@, and @drop@ but with length of another
 589 list giving the break-off point:
 590
 591 \begin{code}
 592 takeList :: [b] -> [a] -> [a]
 593 takeList [] _ = []
 594 takeList (_:xs) ls =
 595    case ls of
 596      [] -> []
 597      (y:ys) -> y : takeList xs ys
 598
 599 dropList :: [b] -> [a] -> [a]
 600 dropList [] xs    = xs
 601 dropList _  xs@[] = xs
 602 dropList (_:xs) (_:ys) = dropList xs ys
 603
 604
 605 splitAtList :: [b] -> [a] -> ([a], [a])
 606 splitAtList [] xs     = ([], xs)
 607 splitAtList _ xs@[]   = (xs, xs)
 608 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 609     where
 610       (ys', ys'') = splitAtList xs ys
 611
 612 -- drop from the end of a list
 613 dropTail :: Int -> [a] -> [a]
 614 dropTail n = reverse . drop n . reverse
 615
 616 snocView :: [a] -> Maybe ([a],a)
 617         -- Split off the last element
 618 snocView [] = Nothing
 619 snocView xs = go [] xs
 620             where
 621                 -- Invariant: second arg is non-empty
 622               go acc [x]    = Just (reverse acc, x)
 623               go acc (x:xs) = go (x:acc) xs
 624               go _   []     = panic "Util: snocView"
 625
 626 split :: Char -> String -> [String]
 627 split c s = case rest of
 628                 []     -> [chunk]
 629                 _:rest -> chunk : split c rest
 630   where (chunk, rest) = break (==c) s
 631 \end{code}
 632
 633
 634 %************************************************************************
 635 %*                                                                      *
 636 \subsection[Utils-comparison]{Comparisons}
 637 %*                                                                      *
 638 %************************************************************************
 639
 640 \begin{code}
 641 isEqual :: Ordering -> Bool
 642 -- Often used in (isEqual (a `compare` b))
 643 isEqual GT = False
 644 isEqual EQ = True
 645 isEqual LT = False
 646
 647 thenCmp :: Ordering -> Ordering -> Ordering
 648 {-# INLINE thenCmp #-}
 649 thenCmp EQ       ordering = ordering
 650 thenCmp ordering _        = ordering
 651
 652 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 653 eqListBy _  []     []     = True
 654 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 655 eqListBy _  _      _      = False
 656
 657 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 658     -- `cmpList' uses a user-specified comparer
 659
 660 cmpList _   []     [] = EQ
 661 cmpList _   []     _  = LT
 662 cmpList _   _      [] = GT
 663 cmpList cmp (a:as) (b:bs)
 664   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 665 \end{code}
 666
 667 \begin{code}
 668 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
 669 -- This definition can be removed once we require at least 6.8 to build.
 670 maybePrefixMatch :: String -> String -> Maybe String
 671 maybePrefixMatch []    rest = Just rest
 672 maybePrefixMatch (_:_) []   = Nothing
 673 maybePrefixMatch (p:pat) (r:rest)
 674   | p == r    = maybePrefixMatch pat rest
 675   | otherwise = Nothing
 676
 677 removeSpaces :: String -> String
 678 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 679 \end{code}
 680
 681 %************************************************************************
 682 %*                                                                      *
 683 \subsection[Utils-pairs]{Pairs}
 684 %*                                                                      *
 685 %************************************************************************
 686
 687 \begin{code}
 688 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 689 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 690 \end{code}
 691
 692 \begin{code}
 693 seqList :: [a] -> b -> b
 694 seqList [] b = b
 695 seqList (x:xs) b = x `seq` seqList xs b
 696 \end{code}
 697
 698 Global variables:
 699
 700 \begin{code}
 701 global :: a -> IORef a
 702 global a = unsafePerformIO (newIORef a)
 703 \end{code}
 704
 705 \begin{code}
 706 consIORef :: IORef [a] -> a -> IO ()
 707 consIORef var x = do
 708   xs <- readIORef var
 709   writeIORef var (x:xs)
 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