X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=b8aa2900e5181a1d06cc02b37d25c1e76dfaafc2;hb=61fae1d3fb61c5f53c3fbcb94afe7c548ad31591;hp=3f7237ec38d6969fd1e5e8ba730766662dcb2654;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs
index 3f7237e..b8aa290 100644
--- a/ghc/compiler/hsSyn/HsTypes.lhs
+++ b/ghc/compiler/hsSyn/HsTypes.lhs
@@ -3,111 +3,253 @@
 %
 \section[HsTypes]{Abstract syntax: user-defined types}
 
-If compiled without \tr{#define COMPILING_GHC}, you get
-(part of) a Haskell-abstract-syntax library.  With it,
-you get part of GHC.
-
 \begin{code}
 module HsTypes (
-	HsType(..), HsTyVar(..),
-	Context, ClassAssertion
-
-	, mkHsForAllTy
-	, getTyVarName, replaceTyVarName
-	, pprParendHsType
-	, pprForAll, pprContext, pprClassAssertion
-	, cmpHsType, cmpHsTypes, cmpContext
+	  HsType(..), HsTyVarBndr(..),
+	, HsContext, HsPred(..)
+	, HsTupCon(..), hsTupParens, mkHsTupCon,
+        , hsUsOnce, hsUsMany
+
+	, mkHsForAllTy, mkHsDictTy, mkHsIParamTy
+	, hsTyVarName, hsTyVarNames, replaceTyVarName
+	, getHsInstHead
+	
+	-- Type place holder
+	, PostTcType, placeHolderType,
+
+	-- Printing
+	, pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
+
+	-- Equality over Hs things
+	, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
+	, eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsTyVars, eq_hsType, eq_hsContext, eqListBy
+
+	-- Converting from Type to HsType
+	, toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs
     ) where
 
 #include "HsVersions.h"
 
-import Type		( Kind )
-import PprType		( {- instance Outputable Kind -} )
+import Class		( FunDep )
+import TcType		( Type, Kind, ThetaType, SourceType(..), 
+			  tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
+			)
+import TypeRep		( Type(..), TyNote(..) )	-- toHsType sees the representation
+import TyCon		( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn )
+import RdrName		( RdrName, mkUnqual )
+import Name		( Name, getName )
+import OccName		( NameSpace, tvName )
+import Var		( TyVar, tyVarKind )
+import Subst		( substTyWith )
+import PprType		( {- instance Outputable Kind -}, pprParendKind )
+import BasicTypes	( Boxity(..), Arity, IPName, tupleParens )
+import PrelNames	( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
+			  usOnceTyConName, usManyTyConName
+			)
+import FiniteMap
+import Util		( eqListBy, lengthIs )
 import Outputable
-import Util		( thenCmp, cmpList )
 \end{code}
 
+
+%************************************************************************
+%*									*
+\subsection{Annotating the syntax}
+%*									*
+%************************************************************************
+
+\begin{code}
+type PostTcType = Type		-- Used for slots in the abstract syntax
+				-- where we want to keep slot for a type
+				-- to be added by the type checker...but
+				-- before typechecking it's just bogus
+
+placeHolderType :: PostTcType	-- Used before typechecking
+placeHolderType  = panic "Evaluated the place holder for a PostTcType"
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Data types}
+%*									*
+%************************************************************************
+
 This is the syntax for types as seen in type signatures.
 
 \begin{code}
-type Context name = [ClassAssertion name]
+type HsContext name = [HsPred name]
 
-type ClassAssertion name = (name, [HsType name])
-	-- The type is usually a type variable, but it
-	-- doesn't have to be when reading interface files
+data HsPred name = HsClassP name [HsType name]
+		 | HsIParam (IPName name) (HsType name)
 
 data HsType name
-  = HsForAllTy		[HsTyVar name]
-			(Context name)
-			(HsType name)
+  = HsForAllTy	(Maybe [HsTyVarBndr name])	-- Nothing for implicitly quantified signatures
+		(HsContext name)
+		(HsType name)
 
-  | MonoTyVar		name		-- Type variable
+  | HsTyVar		name		-- Type variable or type constructor
 
-  | MonoTyApp		(HsType name)
+  | HsAppTy		(HsType name)
 			(HsType name)
 
-  | MonoFunTy		(HsType name) -- function type
+  | HsFunTy		(HsType name) -- function type
 			(HsType name)
 
