summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
c27e722)
The main thing here is to allow us to provide type
signatures for 'deriving' bindings without pain.
-- ^^^^
-- HsPredTy
-- Note no need for location info on the
-- ^^^^
-- 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
| HsKindSig (LHsType name) -- (ty :: kind)
Kind -- A type with a kind signature
| HsBangTy HsBang (LHsType name) -- Bang-style type annotations
| HsRecTy [ConDeclField name] -- Only in data type declarations
| 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)
deriving (Data, Typeable)
data HsExplicitFlag = Explicit | Implicit deriving (Data, Typeable)
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 _ (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 $
ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)
= maybeParen ctxt_prec pREC_CON $
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
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
+ 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
HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
HsSpliceTy {} -> acc -- Type splices mention no type variables
HsKindSig ty _ -> extract_lty ty acc
`minusNameSet`
mkNameSet (hsLTyVarNames tvs)
get (HsDocTy ty _) = getl 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
extractHsTyNames_s :: [LHsType Name] -> NameSet
extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq
; rnHsType doc (unLoc ty) }
#endif
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
rnLHsTypes :: SDoc -> [LHsType RdrName]
-> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
rnLHsTypes doc tys = mapM (rnLHsType doc) tys
genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
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
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
lots_of_constructors = tyConFamilySize tycon > 8
-- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
(mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
(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)))
- 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,
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
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)
rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
mk_constr_name :: DataCon -> RdrName -- "$cC"
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
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}
%************************************************************************
\end{code}
%************************************************************************
kc_hs_type (HsPredTy pred)
= wrongPredErr pred
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
kc_hs_type (HsForAllTy exp tv_names context ty)
= kcHsTyVars tv_names $ \ tv_names' ->
do { ctxt' <- kcHsContext context
; newFlexiTyVarTy kind' }
ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer
; 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
dsHsTypes :: [LHsType Name] -> TcM [Type]
dsHsTypes arg_tys = mapM dsHsType arg_tys