ghc/compiler/utils/Util.lhs

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