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