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