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