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