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