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 The following provide us higher order functions that, when applied
 709 to a function, operate on pairs.
 710
 711 \begin{code}
 712 #if NOT_USED
 713 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 714 applyToPair (f,g) (x,y) = (f x, g y)
 715
 716 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 717 applyToFst f (x,y) = (f x,y)
 718
 719 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 720 applyToSnd f (x,y) = (x,f y)
 721 #endif
 722 \end{code}
 723
 724 \begin{code}
 725 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 726 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 727 \end{code}
 728
 729 \begin{code}
 730 seqList :: [a] -> b -> b
 731 seqList [] b = b
 732 seqList (x:xs) b = x `seq` seqList xs b
 733 \end{code}
 734
 735 Global variables:
 736
 737 \begin{code}
 738 global :: a -> IORef a
 739 global a = unsafePerformIO (newIORef a)
 740 \end{code}
 741
 742 \begin{code}
 743 consIORef :: IORef [a] -> a -> IO ()
 744 consIORef var x = do
 745   xs <- readIORef var
 746   writeIORef var (x:xs)
 747 \end{code}
 748
 749 Module names:
 750
 751 \begin{code}
 752 looksLikeModuleName [] = False
 753 looksLikeModuleName (c:cs) = isUpper c && go cs
 754   where go [] = True
 755         go ('.':cs) = looksLikeModuleName cs
 756         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 757 \end{code}
 758
 759 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 760 quoted strings and escaped characters within the input as solid blocks
 761 of characters.  Doesn't raise any exceptions on malformed escapes or
 762 quoting.
 763
 764 \begin{code}
 765 toArgs :: String -> [String]
 766 toArgs "" = []
 767 toArgs s  =
 768   case dropWhile isSpace s of  -- drop initial spacing
 769     [] -> []  -- empty, so no more tokens
 770     rem -> let (tok,aft) = token rem [] in tok : toArgs aft
 771  where
 772    -- Grab a token off the string, given that the first character exists and
 773    -- isn't whitespace.  The second argument is an accumulator which has to be
 774    -- reversed at the end.
 775   token [] acc = (reverse acc,[])            -- out of characters
 776   token ('\\':c:aft) acc                     -- escapes
 777                = token aft ((escape c) : acc)
 778   token (q:aft) acc | q == '"' || q == '\''  -- open quotes
 779                = let (aft',acc') = quote q aft acc in token aft' acc'
 780   token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
 781                = (reverse acc,aft)
 782   token (c:aft) acc                          -- anything else goes in the token
 783                = token aft (c:acc)
 784
 785    -- Get the appropriate character for a single-character escape.
 786   escape 'n' = '\n'
 787   escape 't' = '\t'
 788   escape 'r' = '\r'
 789   escape c   = c
 790
 791    -- Read into accumulator until a quote character is found.
 792   quote qc =
 793     let quote' [] acc                  = ([],acc)
 794         quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
 795         quote' (c:aft) acc | c == qc   = (aft,acc)
 796         quote' (c:aft) acc             = quote' aft (c:acc)
 797     in quote'
 798 \end{code}
 799
 800 -- -----------------------------------------------------------------------------
 801 -- Floats
 802
 803 \begin{code}
 804 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 805 readRational__ r = do
 806      (n,d,s) <- readFix r
 807      (k,t)   <- readExp s
 808      return ((n%1)*10^^(k-d), t)
 809  where
 810      readFix r = do
 811         (ds,s)  <- lexDecDigits r
 812         (ds',t) <- lexDotDigits s
 813         return (read (ds++ds'), length ds', t)
 814
 815      readExp (e:s) | e `elem` "eE" = readExp' s
 816      readExp s                     = return (0,s)
 817
 818      readExp' ('+':s) = readDec s
 819      readExp' ('-':s) = do
 820                         (k,t) <- readDec s
 821                         return (-k,t)
 822      readExp' s       = readDec s
 823
 824      readDec s = do
 825         (ds,r) <- nonnull isDigit s
 826         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 827                 r)
 828
 829      lexDecDigits = nonnull isDigit
 830
 831      lexDotDigits ('.':s) = return (span isDigit s)
 832      lexDotDigits s       = return ("",s)
 833
 834      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 835                       return (cs,t)
 836
 837 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 838 readRational top_s
 839   = case top_s of
 840       '-' : xs -> - (read_me xs)
 841       xs       -> read_me xs
 842   where
 843     read_me s
 844       = case (do { (x,"") <- readRational__ s ; return x }) of
 845           [x] -> x
 846           []  -> error ("readRational: no parse:"        ++ top_s)
 847           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 848
 849
 850 -----------------------------------------------------------------------------
 851 -- Create a hierarchy of directories
 852
 853 createDirectoryHierarchy :: FilePath -> IO ()
 854 createDirectoryHierarchy dir = do
 855   b <- doesDirectoryExist dir
 856   when (not b) $ do
 857         createDirectoryHierarchy (directoryOf dir)
 858         createDirectory dir
 859
 860 -----------------------------------------------------------------------------
 861 -- Verify that the 'dirname' portion of a FilePath exists.
 862 --
 863 doesDirNameExist :: FilePath -> IO Bool
 864 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 865
 866 -- -----------------------------------------------------------------------------
 867 -- Exception utils
 868
 869 later = flip finally
 870
 871 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 872 handleDyn = flip catchDyn
 873
 874 handle :: (Exception -> IO a) -> IO a -> IO a
 875 handle h f = f `Exception.catch` \e -> case e of
 876     ExitException _ -> throw e
 877     _               -> h e
 878
 879 -- --------------------------------------------------------------
 880 -- check existence & modification time at the same time
 881
 882 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 883 modificationTimeIfExists f = do
 884   (do t <- getModificationTime f; return (Just t))
 885         `IO.catch` \e -> if isDoesNotExistError e
 886                         then return Nothing
 887                         else ioError e
 888
 889 -- --------------------------------------------------------------
 890 -- Filename manipulation
 891
 892 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 893 -- separator.  On Windows these functions will also recognise '\\' as
 894 -- the path separator, but will generally construct paths using '/'.
 895
 896 type Suffix = String
 897
 898 splitFilename :: String -> (String,Suffix)
 899 splitFilename f = splitLongestPrefix f (=='.')
 900
 901 basenameOf :: FilePath -> String
 902 basenameOf = fst . splitFilename
 903
 904 suffixOf :: FilePath -> Suffix
 905 suffixOf = snd . splitFilename
 906
 907 joinFileExt :: String -> String -> FilePath
 908 joinFileExt path ""  = path
 909 joinFileExt path ext = path ++ '.':ext
 910
 911 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 912 splitFilenameDir :: String -> (String,String)
 913 splitFilenameDir str
 914    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 915          (dir', rest') | null rest = (".", dir)
 916                        | otherwise = (dir, rest)
 917      in  (dir', rest')
 918
 919 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 920 splitFilename3 :: String -> (String,String,Suffix)
 921 splitFilename3 str
 922    = let (dir, rest) = splitFilenameDir str
 923          (name, ext) = splitFilename rest
 924      in  (dir, name, ext)
 925
 926 joinFileName :: String -> String -> FilePath
 927 joinFileName ""  fname = fname
 928 joinFileName "." fname = fname
 929 joinFileName dir ""    = dir
 930 joinFileName dir fname = dir ++ '/':fname
 931
 932 -- split a string at the last character where 'pred' is True,
 933 -- returning a pair of strings. The first component holds the string
 934 -- up (but not including) the last character for which 'pred' returned
 935 -- True, the second whatever comes after (but also not including the
 936 -- last character).
 937 --
 938 -- If 'pred' returns False for all characters in the string, the original
 939 -- string is returned in the first component (and the second one is just
 940 -- empty).
 941 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 942 splitLongestPrefix str pred
 943   | null r_pre = (str,           [])
 944   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 945         -- 'tail' drops the char satisfying 'pred'
 946   where
 947     (r_suf, r_pre) = break pred (reverse str)
 948
 949 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 950 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 951
 952 -- directoryOf strips the filename off the input string, returning
 953 -- the directory.
 954 directoryOf :: FilePath -> String
 955 directoryOf = fst . splitFilenameDir
 956
 957 -- filenameOf strips the directory off the input string, returning
 958 -- the filename.
 959 filenameOf :: FilePath -> String
 960 filenameOf = snd . splitFilenameDir
 961
 962 replaceFilenameDirectory :: FilePath -> String -> FilePath
 963 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 964
 965 escapeSpaces :: String -> String
 966 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 967
 968 isPathSeparator :: Char -> Bool
 969 isPathSeparator ch =
 970 #ifdef mingw32_TARGET_OS
 971   ch == '/' || ch == '\\'
 972 #else
 973   ch == '/'
 974 #endif
 975
 976 --------------------------------------------------------------
 977 -- * Search path
 978 --------------------------------------------------------------
 979
 980 -- | The function splits the given string to substrings
 981 -- using the 'searchPathSeparator'.
 982 parseSearchPath :: String -> [FilePath]
 983 parseSearchPath path = split path
 984   where
 985     split :: String -> [String]
 986     split s =
 987       case rest' of
 988         []     -> [chunk]
 989         _:rest -> chunk : split rest
 990       where
 991         chunk =
 992           case chunk' of
 993 #ifdef mingw32_HOST_OS
 994             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 995 #endif
 996             _                                 -> chunk'
 997
 998         (chunk', rest') = break (==searchPathSeparator) s
 999
1000 -- | A platform-specific character used to separate search path strings in
1001 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
1002 -- and a semicolon (\";\") on the Windows operating system.
1003 searchPathSeparator :: Char
1004 #if mingw32_HOST_OS || mingw32_TARGET_OS
1005 searchPathSeparator = ';'
1006 #else
1007 searchPathSeparator = ':'
1008 #endif
1009
1010 -----------------------------------------------------------------------------
1011 -- Convert filepath into platform / MSDOS form.
1012
1013 -- We maintain path names in Unix form ('/'-separated) right until
1014 -- the last moment.  On Windows we dos-ify them just before passing them
1015 -- to the Windows command.
1016 --
1017 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1018 -- proved quite awkward.  There were a lot more calls to platformPath,
1019 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1020 -- interpreted a command line 'foo\baz' as 'foobaz'.
1021
1022 normalisePath :: String -> String
1023 -- Just changes '\' to '/'
1024
1025 pgmPath :: String               -- Directory string in Unix format
1026         -> String               -- Program name with no directory separators
1027                                 --      (e.g. copy /y)
1028         -> String               -- Program invocation string in native format
1029
1030 #if defined(mingw32_HOST_OS)
1031 --------------------- Windows version ------------------
1032 normalisePath xs = subst '\\' '/' xs
1033 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
1034 platformPath p   = subst '/' '\\' p
1035
1036 subst a b ls = map (\ x -> if x == a then b else x) ls
1037 #else
1038 --------------------- Non-Windows version --------------
1039 normalisePath xs   = xs
1040 pgmPath dir pgm    = dir ++ '/' : pgm
1041 platformPath stuff = stuff
1042 --------------------------------------------------------
1043 #endif
1044 \end{code}