X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Futils%2FUtil.lhs;h=33198560a7ca4e780d20d3acf7ba4c2ea82a5b02;hb=bd9eee136c2362fec5acc048bc29d1157a20d7b2;hp=c6e92c0740d97d4cc3e861f7c4b404e5d222cd8c;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index c6e92c0..3319856 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -4,50 +4,24 @@
 \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,
-	mapAndUnzip,
+	mapAndUnzip, mapAndUnzip3,
 	nOfThem, lengthExceeds, isSingleton,
-	startsWith, endsWith,
-#if defined(COMPILING_GHC)
+	startsWith, endsWith, snocView,
 	isIn, isn'tIn,
-#endif
 
 	-- association lists
-	assoc,
+	assoc, assocUsing, assocDefault, assocDefaultUsing,
 
 	-- duplicate handling
 	hasNoDups, equivClasses, runs, removeDups,
@@ -65,60 +39,61 @@ module Util (
 	mapAccumL, mapAccumR, mapAccumB,
 
 	-- comparisons
-	Ord3(..), thenCmp, cmpList,
-	IF_NOT_GHC(cmpString COMMA)
-#ifdef USE_FAST_STRINGS
-	cmpPString,
-#else
-	substr,
-#endif
+	thenCmp, cmpList,
+	FastString,
+
 	-- pairs
 	IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
 	IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
-	unzipWith
+	unzipWith,
+
+	-- tracing (abstract away from lib home)
+	trace,
 
 	-- error handling
-#if defined(COMPILING_GHC)
-	, panic, panic#, pprPanic, pprPanic#, pprError, pprTrace
-	, assertPanic
-#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
+	panic, panic#, assertPanic
 
     ) where
 
-#if defined(COMPILING_GHC)
+#include "HsVersions.h"
 
-CHK_Ubiq() -- debugging consistency check
+import FastString	( FastString )
+import List		( zipWith4 )
+import GlaExts		( trace )
 
-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}
 
 %************************************************************************
@@ -144,34 +119,34 @@ are of equal length.  Alastair Reid thinks this should only happen if
 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}
 
@@ -193,6 +168,16 @@ mapAndUnzip f (x:xs)
 	(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}
@@ -214,6 +199,7 @@ 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
@@ -221,9 +207,17 @@ endsWith cs ss
       Just rs -> Just (reverse rs)
 \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
@@ -256,7 +250,6 @@ isn'tIn msg x ys
 
 # endif {- DEBUG -}
 
-#endif {- COMPILING_GHC -}
 \end{code}
 
 %************************************************************************
@@ -268,13 +261,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}
 
 %************************************************************************
@@ -294,15 +294,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]]
 
@@ -311,8 +307,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
@@ -333,7 +329,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
@@ -349,6 +345,7 @@ removeDups cmp xs
     collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[Utils-sorting]{Sorting}
@@ -440,12 +437,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]
@@ -461,9 +458,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}
 
 %************************************************************************
@@ -585,11 +582,11 @@ transitiveClosure :: (a -> [a])		-- Successor function
 		  -> [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
@@ -664,80 +661,37 @@ 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_
+			  else if x  < y then LT
+			  else		      GT
+cmpString []     ys	= LT
+cmpString xs     []	= GT
 
-cmpString _ _ = panic# "cmpString"
+cmpString _ _ = panic "cmpString"
 \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}
 
+y
 %************************************************************************
 %*									*
 \subsection[Utils-pairs]{Pairs}
@@ -775,6 +729,7 @@ unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
 unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 \end{code}
 
+
 %************************************************************************
 %*									*
 \subsection[Utils-errors]{Error handling}
@@ -782,27 +737,18 @@ unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
 %************************************************************************
 
 \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))
-pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg))
-pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
+	      ++ "to glasgow-haskell-bugs@dcs.gla.ac.uk.\n\n" )
 
 -- #-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))
+panic# :: String -> FAST_INT
+panic# s = case (panic s) of () -> ILIT(0)
 
 assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-
-#endif {- COMPILING_GHC -}
+assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
 \end{code}