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 -- Given a <= function, group finds maximal contiguous up-runs
 377 -- or down-runs in the input list.
 378 -- It's stable, in the sense that it never re-orders equal elements
 379 --
 380 -- Date: Mon, 12 Feb 1996 15:09:41 +0000
 381 -- From: Andy Gill <andy@dcs.gla.ac.uk>
 382 -- Here is a `better' definition of group.
 383
 384 group p []     = []
 385 group p (x:xs) = group' xs x x (x :)
 386   where
 387     group' []     _     _     s  = [s []]
 388     group' (x:xs) x_min x_max s
 389         |      x_max `p` x  = group' xs x_min x (s . (x :))
 390         | not (x_min `p` x) = group' xs x x_max ((x :) . s)
 391         | otherwise         = s [] : group' xs x x (x :)
 392         -- NB: the 'not' is essential for stablity
 393         --      x `p` x_min would reverse equal elements
 394
 395 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 396 generalMerge p xs [] = xs
 397 generalMerge p [] ys = ys
 398 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 399                              | otherwise = y : generalMerge p (x:xs) ys
 400
 401 -- gamma is now called balancedFold
 402
 403 balancedFold :: (a -> a -> a) -> [a] -> a
 404 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 405 balancedFold f [x] = x
 406 balancedFold f l  = balancedFold f (balancedFold' f l)
 407
 408 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 409 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 410 balancedFold' f xs = xs
 411
 412 generalNaturalMergeSort p [] = []
 413 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 414
 415 #if NOT_USED
 416 generalMergeSort p [] = []
 417 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 418
 419 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 420
 421 mergeSort = generalMergeSort (<=)
 422 naturalMergeSort = generalNaturalMergeSort (<=)
 423
 424 mergeSortLe le = generalMergeSort le
 425 #endif
 426
 427 sortLe :: (a->a->Bool) -> [a] -> [a]
 428 sortLe le = generalNaturalMergeSort le
 429 \end{code}
 430
 431 %************************************************************************
 432 %*                                                                      *
 433 \subsection[Utils-transitive-closure]{Transitive closure}
 434 %*                                                                      *
 435 %************************************************************************
 436
 437 This algorithm for transitive closure is straightforward, albeit quadratic.
 438
 439 \begin{code}
 440 transitiveClosure :: (a -> [a])         -- Successor function
 441                   -> (a -> a -> Bool)   -- Equality predicate
 442                   -> [a]
 443                   -> [a]                -- The transitive closure
 444
 445 transitiveClosure succ eq xs
 446  = go [] xs
 447  where
 448    go done []                      = done
 449    go done (x:xs) | x `is_in` done = go done xs
 450                   | otherwise      = go (x:done) (succ x ++ xs)
 451
 452    x `is_in` []                 = False
 453    x `is_in` (y:ys) | eq x y    = True
 454                     | otherwise = x `is_in` ys
 455 \end{code}
 456
 457 %************************************************************************
 458 %*                                                                      *
 459 \subsection[Utils-accum]{Accumulating}
 460 %*                                                                      *
 461 %************************************************************************
 462
 463 @mapAccumL@ behaves like a combination
 464 of  @map@ and @foldl@;
 465 it applies a function to each element of a list, passing an accumulating
 466 parameter from left to right, and returning a final value of this
 467 accumulator together with the new list.
 468
 469 \begin{code}
 470 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 471                                         -- and accumulator, returning new
 472                                         -- accumulator and elt of result list
 473             -> acc              -- Initial accumulator
 474             -> [x]              -- Input list
 475             -> (acc, [y])               -- Final accumulator and result list
 476
 477 mapAccumL f b []     = (b, [])
 478 mapAccumL f b (x:xs) = (b'', x':xs') where
 479                                           (b', x') = f b x
 480                                           (b'', xs') = mapAccumL f b' xs
 481 \end{code}
 482
 483 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 484 the same as @mapAccumL@, though.
 485
 486 \begin{code}
 487 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 488                                         -- and accumulator, returning new
 489                                         -- accumulator and elt of result list
 490             -> acc              -- Initial accumulator
 491             -> [x]              -- Input list
 492             -> (acc, [y])               -- Final accumulator and result list
 493
 494 mapAccumR f b []     = (b, [])
 495 mapAccumR f b (x:xs) = (b'', x':xs') where
 496                                           (b'', x') = f b' x
 497                                           (b', xs') = mapAccumR f b xs
 498 \end{code}
 499
 500 Here is the bi-directional version, that works from both left and right.
 501
 502 \begin{code}
 503 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 504                                 -- Function of elt of input list
 505                                 -- and accumulator, returning new
 506                                 -- accumulator and elt of result list
 507           -> accl                       -- Initial accumulator from left
 508           -> accr                       -- Initial accumulator from right
 509           -> [x]                        -- Input list
 510           -> (accl, accr, [y])  -- Final accumulators and result list
 511
 512 mapAccumB f a b []     = (a,b,[])
 513 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 514    where
 515         (a',b'',y)  = f a b' x
 516         (a'',b',ys) = mapAccumB f a' b xs
 517 \end{code}
 518
 519 A strict version of foldl.
 520
 521 \begin{code}
 522 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 523 foldl' f z xs = lgo z xs
 524              where
 525                 lgo z []     =  z
 526                 lgo z (x:xs) = (lgo $! (f z x)) xs
 527 \end{code}
 528
 529 A combination of foldl with zip.  It works with equal length lists.
 530
 531 \begin{code}
 532 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 533 foldl2 k z [] [] = z
 534 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 535 \end{code}
 536
 537 Count the number of times a predicate is true
 538
 539 \begin{code}
 540 count :: (a -> Bool) -> [a] -> Int
 541 count p [] = 0
 542 count p (x:xs) | p x       = 1 + count p xs
 543                | otherwise = count p xs
 544 \end{code}
 545
 546 @splitAt@, @take@, and @drop@ but with length of another
 547 list giving the break-off point:
 548
 549 \begin{code}
 550 takeList :: [b] -> [a] -> [a]
 551 takeList [] _ = []
 552 takeList (_:xs) ls =
 553    case ls of
 554      [] -> []
 555      (y:ys) -> y : takeList xs ys
 556
 557 dropList :: [b] -> [a] -> [a]
 558 dropList [] xs    = xs
 559 dropList _  xs@[] = xs
 560 dropList (_:xs) (_:ys) = dropList xs ys
 561
 562
 563 splitAtList :: [b] -> [a] -> ([a], [a])
 564 splitAtList [] xs     = ([], xs)
 565 splitAtList _ xs@[]   = (xs, xs)
 566 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 567     where
 568       (ys', ys'') = splitAtList xs ys
 569
 570 \end{code}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection[Utils-comparison]{Comparisons}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 \begin{code}
 580 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 581 eqListBy eq []     []     = True
 582 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 583 eqListBy eq xs     ys     = False
 584
 585 equalLength :: [a] -> [b] -> Bool
 586 equalLength [] []         = True
 587 equalLength (_:xs) (_:ys) = equalLength xs ys
 588 equalLength xs    ys      = False
 589
 590 compareLength :: [a] -> [b] -> Ordering
 591 compareLength [] []         = EQ
 592 compareLength (_:xs) (_:ys) = compareLength xs ys
 593 compareLength [] _ys        = LT
 594 compareLength _xs []        = GT
 595
 596 thenCmp :: Ordering -> Ordering -> Ordering
 597 {-# INLINE thenCmp #-}
 598 thenCmp EQ   any = any
 599 thenCmp other any = other
 600
 601 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 602     -- `cmpList' uses a user-specified comparer
 603
 604 cmpList cmp []     [] = EQ
 605 cmpList cmp []     _  = LT
 606 cmpList cmp _      [] = GT
 607 cmpList cmp (a:as) (b:bs)
 608   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 609 \end{code}
 610
 611 \begin{code}
 612 prefixMatch :: Eq a => [a] -> [a] -> Bool
 613 prefixMatch [] _str = True
 614 prefixMatch _pat [] = False
 615 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 616                           | otherwise = False
 617
 618 maybePrefixMatch :: String -> String -> Maybe String
 619 maybePrefixMatch []    rest = Just rest
 620 maybePrefixMatch (_:_) []   = Nothing
 621 maybePrefixMatch (p:pat) (r:rest)
 622   | p == r    = maybePrefixMatch pat rest
 623   | otherwise = Nothing
 624
 625 suffixMatch :: Eq a => [a] -> [a] -> Bool
 626 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 627 \end{code}
 628
 629 %************************************************************************
 630 %*                                                                      *
 631 \subsection[Utils-pairs]{Pairs}
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 The following are curried versions of @fst@ and @snd@.
 636
 637 \begin{code}
 638 #if NOT_USED
 639 cfst :: a -> b -> a     -- stranal-sem only (Note)
 640 cfst x y = x
 641 #endif
 642 \end{code}
 643
 644 The following provide us higher order functions that, when applied
 645 to a function, operate on pairs.
 646
 647 \begin{code}
 648 #if NOT_USED
 649 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 650 applyToPair (f,g) (x,y) = (f x, g y)
 651
 652 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 653 applyToFst f (x,y) = (f x,y)
 654
 655 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 656 applyToSnd f (x,y) = (x,f y)
 657 #endif
 658 \end{code}
 659
 660 \begin{code}
 661 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 662 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 663 \end{code}
 664
 665 \begin{code}
 666 seqList :: [a] -> b -> b
 667 seqList [] b = b
 668 seqList (x:xs) b = x `seq` seqList xs b
 669 \end{code}
 670
 671 Global variables:
 672
 673 \begin{code}
 674 global :: a -> IORef a
 675 global a = unsafePerformIO (newIORef a)
 676 \end{code}
 677
 678 Module names:
 679
 680 \begin{code}
 681 looksLikeModuleName [] = False
 682 looksLikeModuleName (c:cs) = isUpper c && go cs
 683   where go [] = True
 684         go ('.':cs) = looksLikeModuleName cs
 685         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 686 \end{code}
 687
 688 Akin to @Prelude.words@, but sensitive to dquoted entities treating
 689 them as single words.
 690
 691 \begin{code}
 692 toArgs :: String -> [String]
 693 toArgs "" = []
 694 toArgs s  =
 695   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 696     (w,aft) ->
 697        (\ ws -> if null w then ws else w : ws) $
 698        case aft of
 699          []           -> []
 700          (x:xs)
 701            | x /= '"'  -> toArgs xs
 702            | otherwise ->
 703              case lex aft of
 704                ((str,rs):_) -> stripQuotes str : toArgs rs
 705                _            -> [aft]
 706  where
 707     -- strip away dquotes; assume first and last chars contain quotes.
 708    stripQuotes :: String -> String
 709    stripQuotes ('"':xs)  = init xs
 710    stripQuotes xs        = xs
 711 \end{code}
 712
 713 -- -----------------------------------------------------------------------------
 714 -- Floats
 715
 716 \begin{code}
 717 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 718 readRational__ r = do
 719      (n,d,s) <- readFix r
 720      (k,t)   <- readExp s
 721      return ((n%1)*10^^(k-d), t)
 722  where
 723      readFix r = do
 724         (ds,s)  <- lexDecDigits r
 725         (ds',t) <- lexDotDigits s
 726         return (read (ds++ds'), length ds', t)
 727
 728      readExp (e:s) | e `elem` "eE" = readExp' s
 729      readExp s                     = return (0,s)
 730
 731      readExp' ('+':s) = readDec s
 732      readExp' ('-':s) = do
 733                         (k,t) <- readDec s
 734                         return (-k,t)
 735      readExp' s       = readDec s
 736
 737      readDec s = do
 738         (ds,r) <- nonnull isDigit s
 739         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 740                 r)
 741
 742      lexDecDigits = nonnull isDigit
 743
 744      lexDotDigits ('.':s) = return (span isDigit s)
 745      lexDotDigits s       = return ("",s)
 746
 747      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 748                       return (cs,t)
 749
 750 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 751 readRational top_s
 752   = case top_s of
 753       '-' : xs -> - (read_me xs)
 754       xs       -> read_me xs
 755   where
 756     read_me s
 757       = case (do { (x,"") <- readRational__ s ; return x }) of
 758           [x] -> x
 759           []  -> error ("readRational: no parse:"        ++ top_s)
 760           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 761 \end{code}