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