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