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