ghc/compiler/utils/Util.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   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_ _CMP_TAG
  13 # define LT_ _LT
  14 # define EQ_ _EQ
  15 # define GT_ _GT
  16 # define GT__ _
  17 # define tagCmp_ _tagCmp
  18 # define FAST_STRING String
  19 # define ASSERT(x) {-nothing-}
  20 # define IF_NOT_GHC(a) a
  21 # define COMMA ,
  22 #endif
  23
  24 #ifndef __GLASGOW_HASKELL__
  25 # undef TAG_
  26 # undef LT_
  27 # undef EQ_
  28 # undef GT_
  29 # undef tagCmp_
  30 #endif
  31
  32 module Util (
  33         -- Haskell-version support
  34 #ifndef __GLASGOW_HASKELL__
  35         tagCmp_,
  36         TAG_(..),
  37 #endif
  38         -- general list processing
  39         IF_NOT_GHC(forall COMMA exists COMMA)
  40         zipEqual, nOfThem, lengthExceeds, isSingleton,
  41 #if defined(COMPILING_GHC)
  42         isIn, isn'tIn,
  43 #endif
  44
  45         -- association lists
  46         assoc,
  47 #ifdef USE_SEMANTIQUE_STRANAL
  48         clookup, clookrepl, elemIndex, (\\\),
  49 #endif
  50
  51         -- duplicate handling
  52         hasNoDups, equivClasses, runs, removeDups,
  53
  54         -- sorting
  55         IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
  56         sortLt,
  57         IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
  58         IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
  59
  60         -- transitive closures
  61         transitiveClosure,
  62
  63         -- accumulating
  64         mapAccumL, mapAccumR, mapAccumB,
  65
  66         -- comparisons
  67         IF_NOT_GHC(cmpString COMMA)
  68 #ifdef USE_FAST_STRINGS
  69         cmpPString,
  70 #else
  71         substr,
  72 #endif
  73         -- pairs
  74         IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
  75         IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
  76         unzipWith
  77
  78         -- error handling
  79 #if defined(COMPILING_GHC)
  80         , panic, pprPanic, pprTrace
  81 # ifdef DEBUG
  82         , assertPanic
  83 # endif
  84 #endif {- COMPILING_GHC -}
  85
  86         -- and to make the interface self-sufficient...
  87 #if __HASKELL1__ < 3
  88 # if defined(COMPILING_GHC)
  89         , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..)
  90 # else
  91         , Maybe
  92 # endif
  93 #endif
  94
  95 #ifdef USE_ATTACK_PRAGMAS
  96         -- as more-or-less of a *HACK*, Util exports
  97         -- many types abstractly, so that pragmas will be
  98         -- able to see them (given that most modules
  99         -- import Util).
 100         ,
 101         AbstractC,
 102         ArgUsage,
 103         ArgUsageInfo,
 104         ArithSeqInfo,
 105         ArityInfo,
 106         Bag,
 107         BasicLit,
 108         Bind,
 109         BinderInfo,
 110         Binds,
 111         CAddrMode,
 112         CExprMacro,
 113         CLabel,
 114         CSeq,
 115         CStmtMacro,
 116         CcKind,
 117         Class,
 118         ClassDecl,
 119         ClassOp,
 120         ClassOpPragmas,
 121         ClassPragmas,
 122         ClosureInfo,
 123         ConDecl,
 124         CoreArg,
 125         CoreAtom,
 126         CoreBinding,
 127         CoreCaseAlternatives,
 128         CoreCaseDefault,
 129         CoreExpr,
 130         CostCentre,
 131         DataPragmas,
 132         DataTypeSig,
 133         DefaultDecl,
 134         DeforestInfo,
 135         Delay,
 136         Demand,
 137         DemandInfo,
 138         DuplicationDanger,
 139         EnclosingCcDetails,
 140         EndOfBlockInfo,
 141         ExportFlag,
 142         Expr,
 143         FBConsum,
 144         FBProd,
 145         FBType,
 146         FBTypeInfo,
 147         FiniteMap,
 148         FixityDecl,
 149         FormSummary,
 150         FullName,
 151         FunOrArg,
 152         GRHS,
 153         GRHSsAndBinds,
 154         GenPragmas,
 155         GlobalSwitch,
 156         HeapOffset,
 157         IE,
 158         Id,
 159         IdDetails,
 160         IdEnv(..), -- UGH
 161         IdInfo,
 162         IdVal,
 163         IfaceImportDecl,
 164         ImpStrictness,
 165         ImpUnfolding,
 166         ImportedInterface,
 167         InPat,
 168         InsideSCC,
 169         Inst,
 170         InstDecl,
 171         InstOrigin,
 172         InstTemplate,
 173         InstTy,
 174         InstancePragmas,
 175         Interface,
 176         IsDupdCC, IsCafCC,
 177         LambdaFormInfo,
 178         Literal,
 179         MagicId,
 180         MagicUnfoldingFun,
 181         Match,
 182         Module,
 183         MonoBinds,
 184         MonoType,
 185         Name,
 186         NamedThing(..), -- SIGH
 187         OptIdInfo(..), -- SIGH
 188         OrdList,
 189         Outputable(..), -- SIGH
 190         OverloadedLit,
 191         PolyType,
 192         PprStyle,
 193         PrimKind,
 194         PrimOp,
 195         ProtoName,
 196         Provenance,
 197         Qual,
 198         RegRelative,
 199         Renaming,
 200         ReturnInfo,
 201         SMRep,
 202         SMSpecRepKind,
 203         SMUpdateKind,
 204         Sequel,
 205         ShortName,
 206         Sig,
 207         SimplCount,
 208         SimplEnv,
 209         SimplifierSwitch,
 210         SpecEnv,
 211         SpecInfo,
 212         SpecialisedInstanceSig,
 213         SplitUniqSupply,
 214         SrcLoc,
 215         StableLoc,
 216         StandardFormInfo,
 217         StgAtom,
 218         StgBinderInfo,
 219         StgBinding,
 220         StgCaseAlternatives,
 221         StgCaseDefault,
 222         StgExpr,
 223         StgRhs,
 224         StrictnessInfo,
 225         StubFlag,
 226         SwitchResult,
 227         TickType,
 228         TyCon,
 229         TyDecl,
 230         TyVar,
 231         TyVarEnv(..),
 232         TyVarTemplate,
 233         TypePragmas,
 234         TypecheckedPat,
 235         UfCostCentre,
 236         UfId,
 237         UnfoldEnv,
 238         UnfoldItem,
 239         UnfoldConApp,
 240         UnfoldingCoreAlts,
 241         UnfoldingCoreAtom,
 242         UnfoldingCoreBinding,
 243         UnfoldingCoreDefault,
 244         UnfoldingCoreExpr,
 245         UnfoldingDetails,
 246         UnfoldingGuidance,
 247         UnfoldingPrimOp,
 248         UniType,
 249         UniqFM,
 250         Unique,
 251         UniqueSupply,
 252         UpdateFlag,
 253         UpdateInfo,
 254         VolatileLoc,
 255
 256 #if ! OMIT_NATIVE_CODEGEN
 257         Reg,
 258         CodeSegment,
 259         RegLoc,
 260         StixReg,
 261         StixTree,
 262 #endif
 263
 264         getIdUniType, typeOfBasicLit, typeOfPat,
 265         getIdKind, kindOfBasicLit,
 266         kindFromType,
 267
 268         eqId, cmpId,
 269         eqName, cmpName,
 270         cmpProtoName, eqProtoName,
 271         cmpByLocalName, eqByLocalName,
 272         eqUnique, cmpUnique,
 273         showUnique,
 274
 275         switchIsOn,
 276
 277         ppNil, ppStr, ppInt, ppInteger, ppDouble,
 278 #if __GLASGOW_HASKELL__ >= 23
 279         ppRational, --- ???
 280 #endif
 281         cNil, cStr, cAppend, cCh, cShow,
 282 #if __GLASGOW_HASKELL__ >= 23
 283         cPStr,
 284 #endif
 285
 286 --      mkBlackHoleCLabel,
 287
 288         emptyBag, snocBag,
 289         emptyFM,
 290 --OLD:  emptySet,
 291         nullSpecEnv,
 292
 293         mkUnknownSrcLoc,
 294
 295         pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType,
 296
 297         tagOf_PrimOp,
 298         pprPrimOp
 299
 300 #endif {-USE_ATTACK_PRAGMAS-}
 301     ) where
 302
 303 #if defined(COMPILING_GHC)
 304 IMPORT_Trace
 305 import Pretty
 306 #endif
 307 #if __HASKELL1__ < 3
 308 import Maybes           ( Maybe(..) )
 309 #endif
 310
 311 #if defined(COMPILING_GHC)
 312 import Id
 313 import IdInfo
 314 import Outputable
 315
 316 # ifdef USE_ATTACK_PRAGMAS
 317
 318 import AbsCSyn
 319 import AbsSyn
 320 import AbsUniType
 321 import Bag
 322 import BasicLit
 323 import BinderInfo
 324 import CLabelInfo
 325 import CgBindery
 326 import CgMonad
 327 import CharSeq
 328 import ClosureInfo
 329 import CmdLineOpts
 330 import CoreSyn
 331 import FiniteMap
 332 import HsCore
 333 import HsPragmas
 334 import Inst
 335 import InstEnv
 336 import Name
 337 import NameTypes
 338 import OrdList
 339 import PlainCore
 340 import PrimOps
 341 import ProtoName
 342 import CostCentre
 343 import SMRep
 344 import SimplEnv
 345 import SimplMonad
 346 import SplitUniq
 347 import SrcLoc
 348 import StgSyn
 349 import TyVarEnv
 350 import UniqFM
 351 import Unique
 352
 353 #  if ! OMIT_NATIVE_CODEGEN
 354 import AsmRegAlloc      ( Reg )
 355 import MachDesc
 356 import Stix
 357 #  endif
 358
 359 # endif {-USE_ATTACK_PRAGMAS-}
 360
 361 #endif
 362 \end{code}
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 This is our own idea:
 371 \begin{code}
 372 #ifndef __GLASGOW_HASKELL__
 373 data TAG_ = LT_ | EQ_ | GT_
 374
 375 tagCmp_ :: Ord a => a -> a -> TAG_
 376 tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_
 377 #endif
 378 \end{code}
 379
 380 %************************************************************************
 381 %*                                                                      *
 382 \subsection[Utils-lists]{General list processing}
 383 %*                                                                      *
 384 %************************************************************************
 385
 386 Quantifiers are not standard in Haskell. The following fill in the gap.
 387
 388 \begin{code}
 389 forall :: (a -> Bool) -> [a] -> Bool
 390 forall pred []     = True
 391 forall pred (x:xs) = pred x && forall pred xs
 392
 393 exists :: (a -> Bool) -> [a] -> Bool
 394 exists pred []     = False
 395 exists pred (x:xs) = pred x || exists pred xs
 396 \end{code}
 397
 398 A paranoid @zip@ that checks the lists are of equal length.
 399 Alastair Reid thinks this should only happen if DEBUGging on;
 400 hey, why not?
 401
 402 \begin{code}
 403 zipEqual :: [a] -> [b] -> [(a,b)]
 404
 405 #ifndef DEBUG
 406 zipEqual a b = zip a b
 407 #else
 408 zipEqual []     []     = []
 409 zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
 410 zipEqual as     bs     = panic "zipEqual: unequal lists"
 411 #endif
 412 \end{code}
 413
 414 \begin{code}
 415 nOfThem :: Int -> a -> [a]
 416 nOfThem n thing = take n (repeat thing)
 417
 418 lengthExceeds :: [a] -> Int -> Bool
 419
 420 []      `lengthExceeds` n =  0 > n
 421 (x:xs)  `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
 422
 423 isSingleton :: [a] -> Bool
 424
 425 isSingleton [x] = True
 426 isSingleton  _  = False
 427 \end{code}
 428
 429 Debugging/specialising versions of \tr{elem} and \tr{notElem}
 430 \begin{code}
 431 #if defined(COMPILING_GHC)
 432 isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
 433
 434 # ifndef DEBUG
 435 isIn    msg x ys = elem__    x ys
 436 isn'tIn msg x ys = notElem__ x ys
 437
 438 --these are here to be SPECIALIZEd (automagically)
 439 elem__ _ []     = False
 440 elem__ x (y:ys) = x==y || elem__ x ys
 441
 442 notElem__ x []     =  True
 443 notElem__ x (y:ys) =  x /= y && notElem__ x ys
 444
 445 # else {- DEBUG -}
 446 isIn msg x ys
 447   = elem ILIT(0) x ys
 448   where
 449     elem i _ []     = False
 450     elem i x (y:ys)
 451       | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
 452       | otherwise        = x == y || elem (i _ADD_ ILIT(1)) x ys
 453
 454 isn'tIn msg x ys
 455   = notElem ILIT(0) x ys
 456   where
 457     notElem i x [] =  True
 458     notElem i x (y:ys)
 459       | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
 460       | otherwise        =  x /= y && notElem (i _ADD_ ILIT(1)) x ys
 461
 462 # endif {- DEBUG -}
 463
 464 # ifdef USE_ATTACK_PRAGMAS
 465 {-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-}
 466 {-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
 467 {-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
 468 {-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
 469 {-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-}
 470 {-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-}
 471 {-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-}
 472 {-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-}
 473 {-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
 474 {-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-}
 475 {-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-}
 476 {-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-}
 477 {-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-}
 478 {-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-}
 479 {-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-}
 480 {-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-}
 481 {-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-}
 482 {-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
 483 # endif
 484
 485 #endif {- COMPILING_GHC -}
 486 \end{code}
 487
 488 %************************************************************************
 489 %*                                                                      *
 490 \subsection[Utils-assoc]{Association lists}
 491 %*                                                                      *
 492 %************************************************************************
 493
 494 See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
 495
 496 \begin{code}
 497 assoc :: (Eq a) => String -> [(a, b)] -> a -> b
 498
 499 assoc crash_msg lst key
 500   = if (null res)
 501     then panic ("Failed in assoc: " ++ crash_msg)
 502     else head res
 503   where res = [ val | (key', val) <- lst, key == key']
 504
 505 #if defined(COMPILING_GHC)
 506 # ifdef USE_ATTACK_PRAGMAS
 507 {-# SPECIALIZE assoc :: String -> [(Id,            a)] -> Id            -> a #-}
 508 {-# SPECIALIZE assoc :: String -> [(Class,         a)] -> Class         -> a #-}
 509 {-# SPECIALIZE assoc :: String -> [(Name,          a)] -> Name          -> a #-}
 510 {-# SPECIALIZE assoc :: String -> [(PrimKind,      a)] -> PrimKind      -> a #-}
 511 {-# SPECIALIZE assoc :: String -> [(String,        a)] -> String        -> a #-}
 512 {-# SPECIALIZE assoc :: String -> [(TyCon,         a)] -> TyCon         -> a #-}
 513 {-# SPECIALIZE assoc :: String -> [(TyVar,         a)] -> TyVar         -> a #-}
 514 {-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
 515 {-# SPECIALIZE assoc :: String -> [(UniType,       a)] -> UniType       -> a #-}
 516 {-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
 517 # endif
 518 #endif
 519 \end{code}
 520
 521 Given a list of associations one wants to look for the most recent
 522 association for a given key. A couple of functions follow that cover
 523 the simple lookup, the lookup with a default value when the key not
 524 found, and two corresponding functions operating on unzipped lists
 525 of associations.
 526
 527 \begin{code}
 528 #ifdef USE_SEMANTIQUE_STRANAL
 529
 530 clookup :: (Eq a) => [a] -> [b] -> a -> b
 531 clookup = clookupElse (panic "clookup")
 532   where
 533    -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b
 534    clookupElse d [] [] a = d
 535    clookupElse d (x:xs) (y:ys) a
 536                 | a==x = y
 537                 | True = clookupElse d xs ys a
 538 #endif
 539 \end{code}
 540
 541 The following routine given a curried environment replaces the entry
 542 labelled with a given name with a new value given. The new value is
 543 given in the form of a function that allows to transform the old entry.
 544
 545 Assumption is that the list of labels contains the given one and that
 546 the two lists of the curried environment are of equal lengths.
 547
 548 \begin{code}
 549 #ifdef USE_SEMANTIQUE_STRANAL
 550 clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b]
 551 clookrepl (a:as) (b:bs) x f
 552    = if x == a then  (f b:bs)  else  (b:clookrepl as bs x f)
 553 #endif
 554 \end{code}
 555
 556 The following returns the index of an element in a list.
 557
 558 \begin{code}
 559 #ifdef USE_SEMANTIQUE_STRANAL
 560
 561 elemIndex :: Eq a => [a] -> a -> Int
 562 elemIndex as x = indx as x 0
 563    where
 564      indx :: Eq a => [a] -> a -> Int -> Int
 565      indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int)
 566 # if defined(COMPILING_GHC)
 567      indx [] x n     = pprPanic "element not in list in elemIndex" ppNil
 568 # else
 569      indx [] x n     = error "element not in list in elemIndex"
 570 # endif
 571 #endif
 572 \end{code}
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection[Utils-dups]{Duplicate-handling}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 List difference (non-associative). In the result of @xs \\\ ys@, the
 581 first occurrence of each element of ys in turn (if any) has been
 582 removed from xs.  Thus, @(xs ++ ys) \\\ xs == ys@.  This function is
 583 a copy of @\\@ from report 1.1 and is added to overshade the buggy
 584 version from the 1.0 version of Haskell.
 585
 586 This routine can be removed after the compiler bootstraps itself and
 587 a proper @\\@ is can be applied.
 588
 589 \begin{code}
 590 #ifdef USE_SEMANTIQUE_STRANAL
 591 (\\\) :: (Eq a) => [a] -> [a] -> [a]
 592 (\\\) =  foldl del
 593    where
 594     []     `del` _ = []
 595     (x:xs) `del` y
 596         | x == y    = xs
 597         | otherwise = x : xs `del` y
 598 #endif
 599 \end{code}
 600
 601 \begin{code}
 602 hasNoDups :: (Eq a) => [a] -> Bool
 603 hasNoDups xs = f [] xs
 604   where
 605     f seen_so_far []     = True
 606     f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
 607                                 False
 608                            else
 609                                 f (x:seen_so_far) xs
 610
 611 #if defined(COMPILING_GHC)
 612     is_elem = isIn "hasNoDups"
 613 #else
 614     is_elem = elem
 615 #endif
 616 #if defined(COMPILING_GHC)
 617 # ifdef USE_ATTACK_PRAGMAS
 618 {-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-}
 619 # endif
 620 #endif
 621 \end{code}
 622
 623 \begin{code}
 624 equivClasses :: (a -> a -> TAG_)        -- Comparison
 625              -> [a]
 626              -> [[a]]
 627
 628 equivClasses cmp stuff@[]     = []
 629 equivClasses cmp stuff@[item] = [stuff]
 630 equivClasses cmp items
 631   = runs eq (sortLt lt items)
 632   where
 633     eq a b = case cmp a b of { EQ_ -> True; _ -> False }
 634     lt a b = case cmp a b of { LT_ -> True; _ -> False }
 635 \end{code}
 636
 637 The first cases in @equivClasses@ above are just to cut to the point
 638 more quickly...
 639
 640 @runs@ groups a list into a list of lists, each sublist being a run of
 641 identical elements of the input list. It is passed a predicate @p@ which
 642 tells when two elements are equal.
 643
 644 \begin{code}
 645 runs :: (a -> a -> Bool)        -- Equality
 646      -> [a]
 647      -> [[a]]
 648
 649 runs p []     = []
 650 runs p (x:xs) = case (span (p x) xs) of
 651                   (first, rest) -> (x:first) : (runs p rest)
 652 \end{code}
 653
 654 \begin{code}
 655 removeDups :: (a -> a -> TAG_)  -- Comparison function
 656            -> [a]
 657            -> ([a],     -- List with no duplicates
 658                [[a]])   -- List of duplicate groups.  One representative from
 659                         -- each group appears in the first result
 660
 661 removeDups cmp []  = ([], [])
 662 removeDups cmp [x] = ([x],[])
 663 removeDups cmp xs
 664   = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
 665     (xs', dups) }
 666   where
 667     collect_dups dups_so_far [x]         = (dups_so_far,      x)
 668     collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
 669 \end{code}
 670
 671 %************************************************************************
 672 %*                                                                      *
 673 \subsection[Utils-sorting]{Sorting}
 674 %*                                                                      *
 675 %************************************************************************
 676
 677 %************************************************************************
 678 %*                                                                      *
 679 \subsubsection[Utils-quicksorting]{Quicksorts}
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 \begin{code}
 684 -- tail-recursive, etc., "quicker sort" [as per Meira thesis]
 685 quicksort :: (a -> a -> Bool)           -- Less-than predicate
 686           -> [a]                        -- Input list
 687           -> [a]                        -- Result list in increasing order
 688
 689 quicksort lt []      = []
 690 quicksort lt [x]     = [x]
 691 quicksort lt (x:xs)  = split x [] [] xs
 692   where
 693     split x lo hi []                 = quicksort lt lo ++ (x : quicksort lt hi)
 694     split x lo hi (y:ys) | y `lt` x  = split x (y:lo) hi ys
 695                          | True      = split x lo (y:hi) ys
 696 \end{code}
 697
 698 Quicksort variant from Lennart's Haskell-library contribution.  This
 699 is a {\em stable} sort.
 700
 701 \begin{code}
 702 stableSortLt = sortLt   -- synonym; when we want to highlight stable-ness
 703
 704 sortLt :: (a -> a -> Bool)              -- Less-than predicate
 705        -> [a]                           -- Input list
 706        -> [a]                           -- Result list
 707
 708 sortLt lt l = qsort lt   l []
 709
 710 -- qsort is stable and does not concatenate.
 711 qsort :: (a -> a -> Bool)       -- Less-than predicate
 712       -> [a]                    -- xs, Input list
 713       -> [a]                    -- r,  Concatenate this list to the sorted input list
 714       -> [a]                    -- Result = sort xs ++ r
 715
 716 qsort lt []     r = r
 717 qsort lt [x]    r = x:r
 718 qsort lt (x:xs) r = qpart lt x xs [] [] r
 719
 720 -- qpart partitions and sorts the sublists
 721 -- rlt contains things less than x,
 722 -- rge contains the ones greater than or equal to x.
 723 -- Both have equal elements reversed with respect to the original list.
 724
 725 qpart lt x [] rlt rge r =
 726     -- rlt and rge are in reverse order and must be sorted with an
 727     -- anti-stable sorting
 728     rqsort lt rlt (x : rqsort lt rge r)
 729
 730 qpart lt x (y:ys) rlt rge r =
 731     if lt y x then
 732         -- y < x
 733         qpart lt x ys (y:rlt) rge r
 734     else
 735         -- y >= x
 736         qpart lt x ys rlt (y:rge) r
 737
 738 -- rqsort is as qsort but anti-stable, i.e. reverses equal elements
 739 rqsort lt []     r = r
 740 rqsort lt [x]    r = x:r
 741 rqsort lt (x:xs) r = rqpart lt x xs [] [] r
 742
 743 rqpart lt x [] rle rgt r =
 744     qsort lt rle (x : qsort lt rgt r)
 745
 746 rqpart lt x (y:ys) rle rgt r =
 747     if lt x y then
 748         -- y > x
 749         rqpart lt x ys rle (y:rgt) r
 750     else
 751         -- y <= x
 752         rqpart lt x ys (y:rle) rgt r
 753 \end{code}
 754
 755 %************************************************************************
 756 %*                                                                      *
 757 \subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
 758 %*                                                                      *
 759 %************************************************************************
 760
 761 \begin{code}
 762 mergesort :: (a -> a -> TAG_) -> [a] -> [a]
 763
 764 mergesort cmp xs = merge_lists (split_into_runs [] xs)
 765   where
 766     a `le` b = case cmp a b of { LT_ -> True;  EQ_ -> True; GT__ -> False }
 767     a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True  }
 768
 769     split_into_runs []        []                = []
 770     split_into_runs run       []                = [run]
 771     split_into_runs []        (x:xs)            = split_into_runs [x] xs
 772     split_into_runs [r]       (x:xs) | x `ge` r = split_into_runs [r,x] xs
 773     split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
 774                                      | True     = rl : (split_into_runs [x] xs)
 775
 776     merge_lists []       = []
 777     merge_lists (x:xs)   = merge x (merge_lists xs)
 778
 779     merge [] ys = ys
 780     merge xs [] = xs
 781     merge xl@(x:xs) yl@(y:ys)
 782       = case cmp x y of
 783           EQ_  -> x : y : (merge xs ys)
 784           LT_  -> x : (merge xs yl)
 785           GT__ -> y : (merge xl ys)
 786 \end{code}
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794 \begin{display}
 795 Date: Mon, 3 May 93 20:45:23 +0200
 796 From: Carsten Kehler Holst <kehler@cs.chalmers.se>
 797 To: partain@dcs.gla.ac.uk
 798 Subject: natural merge sort beats quick sort [ and it is prettier ]
 799
 800    Here a piece of Haskell code that I'm rather fond of. See it as an
 801 attempt to get rid of the ridiculous quick-sort rutine. group is quite
 802 useful by itself I think it was John's idea originally though I
 803 believe the lazy version is due to me [surprisingly complicated].
 804 gamma [used to be called] called gamma because I got inspired by the Gamma calculus. It
 805 is not very close to the calculus but does behave less sequential that
 806 both foldr and foldl. One could imagine a version of gamma that took a
 807 unit element as well thereby avoiding the problem with empty lists.
 808
 809 I've tried this code against
 810
 811    1) insertion sort - as provided by haskell
 812    2) the normal implementation of quick sort
 813    3) a deforested version of quick sort due to Jan Sparud
 814    4) a super-optimized-quick-sort of Lennarts
 815
 816 If the list is partially sorted both merge sort and in particular
 817 natural merge sort wins. If the list is random [ average length of
 818 rising subsequences = approx 2 ] mergesort still wins and natural
 819 merge sort is marginally beeten by lennart's soqs. The space
 820 consumption of merge sort is a bit worse than Lennarts quick sort
 821 approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
 822 fpca article ] isn't used because of group.
 823
 824 have fun
 825 Carsten
 826 \end{display}
 827
 828 \begin{code}
 829 group :: (a -> a -> Bool) -> [a] -> [[a]]
 830 group p [] = [[]]
 831 group p (x:xs) =
 832    let ((h1:t1):tt1) = group p xs
 833        (t,tt) = if null xs then ([],[]) else
 834                 if x `p` h1 then (h1:t1,tt1) else
 835                    ([], (h1:t1):tt1)
 836    in ((x:t):tt)
 837
 838 generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
 839 generalMerge p xs [] = xs
 840 generalMerge p [] ys = ys
 841 generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
 842                              | y `p` x = y : generalMerge p (x:xs) ys
 843
 844 -- gamma is now called balancedFold
 845
 846 balancedFold :: (a -> a -> a) -> [a] -> a
 847 balancedFold f [] = error "can't reduce an empty list using balancedFold"
 848 balancedFold f [x] = x
 849 balancedFold f l  = balancedFold f (balancedFold' f l)
 850
 851 balancedFold' :: (a -> a -> a) -> [a] -> [a]
 852 balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
 853 balancedFold' f xs = xs
 854
 855 generalMergeSort p = balancedFold (generalMerge p) . map (:[])
 856 generalNaturalMergeSort p = balancedFold (generalMerge p) . group p
 857
 858 mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
 859
 860 mergeSort = generalMergeSort (<=)
 861 naturalMergeSort = generalNaturalMergeSort (<=)
 862
 863 mergeSortLe le = generalMergeSort le
 864 naturalMergeSortLe le = generalNaturalMergeSort le
 865 \end{code}
 866
 867 %************************************************************************
 868 %*                                                                      *
 869 \subsection[Utils-transitive-closure]{Transitive closure}
 870 %*                                                                      *
 871 %************************************************************************
 872
 873 This algorithm for transitive closure is straightforward, albeit quadratic.
 874
 875 \begin{code}
 876 transitiveClosure :: (a -> [a])         -- Successor function
 877                   -> (a -> a -> Bool)   -- Equality predicate
 878                   -> [a]
 879                   -> [a]                -- The transitive closure
 880
 881 transitiveClosure succ eq xs
 882  = do [] xs
 883  where
 884    do done []                      = done
 885    do done (x:xs) | x `is_in` done = do done xs
 886                   | otherwise      = do (x:done) (succ x ++ xs)
 887
 888    x `is_in` []                 = False
 889    x `is_in` (y:ys) | eq x y    = True
 890                     | otherwise = x `is_in` ys
 891 \end{code}
 892
 893 %************************************************************************
 894 %*                                                                      *
 895 \subsection[Utils-accum]{Accumulating}
 896 %*                                                                      *
 897 %************************************************************************
 898
 899 @mapAccumL@ behaves like a combination
 900 of  @map@ and @foldl@;
 901 it applies a function to each element of a list, passing an accumulating
 902 parameter from left to right, and returning a final value of this
 903 accumulator together with the new list.
 904
 905 \begin{code}
 906 mapAccumL :: (acc -> x -> (acc, y))     -- Function of elt of input list
 907                                         -- and accumulator, returning new
 908                                         -- accumulator and elt of result list
 909             -> acc              -- Initial accumulator
 910             -> [x]              -- Input list
 911             -> (acc, [y])               -- Final accumulator and result list
 912
 913 mapAccumL f b []     = (b, [])
 914 mapAccumL f b (x:xs) = (b'', x':xs') where
 915                                           (b', x') = f b x
 916                                           (b'', xs') = mapAccumL f b' xs
 917 \end{code}
 918
 919 @mapAccumR@ does the same, but working from right to left instead.  Its type is
 920 the same as @mapAccumL@, though.
 921
 922 \begin{code}
 923 mapAccumR :: (acc -> x -> (acc, y))     -- Function of elt of input list
 924                                         -- and accumulator, returning new
 925                                         -- accumulator and elt of result list
 926             -> acc              -- Initial accumulator
 927             -> [x]              -- Input list
 928             -> (acc, [y])               -- Final accumulator and result list
 929
 930 mapAccumR f b []     = (b, [])
 931 mapAccumR f b (x:xs) = (b'', x':xs') where
 932                                           (b'', x') = f b' x
 933                                           (b', xs') = mapAccumR f b xs
 934 \end{code}
 935
 936 Here is the bi-directional version, that works from both left and right.
 937
 938 \begin{code}
 939 mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
 940                                 -- Function of elt of input list
 941                                 -- and accumulator, returning new
 942                                 -- accumulator and elt of result list
 943           -> accl                       -- Initial accumulator from left
 944           -> accr                       -- Initial accumulator from right
 945           -> [x]                        -- Input list
 946           -> (accl, accr, [y])  -- Final accumulators and result list
 947
 948 mapAccumB f a b []     = (a,b,[])
 949 mapAccumB f a b (x:xs) = (a'',b'',y:ys)
 950    where
 951         (a',b'',y)  = f a b' x
 952         (a'',b',ys) = mapAccumB f a' b xs
 953 \end{code}
 954
 955 %************************************************************************
 956 %*                                                                      *
 957 \subsection[Utils-comparison]{Comparisons}
 958 %*                                                                      *
 959 %************************************************************************
 960
 961 See also @tagCmp_@ near the versions-compatibility section.
 962
 963 \begin{code}
 964 cmpString :: String -> String -> TAG_
 965
 966 cmpString []     []     = EQ_
 967 cmpString (x:xs) (y:ys) = if      x == y then cmpString xs ys
 968                           else if x  < y then LT_
 969                           else                GT_
 970 cmpString []     ys     = LT_
 971 cmpString xs     []     = GT_
 972
 973 cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here
 974                 cmpString s "" -- will never get here
 975                 }
 976 \end{code}
 977
 978 \begin{code}
 979 #ifdef USE_FAST_STRINGS
 980 cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
 981
 982 cmpPString x y
 983   = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
 984 #endif
 985 \end{code}
 986
 987 \begin{code}
 988 #ifndef USE_FAST_STRINGS
 989 substr :: FAST_STRING -> Int -> Int -> FAST_STRING
 990
 991 substr str beg end
 992   = ASSERT (beg >= 0 && beg <= end)
 993     take (end - beg + 1) (drop beg str)
 994 #endif
 995 \end{code}
 996
 997 %************************************************************************
 998 %*                                                                      *
 999 \subsection[Utils-pairs]{Pairs}
1000 %*                                                                      *
1001 %************************************************************************
1002
1003 The following are curried versions of @fst@ and @snd@.
1004
1005 \begin{code}
1006 cfst :: a -> b -> a     -- stranal-sem only (Note)
1007 cfst x y = x
1008 \end{code}
1009
1010 The following provide us higher order functions that, when applied
1011 to a function, operate on pairs.
1012
1013 \begin{code}
1014 applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
1015 applyToPair (f,g) (x,y) = (f x, g y)
1016
1017 applyToFst :: (a -> c) -> (a,b)-> (c,b)
1018 applyToFst f (x,y) = (f x,y)
1019
1020 applyToSnd :: (b -> d) -> (a,b) -> (a,d)
1021 applyToSnd f (x,y) = (x,f y)
1022
1023 foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
1024 foldPair fg ab [] = ab
1025 foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
1026                        where (u,v) = foldPair fg ab abs
1027 \end{code}
1028
1029 \begin{code}
1030 unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
1031 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
1032 \end{code}
1033
1034 %************************************************************************
1035 %*                                                                      *
1036 \subsection[Utils-errors]{Error handling}
1037 %*                                                                      *
1038 %************************************************************************
1039
1040 \begin{code}
1041 #if defined(COMPILING_GHC)
1042 panic x = error ("panic! (the `impossible' happened):\n\t"
1043               ++ x ++ "\n\n"
1044               ++ "Please report it as a compiler bug "
1045               ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
1046
1047 pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
1048
1049 pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
1050
1051 # ifdef DEBUG
1052 assertPanic :: String -> Int -> a
1053 assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
1054 # endif
1055 #endif {- COMPILING_GHC -}
1056 \end{code}