ghc/compiler/utils/Util.lhs

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