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