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