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