%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (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, zipWithEqual, zipWith3Equal, zipWith4Equal,
- zipLazy,
+ zipLazy, stretchZipEqual,
+ mapAndUnzip, mapAndUnzip3,
nOfThem, lengthExceeds, isSingleton,
-#if defined(COMPILING_GHC)
+ snocView,
isIn, isn'tIn,
-#endif
-- association lists
- assoc,
+ 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
- Ord3(..), thenCmp, cmpList,
- 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, panic#, pprPanic, 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
-
) where
-#if defined(COMPILING_GHC)
+#include "HsVersions.h"
-CHK_Ubiq() -- debugging consistency check
+import List ( zipWith4 )
+import Panic ( panic )
+import Unique ( Unique )
+import UniqFM ( eltsUFM, emptyUFM, addToUFM_C )
-import Pretty
-#endif
-#if __HASKELL1__ < 3
-import Maybes ( Maybe(..) )
-#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}
%************************************************************************
DEBUGging on; hey, why not?
\begin{code}
-zipEqual :: [a] -> [b] -> [(a,b)]
-zipWithEqual :: (a->b->c) -> [a]->[b]->[c]
-zipWith3Equal :: (a->b->c->d) -> [a]->[b]->[c]->[d]
-zipWith4Equal :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+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 = zip
-zipWithEqual = zipWith
-zipWith3Equal = zipWith3
-zipWith4Equal = zipWith4
+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"
-
-zipWithEqual z (a:as) (b:bs) = z a b : zipWithEqual z as bs
-zipWithEqual _ [] [] = []
-zipWithEqual _ _ _ = panic "zipWithEqual: unequal lists"
-
-zipWith3Equal z (a:as) (b:bs) (c:cs)
- = z a b c : zipWith3Equal z as bs cs
-zipWith3Equal _ [] [] [] = []
-zipWith3Equal _ _ _ _ = panic "zipWith3Equal: unequal lists"
-
-zipWith4Equal z (a:as) (b:bs) (c:cs) (d:ds)
- = z a b c d : zipWith4Equal z as bs cs ds
-zipWith4Equal _ [] [] [] [] = []
-zipWith4Equal _ _ _ _ _ = panic "zipWith4Equal: 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}
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 -> Literal -> [Literal] -> 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 -> [(PrimRep, a)] -> PrimRep -> 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 -> [(Type, a)] -> Type -> a #-}
-{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
-# endif
-#endif
+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
+
+assocDefaultUsing eq deflt ((k,v) : rest) key
+ | k `eq` key = v
+ | otherwise = assocDefaultUsing eq deflt rest key
+
+assocDefaultUsing eq deflt [] key = deflt
+
+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}
%************************************************************************
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
+equivClasses :: (a -> a -> Ordering) -- Comparison
-> [a]
-> [[a]]
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
\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}
%************************************************************************
\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}
%************************************************************************
-> [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
%* *
%************************************************************************
-See also @tagCmp_@ near the versions-compatibility section.
-
-The Ord3 class will be subsumed into Ord in Haskell 1.3.
-
\begin{code}
-class Ord3 a where
- cmp :: a -> a -> TAG_
-
-thenCmp :: TAG_ -> TAG_ -> TAG_
+thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
-thenCmp EQ_ any = any
+thenCmp EQ any = any
thenCmp other any = other
-cmpList :: (a -> a -> TAG_) -> [a] -> [a] -> TAG_
+cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
-- `cmpList' uses a user-specified comparer
-cmpList cmp [] [] = EQ_
-cmpList cmp [] _ = LT_
-cmpList cmp _ [] = GT_
+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 }
+ = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx }
\end{code}
\begin{code}
-instance Ord3 a => Ord3 [a] where
- cmp [] [] = EQ_
- cmp (x:xs) [] = GT_
- cmp [] (y:ys) = LT_
- cmp (x:xs) (y:ys) = (x `cmp` y) `thenCmp` (xs `cmp` ys)
-
-instance Ord3 a => Ord3 (Maybe a) where
- cmp Nothing Nothing = EQ_
- cmp Nothing (Just y) = LT_
- cmp (Just x) Nothing = GT_
- cmp (Just x) (Just y) = x `cmp` y
-
-instance Ord3 Int where
- cmp a b | a < b = LT_
- | a > b = GT_
- | otherwise = EQ_
-\end{code}
+cmpString :: String -> String -> Ordering
-\begin{code}
-cmpString :: String -> String -> TAG_
-
-cmpString [] [] = EQ_
+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 _ _ = panic# "cmpString"
-\end{code}
+ else if x < y then LT
+ else GT
+cmpString [] ys = LT
+cmpString xs [] = GT
-\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
+cmpString _ _ = panic "cmpString"
\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}
+y
%************************************************************************
%* *
\subsection[Utils-pairs]{Pairs}
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))
--- #-versions because panic can't return an unboxed int, and that's
--- what TAG_ is with GHC at the moment. Ugh. (Simon)
--- No, man -- Too Beautiful! (Will)
-
-panic# :: String -> TAG_
-panic# s = case (panic s) of () -> EQ_
-
-pprPanic# heading pretty_msg = panic# (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}