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,
  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         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 "../includes/ghcconfig.h"
  57 #include "HsVersions.h"
  58
  59 import Panic            ( panic, trace )
  60 import FastTypes
  61
  62 #if __GLASGOW_HASKELL__ <= 408
  63 import EXCEPTION        ( catchIO, justIoErrors, raiseInThread )
  64 #endif
  65 import DATA_IOREF       ( IORef, newIORef )
  66 import UNSAFE_IO        ( unsafePerformIO )
  67
  68 import qualified List   ( elem, notElem )
  69
  70 #ifndef DEBUG
  71 import List             ( zipWith4 )
  72 #endif
  73
  74 import Char             ( isUpper, isAlphaNum, isSpace, ord, isDigit )
  75 import Ratio            ( (%) )
  76
  77 infixr 9 `thenCmp`
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection{The Eager monad}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 The @Eager@ monad is just an encoding of continuation-passing style,
  87 used to allow you to express "do this and then that", mainly to avoid
  88 space leaks. It's done with a type synonym to save bureaucracy.
  89
  90 \begin{code}
  91 #if NOT_USED
  92
  93 type Eager ans a = (a -> ans) -> ans
  94
  95 runEager :: Eager a a -> a
  96 runEager m = m (\x -> x)
  97
  98 appEager :: Eager ans a -> (a -> ans) -> ans
  99 appEager m cont = m cont
 100
 101 thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
 102 thenEager m k cont = m (\r -> k r cont)
 103
 104 returnEager :: a -> Eager ans a
 105 returnEager v cont = cont v
 106
 107 mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
 108 mapEager f [] = returnEager []
 109 mapEager f (x:xs) = f x                 `thenEager` \ y ->
 110                     mapEager f xs       `thenEager` \ ys ->
 111                     returnEager (y:ys)
 112 #endif
 113 \end{code}
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{A for loop}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 -- Compose a function with itself n times.  (nth rather than twice)
 123 nTimes :: Int -> (a -> a) -> (a -> a)
 124 nTimes 0 _ = id
 125 nTimes 1 f = f
 126 nTimes n f = f . nTimes (n-1) f
 127 \end{code}
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection[Utils-lists]{General list processing}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 \begin{code}
 136 filterOut :: (a->Bool) -> [a] -> [a]
 137 -- Like filter, only reverses the sense of the test
 138 filterOut p [] = []
 139 filterOut p (x:xs) | p x       = filterOut p xs
 140                    | otherwise = x : filterOut p xs
 141 \end{code}
 142
 143 A paranoid @zip@ (and some @zipWith@ friends) that checks the lists
 144 are of equal length.  Alastair Reid thinks this should only happen if
 145 DEBUGging on; hey, why not?
 146
 147 \begin{code}
 148 zipEqual        :: String -> [a] -> [b] -> [(a,b)]
 149 zipWithEqual    :: String -> (a->b->c) -> [a]->[b]->[c]
 150 zipWith3Equal   :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
 151 zipWith4Equal   :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
 152
 153 #ifndef DEBUG
 154 zipEqual      _ = zip
 155 zipWithEqual  _ = zipWith
 156 zipWith3Equal _ = zipWith3
 157 zipWith4Equal _ = zipWith4
 158 #else
 159 zipEqual msg []     []     = []
 160 zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
 161 zipEqual msg as     bs     = panic ("zipEqual: unequal lists:"++msg)
 162
 163 zipWithEqual msg z (a:as) (b:bs)=  z a b : zipWithEqual msg z as bs
 164 zipWithEqual msg _ [] []        =  []
 165 zipWithEqual msg _ _ _          =  panic ("zipWithEqual: unequal lists:"++msg)
 166
 167 zipWith3Equal msg z (a:as) (b:bs) (c:cs)
 168                                 =  z a b c : zipWith3Equal msg z as bs cs
 169 zipWith3Equal msg _ [] []  []   =  []
 170 zipWith3Equal msg _ _  _   _    =  panic ("zipWith3Equal: unequal lists:"++msg)
 171
 172 zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
 173                                 =  z a b c d : zipWith4Equal msg z as bs cs ds
 174 zipWith4Equal msg _ [] [] [] [] =  []
 175 zipWith4Equal msg _ _  _  _  _  =  panic ("zipWith4Equal: unequal lists:"++msg)
 176 #endif
 177 \end{code}
 178
 179 \begin{code}
 180 -- zipLazy is lazy in the second list (observe the ~)
 181
 182 zipLazy :: [a] -> [b] -> [(a,b)]
 183 zipLazy [] ys = []
 184 zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
 185 \end{code}
 186
 187
 188 \begin{code}
 189 stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c]
 190 -- (stretchZipWith p z f xs ys) stretches ys by inserting z in
 191 -- the places where p returns *True*
 192
 193 stretchZipWith p z f [] ys = []
 194 stretchZipWith p z f (x:xs) ys
 195   | p x       = f x z : stretchZipWith p z f xs ys
 196   | otherwise = case ys of
 197                   []     -> []
 198                   (y:ys) -> f x y : stretchZipWith p z f xs ys
 199 \end{code}
 200
 201
 202 \begin{code}
 203 mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
 204
 205 mapAndUnzip f [] = ([],[])
 206 mapAndUnzip f (x:xs)
 207   = let
 208         (r1,  r2)  = f x
 209         (rs1, rs2) = mapAndUnzip f xs
 210     in
 211     (r1:rs1, r2:rs2)
 212
 213 mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
 214
 215 mapAndUnzip3 f [] = ([],[],[])
 216 mapAndUnzip3 f (x:xs)
 217   = let
 218         (r1,  r2,  r3)  = f x
 219         (rs1, rs2, rs3) = mapAndUnzip3 f xs
 220     in
 221     (r1:rs1, r2:rs2, r3:rs3)
 222 \end{code}
 223
 224 \begin{code}
 225 nOfThem :: Int -> a -> [a]
 226 nOfThem n thing = replicate n thing
 227
 228 -- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
 229 -- specification:
 230 --
 231 --  atLength atLenPred atEndPred ls n
 232 --   | n < 0         = atLenPred n
 233 --   | length ls < n = atEndPred (n - length ls)
 234 --   | otherwise     = atLenPred (drop n ls)
 235 --
 236 atLength :: ([a] -> b)
 237          -> (Int -> b)
 238          -> [a]
 239          -> Int
 240          -> b
 241 atLength atLenPred atEndPred ls n
 242   | n < 0     = atEndPred n
 243   | otherwise = go n ls
 244   where
 245     go n [] = atEndPred n
 246     go 0 ls = atLenPred ls
 247     go n (_:xs) = go (n-1) xs
 248
 249 -- special cases.
 250 lengthExceeds :: [a] -> Int -> Bool
 251 -- (lengthExceeds xs n) = (length xs > n)
 252 lengthExceeds = atLength notNull (const False)
 253
 254 lengthAtLeast :: [a] -> Int -> Bool
 255 lengthAtLeast = atLength notNull (== 0)
 256
 257 lengthIs :: [a] -> Int -> Bool
 258 lengthIs = atLength null (==0)
 259
 260 listLengthCmp :: [a] -> Int -> Ordering
 261 listLengthCmp = atLength atLen atEnd
 262  where
 263   atEnd 0      = EQ
 264   atEnd x
 265    | x > 0     = LT -- not yet seen 'n' elts, so list length is < n.
 266    | otherwise = GT
 267
 268   atLen []     = EQ
 269   atLen _      = GT
 270
 271 isSingleton :: [a] -> Bool
 272 isSingleton [x] = True
 273 isSingleton  _  = False
 274
 275 notNull :: [a] -> Bool
 276 notNull [] = False
 277 notNull _  = True
 278
 279 snocView :: [a] -> Maybe ([a],a)
 280         -- Split off the last element
 281 snocView [] = Nothing
 282 snocView xs = go [] xs
 283             where
 284                 -- Invariant: second arg is non-empty
 285               go acc [x]    = Just (reverse acc, x)
 286               go acc (x:xs) = go (x:acc) xs
 287
 288 only :: [a] -> a
 289 #ifdef DEBUG
 290 only [a] = a
 291 #else
 292 only (a:_) = a
 293 #endif
 294 \end{code}
 295
 296 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 297
 298 \begin{code}
 299 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 300
 301 # ifndef DEBUG
 302 isIn    msg x ys = elem__    x ys
 303 isn'tIn msg x ys = notElem__ x ys
 304
 305 --these are here to be SPECIALIZEd (automagically)
 306 elem__ _ []     = False
 307 elem__ x (y:ys) = x==y || elem__ x ys
 308
 309 notElem__ x []     =  True
 310 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 311
 312 # else /* DEBUG */
 313 isIn msg x ys
 314   = elem (_ILIT 0) x ys
 315   where
 316     elem i _ []     = False
 317     elem i x (y:ys)
 318       | i ># _ILIT 100 = trace ("Over-long elem in " ++ msg) $
 319                          x `List.elem` (y:ys)
 320       | otherwise      = x == y || elem (i +# _ILIT(1)) x ys
 321
 322 isn'tIn msg x ys
 323   = notElem (_ILIT 0) x ys
 324   where
 325     notElem i x [] =  True
 326     notElem i x (y:ys)
 327       | i ># _ILIT 100 = trace ("Over-long notElem in " ++ msg) $
 328                          x `List.notElem` (y:ys)
 329       | otherwise      =  x /= y && notElem (i +# _ILIT(1)) x ys
 330 # endif /* DEBUG */
 331 \end{code}
 332
 333 %************************************************************************
 334 %*                                                                      *
 335 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 \begin{display}
 340 Date: Mon, 3 May 93 20:45:23 +0200
 341 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 342 To: partain@dcs.gla.ac.uk
 343 Subject: natural merge sort beats quick sort [ and it is prettier ]
 344
 345 Here is a piece of Haskell code that I'm rather fond of. See it as an
 346 attempt to get rid of the ridiculous quick-sort routine. group is
 347 quite useful by itself I think it was John's idea originally though I
 348 believe the lazy version is due to me [surprisingly complicated].
 349 gamma [used to be called] is called gamma because I got inspired by
 350 the Gamma calculus. It is not very close to the calculus but does
 351 behave less sequentially than both foldr and foldl. One could imagine
 352 a version of gamma that took a unit element as well thereby avoiding
 353 the problem with empty lists.
 354
 355 I've tried this code against
 356
 357    1) insertion sort - as provided by haskell
 358    2) the normal implementation of quick sort
 359    3) a deforested version of quick sort due to Jan Sparud
 360    4) a super-optimized-quick-sort of Lennart's
 361
 362 If the list is partially sorted both merge sort and in particular
 363 natural merge sort wins. If the list is random [ average length of
 364 rising subsequences = approx 2 ] mergesort still wins and natural
 365 merge sort is marginally beaten by Lennart's soqs. The space
 366 consumption of merge sort is a bit worse than Lennart's quick sort
 367 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 368 fpca article ] isn't used because of group.
 369
 370 have fun
 371 Carsten
 372 \end{display}
 373
 374 \begin{code}
 375 group :: (a -> a -> Bool) -> [a] -> [[a]]
 376
 377 {-
 378 Date: Mon, 12 Feb 1996 15:09:41 +0000
 379 From: Andy Gill <andy@dcs.gla.ac.uk>
 380
 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         | not (x `p` x_max) = group' xs x_min x (s . (x :))
 389         | x `p` x_min       = group' xs x x_max ((x :) . s)
 390         | otherwise         = s [] : group' xs x x (x :)
 391
 392 -- This one works forwards *and* backwards, as well as also being
 393 -- faster that the one in Util.lhs.
 394
 395 {- ORIG:
 396 group p [] = [[]]
 397 group p (x:xs) =
 398    let ((h1:t1):tt1) = group p xs
 399        (t,tt) = if null xs then ([],[]) else
 400                 if x `p` h1 then (h1:t1,tt1) else
 401                    ([], (h1:t1):tt1)
 402    in ((x:t):tt)
 403 -}
 404
 405 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 406 generalMerge p xs [] = xs
 407 generalMerge p [] ys = ys
 408 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 409                              | otherwise = y : generalMerge p (x:xs) ys
 410
 411 -- gamma is now called balancedFold
 412
 413 balancedFold :: (a -> a -> a) -> [a] -> a
 414 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 415 balancedFold f [x] = x
 416 balancedFold f l  = balancedFold f (balancedFold' f l)
 417
 418 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 419 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 420 balancedFold' f xs = xs
 421
 422 generalNaturalMergeSort p [] = []
 423 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 424
 425 #if NOT_USED
 426 generalMergeSort p [] = []
 427 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 428
 429 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 430
 431 mergeSort = generalMergeSort (<=)
 432 naturalMergeSort = generalNaturalMergeSort (<=)
 433
 434 mergeSortLe le = generalMergeSort le
 435 #endif
 436
 437 sortLe :: (a->a->Bool) -> [a] -> [a]
 438 sortLe le = generalNaturalMergeSort le
 439 \end{code}
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsection[Utils-transitive-closure]{Transitive closure}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 This algorithm for transitive closure is straightforward, albeit quadratic.
 448
 449 \begin{code}
 450 transitiveClosure :: (a -> [a])         -- Successor function
 451                   -> (a -> a -> Bool)   -- Equality predicate
 452                   -> [a]
 453                   -> [a]                -- The transitive closure
 454
 455 transitiveClosure succ eq xs
 456  = go [] xs
 457  where
 458    go done []                      = done
 459    go done (x:xs) | x `is_in` done = go done xs
 460                   | otherwise      = go (x:done) (succ x ++ xs)
 461
 462    x `is_in` []                 = False
 463    x `is_in` (y:ys) | eq x y    = True
 464                     | otherwise = x `is_in` ys
 465 \end{code}
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection[Utils-accum]{Accumulating}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 @mapAccumL@ behaves like a combination
 474 of  @map@ and @foldl@;
 475 it applies a function to each element of a list, passing an accumulating
 476 parameter from left to right, and returning a final value of this
 477 accumulator together with the new list.
 478
 479 \begin{code}
 480 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 481                                         -- and accumulator, returning new
 482                                         -- accumulator and elt of result list
 483             -> acc              -- Initial accumulator
 484             -> [x]              -- Input list
 485             -> (acc, [y])               -- Final accumulator and result list
 486
 487 mapAccumL f b []     = (b, [])
 488 mapAccumL f b (x:xs) = (b'', x':xs') where
 489                                           (b', x') = f b x
 490                                           (b'', xs') = mapAccumL f b' xs
 491 \end{code}
 492
 493 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 494 the same as @mapAccumL@, though.
 495
 496 \begin{code}
 497 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 498                                         -- and accumulator, returning new
 499                                         -- accumulator and elt of result list
 500             -> acc              -- Initial accumulator
 501             -> [x]              -- Input list
 502             -> (acc, [y])               -- Final accumulator and result list
 503
 504 mapAccumR f b []     = (b, [])
 505 mapAccumR f b (x:xs) = (b'', x':xs') where
 506                                           (b'', x') = f b' x
 507                                           (b', xs') = mapAccumR f b xs
 508 \end{code}
 509
 510 Here is the bi-directional version, that works from both left and right.
 511
 512 \begin{code}
 513 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 514                                 -- Function of elt of input list
 515                                 -- and accumulator, returning new
 516                                 -- accumulator and elt of result list
 517           -> accl                       -- Initial accumulator from left
 518           -> accr                       -- Initial accumulator from right
 519           -> [x]                        -- Input list
 520           -> (accl, accr, [y])  -- Final accumulators and result list
 521
 522 mapAccumB f a b []     = (a,b,[])
 523 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 524    where
 525         (a',b'',y)  = f a b' x
 526         (a'',b',ys) = mapAccumB f a' b xs
 527 \end{code}
 528
 529 A strict version of foldl.
 530
 531 \begin{code}
 532 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 533 foldl' f z xs = lgo z xs
 534              where
 535                 lgo z []     =  z
 536                 lgo z (x:xs) = (lgo $! (f z x)) xs
 537 \end{code}
 538
 539 A combination of foldl with zip.  It works with equal length lists.
 540
 541 \begin{code}
 542 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 543 foldl2 k z [] [] = z
 544 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 545 \end{code}
 546
 547 Count the number of times a predicate is true
 548
 549 \begin{code}
 550 count :: (a -> Bool) -> [a] -> Int
 551 count p [] = 0
 552 count p (x:xs) | p x       = 1 + count p xs
 553                | otherwise = count p xs
 554 \end{code}
 555
 556 @splitAt@, @take@, and @drop@ but with length of another
 557 list giving the break-off point:
 558
 559 \begin{code}
 560 takeList :: [b] -> [a] -> [a]
 561 takeList [] _ = []
 562 takeList (_:xs) ls =
 563    case ls of
 564      [] -> []
 565      (y:ys) -> y : takeList xs ys
 566
 567 dropList :: [b] -> [a] -> [a]
 568 dropList [] xs    = xs
 569 dropList _  xs@[] = xs
 570 dropList (_:xs) (_:ys) = dropList xs ys
 571
 572
 573 splitAtList :: [b] -> [a] -> ([a], [a])
 574 splitAtList [] xs     = ([], xs)
 575 splitAtList _ xs@[]   = (xs, xs)
 576 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 577     where
 578       (ys', ys'') = splitAtList xs ys
 579
 580 \end{code}
 581
 582
 583 %************************************************************************
 584 %*                                                                      *
 585 \subsection[Utils-comparison]{Comparisons}
 586 %*                                                                      *
 587 %************************************************************************
 588
 589 \begin{code}
 590 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 591 eqListBy eq []     []     = True
 592 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 593 eqListBy eq xs     ys     = False
 594
 595 equalLength :: [a] -> [b] -> Bool
 596 equalLength [] []         = True
 597 equalLength (_:xs) (_:ys) = equalLength xs ys
 598 equalLength xs    ys      = False
 599
 600 compareLength :: [a] -> [b] -> Ordering
 601 compareLength [] []         = EQ
 602 compareLength (_:xs) (_:ys) = compareLength xs ys
 603 compareLength [] _ys        = LT
 604 compareLength _xs []        = GT
 605
 606 thenCmp :: Ordering -> Ordering -> Ordering
 607 {-# INLINE thenCmp #-}
 608 thenCmp EQ   any = any
 609 thenCmp other any = other
 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}