ghc/compiler/utils/Util.lhs

   1 %
   2 % (c) The University of Glasgow 1992-2002
   3 %
   4 \section[Util]{Highly random utility functions}
   5
   6 \begin{code}
   7 module Util (
   8
   9         -- general list processing
  10         zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
  11         zipLazy, stretchZipWith,
  12         mapAndUnzip, mapAndUnzip3,
  13         nOfThem, filterOut,
  14         lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
  15         isSingleton, only,
  16         notNull, snocView,
  17
  18         isIn, isn'tIn,
  19
  20         -- for-loop
  21         nTimes,
  22
  23         -- sorting
  24         sortLe, sortWith,
  25
  26         -- transitive closures
  27         transitiveClosure,
  28
  29         -- accumulating
  30         mapAccumL, mapAccumR, mapAccumB,
  31         foldl2, count,
  32
  33         takeList, dropList, splitAtList,
  34
  35         -- comparisons
  36         isEqual, eqListBy, equalLength, compareLength,
  37         thenCmp, cmpList, prefixMatch, suffixMatch, maybePrefixMatch,
  38
  39         -- strictness
  40         foldl', seqList,
  41
  42         -- pairs
  43         unzipWith,
  44
  45         global,
  46
  47         -- module names
  48         looksLikeModuleName,
  49
  50         toArgs,
  51
  52         -- Floating point stuff
  53         readRational,
  54     ) where
  55
  56 #include "HsVersions.h"
  57
  58 import Panic            ( panic, trace )
  59 import FastTypes
  60
  61 #if __GLASGOW_HASKELL__ <= 408
  62 import EXCEPTION        ( catchIO, justIoErrors, raiseInThread )
  63 #endif
  64 import DATA_IOREF       ( IORef, newIORef )
  65 import UNSAFE_IO        ( unsafePerformIO )
  66
  67 import qualified List   ( elem, notElem )
  68
  69 #ifndef DEBUG
  70 import List             ( zipWith4 )
  71 #endif
  72
  73 import Char             ( isUpper, isAlphaNum, isSpace, ord, isDigit )
  74 import Ratio            ( (%) )
  75
  76 infixr 9 `thenCmp`
  77 \end{code}
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{The Eager monad}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 The @Eager@ monad is just an encoding of continuation-passing style,
  86 used to allow you to express "do this and then that", mainly to avoid
  87 space leaks. It's done with a type synonym to save bureaucracy.
  88
  89 \begin{code}
  90 #if NOT_USED
  91
  92 type Eager ans a = (a -> ans) -> ans
  93
  94 runEager :: Eager a a -> a
  95 runEager m = m (\x -> x)
  96
  97 appEager :: Eager ans a -> (a -> ans) -> ans
  98 appEager m cont = m cont
  99
 100 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
 101 thenEager m k cont = m (\r -> k r cont)
 102
 103 returnEager :: a -> Eager ans a
 104 returnEager v cont = cont v
 105
 106 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
 107 mapEager f [] = returnEager []
 108 mapEager f (x:xs) = f x                 `thenEager` \ y ->
 109                     mapEager f xs       `thenEager` \ ys ->
 110                     returnEager (y:ys)
 111 #endif
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection{A for loop}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \begin{code}
 121 -- Compose a function with itself n times.  (nth rather than twice)
 122 nTimes :: Int -> (a -> a) -> (a -> a)
 123 nTimes 0 _ = id
 124 nTimes 1 f = f
 125 nTimes n f = f . nTimes (n-1) f
 126 \end{code}
 127
 128 %************************************************************************
 129 %*                                                                      *
 130 \subsection[Utils-lists]{General list processing}
 131 %*                                                                      *
 132 %************************************************************************
 133
 134 \begin{code}
 135 filterOut :: (a->Bool) -> [a] -> [a]
 136 -- Like filter, only reverses the sense of the test
 137 filterOut p [] = []
 138 filterOut p (x:xs) | p x       = filterOut p xs
 139                    | otherwise = x : filterOut p xs
 140 \end{code}
 141
 142 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 143 are of equal length.  Alastair Reid thinks this should only happen if
 144 DEBUGging on; hey, why not?
 145
 146 \begin{code}
 147 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 148 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 149 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 150 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 151
 152 #ifndef DEBUG
 153 zipEqual      _ = zip
 154 zipWithEqual  _ = zipWith
 155 zipWith3Equal _ = zipWith3
 156 zipWith4Equal _ = zipWith4
 157 #else
 158 zipEqual msg []     []     = []
 159 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 160 zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
 161
 162 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 163 zipWithEqual msg _ [] []        =  []
 164 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 165
 166 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 167                                 =  z a b c : zipWith3Equal msg z as bs cs
 168 zipWith3Equal msg _ [] []  []   =  []
 169 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 170
 171 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 172                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 173 zipWith4Equal msg _ [] [] [] [] =  []
 174 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 175 #endif
 176 \end{code}
 177
 178 \begin{code}
 179 -- zipLazy is lazy in the second list (observe the ~)
 180
 181 zipLazy :: [a] -> [b] -> [(a,b)]
 182 zipLazy [] ys = []
 183 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 184 \end{code}
 185
 186
 187 \begin{code}
 188 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 189 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
 190 -- the places where p returns *True*
 191
 192 stretchZipWith p z f [] ys = []
 193 stretchZipWith p z f (x:xs) ys
 194   | p x       = f x z : stretchZipWith p z f xs ys
 195   | otherwise = case ys of
 196                   []     -> []
 197                   (y:ys) -> f x y : stretchZipWith p z f xs ys
 198 \end{code}
 199
 200
 201 \begin{code}
 202 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 203
 204 mapAndUnzip f [] = ([],[])
 205 mapAndUnzip f (x:xs)
 206   = let
 207         (r1,  r2)  = f x
 208         (rs1, rs2) = mapAndUnzip f xs
 209     in
 210     (r1:rs1, r2:rs2)
 211
 212 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 213
 214 mapAndUnzip3 f [] = ([],[],[])
 215 mapAndUnzip3 f (x:xs)
 216   = let
 217         (r1,  r2,  r3)  = f x
 218         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 219     in
 220     (r1:rs1, r2:rs2, r3:rs3)
 221 \end{code}
 222
 223 \begin{code}
 224 nOfThem :: Int -> a -> [a]
 225 nOfThem n thing = replicate n thing
 226
 227 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
 228 -- specification:
 229 --
 230 --  atLength atLenPred atEndPred ls n
 231 --   | n < 0         = atLenPred n
 232 --   | length ls < n = atEndPred (n - length ls)
 233 --   | otherwise     = atLenPred (drop n ls)
 234 --
 235 atLength :: ([a] -> b)
 236          -> (Int -> b)
 237          -> [a]
 238          -> Int
 239          -> b
 240 atLength atLenPred atEndPred ls n
 241   | n < 0     = atEndPred n
 242   | otherwise = go n ls
 243   where
 244     go n [] = atEndPred n
 245     go 0 ls = atLenPred ls
 246     go n (_:xs) = go (n-1) xs
 247
 248 -- special cases.
 249 lengthExceeds :: [a] -> Int -> Bool
 250 -- (lengthExceeds xs n) = (length xs > n)
 251 lengthExceeds = atLength notNull (const False)
 252
 253 lengthAtLeast :: [a] -> Int -> Bool
 254 lengthAtLeast = atLength notNull (== 0)
 255
 256 lengthIs :: [a] -> Int -> Bool
 257 lengthIs = atLength null (==0)
 258
 259 listLengthCmp :: [a] -> Int -> Ordering
 260 listLengthCmp = atLength atLen atEnd
 261  where
 262   atEnd 0      = EQ
 263   atEnd x
 264    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 265    | otherwise = GT
 266
 267   atLen []     = EQ
 268   atLen _      = GT
 269
 270 isSingleton :: [a] -> Bool
 271 isSingleton [x] = True
 272 isSingleton  _  = False
 273
 274 notNull :: [a] -> Bool
 275 notNull [] = False
 276 notNull _  = True
 277
 278 snocView :: [a] -> Maybe ([a],a)
 279         -- Split off the last element
 280 snocView [] = Nothing
 281 snocView xs = go [] xs
 282             where
 283                 -- Invariant: second arg is non-empty
 284               go acc [x]    = Just (reverse acc, x)
 285               go acc (x:xs) = go (x:acc) xs
 286
 287 only :: [a] -> a
 288 #ifdef DEBUG
 289 only [a] = a
 290 #else
 291 only (a:_) = a
 292 #endif
 293 \end{code}
 294
 295 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 296
 297 \begin{code}
 298 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 299
 300 # ifndef DEBUG
 301 isIn    msg x ys = elem__    x ys
 302 isn'tIn msg x ys = notElem__ x ys
 303
 304 --these are here to be SPECIALIZEd (automagically)
 305 elem__ _ []     = False
 306 elem__ x (y:ys) = x==y || elem__ x ys
 307
 308 notElem__ x []     =  True
 309 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 310
 311 # else /* DEBUG */
 312 isIn msg x ys
 313   = elem (_ILIT 0) x ys
 314   where
 315     elem i _ []     = False
 316     elem i x (y:ys)
 317       | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
 318                          x `List.elem` (y:ys)
 319       | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 320
 321 isn'tIn msg x ys
 322   = notElem (_ILIT 0) x ys
 323   where
 324     notElem i x [] =  True
 325     notElem i x (y:ys)
 326       | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
 327                          x `List.notElem` (y:ys)
 328       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 329 # endif /* DEBUG */
 330 \end{code}
 331
 332 %************************************************************************
 333 %*                                                                      *
 334 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 335 %*                                                                      *
 336 %************************************************************************
 337
 338 \begin{display}
 339 Date: Mon, 3 May 93 20:45:23 +0200
 340 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 341 To: partain@dcs.gla.ac.uk
 342 Subject: natural merge sort beats quick sort [ and it is prettier ]
 343
 344 Here is a piece of Haskell code that I'm rather fond of. See it as an
 345 attempt to get rid of the ridiculous quick-sort routine. group is
 346 quite useful by itself I think it was John's idea originally though I
 347 believe the lazy version is due to me [surprisingly complicated].
 348 gamma [used to be called] is called gamma because I got inspired by
 349 the Gamma calculus. It is not very close to the calculus but does
 350 behave less sequentially than both foldr and foldl. One could imagine
 351 a version of gamma that took a unit element as well thereby avoiding
 352 the problem with empty lists.
 353
 354 I've tried this code against
 355
 356    1) insertion sort - as provided by haskell
 357    2) the normal implementation of quick sort
 358    3) a deforested version of quick sort due to Jan Sparud
 359    4) a super-optimized-quick-sort of Lennart's
 360
 361 If the list is partially sorted both merge sort and in particular
 362 natural merge sort wins. If the list is random [ average length of
 363 rising subsequences = approx 2 ] mergesort still wins and natural
 364 merge sort is marginally beaten by Lennart's soqs. The space
 365 consumption of merge sort is a bit worse than Lennart's quick sort
 366 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 367 fpca article ] isn't used because of group.
 368
 369 have fun
 370 Carsten
 371 \end{display}
 372
 373 \begin{code}
 374 group :: (a -> a -> Bool) -> [a] -> [[a]]
 375 -- Given a <= function, group finds maximal contiguous up-runs
 376 -- or down-runs in the input list.
 377 -- It's stable, in the sense that it never re-orders equal elements
 378 --
 379 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 380 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 381 -- Here is a `better' definition of group.
 382
 383 group p []     = []
 384 group p (x:xs) = group' xs x x (x :)
 385   where
 386     group' []     _     _     s  = [s []]
 387     group' (x:xs) x_min x_max s
 388         |      x_max `p` x  = group' xs x_min x (s . (x :))
 389         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 390         | otherwise         = s [] : group' xs x x (x :)
 391         -- NB: the 'not' is essential for stablity
 392         --      x `p` x_min would reverse equal elements
 393
 394 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 395 generalMerge p xs [] = xs
 396 generalMerge p [] ys = ys
 397 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 398                              | otherwise = y : generalMerge p (x:xs) ys
 399
 400 -- gamma is now called balancedFold
 401
 402 balancedFold :: (a -> a -> a) -> [a] -> a
 403 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 404 balancedFold f [x] = x
 405 balancedFold f l  = balancedFold f (balancedFold' f l)
 406
 407 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 408 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 409 balancedFold' f xs = xs
 410
 411 generalNaturalMergeSort p [] = []
 412 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 413
 414 #if NOT_USED
 415 generalMergeSort p [] = []
 416 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 417
 418 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 419
 420 mergeSort = generalMergeSort (<=)
 421 naturalMergeSort = generalNaturalMergeSort (<=)
 422
 423 mergeSortLe le = generalMergeSort le
 424 #endif
 425
 426 sortLe :: (a->a->Bool) -> [a] -> [a]
 427 sortLe le = generalNaturalMergeSort le
 428
 429 sortWith :: Ord b => (a->b) -> [a] -> [a]
 430 sortWith get_key xs = sortLe le xs
 431   where
 432     x `le` y = get_key x < get_key y
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection[Utils-transitive-closure]{Transitive closure}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 This algorithm for transitive closure is straightforward, albeit quadratic.
 442
 443 \begin{code}
 444 transitiveClosure :: (a -> [a])         -- Successor function
 445                   -> (a -> a -> Bool)   -- Equality predicate
 446                   -> [a]
 447                   -> [a]                -- The transitive closure
 448
 449 transitiveClosure succ eq xs
 450  = go [] xs
 451  where
 452    go done []                      = done
 453    go done (x:xs) | x `is_in` done = go done xs
 454                   | otherwise      = go (x:done) (succ x ++ xs)
 455
 456    x `is_in` []                 = False
 457    x `is_in` (y:ys) | eq x y    = True
 458                     | otherwise = x `is_in` ys
 459 \end{code}
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection[Utils-accum]{Accumulating}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 @mapAccumL@ behaves like a combination
 468 of  @map@ and @foldl@;
 469 it applies a function to each element of a list, passing an accumulating
 470 parameter from left to right, and returning a final value of this
 471 accumulator together with the new list.
 472
 473 \begin{code}
 474 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 475                                         -- and accumulator, returning new
 476                                         -- accumulator and elt of result list
 477             -> acc              -- Initial accumulator
 478             -> [x]              -- Input list
 479             -> (acc, [y])               -- Final accumulator and result list
 480
 481 mapAccumL f b []     = (b, [])
 482 mapAccumL f b (x:xs) = (b'', x':xs') where
 483                                           (b', x') = f b x
 484                                           (b'', xs') = mapAccumL f b' xs
 485 \end{code}
 486
 487 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 488 the same as @mapAccumL@, though.
 489
 490 \begin{code}
 491 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 492                                         -- and accumulator, returning new
 493                                         -- accumulator and elt of result list
 494             -> acc              -- Initial accumulator
 495             -> [x]              -- Input list
 496             -> (acc, [y])               -- Final accumulator and result list
 497
 498 mapAccumR f b []     = (b, [])
 499 mapAccumR f b (x:xs) = (b'', x':xs') where
 500                                           (b'', x') = f b' x
 501                                           (b', xs') = mapAccumR f b xs
 502 \end{code}
 503
 504 Here is the bi-directional version, that works from both left and right.
 505
 506 \begin{code}
 507 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 508                                 -- Function of elt of input list
 509                                 -- and accumulator, returning new
 510                                 -- accumulator and elt of result list
 511           -> accl                       -- Initial accumulator from left
 512           -> accr                       -- Initial accumulator from right
 513           -> [x]                        -- Input list
 514           -> (accl, accr, [y])  -- Final accumulators and result list
 515
 516 mapAccumB f a b []     = (a,b,[])
 517 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 518    where
 519         (a',b'',y)  = f a b' x
 520         (a'',b',ys) = mapAccumB f a' b xs
 521 \end{code}
 522
 523 A strict version of foldl.
 524
 525 \begin{code}
 526 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 527 foldl' f z xs = lgo z xs
 528              where
 529                 lgo z []     =  z
 530                 lgo z (x:xs) = (lgo $! (f z x)) xs
 531 \end{code}
 532
 533 A combination of foldl with zip.  It works with equal length lists.
 534
 535 \begin{code}
 536 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 537 foldl2 k z [] [] = z
 538 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 539 \end{code}
 540
 541 Count the number of times a predicate is true
 542
 543 \begin{code}
 544 count :: (a -> Bool) -> [a] -> Int
 545 count p [] = 0
 546 count p (x:xs) | p x       = 1 + count p xs
 547                | otherwise = count p xs
 548 \end{code}
 549
 550 @splitAt@, @take@, and @drop@ but with length of another
 551 list giving the break-off point:
 552
 553 \begin{code}
 554 takeList :: [b] -> [a] -> [a]
 555 takeList [] _ = []
 556 takeList (_:xs) ls =
 557    case ls of
 558      [] -> []
 559      (y:ys) -> y : takeList xs ys
 560
 561 dropList :: [b] -> [a] -> [a]
 562 dropList [] xs    = xs
 563 dropList _  xs@[] = xs
 564 dropList (_:xs) (_:ys) = dropList xs ys
 565
 566
 567 splitAtList :: [b] -> [a] -> ([a], [a])
 568 splitAtList [] xs     = ([], xs)
 569 splitAtList _ xs@[]   = (xs, xs)
 570 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 571     where
 572       (ys', ys'') = splitAtList xs ys
 573
 574 \end{code}
 575
 576
 577 %************************************************************************
 578 %*                                                                      *
 579 \subsection[Utils-comparison]{Comparisons}
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 isEqual :: Ordering -> Bool
 585 -- Often used in (isEqual (a `compare` b))
 586 isEqual GT = False
 587 isEqual EQ = True
 588 isEqual LT = False
 589
 590 thenCmp :: Ordering -> Ordering -> Ordering
 591 {-# INLINE thenCmp #-}
 592 thenCmp EQ   any = any
 593 thenCmp other any = other
 594
 595 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 596 eqListBy eq []     []     = True
 597 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 598 eqListBy eq xs     ys     = False
 599
 600 equalLength :: [a] -> [b] -> Bool
 601 equalLength [] []         = True
 602 equalLength (_:xs) (_:ys) = equalLength xs ys
 603 equalLength xs    ys      = False
 604
 605 compareLength :: [a] -> [b] -> Ordering
 606 compareLength [] []         = EQ
 607 compareLength (_:xs) (_:ys) = compareLength xs ys
 608 compareLength [] _ys        = LT
 609 compareLength _xs []        = GT
 610
 611 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 612     -- `cmpList' uses a user-specified comparer
 613
 614 cmpList cmp []     [] = EQ
 615 cmpList cmp []     _  = LT
 616 cmpList cmp _      [] = GT
 617 cmpList cmp (a:as) (b:bs)
 618   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 619 \end{code}
 620
 621 \begin{code}
 622 prefixMatch :: Eq a => [a] -> [a] -> Bool
 623 prefixMatch [] _str = True
 624 prefixMatch _pat [] = False
 625 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 626                           | otherwise = False
 627
 628 maybePrefixMatch :: String -> String -> Maybe String
 629 maybePrefixMatch []    rest = Just rest
 630 maybePrefixMatch (_:_) []   = Nothing
 631 maybePrefixMatch (p:pat) (r:rest)
 632   | p == r    = maybePrefixMatch pat rest
 633   | otherwise = Nothing
 634
 635 suffixMatch :: Eq a => [a] -> [a] -> Bool
 636 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 637 \end{code}
 638
 639 %************************************************************************
 640 %*                                                                      *
 641 \subsection[Utils-pairs]{Pairs}
 642 %*                                                                      *
 643 %************************************************************************
 644
 645 The following are curried versions of @fst@ and @snd@.
 646
 647 \begin{code}
 648 #if NOT_USED
 649 cfst :: a -> b -> a     -- stranal-sem only (Note)
 650 cfst x y = x
 651 #endif
 652 \end{code}
 653
 654 The following provide us higher order functions that, when applied
 655 to a function, operate on pairs.
 656
 657 \begin{code}
 658 #if NOT_USED
 659 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 660 applyToPair (f,g) (x,y) = (f x, g y)
 661
 662 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 663 applyToFst f (x,y) = (f x,y)
 664
 665 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 666 applyToSnd f (x,y) = (x,f y)
 667 #endif
 668 \end{code}
 669
 670 \begin{code}
 671 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 672 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 673 \end{code}
 674
 675 \begin{code}
 676 seqList :: [a] -> b -> b
 677 seqList [] b = b
 678 seqList (x:xs) b = x `seq` seqList xs b
 679 \end{code}
 680
 681 Global variables:
 682
 683 \begin{code}
 684 global :: a -> IORef a
 685 global a = unsafePerformIO (newIORef a)
 686 \end{code}
 687
 688 Module names:
 689
 690 \begin{code}
 691 looksLikeModuleName [] = False
 692 looksLikeModuleName (c:cs) = isUpper c && go cs
 693   where go [] = True
 694         go ('.':cs) = looksLikeModuleName cs
 695         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 696 \end{code}
 697
 698 Akin to @Prelude.words@, but sensitive to dquoted entities treating
 699 them as single words.
 700
 701 \begin{code}
 702 toArgs :: String -> [String]
 703 toArgs "" = []
 704 toArgs s  =
 705   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 706     (w,aft) ->
 707        (\ ws -> if null w then ws else w : ws) $
 708        case aft of
 709          []           -> []
 710          (x:xs)
 711            | x /= '"'  -> toArgs xs
 712            | otherwise ->
 713              case lex aft of
 714                ((str,rs):_) -> stripQuotes str : toArgs rs
 715                _            -> [aft]
 716  where
 717     -- strip away dquotes; assume first and last chars contain quotes.
 718    stripQuotes :: String -> String
 719    stripQuotes ('"':xs)  = init xs
 720    stripQuotes xs        = xs
 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
 743                         (k,t) <- readDec s
 744                         return (-k,t)
 745      readExp' s       = readDec s
 746
 747      readDec s = do
 748         (ds,r) <- nonnull isDigit s
 749         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 750                 r)
 751
 752      lexDecDigits = nonnull isDigit
 753
 754      lexDotDigits ('.':s) = return (span isDigit s)
 755      lexDotDigits s       = return ("",s)
 756
 757      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 758                       return (cs,t)
 759
 760 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 761 readRational top_s
 762   = case top_s of
 763       '-' : xs -> - (read_me xs)
 764       xs       -> read_me xs
 765   where
 766     read_me s
 767       = case (do { (x,"") <- readRational__ s ; return x }) of
 768           [x] -> x
 769           []  -> error ("readRational: no parse:"        ++ top_s)
 770           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 771 \end{code}