From 1a9245caefb80a3c4c5965aaacdf9a607e792e1c Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 24 Aug 2010 14:18:45 +0000 Subject: [PATCH 1/1] Add HsCoreTy to HsType The main thing here is to allow us to provide type signatures for 'deriving' bindings without pain. --- compiler/hsSyn/HsTypes.lhs | 7 ++++++- compiler/parser/RdrHsSyn.lhs | 3 ++- compiler/rename/RnHsSyn.lhs | 2 ++ compiler/rename/RnTypes.lhs | 2 ++ compiler/typecheck/TcGenDeriv.lhs | 34 +++++++++++++++------------------- compiler/typecheck/TcHsType.lhs | 4 ++++ 6 files changed, 31 insertions(+), 21 deletions(-) diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 806faf2..a5e8982 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 149eae4..7d806ed 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 60e0823..9226cb4 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 e2897ee..b275d2d 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 2c0b89d..525f095 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 62c5eaa..fcf329b 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 -- 1.7.10.4