compiler/utils/Util.lhs

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