X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsTypes.lhs;h=def44c5917e573bb87914e989186989eee1f1934;hp=cb06a7f548d7e243585998156f349ce142c6d4f2;hb=841e81e28f8cc711f624fdca122219a5bbde2fae;hpb=215ce9f15215399ce30ae55c9521087847d78646

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index cb06a7f..def44c5 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -155,6 +155,8 @@ data HsType name
 
   | HsPArrTy		(LHsType name)	-- Elem. type of parallel array: [:t:]
 
+  | HsModalBoxType	name (LHsType name)	-- modal types; first argument is the environment classifier
+
   | HsTupleTy		Boxity
 			[LHsType name]	-- Element types (length gives arity)
 
@@ -175,7 +177,7 @@ data HsType name
 					--			       ^^^^
 					--                            HsPredTy
 					-- Note no need for location info on the
-					-- enclosed HsPred; the one on the type will do
+					-- Enclosed HsPred; the one on the type will do
 
   | HsKindSig		(LHsType name)	-- (ty :: kind)
 			Kind		-- A type with a kind signature
@@ -190,6 +192,10 @@ data HsType name
 
   | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
   | HsRecTy [ConDeclField name]	        -- Only in data type declarations
+
+  | HsCoreTy Type	-- An escape hatch for tunnelling a *closed* 
+    	       		-- Core Type through HsSyn.  
+					 
   deriving (Data, Typeable)
 
 data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
@@ -353,8 +359,16 @@ pprHsForAll exp tvs cxt
     forall_part = ptext (sLit "forall") <+> interppSP tvs <> dot
 
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
-pprHsContext []	 = empty
-pprHsContext cxt = ppr_hs_context cxt <+> ptext (sLit "=>")
+pprHsContext []	        = empty
+pprHsContext [L _ pred] 
+   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext cxt        = ppr_hs_context cxt <+> darrow
+
+noParenHsPred :: HsPred name -> Bool
+-- c.f. TypeRep.noParenPred
+noParenHsPred (HsClassP {}) = True
+noParenHsPred (HsEqualP {}) = True
+noParenHsPred (HsIParam {}) = False
 
 ppr_hs_context :: (OutputableBndr name) => HsContext name -> SDoc
 ppr_hs_context []  = empty
@@ -427,9 +441,11 @@ ppr_mono_ty _    (HsTupleTy con tys) = tupleParens con (interpp'SP tys)
 ppr_mono_ty _    (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind)
 ppr_mono_ty _    (HsListTy ty)	     = brackets (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPArrTy ty)	     = pabrackets (ppr_mono_lty pREC_TOP ty)
+ppr_mono_ty _    (HsModalBoxType ecn ty) = ppr_modalBoxType (ppr ecn) (ppr_mono_lty pREC_TOP ty)
 ppr_mono_ty _    (HsPredTy pred)     = ppr pred
 ppr_mono_ty _    (HsNumTy n)         = integer n  -- generics only
 ppr_mono_ty _    (HsSpliceTy s _ _)  = pprSplice s
+ppr_mono_ty _    (HsCoreTy ty)       = ppr ty
 
 ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
   = maybeParen ctxt_prec pREC_CON $
@@ -463,6 +479,10 @@ ppr_fun_ty ctxt_prec ty1 ty2
 --------------------------
 pabrackets :: SDoc -> SDoc
 pabrackets p = ptext (sLit "[:") <> p <> ptext (sLit ":]")
+
+ppr_modalBoxType :: SDoc -> SDoc -> SDoc
+ppr_modalBoxType ecn p = ptext (sLit "<[") <> p <> ptext (sLit "]>@") <> ecn 
+
 \end{code}