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