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, singleton,
  17         notNull, snocView,
  18
  19         isIn, isn'tIn,
  20
  21         -- for-loop
  22         nTimes,
  23
  24         -- sorting
  25         sortLe, sortWith,
  26
  27         -- transitive closures
  28         transitiveClosure,
  29
  30         -- accumulating
  31         mapAccumL, mapAccumR, mapAccumB,
  32         foldl2, count,
  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 singleton :: a -> [a]
 303 singleton x = [x]
 304
 305 isSingleton :: [a] -> Bool
 306 isSingleton [x] = True
 307 isSingleton  _  = False
 308
 309 notNull :: [a] -> Bool
 310 notNull [] = False
 311 notNull _  = True
 312
 313 snocView :: [a] -> Maybe ([a],a)
 314         -- Split off the last element
 315 snocView [] = Nothing
 316 snocView xs = go [] xs
 317             where
 318                 -- Invariant: second arg is non-empty
 319               go acc [x]    = Just (reverse acc, x)
 320               go acc (x:xs) = go (x:acc) xs
 321
 322 only :: [a] -> a
 323 #ifdef DEBUG
 324 only [a] = a
 325 #else
 326 only (a:_) = a
 327 #endif
 328 \end{code}
 329
 330 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 331
 332 \begin{code}
 333 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 334
 335 # ifndef DEBUG
 336 isIn    msg x ys = elem__    x ys
 337 isn'tIn msg x ys = notElem__ x ys
 338
 339 --these are here to be SPECIALIZEd (automagically)
 340 elem__ _ []     = False
 341 elem__ x (y:ys) = x==y || elem__ x ys
 342
 343 notElem__ x []     =  True
 344 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 345
 346 # else /* DEBUG */
 347 isIn msg x ys
 348   = elem (_ILIT 0) x ys
 349   where
 350     elem i _ []     = False
 351     elem i x (y:ys)
 352       | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
 353                          x `List.elem` (y:ys)
 354       | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 355
 356 isn'tIn msg x ys
 357   = notElem (_ILIT 0) x ys
 358   where
 359     notElem i x [] =  True
 360     notElem i x (y:ys)
 361       | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
 362                          x `List.notElem` (y:ys)
 363       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 364 # endif /* DEBUG */
 365 \end{code}
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{display}
 374 Date: Mon, 3 May 93 20:45:23 +0200
 375 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 376 To: partain@dcs.gla.ac.uk
 377 Subject: natural merge sort beats quick sort [ and it is prettier ]
 378
 379 Here is a piece of Haskell code that I'm rather fond of. See it as an
 380 attempt to get rid of the ridiculous quick-sort routine. group is
 381 quite useful by itself I think it was John's idea originally though I
 382 believe the lazy version is due to me [surprisingly complicated].
 383 gamma [used to be called] is called gamma because I got inspired by
 384 the Gamma calculus. It is not very close to the calculus but does
 385 behave less sequentially than both foldr and foldl. One could imagine
 386 a version of gamma that took a unit element as well thereby avoiding
 387 the problem with empty lists.
 388
 389 I've tried this code against
 390
 391    1) insertion sort - as provided by haskell
 392    2) the normal implementation of quick sort
 393    3) a deforested version of quick sort due to Jan Sparud
 394    4) a super-optimized-quick-sort of Lennart's
 395
 396 If the list is partially sorted both merge sort and in particular
 397 natural merge sort wins. If the list is random [ average length of
 398 rising subsequences = approx 2 ] mergesort still wins and natural
 399 merge sort is marginally beaten by Lennart's soqs. The space
 400 consumption of merge sort is a bit worse than Lennart's quick sort
 401 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 402 fpca article ] isn't used because of group.
 403
 404 have fun
 405 Carsten
 406 \end{display}
 407
 408 \begin{code}
 409 group :: (a -> a -> Bool) -> [a] -> [[a]]
 410 -- Given a <= function, group finds maximal contiguous up-runs
 411 -- or down-runs in the input list.
 412 -- It's stable, in the sense that it never re-orders equal elements
 413 --
 414 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 415 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 416 -- Here is a `better' definition of group.
 417
 418 group p []     = []
 419 group p (x:xs) = group' xs x x (x :)
 420   where
 421     group' []     _     _     s  = [s []]
 422     group' (x:xs) x_min x_max s
 423         |      x_max `p` x  = group' xs x_min x (s . (x :))
 424         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 425         | otherwise         = s [] : group' xs x x (x :)
 426         -- NB: the 'not' is essential for stablity
 427         --      x `p` x_min would reverse equal elements
 428
 429 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 430 generalMerge p xs [] = xs
 431 generalMerge p [] ys = ys
 432 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 433                              | otherwise = y : generalMerge p (x:xs) ys
 434
 435 -- gamma is now called balancedFold
 436
 437 balancedFold :: (a -> a -> a) -> [a] -> a
 438 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 439 balancedFold f [x] = x
 440 balancedFold f l  = balancedFold f (balancedFold' f l)
 441
 442 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 443 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 444 balancedFold' f xs = xs
 445
 446 generalNaturalMergeSort p [] = []
 447 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 448
 449 #if NOT_USED
 450 generalMergeSort p [] = []
 451 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 452
 453 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 454
 455 mergeSort = generalMergeSort (<=)
 456 naturalMergeSort = generalNaturalMergeSort (<=)
 457
 458 mergeSortLe le = generalMergeSort le
 459 #endif
 460
 461 sortLe :: (a->a->Bool) -> [a] -> [a]
 462 sortLe le = generalNaturalMergeSort le
 463
 464 sortWith :: Ord b => (a->b) -> [a] -> [a]
 465 sortWith get_key xs = sortLe le xs
 466   where
 467     x `le` y = get_key x < get_key y
 468 \end{code}
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection[Utils-transitive-closure]{Transitive closure}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476 This algorithm for transitive closure is straightforward, albeit quadratic.
 477
 478 \begin{code}
 479 transitiveClosure :: (a -> [a])         -- Successor function
 480                   -> (a -> a -> Bool)   -- Equality predicate
 481                   -> [a]
 482                   -> [a]                -- The transitive closure
 483
 484 transitiveClosure succ eq xs
 485  = go [] xs
 486  where
 487    go done []                      = done
 488    go done (x:xs) | x `is_in` done = go done xs
 489                   | otherwise      = go (x:done) (succ x ++ xs)
 490
 491    x `is_in` []                 = False
 492    x `is_in` (y:ys) | eq x y    = True
 493                     | otherwise = x `is_in` ys
 494 \end{code}
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection[Utils-accum]{Accumulating}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 @mapAccumL@ behaves like a combination
 503 of  @map@ and @foldl@;
 504 it applies a function to each element of a list, passing an accumulating
 505 parameter from left to right, and returning a final value of this
 506 accumulator together with the new list.
 507
 508 \begin{code}
 509 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 510                                         -- and accumulator, returning new
 511                                         -- accumulator and elt of result list
 512             -> acc              -- Initial accumulator
 513             -> [x]              -- Input list
 514             -> (acc, [y])               -- Final accumulator and result list
 515
 516 mapAccumL f b []     = (b, [])
 517 mapAccumL f b (x:xs) = (b'', x':xs') where
 518                                           (b', x') = f b x
 519                                           (b'', xs') = mapAccumL f b' xs
 520 \end{code}
 521
 522 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 523 the same as @mapAccumL@, though.
 524
 525 \begin{code}
 526 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 527                                         -- and accumulator, returning new
 528                                         -- accumulator and elt of result list
 529             -> acc              -- Initial accumulator
 530             -> [x]              -- Input list
 531             -> (acc, [y])               -- Final accumulator and result list
 532
 533 mapAccumR f b []     = (b, [])
 534 mapAccumR f b (x:xs) = (b'', x':xs') where
 535                                           (b'', x') = f b' x
 536                                           (b', xs') = mapAccumR f b xs
 537 \end{code}
 538
 539 Here is the bi-directional version, that works from both left and right.
 540
 541 \begin{code}
 542 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 543                                 -- Function of elt of input list
 544                                 -- and accumulator, returning new
 545                                 -- accumulator and elt of result list
 546           -> accl                       -- Initial accumulator from left
 547           -> accr                       -- Initial accumulator from right
 548           -> [x]                        -- Input list
 549           -> (accl, accr, [y])  -- Final accumulators and result list
 550
 551 mapAccumB f a b []     = (a,b,[])
 552 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 553    where
 554         (a',b'',y)  = f a b' x
 555         (a'',b',ys) = mapAccumB f a' b xs
 556 \end{code}
 557
 558 A strict version of foldl.
 559
 560 \begin{code}
 561 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 562 foldl' f z xs = lgo z xs
 563              where
 564                 lgo z []     =  z
 565                 lgo z (x:xs) = (lgo $! (f z x)) xs
 566 \end{code}
 567
 568 A combination of foldl with zip.  It works with equal length lists.
 569
 570 \begin{code}
 571 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 572 foldl2 k z [] [] = z
 573 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 574 \end{code}
 575
 576 Count the number of times a predicate is true
 577
 578 \begin{code}
 579 count :: (a -> Bool) -> [a] -> Int
 580 count p [] = 0
 581 count p (x:xs) | p x       = 1 + count p xs
 582                | otherwise = count p xs
 583 \end{code}
 584
 585 @splitAt@, @take@, and @drop@ but with length of another
 586 list giving the break-off point:
 587
 588 \begin{code}
 589 takeList :: [b] -> [a] -> [a]
 590 takeList [] _ = []
 591 takeList (_:xs) ls =
 592    case ls of
 593      [] -> []
 594      (y:ys) -> y : takeList xs ys
 595
 596 dropList :: [b] -> [a] -> [a]
 597 dropList [] xs    = xs
 598 dropList _  xs@[] = xs
 599 dropList (_:xs) (_:ys) = dropList xs ys
 600
 601
 602 splitAtList :: [b] -> [a] -> ([a], [a])
 603 splitAtList [] xs     = ([], xs)
 604 splitAtList _ xs@[]   = (xs, xs)
 605 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 606     where
 607       (ys', ys'') = splitAtList xs ys
 608
 609 split :: Char -> String -> [String]
 610 split c s = case rest of
 611                 []     -> [chunk]
 612                 _:rest -> chunk : split c rest
 613   where (chunk, rest) = break (==c) s
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619 \subsection[Utils-comparison]{Comparisons}
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 isEqual :: Ordering -> Bool
 625 -- Often used in (isEqual (a `compare` b))
 626 isEqual GT = False
 627 isEqual EQ = True
 628 isEqual LT = False
 629
 630 thenCmp :: Ordering -> Ordering -> Ordering
 631 {-# INLINE thenCmp #-}
 632 thenCmp EQ   any = any
 633 thenCmp other any = other
 634
 635 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 636 eqListBy eq []     []     = True
 637 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 638 eqListBy eq xs     ys     = False
 639
 640 equalLength :: [a] -> [b] -> Bool
 641 equalLength [] []         = True
 642 equalLength (_:xs) (_:ys) = equalLength xs ys
 643 equalLength xs    ys      = False
 644
 645 compareLength :: [a] -> [b] -> Ordering
 646 compareLength [] []         = EQ
 647 compareLength (_:xs) (_:ys) = compareLength xs ys
 648 compareLength [] _ys        = LT
 649 compareLength _xs []        = GT
 650
 651 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 652     -- `cmpList' uses a user-specified comparer
 653
 654 cmpList cmp []     [] = EQ
 655 cmpList cmp []     _  = LT
 656 cmpList cmp _      [] = GT
 657 cmpList cmp (a:as) (b:bs)
 658   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 659 \end{code}
 660
 661 \begin{code}
 662 prefixMatch :: Eq a => [a] -> [a] -> Bool
 663 prefixMatch [] _str = True
 664 prefixMatch _pat [] = False
 665 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 666                           | otherwise = False
 667
 668 maybePrefixMatch :: String -> String -> Maybe String
 669 maybePrefixMatch []    rest = Just rest
 670 maybePrefixMatch (_:_) []   = Nothing
 671 maybePrefixMatch (p:pat) (r:rest)
 672   | p == r    = maybePrefixMatch pat rest
 673   | otherwise = Nothing
 674
 675 suffixMatch :: Eq a => [a] -> [a] -> Bool
 676 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 677
 678 removeSpaces :: String -> String
 679 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 680 \end{code}
 681
 682 %************************************************************************
 683 %*                                                                      *
 684 \subsection[Utils-pairs]{Pairs}
 685 %*                                                                      *
 686 %************************************************************************
 687
 688 The following are curried versions of @fst@ and @snd@.
 689
 690 \begin{code}
 691 #if NOT_USED
 692 cfst :: a -> b -> a     -- stranal-sem only (Note)
 693 cfst x y = x
 694 #endif
 695 \end{code}
 696
 697 The following provide us higher order functions that, when applied
 698 to a function, operate on pairs.
 699
 700 \begin{code}
 701 #if NOT_USED
 702 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 703 applyToPair (f,g) (x,y) = (f x, g y)
 704
 705 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 706 applyToFst f (x,y) = (f x,y)
 707
 708 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 709 applyToSnd f (x,y) = (x,f y)
 710 #endif
 711 \end{code}
 712
 713 \begin{code}
 714 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 715 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 716 \end{code}
 717
 718 \begin{code}
 719 seqList :: [a] -> b -> b
 720 seqList [] b = b
 721 seqList (x:xs) b = x `seq` seqList xs b
 722 \end{code}
 723
 724 Global variables:
 725
 726 \begin{code}
 727 global :: a -> IORef a
 728 global a = unsafePerformIO (newIORef a)
 729 \end{code}
 730
 731 \begin{code}
 732 consIORef :: IORef [a] -> a -> IO ()
 733 consIORef var x = do
 734   xs <- readIORef var
 735   writeIORef var (x:xs)
 736 \end{code}
 737
 738 Module names:
 739
 740 \begin{code}
 741 looksLikeModuleName [] = False
 742 looksLikeModuleName (c:cs) = isUpper c && go cs
 743   where go [] = True
 744         go ('.':cs) = looksLikeModuleName cs
 745         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 746 \end{code}
 747
 748 Akin to @Prelude.words@, but sensitive to dquoted entities treating
 749 them as single words.
 750
 751 \begin{code}
 752 toArgs :: String -> [String]
 753 toArgs "" = []
 754 toArgs s  =
 755   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 756     (w,aft) ->
 757        (\ ws -> if null w then ws else w : ws) $
 758        case aft of
 759          []           -> []
 760          (x:xs)
 761            | x /= '"'  -> toArgs xs
 762            | otherwise ->
 763              case lex aft of
 764                ((str,rs):_) -> stripQuotes str : toArgs rs
 765                _            -> [aft]
 766  where
 767     -- strip away dquotes; assume first and last chars contain quotes.
 768    stripQuotes :: String -> String
 769    stripQuotes ('"':xs)  = init xs
 770    stripQuotes xs        = xs
 771 \end{code}
 772
 773 -- -----------------------------------------------------------------------------
 774 -- Floats
 775
 776 \begin{code}
 777 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 778 readRational__ r = do
 779      (n,d,s) <- readFix r
 780      (k,t)   <- readExp s
 781      return ((n%1)*10^^(k-d), t)
 782  where
 783      readFix r = do
 784         (ds,s)  <- lexDecDigits r
 785         (ds',t) <- lexDotDigits s
 786         return (read (ds++ds'), length ds', t)
 787
 788      readExp (e:s) | e `elem` "eE" = readExp' s
 789      readExp s                     = return (0,s)
 790
 791      readExp' ('+':s) = readDec s
 792      readExp' ('-':s) = do
 793                         (k,t) <- readDec s
 794                         return (-k,t)
 795      readExp' s       = readDec s
 796
 797      readDec s = do
 798         (ds,r) <- nonnull isDigit s
 799         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 800                 r)
 801
 802      lexDecDigits = nonnull isDigit
 803
 804      lexDotDigits ('.':s) = return (span isDigit s)
 805      lexDotDigits s       = return ("",s)
 806
 807      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 808                       return (cs,t)
 809
 810 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 811 readRational top_s
 812   = case top_s of
 813       '-' : xs -> - (read_me xs)
 814       xs       -> read_me xs
 815   where
 816     read_me s
 817       = case (do { (x,"") <- readRational__ s ; return x }) of
 818           [x] -> x
 819           []  -> error ("readRational: no parse:"        ++ top_s)
 820           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 821
 822
 823 -----------------------------------------------------------------------------
 824 -- Create a hierarchy of directories
 825
 826 createDirectoryHierarchy :: FilePath -> IO ()
 827 createDirectoryHierarchy dir = do
 828   b <- doesDirectoryExist dir
 829   when (not b) $ do
 830         createDirectoryHierarchy (directoryOf dir)
 831         createDirectory dir
 832
 833 -----------------------------------------------------------------------------
 834 -- Verify that the 'dirname' portion of a FilePath exists.
 835 --
 836 doesDirNameExist :: FilePath -> IO Bool
 837 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 838
 839 -- -----------------------------------------------------------------------------
 840 -- Exception utils
 841
 842 later = flip finally
 843
 844 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 845 handleDyn = flip catchDyn
 846
 847 handle :: (Exception -> IO a) -> IO a -> IO a
 848 #if __GLASGOW_HASKELL__ < 501
 849 handle = flip Exception.catchAllIO
 850 #else
 851 handle h f = f `Exception.catch` \e -> case e of
 852     ExitException _ -> throw e
 853     _               -> h e
 854 #endif
 855
 856 -- --------------------------------------------------------------
 857 -- check existence & modification time at the same time
 858
 859 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 860 modificationTimeIfExists f = do
 861   (do t <- getModificationTime f; return (Just t))
 862         `IO.catch` \e -> if isDoesNotExistError e
 863                         then return Nothing
 864                         else ioError e
 865
 866 -- --------------------------------------------------------------
 867 -- Filename manipulation
 868
 869 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 870 -- separator.  On Windows these functions will also recognise '\\' as
 871 -- the path separator, but will generally construct paths using '/'.
 872
 873 type Suffix = String
 874
 875 splitFilename :: String -> (String,Suffix)
 876 splitFilename f = splitLongestPrefix f (=='.')
 877
 878 basenameOf :: FilePath -> String
 879 basenameOf = fst . splitFilename
 880
 881 suffixOf :: FilePath -> Suffix
 882 suffixOf = snd . splitFilename
 883
 884 joinFileExt :: String -> String -> FilePath
 885 joinFileExt path ""  = path
 886 joinFileExt path ext = path ++ '.':ext
 887
 888 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 889 splitFilenameDir :: String -> (String,String)
 890 splitFilenameDir str
 891    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 892          (dir', rest') | null rest = (".", dir)
 893                        | otherwise = (dir, rest)
 894      in  (dir', rest')
 895
 896 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 897 splitFilename3 :: String -> (String,String,Suffix)
 898 splitFilename3 str
 899    = let (dir, rest) = splitFilenameDir str
 900          (name, ext) = splitFilename rest
 901      in  (dir, name, ext)
 902
 903 joinFileName :: String -> String -> FilePath
 904 joinFileName ""  fname = fname
 905 joinFileName "." fname = fname
 906 joinFileName dir ""    = dir
 907 joinFileName dir fname = dir ++ '/':fname
 908
 909 -- split a string at the last character where 'pred' is True,
 910 -- returning a pair of strings. The first component holds the string
 911 -- up (but not including) the last character for which 'pred' returned
 912 -- True, the second whatever comes after (but also not including the
 913 -- last character).
 914 --
 915 -- If 'pred' returns False for all characters in the string, the original
 916 -- string is returned in the first component (and the second one is just
 917 -- empty).
 918 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 919 splitLongestPrefix str pred
 920   | null r_pre = (str,           [])
 921   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 922         -- 'tail' drops the char satisfying 'pred'
 923   where
 924     (r_suf, r_pre) = break pred (reverse str)
 925
 926 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 927 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 928
 929 -- directoryOf strips the filename off the input string, returning
 930 -- the directory.
 931 directoryOf :: FilePath -> String
 932 directoryOf = fst . splitFilenameDir
 933
 934 -- filenameOf strips the directory off the input string, returning
 935 -- the filename.
 936 filenameOf :: FilePath -> String
 937 filenameOf = snd . splitFilenameDir
 938
 939 replaceFilenameDirectory :: FilePath -> String -> FilePath
 940 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 941
 942 escapeSpaces :: String -> String
 943 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 944
 945 isPathSeparator :: Char -> Bool
 946 isPathSeparator ch =
 947 #ifdef mingw32_TARGET_OS
 948   ch == '/' || ch == '\\'
 949 #else
 950   ch == '/'
 951 #endif
 952
 953 -----------------------------------------------------------------------------
 954 -- Convert filepath into platform / MSDOS form.
 955
 956 -- We maintain path names in Unix form ('/'-separated) right until
 957 -- the last moment.  On Windows we dos-ify them just before passing them
 958 -- to the Windows command.
 959 --
 960 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
 961 -- proved quite awkward.  There were a lot more calls to platformPath,
 962 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
 963 -- interpreted a command line 'foo\baz' as 'foobaz'.
 964
 965 normalisePath :: String -> String
 966 -- Just changes '\' to '/'
 967
 968 pgmPath :: String               -- Directory string in Unix format
 969         -> String               -- Program name with no directory separators
 970                                 --      (e.g. copy /y)
 971         -> String               -- Program invocation string in native format
 972
 973 #if defined(mingw32_HOST_OS)
 974 --------------------- Windows version ------------------
 975 normalisePath xs = subst '\\' '/' xs
 976 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
 977 platformPath p   = subst '/' '\\' p
 978
 979 subst a b ls = map (\ x -> if x == a then b else x) ls
 980 #else
 981 --------------------- Non-Windows version --------------
 982 normalisePath xs   = xs
 983 pgmPath dir pgm    = dir ++ '/' : pgm
 984 platformPath stuff = stuff
 985 --------------------------------------------------------
 986 #endif
 987 \end{code}