X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2FhsSyn%2FHsTypes.lhs;h=a4ac86549c3a506456944c71d5bb15e9881e18b9;hb=d386e0d20c6953b7cba4d53538a1782c4aa9980d;hp=09cb0736cce1798e5862089b16e15a103c949a29;hpb=9da4639011348fb6c318e3cba4b08622f811d9c4;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 09cb073..a4ac865 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -1,7 +1,9 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-\section[HsTypes]{Abstract syntax: user-defined types}
+
+HsTypes: Abstract syntax: user-defined types
 
 \begin{code}
 module HsTypes (
@@ -30,13 +32,11 @@ module HsTypes (
 
 import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice )
 
-import Type		( Type )
-import {- Kind parts of -} 
-       Type	        ( {- instance Outputable Kind -} Kind,
-			  pprParendKind, pprKind, isLiftedTypeKind )
-import BasicTypes	( IPName, Boxity, tupleParens )
-import SrcLoc		( Located(..), unLoc, noSrcSpan )
-import StaticFlags	( opt_PprStyle_Debug )
+import Type
+import HsDoc
+import BasicTypes
+import SrcLoc
+import StaticFlags
 import Outputable
 \end{code}
 
@@ -102,7 +102,8 @@ type HsContext name = [LHsPred name]
 
 type LHsPred name = Located (HsPred name)
 
-data HsPred name = HsClassP name [LHsType name]
+data HsPred name = HsClassP name [LHsType name]		 -- class constraint
+		 | HsEqualP (LHsType name) (LHsType name)-- equality constraint
 		 | HsIParam (IPName name) (LHsType name)
 
 type LHsType name = Located (HsType name)
@@ -157,6 +158,8 @@ data HsType name
 
   | HsSpliceTy		(HsSplice name)
 
+  | HsDocTy             (LHsType name) (LHsDoc name) -- A documented type
+
 data HsExplicitForAll = Explicit | Implicit
 
 -----------------------
@@ -246,6 +249,7 @@ splitHsInstDeclTy inst_ty
   where
     split_tau tvs cxt (HsPredTy (HsClassP cls tys)) = (tvs, cxt, cls, tys)
     split_tau tvs cxt (HsParTy (L _ ty))	    = split_tau tvs cxt ty
+    split_tau _ _ other = pprPanic "splitHsInstDeclTy" (ppr inst_ty)
 
 -- Splits HsType into the (init, last) parts
 -- Breaks up any parens in the result type: 
@@ -265,9 +269,6 @@ splitHsFunType other 	   	   = ([], other)
 %*									*
 %************************************************************************
 
-NB: these types get printed into interface files, so 
-    don't change the printing format lightly
-
 \begin{code}
 instance (OutputableBndr name) => Outputable (HsType name) where
     ppr ty = pprHsType ty
@@ -277,8 +278,13 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where
     ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind
 
 instance OutputableBndr name => Outputable (HsPred name) where
-    ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys)
-    ppr (HsIParam n ty)    = hsep [ppr n, dcolon, ppr ty]
+    ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys)
+    ppr (HsEqualP t1 t2)    = hsep [pprLHsType t1, ptext SLIT("~"), 
+				    pprLHsType t2]
+    ppr (HsIParam n ty)     = hsep [ppr n, dcolon, ppr ty]
+
+pprLHsType :: OutputableBndr name => LHsType name -> SDoc
+pprLHsType = pprParendHsType . unLoc
 
 pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
 pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name
@@ -362,6 +368,9 @@ ppr_mono_ty ctxt_prec (HsParTy ty)
   -- But we still use the precedence stuff to add parens because
   --	toHsType doesn't put in any HsParTys, so we may still need them
 
+ppr_mono_ty ctxt_prec (HsDocTy ty doc)
+  = ppr ty <+> ppr (unLoc doc)
+
 --------------------------
 ppr_fun_ty ctxt_prec ty1 ty2
   = let p1 = ppr_mono_lty pREC_FUN ty1