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, all2,
  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
 576 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 577 -- True if the lists are the same length, and
 578 -- all corresponding elements satisfy the predicate
 579 all2 p []     []     = True
 580 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 581 all2 p xs     ys     = False
 582 \end{code}
 583
 584 Count the number of times a predicate is true
 585
 586 \begin{code}
 587 count :: (a -> Bool) -> [a] -> Int
 588 count p [] = 0
 589 count p (x:xs) | p x       = 1 + count p xs
 590                | otherwise = count p xs
 591 \end{code}
 592
 593 @splitAt@, @take@, and @drop@ but with length of another
 594 list giving the break-off point:
 595
 596 \begin{code}
 597 takeList :: [b] -> [a] -> [a]
 598 takeList [] _ = []
 599 takeList (_:xs) ls =
 600    case ls of
 601      [] -> []
 602      (y:ys) -> y : takeList xs ys
 603
 604 dropList :: [b] -> [a] -> [a]
 605 dropList [] xs    = xs
 606 dropList _  xs@[] = xs
 607 dropList (_:xs) (_:ys) = dropList xs ys
 608
 609
 610 splitAtList :: [b] -> [a] -> ([a], [a])
 611 splitAtList [] xs     = ([], xs)
 612 splitAtList _ xs@[]   = (xs, xs)
 613 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 614     where
 615       (ys', ys'') = splitAtList xs ys
 616
 617 split :: Char -> String -> [String]
 618 split c s = case rest of
 619                 []     -> [chunk]
 620                 _:rest -> chunk : split c rest
 621   where (chunk, rest) = break (==c) s
 622 \end{code}
 623
 624
 625 %************************************************************************
 626 %*                                                                      *
 627 \subsection[Utils-comparison]{Comparisons}
 628 %*                                                                      *
 629 %************************************************************************
 630
 631 \begin{code}
 632 isEqual :: Ordering -> Bool
 633 -- Often used in (isEqual (a `compare` b))
 634 isEqual GT = False
 635 isEqual EQ = True
 636 isEqual LT = False
 637
 638 thenCmp :: Ordering -> Ordering -> Ordering
 639 {-# INLINE thenCmp #-}
 640 thenCmp EQ   any = any
 641 thenCmp other any = other
 642
 643 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 644 eqListBy eq []     []     = True
 645 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 646 eqListBy eq xs     ys     = False
 647
 648 equalLength :: [a] -> [b] -> Bool
 649 equalLength [] []         = True
 650 equalLength (_:xs) (_:ys) = equalLength xs ys
 651 equalLength xs    ys      = False
 652
 653 compareLength :: [a] -> [b] -> Ordering
 654 compareLength [] []         = EQ
 655 compareLength (_:xs) (_:ys) = compareLength xs ys
 656 compareLength [] _ys        = LT
 657 compareLength _xs []        = GT
 658
 659 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 660     -- `cmpList' uses a user-specified comparer
 661
 662 cmpList cmp []     [] = EQ
 663 cmpList cmp []     _  = LT
 664 cmpList cmp _      [] = GT
 665 cmpList cmp (a:as) (b:bs)
 666   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 667 \end{code}
 668
 669 \begin{code}
 670 prefixMatch :: Eq a => [a] -> [a] -> Bool
 671 prefixMatch [] _str = True
 672 prefixMatch _pat [] = False
 673 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 674                           | otherwise = False
 675
 676 maybePrefixMatch :: String -> String -> Maybe String
 677 maybePrefixMatch []    rest = Just rest
 678 maybePrefixMatch (_:_) []   = Nothing
 679 maybePrefixMatch (p:pat) (r:rest)
 680   | p == r    = maybePrefixMatch pat rest
 681   | otherwise = Nothing
 682
 683 suffixMatch :: Eq a => [a] -> [a] -> Bool
 684 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 685
 686 removeSpaces :: String -> String
 687 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 688 \end{code}
 689
 690 %************************************************************************
 691 %*                                                                      *
 692 \subsection[Utils-pairs]{Pairs}
 693 %*                                                                      *
 694 %************************************************************************
 695
 696 The following are curried versions of @fst@ and @snd@.
 697
 698 \begin{code}
 699 #if NOT_USED
 700 cfst :: a -> b -> a     -- stranal-sem only (Note)
 701 cfst x y = x
 702 #endif
 703 \end{code}
 704
 705 The following provide us higher order functions that, when applied
 706 to a function, operate on pairs.
 707
 708 \begin{code}
 709 #if NOT_USED
 710 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 711 applyToPair (f,g) (x,y) = (f x, g y)
 712
 713 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 714 applyToFst f (x,y) = (f x,y)
 715
 716 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 717 applyToSnd f (x,y) = (x,f y)
 718 #endif
 719 \end{code}
 720
 721 \begin{code}
 722 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 723 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 724 \end{code}
 725
 726 \begin{code}
 727 seqList :: [a] -> b -> b
 728 seqList [] b = b
 729 seqList (x:xs) b = x `seq` seqList xs b
 730 \end{code}
 731
 732 Global variables:
 733
 734 \begin{code}
 735 global :: a -> IORef a
 736 global a = unsafePerformIO (newIORef a)
 737 \end{code}
 738
 739 \begin{code}
 740 consIORef :: IORef [a] -> a -> IO ()
 741 consIORef var x = do
 742   xs <- readIORef var
 743   writeIORef var (x:xs)
 744 \end{code}
 745
 746 Module names:
 747
 748 \begin{code}
 749 looksLikeModuleName [] = False
 750 looksLikeModuleName (c:cs) = isUpper c && go cs
 751   where go [] = True
 752         go ('.':cs) = looksLikeModuleName cs
 753         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 754 \end{code}
 755
 756 Akin to @Prelude.words@, but sensitive to dquoted entities treating
 757 them as single words.
 758
 759 \begin{code}
 760 toArgs :: String -> [String]
 761 toArgs "" = []
 762 toArgs s  =
 763   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 764     (w,aft) ->
 765        (\ ws -> if null w then ws else w : ws) $
 766        case aft of
 767          []           -> []
 768          (x:xs)
 769            | x /= '"'  -> toArgs xs
 770            | otherwise ->
 771              case lex aft of
 772                ((str,rs):_) -> stripQuotes str : toArgs rs
 773                _            -> [aft]
 774  where
 775     -- strip away dquotes; assume first and last chars contain quotes.
 776    stripQuotes :: String -> String
 777    stripQuotes ('"':xs)  = init xs
 778    stripQuotes xs        = xs
 779 \end{code}
 780
 781 -- -----------------------------------------------------------------------------
 782 -- Floats
 783
 784 \begin{code}
 785 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 786 readRational__ r = do
 787      (n,d,s) <- readFix r
 788      (k,t)   <- readExp s
 789      return ((n%1)*10^^(k-d), t)
 790  where
 791      readFix r = do
 792         (ds,s)  <- lexDecDigits r
 793         (ds',t) <- lexDotDigits s
 794         return (read (ds++ds'), length ds', t)
 795
 796      readExp (e:s) | e `elem` "eE" = readExp' s
 797      readExp s                     = return (0,s)
 798
 799      readExp' ('+':s) = readDec s
 800      readExp' ('-':s) = do
 801                         (k,t) <- readDec s
 802                         return (-k,t)
 803      readExp' s       = readDec s
 804
 805      readDec s = do
 806         (ds,r) <- nonnull isDigit s
 807         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 808                 r)
 809
 810      lexDecDigits = nonnull isDigit
 811
 812      lexDotDigits ('.':s) = return (span isDigit s)
 813      lexDotDigits s       = return ("",s)
 814
 815      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 816                       return (cs,t)
 817
 818 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 819 readRational top_s
 820   = case top_s of
 821       '-' : xs -> - (read_me xs)
 822       xs       -> read_me xs
 823   where
 824     read_me s
 825       = case (do { (x,"") <- readRational__ s ; return x }) of
 826           [x] -> x
 827           []  -> error ("readRational: no parse:"        ++ top_s)
 828           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 829
 830
 831 -----------------------------------------------------------------------------
 832 -- Create a hierarchy of directories
 833
 834 createDirectoryHierarchy :: FilePath -> IO ()
 835 createDirectoryHierarchy dir = do
 836   b <- doesDirectoryExist dir
 837   when (not b) $ do
 838         createDirectoryHierarchy (directoryOf dir)
 839         createDirectory dir
 840
 841 -----------------------------------------------------------------------------
 842 -- Verify that the 'dirname' portion of a FilePath exists.
 843 --
 844 doesDirNameExist :: FilePath -> IO Bool
 845 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 846
 847 -- -----------------------------------------------------------------------------
 848 -- Exception utils
 849
 850 later = flip finally
 851
 852 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 853 handleDyn = flip catchDyn
 854
 855 handle :: (Exception -> IO a) -> IO a -> IO a
 856 #if __GLASGOW_HASKELL__ < 501
 857 handle = flip Exception.catchAllIO
 858 #else
 859 handle h f = f `Exception.catch` \e -> case e of
 860     ExitException _ -> throw e
 861     _               -> h e
 862 #endif
 863
 864 -- --------------------------------------------------------------
 865 -- check existence & modification time at the same time
 866
 867 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 868 modificationTimeIfExists f = do
 869   (do t <- getModificationTime f; return (Just t))
 870         `IO.catch` \e -> if isDoesNotExistError e
 871                         then return Nothing
 872                         else ioError e
 873
 874 -- --------------------------------------------------------------
 875 -- Filename manipulation
 876
 877 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 878 -- separator.  On Windows these functions will also recognise '\\' as
 879 -- the path separator, but will generally construct paths using '/'.
 880
 881 type Suffix = String
 882
 883 splitFilename :: String -> (String,Suffix)
 884 splitFilename f = splitLongestPrefix f (=='.')
 885
 886 basenameOf :: FilePath -> String
 887 basenameOf = fst . splitFilename
 888
 889 suffixOf :: FilePath -> Suffix
 890 suffixOf = snd . splitFilename
 891
 892 joinFileExt :: String -> String -> FilePath
 893 joinFileExt path ""  = path
 894 joinFileExt path ext = path ++ '.':ext
 895
 896 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 897 splitFilenameDir :: String -> (String,String)
 898 splitFilenameDir str
 899    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 900          (dir', rest') | null rest = (".", dir)
 901                        | otherwise = (dir, rest)
 902      in  (dir', rest')
 903
 904 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 905 splitFilename3 :: String -> (String,String,Suffix)
 906 splitFilename3 str
 907    = let (dir, rest) = splitFilenameDir str
 908          (name, ext) = splitFilename rest
 909      in  (dir, name, ext)
 910
 911 joinFileName :: String -> String -> FilePath
 912 joinFileName ""  fname = fname
 913 joinFileName "." fname = fname
 914 joinFileName dir ""    = dir
 915 joinFileName dir fname = dir ++ '/':fname
 916
 917 -- split a string at the last character where 'pred' is True,
 918 -- returning a pair of strings. The first component holds the string
 919 -- up (but not including) the last character for which 'pred' returned
 920 -- True, the second whatever comes after (but also not including the
 921 -- last character).
 922 --
 923 -- If 'pred' returns False for all characters in the string, the original
 924 -- string is returned in the first component (and the second one is just
 925 -- empty).
 926 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 927 splitLongestPrefix str pred
 928   | null r_pre = (str,           [])
 929   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 930         -- 'tail' drops the char satisfying 'pred'
 931   where
 932     (r_suf, r_pre) = break pred (reverse str)
 933
 934 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 935 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 936
 937 -- directoryOf strips the filename off the input string, returning
 938 -- the directory.
 939 directoryOf :: FilePath -> String
 940 directoryOf = fst . splitFilenameDir
 941
 942 -- filenameOf strips the directory off the input string, returning
 943 -- the filename.
 944 filenameOf :: FilePath -> String
 945 filenameOf = snd . splitFilenameDir
 946
 947 replaceFilenameDirectory :: FilePath -> String -> FilePath
 948 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 949
 950 escapeSpaces :: String -> String
 951 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 952
 953 isPathSeparator :: Char -> Bool
 954 isPathSeparator ch =
 955 #ifdef mingw32_TARGET_OS
 956   ch == '/' || ch == '\\'
 957 #else
 958   ch == '/'
 959 #endif
 960
 961 --------------------------------------------------------------
 962 -- * Search path
 963 --------------------------------------------------------------
 964
 965 -- | The function splits the given string to substrings
 966 -- using the 'searchPathSeparator'.
 967 parseSearchPath :: String -> [FilePath]
 968 parseSearchPath path = split path
 969   where
 970     split :: String -> [String]
 971     split s =
 972       case rest' of
 973         []     -> [chunk]
 974         _:rest -> chunk : split rest
 975       where
 976         chunk =
 977           case chunk' of
 978 #ifdef mingw32_HOST_OS
 979             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 980 #endif
 981             _                                 -> chunk'
 982
 983         (chunk', rest') = break (==searchPathSeparator) s
 984
 985 -- | A platform-specific character used to separate search path strings in
 986 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
 987 -- and a semicolon (\";\") on the Windows operating system.
 988 searchPathSeparator :: Char
 989 #if mingw32_HOST_OS || mingw32_TARGET_OS
 990 searchPathSeparator = ';'
 991 #else
 992 searchPathSeparator = ':'
 993 #endif
 994
 995 -----------------------------------------------------------------------------
 996 -- Convert filepath into platform / MSDOS form.
 997
 998 -- We maintain path names in Unix form ('/'-separated) right until
 999 -- the last moment.  On Windows we dos-ify them just before passing them
1000 -- to the Windows command.
1001 --
1002 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1003 -- proved quite awkward.  There were a lot more calls to platformPath,
1004 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1005 -- interpreted a command line 'foo\baz' as 'foobaz'.
1006
1007 normalisePath :: String -> String
1008 -- Just changes '\' to '/'
1009
1010 pgmPath :: String               -- Directory string in Unix format
1011         -> String               -- Program name with no directory separators
1012                                 --      (e.g. copy /y)
1013         -> String               -- Program invocation string in native format
1014
1015 #if defined(mingw32_HOST_OS)
1016 --------------------- Windows version ------------------
1017 normalisePath xs = subst '\\' '/' xs
1018 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
1019 platformPath p   = subst '/' '\\' p
1020
1021 subst a b ls = map (\ x -> if x == a then b else x) ls
1022 #else
1023 --------------------- Non-Windows version --------------
1024 normalisePath xs   = xs
1025 pgmPath dir pgm    = dir ++ '/' : pgm
1026 platformPath stuff = stuff
1027 --------------------------------------------------------
1028 #endif
1029 \end{code}