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_GHC -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/WorkingConventions#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
  24         lengthExceeds, lengthIs, lengthAtLeast,
  25         listLengthCmp, atLength, equalLength, compareLength,
  26
  27         isSingleton, only, singleton,
  28         notNull, snocView,
  29
  30         isIn, isn'tIn,
  31
  32         -- for-loop
  33         nTimes,
  34
  35         -- sorting
  36         sortLe, sortWith, on,
  37
  38         -- transitive closures
  39         transitiveClosure,
  40
  41         -- accumulating
  42         foldl2, count, all2,
  43
  44         takeList, dropList, splitAtList, split,
  45
  46         -- comparisons
  47         isEqual, eqListBy,
  48         thenCmp, cmpList, maybePrefixMatch,
  49         removeSpaces,
  50
  51         -- strictness
  52         seqList,
  53
  54         -- pairs
  55         unzipWith,
  56
  57         global, consIORef,
  58
  59         -- module names
  60         looksLikeModuleName,
  61
  62         toArgs,
  63
  64         -- Floating point stuff
  65         readRational,
  66
  67         -- IO-ish utilities
  68         createDirectoryHierarchy,
  69         doesDirNameExist,
  70         modificationTimeIfExists,
  71
  72         later, handleDyn, handle,
  73
  74         -- Filename utils
  75         Suffix,
  76         splitFilename, suffixOf, basenameOf, joinFileExt,
  77         splitFilenameDir, joinFileName,
  78         splitFilename3,
  79         splitLongestPrefix,
  80         replaceFilenameSuffix, directoryOf, filenameOf,
  81         replaceFilenameDirectory,
  82         escapeSpaces, isPathSeparator,
  83         parseSearchPath,
  84         normalisePath, platformPath, pgmPath,
  85     ) where
  86
  87 #include "HsVersions.h"
  88
  89 import FastTypes
  90
  91 #ifdef DEBUG
  92 import Panic            ( panic, trace )
  93 #endif
  94
  95 import Control.Exception ( Exception(..), finally, catchDyn, throw )
  96 import qualified Control.Exception as Exception
  97 import Data.Dynamic     ( Typeable )
  98 import Data.IORef       ( IORef, newIORef )
  99 import System.IO.Unsafe ( unsafePerformIO )
 100 import Data.IORef       ( readIORef, writeIORef )
 101
 102 import qualified Data.List as List ( elem )
 103 #ifndef DEBUG
 104 import Data.List                ( zipWith4 )
 105 #else
 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 %************************************************************************
 367 %*                                                                      *
 368 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{display}
 373 Date: Mon, 3 May 93 20:45:23 +0200
 374 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 375 To: partain@dcs.gla.ac.uk
 376 Subject: natural merge sort beats quick sort [ and it is prettier ]
 377
 378 Here is a piece of Haskell code that I'm rather fond of. See it as an
 379 attempt to get rid of the ridiculous quick-sort routine. group is
 380 quite useful by itself I think it was John's idea originally though I
 381 believe the lazy version is due to me [surprisingly complicated].
 382 gamma [used to be called] is called gamma because I got inspired by
 383 the Gamma calculus. It is not very close to the calculus but does
 384 behave less sequentially than both foldr and foldl. One could imagine
 385 a version of gamma that took a unit element as well thereby avoiding
 386 the problem with empty lists.
 387
 388 I've tried this code against
 389
 390    1) insertion sort - as provided by haskell
 391    2) the normal implementation of quick sort
 392    3) a deforested version of quick sort due to Jan Sparud
 393    4) a super-optimized-quick-sort of Lennart's
 394
 395 If the list is partially sorted both merge sort and in particular
 396 natural merge sort wins. If the list is random [ average length of
 397 rising subsequences = approx 2 ] mergesort still wins and natural
 398 merge sort is marginally beaten by Lennart's soqs. The space
 399 consumption of merge sort is a bit worse than Lennart's quick sort
 400 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 401 fpca article ] isn't used because of group.
 402
 403 have fun
 404 Carsten
 405 \end{display}
 406
 407 \begin{code}
 408 group :: (a -> a -> Bool) -> [a] -> [[a]]
 409 -- Given a <= function, group finds maximal contiguous up-runs
 410 -- or down-runs in the input list.
 411 -- It's stable, in the sense that it never re-orders equal elements
 412 --
 413 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 414 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 415 -- Here is a `better' definition of group.
 416
 417 group p []     = []
 418 group p (x:xs) = group' xs x x (x :)
 419   where
 420     group' []     _     _     s  = [s []]
 421     group' (x:xs) x_min x_max s
 422         |      x_max `p` x  = group' xs x_min x (s . (x :))
 423         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 424         | otherwise         = s [] : group' xs x x (x :)
 425         -- NB: the 'not' is essential for stablity
 426         --      x `p` x_min would reverse equal elements
 427
 428 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 429 generalMerge p xs [] = xs
 430 generalMerge p [] ys = ys
 431 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 432                              | otherwise = y : generalMerge p (x:xs) ys
 433
 434 -- gamma is now called balancedFold
 435
 436 balancedFold :: (a -> a -> a) -> [a] -> a
 437 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 438 balancedFold f [x] = x
 439 balancedFold f l  = balancedFold f (balancedFold' f l)
 440
 441 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 442 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 443 balancedFold' f xs = xs
 444
 445 generalNaturalMergeSort p [] = []
 446 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 447
 448 #if NOT_USED
 449 generalMergeSort p [] = []
 450 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 451
 452 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 453
 454 mergeSort = generalMergeSort (<=)
 455 naturalMergeSort = generalNaturalMergeSort (<=)
 456
 457 mergeSortLe le = generalMergeSort le
 458 #endif
 459
 460 sortLe :: (a->a->Bool) -> [a] -> [a]
 461 sortLe le = generalNaturalMergeSort le
 462
 463 sortWith :: Ord b => (a->b) -> [a] -> [a]
 464 sortWith get_key xs = sortLe le xs
 465   where
 466     x `le` y = get_key x < get_key y
 467
 468 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 469 on cmp sel = \x y -> sel x `cmp` sel y
 470
 471 \end{code}
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection[Utils-transitive-closure]{Transitive closure}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 This algorithm for transitive closure is straightforward, albeit quadratic.
 480
 481 \begin{code}
 482 transitiveClosure :: (a -> [a])         -- Successor function
 483                   -> (a -> a -> Bool)   -- Equality predicate
 484                   -> [a]
 485                   -> [a]                -- The transitive closure
 486
 487 transitiveClosure succ eq xs
 488  = go [] xs
 489  where
 490    go done []                      = done
 491    go done (x:xs) | x `is_in` done = go done xs
 492                   | otherwise      = go (x:done) (succ x ++ xs)
 493
 494    x `is_in` []                 = False
 495    x `is_in` (y:ys) | eq x y    = True
 496                     | otherwise = x `is_in` ys
 497 \end{code}
 498
 499 %************************************************************************
 500 %*                                                                      *
 501 \subsection[Utils-accum]{Accumulating}
 502 %*                                                                      *
 503 %************************************************************************
 504
 505 A combination of foldl with zip.  It works with equal length lists.
 506
 507 \begin{code}
 508 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 509 foldl2 k z [] [] = z
 510 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 511
 512 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 513 -- True if the lists are the same length, and
 514 -- all corresponding elements satisfy the predicate
 515 all2 p []     []     = True
 516 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 517 all2 p xs     ys     = False
 518 \end{code}
 519
 520 Count the number of times a predicate is true
 521
 522 \begin{code}
 523 count :: (a -> Bool) -> [a] -> Int
 524 count p [] = 0
 525 count p (x:xs) | p x       = 1 + count p xs
 526                | otherwise = count p xs
 527 \end{code}
 528
 529 @splitAt@, @take@, and @drop@ but with length of another
 530 list giving the break-off point:
 531
 532 \begin{code}
 533 takeList :: [b] -> [a] -> [a]
 534 takeList [] _ = []
 535 takeList (_:xs) ls =
 536    case ls of
 537      [] -> []
 538      (y:ys) -> y : takeList xs ys
 539
 540 dropList :: [b] -> [a] -> [a]
 541 dropList [] xs    = xs
 542 dropList _  xs@[] = xs
 543 dropList (_:xs) (_:ys) = dropList xs ys
 544
 545
 546 splitAtList :: [b] -> [a] -> ([a], [a])
 547 splitAtList [] xs     = ([], xs)
 548 splitAtList _ xs@[]   = (xs, xs)
 549 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 550     where
 551       (ys', ys'') = splitAtList xs ys
 552
 553 snocView :: [a] -> Maybe ([a],a)
 554         -- Split off the last element
 555 snocView [] = Nothing
 556 snocView xs = go [] xs
 557             where
 558                 -- Invariant: second arg is non-empty
 559               go acc [x]    = Just (reverse acc, x)
 560               go acc (x:xs) = go (x:acc) xs
 561
 562 split :: Char -> String -> [String]
 563 split c s = case rest of
 564                 []     -> [chunk]
 565                 _:rest -> chunk : split c rest
 566   where (chunk, rest) = break (==c) s
 567 \end{code}
 568
 569
 570 %************************************************************************
 571 %*                                                                      *
 572 \subsection[Utils-comparison]{Comparisons}
 573 %*                                                                      *
 574 %************************************************************************
 575
 576 \begin{code}
 577 isEqual :: Ordering -> Bool
 578 -- Often used in (isEqual (a `compare` b))
 579 isEqual GT = False
 580 isEqual EQ = True
 581 isEqual LT = False
 582
 583 thenCmp :: Ordering -> Ordering -> Ordering
 584 {-# INLINE thenCmp #-}
 585 thenCmp EQ   any = any
 586 thenCmp other any = other
 587
 588 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 589 eqListBy eq []     []     = True
 590 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 591 eqListBy eq xs     ys     = False
 592
 593 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 594     -- `cmpList' uses a user-specified comparer
 595
 596 cmpList cmp []     [] = EQ
 597 cmpList cmp []     _  = LT
 598 cmpList cmp _      [] = GT
 599 cmpList cmp (a:as) (b:bs)
 600   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 601 \end{code}
 602
 603 \begin{code}
 604 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
 605 -- This definition can be removed once we require at least 6.8 to build.
 606 maybePrefixMatch :: String -> String -> Maybe String
 607 maybePrefixMatch []    rest = Just rest
 608 maybePrefixMatch (_:_) []   = Nothing
 609 maybePrefixMatch (p:pat) (r:rest)
 610   | p == r    = maybePrefixMatch pat rest
 611   | otherwise = Nothing
 612
 613 removeSpaces :: String -> String
 614 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 615 \end{code}
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsection[Utils-pairs]{Pairs}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 625 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 626 \end{code}
 627
 628 \begin{code}
 629 seqList :: [a] -> b -> b
 630 seqList [] b = b
 631 seqList (x:xs) b = x `seq` seqList xs b
 632 \end{code}
 633
 634 Global variables:
 635
 636 \begin{code}
 637 global :: a -> IORef a
 638 global a = unsafePerformIO (newIORef a)
 639 \end{code}
 640
 641 \begin{code}
 642 consIORef :: IORef [a] -> a -> IO ()
 643 consIORef var x = do
 644   xs <- readIORef var
 645   writeIORef var (x:xs)
 646 \end{code}
 647
 648 Module names:
 649
 650 \begin{code}
 651 looksLikeModuleName :: String -> Bool
 652 looksLikeModuleName [] = False
 653 looksLikeModuleName (c:cs) = isUpper c && go cs
 654   where go [] = True
 655         go ('.':cs) = looksLikeModuleName cs
 656         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 657 \end{code}
 658
 659 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 660 quoted strings and escaped characters within the input as solid blocks
 661 of characters.  Doesn't raise any exceptions on malformed escapes or
 662 quoting.
 663
 664 \begin{code}
 665 toArgs :: String -> [String]
 666 toArgs "" = []
 667 toArgs s  =
 668   case dropWhile isSpace s of  -- drop initial spacing
 669     [] -> []  -- empty, so no more tokens
 670     rem -> let (tok,aft) = token rem [] in tok : toArgs aft
 671  where
 672    -- Grab a token off the string, given that the first character exists and
 673    -- isn't whitespace.  The second argument is an accumulator which has to be
 674    -- reversed at the end.
 675   token [] acc = (reverse acc,[])            -- out of characters
 676   token ('\\':c:aft) acc                     -- escapes
 677                = token aft ((escape c) : acc)
 678   token (q:aft) acc | q == '"' || q == '\''  -- open quotes
 679                = let (aft',acc') = quote q aft acc in token aft' acc'
 680   token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
 681                = (reverse acc,aft)
 682   token (c:aft) acc                          -- anything else goes in the token
 683                = token aft (c:acc)
 684
 685    -- Get the appropriate character for a single-character escape.
 686   escape 'n' = '\n'
 687   escape 't' = '\t'
 688   escape 'r' = '\r'
 689   escape c   = c
 690
 691    -- Read into accumulator until a quote character is found.
 692   quote qc =
 693     let quote' [] acc                  = ([],acc)
 694         quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
 695         quote' (c:aft) acc | c == qc   = (aft,acc)
 696         quote' (c:aft) acc             = quote' aft (c:acc)
 697     in quote'
 698 \end{code}
 699
 700 -- -----------------------------------------------------------------------------
 701 -- Floats
 702
 703 \begin{code}
 704 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 705 readRational__ r = do
 706      (n,d,s) <- readFix r
 707      (k,t)   <- readExp s
 708      return ((n%1)*10^^(k-d), t)
 709  where
 710      readFix r = do
 711         (ds,s)  <- lexDecDigits r
 712         (ds',t) <- lexDotDigits s
 713         return (read (ds++ds'), length ds', t)
 714
 715      readExp (e:s) | e `elem` "eE" = readExp' s
 716      readExp s                     = return (0,s)
 717
 718      readExp' ('+':s) = readDec s
 719      readExp' ('-':s) = do
 720                         (k,t) <- readDec s
 721                         return (-k,t)
 722      readExp' s       = readDec s
 723
 724      readDec s = do
 725         (ds,r) <- nonnull isDigit s
 726         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 727                 r)
 728
 729      lexDecDigits = nonnull isDigit
 730
 731      lexDotDigits ('.':s) = return (span isDigit s)
 732      lexDotDigits s       = return ("",s)
 733
 734      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 735                       return (cs,t)
 736
 737 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 738 readRational top_s
 739   = case top_s of
 740       '-' : xs -> - (read_me xs)
 741       xs       -> read_me xs
 742   where
 743     read_me s
 744       = case (do { (x,"") <- readRational__ s ; return x }) of
 745           [x] -> x
 746           []  -> error ("readRational: no parse:"        ++ top_s)
 747           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 748
 749
 750 -----------------------------------------------------------------------------
 751 -- Create a hierarchy of directories
 752
 753 createDirectoryHierarchy :: FilePath -> IO ()
 754 createDirectoryHierarchy dir = do
 755   b <- doesDirectoryExist dir
 756   when (not b) $ do
 757         createDirectoryHierarchy (directoryOf dir)
 758         createDirectory dir
 759
 760 -----------------------------------------------------------------------------
 761 -- Verify that the 'dirname' portion of a FilePath exists.
 762 --
 763 doesDirNameExist :: FilePath -> IO Bool
 764 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 765
 766 -- -----------------------------------------------------------------------------
 767 -- Exception utils
 768
 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 -- --------------------------------------------------------------
 790 -- Filename manipulation
 791
 792 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 793 -- separator.  On Windows these functions will also recognise '\\' as
 794 -- the path separator, but will generally construct paths using '/'.
 795
 796 type Suffix = String
 797
 798 splitFilename :: String -> (String,Suffix)
 799 splitFilename f = splitLongestPrefix f (=='.')
 800
 801 basenameOf :: FilePath -> String
 802 basenameOf = fst . splitFilename
 803
 804 suffixOf :: FilePath -> Suffix
 805 suffixOf = snd . splitFilename
 806
 807 joinFileExt :: String -> String -> FilePath
 808 joinFileExt path ""  = path
 809 joinFileExt path ext = path ++ '.':ext
 810
 811 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 812 splitFilenameDir :: String -> (String,String)
 813 splitFilenameDir str
 814    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 815          (dir', rest') | null rest = (".", dir)
 816                        | otherwise = (dir, rest)
 817      in  (dir', rest')
 818
 819 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 820 splitFilename3 :: String -> (String,String,Suffix)
 821 splitFilename3 str
 822    = let (dir, rest) = splitFilenameDir str
 823          (name, ext) = splitFilename rest
 824      in  (dir, name, ext)
 825
 826 joinFileName :: String -> String -> FilePath
 827 joinFileName ""  fname = fname
 828 joinFileName "." fname = fname
 829 joinFileName dir ""    = dir
 830 joinFileName dir fname = dir ++ '/':fname
 831
 832 -- split a string at the last character where 'pred' is True,
 833 -- returning a pair of strings. The first component holds the string
 834 -- up (but not including) the last character for which 'pred' returned
 835 -- True, the second whatever comes after (but also not including the
 836 -- last character).
 837 --
 838 -- If 'pred' returns False for all characters in the string, the original
 839 -- string is returned in the first component (and the second one is just
 840 -- empty).
 841 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 842 splitLongestPrefix str pred
 843   | null r_pre = (str,           [])
 844   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 845         -- 'tail' drops the char satisfying 'pred'
 846   where
 847     (r_suf, r_pre) = break pred (reverse str)
 848
 849 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 850 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 851
 852 -- directoryOf strips the filename off the input string, returning
 853 -- the directory.
 854 directoryOf :: FilePath -> String
 855 directoryOf = fst . splitFilenameDir
 856
 857 -- filenameOf strips the directory off the input string, returning
 858 -- the filename.
 859 filenameOf :: FilePath -> String
 860 filenameOf = snd . splitFilenameDir
 861
 862 replaceFilenameDirectory :: FilePath -> String -> FilePath
 863 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 864
 865 escapeSpaces :: String -> String
 866 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 867
 868 isPathSeparator :: Char -> Bool
 869 isPathSeparator ch =
 870 #ifdef mingw32_TARGET_OS
 871   ch == '/' || ch == '\\'
 872 #else
 873   ch == '/'
 874 #endif
 875
 876 --------------------------------------------------------------
 877 -- * Search path
 878 --------------------------------------------------------------
 879
 880 -- | The function splits the given string to substrings
 881 -- using the 'searchPathSeparator'.
 882 parseSearchPath :: String -> [FilePath]
 883 parseSearchPath path = split path
 884   where
 885     split :: String -> [String]
 886     split s =
 887       case rest' of
 888         []     -> [chunk]
 889         _:rest -> chunk : split rest
 890       where
 891         chunk =
 892           case chunk' of
 893 #ifdef mingw32_HOST_OS
 894             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 895 #endif
 896             _                                 -> chunk'
 897
 898         (chunk', rest') = break (==searchPathSeparator) s
 899
 900 -- | A platform-specific character used to separate search path strings in
 901 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
 902 -- and a semicolon (\";\") on the Windows operating system.
 903 searchPathSeparator :: Char
 904 #if mingw32_HOST_OS || mingw32_TARGET_OS
 905 searchPathSeparator = ';'
 906 #else
 907 searchPathSeparator = ':'
 908 #endif
 909
 910 -----------------------------------------------------------------------------
 911 -- Convert filepath into platform / MSDOS form.
 912
 913 -- We maintain path names in Unix form ('/'-separated) right until
 914 -- the last moment.  On Windows we dos-ify them just before passing them
 915 -- to the Windows command.
 916 --
 917 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
 918 -- proved quite awkward.  There were a lot more calls to platformPath,
 919 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 920 -- interpreted a command line 'foo\baz' as 'foobaz'.
 921
 922 normalisePath :: String -> String
 923 -- Just changes '\' to '/'
 924
 925 pgmPath :: String               -- Directory string in Unix format
 926         -> String               -- Program name with no directory separators
 927                                 --      (e.g. copy /y)
 928         -> String               -- Program invocation string in native format
 929
 930 #if defined(mingw32_HOST_OS)
 931 --------------------- Windows version ------------------
 932 normalisePath xs = subst '\\' '/' xs
 933 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 934 platformPath p   = subst '/' '\\' p
 935
 936 subst a b ls = map (\ x -> if x == a then b else x) ls
 937 #else
 938 --------------------- Non-Windows version --------------
 939 normalisePath xs   = xs
 940 pgmPath dir pgm    = dir ++ '/' : pgm
 941 platformPath stuff = stuff
 942 --------------------------------------------------------
 943 #endif
 944 \end{code}