-  | MonoListTy		(HsType name)	-- Element type
-
-  | MonoTupleTy		[HsType name]	-- Element types (length gives arity)
-			Bool		-- boxed?
-
-  -- these next two are only used in unfoldings in interfaces
-  | MonoDictTy		name	-- Class
-			[HsType name]
-
-mkHsForAllTy []  []   ty = ty
+  | HsListTy		(HsType name)	-- Element type
+
+  | HsTupleTy		(HsTupCon name)
+			[HsType name]	-- Element types (length gives arity)
+  -- Generics
+  | HsOpTy		(HsType name) name (HsType name)
+  | HsNumTy             Integer
+
+  -- these next two are only used in interfaces
+  | HsPredTy		(HsPred name)
+  
+  | HsUsageTy		(HsType name)   -- Usage annotation
+			(HsType name)	-- Annotated type
+
+
+-----------------------
+hsUsOnce, hsUsMany :: HsType RdrName
+hsUsOnce = HsTyVar (mkUnqual tvName SLIT("."))  -- deep magic
+hsUsMany = HsTyVar (mkUnqual tvName SLIT("!"))  -- deep magic
+
+hsUsOnce_Name, hsUsMany_Name :: HsType Name
+hsUsOnce_Name = HsTyVar usOnceTyConName
+hsUsMany_Name = HsTyVar usManyTyConName
+
+-----------------------
+data HsTupCon name = HsTupCon name Boxity Arity
+
+instance Eq name => Eq (HsTupCon name) where
+  (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2
+   
+mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
+mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity
+			     where
+			       arity = length args
+
+hsTupParens :: HsTupCon name -> SDoc -> SDoc
+hsTupParens (HsTupCon _ b _) p = tupleParens b p
+
+-----------------------
+-- Combine adjacent for-alls. 
+-- The following awkward situation can happen otherwise:
+--	f :: forall a. ((Num a) => Int)
+-- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
+-- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
+-- but the export list abstracts f wrt [a].  Disaster.
+--
+-- A valid type must have one for-all at the top of the type, or of the fn arg types
+
+mkHsForAllTy (Just []) [] ty = ty	-- Explicit for-all with no tyvars
+mkHsForAllTy mtvs1     [] (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
+						     where
+						       mtvs1       `plus` Nothing     = mtvs1
+						       Nothing     `plus` mtvs2       = mtvs2 
+						       (Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
 mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
 
-data HsTyVar name
+mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
+mkHsIParamTy v ty  = HsPredTy (HsIParam v ty)
+
+data HsTyVarBndr name
   = UserTyVar name
   | IfaceTyVar name Kind
 	-- *** NOTA BENE *** A "monotype" in a pragma can have
 	-- for-alls in it, (mostly to do with dictionaries).  These
 	-- must be explicitly Kinded.
 
-getTyVarName (UserTyVar n)    = n
-getTyVarName (IfaceTyVar n _) = n
+hsTyVarName (UserTyVar n)    = n
+hsTyVarName (IfaceTyVar n _) = n
+
+hsTyVarNames tvs = map hsTyVarName tvs
 
-replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
 replaceTyVarName (UserTyVar n)    n' = UserTyVar n'
 replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
 \end{code}
 
 
+\begin{code}
+getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name]))
+	-- Split up an instance decl type, returning the 'head' part
+
+-- In interface fiels, the type of the decl is held like this:
+--	forall a. Foo a -> Baz (T a)
+-- so we have to strip off function argument types,
+-- as well as the bit before the '=>' (which is always 
+-- empty in interface files)
+--
+-- The parser ensures the type will have the right shape.
+-- (e.g. see ParseUtil.checkInstType)
+
+getHsInstHead  (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau)
+getHsInstHead  tau			     = ([],  get_head1 tau)
+
+get_head1 (HsFunTy _ ty)		= get_head1 ty
+get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys)
+\end{code}
+
+
 %************************************************************************
 %*									*
 \subsection{Pretty printing}
 %*									*
 %************************************************************************
 
-\begin{code}
+NB: these types get printed into interface files, so 
+    don't change the printing format lightly
 
