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