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