Add HsCoreTy to HsType

The main thing here is to allow us to provide type
signatures for 'deriving' bindings without pain.

6 files changed, 31 insertions, 21 deletions

diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 806faf29dc..a5e8982826 100644
--- 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)
@@ -438,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 $
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 149eae4723..7d806ed174 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -127,7 +127,8 @@ extract_lty (L loc ty) acc
       HsPredTy p		-> extract_pred p acc
       HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc))
       HsParTy ty               	-> extract_lty ty acc
-      HsNumTy _                 -> acc
+      HsNumTy {}                -> acc
+      HsCoreTy {}               -> acc  -- The type is closed
       HsQuasiQuoteTy {}	        -> acc  -- Quasi quotes mention no type variables
       HsSpliceTy {}           	-> acc	-- Type splices mention no type variables
       HsKindSig ty _            -> extract_lty ty acc
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
index 60e0823802..9226cb4668 100644
--- a/compiler/rename/RnHsSyn.lhs
+++ b/compiler/rename/RnHsSyn.lhs
@@ -77,6 +77,8 @@ extractHsTyNames ty
                                             `minusNameSet`
                                   mkNameSet (hsLTyVarNames tvs)
     get (HsDocTy ty _)         = getl ty
+    get (HsCoreTy {})          = emptyNameSet	-- This probably isn't quite right
+    		  	       	 		-- but I don't think it matters
 
 extractHsTyNames_s  :: [LHsType Name] -> NameSet
 extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index e2897ee41f..b275d2df40 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -200,7 +200,9 @@ rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHC
 rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
                                       ; rnHsType doc (unLoc ty) }
 #endif
+rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty)
 
+--------------
 rnLHsTypes :: SDoc -> [LHsType RdrName]
            -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
 rnLHsTypes doc tys = mapM (rnLHsType doc) tys
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 2c0b89df08..525f0950b0 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -1662,12 +1662,13 @@ fiddling around.
 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
 genAuxBind loc (GenCon2Tag tycon)
   = (mk_FunBind loc rdr_name eqns, 
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
     rdr_name = con2tag_RDR tycon
 
-    sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
-             hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
+    sig_ty = HsCoreTy $ 
+             mkForAllTys (tyConTyVars tycon) $
+             mkParentType tycon `mkFunTy` intPrimTy
 
     lots_of_constructors = tyConFamilySize tycon > 8
                         -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
@@ -1687,19 +1688,18 @@ genAuxBind loc (GenTag2Con tycon)
     (mk_FunBind loc rdr_name 
 	[([nlConVarPat intDataCon_RDR [a_RDR]], 
 	   nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
-    sig_ty = nlHsTyVar (getRdrName intTyCon) 
-             `nlHsFunTy` (nlHsTyVar (getRdrName tycon))
+    sig_ty = HsCoreTy $ intTy `mkFunTy` mkParentType tycon
 
     rdr_name = tag2con_RDR tycon
 
 genAuxBind loc (GenMaxTag tycon)
   = (mkHsVarBind loc rdr_name rhs,
-     L loc (TypeSig (L loc rdr_name) sig_ty))
+     L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
   where
     rdr_name = maxtag_RDR tycon
-    sig_ty = nlHsTyVar (getRdrName intTyCon) 
+    sig_ty = HsCoreTy intTy
     rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
     max_tag =  case (tyConDataCons tycon) of
 		 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
@@ -1743,17 +1743,13 @@ mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
 mk_constr_name :: DataCon -> RdrName	-- "$cC"
 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
 
-genForAllTy :: SrcSpan -> TyCon
-            -> (LHsType RdrName -> LHsType RdrName)
-            -> LHsType RdrName
--- Wrap a forall type for the variables of the TyCOn
-genForAllTy loc tc thing_inside
-  = L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
-    thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
-  where
-    tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
-	-- We can't use getRdrName because that makes an Exact RdrName
-	-- and we can't put them in the LocalRdrEnv
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+  = case tyConFamInst_maybe tc of
+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index 62c5eaacd5..fcf329b8cb 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -394,6 +394,9 @@ kc_hs_type (HsAppTy ty1 ty2) = do
 kc_hs_type (HsPredTy pred)
   = wrongPredErr pred
 
+kc_hs_type (HsCoreTy ty)
+  = return (HsCoreTy ty, typeKind ty)
+
 kc_hs_type (HsForAllTy exp tv_names context ty)
   = kcHsTyVars tv_names         $ \ tv_names' ->
     do	{ ctxt' <- kcHsContext context
@@ -628,6 +631,7 @@ ds_type (HsSpliceTy _ _ kind)
        ; newFlexiTyVarTy kind' }
 
 ds_type (HsQuasiQuoteTy {}) = panic "ds_type"	-- Eliminated by renamer
+ds_type (HsCoreTy ty)       = return ty
 
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 dsHsTypes arg_tys = mapM dsHsType arg_tys