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