X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsTypes.lhs;h=a5e89828265f0913f91f9f3369b204198c82b0da;hp=2e2eaabccf92f0fda7ab63a5a82cc6213ebc4be1;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=836b1e90821aacc9d1e09fe78085f911597274c8

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 2e2eaab..a5e8982 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -6,6 +6,8 @@
 HsTypes: Abstract syntax: user-defined types
 
 \begin{code}
+{-# LANGUAGE DeriveDataTypeable #-}
+
 module HsTypes (
 	HsType(..), LHsType, 
 	HsTyVarBndr(..), LHsTyVarBndr,
@@ -42,6 +44,8 @@ import SrcLoc
 import StaticFlags
 import Outputable
 import FastString
+
+import Data.Data
 \end{code}
 
 
@@ -76,6 +80,7 @@ data HsQuasiQuote id = HsQuasiQuote
 		       	   id		-- The quasi-quoter
 		       	   SrcSpan	-- The span of the enclosed string
 		       	   FastString	-- The enclosed string
+  deriving (Data, Typeable)
 
 instance OutputableBndr id => Outputable (HsQuasiQuote id) where
     ppr = ppr_qq
@@ -97,16 +102,6 @@ ppr_qq (HsQuasiQuote quoter _ quote) =
 type LBangType name = Located (BangType name)
 type BangType name  = HsType name	-- Bangs are in the HsType data type
 
-data HsBang = HsNoBang	-- Only used as a return value for getBangStrictness,
-			-- never appears on a HsBangTy
-	    | HsStrict	-- ! 
-	    | HsUnbox	-- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
-
-instance Outputable HsBang where
-    ppr (HsNoBang) = empty
-    ppr (HsStrict) = char '!'
-    ppr (HsUnbox)  = ptext (sLit "!!")
-
 getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
 getBangType ty                    = ty
@@ -135,6 +130,7 @@ type LHsPred name = Located (HsPred name)
 data HsPred name = HsClassP name [LHsType name]		 -- class constraint
 		 | HsEqualP (LHsType name) (LHsType name)-- equality constraint
 		 | HsIParam (IPName name) (LHsType name)
+		 deriving (Data, Typeable)
 
 type LHsType name = Located (HsType name)
 
@@ -179,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
@@ -195,13 +191,18 @@ data HsType name
   | HsBangTy	HsBang (LHsType name)	-- Bang-style type annotations 
   | HsRecTy [ConDeclField name]	        -- Only in data type declarations
 
-data HsExplicitFlag = Explicit | Implicit
+  | HsCoreTy Type	-- An escape hatch for tunnelling a *closed* 
+    	       		-- Core Type through HsSyn.  
+					 
+  deriving (Data, Typeable)
+
+data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
 
 data ConDeclField name	-- Record fields have Haddoc docs on them
   = ConDeclField { cd_fld_name :: Located name,
 		   cd_fld_type :: LBangType name, 
 		   cd_fld_doc  :: Maybe LHsDocString }
-
+  deriving (Data, Typeable)
 
 -----------------------
 -- Combine adjacent for-alls. 
@@ -257,6 +258,7 @@ data HsTyVarBndr name
       --  *** NOTA BENE *** A "monotype" in a pragma can have
       -- for-alls in it, (mostly to do with dictionaries).  These
       -- must be explicitly Kinded.
+  deriving (Data, Typeable)
 
 hsTyVarName :: HsTyVarBndr name -> name
 hsTyVarName (UserTyVar n _)   = n
@@ -355,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
@@ -432,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 $