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,
  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         foldl', 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 Panic            ( panic, trace )
  83 import FastTypes
  84
  85 import Control.Exception ( Exception(..), finally, catchDyn, throw )
  86 import qualified Control.Exception as Exception
  87 import Data.Dynamic     ( Typeable )
  88 import Data.IORef       ( IORef, newIORef )
  89 import System.IO.Unsafe ( unsafePerformIO )
  90 import Data.IORef       ( readIORef, writeIORef )
  91
  92 import qualified Data.List as List ( elem, notElem )
  93
  94 #ifndef DEBUG
  95 import Data.List                ( zipWith4 )
  96 #endif
  97
  98 import Control.Monad    ( when )
  99 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
 100 import System.Directory ( doesDirectoryExist, createDirectory,
 101                           getModificationTime )
 102 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
 103 import Data.Ratio       ( (%) )
 104 import System.Time      ( ClockTime )
 105
 106 infixr 9 `thenCmp`
 107 \end{code}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 \subsection{A for loop}
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \begin{code}
 116 -- Compose a function with itself n times.  (nth rather than twice)
 117 nTimes :: Int -> (a -> a) -> (a -> a)
 118 nTimes 0 _ = id
 119 nTimes 1 f = f
 120 nTimes n f = f . nTimes (n-1) f
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection[Utils-lists]{General list processing}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 \begin{code}
 130 filterOut :: (a->Bool) -> [a] -> [a]
 131 -- Like filter, only reverses the sense of the test
 132 filterOut p [] = []
 133 filterOut p (x:xs) | p x       = filterOut p xs
 134                    | otherwise = x : filterOut p xs
 135
 136 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 137 partitionWith f [] = ([],[])
 138 partitionWith f (x:xs) = case f x of
 139                            Left  b -> (b:bs, cs)
 140                            Right c -> (bs, c:cs)
 141                        where
 142                          (bs,cs) = partitionWith f xs
 143
 144 splitEithers :: [Either a b] -> ([a], [b])
 145 splitEithers [] = ([],[])
 146 splitEithers (e : es) = case e of
 147                           Left x -> (x:xs, ys)
 148                           Right y -> (xs, y:ys)
 149                       where
 150                         (xs,ys) = splitEithers es
 151 \end{code}
 152
 153 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 154 are of equal length.  Alastair Reid thinks this should only happen if
 155 DEBUGging on; hey, why not?
 156
 157 \begin{code}
 158 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 159 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 160 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 161 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 162
 163 #ifndef DEBUG
 164 zipEqual      _ = zip
 165 zipWithEqual  _ = zipWith
 166 zipWith3Equal _ = zipWith3
 167 zipWith4Equal _ = zipWith4
 168 #else
 169 zipEqual msg []     []     = []
 170 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 171 zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
 172
 173 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 174 zipWithEqual msg _ [] []        =  []
 175 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 176
 177 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 178                                 =  z a b c : zipWith3Equal msg z as bs cs
 179 zipWith3Equal msg _ [] []  []   =  []
 180 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 181
 182 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 183                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 184 zipWith4Equal msg _ [] [] [] [] =  []
 185 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 186 #endif
 187 \end{code}
 188
 189 \begin{code}
 190 -- zipLazy is lazy in the second list (observe the ~)
 191
 192 zipLazy :: [a] -> [b] -> [(a,b)]
 193 zipLazy [] ys = []
 194 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 195 \end{code}
 196
 197
 198 \begin{code}
 199 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 200 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
 201 -- the places where p returns *True*
 202
 203 stretchZipWith p z f [] ys = []
 204 stretchZipWith p z f (x:xs) ys
 205   | p x       = f x z : stretchZipWith p z f xs ys
 206   | otherwise = case ys of
 207                   []     -> []
 208                   (y:ys) -> f x y : stretchZipWith p z f xs ys
 209 \end{code}
 210
 211
 212 \begin{code}
 213 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
 214 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
 215
 216 mapFst f xys = [(f x, y) | (x,y) <- xys]
 217 mapSnd f xys = [(x, f y) | (x,y) <- xys]
 218
 219 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 220
 221 mapAndUnzip f [] = ([],[])
 222 mapAndUnzip f (x:xs)
 223   = let
 224         (r1,  r2)  = f x
 225         (rs1, rs2) = mapAndUnzip f xs
 226     in
 227     (r1:rs1, r2:rs2)
 228
 229 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 230
 231 mapAndUnzip3 f [] = ([],[],[])
 232 mapAndUnzip3 f (x:xs)
 233   = let
 234         (r1,  r2,  r3)  = f x
 235         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 236     in
 237     (r1:rs1, r2:rs2, r3:rs3)
 238 \end{code}
 239
 240 \begin{code}
 241 nOfThem :: Int -> a -> [a]
 242 nOfThem n thing = replicate n thing
 243
 244 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
 245 -- specification:
 246 --
 247 --  atLength atLenPred atEndPred ls n
 248 --   | n < 0         = atLenPred n
 249 --   | length ls < n = atEndPred (n - length ls)
 250 --   | otherwise     = atLenPred (drop n ls)
 251 --
 252 atLength :: ([a] -> b)
 253          -> (Int -> b)
 254          -> [a]
 255          -> Int
 256          -> b
 257 atLength atLenPred atEndPred ls n
 258   | n < 0     = atEndPred n
 259   | otherwise = go n ls
 260   where
 261     go n [] = atEndPred n
 262     go 0 ls = atLenPred ls
 263     go n (_:xs) = go (n-1) xs
 264
 265 -- special cases.
 266 lengthExceeds :: [a] -> Int -> Bool
 267 -- (lengthExceeds xs n) = (length xs > n)
 268 lengthExceeds = atLength notNull (const False)
 269
 270 lengthAtLeast :: [a] -> Int -> Bool
 271 lengthAtLeast = atLength notNull (== 0)
 272
 273 lengthIs :: [a] -> Int -> Bool
 274 lengthIs = atLength null (==0)
 275
 276 listLengthCmp :: [a] -> Int -> Ordering
 277 listLengthCmp = atLength atLen atEnd
 278  where
 279   atEnd 0      = EQ
 280   atEnd x
 281    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 282    | otherwise = GT
 283
 284   atLen []     = EQ
 285   atLen _      = GT
 286
 287 equalLength :: [a] -> [b] -> Bool
 288 equalLength [] []         = True
 289 equalLength (_:xs) (_:ys) = equalLength xs ys
 290 equalLength xs    ys      = False
 291
 292 compareLength :: [a] -> [b] -> Ordering
 293 compareLength [] []         = EQ
 294 compareLength (_:xs) (_:ys) = compareLength xs ys
 295 compareLength [] _ys        = LT
 296 compareLength _xs []        = GT
 297
 298 ----------------------------
 299 singleton :: a -> [a]
 300 singleton x = [x]
 301
 302 isSingleton :: [a] -> Bool
 303 isSingleton [x] = True
 304 isSingleton  _  = False
 305
 306 notNull :: [a] -> Bool
 307 notNull [] = False
 308 notNull _  = True
 309
 310 only :: [a] -> a
 311 #ifdef DEBUG
 312 only [a] = a
 313 #else
 314 only (a:_) = a
 315 #endif
 316 \end{code}
 317
 318 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 319
 320 \begin{code}
 321 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 322
 323 # ifndef DEBUG
 324 isIn    msg x ys = elem__    x ys
 325 isn'tIn msg x ys = notElem__ x ys
 326
 327 --these are here to be SPECIALIZEd (automagically)
 328 elem__ _ []     = False
 329 elem__ x (y:ys) = x==y || elem__ x ys
 330
 331 notElem__ x []     =  True
 332 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 333
 334 # else /* DEBUG */
 335 isIn msg x ys
 336   = elem (_ILIT 0) x ys
 337   where
 338     elem i _ []     = False
 339     elem i x (y:ys)
 340       | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
 341                          x `List.elem` (y:ys)
 342       | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 343
 344 isn'tIn msg x ys
 345   = notElem (_ILIT 0) x ys
 346   where
 347     notElem i x [] =  True
 348     notElem i x (y:ys)
 349       | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
 350                          x `List.notElem` (y:ys)
 351       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 352 # endif /* DEBUG */
 353 \end{code}
 354
 355 %************************************************************************
 356 %*                                                                      *
 357 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 358 %*                                                                      *
 359 %************************************************************************
 360
 361 \begin{display}
 362 Date: Mon, 3 May 93 20:45:23 +0200
 363 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 364 To: partain@dcs.gla.ac.uk
 365 Subject: natural merge sort beats quick sort [ and it is prettier ]
 366
 367 Here is a piece of Haskell code that I'm rather fond of. See it as an
 368 attempt to get rid of the ridiculous quick-sort routine. group is
 369 quite useful by itself I think it was John's idea originally though I
 370 believe the lazy version is due to me [surprisingly complicated].
 371 gamma [used to be called] is called gamma because I got inspired by
 372 the Gamma calculus. It is not very close to the calculus but does
 373 behave less sequentially than both foldr and foldl. One could imagine
 374 a version of gamma that took a unit element as well thereby avoiding
 375 the problem with empty lists.
 376
 377 I've tried this code against
 378
 379    1) insertion sort - as provided by haskell
 380    2) the normal implementation of quick sort
 381    3) a deforested version of quick sort due to Jan Sparud
 382    4) a super-optimized-quick-sort of Lennart's
 383
 384 If the list is partially sorted both merge sort and in particular
 385 natural merge sort wins. If the list is random [ average length of
 386 rising subsequences = approx 2 ] mergesort still wins and natural
 387 merge sort is marginally beaten by Lennart's soqs. The space
 388 consumption of merge sort is a bit worse than Lennart's quick sort
 389 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 390 fpca article ] isn't used because of group.
 391
 392 have fun
 393 Carsten
 394 \end{display}
 395
 396 \begin{code}
 397 group :: (a -> a -> Bool) -> [a] -> [[a]]
 398 -- Given a <= function, group finds maximal contiguous up-runs
 399 -- or down-runs in the input list.
 400 -- It's stable, in the sense that it never re-orders equal elements
 401 --
 402 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 403 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 404 -- Here is a `better' definition of group.
 405
 406 group p []     = []
 407 group p (x:xs) = group' xs x x (x :)
 408   where
 409     group' []     _     _     s  = [s []]
 410     group' (x:xs) x_min x_max s
 411         |      x_max `p` x  = group' xs x_min x (s . (x :))
 412         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 413         | otherwise         = s [] : group' xs x x (x :)
 414         -- NB: the 'not' is essential for stablity
 415         --      x `p` x_min would reverse equal elements
 416
 417 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 418 generalMerge p xs [] = xs
 419 generalMerge p [] ys = ys
 420 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 421                              | otherwise = y : generalMerge p (x:xs) ys
 422
 423 -- gamma is now called balancedFold
 424
 425 balancedFold :: (a -> a -> a) -> [a] -> a
 426 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 427 balancedFold f [x] = x
 428 balancedFold f l  = balancedFold f (balancedFold' f l)
 429
 430 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 431 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 432 balancedFold' f xs = xs
 433
 434 generalNaturalMergeSort p [] = []
 435 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 436
 437 #if NOT_USED
 438 generalMergeSort p [] = []
 439 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 440
 441 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 442
 443 mergeSort = generalMergeSort (<=)
 444 naturalMergeSort = generalNaturalMergeSort (<=)
 445
 446 mergeSortLe le = generalMergeSort le
 447 #endif
 448
 449 sortLe :: (a->a->Bool) -> [a] -> [a]
 450 sortLe le = generalNaturalMergeSort le
 451
 452 sortWith :: Ord b => (a->b) -> [a] -> [a]
 453 sortWith get_key xs = sortLe le xs
 454   where
 455     x `le` y = get_key x < get_key y
 456 \end{code}
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection[Utils-transitive-closure]{Transitive closure}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 This algorithm for transitive closure is straightforward, albeit quadratic.
 465
 466 \begin{code}
 467 transitiveClosure :: (a -> [a])         -- Successor function
 468                   -> (a -> a -> Bool)   -- Equality predicate
 469                   -> [a]
 470                   -> [a]                -- The transitive closure
 471
 472 transitiveClosure succ eq xs
 473  = go [] xs
 474  where
 475    go done []                      = done
 476    go done (x:xs) | x `is_in` done = go done xs
 477                   | otherwise      = go (x:done) (succ x ++ xs)
 478
 479    x `is_in` []                 = False
 480    x `is_in` (y:ys) | eq x y    = True
 481                     | otherwise = x `is_in` ys
 482 \end{code}
 483
 484 %************************************************************************
 485 %*                                                                      *
 486 \subsection[Utils-accum]{Accumulating}
 487 %*                                                                      *
 488 %************************************************************************
 489
 490 A strict version of foldl.
 491
 492 \begin{code}
 493 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 494 foldl' f z xs = lgo z xs
 495              where
 496                 lgo z []     =  z
 497                 lgo z (x:xs) = (lgo $! (f z x)) xs
 498 \end{code}
 499
 500 A combination of foldl with zip.  It works with equal length lists.
 501
 502 \begin{code}
 503 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 504 foldl2 k z [] [] = z
 505 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 506
 507 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 508 -- True if the lists are the same length, and
 509 -- all corresponding elements satisfy the predicate
 510 all2 p []     []     = True
 511 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 512 all2 p xs     ys     = False
 513 \end{code}
 514
 515 Count the number of times a predicate is true
 516
 517 \begin{code}
 518 count :: (a -> Bool) -> [a] -> Int
 519 count p [] = 0
 520 count p (x:xs) | p x       = 1 + count p xs
 521                | otherwise = count p xs
 522 \end{code}
 523
 524 @splitAt@, @take@, and @drop@ but with length of another
 525 list giving the break-off point:
 526
 527 \begin{code}
 528 takeList :: [b] -> [a] -> [a]
 529 takeList [] _ = []
 530 takeList (_:xs) ls =
 531    case ls of
 532      [] -> []
 533      (y:ys) -> y : takeList xs ys
 534
 535 dropList :: [b] -> [a] -> [a]
 536 dropList [] xs    = xs
 537 dropList _  xs@[] = xs
 538 dropList (_:xs) (_:ys) = dropList xs ys
 539
 540
 541 splitAtList :: [b] -> [a] -> ([a], [a])
 542 splitAtList [] xs     = ([], xs)
 543 splitAtList _ xs@[]   = (xs, xs)
 544 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 545     where
 546       (ys', ys'') = splitAtList xs ys
 547
 548 snocView :: [a] -> Maybe ([a],a)
 549         -- Split off the last element
 550 snocView [] = Nothing
 551 snocView xs = go [] xs
 552             where
 553                 -- Invariant: second arg is non-empty
 554               go acc [x]    = Just (reverse acc, x)
 555               go acc (x:xs) = go (x:acc) xs
 556
 557 split :: Char -> String -> [String]
 558 split c s = case rest of
 559                 []     -> [chunk]
 560                 _:rest -> chunk : split c rest
 561   where (chunk, rest) = break (==c) s
 562 \end{code}
 563
 564
 565 %************************************************************************
 566 %*                                                                      *
 567 \subsection[Utils-comparison]{Comparisons}
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 \begin{code}
 572 isEqual :: Ordering -> Bool
 573 -- Often used in (isEqual (a `compare` b))
 574 isEqual GT = False
 575 isEqual EQ = True
 576 isEqual LT = False
 577
 578 thenCmp :: Ordering -> Ordering -> Ordering
 579 {-# INLINE thenCmp #-}
 580 thenCmp EQ   any = any
 581 thenCmp other any = other
 582
 583 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 584 eqListBy eq []     []     = True
 585 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 586 eqListBy eq xs     ys     = False
 587
 588 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 589     -- `cmpList' uses a user-specified comparer
 590
 591 cmpList cmp []     [] = EQ
 592 cmpList cmp []     _  = LT
 593 cmpList cmp _      [] = GT
 594 cmpList cmp (a:as) (b:bs)
 595   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 596 \end{code}
 597
 598 \begin{code}
 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}