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