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         sortLt, naturalMergeSortLe,
  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 \subsection[Utils-sorting]{Sorting}
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 %************************************************************************
 340 %*                                                                      *
 341 \subsubsection[Utils-quicksorting]{Quicksorts}
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 \begin{code}
 346 #if NOT_USED
 347
 348 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
 349 quicksort :: (a -> a -> Bool)           -- Less-than predicate
 350           -> [a]                        -- Input list
 351           -> [a]                        -- Result list in increasing order
 352
 353 quicksort lt []      = []
 354 quicksort lt [x]     = [x]
 355 quicksort lt (x:xs)  = split x [] [] xs
 356   where
 357     split x lo hi []                 = quicksort lt lo ++ (x : quicksort lt hi)
 358     split x lo hi (y:ys) | y `lt` x  = split x (y:lo) hi ys
 359                          | True      = split x lo (y:hi) ys
 360 #endif
 361 \end{code}
 362
 363 Quicksort variant from Lennart's Haskell-library contribution.  This
 364 is a {\em stable} sort.
 365
 366 \begin{code}
 367 sortLt :: (a -> a -> Bool)              -- Less-than predicate
 368        -> [a]                           -- Input list
 369        -> [a]                           -- Result list
 370
 371 sortLt lt l = qsort lt   l []
 372
 373 -- qsort is stable and does not concatenate.
 374 qsort :: (a -> a -> Bool)       -- Less-than predicate
 375       -> [a]                    -- xs, Input list
 376       -> [a]                    -- r,  Concatenate this list to the sorted input list
 377       -> [a]                    -- Result = sort xs ++ r
 378
 379 qsort lt []     r = r
 380 qsort lt [x]    r = x:r
 381 qsort lt (x:xs) r = qpart lt x xs [] [] r
 382
 383 -- qpart partitions and sorts the sublists
 384 -- rlt contains things less than x,
 385 -- rge contains the ones greater than or equal to x.
 386 -- Both have equal elements reversed with respect to the original list.
 387
 388 qpart lt x [] rlt rge r =
 389     -- rlt and rge are in reverse order and must be sorted with an
 390     -- anti-stable sorting
 391     rqsort lt rlt (x : rqsort lt rge r)
 392
 393 qpart lt x (y:ys) rlt rge r =
 394     if lt y x then
 395         -- y < x
 396         qpart lt x ys (y:rlt) rge r
 397     else
 398         -- y >= x
 399         qpart lt x ys rlt (y:rge) r
 400
 401 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
 402 rqsort lt []     r = r
 403 rqsort lt [x]    r = x:r
 404 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
 405
 406 rqpart lt x [] rle rgt r =
 407     qsort lt rle (x : qsort lt rgt r)
 408
 409 rqpart lt x (y:ys) rle rgt r =
 410     if lt x y then
 411         -- y > x
 412         rqpart lt x ys rle (y:rgt) r
 413     else
 414         -- y <= x
 415         rqpart lt x ys (y:rle) rgt r
 416 \end{code}
 417
 418 %************************************************************************
 419 %*                                                                      *
 420 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
 421 %*                                                                      *
 422 %************************************************************************
 423
 424 \begin{code}
 425 #if NOT_USED
 426 mergesort :: (a -> a -> Ordering) -> [a] -> [a]
 427
 428 mergesort cmp xs = merge_lists (split_into_runs [] xs)
 429   where
 430     a `le` b = case cmp a b of { LT -> True;  EQ -> True; GT -> False }
 431     a `ge` b = case cmp a b of { LT -> False; EQ -> True; GT -> True  }
 432
 433     split_into_runs []        []                = []
 434     split_into_runs run       []                = [run]
 435     split_into_runs []        (x:xs)            = split_into_runs [x] xs
 436     split_into_runs [r]       (x:xs) | x `ge` r = split_into_runs [r,x] xs
 437     split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
 438                                      | True     = rl : (split_into_runs [x] xs)
 439
 440     merge_lists []       = []
 441     merge_lists (x:xs)   = merge x (merge_lists xs)
 442
 443     merge [] ys = ys
 444     merge xs [] = xs
 445     merge xl@(x:xs) yl@(y:ys)
 446       = case cmp x y of
 447           EQ  -> x : y : (merge xs ys)
 448           LT  -> x : (merge xs yl)
 449           GT -> y : (merge xl ys)
 450 #endif
 451 \end{code}
 452
 453 %************************************************************************
 454 %*                                                                      *
 455 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 456 %*                                                                      *
 457 %************************************************************************
 458
 459 \begin{display}
 460 Date: Mon, 3 May 93 20:45:23 +0200
 461 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 462 To: partain@dcs.gla.ac.uk
 463 Subject: natural merge sort beats quick sort [ and it is prettier ]
 464
 465 Here is a piece of Haskell code that I'm rather fond of. See it as an
 466 attempt to get rid of the ridiculous quick-sort routine. group is
 467 quite useful by itself I think it was John's idea originally though I
 468 believe the lazy version is due to me [surprisingly complicated].
 469 gamma [used to be called] is called gamma because I got inspired by
 470 the Gamma calculus. It is not very close to the calculus but does
 471 behave less sequentially than both foldr and foldl. One could imagine
 472 a version of gamma that took a unit element as well thereby avoiding
 473 the problem with empty lists.
 474
 475 I've tried this code against
 476
 477    1) insertion sort - as provided by haskell
 478    2) the normal implementation of quick sort
 479    3) a deforested version of quick sort due to Jan Sparud
 480    4) a super-optimized-quick-sort of Lennart's
 481
 482 If the list is partially sorted both merge sort and in particular
 483 natural merge sort wins. If the list is random [ average length of
 484 rising subsequences = approx 2 ] mergesort still wins and natural
 485 merge sort is marginally beaten by Lennart's soqs. The space
 486 consumption of merge sort is a bit worse than Lennart's quick sort
 487 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 488 fpca article ] isn't used because of group.
 489
 490 have fun
 491 Carsten
 492 \end{display}
 493
 494 \begin{code}
 495 group :: (a -> a -> Bool) -> [a] -> [[a]]
 496
 497 {-
 498 Date: Mon, 12 Feb 1996 15:09:41 +0000
 499 From: Andy Gill <andy@dcs.gla.ac.uk>
 500
 501 Here is a `better' definition of group.
 502 -}
 503 group p []     = []
 504 group p (x:xs) = group' xs x x (x :)
 505   where
 506     group' []     _     _     s  = [s []]
 507     group' (x:xs) x_min x_max s
 508         | not (x `p` x_max) = group' xs x_min x (s . (x :))
 509         | x `p` x_min       = group' xs x x_max ((x :) . s)
 510         | otherwise         = s [] : group' xs x x (x :)
 511
 512 -- This one works forwards *and* backwards, as well as also being
 513 -- faster that the one in Util.lhs.
 514
 515 {- ORIG:
 516 group p [] = [[]]
 517 group p (x:xs) =
 518    let ((h1:t1):tt1) = group p xs
 519        (t,tt) = if null xs then ([],[]) else
 520                 if x `p` h1 then (h1:t1,tt1) else
 521                    ([], (h1:t1):tt1)
 522    in ((x:t):tt)
 523 -}
 524
 525 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 526 generalMerge p xs [] = xs
 527 generalMerge p [] ys = ys
 528 generalMerge p (x:xs) (y:ys) | x `p` y   = x : generalMerge p xs (y:ys)
 529                              | otherwise = y : generalMerge p (x:xs) ys
 530
 531 -- gamma is now called balancedFold
 532
 533 balancedFold :: (a -> a -> a) -> [a] -> a
 534 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 535 balancedFold f [x] = x
 536 balancedFold f l  = balancedFold f (balancedFold' f l)
 537
 538 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 539 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 540 balancedFold' f xs = xs
 541
 542 generalNaturalMergeSort p [] = []
 543 generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
 544
 545 #if NOT_USED
 546 generalMergeSort p [] = []
 547 generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
 548
 549 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 550
 551 mergeSort = generalMergeSort (<=)
 552 naturalMergeSort = generalNaturalMergeSort (<=)
 553
 554 mergeSortLe le = generalMergeSort le
 555 #endif
 556
 557 naturalMergeSortLe le = generalNaturalMergeSort le
 558 \end{code}
 559
 560 %************************************************************************
 561 %*                                                                      *
 562 \subsection[Utils-transitive-closure]{Transitive closure}
 563 %*                                                                      *
 564 %************************************************************************
 565
 566 This algorithm for transitive closure is straightforward, albeit quadratic.
 567
 568 \begin{code}
 569 transitiveClosure :: (a -> [a])         -- Successor function
 570                   -> (a -> a -> Bool)   -- Equality predicate
 571                   -> [a]
 572                   -> [a]                -- The transitive closure
 573
 574 transitiveClosure succ eq xs
 575  = go [] xs
 576  where
 577    go done []                      = done
 578    go done (x:xs) | x `is_in` done = go done xs
 579                   | otherwise      = go (x:done) (succ x ++ xs)
 580
 581    x `is_in` []                 = False
 582    x `is_in` (y:ys) | eq x y    = True
 583                     | otherwise = x `is_in` ys
 584 \end{code}
 585
 586 %************************************************************************
 587 %*                                                                      *
 588 \subsection[Utils-accum]{Accumulating}
 589 %*                                                                      *
 590 %************************************************************************
 591
 592 @mapAccumL@ behaves like a combination
 593 of  @map@ and @foldl@;
 594 it applies a function to each element of a list, passing an accumulating
 595 parameter from left to right, and returning a final value of this
 596 accumulator together with the new list.
 597
 598 \begin{code}
 599 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 600                                         -- and accumulator, returning new
 601                                         -- accumulator and elt of result list
 602             -> acc              -- Initial accumulator
 603             -> [x]              -- Input list
 604             -> (acc, [y])               -- Final accumulator and result list
 605
 606 mapAccumL f b []     = (b, [])
 607 mapAccumL f b (x:xs) = (b'', x':xs') where
 608                                           (b', x') = f b x
 609                                           (b'', xs') = mapAccumL f b' xs
 610 \end{code}
 611
 612 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 613 the same as @mapAccumL@, though.
 614
 615 \begin{code}
 616 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 617                                         -- and accumulator, returning new
 618                                         -- accumulator and elt of result list
 619             -> acc              -- Initial accumulator
 620             -> [x]              -- Input list
 621             -> (acc, [y])               -- Final accumulator and result list
 622
 623 mapAccumR f b []     = (b, [])
 624 mapAccumR f b (x:xs) = (b'', x':xs') where
 625                                           (b'', x') = f b' x
 626                                           (b', xs') = mapAccumR f b xs
 627 \end{code}
 628
 629 Here is the bi-directional version, that works from both left and right.
 630
 631 \begin{code}
 632 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 633                                 -- Function of elt of input list
 634                                 -- and accumulator, returning new
 635                                 -- accumulator and elt of result list
 636           -> accl                       -- Initial accumulator from left
 637           -> accr                       -- Initial accumulator from right
 638           -> [x]                        -- Input list
 639           -> (accl, accr, [y])  -- Final accumulators and result list
 640
 641 mapAccumB f a b []     = (a,b,[])
 642 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 643    where
 644         (a',b'',y)  = f a b' x
 645         (a'',b',ys) = mapAccumB f a' b xs
 646 \end{code}
 647
 648 A strict version of foldl.
 649
 650 \begin{code}
 651 foldl'        :: (a -> b -> a) -> a -> [b] -> a
 652 foldl' f z xs = lgo z xs
 653              where
 654                 lgo z []     =  z
 655                 lgo z (x:xs) = (lgo $! (f z x)) xs
 656 \end{code}
 657
 658 A combination of foldl with zip.  It works with equal length lists.
 659
 660 \begin{code}
 661 foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc
 662 foldl2 k z [] [] = z
 663 foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs
 664 \end{code}
 665
 666 Count the number of times a predicate is true
 667
 668 \begin{code}
 669 count :: (a -> Bool) -> [a] -> Int
 670 count p [] = 0
 671 count p (x:xs) | p x       = 1 + count p xs
 672                | otherwise = count p xs
 673 \end{code}
 674
 675 @splitAt@, @take@, and @drop@ but with length of another
 676 list giving the break-off point:
 677
 678 \begin{code}
 679 takeList :: [b] -> [a] -> [a]
 680 takeList [] _ = []
 681 takeList (_:xs) ls =
 682    case ls of
 683      [] -> []
 684      (y:ys) -> y : takeList xs ys
 685
 686 dropList :: [b] -> [a] -> [a]
 687 dropList [] xs    = xs
 688 dropList _  xs@[] = xs
 689 dropList (_:xs) (_:ys) = dropList xs ys
 690
 691
 692 splitAtList :: [b] -> [a] -> ([a], [a])
 693 splitAtList [] xs     = ([], xs)
 694 splitAtList _ xs@[]   = (xs, xs)
 695 splitAtList (_:xs) (y:ys) = (y:ys', ys'')
 696     where
 697       (ys', ys'') = splitAtList xs ys
 698
 699 \end{code}
 700
 701
 702 %************************************************************************
 703 %*                                                                      *
 704 \subsection[Utils-comparison]{Comparisons}
 705 %*                                                                      *
 706 %************************************************************************
 707
 708 \begin{code}
 709 eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
 710 eqListBy eq []     []     = True
 711 eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
 712 eqListBy eq xs     ys     = False
 713
 714 equalLength :: [a] -> [b] -> Bool
 715 equalLength [] []         = True
 716 equalLength (_:xs) (_:ys) = equalLength xs ys
 717 equalLength xs    ys      = False
 718
 719 compareLength :: [a] -> [b] -> Ordering
 720 compareLength [] []         = EQ
 721 compareLength (_:xs) (_:ys) = compareLength xs ys
 722 compareLength [] _ys        = LT
 723 compareLength _xs []        = GT
 724
 725 thenCmp :: Ordering -> Ordering -> Ordering
 726 {-# INLINE thenCmp #-}
 727 thenCmp EQ   any = any
 728 thenCmp other any = other
 729
 730 cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
 731     -- `cmpList' uses a user-specified comparer
 732
 733 cmpList cmp []     [] = EQ
 734 cmpList cmp []     _  = LT
 735 cmpList cmp _      [] = GT
 736 cmpList cmp (a:as) (b:bs)
 737   = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
 738 \end{code}
 739
 740 \begin{code}
 741 prefixMatch :: Eq a => [a] -> [a] -> Bool
 742 prefixMatch [] _str = True
 743 prefixMatch _pat [] = False
 744 prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
 745                           | otherwise = False
 746
 747 maybePrefixMatch :: String -> String -> Maybe String
 748 maybePrefixMatch []    rest = Just rest
 749 maybePrefixMatch (_:_) []   = Nothing
 750 maybePrefixMatch (p:pat) (r:rest)
 751   | p == r    = maybePrefixMatch pat rest
 752   | otherwise = Nothing
 753
 754 suffixMatch :: Eq a => [a] -> [a] -> Bool
 755 suffixMatch pat str = prefixMatch (reverse pat) (reverse str)
 756 \end{code}
 757
 758 %************************************************************************
 759 %*                                                                      *
 760 \subsection[Utils-pairs]{Pairs}
 761 %*                                                                      *
 762 %************************************************************************
 763
 764 The following are curried versions of @fst@ and @snd@.
 765
 766 \begin{code}
 767 #if NOT_USED
 768 cfst :: a -> b -> a     -- stranal-sem only (Note)
 769 cfst x y = x
 770 #endif
 771 \end{code}
 772
 773 The following provide us higher order functions that, when applied
 774 to a function, operate on pairs.
 775
 776 \begin{code}
 777 #if NOT_USED
 778 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
 779 applyToPair (f,g) (x,y) = (f x, g y)
 780
 781 applyToFst :: (a -> c) -> (a,b)-> (c,b)
 782 applyToFst f (x,y) = (f x,y)
 783
 784 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
 785 applyToSnd f (x,y) = (x,f y)
 786 #endif
 787 \end{code}
 788
 789 \begin{code}
 790 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 791 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 792 \end{code}
 793
 794 \begin{code}
 795 seqList :: [a] -> b -> b
 796 seqList [] b = b
 797 seqList (x:xs) b = x `seq` seqList xs b
 798 \end{code}
 799
 800 Global variables:
 801
 802 \begin{code}
 803 global :: a -> IORef a
 804 global a = unsafePerformIO (newIORef a)
 805 \end{code}
 806
 807 Module names:
 808
 809 \begin{code}
 810 looksLikeModuleName [] = False
 811 looksLikeModuleName (c:cs) = isUpper c && go cs
 812   where go [] = True
 813         go ('.':cs) = looksLikeModuleName cs
 814         go (c:cs)   = (isAlphaNum c || c == '_') && go cs
 815 \end{code}
 816
 817 Akin to @Prelude.words@, but sensitive to dquoted entities treating
 818 them as single words.
 819
 820 \begin{code}
 821 toArgs :: String -> [String]
 822 toArgs "" = []
 823 toArgs s  =
 824   case break (\ ch -> isSpace ch || ch == '"') (dropWhile isSpace s) of -- "
 825     (w,aft) ->
 826        (\ ws -> if null w then ws else w : ws) $
 827        case aft of
 828          []           -> []
 829          (x:xs)
 830            | x /= '"'  -> toArgs xs
 831            | otherwise ->
 832              case lex aft of
 833                ((str,rs):_) -> stripQuotes str : toArgs rs
 834                _            -> [aft]
 835  where
 836     -- strip away dquotes; assume first and last chars contain quotes.
 837    stripQuotes :: String -> String
 838    stripQuotes ('"':xs)  = init xs
 839    stripQuotes xs        = xs
 840 \end{code}
 841
 842 -- -----------------------------------------------------------------------------
 843 -- Floats
 844
 845 \begin{code}
 846 readRational__ :: ReadS Rational -- NB: doesn't handle leading "-"
 847 readRational__ r = do
 848      (n,d,s) <- readFix r
 849      (k,t)   <- readExp s
 850      return ((n%1)*10^^(k-d), t)
 851  where
 852      readFix r = do
 853         (ds,s)  <- lexDecDigits r
 854         (ds',t) <- lexDotDigits s
 855         return (read (ds++ds'), length ds', t)
 856
 857      readExp (e:s) | e `elem` "eE" = readExp' s
 858      readExp s                     = return (0,s)
 859
 860      readExp' ('+':s) = readDec s
 861      readExp' ('-':s) = do
 862                         (k,t) <- readDec s
 863                         return (-k,t)
 864      readExp' s       = readDec s
 865
 866      readDec s = do
 867         (ds,r) <- nonnull isDigit s
 868         return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ],
 869                 r)
 870
 871      lexDecDigits = nonnull isDigit
 872
 873      lexDotDigits ('.':s) = return (span isDigit s)
 874      lexDotDigits s       = return ("",s)
 875
 876      nonnull p s = do (cs@(_:_),t) <- return (span p s)
 877                       return (cs,t)
 878
 879 readRational :: String -> Rational -- NB: *does* handle a leading "-"
 880 readRational top_s
 881   = case top_s of
 882       '-' : xs -> - (read_me xs)
 883       xs       -> read_me xs
 884   where
 885     read_me s
 886       = case (do { (x,"") <- readRational__ s ; return x }) of
 887           [x] -> x
 888           []  -> error ("readRational: no parse:"        ++ top_s)
 889           _   -> error ("readRational: ambiguous parse:" ++ top_s)
 890 \end{code}