ghc/compiler/utils/Util.lhs

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