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