X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FTypeRep.lhs;h=1660267b4ef0937463a1e988c7eec4bab6651857;hb=0e73a9fbdc8555ffb948cfd72401a700b122c395;hp=52e12bf56b664c8a83376485230019135606d58a;hpb=125502965ee73734980b19c6cbcc5e6a43a860a8;p=ghc-hetmet.git

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 52e12bf..1660267 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -15,12 +15,12 @@ module TypeRep (
 	
  	Kind, ThetaType,		-- Synonyms
 
-	funTyCon,
+	funTyCon, funTyConName,
 
 	-- Pretty-printing
 	pprType, pprParendType, pprTypeApp,
 	pprTyThing, pprTyThingCategory, 
-	pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
+	pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
 	-- Kinds
 	liftedTypeKind, unliftedTypeKind, openTypeKind,
@@ -53,7 +53,6 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName )
 -- friends:
 import Var
 import Name
-import OccName
 import BasicTypes
 import TyCon
 import Class
@@ -305,14 +304,11 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif
 tySuperKindTyCon     = mkSuperKindTyCon tySuperKindTyConName
 coSuperKindTyCon     = mkSuperKindTyCon coSuperKindTyConName
 
-liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName
-openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName
-ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName
-argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName
-
-mkKindTyCon :: Name -> TyCon
-mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0
+liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
+openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName     tySuperKind
+argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName      tySuperKind
 
 --------------------------
 -- ... and now their names
@@ -432,7 +428,17 @@ 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 ty1, nest 2 (ptext (sLit "~")), ppr 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
+			       -- Note parens on the latter!
+
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
 
@@ -462,8 +468,11 @@ pprKind = pprType
 pprParendKind = pprParendType
 
 ppr_type :: Prec -> Type -> SDoc
-ppr_type _ (TyVarTy tv)       = ppr tv
-ppr_type _ (PredTy pred)      = ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
+ppr_type _ (TyVarTy tv)		-- Note [Infix type variables]
+  | isSymOcc (getOccName tv)  = parens (ppr tv)
+  | otherwise		      = ppr tv
+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 $
@@ -553,3 +562,24 @@ pprTvBndr tv | isLiftedTypeKind kind = ppr tv
 	       kind = tyVarKind tv
 \end{code}
 
+Note [Infix type variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In Haskell 98 you can say
+
+   f :: (a ~> b) -> b
+
+and the (~>) is considered a type variable.  However, the type
+pretty-printer in this module will just see (a ~> b) as
+
+   App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b")
+
+So it'll print the type in prefix form.  To avoid confusion we must
+remember to parenthesise the operator, thus
+
+   (~>) a b -> b
+
+See Trac #2766.
+
+
+
+