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         debugIsOn,
  10
  11         -- general list processing
  12         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
  13         zipLazy, stretchZipWith,
  14         mapFst, mapSnd,
  15         mapAndUnzip, mapAndUnzip3,
  16         nOfThem, filterOut, partitionWith, splitEithers,
  17         foldl1',
  18
  19         lengthExceeds, lengthIs, lengthAtLeast,
  20         listLengthCmp, atLength, equalLength, compareLength,
  21
  22         isSingleton, only, singleton,
  23         notNull, snocView,
  24
  25         isIn, isn'tIn,
  26
  27         -- for-loop
  28         nTimes,
  29
  30         -- sorting
  31         sortLe, sortWith, on,
  32
  33         -- transitive closures
  34         transitiveClosure,
  35
  36         -- accumulating
  37         foldl2, count, all2,
  38
  39         takeList, dropList, splitAtList, split,
  40
  41         -- comparisons
  42         isEqual, eqListBy,
  43         thenCmp, cmpList, maybePrefixMatch,
  44         removeSpaces,
  45
  46         -- strictness
  47         seqList,
  48
  49         -- pairs
  50         unzipWith,
  51
  52         global, consIORef,
  53
  54         -- module names
  55         looksLikeModuleName,
  56
  57         getCmd, toCmdArgs, toArgs,
  58
  59         -- Floating point stuff
  60         readRational,
  61
  62         -- IO-ish utilities
  63         createDirectoryHierarchy,
  64         doesDirNameExist,
  65         modificationTimeIfExists,
  66
  67         later, handleDyn, handle,
  68
  69         -- Filename utils
  70         Suffix,
  71         splitLongestPrefix,
  72         escapeSpaces,
  73         parseSearchPath,
  74         Direction(..), reslash,
  75     ) where
  76
  77 #include "HsVersions.h"
  78
  79 import Panic
  80
  81 import Control.Exception ( Exception(..), finally, catchDyn, throw )
  82 import qualified Control.Exception as Exception
  83 import Data.Dynamic     ( Typeable )
  84 import Data.IORef       ( IORef, newIORef )
  85 import System.IO.Unsafe ( unsafePerformIO )
  86 import Data.IORef       ( readIORef, writeIORef )
  87 import Data.List        hiding (group)
  88
  89 import qualified Data.List as List ( elem )
  90 #ifdef DEBUG
  91 import qualified Data.List as List ( notElem )
  92 import FastTypes
  93 #endif
  94
  95 import Control.Monad    ( unless )
  96 import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
  97 import System.Directory ( doesDirectoryExist, createDirectory,
  98                           getModificationTime )
  99 import System.FilePath hiding ( searchPathSeparator )
 100 import Data.Char        ( isUpper, isAlphaNum, isSpace, ord, isDigit )
 101 import Data.Ratio       ( (%) )
 102 import System.Time      ( ClockTime )
 103
 104 infixr 9 `thenCmp`
 105 \end{code}
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{-DDEBUG}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 \begin{code}
 114 debugIsOn :: Bool
 115 #ifdef DEBUG
 116 debugIsOn = True
 117 #else
 118 debugIsOn = False
 119 #endif
 120 \end{code}
 121
 122 %************************************************************************
 123 %*                                                                      *
 124 \subsection{A for loop}
 125 %*                                                                      *
 126 %************************************************************************
 127
 128 \begin{code}
 129 -- Compose a function with itself n times.  (nth rather than twice)
 130 nTimes :: Int -> (a -> a) -> (a -> a)
 131 nTimes 0 _ = id
 132 nTimes 1 f = f
 133 nTimes n f = f . nTimes (n-1) f
 134 \end{code}
 135
 136 %************************************************************************
 137 %*                                                                      *
 138 \subsection[Utils-lists]{General list processing}
 139 %*                                                                      *
 140 %************************************************************************
 141
 142 \begin{code}
 143 filterOut :: (a->Bool) -> [a] -> [a]
 144 -- Like filter, only reverses the sense of the test
 145 filterOut _ [] = []
 146 filterOut p (x:xs) | p x       = filterOut p xs
 147                    | otherwise = x : filterOut p xs
 148
 149 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])
 150 partitionWith _ [] = ([],[])
 151 partitionWith f (x:xs) = case f x of
 152                          Left  b -> (b:bs, cs)
 153                          Right c -> (bs, c:cs)
 154     where (bs,cs) = partitionWith f xs
 155
 156 splitEithers :: [Either a b] -> ([a], [b])
 157 splitEithers [] = ([],[])
 158 splitEithers (e : es) = case e of
 159                         Left x -> (x:xs, ys)
 160                         Right y -> (xs, y:ys)
 161     where (xs,ys) = splitEithers es
 162 \end{code}
 163
 164 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 165 are of equal length.  Alastair Reid thinks this should only happen if
 166 DEBUGging on; hey, why not?
 167
 168 \begin{code}
 169 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 170 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 171 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 172 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 173
 174 #ifndef DEBUG
 175 zipEqual      _ = zip
 176 zipWithEqual  _ = zipWith
 177 zipWith3Equal _ = zipWith3
 178 zipWith4Equal _ = zipWith4
 179 #else
 180 zipEqual _   []     []     = []
 181 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 182 zipEqual msg _      _      = panic ("zipEqual: unequal lists:"++msg)
 183
 184 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 185 zipWithEqual _   _ [] []        =  []
 186 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 187
 188 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 189                                 =  z a b c : zipWith3Equal msg z as bs cs
 190 zipWith3Equal _   _ [] []  []   =  []
 191 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 192
 193 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 194                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 195 zipWith4Equal _   _ [] [] [] [] =  []
 196 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 197 #endif
 198 \end{code}
 199
 200 \begin{code}
 201 -- zipLazy is lazy in the second list (observe the ~)
 202
 203 zipLazy :: [a] -> [b] -> [(a,b)]
 204 zipLazy []     _       = []
 205 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 206 \end{code}
 207
 208
 209 \begin{code}
 210 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 211 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
 212 -- the places where p returns *True*
 213
 214 stretchZipWith _ _ _ []     _ = []
 215 stretchZipWith p z f (x:xs) ys
 216   | p x       = f x z : stretchZipWith p z f xs ys
 217   | otherwise = case ys of
 218                 []     -> []
 219                 (y:ys) -> f x y : stretchZipWith p z f xs ys
 220 \end{code}
 221
 222
 223 \begin{code}
 224 mapFst :: (a->c) -> [(a,b)] -> [(c,b)]
 225 mapSnd :: (b->c) -> [(a,b)] -> [(a,c)]
 226
 227 mapFst f xys = [(f x, y) | (x,y) <- xys]
 228 mapSnd f xys = [(x, f y) | (x,y) <- xys]
 229
 230 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 231
 232 mapAndUnzip _ [] = ([], [])
 233 mapAndUnzip f (x:xs)
 234   = let (r1,  r2)  = f x
 235         (rs1, rs2) = mapAndUnzip f xs
 236     in
 237     (r1:rs1, r2:rs2)
 238
 239 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 240
 241 mapAndUnzip3 _ [] = ([], [], [])
 242 mapAndUnzip3 f (x:xs)
 243   = let (r1,  r2,  r3)  = f x
 244         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 245     in
 246     (r1:rs1, r2:rs2, r3:rs3)
 247 \end{code}
 248
 249 \begin{code}
 250 nOfThem :: Int -> a -> [a]
 251 nOfThem n thing = replicate n thing
 252
 253 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
 254 -- specification:
 255 --
 256 --  atLength atLenPred atEndPred ls n
 257 --   | n < 0         = atLenPred n
 258 --   | length ls < n = atEndPred (n - length ls)
 259 --   | otherwise     = atLenPred (drop n ls)
 260 --
 261 atLength :: ([a] -> b)
 262          -> (Int -> b)
 263          -> [a]
 264          -> Int
 265          -> b
 266 atLength atLenPred atEndPred ls n
 267   | n < 0     = atEndPred n
 268   | otherwise = go n ls
 269   where
 270     go n [] = atEndPred n
 271     go 0 ls = atLenPred ls
 272     go n (_:xs) = go (n-1) xs
 273
 274 -- special cases.
 275 lengthExceeds :: [a] -> Int -> Bool
 276 -- (lengthExceeds xs n) = (length xs > n)
 277 lengthExceeds = atLength notNull (const False)
 278
 279 lengthAtLeast :: [a] -> Int -> Bool
 280 lengthAtLeast = atLength notNull (== 0)
 281
 282 lengthIs :: [a] -> Int -> Bool
 283 lengthIs = atLength null (==0)
 284
 285 listLengthCmp :: [a] -> Int -> Ordering
 286 listLengthCmp = atLength atLen atEnd
 287  where
 288   atEnd 0      = EQ
 289   atEnd x
 290    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 291    | otherwise = GT
 292
 293   atLen []     = EQ
 294   atLen _      = GT
 295
 296 equalLength :: [a] -> [b] -> Bool
 297 equalLength []     []     = True
 298 equalLength (_:xs) (_:ys) = equalLength xs ys
 299 equalLength _      _      = False
 300
 301 compareLength :: [a] -> [b] -> Ordering
 302 compareLength []     []     = EQ
 303 compareLength (_:xs) (_:ys) = compareLength xs ys
 304 compareLength []     _      = LT
 305 compareLength _      []     = GT
 306
 307 ----------------------------
 308 singleton :: a -> [a]
 309 singleton x = [x]
 310
 311 isSingleton :: [a] -> Bool
 312 isSingleton [_] = True
 313 isSingleton _   = False
 314
 315 notNull :: [a] -> Bool
 316 notNull [] = False
 317 notNull _  = True
 318
 319 only :: [a] -> a
 320 #ifdef DEBUG
 321 only [a] = a
 322 #else
 323 only (a:_) = a
 324 #endif
 325 only _ = panic "Util: only"
 326 \end{code}
 327
 328 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 329
 330 \begin{code}
 331 isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool
 332
 333 # ifndef DEBUG
 334 isIn    _msg x ys = elem__    x ys
 335 isn'tIn _msg x ys = notElem__ x ys
 336
 337 --these are here to be SPECIALIZEd (automagically)
 338 elem__ :: Eq a => a -> [a] -> Bool
 339 elem__ _ []     = False
 340 elem__ x (y:ys) = x == y || elem__ x ys
 341
 342 notElem__ :: Eq a => a -> [a] -> Bool
 343 notElem__ _ []     = True
 344 notElem__ x (y:ys) = x /= y && notElem__ x ys
 345
 346 # else /* DEBUG */
 347 isIn msg x ys
 348   = elem (_ILIT(0)) x ys
 349   where
 350     elem _ _ []        = False
 351     elem i x (y:ys)
 352       | i ># _ILIT(100) = trace ("Over-long elem in " ++ msg)
 353                                 (x `List.elem` (y:ys))
 354       | otherwise       = x == y || elem (i +# _ILIT(1)) x ys
 355
 356 isn'tIn msg x ys
 357   = notElem (_ILIT(0)) x ys
 358   where
 359     notElem _ _ [] =  True
 360     notElem i x (y:ys)
 361       | i ># _ILIT(100) = trace ("Over-long notElem in " ++ msg)
 362                                 (x `List.notElem` (y:ys))
 363       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 364 # endif /* DEBUG */
 365 \end{code}
 366
 367 foldl1' was added in GHC 6.4
 368
 369 \begin{code}
 370 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 604
 371 foldl1'          :: (a -> a -> a) -> [a] -> a
 372 foldl1' f (x:xs) =  foldl' f x xs
 373 foldl1' _ []     =  panic "foldl1'"
 374 #endif
 375 \end{code}
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{display}
 384 Date: Mon, 3 May 93 20:45:23 +0200
 385 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 386 To: partain@dcs.gla.ac.uk
 387 Subject: natural merge sort beats quick sort [ and it is prettier ]
 388
 389 Here is a piece of Haskell code that I'm rather fond of. See it as an
 390 attempt to get rid of the ridiculous quick-sort routine. group is
 391 quite useful by itself I think it was John's idea originally though I
 392 believe the lazy version is due to me [surprisingly complicated].
 393 gamma [used to be called] is called gamma because I got inspired by
 394 the Gamma calculus. It is not very close to the calculus but does
 395 behave less sequentially than both foldr and foldl. One could imagine
 396 a version of gamma that took a unit element as well thereby avoiding
 397 the problem with empty lists.
 398
 399 I've tried this code against
 400
 401    1) insertion sort - as provided by haskell
 402    2) the normal implementation of quick sort
 403    3) a deforested version of quick sort due to Jan Sparud
 404    4) a super-optimized-quick-sort of Lennart's
 405
 406 If the list is partially sorted both merge sort and in particular
 407 natural merge sort wins. If the list is random [ average length of
 408 rising subsequences = approx 2 ] mergesort still wins and natural
 409 merge sort is marginally beaten by Lennart's soqs. The space
 410 consumption of merge sort is a bit worse than Lennart's quick sort
 411 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 412 fpca article ] isn't used because of group.
 413
 414 have fun
 415 Carsten
 416 \end{display}
 417
 418 \begin{code}
 419 group :: (a -> a -> Bool) -> [a] -> [[a]]
 420 -- Given a <= function, group finds maximal contiguous up-runs
 421 -- or down-runs in the input list.
 422 -- It's stable, in the sense that it never re-orders equal elements
 423 --
 424 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 425 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 426 -- Here is a `better' definition of group.
 427
 428 group _ []     = []
 429 group p (x:xs) = group' xs x x (x :)
 430   where
 431     group' []     _     _     s  = [s []]
 432     group' (x:xs) x_min x_max s
 433         |      x_max `p` x  = group' xs x_min x     (s . (x :))
 434         | not (x_min `p` x) = group' xs x     x_max ((x :) . s)
 435         | otherwise         = s [] : group' xs x x (x :)
 436         -- NB: the 'not' is essential for stablity
 437         --     x `p` x_min would reverse equal elements
 438
 439 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 440 generalMerge _ xs [] = xs
 441 generalMerge _ [] ys = ys
 442 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs     (y:ys)
 443                              | otherwise = y : generalMerge p (x:xs) ys
 444
 445 -- gamma is now called balancedFold
 446
 447 balancedFold :: (a -> a -> a) -> [a] -> a
 448 balancedFold _ [] = error "can't reduce an empty list using balancedFold"
 449 balancedFold _ [x] = x
 450 balancedFold f l  = balancedFold f (balancedFold' f l)
 451
 452 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 453 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 454 balancedFold' _ xs = xs
 455
 456 generalNaturalMergeSort :: (a -> a -> Bool) -> [a] -> [a]
 457 generalNaturalMergeSort _ [] = []
 458 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 459
 460 #if NOT_USED
 461 generalMergeSort p [] = []
 462 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 463
 464 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 465
 466 mergeSort = generalMergeSort (<=)
 467 naturalMergeSort = generalNaturalMergeSort (<=)
 468
 469 mergeSortLe le = generalMergeSort le
 470 #endif
 471
 472 sortLe :: (a->a->Bool) -> [a] -> [a]
 473 sortLe le = generalNaturalMergeSort le
 474
 475 sortWith :: Ord b => (a->b) -> [a] -> [a]
 476 sortWith get_key xs = sortLe le xs
 477   where
 478     x `le` y = get_key x < get_key y
 479
 480 on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
 481 on cmp sel = \x y -> sel x `cmp` sel y
 482
 483 \end{code}
 484
 485 %************************************************************************
 486 %*                                                                      *
 487 \subsection[Utils-transitive-closure]{Transitive closure}
 488 %*                                                                      *
 489 %************************************************************************
 490
 491 This algorithm for transitive closure is straightforward, albeit quadratic.
 492
 493 \begin{code}
 494 transitiveClosure :: (a -> [a])         -- Successor function
 495                   -> (a -> a -> Bool)   -- Equality predicate
 496                   -> [a]
 497                   -> [a]                -- The transitive closure
 498
 499 transitiveClosure succ eq xs
 500  = go [] xs
 501  where
 502    go done []                      = done
 503    go done (x:xs) | x `is_in` done = go done xs
 504                   | otherwise      = go (x:done) (succ x ++ xs)
 505
 506    _ `is_in` []                 = False
 507    x `is_in` (y:ys) | eq x y    = True
 508                     | otherwise = x `is_in` ys
 509 \end{code}
 510
 511 %************************************************************************
 512 %*                                                                      *
 513 \subsection[Utils-accum]{Accumulating}
 514 %*                                                                      *
 515 %************************************************************************
 516
 517 A combination of foldl with zip.  It works with equal length lists.
 518
 519 \begin{code}
 520 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 521 foldl2 _ z [] [] = z
 522 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 523 foldl2 _ _ _      _      = panic "Util: foldl2"
 524
 525 all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool
 526 -- True if the lists are the same length, and
 527 -- all corresponding elements satisfy the predicate
 528 all2 _ []     []     = True
 529 all2 p (x:xs) (y:ys) = p x y && all2 p xs ys
 530 all2 _ _      _      = False
 531 \end{code}
 532
 533 Count the number of times a predicate is true
 534
 535 \begin{code}
 536 count :: (a -> Bool) -> [a] -> Int
 537 count _ [] = 0
 538 count p (x:xs) | p x       = 1 + count p xs
 539                | otherwise = count p xs
 540 \end{code}
 541
 542 @splitAt@, @take@, and @drop@ but with length of another
 543 list giving the break-off point:
 544
 545 \begin{code}
 546 takeList :: [b] -> [a] -> [a]
 547 takeList [] _ = []
 548 takeList (_:xs) ls =
 549    case ls of
 550      [] -> []
 551      (y:ys) -> y : takeList xs ys
 552
 553 dropList :: [b] -> [a] -> [a]
 554 dropList [] xs    = xs
 555 dropList _  xs@[] = xs
 556 dropList (_:xs) (_:ys) = dropList xs ys
 557
 558
 559 splitAtList :: [b] -> [a] -> ([a], [a])
 560 splitAtList [] xs     = ([], xs)
 561 splitAtList _ xs@[]   = (xs, xs)
 562 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 563     where
 564       (ys', ys'') = splitAtList xs ys
 565
 566 snocView :: [a] -> Maybe ([a],a)
 567         -- Split off the last element
 568 snocView [] = Nothing
 569 snocView xs = go [] xs
 570             where
 571                 -- Invariant: second arg is non-empty
 572               go acc [x]    = Just (reverse acc, x)
 573               go acc (x:xs) = go (x:acc) xs
 574               go _   []     = panic "Util: snocView"
 575
 576 split :: Char -> String -> [String]
 577 split c s = case rest of
 578                 []     -> [chunk]
 579                 _:rest -> chunk : split c rest
 580   where (chunk, rest) = break (==c) s
 581 \end{code}
 582
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsection[Utils-comparison]{Comparisons}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 \begin{code}
 591 isEqual :: Ordering -> Bool
 592 -- Often used in (isEqual (a `compare` b))
 593 isEqual GT = False
 594 isEqual EQ = True
 595 isEqual LT = False
 596
 597 thenCmp :: Ordering -> Ordering -> Ordering
 598 {-# INLINE thenCmp #-}
 599 thenCmp EQ       ordering = ordering
 600 thenCmp ordering _        = ordering
 601
 602 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 603 eqListBy _  []     []     = True
 604 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 605 eqListBy _  _      _      = False
 606
 607 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 608     -- `cmpList' uses a user-specified comparer
 609
 610 cmpList _   []     [] = EQ
 611 cmpList _   []     _  = LT
 612 cmpList _   _      [] = GT
 613 cmpList cmp (a:as) (b:bs)
 614   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 615 \end{code}
 616
 617 \begin{code}
 618 -- This (with a more general type) is Data.List.stripPrefix from GHC 6.8.
 619 -- This definition can be removed once we require at least 6.8 to build.
 620 maybePrefixMatch :: String -> String -> Maybe String
 621 maybePrefixMatch []    rest = Just rest
 622 maybePrefixMatch (_:_) []   = Nothing
 623 maybePrefixMatch (p:pat) (r:rest)
 624   | p == r    = maybePrefixMatch pat rest
 625   | otherwise = Nothing
 626
 627 removeSpaces :: String -> String
 628 removeSpaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
 629 \end{code}
 630
 631 %************************************************************************
 632 %*                                                                      *
 633 \subsection[Utils-pairs]{Pairs}
 634 %*                                                                      *
 635 %************************************************************************
 636
 637 \begin{code}
 638 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 639 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 640 \end{code}
 641
 642 \begin{code}
 643 seqList :: [a] -> b -> b
 644 seqList [] b = b
 645 seqList (x:xs) b = x `seq` seqList xs b
 646 \end{code}
 647
 648 Global variables:
 649
 650 \begin{code}
 651 global :: a -> IORef a
 652 global a = unsafePerformIO (newIORef a)
 653 \end{code}
 654
 655 \begin{code}
 656 consIORef :: IORef [a] -> a -> IO ()
 657 consIORef var x = do
 658   xs <- readIORef var
 659   writeIORef var (x:xs)
 660 \end{code}
 661
 662 Module names:
 663
 664 \begin{code}
 665 looksLikeModuleName :: String -> Bool
 666 looksLikeModuleName [] = False
 667 looksLikeModuleName (c:cs) = isUpper c && go cs
 668   where go [] = True
 669         go ('.':cs) = looksLikeModuleName cs
 670         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 671 \end{code}
 672
 673 Akin to @Prelude.words@, but acts like the Bourne shell, treating
 674 quoted strings as Haskell Strings, and also parses Haskell [String]
 675 syntax.
 676
 677 \begin{code}
 678 getCmd :: String -> Either String             -- Error
 679                            (String, String) -- (Cmd, Rest)
 680 getCmd s = case break isSpace $ dropWhile isSpace s of
 681            ([], _) -> Left ("Couldn't find command in " ++ show s)
 682            res -> Right res
 683
 684 toCmdArgs :: String -> Either String             -- Error
 685                               (String, [String]) -- (Cmd, Args)
 686 toCmdArgs s = case getCmd s of
 687               Left err -> Left err
 688               Right (cmd, s') -> case toArgs s' of
 689                                  Left err -> Left err
 690                                  Right args -> Right (cmd, args)
 691
 692 toArgs :: String -> Either String   -- Error
 693                            [String] -- Args
 694 toArgs str
 695     = case dropWhile isSpace str of
 696       s@('[':_) -> case reads s of
 697                    [(args, spaces)]
 698                     | all isSpace spaces ->
 699                        Right args
 700                    _ ->
 701                        Left ("Couldn't read " ++ show str ++ "as [String]")
 702       s -> toArgs' s
 703  where
 704   toArgs' s = case dropWhile isSpace s of
 705               [] -> Right []
 706               ('"' : _) -> case reads s of
 707                            [(arg, rest)]
 708                               -- rest must either be [] or start with a space
 709                             | all isSpace (take 1 rest) ->
 710                                case toArgs' rest of
 711                                Left err -> Left err
 712                                Right args -> Right (arg : args)
 713                            _ ->
 714                                Left ("Couldn't read " ++ show s ++ "as String")
 715               s' -> case break isSpace s' of
 716                     (arg, s'') -> case toArgs' s'' of
 717                                   Left err -> Left err
 718                                   Right args -> Right (arg : args)
 719 \end{code}
 720
 721 -- -----------------------------------------------------------------------------
 722 -- Floats
 723
 724 \begin{code}
 725 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 726 readRational__ r = do
 727      (n,d,s) <- readFix r
 728      (k,t)   <- readExp s
 729      return ((n%1)*10^^(k-d), t)
 730  where
 731      readFix r = do
 732         (ds,s)  <- lexDecDigits r
 733         (ds',t) <- lexDotDigits s
 734         return (read (ds++ds'), length ds', t)
 735
 736      readExp (e:s) | e `elem` "eE" = readExp' s
 737      readExp s                     = return (0,s)
 738
 739      readExp' ('+':s) = readDec s
 740      readExp' ('-':s) = do (k,t) <- readDec s
 741                            return (-k,t)
 742      readExp' s       = readDec s
 743
 744      readDec s = do
 745         (ds,r) <- nonnull isDigit s
 746         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 747                 r)
 748
 749      lexDecDigits = nonnull isDigit
 750
 751      lexDotDigits ('.':s) = return (span isDigit s)
 752      lexDotDigits s       = return ("",s)
 753
 754      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 755                       return (cs,t)
 756
 757 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 758 readRational top_s
 759   = case top_s of
 760       '-' : xs -> - (read_me xs)
 761       xs       -> read_me xs
 762   where
 763     read_me s
 764       = case (do { (x,"") <- readRational__ s ; return x }) of
 765           [x] -> x
 766           []  -> error ("readRational: no parse:"        ++ top_s)
 767           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 768
 769
 770 -----------------------------------------------------------------------------
 771 -- Create a hierarchy of directories
 772
 773 createDirectoryHierarchy :: FilePath -> IO ()
 774 createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
 775 createDirectoryHierarchy dir = do
 776   b <- doesDirectoryExist dir
 777   unless b $ do createDirectoryHierarchy (takeDirectory dir)
 778                 createDirectory dir
 779
 780 -----------------------------------------------------------------------------
 781 -- Verify that the 'dirname' portion of a FilePath exists.
 782 --
 783 doesDirNameExist :: FilePath -> IO Bool
 784 doesDirNameExist fpath = case takeDirectory fpath of
 785                          "" -> return True -- XXX Hack
 786                          _  -> doesDirectoryExist (takeDirectory fpath)
 787
 788 -- -----------------------------------------------------------------------------
 789 -- Exception utils
 790
 791 later :: IO b -> IO a -> IO a
 792 later = flip finally
 793
 794 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
 795 handleDyn = flip catchDyn
 796
 797 handle :: (Exception -> IO a) -> IO a -> IO a
 798 handle h f = f `Exception.catch` \e -> case e of
 799     ExitException _ -> throw e
 800     _               -> h e
 801
 802 -- --------------------------------------------------------------
 803 -- check existence & modification time at the same time
 804
 805 modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime)
 806 modificationTimeIfExists f = do
 807   (do t <- getModificationTime f; return (Just t))
 808         `IO.catch` \e -> if isDoesNotExistError e
 809                          then return Nothing
 810                          else ioError e
 811
 812 -- split a string at the last character where 'pred' is True,
 813 -- returning a pair of strings. The first component holds the string
 814 -- up (but not including) the last character for which 'pred' returned
 815 -- True, the second whatever comes after (but also not including the
 816 -- last character).
 817 --
 818 -- If 'pred' returns False for all characters in the string, the original
 819 -- string is returned in the first component (and the second one is just
 820 -- empty).
 821 splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
 822 splitLongestPrefix str pred
 823   | null r_pre = (str,           [])
 824   | otherwise  = (reverse (tail r_pre), reverse r_suf)
 825                            -- 'tail' drops the char satisfying 'pred'
 826   where (r_suf, r_pre) = break pred (reverse str)
 827
 828 escapeSpaces :: String -> String
 829 escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
 830
 831 type Suffix = String
 832
 833 --------------------------------------------------------------
 834 -- * Search path
 835 --------------------------------------------------------------
 836
 837 -- | The function splits the given string to substrings
 838 -- using the 'searchPathSeparator'.
 839 parseSearchPath :: String -> [FilePath]
 840 parseSearchPath path = split path
 841   where
 842     split :: String -> [String]
 843     split s =
 844       case rest' of
 845         []     -> [chunk]
 846         _:rest -> chunk : split rest
 847       where
 848         chunk =
 849           case chunk' of
 850 #ifdef mingw32_HOST_OS
 851             ('\"':xs@(_:_)) | last xs == '\"' -> init xs
 852 #endif
 853             _                                 -> chunk'
 854
 855         (chunk', rest') = break (==searchPathSeparator) s
 856
 857 -- | A platform-specific character used to separate search path strings in
 858 -- environment variables. The separator is a colon (\":\") on Unix and
 859 -- Macintosh, and a semicolon (\";\") on the Windows operating system.
 860 searchPathSeparator :: Char
 861 #if mingw32_HOST_OS || mingw32_TARGET_OS
 862 searchPathSeparator = ';'
 863 #else
 864 searchPathSeparator = ':'
 865 #endif
 866
 867 data Direction = Forwards | Backwards
 868
 869 reslash :: Direction -> FilePath -> FilePath
 870 reslash d = f
 871     where f ('/'  : xs) = slash : f xs
 872           f ('\\' : xs) = slash : f xs
 873           f (x    : xs) = x     : f xs
 874           f ""          = ""
 875           slash = case d of
 876                   Forwards -> '/'
 877                   Backwards -> '\\'
 878 \end{code}
 879