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