ghc/compiler/utils/Util.lhs

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