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