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, globalMVar, globalEmptyMVar,
  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, atomicModifyIORef )
  83 import System.IO.Unsafe ( unsafePerformIO )
  84 import Data.List        hiding (group)
  85 import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar )
  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 = x `elem` ys
 390 isn'tIn _msg x ys = x `notElem` ys
 391
 392 # else /* DEBUG */
 393 isIn msg x ys
 394   = elem100 (_ILIT(0)) x ys
 395   where
 396     elem100 _ _ []        = False
 397     elem100 i x (y:ys)
 398       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
 399                                 (x `elem` (y:ys))
 400       | otherwise       = x == y || elem100 (i +# _ILIT(1)) x ys
 401
 402 isn'tIn msg x ys
 403   = notElem100 (_ILIT(0)) x ys
 404   where
 405     notElem100 _ _ [] =  True
 406     notElem100 i x (y:ys)
 407       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
 408                                 (x `notElem` (y:ys))
 409       | otherwise      =  x /= y && notElem100 (i +# _ILIT(1)) x ys
 410 # endif /* DEBUG */
 411 \end{code}
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{display}
 420 Date: Mon, 3 May 93 20:45:23 +0200
 421 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 422 To: partain@dcs.gla.ac.uk
 423 Subject: natural merge sort beats quick sort [ and it is prettier ]
 424
 425 Here is a piece of Haskell code that I'm rather fond of. See it as an
 426 attempt to get rid of the ridiculous quick-sort routine. group is
 427 quite useful by itself I think it was John's idea originally though I
 428 believe the lazy version is due to me [surprisingly complicated].
 429 gamma [used to be called] is called gamma because I got inspired by
 430 the Gamma calculus. It is not very close to the calculus but does
 431 behave less sequentially than both foldr and foldl. One could imagine
 432 a version of gamma that took a unit element as well thereby avoiding
 433 the problem with empty lists.
 434
 435 I've tried this code against
 436
 437    1) insertion sort - as provided by haskell
 438    2) the normal implementation of quick sort
 439    3) a deforested version of quick sort due to Jan Sparud
 440    4) a super-optimized-quick-sort of Lennart's
 441
 442 If the list is partially sorted both merge sort and in particular
 443 natural merge sort wins. If the list is random [ average length of
 444 rising subsequences = approx 2 ] mergesort still wins and natural
 445 merge sort is marginally beaten by Lennart's soqs. The space
 446 consumption of merge sort is a bit worse than Lennart's quick sort
 447 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 448 fpca article ] isn't used because of group.
 449
 450 have fun
 451 Carsten
 452 \end{display}
 453
 454 \begin{code}
 455 group :: (a -> a -> Bool) -> [a] -> [[a]]
 456 -- Given a <= function, group finds maximal contiguous up-runs
 457 -- or down-runs in the input list.
 458 -- It's stable, in the sense that it never re-orders equal elements
 459 --
 460 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 461 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 462 -- Here is a `better' definition of group.
 463
 464 group _ []     = []
 465 group p (x:xs) = group' xs x x (x :)
 466   where
 467     group' []     _     _     s  = [s []]
 468     group' (x:xs) x_min x_max s
 469         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 470         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 471         | otherwise         = s [] : group' xs x x (x :)
 472         -- NB: the 'not' is essential for stablity
 473         --     x `p` x_min would reverse equal elements
 474
 475 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 476 generalMerge _ xs [] = xs
 477 generalMerge _ [] ys = ys
 478 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 479                              | otherwise = y : generalMerge p (x:xs) ys
 480
 481 -- gamma is now called balancedFold
 482
 483 balancedFold :: (a -> a -> a) -> [a] -> a
 484 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 485 balancedFold _ [x] = x
 486 balancedFold f l  = balancedFold f (balancedFold' f l)
 487
 488 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 489 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 490 balancedFold' _ xs = xs
 491
 492 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 493 generalNaturalMergeSort _ [] = []
 494 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 495
 496 #if NOT_USED
 497 generalMergeSort p [] = []
 498 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 499
 500 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 501
 502 mergeSort = generalMergeSort (<=)
 503 naturalMergeSort = generalNaturalMergeSort (<=)
 504
 505 mergeSortLe le = generalMergeSort le
 506 #endif
 507
 508 sortLe :: (a->a->Bool) -> [a] -> [a]
 509 sortLe le = generalNaturalMergeSort le
 510
 511 sortWith :: Ord b => (a->b) -> [a] -> [a]
 512 sortWith get_key xs = sortLe le xs
 513   where
 514     x `le` y = get_key x < get_key y
 515
 516 on :: (a -> a -> c) -> (b -> a) -> b -> b -> c
 517 on cmp sel = \x y -> sel x `cmp` sel y
 518
 519 \end{code}
 520
 521 %************************************************************************
 522 %*                                                                      *
 523 \subsection[Utils-transitive-closure]{Transitive closure}
 524 %*                                                                      *
 525 %************************************************************************
 526
 527 This algorithm for transitive closure is straightforward, albeit quadratic.
 528
 529 \begin{code}
 530 transitiveClosure :: (a -> [a])         -- Successor function
 531                   -> (a -> a -> Bool)   -- Equality predicate
 532                   -> [a]
 533                   -> [a]                -- The transitive closure
 534
 535 transitiveClosure succ eq xs
 536  = go [] xs
 537  where
 538    go done []                      = done
 539    go done (x:xs) | x `is_in` done = go done xs
 540                   | otherwise      = go (x:done) (succ x ++ xs)
 541
 542    _ `is_in` []                 = False
 543    x `is_in` (y:ys) | eq x y    = True
 544                     | otherwise = x `is_in` ys
 545 \end{code}
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsection[Utils-accum]{Accumulating}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 A combination of foldl with zip.  It works with equal length lists.
 554
 555 \begin{code}
 556 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 557 foldl2 _ z [] [] = z
 558 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 559 foldl2 _ _ _      _      = panic "Util: foldl2"
 560
 561 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 562 -- True if the lists are the same length, and
 563 -- all corresponding elements satisfy the predicate
 564 all2 _ []     []     = True
 565 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 566 all2 _ _      _      = False
 567 \end{code}
 568
 569 Count the number of times a predicate is true
 570
 571 \begin{code}
 572 count :: (a -> Bool) -> [a] -> Int
 573 count _ [] = 0
 574 count p (x:xs) | p x       = 1 + count p xs
 575                | otherwise = count p xs
 576 \end{code}
 577
 578 @splitAt@, @take@, and @drop@ but with length of another
 579 list giving the break-off point:
 580
 581 \begin{code}
 582 takeList :: [b] -> [a] -> [a]
 583 takeList [] _ = []
 584 takeList (_:xs) ls =
 585    case ls of
 586      [] -> []
 587      (y:ys) -> y : takeList xs ys
 588
 589 dropList :: [b] -> [a] -> [a]
 590 dropList [] xs    = xs
 591 dropList _  xs@[] = xs
 592 dropList (_:xs) (_:ys) = dropList xs ys
 593
 594
 595 splitAtList :: [b] -> [a] -> ([a], [a])
 596 splitAtList [] xs     = ([], xs)
 597 splitAtList _ xs@[]   = (xs, xs)
 598 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 599     where
 600       (ys', ys'') = splitAtList xs ys
 601
 602 -- drop from the end of a list
 603 dropTail :: Int -> [a] -> [a]
 604 dropTail n = reverse . drop n . reverse
 605
 606 snocView :: [a] -> Maybe ([a],a)
 607         -- Split off the last element
 608 snocView [] = Nothing
 609 snocView xs = go [] xs
 610             where
 611                 -- Invariant: second arg is non-empty
 612               go acc [x]    = Just (reverse acc, x)
 613               go acc (x:xs) = go (x:acc) xs
 614               go _   []     = panic "Util: snocView"
 615
 616 split :: Char -> String -> [String]
 617 split c s = case rest of
 618                 []     -> [chunk]
 619                 _:rest -> chunk : split c rest
 620   where (chunk, rest) = break (==c) s
 621 \end{code}
 622
 623
 624 %************************************************************************
 625 %*                                                                      *
 626 \subsection[Utils-comparison]{Comparisons}
 627 %*                                                                      *
 628 %************************************************************************
 629
 630 \begin{code}
 631 isEqual :: Ordering -> Bool
 632 -- Often used in (isEqual (a `compare` b))
 633 isEqual GT = False
 634 isEqual EQ = True
 635 isEqual LT = False
 636
 637 thenCmp :: Ordering -> Ordering -> Ordering
 638 {-# INLINE thenCmp #-}
 639 thenCmp EQ       ordering = ordering
 640 thenCmp ordering _        = ordering
 641
 642 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 643 eqListBy _  []     []     = True
 644 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 645 eqListBy _  _      _      = False
 646
 647 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 648     -- `cmpList' uses a user-specified comparer
 649
 650 cmpList _   []     [] = EQ
 651 cmpList _   []     _  = LT
 652 cmpList _   _      [] = GT
 653 cmpList cmp (a:as) (b:bs)
 654   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 655 \end{code}
 656
 657 \begin{code}
 658 removeSpaces :: String -> String
 659 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsection[Utils-pairs]{Pairs}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 \begin{code}
 669 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 670 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 671 \end{code}
 672
 673 \begin{code}
 674 seqList :: [a] -> b -> b
 675 seqList [] b = b
 676 seqList (x:xs) b = x `seq` seqList xs b
 677 \end{code}
 678
 679 Global variables:
 680
 681 \begin{code}
 682 global :: a -> IORef a
 683 global a = unsafePerformIO (newIORef a)
 684 \end{code}
 685
 686 \begin{code}
 687 consIORef :: IORef [a] -> a -> IO ()
 688 consIORef var x = do
 689   atomicModifyIORef var (\xs -> (x:xs,()))
 690 \end{code}
 691
 692 \begin{code}
 693 globalMVar :: a -> MVar a
 694 globalMVar a = unsafePerformIO (newMVar a)
 695
 696 globalEmptyMVar :: MVar a
 697 globalEmptyMVar = unsafePerformIO newEmptyMVar
 698 \end{code}
 699
 700 Module names:
 701
 702 \begin{code}
 703 looksLikeModuleName :: String -> Bool
 704 looksLikeModuleName [] = False
 705 looksLikeModuleName (c:cs) = isUpper c && go cs
 706   where go [] = True
 707         go ('.':cs) = looksLikeModuleName cs
 708         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 709 \end{code}
 710
 711 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 712 quoted strings as Haskell Strings, and also parses Haskell [String]
 713 syntax.
 714
 715 \begin{code}
 716 getCmd :: String -> Either String             -- Error
 717                            (String, String) -- (Cmd, Rest)
 718 getCmd s = case break isSpace $ dropWhile isSpace s of
 719            ([], _) -> Left ("Couldn't find command in " ++ show s)
 720            res -> Right res
 721
 722 toCmdArgs :: String -> Either String             -- Error
 723                               (String, [String]) -- (Cmd, Args)
 724 toCmdArgs s = case getCmd s of
 725               Left err -> Left err
 726               Right (cmd, s') -> case toArgs s' of
 727                                  Left err -> Left err
 728                                  Right args -> Right (cmd, args)
 729
 730 toArgs :: String -> Either String   -- Error
 731                            [String] -- Args
 732 toArgs str
 733     = case dropWhile isSpace str of
 734       s@('[':_) -> case reads s of
 735                    [(args, spaces)]
 736                     | all isSpace spaces ->
 737                        Right args
 738                    _ ->
 739                        Left ("Couldn't read " ++ show str ++ "as [String]")
 740       s -> toArgs' s
 741  where
 742   toArgs' s = case dropWhile isSpace s of
 743               [] -> Right []
 744               ('"' : _) -> case reads s of
 745                            [(arg, rest)]
 746                               -- rest must either be [] or start with a space
 747                             | all isSpace (take 1 rest) ->
 748                                case toArgs' rest of
 749                                Left err -> Left err
 750                                Right args -> Right (arg : args)
 751                            _ ->
 752                                Left ("Couldn't read " ++ show s ++ "as String")
 753               s' -> case break isSpace s' of
 754                     (arg, s'') -> case toArgs' s'' of
 755                                   Left err -> Left err
 756                                   Right args -> Right (arg : args)
 757 \end{code}
 758
 759 -- -----------------------------------------------------------------------------
 760 -- Floats
 761
 762 \begin{code}
 763 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 764 readRational__ r = do
 765      (n,d,s) <- readFix r
 766      (k,t)   <- readExp s
 767      return ((n%1)*10^^(k-d), t)
 768  where
 769      readFix r = do
 770         (ds,s)  <- lexDecDigits r
 771         (ds',t) <- lexDotDigits s
 772         return (read (ds++ds'), length ds', t)
 773
 774      readExp (e:s) | e `elem` "eE" = readExp' s
 775      readExp s                     = return (0,s)
 776
 777      readExp' ('+':s) = readDec s
 778      readExp' ('-':s) = do (k,t) <- readDec s
 779                            return (-k,t)
 780      readExp' s       = readDec s
 781
 782      readDec s = do
 783         (ds,r) <- nonnull isDigit s
 784         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 785                 r)
 786
 787      lexDecDigits = nonnull isDigit
 788
 789      lexDotDigits ('.':s) = return (span isDigit s)
 790      lexDotDigits s       = return ("",s)
 791
 792      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 793                       return (cs,t)
 794
 795 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 796 readRational top_s
 797   = case top_s of
 798       '-' : xs -> - (read_me xs)
 799       xs       -> read_me xs
 800   where
 801     read_me s
 802       = case (do { (x,"") <- readRational__ s ; return x }) of
 803           [x] -> x
 804           []  -> error ("readRational: no parse:"        ++ top_s)
 805           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 806
 807
 808 -----------------------------------------------------------------------------
 809 -- Create a hierarchy of directories
 810
 811 createDirectoryHierarchy :: FilePath -> IO ()
 812 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 813 createDirectoryHierarchy dir = do
 814   b <- doesDirectoryExist dir
 815   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 816                 createDirectory dir
 817
 818 -----------------------------------------------------------------------------
 819 -- Verify that the 'dirname' portion of a FilePath exists.
 820 --
 821 doesDirNameExist :: FilePath -> IO Bool
 822 doesDirNameExist fpath = case takeDirectory fpath of
 823                          "" -> return True -- XXX Hack
 824                          _  -> doesDirectoryExist (takeDirectory fpath)
 825
 826 -- --------------------------------------------------------------
 827 -- check existence & modification time at the same time
 828
 829 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 830 modificationTimeIfExists f = do
 831   (do t <- getModificationTime f; return (Just t))
 832         `IO.catch` \e -> if isDoesNotExistError e
 833                          then return Nothing
 834                          else ioError e
 835
 836 -- split a string at the last character where 'pred' is True,
 837 -- returning a pair of strings. The first component holds the string
 838 -- up (but not including) the last character for which 'pred' returned
 839 -- True, the second whatever comes after (but also not including the
 840 -- last character).
 841 --
 842 -- If 'pred' returns False for all characters in the string, the original
 843 -- string is returned in the first component (and the second one is just
 844 -- empty).
 845 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 846 splitLongestPrefix str pred
 847   | null r_pre = (str,           [])
 848   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 849                            -- 'tail' drops the char satisfying 'pred'
 850   where (r_suf, r_pre) = break pred (reverse str)
 851
 852 escapeSpaces :: String -> String
 853 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 854
 855 type Suffix = String
 856
 857 --------------------------------------------------------------
 858 -- * Search path
 859 --------------------------------------------------------------
 860
 861 -- | The function splits the given string to substrings
 862 -- using the 'searchPathSeparator'.
 863 parseSearchPath :: String -> [FilePath]
 864 parseSearchPath path = split path
 865   where
 866     split :: String -> [String]
 867     split s =
 868       case rest' of
 869         []     -> [chunk]
 870         _:rest -> chunk : split rest
 871       where
 872         chunk =
 873           case chunk' of
 874 #ifdef mingw32_HOST_OS
 875             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 876 #endif
 877             _                                 -> chunk'
 878
 879         (chunk', rest') = break isSearchPathSeparator s
 880
 881 data Direction = Forwards | Backwards
 882
 883 reslash :: Direction -> FilePath -> FilePath
 884 reslash d = f
 885     where f ('/'  : xs) = slash : f xs
 886           f ('\\' : xs) = slash : f xs
 887           f (x    : xs) = x     : f xs
 888           f ""          = ""
 889           slash = case d of
 890                   Forwards -> '/'
 891                   Backwards -> '\\'
 892 \end{code}
 893