compiler/utils/Util.lhs

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