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         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 \end{code}
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection[Utils-transitive-closure]{Transitive closure}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 This algorithm for transitive closure is straightforward, albeit quadratic.
 469
 470 \begin{code}
 471 transitiveClosure :: (a -> [a])         -- Successor function
 472                   -> (a -> a -> Bool)   -- Equality predicate
 473                   -> [a]
 474                   -> [a]                -- The transitive closure
 475
 476 transitiveClosure succ eq xs
 477  = go [] xs
 478  where
 479    go done []                      = done
 480    go done (x:xs) | x `is_in` done = go done xs
 481                   | otherwise      = go (x:done) (succ x ++ xs)
 482
 483    x `is_in` []                 = False
 484    x `is_in` (y:ys) | eq x y    = True
 485                     | otherwise = x `is_in` ys
 486 \end{code}
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection[Utils-accum]{Accumulating}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 A combination of foldl with zip.  It works with equal length lists.
 495
 496 \begin{code}
 497 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 498 foldl2 k z [] [] = z
 499 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 500
 501 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 502 -- True if the lists are the same length, and
 503 -- all corresponding elements satisfy the predicate
 504 all2 p []     []     = True
 505 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 506 all2 p xs     ys     = False
 507 \end{code}
 508
 509 Count the number of times a predicate is true
 510
 511 \begin{code}
 512 count :: (a -> Bool) -> [a] -> Int
 513 count p [] = 0
 514 count p (x:xs) | p x       = 1 + count p xs
 515                | otherwise = count p xs
 516 \end{code}
 517
 518 @splitAt@, @take@, and @drop@ but with length of another
 519 list giving the break-off point:
 520
 521 \begin{code}
 522 takeList :: [b] -> [a] -> [a]
 523 takeList [] _ = []
 524 takeList (_:xs) ls =
 525    case ls of
 526      [] -> []
 527      (y:ys) -> y : takeList xs ys
 528
 529 dropList :: [b] -> [a] -> [a]
 530 dropList [] xs    = xs
 531 dropList _  xs@[] = xs
 532 dropList (_:xs) (_:ys) = dropList xs ys
 533
 534
 535 splitAtList :: [b] -> [a] -> ([a], [a])
 536 splitAtList [] xs     = ([], xs)
 537 splitAtList _ xs@[]   = (xs, xs)
 538 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 539     where
 540       (ys', ys'') = splitAtList xs ys
 541
 542 snocView :: [a] -> Maybe ([a],a)
 543         -- Split off the last element
 544 snocView [] = Nothing
 545 snocView xs = go [] xs
 546             where
 547                 -- Invariant: second arg is non-empty
 548               go acc [x]    = Just (reverse acc, x)
 549               go acc (x:xs) = go (x:acc) xs
 550
 551 split :: Char -> String -> [String]
 552 split c s = case rest of
 553                 []     -> [chunk]
 554                 _:rest -> chunk : split c rest
 555   where (chunk, rest) = break (==c) s
 556 \end{code}
 557
 558
 559 %************************************************************************
 560 %*                                                                      *
 561 \subsection[Utils-comparison]{Comparisons}
 562 %*                                                                      *
 563 %************************************************************************
 564
 565 \begin{code}
 566 isEqual :: Ordering -> Bool
 567 -- Often used in (isEqual (a `compare` b))
 568 isEqual GT = False
 569 isEqual EQ = True
 570 isEqual LT = False
 571
 572 thenCmp :: Ordering -> Ordering -> Ordering
 573 {-# INLINE thenCmp #-}
 574 thenCmp EQ   any = any
 575 thenCmp other any = other
 576
 577 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 578 eqListBy eq []     []     = True
 579 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 580 eqListBy eq xs     ys     = False
 581
 582 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 583     -- `cmpList' uses a user-specified comparer
 584
 585 cmpList cmp []     [] = EQ
 586 cmpList cmp []     _  = LT
 587 cmpList cmp _      [] = GT
 588 cmpList cmp (a:as) (b:bs)
 589   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 590 \end{code}
 591
 592 \begin{code}
 593 maybePrefixMatch :: String -> String -> Maybe String
 594 maybePrefixMatch []    rest = Just rest
 595 maybePrefixMatch (_:_) []   = Nothing
 596 maybePrefixMatch (p:pat) (r:rest)
 597   | p == r    = maybePrefixMatch pat rest
 598   | otherwise = Nothing
 599
 600 removeSpaces :: String -> String
 601 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 602 \end{code}
 603
 604 %************************************************************************
 605 %*                                                                      *
 606 \subsection[Utils-pairs]{Pairs}
 607 %*                                                                      *
 608 %************************************************************************
 609
 610 \begin{code}
 611 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 612 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 613 \end{code}
 614
 615 \begin{code}
 616 seqList :: [a] -> b -> b
 617 seqList [] b = b
 618 seqList (x:xs) b = x `seq` seqList xs b
 619 \end{code}
 620
 621 Global variables:
 622
 623 \begin{code}
 624 global :: a -> IORef a
 625 global a = unsafePerformIO (newIORef a)
 626 \end{code}
 627
 628 \begin{code}
 629 consIORef :: IORef [a] -> a -> IO ()
 630 consIORef var x = do
 631   xs <- readIORef var
 632   writeIORef var (x:xs)
 633 \end{code}
 634
 635 Module names:
 636
 637 \begin{code}
 638 looksLikeModuleName :: String -> Bool
 639 looksLikeModuleName [] = False
 640 looksLikeModuleName (c:cs) = isUpper c && go cs
 641   where go [] = True
 642         go ('.':cs) = looksLikeModuleName cs
 643         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 644 \end{code}
 645
 646 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 647 quoted strings and escaped characters within the input as solid blocks
 648 of characters.  Doesn't raise any exceptions on malformed escapes or
 649 quoting.
 650
 651 \begin{code}
 652 toArgs :: String -> [String]
 653 toArgs "" = []
 654 toArgs s  =
 655   case dropWhile isSpace s of  -- drop initial spacing
 656     [] -> []  -- empty, so no more tokens
 657     rem -> let (tok,aft) = token rem [] in tok : toArgs aft
 658  where
 659    -- Grab a token off the string, given that the first character exists and
 660    -- isn't whitespace.  The second argument is an accumulator which has to be
 661    -- reversed at the end.
 662   token [] acc = (reverse acc,[])            -- out of characters
 663   token ('\\':c:aft) acc                     -- escapes
 664                = token aft ((escape c) : acc)
 665   token (q:aft) acc | q == '"' || q == '\''  -- open quotes
 666                = let (aft',acc') = quote q aft acc in token aft' acc'
 667   token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
 668                = (reverse acc,aft)
 669   token (c:aft) acc                          -- anything else goes in the token
 670                = token aft (c:acc)
 671
 672    -- Get the appropriate character for a single-character escape.
 673   escape 'n' = '\n'
 674   escape 't' = '\t'
 675   escape 'r' = '\r'
 676   escape c   = c
 677
 678    -- Read into accumulator until a quote character is found.
 679   quote qc =
 680     let quote' [] acc                  = ([],acc)
 681         quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
 682         quote' (c:aft) acc | c == qc   = (aft,acc)
 683         quote' (c:aft) acc             = quote' aft (c:acc)
 684     in quote'
 685 \end{code}
 686
 687 -- -----------------------------------------------------------------------------
 688 -- Floats
 689
 690 \begin{code}
 691 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 692 readRational__ r = do
 693      (n,d,s) <- readFix r
 694      (k,t)   <- readExp s
 695      return ((n%1)*10^^(k-d), t)
 696  where
 697      readFix r = do
 698         (ds,s)  <- lexDecDigits r
 699         (ds',t) <- lexDotDigits s
 700         return (read (ds++ds'), length ds', t)
 701
 702      readExp (e:s) | e `elem` "eE" = readExp' s
 703      readExp s                     = return (0,s)
 704
 705      readExp' ('+':s) = readDec s
 706      readExp' ('-':s) = do
 707                         (k,t) <- readDec s
 708                         return (-k,t)
 709      readExp' s       = readDec s
 710
 711      readDec s = do
 712         (ds,r) <- nonnull isDigit s
 713         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 714                 r)
 715
 716      lexDecDigits = nonnull isDigit
 717
 718      lexDotDigits ('.':s) = return (span isDigit s)
 719      lexDotDigits s       = return ("",s)
 720
 721      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 722                       return (cs,t)
 723
 724 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 725 readRational top_s
 726   = case top_s of
 727       '-' : xs -> - (read_me xs)
 728       xs       -> read_me xs
 729   where
 730     read_me s
 731       = case (do { (x,"") <- readRational__ s ; return x }) of
 732           [x] -> x
 733           []  -> error ("readRational: no parse:"        ++ top_s)
 734           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 735
 736
 737 -----------------------------------------------------------------------------
 738 -- Create a hierarchy of directories
 739
 740 createDirectoryHierarchy :: FilePath -> IO ()
 741 createDirectoryHierarchy dir = do
 742   b <- doesDirectoryExist dir
 743   when (not b) $ do
 744         createDirectoryHierarchy (directoryOf dir)
 745         createDirectory dir
 746
 747 -----------------------------------------------------------------------------
 748 -- Verify that the 'dirname' portion of a FilePath exists.
 749 --
 750 doesDirNameExist :: FilePath -> IO Bool
 751 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 752
 753 -- -----------------------------------------------------------------------------
 754 -- Exception utils
 755
 756 later = flip finally
 757
 758 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 759 handleDyn = flip catchDyn
 760
 761 handle :: (Exception -> IO a) -> IO a -> IO a
 762 handle h f = f `Exception.catch` \e -> case e of
 763     ExitException _ -> throw e
 764     _               -> h e
 765
 766 -- --------------------------------------------------------------
 767 -- check existence & modification time at the same time
 768
 769 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 770 modificationTimeIfExists f = do
 771   (do t <- getModificationTime f; return (Just t))
 772         `IO.catch` \e -> if isDoesNotExistError e
 773                         then return Nothing
 774                         else ioError e
 775
 776 -- --------------------------------------------------------------
 777 -- Filename manipulation
 778
 779 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 780 -- separator.  On Windows these functions will also recognise '\\' as
 781 -- the path separator, but will generally construct paths using '/'.
 782
 783 type Suffix = String
 784
 785 splitFilename :: String -> (String,Suffix)
 786 splitFilename f = splitLongestPrefix f (=='.')
 787
 788 basenameOf :: FilePath -> String
 789 basenameOf = fst . splitFilename
 790
 791 suffixOf :: FilePath -> Suffix
 792 suffixOf = snd . splitFilename
 793
 794 joinFileExt :: String -> String -> FilePath
 795 joinFileExt path ""  = path
 796 joinFileExt path ext = path ++ '.':ext
 797
 798 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 799 splitFilenameDir :: String -> (String,String)
 800 splitFilenameDir str
 801    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 802          (dir', rest') | null rest = (".", dir)
 803                        | otherwise = (dir, rest)
 804      in  (dir', rest')
 805
 806 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 807 splitFilename3 :: String -> (String,String,Suffix)
 808 splitFilename3 str
 809    = let (dir, rest) = splitFilenameDir str
 810          (name, ext) = splitFilename rest
 811      in  (dir, name, ext)
 812
 813 joinFileName :: String -> String -> FilePath
 814 joinFileName ""  fname = fname
 815 joinFileName "." fname = fname
 816 joinFileName dir ""    = dir
 817 joinFileName dir fname = dir ++ '/':fname
 818
 819 -- split a string at the last character where 'pred' is True,
 820 -- returning a pair of strings. The first component holds the string
 821 -- up (but not including) the last character for which 'pred' returned
 822 -- True, the second whatever comes after (but also not including the
 823 -- last character).
 824 --
 825 -- If 'pred' returns False for all characters in the string, the original
 826 -- string is returned in the first component (and the second one is just
 827 -- empty).
 828 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 829 splitLongestPrefix str pred
 830   | null r_pre = (str,           [])
 831   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 832         -- 'tail' drops the char satisfying 'pred'
 833   where
 834     (r_suf, r_pre) = break pred (reverse str)
 835
 836 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 837 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 838
 839 -- directoryOf strips the filename off the input string, returning
 840 -- the directory.
 841 directoryOf :: FilePath -> String
 842 directoryOf = fst . splitFilenameDir
 843
 844 -- filenameOf strips the directory off the input string, returning
 845 -- the filename.
 846 filenameOf :: FilePath -> String
 847 filenameOf = snd . splitFilenameDir
 848
 849 replaceFilenameDirectory :: FilePath -> String -> FilePath
 850 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 851
 852 escapeSpaces :: String -> String
 853 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 854
 855 isPathSeparator :: Char -> Bool
 856 isPathSeparator ch =
 857 #ifdef mingw32_TARGET_OS
 858   ch == '/' || ch == '\\'
 859 #else
 860   ch == '/'
 861 #endif
 862
 863 --------------------------------------------------------------
 864 -- * Search path
 865 --------------------------------------------------------------
 866
 867 -- | The function splits the given string to substrings
 868 -- using the 'searchPathSeparator'.
 869 parseSearchPath :: String -> [FilePath]
 870 parseSearchPath path = split path
 871   where
 872     split :: String -> [String]
 873     split s =
 874       case rest' of
 875         []     -> [chunk]
 876         _:rest -> chunk : split rest
 877       where
 878         chunk =
 879           case chunk' of
 880 #ifdef mingw32_HOST_OS
 881             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 882 #endif
 883             _                                 -> chunk'
 884
 885         (chunk', rest') = break (==searchPathSeparator) s
 886
 887 -- | A platform-specific character used to separate search path strings in
 888 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
 889 -- and a semicolon (\";\") on the Windows operating system.
 890 searchPathSeparator :: Char
 891 #if mingw32_HOST_OS || mingw32_TARGET_OS
 892 searchPathSeparator = ';'
 893 #else
 894 searchPathSeparator = ':'
 895 #endif
 896
 897 -----------------------------------------------------------------------------
 898 -- Convert filepath into platform / MSDOS form.
 899
 900 -- We maintain path names in Unix form ('/'-separated) right until
 901 -- the last moment.  On Windows we dos-ify them just before passing them
 902 -- to the Windows command.
 903 --
 904 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
 905 -- proved quite awkward.  There were a lot more calls to platformPath,
 906 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 907 -- interpreted a command line 'foo\baz' as 'foobaz'.
 908
 909 normalisePath :: String -> String
 910 -- Just changes '\' to '/'
 911
 912 pgmPath :: String               -- Directory string in Unix format
 913         -> String               -- Program name with no directory separators
 914                                 --      (e.g. copy /y)
 915         -> String               -- Program invocation string in native format
 916
 917 #if defined(mingw32_HOST_OS)
 918 --------------------- Windows version ------------------
 919 normalisePath xs = subst '\\' '/' xs
 920 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 921 platformPath p   = subst '/' '\\' p
 922
 923 subst a b ls = map (\ x -> if x == a then b else x) ls
 924 #else
 925 --------------------- Non-Windows version --------------
 926 normalisePath xs   = xs
 927 pgmPath dir pgm    = dir ++ '/' : pgm
 928 platformPath stuff = stuff
 929 --------------------------------------------------------
 930 #endif
 931 \end{code}