%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\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
+-- IF_NOT_GHC is meant to make this module useful outside the context of GHC
+#define IF_NOT_GHC(a)
module Util (
- -- Haskell-version support
-#ifndef __GLASGOW_HASKELL__
- tagCmp_,
- TAG_(..),
-#endif
+ -- The Eager monad
+ Eager, thenEager, returnEager, mapEager, appEager, runEager,
+
-- general list processing
IF_NOT_GHC(forall COMMA exists COMMA)
- zipEqual, nOfThem, lengthExceeds, isSingleton,
-#if defined(COMPILING_GHC)
+ zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
+ zipLazy, stretchZipEqual,
+ mapAndUnzip, mapAndUnzip3,
+ nOfThem, lengthExceeds, isSingleton,
+ snocView,
isIn, isn'tIn,
-#endif
-- association lists
- assoc,
-#ifdef USE_SEMANTIQUE_STRANAL
- clookup, clookrepl, elemIndex, (\\\),
-#endif
+ assoc, assocUsing, assocDefault, assocDefaultUsing,
-- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
+ hasNoDups, equivClasses, runs, removeDups, equivClassesByUniq,
-- sorting
IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
mapAccumL, mapAccumR, mapAccumB,
-- comparisons
- IF_NOT_GHC(cmpString COMMA)
-#ifdef USE_FAST_STRINGS
- cmpPString,
-#else
- substr,
-#endif
+ thenCmp, cmpList,
+
-- 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
+#include "HsVersions.h"
-#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-}
+import List ( zipWith4 )
+import Panic ( panic )
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
-#endif
+infixr 9 `thenCmp`
\end{code}
%************************************************************************
%* *
-\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
+\subsection{The Eager monad}
%* *
%************************************************************************
-This is our own idea:
+The @Eager@ monad is just an encoding of continuation-passing style,
+used to allow you to express "do this and then that", mainly to avoid
+space leaks. It's done with a type synonym to save bureaucracy.
+
\begin{code}
-#ifndef __GLASGOW_HASKELL__
-data TAG_ = LT_ | EQ_ | GT_
+type Eager ans a = (a -> ans) -> ans
-tagCmp_ :: Ord a => a -> a -> TAG_
-tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_
-#endif
+runEager :: Eager a a -> a
+runEager m = m (\x -> x)
+
+appEager :: Eager ans a -> (a -> ans) -> ans
+appEager m cont = m cont
+
+thenEager :: Eager ans a -> (a -> Eager ans b) -> Eager ans b
+thenEager m k cont = m (\r -> k r cont)
+
+returnEager :: a -> Eager ans a
+returnEager v cont = cont v
+
+mapEager :: (a -> Eager ans b) -> [a] -> Eager ans [b]
+mapEager f [] = returnEager []
+mapEager f (x:xs) = f x `thenEager` \ y ->
+ mapEager f xs `thenEager` \ ys ->
+ returnEager (y:ys)
\end{code}
%************************************************************************
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?
+A paranoid @zip@ (and some @zipWith@ friends) 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)]
+zipEqual :: String -> [a] -> [b] -> [(a,b)]
+zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c]
+zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
#ifndef DEBUG
-zipEqual a b = zip a b
+zipEqual _ = zip
+zipWithEqual _ = zipWith
+zipWith3Equal _ = zipWith3
+zipWith4Equal _ = zipWith4
#else
-zipEqual [] [] = []
-zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
-zipEqual as bs = panic "zipEqual: unequal lists"
+zipEqual msg [] [] = []
+zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs
+zipEqual msg as bs = panic ("zipEqual: unequal lists:"++msg)
+
+zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs
+zipWithEqual msg _ [] [] = []
+zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg)
+
+zipWith3Equal msg z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3Equal msg z as bs cs
+zipWith3Equal msg _ [] [] [] = []
+zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg)
+
+zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds)
+ = z a b c d : zipWith4Equal msg z as bs cs ds
+zipWith4Equal msg _ [] [] [] [] = []
+zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg)
#endif
\end{code}
\begin{code}
+-- zipLazy is lazy in the second list (observe the ~)
+
+zipLazy :: [a] -> [b] -> [(a,b)]
+zipLazy [] ys = []
+zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
+\end{code}
+
+
+\begin{code}
+stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a]
+-- (stretchZipEqual f xs ys) stretches ys to "fit" the places where f returns a Just
+
+stretchZipEqual f [] [] = []
+stretchZipEqual f (x:xs) (y:ys) = case f x y of
+ Just x' -> x' : stretchZipEqual f xs ys
+ Nothing -> x : stretchZipEqual f xs (y:ys)
+\end{code}
+
+
+\begin{code}
+mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
+
+mapAndUnzip f [] = ([],[])
+mapAndUnzip f (x:xs)
+ = let
+ (r1, r2) = f x
+ (rs1, rs2) = mapAndUnzip f xs
+ in
+ (r1:rs1, r2:rs2)
+
+mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])
+
+mapAndUnzip3 f [] = ([],[],[])
+mapAndUnzip3 f (x:xs)
+ = let
+ (r1, r2, r3) = f x
+ (rs1, rs2, rs3) = mapAndUnzip3 f xs
+ in
+ (r1:rs1, r2:rs2, r3:rs3)
+\end{code}
+
+\begin{code}
nOfThem :: Int -> a -> [a]
nOfThem n thing = take n (repeat thing)
isSingleton _ = False
\end{code}
+\begin{code}
+snocView :: [a] -> ([a], a) -- Split off the last element
+snocView xs = go xs []
+ where
+ go [x] acc = (reverse acc, x)
+ go (x:xs) acc = go xs (x:acc)
+\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
# 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}
%************************************************************************
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}
+assoc :: (Eq a) => String -> [(a, b)] -> a -> b
+assocDefault :: (Eq a) => b -> [(a, b)] -> a -> b
+assocUsing :: (a -> a -> Bool) -> String -> [(a, b)] -> a -> b
+assocDefaultUsing :: (a -> a -> Bool) -> b -> [(a, b)] -> a -> b
-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.
+assocDefaultUsing eq deflt ((k,v) : rest) key
+ | k `eq` key = v
+ | otherwise = assocDefaultUsing eq deflt rest key
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
+assocDefaultUsing eq deflt [] key = deflt
-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
+assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key
+assocDefault deflt list key = assocDefaultUsing (==) deflt list key
+assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key
\end{code}
%************************************************************************
%* *
%************************************************************************
-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
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]
+equivClasses :: (a -> a -> Ordering) -- Comparison
+ -> [a]
-> [[a]]
equivClasses cmp 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 }
+ 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
tells when two elements are equal.
\begin{code}
-runs :: (a -> a -> Bool) -- Equality
- -> [a]
+runs :: (a -> a -> Bool) -- Equality
+ -> [a]
-> [[a]]
runs p [] = []
\end{code}
\begin{code}
-removeDups :: (a -> a -> TAG_) -- Comparison function
+removeDups :: (a -> a -> Ordering) -- Comparison function
-> [a]
-> ([a], -- List with no duplicates
[[a]]) -- List of duplicate groups. One representative from
collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
\end{code}
+
+\begin{code}
+equivClassesByUniq :: (a -> Unique) -> [a] -> [[a]]
+ -- NB: it's *very* important that if we have the input list [a,b,c],
+ -- where a,b,c all have the same unique, then we get back the list
+ -- [a,b,c]
+ -- not
+ -- [c,b,a]
+ -- Hence the use of foldr, plus the reversed-args tack_on below
+equivClassesByUniq get_uniq xs
+ = eltsUFM (foldr add emptyUFM xs)
+ where
+ add a ufm = addToUFM_C tack_on ufm (get_uniq a) [a]
+ tack_on old new = new++old
+\end{code}
+
%************************************************************************
%* *
\subsection[Utils-sorting]{Sorting}
qsort lt (x:xs) r = qpart lt x xs [] [] r
-- qpart partitions and sorts the sublists
--- rlt contains things less than x,
+-- 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.
if lt y x then
-- y < x
qpart lt x ys (y:rlt) rge r
- else
+ else
-- y >= x
qpart lt x ys rlt (y:rge) r
%************************************************************************
\begin{code}
-mergesort :: (a -> a -> TAG_) -> [a] -> [a]
+mergesort :: (a -> a -> Ordering) -> [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 }
+ 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]
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)
+ EQ -> x : y : (merge xs ys)
+ LT -> x : (merge xs yl)
+ GT -> y : (merge xl ys)
\end{code}
%************************************************************************
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
+Here is a piece of Haskell code that I'm rather fond of. See it as an
+attempt to get rid of the ridiculous quick-sort routine. 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.
+gamma [used to be called] is called gamma because I got inspired by
+the Gamma calculus. It is not very close to the calculus but does
+behave less sequentially than 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
+ 4) a super-optimized-quick-sort of Lennart's
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
+merge sort is marginally beaten by Lennart's soqs. The space
+consumption of merge sort is a bit worse than Lennart's 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
+have fun
Carsten
\end{display}
\begin{code}
group :: (a -> a -> Bool) -> [a] -> [[a]]
+
+{-
+Date: Mon, 12 Feb 1996 15:09:41 +0000
+From: Andy Gill <andy@dcs.gla.ac.uk>
+
+Here is a `better' definition of group.
+-}
+group p [] = []
+group p (x:xs) = group' xs x x (x :)
+ where
+ group' [] _ _ s = [s []]
+ group' (x:xs) x_min x_max s
+ | not (x `p` x_max) = group' xs x_min x (s . (x :))
+ | x `p` x_min = group' xs x x_max ((x :) . s)
+ | otherwise = s [] : group' xs x x (x :)
+
+-- This one works forwards *and* backwards, as well as also being
+-- faster that the one in Util.lhs.
+
+{- ORIG:
group p [] = [[]]
-group p (x:xs) =
+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)
+ 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
+generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
+ | otherwise = y : generalMerge p (x:xs) ys
-- gamma is now called balancedFold
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
+generalMergeSort p [] = []
+generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
+
+generalNaturalMergeSort p [] = []
+generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
\begin{code}
transitiveClosure :: (a -> [a]) -- Successor function
-> (a -> a -> Bool) -- Equality predicate
- -> [a]
+ -> [a]
-> [a] -- The transitive closure
transitiveClosure succ eq xs
- = do [] xs
+ = go [] xs
where
- do done [] = done
- do done (x:xs) | x `is_in` done = do done xs
- | otherwise = do (x:done) (succ x ++ xs)
+ go done [] = done
+ go done (x:xs) | x `is_in` done = go done xs
+ | otherwise = go (x:done) (succ x ++ xs)
x `is_in` [] = False
x `is_in` (y:ys) | eq x y = True
-- 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
+ -> 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)
%* *
%************************************************************************
-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
- }
+thenCmp :: Ordering -> Ordering -> Ordering
+{-# INLINE thenCmp #-}
+thenCmp EQ any = any
+thenCmp other any = other
+
+cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
+ -- `cmpList' uses a user-specified comparer
+
+cmpList cmp [] [] = EQ
+cmpList cmp [] _ = LT
+cmpList cmp _ [] = GT
+cmpList cmp (a:as) (b:bs)
+ = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
\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}
+cmpString :: String -> String -> Ordering
-\begin{code}
-#ifndef USE_FAST_STRINGS
-substr :: FAST_STRING -> Int -> Int -> FAST_STRING
+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
-substr str beg end
- = ASSERT (beg >= 0 && beg <= end)
- take (end - beg + 1) (drop beg str)
-#endif
+cmpString _ _ = panic "cmpString"
\end{code}
+
+y
%************************************************************************
%* *
\subsection[Utils-pairs]{Pairs}
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
+ where (u,v) = foldPair fg ab abs
\end{code}
\begin{code}
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}