Add HsCoreTy to HsType

[ghc-hetmet.git] / compiler / hsSyn / HsTypes.lhs

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index cb06a7f..a5e8982 100644 (file)
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -175,7 +175,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 +190,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 +357,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 <+> ptext (sLit "=>")
+pprHsContext cxt        = ppr_hs_context cxt <+> ptext (sLit "=>")
+
+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
@@ -430,6 +442,7 @@ ppr_mono_ty _    (HsPArrTy ty)           = pabrackets (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 $