+\begin{code}
 instance (Outputable name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
 
-instance (Outputable name) => Outputable (HsTyVar name) where
+instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (UserTyVar name)       = ppr name
-    ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
-
-pprForAll []  = empty
-pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
-
-pprContext :: (Outputable name) => Context name -> SDoc
-pprContext []	   = empty
-pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>")
-
-pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc
-pprClassAssertion (clas, tys) 
-  = ppr clas <+> hsep (map pprParendHsType tys)
+    ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
+
+instance Outputable name => Outputable (HsPred name) where
+    ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
+    ppr (HsIParam n ty)    = hsep [ppr n, dcolon, ppr ty]
+
+pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
+pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name
+			 | otherwise 	  	        = hsep [ppr name, dcolon, pprParendKind kind]
+
+pprHsForAll []  []  = empty
+pprHsForAll tvs cxt 
+	-- This printer is used for both interface files and
+	-- printing user types in error messages; and alas the
+	-- two use slightly different syntax.  Ah well.
+  = getPprStyle $ \ sty ->
+    if userStyle sty then
+	ptext SLIT("forall") <+> interppSP tvs <> dot <+> 
+              -- **! ToDo: want to hide uvars from user, but not enough info
+              -- in a HsTyVarBndr name (see PprType).  KSW 2000-10.
+	(if null cxt then 
+		empty 
+	 else 
+		ppr_context cxt <+> ptext SLIT("=>")
+	)
+    else	-- Used in interfaces
+	ptext SLIT("__forall") <+> interppSP tvs <+> 
+	ppr_context cxt <+> ptext SLIT("=>")
+
+pprHsContext :: (Outputable name) => HsContext name -> SDoc
+pprHsContext []	 = empty
+pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>")
+
+ppr_context []  = empty
+ppr_context cxt = parens (interpp'SP cxt)
 \end{code}
 
 \begin{code}
-pREC_TOP = (0 :: Int)
-pREC_FUN = (1 :: Int)
-pREC_CON = (2 :: Int)
+pREC_TOP = (0 :: Int)  -- type   in ParseIface.y
+pREC_FUN = (1 :: Int)  -- btype  in ParseIface.y
+pREC_CON = (2 :: Int)  -- atype  in ParseIface.y
 
 maybeParen :: Bool -> SDoc -> SDoc
 maybeParen True  p = parens p
@@ -120,34 +262,126 @@ pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc
 pprHsType ty       = ppr_mono_ty pREC_TOP ty
 pprParendHsType ty = ppr_mono_ty pREC_CON ty
 
-ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty)
+ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
   = maybeParen (ctxt_prec >= pREC_FUN) $
-    sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
+    sep [pp_header, pprHsType ty]
+  where
+    pp_header = case maybe_tvs of
+		  Just tvs -> pprHsForAll tvs ctxt
+		  Nothing  -> pprHsContext ctxt
 
-ppr_mono_ty ctxt_prec (MonoTyVar name)
+ppr_mono_ty ctxt_prec (HsTyVar name)
   = ppr name
 
-ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2)
+ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2)
   = let p1 = ppr_mono_ty pREC_FUN ty1
 	p2 = ppr_mono_ty pREC_TOP ty2
     in
     maybeParen (ctxt_prec >= pREC_FUN)
 	       (sep [p1, (<>) (ptext SLIT("-> ")) p2])
 
-ppr_mono_ty ctxt_prec (MonoTupleTy tys True)
- = parens (sep (punctuate comma (map ppr tys)))
-ppr_mono_ty ctxt_prec (MonoTupleTy tys False)
- = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)")
-
-ppr_mono_ty ctxt_prec (MonoListTy ty)
- = brackets (ppr_mono_ty pREC_TOP ty)
+ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys)
+ppr_mono_ty ctxt_prec (HsListTy ty)	  = brackets (ppr_mono_ty pREC_TOP ty)
 
-ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty)
+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen (ctxt_prec >= pREC_CON)
 	       (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
 
-ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
-  = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys)
+ppr_mono_ty ctxt_prec (HsPredTy pred) 
+  = braces (ppr pred)
+
+ppr_mono_ty ctxt_prec (HsUsageTy u ty)
+  = maybeParen (ctxt_prec >= pREC_CON)
+               (sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u,
+                     ppr_mono_ty pREC_CON ty])
+    -- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy
+
+-- Generics
+ppr_mono_ty ctxt_prec (HsNumTy n) = integer  n
+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Converting from Type to HsType}
+%*									*
+%************************************************************************
+
+@toHsType@ converts from a Type to a HsType, making the latter look as
+user-friendly as possible.  Notably, it uses synonyms where possible, and
+expresses overloaded functions using the '=>' context part of a HsForAllTy.
+
+\begin{code}
+toHsTyVar :: TyVar -> HsTyVarBndr Name
+toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv)
+
+toHsTyVars tvs = map toHsTyVar tvs
+
+toHsType :: Type -> HsType Name
+-- This function knows the representation of types
+toHsType (TyVarTy tv)    = HsTyVar (getName tv)
+toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
+toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg) 
+
+toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty)
+  | isNewTyCon tycon = toHsType ty
+  | syn_matches      = toHsType ty             -- Use synonyms if possible!!
+  | otherwise        = 
+#ifdef DEBUG
+                       pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
+#endif
+                       toHsType real_ty              -- but drop it if not.
+  where
+    syn_matches      = ty_from_syn `tcEqType` real_ty
+    (tyvars,syn_ty)  = getSynTyConDefn tycon
+    ty_from_syn      = substTyWith tyvars tyargs syn_ty
+
+    -- We only use the type synonym in the file if this doesn't cause
+    -- us to lose important information.  This matters for usage
+    -- annotations.  It's an issue if some of the args to the synonym
+    -- have arrows in them, or if the synonym's RHS has an arrow; for
+    -- example, with nofib/real/ebnf2ps/ in Parsers.using.
+
+    -- **! It would be nice if when this test fails we could still
+    -- write the synonym in as a Note, so we don't lose the info for
+    -- error messages, but it's too much work for right now.
+    -- KSW 2000-07.
+
+toHsType (NoteTy _ ty)	       = toHsType ty
+
+toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys)
+toHsType (SourceTy pred)	   = HsPredTy (toHsPred pred)
+
+toHsType ty@(TyConApp tc tys)	-- Must be saturated because toHsType's arg is of kind *
+  | not saturated	       = generic_case
+  | isTupleTyCon tc	       = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys'
+  | tc `hasKey` listTyConKey   = HsListTy (head tys')
+  | tc `hasKey` usOnceTyConKey = hsUsOnce_Name		 -- must print !, . unqualified
+  | tc `hasKey` usManyTyConKey = hsUsMany_Name		 -- must print !, . unqualified
+  | otherwise		       = generic_case
+  where
+     generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
+     tys'         = map toHsType tys
+     saturated    = tys `lengthIs` tyConArity tc
+
+toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
+			        (tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
+			 				        (map toHsPred preds)
+						                (toHsType tau)
+
+toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty)
+                          -- **! consider dropping usMany annotations ToDo KSW 2000-10
+
+
+toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
+toHsPred (IParam n ty)    = HsIParam n		   (toHsType ty)
+
+toHsContext :: ThetaType -> HsContext Name
+toHsContext theta = map toHsPred theta
+
+toHsFDs :: [FunDep TyVar] -> [FunDep Name]
+toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
 \end{code}
 
 
@@ -157,68 +391,106 @@ ppr_mono_ty ctxt_prec (MonoDictTy clas tys)
 %*									*
 %************************************************************************
 
+\begin{code}
+instance Ord a => Eq (HsType a) where
+	-- The Ord is needed because we keep a
+	-- finite map of variables to variables
+   (==) a b = eq_hsType emptyEqHsEnv a b
+
+instance Ord a => Eq (HsPred a) where
+   (==) a b = eq_hsPred emptyEqHsEnv a b
+
+eqWithHsTyVars :: Ord name =>
+	          [HsTyVarBndr name] -> [HsTyVarBndr name]
+	       -> (EqHsEnv name -> Bool) -> Bool
+eqWithHsTyVars = eq_hsTyVars emptyEqHsEnv
+\end{code}
+
+\begin{code}
+type EqHsEnv n = FiniteMap n n
+-- Tracks the mapping from L-variables to R-variables
+
+eq_hsVar :: Ord n => EqHsEnv n -> n -> n -> Bool
+eq_hsVar env n1 n2 = case lookupFM env n1 of
+		      Just n1 -> n1 == n2
+		      Nothing -> n1 == n2
+
+extendEqHsEnv env n1 n2 
+  | n1 == n2  = env
+  | otherwise = addToFM env n1 n2
+
+emptyEqHsEnv :: EqHsEnv n
+emptyEqHsEnv = emptyFM
+\end{code}
+
 We do define a specialised equality for these \tr{*Type} types; used
-in checking interfaces.  Most any other use is likely to be {\em
-wrong}, so be careful!
+in checking interfaces.
+
+\begin{code}
+-------------------
+eq_hsTyVars env [] 	    []	       k = k env
+eq_hsTyVars env (tv1:tvs1) (tv2:tvs2)  k = eq_hsTyVar env tv1 tv2 $ \ env ->
+					   eq_hsTyVars env tvs1 tvs2 k
+eq_hsTyVars env _ _ _ = False
+
+eq_hsTyVar env (UserTyVar v1)     (UserTyVar v2)     k = k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env _ _ _ = False
+
+eq_hsVars env []       []       k = k env
+eq_hsVars env (v1:bs1) (v2:bs2) k = eq_hsVars (extendEqHsEnv env v1 v2) bs1 bs2 k
+eq_hsVars env _ _ _ = False
+\end{code}
 
 \begin{code}
-cmpHsTyVar  :: (a -> a -> Ordering) -> HsTyVar a  -> HsTyVar a  -> Ordering
-cmpHsType   :: (a -> a -> Ordering) -> HsType a   -> HsType a   -> Ordering
-cmpHsTypes  :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering
-cmpContext  :: (a -> a -> Ordering) -> Context  a -> Context  a -> Ordering
+-------------------
+eq_hsTypes env = eqListBy (eq_hsType env)
+
+-------------------
+eq_hsType env (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+  = eq_tvs tvs1 tvs2 		$ \env ->
+    eq_hsContext env c1 c2   	&&
+    eq_hsType env t1 t2
+  where
+    eq_tvs Nothing     (Just _) k    = False
+    eq_tvs Nothing     Nothing  k    = k env
+    eq_tvs (Just _)    Nothing  k    = False
+    eq_tvs (Just tvs1) (Just tvs2) k = eq_hsTyVars env tvs1 tvs2 k
 
-cmpHsTyVar cmp (UserTyVar v1)    (UserTyVar v2)    = v1 `cmp` v2
-cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
-cmpHsTyVar cmp (UserTyVar _)	 other		   = LT
-cmpHsTyVar cmp other1	 	 other2		   = GT
+eq_hsType env (HsTyVar n1) (HsTyVar n2)
+  = eq_hsVar env n1 n2
 
+eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2)
+  = (c1 == c2) && eq_hsTypes env tys1 tys2
 
-cmpHsTypes cmp [] []   = EQ
-cmpHsTypes cmp [] tys2 = LT
-cmpHsTypes cmp tys1 [] = GT
-cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2
+eq_hsType env (HsListTy ty1) (HsListTy ty2)
+  = eq_hsType env ty1 ty2
 
-cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
-  = cmpList (cmpHsTyVar cmp) tvs1 tvs2  `thenCmp`
-    cmpContext cmp c1 c2    		`thenCmp`
-    cmpHsType cmp t1 t2
+eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2)
+  = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2
 
-cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
-  = cmp n1 n2
+eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2)
+  = eq_hsType env a1 a2 && eq_hsType env b1 b2
 
-cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2)
-  = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2
+eq_hsType env (HsPredTy p1) (HsPredTy p2)
+  = eq_hsPred env p1 p2
 
-cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2)
-  = cmpHsType cmp ty1 ty2
+eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2)
+  = eq_hsType env u1 u2 && eq_hsType env ty1 ty2
 
-cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2)
-  = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2
+eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
+  = eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
 
-cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
-  = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
+eq_hsType env ty1 ty2 = False
 
-cmpHsType cmp (MonoDictTy c1 tys1)   (MonoDictTy c2 tys2)
-  = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
 
-cmpHsType cmp ty1 ty2 -- tags must be different
-  = let tag1 = tag ty1
-	tag2 = tag ty2
-    in
-    if tag1 _LT_ tag2 then LT else GT
-  where
-    tag (MonoTyVar n1)			= (ILIT(1) :: FAST_INT)
-    tag (MonoTupleTy tys1 _)		= ILIT(2)
-    tag (MonoListTy ty1)		= ILIT(3)
-    tag (MonoTyApp tc1 tys1)		= ILIT(4)
-    tag (MonoFunTy a1 b1)		= ILIT(5)
-    tag (MonoDictTy c1 tys1)		= ILIT(7)
-    tag (HsForAllTy _ _ _)		= ILIT(8)
+-------------------
+eq_hsContext env a b = eqListBy (eq_hsPred env) a b
 
 -------------------
-cmpContext cmp a b
-  = cmpList cmp_ctxt a b
-  where
-    cmp_ctxt (c1, tys1) (c2, tys2)
-      = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2
+eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2)
+  = c1 == c2 &&  eq_hsTypes env tys1 tys2
+eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2)
+  = n1 == n2 && eq_hsType env ty1 ty2
+eq_hsPred env _ _ = False
 \end{code}