Util.lhs

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