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