X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=55beb28da186117bcb58638c9309eddb7ec64bf7;hb=f87cc9cfccf83b21a66501f9654d3e6f1fa7adb4;hp=c1670f67bd61be348484370fcbf9ec87d2512033;hpb=388e3356f71daffa62f1d4157e1e07e4c68f218a;p=ghc-hetmet.git

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index c1670f6..55beb28 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -7,6 +7,7 @@
 \begin{code}
 -- We expose the relevant stuff from this module via the Type module
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module TypeRep (
 	TyThing(..), 
@@ -20,7 +21,7 @@ module TypeRep (
 	-- Pretty-printing
 	pprType, pprParendType, pprTypeApp,
 	pprTyThing, pprTyThingCategory, 
-	pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
+	pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
 	-- Kinds
 	liftedTypeKind, unliftedTypeKind, openTypeKind,
@@ -61,6 +62,9 @@ import Class
 import PrelNames
 import Outputable
 import FastString
+
+-- libraries
+import Data.Data hiding ( TyCon )
 \end{code}
 
 	----------------------
@@ -155,6 +159,7 @@ data Type
 	                -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
 	                
 	                -- See Note [PredTy], and Note [Equality predicates]
+  deriving (Data, Typeable)
 
 -- | The key type representing kinds in the compiler.
 -- Invariant: a kind is always in one of these forms:
@@ -196,6 +201,7 @@ data PredType
   = ClassP Class [Type]		-- ^ Class predicate e.g. @Eq a@
   | IParam (IPName Name) Type	-- ^ Implicit parameter e.g. @?x :: Int@
   | EqPred Type Type		-- ^ Equality predicate e.g @ty1 ~ ty2@
+  deriving (Data, Typeable)
 
 -- | A collection of 'PredType's
 type ThetaType = [PredType]
@@ -428,9 +434,12 @@ pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
 pprPred :: PredType -> SDoc
 pprPred (ClassP cls tys) = pprClassPred cls tys
 pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
-pprPred (EqPred ty1 ty2) = sep [ ppr_type FunPrec ty1
-                               , nest 2 (ptext (sLit "~"))
-                               , ppr_type FunPrec ty2]
+pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
+
+pprEqPred :: (Type,Type) -> SDoc
+pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
+                          , nest 2 (ptext (sLit "~"))
+                          , ppr_type FunPrec ty2]
 			       -- Precedence looks like (->) so that we get
 			       --    Maybe a ~ Bool
 			       --    (a->a) ~ Bool
@@ -443,9 +452,19 @@ pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
 
 pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow theta 
-  | null theta = empty
-  | otherwise  = parens (sep (punctuate comma (map pprPred theta))) <+> ptext (sLit "=>")
+pprThetaArrow []     = empty
+pprThetaArrow [pred] 
+  | noParenPred pred = pprPred pred <+> ptext (sLit "=>")
+pprThetaArrow preds  = parens (sep (punctuate comma (map pprPred preds))) <+> ptext (sLit "=>")
+
+noParenPred :: PredType -> Bool
+-- A predicate that can appear without parens before a "=>"
+--       C a => a -> a
+--       a~b => a -> b
+-- But   (?x::Int) => Int -> Int
+noParenPred (ClassP {}) = True
+noParenPred (EqPred {}) = True
+noParenPred (IParam {}) = False
 
 ------------------
 instance Outputable Type where
@@ -468,7 +487,8 @@ ppr_type :: Prec -> Type -> SDoc
 ppr_type _ (TyVarTy tv)		-- Note [Infix type variables]
   | isSymOcc (getOccName tv)  = parens (ppr tv)
   | otherwise		      = ppr tv
-ppr_type _ (PredTy pred)      = ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
+ppr_type p (PredTy pred)      = maybeParen p TyConPrec $
+                                ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
 ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $