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