diff options
Diffstat (limited to 'ghc/compiler/utils/Util.lhs')
| -rw-r--r-- | ghc/compiler/utils/Util.lhs | 1056 |
1 files changed, 1056 insertions, 0 deletions
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs new file mode 100644 index 0000000000..7f0d40680b --- /dev/null +++ b/ghc/compiler/utils/Util.lhs @@ -0,0 +1,1056 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% +\section[Util]{Highly random utility functions} + +\begin{code} +#if defined(COMPILING_GHC) +# include "HsVersions.h" +# define IF_NOT_GHC(a) {--} +#else +# define panic error +# define TAG_ _CMP_TAG +# define LT_ _LT +# define EQ_ _EQ +# define GT_ _GT +# define GT__ _ +# define tagCmp_ _tagCmp +# define FAST_STRING String +# define ASSERT(x) {-nothing-} +# define IF_NOT_GHC(a) a +# define COMMA , +#endif + +#ifndef __GLASGOW_HASKELL__ +# undef TAG_ +# undef LT_ +# undef EQ_ +# undef GT_ +# undef tagCmp_ +#endif + +module Util ( + -- Haskell-version support +#ifndef __GLASGOW_HASKELL__ + tagCmp_, + TAG_(..), +#endif + -- general list processing + IF_NOT_GHC(forall COMMA exists COMMA) + zipEqual, nOfThem, lengthExceeds, isSingleton, +#if defined(COMPILING_GHC) + isIn, isn'tIn, +#endif + + -- association lists + assoc, +#ifdef USE_SEMANTIQUE_STRANAL + clookup, clookrepl, elemIndex, (\\\), +#endif + + -- duplicate handling + hasNoDups, equivClasses, runs, removeDups, + + -- sorting + IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA) + sortLt, + IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten + IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA) + + -- transitive closures + transitiveClosure, + + -- accumulating + mapAccumL, mapAccumR, mapAccumB, + + -- comparisons + IF_NOT_GHC(cmpString COMMA) +#ifdef USE_FAST_STRINGS + cmpPString, +#else + substr, +#endif + -- pairs + IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA) + IF_NOT_GHC(applyToSnd COMMA foldPair COMMA) + unzipWith + + -- error handling +#if defined(COMPILING_GHC) + , panic, pprPanic, pprTrace +# ifdef DEBUG + , assertPanic +# endif +#endif {- COMPILING_GHC -} + + -- and to make the interface self-sufficient... +#if __HASKELL1__ < 3 +# if defined(COMPILING_GHC) + , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..) +# else + , Maybe +# endif +#endif + +#ifdef USE_ATTACK_PRAGMAS + -- as more-or-less of a *HACK*, Util exports + -- many types abstractly, so that pragmas will be + -- able to see them (given that most modules + -- import Util). + , + AbstractC, + ArgUsage, + ArgUsageInfo, + ArithSeqInfo, + ArityInfo, + Bag, + BasicLit, + Bind, + BinderInfo, + Binds, + CAddrMode, + CExprMacro, + CLabel, + CSeq, + CStmtMacro, + CcKind, + Class, + ClassDecl, + ClassOp, + ClassOpPragmas, + ClassPragmas, + ClosureInfo, + ConDecl, + CoreArg, + CoreAtom, + CoreBinding, + CoreCaseAlternatives, + CoreCaseDefault, + CoreExpr, + CostCentre, + DataPragmas, + DataTypeSig, + DefaultDecl, + DeforestInfo, + Delay, + Demand, + DemandInfo, + DuplicationDanger, + EnclosingCcDetails, + EndOfBlockInfo, + ExportFlag, + Expr, + FBConsum, + FBProd, + FBType, + FBTypeInfo, + FiniteMap, + FixityDecl, + FormSummary, + FullName, + FunOrArg, + GRHS, + GRHSsAndBinds, + GenPragmas, + GlobalSwitch, + HeapOffset, + IE, + Id, + IdDetails, + IdEnv(..), -- UGH + IdInfo, + IdVal, + IfaceImportDecl, + ImpStrictness, + ImpUnfolding, + ImportedInterface, + InPat, + InsideSCC, + Inst, + InstDecl, + InstOrigin, + InstTemplate, + InstTy, + InstancePragmas, + Interface, + IsDupdCC, IsCafCC, + LambdaFormInfo, + Literal, + MagicId, + MagicUnfoldingFun, + Match, + Module, + MonoBinds, + MonoType, + Name, + NamedThing(..), -- SIGH + OptIdInfo(..), -- SIGH + OrdList, + Outputable(..), -- SIGH + OverloadedLit, + PolyType, + PprStyle, + PrimKind, + PrimOp, + ProtoName, + Provenance, + Qual, + RegRelative, + Renaming, + ReturnInfo, + SMRep, + SMSpecRepKind, + SMUpdateKind, + Sequel, + ShortName, + Sig, + SimplCount, + SimplEnv, + SimplifierSwitch, + SpecEnv, + SpecInfo, + SpecialisedInstanceSig, + SplitUniqSupply, + SrcLoc, + StableLoc, + StandardFormInfo, + StgAtom, + StgBinderInfo, + StgBinding, + StgCaseAlternatives, + StgCaseDefault, + StgExpr, + StgRhs, + StrictnessInfo, + StubFlag, + SwitchResult, + TickType, + TyCon, + TyDecl, + TyVar, + TyVarEnv(..), + TyVarTemplate, + TypePragmas, + TypecheckedPat, + UfCostCentre, + UfId, + UnfoldEnv, + UnfoldItem, + UnfoldConApp, + UnfoldingCoreAlts, + UnfoldingCoreAtom, + UnfoldingCoreBinding, + UnfoldingCoreDefault, + UnfoldingCoreExpr, + UnfoldingDetails, + UnfoldingGuidance, + UnfoldingPrimOp, + UniType, + UniqFM, + Unique, + UniqueSupply, + UpdateFlag, + UpdateInfo, + VolatileLoc, + +#if ! OMIT_NATIVE_CODEGEN + Reg, + CodeSegment, + RegLoc, + StixReg, + StixTree, +#endif + + getIdUniType, typeOfBasicLit, typeOfPat, + getIdKind, kindOfBasicLit, + kindFromType, + + eqId, cmpId, + eqName, cmpName, + cmpProtoName, eqProtoName, + cmpByLocalName, eqByLocalName, + eqUnique, cmpUnique, + showUnique, + + switchIsOn, + + ppNil, ppStr, ppInt, ppInteger, ppDouble, +#if __GLASGOW_HASKELL__ >= 23 + ppRational, --- ??? +#endif + cNil, cStr, cAppend, cCh, cShow, +#if __GLASGOW_HASKELL__ >= 23 + cPStr, +#endif + +-- mkBlackHoleCLabel, + + emptyBag, snocBag, + emptyFM, +--OLD: emptySet, + nullSpecEnv, + + mkUnknownSrcLoc, + + pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType, + + tagOf_PrimOp, + pprPrimOp + +#endif {-USE_ATTACK_PRAGMAS-} + ) where + +#if defined(COMPILING_GHC) +IMPORT_Trace +import Pretty +#endif +#if __HASKELL1__ < 3 +import Maybes ( Maybe(..) ) +#endif + +#if defined(COMPILING_GHC) +import Id +import IdInfo +import Outputable + +# ifdef USE_ATTACK_PRAGMAS + +import AbsCSyn +import AbsSyn +import AbsUniType +import Bag +import BasicLit +import BinderInfo +import CLabelInfo +import CgBindery +import CgMonad +import CharSeq +import ClosureInfo +import CmdLineOpts +import CoreSyn +import FiniteMap +import HsCore +import HsPragmas +import Inst +import InstEnv +import Name +import NameTypes +import OrdList +import PlainCore +import PrimOps +import ProtoName +import CostCentre +import SMRep +import SimplEnv +import SimplMonad +import SplitUniq +import SrcLoc +import StgSyn +import TyVarEnv +import UniqFM +import Unique + +# if ! OMIT_NATIVE_CODEGEN +import AsmRegAlloc ( Reg ) +import MachDesc +import Stix +# endif + +# endif {-USE_ATTACK_PRAGMAS-} + +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell} +%* * +%************************************************************************ + +This is our own idea: +\begin{code} +#ifndef __GLASGOW_HASKELL__ +data TAG_ = LT_ | EQ_ | GT_ + +tagCmp_ :: Ord a => a -> a -> TAG_ +tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_ +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-lists]{General list processing} +%* * +%************************************************************************ + +Quantifiers are not standard in Haskell. The following fill in the gap. + +\begin{code} +forall :: (a -> Bool) -> [a] -> Bool +forall pred [] = True +forall pred (x:xs) = pred x && forall pred xs + +exists :: (a -> Bool) -> [a] -> Bool +exists pred [] = False +exists pred (x:xs) = pred x || exists pred xs +\end{code} + +A paranoid @zip@ that checks the lists are of equal length. +Alastair Reid thinks this should only happen if DEBUGging on; +hey, why not? + +\begin{code} +zipEqual :: [a] -> [b] -> [(a,b)] + +#ifndef DEBUG +zipEqual a b = zip a b +#else +zipEqual [] [] = [] +zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs +zipEqual as bs = panic "zipEqual: unequal lists" +#endif +\end{code} + +\begin{code} +nOfThem :: Int -> a -> [a] +nOfThem n thing = take n (repeat thing) + +lengthExceeds :: [a] -> Int -> Bool + +[] `lengthExceeds` n = 0 > n +(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1)) + +isSingleton :: [a] -> Bool + +isSingleton [x] = True +isSingleton _ = False +\end{code} + +Debugging/specialising versions of \tr{elem} and \tr{notElem} +\begin{code} +#if defined(COMPILING_GHC) +isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool + +# ifndef DEBUG +isIn msg x ys = elem__ x ys +isn'tIn msg x ys = notElem__ x ys + +--these are here to be SPECIALIZEd (automagically) +elem__ _ [] = False +elem__ x (y:ys) = x==y || elem__ x ys + +notElem__ x [] = True +notElem__ x (y:ys) = x /= y && notElem__ x ys + +# else {- DEBUG -} +isIn msg x ys + = elem ILIT(0) x ys + where + elem i _ [] = False + elem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg) + | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys + +isn'tIn msg x ys + = notElem ILIT(0) x ys + where + notElem i x [] = True + notElem i x (y:ys) + | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg) + | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys + +# endif {- DEBUG -} + +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-} +{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-} +{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-} +# endif + +#endif {- COMPILING_GHC -} +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-assoc]{Association lists} +%* * +%************************************************************************ + +See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@. + +\begin{code} +assoc :: (Eq a) => String -> [(a, b)] -> a -> b + +assoc crash_msg lst key + = if (null res) + then panic ("Failed in assoc: " ++ crash_msg) + else head res + where res = [ val | (key', val) <- lst, key == key'] + +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-} +{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-} +{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-} +{-# SPECIALIZE assoc :: String -> [(PrimKind, a)] -> PrimKind -> a #-} +{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-} +{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-} +{-# SPECIALIZE assoc :: String -> [(UniType, a)] -> UniType -> a #-} +{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-} +# endif +#endif +\end{code} + +Given a list of associations one wants to look for the most recent +association for a given key. A couple of functions follow that cover +the simple lookup, the lookup with a default value when the key not +found, and two corresponding functions operating on unzipped lists +of associations. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +clookup :: (Eq a) => [a] -> [b] -> a -> b +clookup = clookupElse (panic "clookup") + where + -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b + clookupElse d [] [] a = d + clookupElse d (x:xs) (y:ys) a + | a==x = y + | True = clookupElse d xs ys a +#endif +\end{code} + +The following routine given a curried environment replaces the entry +labelled with a given name with a new value given. The new value is +given in the form of a function that allows to transform the old entry. + +Assumption is that the list of labels contains the given one and that +the two lists of the curried environment are of equal lengths. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b] +clookrepl (a:as) (b:bs) x f + = if x == a then (f b:bs) else (b:clookrepl as bs x f) +#endif +\end{code} + +The following returns the index of an element in a list. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL + +elemIndex :: Eq a => [a] -> a -> Int +elemIndex as x = indx as x 0 + where + indx :: Eq a => [a] -> a -> Int -> Int + indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int) +# if defined(COMPILING_GHC) + indx [] x n = pprPanic "element not in list in elemIndex" ppNil +# else + indx [] x n = error "element not in list in elemIndex" +# endif +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-dups]{Duplicate-handling} +%* * +%************************************************************************ + +List difference (non-associative). In the result of @xs \\\ ys@, the +first occurrence of each element of ys in turn (if any) has been +removed from xs. Thus, @(xs ++ ys) \\\ xs == ys@. This function is +a copy of @\\@ from report 1.1 and is added to overshade the buggy +version from the 1.0 version of Haskell. + +This routine can be removed after the compiler bootstraps itself and +a proper @\\@ is can be applied. + +\begin{code} +#ifdef USE_SEMANTIQUE_STRANAL +(\\\) :: (Eq a) => [a] -> [a] -> [a] +(\\\) = foldl del + where + [] `del` _ = [] + (x:xs) `del` y + | x == y = xs + | otherwise = x : xs `del` y +#endif +\end{code} + +\begin{code} +hasNoDups :: (Eq a) => [a] -> Bool +hasNoDups xs = f [] xs + where + f seen_so_far [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far then + False + else + f (x:seen_so_far) xs + +#if defined(COMPILING_GHC) + is_elem = isIn "hasNoDups" +#else + is_elem = elem +#endif +#if defined(COMPILING_GHC) +# ifdef USE_ATTACK_PRAGMAS +{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-} +# endif +#endif +\end{code} + +\begin{code} +equivClasses :: (a -> a -> TAG_) -- Comparison + -> [a] + -> [[a]] + +equivClasses cmp stuff@[] = [] +equivClasses cmp stuff@[item] = [stuff] +equivClasses cmp items + = runs eq (sortLt lt items) + where + eq a b = case cmp a b of { EQ_ -> True; _ -> False } + lt a b = case cmp a b of { LT_ -> True; _ -> False } +\end{code} + +The first cases in @equivClasses@ above are just to cut to the point +more quickly... + +@runs@ groups a list into a list of lists, each sublist being a run of +identical elements of the input list. It is passed a predicate @p@ which +tells when two elements are equal. + +\begin{code} +runs :: (a -> a -> Bool) -- Equality + -> [a] + -> [[a]] + +runs p [] = [] +runs p (x:xs) = case (span (p x) xs) of + (first, rest) -> (x:first) : (runs p rest) +\end{code} + +\begin{code} +removeDups :: (a -> a -> TAG_) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [[a]]) -- List of duplicate groups. One representative from + -- each group appears in the first result + +removeDups cmp [] = ([], []) +removeDups cmp [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups dups_so_far [x] = (dups_so_far, x) + collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x) +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-sorting]{Sorting} +%* * +%************************************************************************ + +%************************************************************************ +%* * +\subsubsection[Utils-quicksorting]{Quicksorts} +%* * +%************************************************************************ + +\begin{code} +-- tail-recursive, etc., "quicker sort" [as per Meira thesis] +quicksort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list in increasing order + +quicksort lt [] = [] +quicksort lt [x] = [x] +quicksort lt (x:xs) = split x [] [] xs + where + split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi) + split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys + | True = split x lo (y:hi) ys +\end{code} + +Quicksort variant from Lennart's Haskell-library contribution. This +is a {\em stable} sort. + +\begin{code} +stableSortLt = sortLt -- synonym; when we want to highlight stable-ness + +sortLt :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- Input list + -> [a] -- Result list + +sortLt lt l = qsort lt l [] + +-- qsort is stable and does not concatenate. +qsort :: (a -> a -> Bool) -- Less-than predicate + -> [a] -- xs, Input list + -> [a] -- r, Concatenate this list to the sorted input list + -> [a] -- Result = sort xs ++ r + +qsort lt [] r = r +qsort lt [x] r = x:r +qsort lt (x:xs) r = qpart lt x xs [] [] r + +-- qpart partitions and sorts the sublists +-- rlt contains things less than x, +-- rge contains the ones greater than or equal to x. +-- Both have equal elements reversed with respect to the original list. + +qpart lt x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort lt rlt (x : rqsort lt rge r) + +qpart lt x (y:ys) rlt rge r = + if lt y x then + -- y < x + qpart lt x ys (y:rlt) rge r + else + -- y >= x + qpart lt x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort lt [] r = r +rqsort lt [x] r = x:r +rqsort lt (x:xs) r = rqpart lt x xs [] [] r + +rqpart lt x [] rle rgt r = + qsort lt rle (x : qsort lt rgt r) + +rqpart lt x (y:ys) rle rgt r = + if lt x y then + -- y > x + rqpart lt x ys rle (y:rgt) r + else + -- y <= x + rqpart lt x ys (y:rle) rgt r +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-dull-mergesort]{A rather dull mergesort} +%* * +%************************************************************************ + +\begin{code} +mergesort :: (a -> a -> TAG_) -> [a] -> [a] + +mergesort cmp xs = merge_lists (split_into_runs [] xs) + where + a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False } + a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True } + + split_into_runs [] [] = [] + split_into_runs run [] = [run] + split_into_runs [] (x:xs) = split_into_runs [x] xs + split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs + split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs + | True = rl : (split_into_runs [x] xs) + + merge_lists [] = [] + merge_lists (x:xs) = merge x (merge_lists xs) + + merge [] ys = ys + merge xs [] = xs + merge xl@(x:xs) yl@(y:ys) + = case cmp x y of + EQ_ -> x : y : (merge xs ys) + LT_ -> x : (merge xs yl) + GT__ -> y : (merge xl ys) +\end{code} + +%************************************************************************ +%* * +\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten} +%* * +%************************************************************************ + +\begin{display} +Date: Mon, 3 May 93 20:45:23 +0200 +From: Carsten Kehler Holst <kehler@cs.chalmers.se> +To: partain@dcs.gla.ac.uk +Subject: natural merge sort beats quick sort [ and it is prettier ] + + Here a piece of Haskell code that I'm rather fond of. See it as an +attempt to get rid of the ridiculous quick-sort rutine. group is quite +useful by itself I think it was John's idea originally though I +believe the lazy version is due to me [surprisingly complicated]. +gamma [used to be called] called gamma because I got inspired by the Gamma calculus. It +is not very close to the calculus but does behave less sequential that +both foldr and foldl. One could imagine a version of gamma that took a +unit element as well thereby avoiding the problem with empty lists. + +I've tried this code against + + 1) insertion sort - as provided by haskell + 2) the normal implementation of quick sort + 3) a deforested version of quick sort due to Jan Sparud + 4) a super-optimized-quick-sort of Lennarts + +If the list is partially sorted both merge sort and in particular +natural merge sort wins. If the list is random [ average length of +rising subsequences = approx 2 ] mergesort still wins and natural +merge sort is marginally beeten by lennart's soqs. The space +consumption of merge sort is a bit worse than Lennarts quick sort +approx a factor of 2. And a lot worse if Sparud's bug-fix [see his +fpca article ] isn't used because of group. + +have fun +Carsten +\end{display} + +\begin{code} +group :: (a -> a -> Bool) -> [a] -> [[a]] +group p [] = [[]] +group p (x:xs) = + let ((h1:t1):tt1) = group p xs + (t,tt) = if null xs then ([],[]) else + if x `p` h1 then (h1:t1,tt1) else + ([], (h1:t1):tt1) + in ((x:t):tt) + +generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a] +generalMerge p xs [] = xs +generalMerge p [] ys = ys +generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys) + | y `p` x = y : generalMerge p (x:xs) ys + +-- gamma is now called balancedFold + +balancedFold :: (a -> a -> a) -> [a] -> a +balancedFold f [] = error "can't reduce an empty list using balancedFold" +balancedFold f [x] = x +balancedFold f l = balancedFold f (balancedFold' f l) + +balancedFold' :: (a -> a -> a) -> [a] -> [a] +balancedFold' f (x:y:xs) = f x y : balancedFold' f xs +balancedFold' f xs = xs + +generalMergeSort p = balancedFold (generalMerge p) . map (:[]) +generalNaturalMergeSort p = balancedFold (generalMerge p) . group p + +mergeSort, naturalMergeSort :: Ord a => [a] -> [a] + +mergeSort = generalMergeSort (<=) +naturalMergeSort = generalNaturalMergeSort (<=) + +mergeSortLe le = generalMergeSort le +naturalMergeSortLe le = generalNaturalMergeSort le +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-transitive-closure]{Transitive closure} +%* * +%************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. + +\begin{code} +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = do [] xs + where + do done [] = done + do done (x:xs) | x `is_in` done = do done xs + | otherwise = do (x:done) (succ x ++ xs) + + x `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-accum]{Accumulating} +%* * +%************************************************************************ + +@mapAccumL@ behaves like a combination +of @map@ and @foldl@; +it applies a function to each element of a list, passing an accumulating +parameter from left to right, and returning a final value of this +accumulator together with the new list. + +\begin{code} +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumL f b [] = (b, []) +mapAccumL f b (x:xs) = (b'', x':xs') where + (b', x') = f b x + (b'', xs') = mapAccumL f b' xs +\end{code} + +@mapAccumR@ does the same, but working from right to left instead. Its type is +the same as @mapAccumL@, though. + +\begin{code} +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list + +mapAccumR f b [] = (b, []) +mapAccumR f b (x:xs) = (b'', x':xs') where + (b'', x') = f b' x + (b', xs') = mapAccumR f b xs +\end{code} + +Here is the bi-directional version, that works from both left and right. + +\begin{code} +mapAccumB :: (accl -> accr -> x -> (accl, accr,y)) + -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> accl -- Initial accumulator from left + -> accr -- Initial accumulator from right + -> [x] -- Input list + -> (accl, accr, [y]) -- Final accumulators and result list + +mapAccumB f a b [] = (a,b,[]) +mapAccumB f a b (x:xs) = (a'',b'',y:ys) + where + (a',b'',y) = f a b' x + (a'',b',ys) = mapAccumB f a' b xs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-comparison]{Comparisons} +%* * +%************************************************************************ + +See also @tagCmp_@ near the versions-compatibility section. + +\begin{code} +cmpString :: String -> String -> TAG_ + +cmpString [] [] = EQ_ +cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys + else if x < y then LT_ + else GT_ +cmpString [] ys = LT_ +cmpString xs [] = GT_ + +cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here + cmpString s "" -- will never get here + } +\end{code} + +\begin{code} +#ifdef USE_FAST_STRINGS +cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ + +cmpPString x y + = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } +#endif +\end{code} + +\begin{code} +#ifndef USE_FAST_STRINGS +substr :: FAST_STRING -> Int -> Int -> FAST_STRING + +substr str beg end + = ASSERT (beg >= 0 && beg <= end) + take (end - beg + 1) (drop beg str) +#endif +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-pairs]{Pairs} +%* * +%************************************************************************ + +The following are curried versions of @fst@ and @snd@. + +\begin{code} +cfst :: a -> b -> a -- stranal-sem only (Note) +cfst x y = x +\end{code} + +The following provide us higher order functions that, when applied +to a function, operate on pairs. + +\begin{code} +applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d) +applyToPair (f,g) (x,y) = (f x, g y) + +applyToFst :: (a -> c) -> (a,b)-> (c,b) +applyToFst f (x,y) = (f x,y) + +applyToSnd :: (b -> d) -> (a,b) -> (a,d) +applyToSnd f (x,y) = (x,f y) + +foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b) +foldPair fg ab [] = ab +foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v) + where (u,v) = foldPair fg ab abs +\end{code} + +\begin{code} +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs +\end{code} + +%************************************************************************ +%* * +\subsection[Utils-errors]{Error handling} +%* * +%************************************************************************ + +\begin{code} +#if defined(COMPILING_GHC) +panic x = error ("panic! (the `impossible' happened):\n\t" + ++ x ++ "\n\n" + ++ "Please report it as a compiler bug " + ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" ) + +pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) + +pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg)) + +# ifdef DEBUG +assertPanic :: String -> Int -> a +assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line) +# endif +#endif {- COMPILING_GHC -} +\end{code} |