ghc/compiler/utils/Util.lhs

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