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, prefixMatch, suffixMatch, maybePrefixMatch,
  43         removeSpaces,
  44
  45         -- strictness
  46         foldl', seqList,
  47
  48         -- pairs
  49         unzipWith,
  50
  51         global, consIORef,
  52
  53         -- module names
  54         looksLikeModuleName,
  55
  56         toArgs,
  57
  58         -- Floating point stuff
  59         readRational,
  60
  61         -- IO-ish utilities
  62         createDirectoryHierarchy,
  63         doesDirNameExist,
  64         modificationTimeIfExists,
  65
  66         later, handleDyn, handle,
  67
  68         -- Filename utils
  69         Suffix,
  70         splitFilename, suffixOf, basenameOf, joinFileExt,
  71         splitFilenameDir, joinFileName,
  72         splitFilename3,
  73         splitLongestPrefix,
  74         replaceFilenameSuffix, directoryOf, filenameOf,
  75         replaceFilenameDirectory,
  76         escapeSpaces, isPathSeparator,
  77         parseSearchPath,
  78         normalisePath, platformPath, pgmPath,
  79     ) where
  80
  81 #include "HsVersions.h"
  82
  83 import Panic            ( panic, trace )
  84 import FastTypes
  85
  86 import Control.Exception ( Exception(..), finally, catchDyn, throw )
  87 import qualified Control.Exception as Exception
  88 import Data.Dynamic     ( Typeable )
  89 import Data.IORef       ( IORef, newIORef )
  90 import System.IO.Unsafe ( unsafePerformIO )
  91 import Data.IORef       ( readIORef, writeIORef )
  92
  93 import qualified Data.List as List ( elem, notElem )
  94
  95 #ifndef DEBUG
  96 import Data.List                ( zipWith4 )
  97 #endif
  98
  99 import Control.Monad    ( when )
 100 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
 101 import System.Directory ( doesDirectoryExist, createDirectory,
 102                           getModificationTime )
 103 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
 104 import Data.Ratio       ( (%) )
 105 import System.Time      ( ClockTime )
 106
 107 infixr 9 `thenCmp`
 108 \end{code}
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{The Eager monad}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 The @Eager@ monad is just an encoding of continuation-passing style,
 117 used to allow you to express "do this and then that", mainly to avoid
 118 space leaks. It's done with a type synonym to save bureaucracy.
 119
 120 \begin{code}
 121 #if NOT_USED
 122
 123 type Eager ans a = (a -> ans) -> ans
 124
 125 runEager :: Eager a a -> a
 126 runEager m = m (\x -> x)
 127
 128 appEager :: Eager ans a -> (a -> ans) -> ans
 129 appEager m cont = m cont
 130
 131 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
 132 thenEager m k cont = m (\r -> k r cont)
 133
 134 returnEager :: a -> Eager ans a
 135 returnEager v cont = cont v
 136
 137 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
 138 mapEager f [] = returnEager []
 139 mapEager f (x:xs) = f x                 `thenEager` \ y ->
 140                     mapEager f xs       `thenEager` \ ys ->
 141                     returnEager (y:ys)
 142 #endif
 143 \end{code}
 144
 145 %************************************************************************
 146 %*                                                                      *
 147 \subsection{A for loop}
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 -- Compose a function with itself n times.  (nth rather than twice)
 153 nTimes :: Int -> (a -> a) -> (a -> a)
 154 nTimes 0 _ = id
 155 nTimes 1 f = f
 156 nTimes n f = f . nTimes (n-1) f
 157 \end{code}
 158
 159 %************************************************************************
 160 %*                                                                      *
 161 \subsection[Utils-lists]{General list processing}
 162 %*                                                                      *
 163 %************************************************************************
 164
 165 \begin{code}
 166 filterOut :: (a->Bool) -> [a] -> [a]
 167 -- Like filter, only reverses the sense of the test
 168 filterOut p [] = []
 169 filterOut p (x:xs) | p x       = filterOut p xs
 170                    | otherwise = x : filterOut p xs
 171
 172 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 173 partitionWith f [] = ([],[])
 174 partitionWith f (x:xs) = case f x of
 175                            Left  b -> (b:bs, cs)
 176                            Right c -> (bs, c:cs)
 177                        where
 178                          (bs,cs) = partitionWith f xs
 179
 180 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 prefixMatch :: Eq a => [a] -> [a] -> Bool
 692 prefixMatch [] _str = True
 693 prefixMatch _pat [] = False
 694 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 695                           | otherwise = False
 696
 697 maybePrefixMatch :: String -> String -> Maybe String
 698 maybePrefixMatch []    rest = Just rest
 699 maybePrefixMatch (_:_) []   = Nothing
 700 maybePrefixMatch (p:pat) (r:rest)
 701   | p == r    = maybePrefixMatch pat rest
 702   | otherwise = Nothing
 703
 704 suffixMatch :: Eq a => [a] -> [a] -> Bool
 705 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 706
 707 removeSpaces :: String -> String
 708 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 709 \end{code}
 710
 711 %************************************************************************
 712 %*                                                                      *
 713 \subsection[Utils-pairs]{Pairs}
 714 %*                                                                      *
 715 %************************************************************************
 716
 717 The following are curried versions of @fst@ and @snd@.
 718
 719 \begin{code}
 720 #if NOT_USED
 721 cfst :: a -> b -> a     -- stranal-sem only (Note)
 722 cfst x y = x
 723 #endif
 724 \end{code}
 725
 726 The following provide us higher order functions that, when applied
 727 to a function, operate on pairs.
 728
 729 \begin{code}
 730 #if NOT_USED
 731 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 732 applyToPair (f,g) (x,y) = (f x, g y)
 733
 734 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 735 applyToFst f (x,y) = (f x,y)
 736
 737 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 738 applyToSnd f (x,y) = (x,f y)
 739 #endif
 740 \end{code}
 741
 742 \begin{code}
 743 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 744 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 745 \end{code}
 746
 747 \begin{code}
 748 seqList :: [a] -> b -> b
 749 seqList [] b = b
 750 seqList (x:xs) b = x `seq` seqList xs b
 751 \end{code}
 752
 753 Global variables:
 754
 755 \begin{code}
 756 global :: a -> IORef a
 757 global a = unsafePerformIO (newIORef a)
 758 \end{code}
 759
 760 \begin{code}
 761 consIORef :: IORef [a] -> a -> IO ()
 762 consIORef var x = do
 763   xs <- readIORef var
 764   writeIORef var (x:xs)
 765 \end{code}
 766
 767 Module names:
 768
 769 \begin{code}
 770 looksLikeModuleName [] = False
 771 looksLikeModuleName (c:cs) = isUpper c && go cs
 772   where go [] = True
 773         go ('.':cs) = looksLikeModuleName cs
 774         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 775 \end{code}
 776
 777 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 778 quoted strings and escaped characters within the input as solid blocks
 779 of characters.  Doesn't raise any exceptions on malformed escapes or
 780 quoting.
 781
 782 \begin{code}
 783 toArgs :: String -> [String]
 784 toArgs "" = []
 785 toArgs s  =
 786   case dropWhile isSpace s of  -- drop initial spacing
 787     [] -> []  -- empty, so no more tokens
 788     rem -> let (tok,aft) = token rem [] in tok : toArgs aft
 789  where
 790    -- Grab a token off the string, given that the first character exists and
 791    -- isn't whitespace.  The second argument is an accumulator which has to be
 792    -- reversed at the end.
 793   token [] acc = (reverse acc,[])            -- out of characters
 794   token ('\\':c:aft) acc                     -- escapes
 795                = token aft ((escape c) : acc)
 796   token (q:aft) acc | q == '"' || q == '\''  -- open quotes
 797                = let (aft',acc') = quote q aft acc in token aft' acc'
 798   token (c:aft) acc | isSpace c              -- unescaped, unquoted spacing
 799                = (reverse acc,aft)
 800   token (c:aft) acc                          -- anything else goes in the token
 801                = token aft (c:acc)
 802
 803    -- Get the appropriate character for a single-character escape.
 804   escape 'n' = '\n'
 805   escape 't' = '\t'
 806   escape 'r' = '\r'
 807   escape c   = c
 808
 809    -- Read into accumulator until a quote character is found.
 810   quote qc =
 811     let quote' [] acc                  = ([],acc)
 812         quote' ('\\':c:aft) acc        = quote' aft ((escape c) : acc)
 813         quote' (c:aft) acc | c == qc   = (aft,acc)
 814         quote' (c:aft) acc             = quote' aft (c:acc)
 815     in quote'
 816 \end{code}
 817
 818 -- -----------------------------------------------------------------------------
 819 -- Floats
 820
 821 \begin{code}
 822 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 823 readRational__ r = do
 824      (n,d,s) <- readFix r
 825      (k,t)   <- readExp s
 826      return ((n%1)*10^^(k-d), t)
 827  where
 828      readFix r = do
 829         (ds,s)  <- lexDecDigits r
 830         (ds',t) <- lexDotDigits s
 831         return (read (ds++ds'), length ds', t)
 832
 833      readExp (e:s) | e `elem` "eE" = readExp' s
 834      readExp s                     = return (0,s)
 835
 836      readExp' ('+':s) = readDec s
 837      readExp' ('-':s) = do
 838                         (k,t) <- readDec s
 839                         return (-k,t)
 840      readExp' s       = readDec s
 841
 842      readDec s = do
 843         (ds,r) <- nonnull isDigit s
 844         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 845                 r)
 846
 847      lexDecDigits = nonnull isDigit
 848
 849      lexDotDigits ('.':s) = return (span isDigit s)
 850      lexDotDigits s       = return ("",s)
 851
 852      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 853                       return (cs,t)
 854
 855 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 856 readRational top_s
 857   = case top_s of
 858       '-' : xs -> - (read_me xs)
 859       xs       -> read_me xs
 860   where
 861     read_me s
 862       = case (do { (x,"") <- readRational__ s ; return x }) of
 863           [x] -> x
 864           []  -> error ("readRational: no parse:"        ++ top_s)
 865           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 866
 867
 868 -----------------------------------------------------------------------------
 869 -- Create a hierarchy of directories
 870
 871 createDirectoryHierarchy :: FilePath -> IO ()
 872 createDirectoryHierarchy dir = do
 873   b <- doesDirectoryExist dir
 874   when (not b) $ do
 875         createDirectoryHierarchy (directoryOf dir)
 876         createDirectory dir
 877
 878 -----------------------------------------------------------------------------
 879 -- Verify that the 'dirname' portion of a FilePath exists.
 880 --
 881 doesDirNameExist :: FilePath -> IO Bool
 882 doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
 883
 884 -- -----------------------------------------------------------------------------
 885 -- Exception utils
 886
 887 later = flip finally
 888
 889 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 890 handleDyn = flip catchDyn
 891
 892 handle :: (Exception -> IO a) -> IO a -> IO a
 893 #if __GLASGOW_HASKELL__ < 501
 894 handle = flip Exception.catchAllIO
 895 #else
 896 handle h f = f `Exception.catch` \e -> case e of
 897     ExitException _ -> throw e
 898     _               -> h e
 899 #endif
 900
 901 -- --------------------------------------------------------------
 902 -- check existence & modification time at the same time
 903
 904 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 905 modificationTimeIfExists f = do
 906   (do t <- getModificationTime f; return (Just t))
 907         `IO.catch` \e -> if isDoesNotExistError e
 908                         then return Nothing
 909                         else ioError e
 910
 911 -- --------------------------------------------------------------
 912 -- Filename manipulation
 913
 914 -- Filenames are kept "normalised" inside GHC, using '/' as the path
 915 -- separator.  On Windows these functions will also recognise '\\' as
 916 -- the path separator, but will generally construct paths using '/'.
 917
 918 type Suffix = String
 919
 920 splitFilename :: String -> (String,Suffix)
 921 splitFilename f = splitLongestPrefix f (=='.')
 922
 923 basenameOf :: FilePath -> String
 924 basenameOf = fst . splitFilename
 925
 926 suffixOf :: FilePath -> Suffix
 927 suffixOf = snd . splitFilename
 928
 929 joinFileExt :: String -> String -> FilePath
 930 joinFileExt path ""  = path
 931 joinFileExt path ext = path ++ '.':ext
 932
 933 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
 934 splitFilenameDir :: String -> (String,String)
 935 splitFilenameDir str
 936    = let (dir, rest) = splitLongestPrefix str isPathSeparator
 937          (dir', rest') | null rest = (".", dir)
 938                        | otherwise = (dir, rest)
 939      in  (dir', rest')
 940
 941 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
 942 splitFilename3 :: String -> (String,String,Suffix)
 943 splitFilename3 str
 944    = let (dir, rest) = splitFilenameDir str
 945          (name, ext) = splitFilename rest
 946      in  (dir, name, ext)
 947
 948 joinFileName :: String -> String -> FilePath
 949 joinFileName ""  fname = fname
 950 joinFileName "." fname = fname
 951 joinFileName dir ""    = dir
 952 joinFileName dir fname = dir ++ '/':fname
 953
 954 -- split a string at the last character where 'pred' is True,
 955 -- returning a pair of strings. The first component holds the string
 956 -- up (but not including) the last character for which 'pred' returned
 957 -- True, the second whatever comes after (but also not including the
 958 -- last character).
 959 --
 960 -- If 'pred' returns False for all characters in the string, the original
 961 -- string is returned in the first component (and the second one is just
 962 -- empty).
 963 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 964 splitLongestPrefix str pred
 965   | null r_pre = (str,           [])
 966   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 967         -- 'tail' drops the char satisfying 'pred'
 968   where
 969     (r_suf, r_pre) = break pred (reverse str)
 970
 971 replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
 972 replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
 973
 974 -- directoryOf strips the filename off the input string, returning
 975 -- the directory.
 976 directoryOf :: FilePath -> String
 977 directoryOf = fst . splitFilenameDir
 978
 979 -- filenameOf strips the directory off the input string, returning
 980 -- the filename.
 981 filenameOf :: FilePath -> String
 982 filenameOf = snd . splitFilenameDir
 983
 984 replaceFilenameDirectory :: FilePath -> String -> FilePath
 985 replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
 986
 987 escapeSpaces :: String -> String
 988 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 989
 990 isPathSeparator :: Char -> Bool
 991 isPathSeparator ch =
 992 #ifdef mingw32_TARGET_OS
 993   ch == '/' || ch == '\\'
 994 #else
 995   ch == '/'
 996 #endif
 997
 998 --------------------------------------------------------------
 999 -- * Search path
1000 --------------------------------------------------------------
1001
1002 -- | The function splits the given string to substrings
1003 -- using the 'searchPathSeparator'.
1004 parseSearchPath :: String -> [FilePath]
1005 parseSearchPath path = split path
1006   where
1007     split :: String -> [String]
1008     split s =
1009       case rest' of
1010         []     -> [chunk]
1011         _:rest -> chunk : split rest
1012       where
1013         chunk =
1014           case chunk' of
1015 #ifdef mingw32_HOST_OS
1016             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1017 #endif
1018             _                                 -> chunk'
1019
1020         (chunk', rest') = break (==searchPathSeparator) s
1021
1022 -- | A platform-specific character used to separate search path strings in
1023 -- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
1024 -- and a semicolon (\";\") on the Windows operating system.
1025 searchPathSeparator :: Char
1026 #if mingw32_HOST_OS || mingw32_TARGET_OS
1027 searchPathSeparator = ';'
1028 #else
1029 searchPathSeparator = ':'
1030 #endif
1031
1032 -----------------------------------------------------------------------------
1033 -- Convert filepath into platform / MSDOS form.
1034
1035 -- We maintain path names in Unix form ('/'-separated) right until
1036 -- the last moment.  On Windows we dos-ify them just before passing them
1037 -- to the Windows command.
1038 --
1039 -- The alternative, of using '/' consistently on Unix and '\' on Windows,
1040 -- proved quite awkward.  There were a lot more calls to platformPath,
1041 -- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
1042 -- interpreted a command line 'foo\baz' as 'foobaz'.
1043
1044 normalisePath :: String -> String
1045 -- Just changes '\' to '/'
1046
1047 pgmPath :: String               -- Directory string in Unix format
1048         -> String               -- Program name with no directory separators
1049                                 --      (e.g. copy /y)
1050         -> String               -- Program invocation string in native format
1051
1052 #if defined(mingw32_HOST_OS)
1053 --------------------- Windows version ------------------
1054 normalisePath xs = subst '\\' '/' xs
1055 pgmPath dir pgm  = platformPath dir ++ '\\' : pgm
1056 platformPath p   = subst '/' '\\' p
1057
1058 subst a b ls = map (\ x -> if x == a then b else x) ls
1059 #else
1060 --------------------- Non-Windows version --------------
1061 normalisePath xs   = xs
1062 pgmPath dir pgm    = dir ++ '/' : pgm
1063 platformPath stuff = stuff
1064 --------------------------------------------------------
1065 #endif
1066 \end{code}