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