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