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