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