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