X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=149ca9d9ac063453155b676a03ed39f36cdc9efe;hb=0710d446789cc7b3e29f12ab56d9d5315fd4b8af;hp=6d51f3aaf2c56aca8d4f509df673a52cf8073d9d;hpb=5eb1c77c795f92ed0f4c8023847e9d4be1a4fd0d;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 6d51f3a..149ca9d 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -1,60 +1,29 @@ % -% (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_ Ordering -# define LT_ LT -# define EQ_ EQ -# define GT_ GT -# define _LT LT -# define _EQ EQ -# define _GT GT -# define GT__ _ -# define tagCmp_ compare -# define _tagCmp compare -# 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) - startsWith, endsWith, + 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) @@ -69,53 +38,57 @@ module Util ( mapAccumL, mapAccumR, mapAccumB, -- comparisons -#if defined(COMPILING_GHC) - Ord3(..), thenCmp, cmpList, - cmpPString, -#else - cmpString, -#endif + thenCmp, cmpList, + + -- strictness + seqList, ($!), -- 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#, pprError, pprTrace - , assertPanic -#endif {- COMPILING_GHC -} - ) where -#if defined(COMPILING_GHC) - -CHK_Ubiq() -- debugging consistency check -IMPORT_1_3(List(zipWith4)) +#include "HsVersions.h" -import Pretty -#else -import List(zipWith4) -#endif +import List ( zipWith4 ) +import Panic ( panic ) +import Unique ( Unique ) +import UniqFM ( eltsUFM, emptyUFM, addToUFM_C ) 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} %************************************************************************ @@ -124,18 +97,6 @@ tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_ %* * %************************************************************************ -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@ (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? @@ -180,6 +141,18 @@ 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]) @@ -204,7 +177,7 @@ mapAndUnzip3 f (x:xs) \begin{code} nOfThem :: Int -> a -> [a] -nOfThem n thing = take n (repeat thing) +nOfThem n thing = replicate n thing lengthExceeds :: [a] -> Int -> Bool @@ -215,23 +188,19 @@ isSingleton :: [a] -> Bool isSingleton [x] = True isSingleton _ = False +\end{code} -startsWith, endsWith :: String -> String -> Maybe String - -startsWith [] str = Just str -startsWith (c:cs) (s:ss) - = if c /= s then Nothing else startsWith cs ss -startsWith _ [] = Nothing - -endsWith cs ss - = case (startsWith (reverse cs) (reverse ss)) of - Nothing -> Nothing - Just rs -> Just (reverse rs) +\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 @@ -264,7 +233,6 @@ isn'tIn msg x ys # endif {- DEBUG -} -#endif {- COMPILING_GHC -} \end{code} %************************************************************************ @@ -276,13 +244,20 @@ isn'tIn msg x ys See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@. \begin{code} -assoc :: (Eq a) => String -> [(a, b)] -> a -> b +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 lst key - = if (null res) - then panic ("Failed in assoc: " ++ crash_msg) - else head res - where res = [ val | (key', val) <- lst, key == key'] +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} %************************************************************************ @@ -302,15 +277,11 @@ hasNoDups xs = f [] xs else f (x:seen_so_far) xs -#if defined(COMPILING_GHC) is_elem = isIn "hasNoDups" -#else - is_elem = elem -#endif \end{code} \begin{code} -equivClasses :: (a -> a -> TAG_) -- Comparison +equivClasses :: (a -> a -> Ordering) -- Comparison -> [a] -> [[a]] @@ -319,8 +290,8 @@ 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 } + 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 @@ -341,7 +312,7 @@ runs p (x:xs) = case (span (p x) xs) of \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 @@ -357,6 +328,22 @@ removeDups cmp xs 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} @@ -448,12 +435,12 @@ rqpart lt x (y:ys) rle rgt 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] @@ -469,9 +456,9 @@ mergesort cmp xs = merge_lists (split_into_runs [] xs) 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} %************************************************************************ @@ -672,72 +659,35 @@ mapAccumB f a b (x:xs) = (a'',b'',y:ys) %* * %************************************************************************ -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 } -\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_ + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } \end{code} \begin{code} -cmpString :: String -> String -> TAG_ +cmpString :: String -> String -> Ordering -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_ - -#ifdef COMPILING_GHC -cmpString _ _ = panic# "cmpString" -#else -cmpString _ _ = error "cmpString" -#endif + else if x < y then LT + else GT +cmpString [] ys = LT +cmpString xs [] = GT \end{code} -\begin{code} -cmpPString :: FAST_STRING -> FAST_STRING -> TAG_ - -cmpPString x y - = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ } -\end{code} +y %************************************************************************ %* * \subsection[Utils-pairs]{Pairs} @@ -775,38 +725,17 @@ 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.gla.ac.uk.\n\n" ) - -pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) -pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg)) -#if __GLASGOW_HASKELL__ >= 200 -pprTrace heading pretty_msg = GHCbase.trace (heading++(ppShow 80 pretty_msg)) +#if __HASKELL1__ > 4 +seqList :: [a] -> b -> b #else -pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg)) +seqList :: (Eval a) => [a] -> b -> b #endif +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b --- #-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)) - -assertPanic :: String -> Int -> a -assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line) - -#endif {- COMPILING_GHC -} +#if __HASKELL1__ <= 4 +($!) :: (Eval a) => (a -> b) -> a -> b +f $! x = x `seq` f x +#endif \end{code}