ghc/compiler/utils/Util.lhs

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