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