Commit 1a9245ca authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Add HsCoreTy to HsType

The main thing here is to allow us to provide type
signatures for 'deriving' bindings without pain.
parent c27e722f
......@@ -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 $
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment