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