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