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