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 snocView :: [a] -> Maybe ([a],a)
 330         -- Split off the last element
 331 snocView [] = Nothing
 332 snocView xs = go [] xs
 333             where
 334                 -- Invariant: second arg is non-empty
 335               go acc [x]    = Just (reverse acc, x)
 336               go acc (x:xs) = go (x:acc) xs
 337
 338 only :: [a] -> a
 339 #ifdef DEBUG
 340 only [a] = a
 341 #else
 342 only (a:_) = a
 343 #endif
 344 \end{code}
 345
 346 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 347
 348 \begin{code}
 349 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 350
 351 # ifndef DEBUG
 352 isIn    msg x ys = elem__    x ys
 353 isn'tIn msg x ys = notElem__ x ys
 354
 355 --these are here to be SPECIALIZEd (automagically)
 356 elem__ _ []     = False
 357 elem__ x (y:ys) = x==y || elem__ x ys
 358
 359 notElem__ x []     =  True
 360 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 361
 362 # else /* DEBUG */
 363 isIn msg x ys
 364   = elem (_ILIT 0) x ys
 365   where
 366     elem i _ []     = False
 367     elem i x (y:ys)
 368       | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
 369                          x `List.elem` (y:ys)
 370       | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 371
 372 isn'tIn msg x ys
 373   = notElem (_ILIT 0) x ys
 374   where
 375     notElem i x [] =  True
 376     notElem i x (y:ys)
 377       | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
 378                          x `List.notElem` (y:ys)
 379       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 380 # endif /* DEBUG */
 381 \end{code}
 382
 383 %************************************************************************
 384 %*                                                                      *
 385 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 \begin{display}
 390 Date: Mon, 3 May 93 20:45:23 +0200
 391 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 392 To: partain@dcs.gla.ac.uk
 393 Subject: natural merge sort beats quick sort [ and it is prettier ]
 394
 395 Here is a piece of Haskell code that I'm rather fond of. See it as an
 396 attempt to get rid of the ridiculous quick-sort routine. group is
 397 quite useful by itself I think it was John's idea originally though I
 398 believe the lazy version is due to me [surprisingly complicated].
 399 gamma [used to be called] is called gamma because I got inspired by
 400 the Gamma calculus. It is not very close to the calculus but does
 401 behave less sequentially than both foldr and foldl. One could imagine
 402 a version of gamma that took a unit element as well thereby avoiding
 403 the problem with empty lists.
 404
 405 I've tried this code against
 406
 407    1) insertion sort - as provided by haskell
 408    2) the normal implementation of quick sort
 409    3) a deforested version of quick sort due to Jan Sparud
 410    4) a super-optimized-quick-sort of Lennart's
 411
 412 If the list is partially sorted both merge sort and in particular
 413 natural merge sort wins. If the list is random [ average length of
 414 rising subsequences = approx 2 ] mergesort still wins and natural
 415 merge sort is marginally beaten by Lennart's soqs. The space
 416 consumption of merge sort is a bit worse than Lennart's quick sort
 417 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 418 fpca article ] isn't used because of group.
 419
 420 have fun
 421 Carsten
 422 \end{display}
 423
 424 \begin{code}
 425 group :: (a -> a -> Bool) -> [a] -> [[a]]
 426 -- Given a <= function, group finds maximal contiguous up-runs
 427 -- or down-runs in the input list.
 428 -- It's stable, in the sense that it never re-orders equal elements
 429 --
 430 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 431 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 432 -- Here is a `better' definition of group.
 433
 434 group p []     = []
 435 group p (x:xs) = group' xs x x (x :)
 436   where
 437     group' []     _     _     s  = [s []]
 438     group' (x:xs) x_min x_max s
 439         |      x_max `p` x  = group' xs x_min x (s . (x :))
 440         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 441         | otherwise         = s [] : group' xs x x (x :)
 442         -- NB: the 'not' is essential for stablity
 443         --      x `p` x_min would reverse equal elements
 444
 445 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 446 generalMerge p xs [] = xs
 447 generalMerge p [] ys = ys
 448 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 449                              | otherwise = y : generalMerge p (x:xs) ys
 450
 451 -- gamma is now called balancedFold
 452
 453 balancedFold :: (a -> a -> a) -> [a] -> a
 454 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 455 balancedFold f [x] = x
 456 balancedFold f l  = balancedFold f (balancedFold' f l)
 457
 458 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 459 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 460 balancedFold' f xs = xs
 461
 462 generalNaturalMergeSort p [] = []
 463 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 464
 465 #if NOT_USED
 466 generalMergeSort p [] = []
 467 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 468
 469 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 470
 471 mergeSort = generalMergeSort (<=)
 472 naturalMergeSort = generalNaturalMergeSort (<=)
 473
 474 mergeSortLe le = generalMergeSort le
 475 #endif
 476
 477 sortLe :: (a->a->Bool) -> [a] -> [a]
 478 sortLe le = generalNaturalMergeSort le
 479
 480 sortWith :: Ord b => (a->b) -> [a] -> [a]
 481 sortWith get_key xs = sortLe le xs
 482   where
 483     x `le` y = get_key x < get_key y
 484 \end{code}
 485
 486 %************************************************************************
 487 %*                                                                      *
 488 \subsection[Utils-transitive-closure]{Transitive closure}
 489 %*                                                                      *
 490 %************************************************************************
 491
 492 This algorithm for transitive closure is straightforward, albeit quadratic.
 493
 494 \begin{code}
 495 transitiveClosure :: (a -> [a])         -- Successor function
 496                   -> (a -> a -> Bool)   -- Equality predicate
 497                   -> [a]
 498                   -> [a]                -- The transitive closure
 499
 500 transitiveClosure succ eq xs
 501  = go [] xs
 502  where
 503    go done []                      = done
 504    go done (x:xs) | x `is_in` done = go done xs
 505                   | otherwise      = go (x:done) (succ x ++ xs)
 506
 507    x `is_in` []                 = False
 508    x `is_in` (y:ys) | eq x y    = True
 509                     | otherwise = x `is_in` ys
 510 \end{code}
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection[Utils-accum]{Accumulating}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 @mapAccumL@ behaves like a combination
 519 of  @map@ and @foldl@;
 520 it applies a function to each element of a list, passing an accumulating
 521 parameter from left to right, and returning a final value of this
 522 accumulator together with the new list.
 523
 524 \begin{code}
 525 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 526                                         -- and accumulator, returning new
 527                                         -- accumulator and elt of result list
 528             -> acc              -- Initial accumulator
 529             -> [x]              -- Input list
 530             -> (acc, [y])               -- Final accumulator and result list
 531
 532 mapAccumL f b []     = (b, [])
 533 mapAccumL f b (x:xs) = (b'', x':xs') where
 534                                           (b', x') = f b x
 535                                           (b'', xs') = mapAccumL f b' xs
 536 \end{code}
 537
 538 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 539 the same as @mapAccumL@, though.
 540
 541 \begin{code}
 542 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 543                                         -- and accumulator, returning new
 544                                         -- accumulator and elt of result list
 545             -> acc              -- Initial accumulator
 546             -> [x]              -- Input list
 547             -> (acc, [y])               -- Final accumulator and result list
 548
 549 mapAccumR f b []     = (b, [])
 550 mapAccumR f b (x:xs) = (b'', x':xs') where
 551                                           (b'', x') = f b' x
 552                                           (b', xs') = mapAccumR f b xs
 553 \end{code}
 554
 555 Here is the bi-directional version, that works from both left and right.
 556
 557 \begin{code}
 558 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 559                                 -- Function of elt of input list
 560                                 -- and accumulator, returning new
 561                                 -- accumulator and elt of result list
 562           -> accl                       -- Initial accumulator from left
 563           -> accr                       -- Initial accumulator from right
 564           -> [x]                        -- Input list
 565           -> (accl, accr, [y])  -- Final accumulators and result list
 566
 567 mapAccumB f a b []     = (a,b,[])
 568 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 569    where
 570         (a',b'',y)  = f a b' x
 571         (a'',b',ys) = mapAccumB f a' b xs
 572 \end{code}
 573
 574 A strict version of foldl.
 575
 576 \begin{code}
 577 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 578 foldl' f z xs = lgo z xs
 579              where
 580                 lgo z []     =  z
 581                 lgo z (x:xs) = (lgo $! (f z x)) xs
 582 \end{code}
 583
 584 A combination of foldl with zip.  It works with equal length lists.
 585
 586 \begin{code}
 587 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 588 foldl2 k z [] [] = z
 589 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 590
 591 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 592 -- True if the lists are the same length, and
 593 -- all corresponding elements satisfy the predicate
 594 all2 p []     []     = True
 595 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 596 all2 p xs     ys     = False
 597 \end{code}
 598
 599 Count the number of times a predicate is true
 600
 601 \begin{code}
 602 count :: (a -> Bool) -> [a] -> Int
 603 count p [] = 0
 604 count p (x:xs) | p x       = 1 + count p xs
 605                | otherwise = count p xs
 606 \end{code}
 607
 608 @splitAt@, @take@, and @drop@ but with length of another
 609 list giving the break-off point:
 610
 611 \begin{code}
 612 takeList :: [b] -> [a] -> [a]
 613 takeList [] _ = []
 614 takeList (_:xs) ls =
 615    case ls of
 616      [] -> []
 617      (y:ys) -> y : takeList xs ys
 618
 619 dropList :: [b] -> [a] -> [a]
 620 dropList [] xs    = xs
 621 dropList _  xs@[] = xs
 622 dropList (_:xs) (_:ys) = dropList xs ys
 623
 624
 625 splitAtList :: [b] -> [a] -> ([a], [a])
 626 splitAtList [] xs     = ([], xs)
 627 splitAtList _ xs@[]   = (xs, xs)
 628 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 629     where
 630       (ys', ys'') = splitAtList xs ys
 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 sensitive to dquoted entities treating
 761 them as single words.
 762
 763 \begin{code}
 764 toArgs :: String -> [String]
 765 toArgs "" = []
 766 toArgs s  =
 767   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 768     (w,aft) ->
 769        (\ ws -> if null w then ws else w : ws) $
 770        case aft of
 771          []           -> []
 772          (x:xs)
 773            | x /= '"'  -> toArgs xs
 774            | otherwise ->
 775              case lex aft of
 776                ((str,rs):_) -> stripQuotes str : toArgs rs
 777                _            -> [aft]
 778  where
 779     -- strip away dquotes; assume first and last chars contain quotes.
 780    stripQuotes :: String -> String
 781    stripQuotes ('"':xs)  = init xs
 782    stripQuotes xs        = xs
 783 \end{code}
 784
 785 -- -----------------------------------------------------------------------------
 786 -- Floats
 787
 788 \begin{code}
 789 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 790 readRational__ r = do
 791      (n,d,s) <- readFix r
 792      (k,t)   <- readExp s
 793      return ((n%1)*10^^(k-d), t)
 794  where
 795      readFix r = do
 796         (ds,s)  <- lexDecDigits r
 797         (ds',t) <- lexDotDigits s
 798         return (read (ds++ds'), length ds', t)
 799
 800      readExp (e:s) | e `elem` "eE" = readExp' s
 801      readExp s                     = return (0,s)
 802
 803      readExp' ('+':s) = readDec s
 804      readExp' ('-':s) = do
 805                         (k,t) <- readDec s
 806                         return (-k,t)
 807      readExp' s       = readDec s
 808
 809      readDec s = do
 810         (ds,r) <- nonnull isDigit s
 811         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 812                 r)
 813
 814      lexDecDigits = nonnull isDigit
 815
 816      lexDotDigits ('.':s) = return (span isDigit s)
 817      lexDotDigits s       = return ("",s)
 818
 819      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 820                       return (cs,t)
 821
 822 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 823 readRational top_s
 824   = case top_s of
 825       '-' : xs -> - (read_me xs)
 826       xs       -> read_me xs
 827   where
 828     read_me s
 829       = case (do { (x,"") <- readRational__ s ; return x }) of
 830           [x] -> x
 831           []  -> error ("readRational: no parse:"        ++ top_s)
 832           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 833
 834
 835 -----------------------------------------------------------------------------
 836 -- Create a hierarchy of directories
 837
 838 createDirectoryHierarchy :: FilePath -> IO ()
 839 createDirectoryHierarchy dir = do
 840   b <- doesDirectoryExist dir
 841   when (not b) $ do
 842         createDirectoryHierarchy (directoryOf dir)
 843         createDirectory dir
 844
 845 -----------------------------------------------------------------------------
 846 -- Verify that the 'dirname' portion of a FilePath exists.
 847 --
 848 doesDirNameExist :: FilePath -> IO Bool
 849 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 850
 851 -- -----------------------------------------------------------------------------
 852 -- Exception utils
 853
 854 later = flip finally
 855
 856 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 857 handleDyn = flip catchDyn
 858
 859 handle :: (Exception -> IO a) -> IO a -> IO a
 860 #if __GLASGOW_HASKELL__ < 501
 861 handle = flip Exception.catchAllIO
 862 #else
 863 handle h f = f `Exception.catch` \e -> case e of
 864     ExitException _ -> throw e
 865     _               -> h e
 866 #endif
 867
 868 -- --------------------------------------------------------------
 869 -- check existence & modification time at the same time
 870
 871 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 872 modificationTimeIfExists f = do
 873   (do t <- getModificationTime f; return (Just t))
 874         `IO.catch` \e -> if isDoesNotExistError e
 875                         then return Nothing
 876                         else ioError e
 877
 878 -- --------------------------------------------------------------
 879 -- Filename manipulation
 880
 881 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 882 -- separator.  On Windows these functions will also recognise '\\' as
 883 -- the path separator, but will generally construct paths using '/'.
 884
 885 type Suffix = String
 886
 887 splitFilename :: String -> (String,Suffix)
 888 splitFilename f = splitLongestPrefix f (=='.')
 889
 890 basenameOf :: FilePath -> String
 891 basenameOf = fst . splitFilename
 892
 893 suffixOf :: FilePath -> Suffix
 894 suffixOf = snd . splitFilename
 895
 896 joinFileExt :: String -> String -> FilePath
 897 joinFileExt path ""  = path
 898 joinFileExt path ext = path ++ '.':ext
 899
 900 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 901 splitFilenameDir :: String -> (String,String)
 902 splitFilenameDir str
 903    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 904          (dir', rest') | null rest = (".", dir)
 905                        | otherwise = (dir, rest)
 906      in  (dir', rest')
 907
 908 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 909 splitFilename3 :: String -> (String,String,Suffix)
 910 splitFilename3 str
 911    = let (dir, rest) = splitFilenameDir str
 912          (name, ext) = splitFilename rest
 913      in  (dir, name, ext)
 914
 915 joinFileName :: String -> String -> FilePath
 916 joinFileName ""  fname = fname
 917 joinFileName "." fname = fname
 918 joinFileName dir ""    = dir
 919 joinFileName dir fname = dir ++ '/':fname
 920
 921 -- split a string at the last character where 'pred' is True,
 922 -- returning a pair of strings. The first component holds the string
 923 -- up (but not including) the last character for which 'pred' returned
 924 -- True, the second whatever comes after (but also not including the
 925 -- last character).
 926 --
 927 -- If 'pred' returns False for all characters in the string, the original
 928 -- string is returned in the first component (and the second one is just
 929 -- empty).
 930 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 931 splitLongestPrefix str pred
 932   | null r_pre = (str,           [])
 933   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 934         -- 'tail' drops the char satisfying 'pred'
 935   where
 936     (r_suf, r_pre) = break pred (reverse str)
 937
 938 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 939 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 940
 941 -- directoryOf strips the filename off the input string, returning
 942 -- the directory.
 943 directoryOf :: FilePath -> String
 944 directoryOf = fst . splitFilenameDir
 945
 946 -- filenameOf strips the directory off the input string, returning
 947 -- the filename.
 948 filenameOf :: FilePath -> String
 949 filenameOf = snd . splitFilenameDir
 950
 951 replaceFilenameDirectory :: FilePath -> String -> FilePath
 952 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 953
 954 escapeSpaces :: String -> String
 955 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 956
 957 isPathSeparator :: Char -> Bool
 958 isPathSeparator ch =
 959 #ifdef mingw32_TARGET_OS
 960   ch == '/' || ch == '\\'
 961 #else
 962   ch == '/'
 963 #endif
 964
 965 --------------------------------------------------------------
 966 -- * Search path
 967 --------------------------------------------------------------
 968
 969 -- | The function splits the given string to substrings
 970 -- using the 'searchPathSeparator'.
 971 parseSearchPath :: String -> [FilePath]
 972 parseSearchPath path = split path
 973   where
 974     split :: String -> [String]
 975     split s =
 976       case rest' of
 977         []     -> [chunk]
 978         _:rest -> chunk : split rest
 979       where
 980         chunk =
 981           case chunk' of
 982 #ifdef mingw32_HOST_OS
 983             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 984 #endif
 985             _                                 -> chunk'
 986
 987         (chunk', rest') = break (==searchPathSeparator) s
 988
 989 -- | A platform-specific character used to separate search path strings in
 990 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
 991 -- and a semicolon (\";\") on the Windows operating system.
 992 searchPathSeparator :: Char
 993 #if mingw32_HOST_OS || mingw32_TARGET_OS
 994 searchPathSeparator = ';'
 995 #else
 996 searchPathSeparator = ':'
 997 #endif
 998
 999 -----------------------------------------------------------------------------
1000 -- Convert filepath into platform / MSDOS form.
1001
1002 -- We maintain path names in Unix form ('/'-separated) right until
1003 -- the last moment.  On Windows we dos-ify them just before passing them
1004 -- to the Windows command.
1005 --
1006 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1007 -- proved quite awkward.  There were a lot more calls to platformPath,
1008 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1009 -- interpreted a command line 'foo\baz' as 'foobaz'.
1010
1011 normalisePath :: String -> String
1012 -- Just changes '\' to '/'
1013
1014 pgmPath :: String               -- Directory string in Unix format
1015         -> String               -- Program name with no directory separators
1016                                 --      (e.g. copy /y)
1017         -> String               -- Program invocation string in native format
1018
1019 #if defined(mingw32_HOST_OS)
1020 --------------------- Windows version ------------------
1021 normalisePath xs = subst '\\' '/' xs
1022 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
1023 platformPath p   = subst '/' '\\' p
1024
1025 subst a b ls = map (\ x -> if x == a then b else x) ls
1026 #else
1027 --------------------- Non-Windows version --------------
1028 normalisePath xs   = xs
1029 pgmPath dir pgm    = dir ++ '/' : pgm
1030 platformPath stuff = stuff
1031 --------------------------------------------------------
1032 #endif
1033 \end{code}