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         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 __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 and escaped characters within the input as solid blocks
 661 of characters.  Doesn't raise any exceptions on malformed escapes or
 662 quoting.
 663
 664 \begin{code}
 665 toArgs :: String -> [String]
 666 toArgs "" = []
 667 toArgs s  =
 668   case dropWhile isSpace s of  -- drop initial spacing
 669     [] -> []  -- empty, so no more tokens
 670     rem -> let (tok,aft) = token rem [] in tok : toArgs aft
 671  where
 672    -- Grab a token off the string, given that the first character exists and
 673    -- isn't whitespace.  The second argument is an accumulator which has to be
 674    -- reversed at the end.
 675   token [] acc = (reverse acc,[])            -- out of characters
 676   token ('\\':c:aft) acc                     -- escapes
 677                = token aft ((escape c) : acc)
 678   token (q:aft) acc | q == '"' || q == '\''  -- open quotes
 679                = let (aft',acc') = quote q aft acc in token aft' acc'
 680   token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
 681                = (reverse acc,aft)
 682   token (c:aft) acc                          -- anything else goes in the token
 683                = token aft (c:acc)
 684
 685    -- Get the appropriate character for a single-character escape.
 686   escape 'n' = '\n'
 687   escape 't' = '\t'
 688   escape 'r' = '\r'
 689   escape c   = c
 690
 691    -- Read into accumulator until a quote character is found.
 692   quote qc =
 693     let quote' [] acc                  = ([],acc)
 694         quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
 695         quote' (c:aft) acc | c == qc   = (aft,acc)
 696         quote' (c:aft) acc             = quote' aft (c:acc)
 697     in quote'
 698 \end{code}
 699
 700 -- -----------------------------------------------------------------------------
 701 -- Floats
 702
 703 \begin{code}
 704 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 705 readRational__ r = do
 706      (n,d,s) <- readFix r
 707      (k,t)   <- readExp s
 708      return ((n%1)*10^^(k-d), t)
 709  where
 710      readFix r = do
 711         (ds,s)  <- lexDecDigits r
 712         (ds',t) <- lexDotDigits s
 713         return (read (ds++ds'), length ds', t)
 714
 715      readExp (e:s) | e `elem` "eE" = readExp' s
 716      readExp s                     = return (0,s)
 717
 718      readExp' ('+':s) = readDec s
 719      readExp' ('-':s) = do (k,t) <- readDec s
 720                            return (-k,t)
 721      readExp' s       = readDec s
 722
 723      readDec s = do
 724         (ds,r) <- nonnull isDigit s
 725         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 726                 r)
 727
 728      lexDecDigits = nonnull isDigit
 729
 730      lexDotDigits ('.':s) = return (span isDigit s)
 731      lexDotDigits s       = return ("",s)
 732
 733      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 734                       return (cs,t)
 735
 736 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 737 readRational top_s
 738   = case top_s of
 739       '-' : xs -> - (read_me xs)
 740       xs       -> read_me xs
 741   where
 742     read_me s
 743       = case (do { (x,"") <- readRational__ s ; return x }) of
 744           [x] -> x
 745           []  -> error ("readRational: no parse:"        ++ top_s)
 746           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 747
 748
 749 -----------------------------------------------------------------------------
 750 -- Create a hierarchy of directories
 751
 752 createDirectoryHierarchy :: FilePath -> IO ()
 753 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 754 createDirectoryHierarchy dir = do
 755   b <- doesDirectoryExist dir
 756   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 757                 createDirectory dir
 758
 759 -----------------------------------------------------------------------------
 760 -- Verify that the 'dirname' portion of a FilePath exists.
 761 --
 762 doesDirNameExist :: FilePath -> IO Bool
 763 doesDirNameExist fpath = case takeDirectory fpath of
 764                          "" -> return True -- XXX Hack
 765                          _  -> doesDirectoryExist (takeDirectory fpath)
 766
 767 -- -----------------------------------------------------------------------------
 768 -- Exception utils
 769
 770 later :: IO b -> IO a -> IO a
 771 later = flip finally
 772
 773 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 774 handleDyn = flip catchDyn
 775
 776 handle :: (Exception -> IO a) -> IO a -> IO a
 777 handle h f = f `Exception.catch` \e -> case e of
 778     ExitException _ -> throw e
 779     _               -> h e
 780
 781 -- --------------------------------------------------------------
 782 -- check existence & modification time at the same time
 783
 784 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 785 modificationTimeIfExists f = do
 786   (do t <- getModificationTime f; return (Just t))
 787         `IO.catch` \e -> if isDoesNotExistError e
 788                          then return Nothing
 789                          else ioError e
 790
 791 -- split a string at the last character where 'pred' is True,
 792 -- returning a pair of strings. The first component holds the string
 793 -- up (but not including) the last character for which 'pred' returned
 794 -- True, the second whatever comes after (but also not including the
 795 -- last character).
 796 --
 797 -- If 'pred' returns False for all characters in the string, the original
 798 -- string is returned in the first component (and the second one is just
 799 -- empty).
 800 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 801 splitLongestPrefix str pred
 802   | null r_pre = (str,           [])
 803   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 804                            -- 'tail' drops the char satisfying 'pred'
 805   where (r_suf, r_pre) = break pred (reverse str)
 806
 807 escapeSpaces :: String -> String
 808 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 809
 810 type Suffix = String
 811
 812 --------------------------------------------------------------
 813 -- * Search path
 814 --------------------------------------------------------------
 815
 816 -- | The function splits the given string to substrings
 817 -- using the 'searchPathSeparator'.
 818 parseSearchPath :: String -> [FilePath]
 819 parseSearchPath path = split path
 820   where
 821     split :: String -> [String]
 822     split s =
 823       case rest' of
 824         []     -> [chunk]
 825         _:rest -> chunk : split rest
 826       where
 827         chunk =
 828           case chunk' of
 829 #ifdef mingw32_HOST_OS
 830             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 831 #endif
 832             _                                 -> chunk'
 833
 834         (chunk', rest') = break (==searchPathSeparator) s
 835
 836 -- | A platform-specific character used to separate search path strings in
 837 -- environment variables. The separator is a colon (\":\") on Unix and
 838 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
 839 searchPathSeparator :: Char
 840 #if mingw32_HOST_OS || mingw32_TARGET_OS
 841 searchPathSeparator = ';'
 842 #else
 843 searchPathSeparator = ':'
 844 #endif
 845
 846 data Direction = Forwards | Backwards
 847
 848 reslash :: Direction -> FilePath -> FilePath
 849 reslash d = f
 850     where f ('/'  : xs) = slash : f xs
 851           f ('\\' : xs) = slash : f xs
 852           f (x    : xs) = x     : f xs
 853           f ""          = ""
 854           slash = case d of
 855                   Forwards -> '/'
 856                   Backwards -> '\\'
 857 \end{code}
 858