Commit fc8959ac authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor LHsTyVarBndrs to fix Trac #6081

This is really a small change, but it touches a lot of files quite
significantly. The real goal is to put the implicitly-bound kind
variables of a data/class decl in the right place, namely on the
LHsTyVarBndrs type, which now looks like

  data LHsTyVarBndrs name
    = HsQTvs { hsq_kvs :: [Name]
             , hsq_tvs :: [LHsTyVarBndr name]
      }

This little change made the type checker neater in a number of
ways, but it was fiddly to push through the changes.
parent c1e928e4
...@@ -150,7 +150,8 @@ repTopDs group ...@@ -150,7 +150,8 @@ repTopDs group
hsSigTvBinders :: HsValBinds Name -> [Name] hsSigTvBinders :: HsValBinds Name -> [Name]
-- See Note [Scoped type variables in bindings] -- See Note [Scoped type variables in bindings]
hsSigTvBinders binds hsSigTvBinders binds
= [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit tvs _ _))) <- sigs, tv <- tvs] = [hsLTyVarName tv | L _ (TypeSig _ (L _ (HsForAllTy Explicit qtvs _ _))) <- sigs
, tv <- hsQTvBndrs qtvs]
where where
sigs = case binds of sigs = case binds of
ValBindsIn _ sigs -> sigs ValBindsIn _ sigs -> sigs
...@@ -214,8 +215,7 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour, ...@@ -214,8 +215,7 @@ repTyClD (L loc (TyFamily { tcdFlavour = flavour,
do { flav <- repFamilyFlavour flavour do { flav <- repFamilyFlavour flavour
; case opt_kind of ; case opt_kind of
Nothing -> repFamilyNoKind flav tc1 bndrs Nothing -> repFamilyNoKind flav tc1 bndrs
Just (HsBSig ki _) Just ki -> do { ki1 <- repKind ki
-> do { ki1 <- repKind ki
; repFamilyKind flav tc1 bndrs ki1 } ; repFamilyKind flav tc1 bndrs ki1 }
} }
; return $ Just (loc, dec) ; return $ Just (loc, dec)
...@@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty }) ...@@ -272,15 +272,15 @@ repTyDefn tc bndrs opt_tys _ (TySynonym { td_synRhs = ty })
; repTySyn tc bndrs opt_tys ty1 } ; repTySyn tc bndrs opt_tys ty1 }
------------------------- -------------------------
mk_extra_tvs :: Located Name -> [LHsTyVarBndr Name] mk_extra_tvs :: Located Name -> LHsTyVarBndrs Name
-> HsTyDefn Name -> DsM [LHsTyVarBndr Name] -> HsTyDefn Name -> DsM (LHsTyVarBndrs Name)
-- If there is a kind signature it must be of form -- If there is a kind signature it must be of form
-- k1 -> .. -> kn -> * -- k1 -> .. -> kn -> *
-- Return type variables [tv1:k1, tv2:k2, .., tvn:kn] -- Return type variables [tv1:k1, tv2:k2, .., tvn:kn]
mk_extra_tvs tc tvs defn mk_extra_tvs tc tvs defn
| TyData { td_kindSig = Just (HsBSig hs_kind _) } <- defn | TyData { td_kindSig = Just hs_kind } <- defn
= do { extra_tvs <- go hs_kind = do { extra_tvs <- go hs_kind
; return (tvs ++ extra_tvs) } ; return (mkHsQTvs (hsQTvBndrs tvs ++ extra_tvs)) }
| otherwise | otherwise
= return tvs = return tvs
where where
...@@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn ...@@ -289,7 +289,7 @@ mk_extra_tvs tc tvs defn
= do { uniq <- newUnique = do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t") ; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc ; nm = mkInternalName uniq occ loc
; hs_tv = L loc (KindedTyVar nm (mkHsBSig kind)) } ; hs_tv = L loc (KindedTyVar nm kind) }
; hs_tvs <- go rest ; hs_tvs <- go rest
; return (hs_tv : hs_tvs) } ; return (hs_tv : hs_tvs) }
...@@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds ...@@ -340,7 +340,7 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
-- the selector Ids, not to fresh names (Trac #5410) -- the selector Ids, not to fresh names (Trac #5410)
-- --
do { cxt1 <- repContext cxt do { cxt1 <- repContext cxt
; cls_tcon <- repTy (HsTyVar cls) ; cls_tcon <- repTy (HsTyVar (unLoc cls))
; cls_tys <- repLTys tys ; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys ; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds ; binds1 <- rep_binds binds
...@@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds ...@@ -350,17 +350,17 @@ repInstD (L loc (ClsInstD { cid_poly_ty = ty, cid_binds = binds
; repInst cxt1 inst_ty1 decls } ; repInst cxt1 inst_ty1 decls }
; return (loc, dec) } ; return (loc, dec) }
where where
Just (tvs, cxt, cls, tys) = splitHsInstDeclTy_maybe (unLoc ty) Just (tvs, cxt, cls, tys) = splitLHsInstDeclTy_maybe ty
repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ) repFamInstD :: FamInstDecl Name -> DsM (Core TH.DecQ)
repFamInstD (FamInstDecl { fid_tycon = tc_name repFamInstD (FamInstDecl { fid_tycon = tc_name
, fid_pats = HsBSig tys (kv_names, tv_names) , fid_pats = HsWB { hswb_cts = tys, hswb_kvs = kv_names, hswb_tvs = tv_names }
, fid_defn = defn }) , fid_defn = defn })
= WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind = WARN( not (null kv_names), ppr kv_names ) -- We have not yet dealt with kind
-- polymorphism in Template Haskell (sigh) -- polymorphism in Template Haskell (sigh)
do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences]
; let loc = getLoc tc_name ; let loc = getLoc tc_name
hs_tvs = [ L loc (UserTyVar n) | n <- tv_names] -- Yuk hs_tvs = mkHsQTvs (userHsTyVarBndrs loc tv_names) -- Yuk
; addTyClTyVarBinds hs_tvs $ \ bndrs -> ; addTyClTyVarBinds hs_tvs $ \ bndrs ->
do { tys1 <- repLTys tys do { tys1 <- repLTys tys
; tys2 <- coreList typeQTyConName tys1 ; tys2 <- coreList typeQTyConName tys1
...@@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") ...@@ -419,8 +419,9 @@ ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:")
------------------------------------------------------- -------------------------------------------------------
repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ)
repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] repC _ (L _ (ConDecl { con_name = con, con_qvars = con_tvs, con_cxt = L _ []
, con_details = details, con_res = ResTyH98 })) , con_details = details, con_res = ResTyH98 }))
| null (hsQTvBndrs con_tvs)
= do { con1 <- lookupLOcc con -- See note [Binders and occurrences] = do { con1 <- lookupLOcc con -- See note [Binders and occurrences]
; repConstr con1 details } ; repConstr con1 details }
repC tvs (L _ (ConDecl { con_name = con repC tvs (L _ (ConDecl { con_name = con
...@@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con ...@@ -428,7 +429,7 @@ repC tvs (L _ (ConDecl { con_name = con
, con_details = details , con_details = details
, con_res = res_ty })) , con_res = res_ty }))
= do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty
; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] ; let ex_tvs = mkHsQTvs [ tv | tv <- hsQTvBndrs con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)]
; binds <- mapM dupBinder con_tv_subst ; binds <- mapM dupBinder con_tv_subst
; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs
addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs
...@@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm ...@@ -552,7 +553,7 @@ rep_ty_sig loc (L _ ty) nm
rep_ty (HsForAllTy Explicit tvs ctxt ty) rep_ty (HsForAllTy Explicit tvs ctxt ty)
= do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) = do { let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)
; repTyVarBndrWithKind tv name } ; repTyVarBndrWithKind tv name }
; bndrs1 <- mapM rep_in_scope_tv tvs ; bndrs1 <- mapM rep_in_scope_tv (hsQTvBndrs tvs)
; bndrs2 <- coreList tyVarBndrTyConName bndrs1 ; bndrs2 <- coreList tyVarBndrTyConName bndrs1
; ctxt1 <- repLContext ctxt ; ctxt1 <- repLContext ctxt
; ty1 <- repLTy ty ; ty1 <- repLTy ty
...@@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin ...@@ -616,7 +617,7 @@ rep_InlinePrag (InlinePragma { inl_act = activation, inl_rule = match, inl_inlin
-- Types -- Types
------------------------------------------------------- -------------------------------------------------------
addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added addTyVarBinds :: LHsTyVarBndrs Name -- the binders to be added
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -- action in the ext env
-> DsM (Core (TH.Q a)) -> DsM (Core (TH.Q a))
-- gensym a list of type variables and enter them into the meta environment; -- gensym a list of type variables and enter them into the meta environment;
...@@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be ...@@ -626,14 +627,14 @@ addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be
addTyVarBinds tvs m addTyVarBinds tvs m
= do { freshNames <- mkGenSyms (hsLTyVarNames tvs) = do { freshNames <- mkGenSyms (hsLTyVarNames tvs)
; term <- addBinds freshNames $ ; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr (tvs `zip` freshNames) do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs `zip` freshNames)
; kbs2 <- coreList tyVarBndrTyConName kbs1 ; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 } ; m kbs2 }
; wrapGenSyms freshNames term } ; wrapGenSyms freshNames term }
where where
mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)
addTyClTyVarBinds :: [LHsTyVarBndr Name] addTyClTyVarBinds :: LHsTyVarBndrs Name
-> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a))) -> (Core [TH.TyVarBndr] -> DsM (Core (TH.Q a)))
-> DsM (Core (TH.Q a)) -> DsM (Core (TH.Q a))
...@@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m ...@@ -650,7 +651,7 @@ addTyClTyVarBinds tvs m
-- This makes things work for family declarations -- This makes things work for family declarations
; term <- addBinds freshNames $ ; term <- addBinds freshNames $
do { kbs1 <- mapM mk_tv_bndr tvs do { kbs1 <- mapM mk_tv_bndr (hsQTvBndrs tvs)
; kbs2 <- coreList tyVarBndrTyConName kbs1 ; kbs2 <- coreList tyVarBndrTyConName kbs1
; m kbs2 } ; m kbs2 }
...@@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name ...@@ -665,7 +666,7 @@ repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr) -> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm repTyVarBndrWithKind (L _ (UserTyVar {})) nm
= repPlainTV nm = repPlainTV nm
repTyVarBndrWithKind (L _ (KindedTyVar _ (HsBSig ki _))) nm repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
= repKind ki >>= repKindedTV nm = repKind ki >>= repKindedTV nm
-- represent a type context -- represent a type context
......
...@@ -275,7 +275,7 @@ cvt_ci_decs doc decs ...@@ -275,7 +275,7 @@ cvt_ci_decs doc decs
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
-> CvtM ( LHsContext RdrName -> CvtM ( LHsContext RdrName
, Located RdrName , Located RdrName
, [LHsTyVarBndr RdrName]) , LHsTyVarBndrs RdrName)
cvt_tycl_hdr cxt tc tvs cvt_tycl_hdr cxt tc tvs
= do { cxt' <- cvtContext cxt = do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc ; tc' <- tconNameL tc
...@@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs ...@@ -286,12 +286,12 @@ cvt_tycl_hdr cxt tc tvs
cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type]
-> CvtM ( LHsContext RdrName -> CvtM ( LHsContext RdrName
, Located RdrName , Located RdrName
, HsBndrSig [LHsType RdrName]) , HsWithBndrs [LHsType RdrName])
cvt_tyinst_hdr cxt tc tys cvt_tyinst_hdr cxt tc tys
= do { cxt' <- cvtContext cxt = do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc ; tc' <- tconNameL tc
; tys' <- mapM cvtType tys ; tys' <- mapM cvtType tys
; return (cxt', tc', mkHsBSig tys') } ; return (cxt', tc', mkHsWithBndrs tys') }
------------------------------------------------------------------- -------------------------------------------------------------------
-- Partitioning declarations -- Partitioning declarations
...@@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con) ...@@ -348,7 +348,7 @@ cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs = do { tvs' <- cvtTvs tvs
; L loc ctxt' <- cvtContext ctxt ; L loc ctxt' <- cvtContext ctxt
; L _ con' <- cvtConstr con ; L _ con' <- cvtConstr con
; returnL $ con' { con_qvars = tvs' ++ con_qvars con' ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con'))
, con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
...@@ -759,7 +759,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ...@@ -759,7 +759,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) }
cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void }
cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t
; return $ SigPatIn p' (mkHsBSig t') } ; return $ SigPatIn p' (mkHsWithBndrs t') }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName)) cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
...@@ -784,8 +784,8 @@ cvtOpAppP x op y ...@@ -784,8 +784,8 @@ cvtOpAppP x op y
----------------------------------------------------------- -----------------------------------------------------------
-- Types and type variables -- Types and type variables
cvtTvs :: [TH.TyVarBndr] -> CvtM [LHsTyVarBndr RdrName] cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName)
cvtTvs tvs = mapM cvt_tv tvs cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm) cvt_tv (TH.PlainTV nm)
...@@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm) ...@@ -794,7 +794,7 @@ cvt_tv (TH.PlainTV nm)
cvt_tv (TH.KindedTV nm ki) cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm = do { nm' <- tName nm
; ki' <- cvtKind ki ; ki' <- cvtKind ki
; returnL $ KindedTyVar nm' (mkHsBSig ki') } ; returnL $ KindedTyVar nm' ki' }
cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName) cvtContext :: TH.Cxt -> CvtM (LHsContext RdrName)
cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' } cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
...@@ -845,7 +845,7 @@ cvtType ty ...@@ -845,7 +845,7 @@ cvtType ty
-> do { tvs' <- cvtTvs tvs -> do { tvs' <- cvtTvs tvs
; cxt' <- cvtContext cxt ; cxt' <- cvtContext cxt
; ty' <- cvtType ty ; ty' <- cvtType ty
; returnL $ mkExplicitHsForAllTy tvs' cxt' ty' ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty'
} }
SigT ty ki SigT ty ki
...@@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do ...@@ -875,10 +875,10 @@ cvtKind (ArrowK k1 k2) = do
k2' <- cvtKind k2 k2' <- cvtKind k2
returnL (HsFunTy k1' k2') returnL (HsFunTy k1' k2')
cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (HsBndrSig (LHsKind RdrName))) cvtMaybeKind :: Maybe TH.Kind -> CvtM (Maybe (LHsKind RdrName))
cvtMaybeKind Nothing = return Nothing cvtMaybeKind Nothing = return Nothing
cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki cvtMaybeKind (Just ki) = do { ki' <- cvtKind ki
; return (Just (mkHsBSig ki')) } ; return (Just ki') }
----------------------------------------------------------- -----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity cvtFixity :: TH.Fixity -> Hs.Fixity
......
...@@ -428,20 +428,20 @@ data TyClDecl name ...@@ -428,20 +428,20 @@ data TyClDecl name
| -- | @type/data family T :: *->*@ | -- | @type/data family T :: *->*@
TyFamily { tcdFlavour :: FamilyFlavour, -- type or data TyFamily { tcdFlavour :: FamilyFlavour, -- type or data
tcdLName :: Located name, -- type constructor tcdLName :: Located name, -- type constructor
tcdTyVars :: [LHsTyVarBndr name], -- type variables tcdTyVars :: LHsTyVarBndrs name, -- type variables
tcdKindSig :: Maybe (HsBndrSig (LHsKind name)) -- result kind tcdKindSig :: Maybe (LHsKind name) -- result kind
} }
| -- | @type/data declaration | -- | @type/data declaration
TyDecl { tcdLName :: Located name -- ^ Type constructor TyDecl { tcdLName :: Located name -- ^ Type constructor
, tcdTyVars :: [LHsTyVarBndr name] , tcdTyVars :: LHsTyVarBndrs name
, tcdTyDefn :: HsTyDefn name , tcdTyDefn :: HsTyDefn name
, tcdFVs :: NameSet } , tcdFVs :: NameSet }
| ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context...
tcdLName :: Located name, -- ^ Name of the class tcdLName :: Located name, -- ^ Name of the class
tcdTyVars :: [LHsTyVarBndr name], -- ^ Class type variables tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables
tcdFDs :: [Located (FunDep name)], -- ^ Functional deps tcdFDs :: [Located (FunDep name)], -- ^ Functional deps
tcdSigs :: [LSig name], -- ^ Methods' signatures tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods tcdMeths :: LHsBinds name, -- ^ Default methods
...@@ -468,7 +468,7 @@ data HsTyDefn name -- The payload of a type synonym or data type defn ...@@ -468,7 +468,7 @@ data HsTyDefn name -- The payload of a type synonym or data type defn
TyData { td_ND :: NewOrData, TyData { td_ND :: NewOrData,
td_ctxt :: LHsContext name, -- ^ Context td_ctxt :: LHsContext name, -- ^ Context
td_cType :: Maybe CType, td_cType :: Maybe CType,
td_kindSig:: Maybe (HsBndrSig (LHsKind name)), td_kindSig:: Maybe (LHsKind name),
-- ^ Optional kind signature. -- ^ Optional kind signature.
-- --
-- @(Just k)@ for a GADT-style @data@, or @data -- @(Just k)@ for a GADT-style @data@, or @data
...@@ -619,18 +619,18 @@ instance OutputableBndr name ...@@ -619,18 +619,18 @@ instance OutputableBndr name
pp_vanilla_decl_head :: OutputableBndr name pp_vanilla_decl_head :: OutputableBndr name
=> Located name => Located name
-> [LHsTyVarBndr name] -> LHsTyVarBndrs name
-> HsContext name -> HsContext name
-> SDoc -> SDoc
pp_vanilla_decl_head thing tyvars context pp_vanilla_decl_head thing tyvars context
= hsep [pprHsContext context, pprPrefixOcc (unLoc thing), interppSP tyvars] = hsep [pprHsContext context, pprPrefixOcc (unLoc thing), ppr tyvars]
pp_fam_inst_head :: OutputableBndr name pp_fam_inst_head :: OutputableBndr name
=> Located name => Located name
-> HsBndrSig [LHsType name] -> HsWithBndrs [LHsType name]
-> HsContext name -> HsContext name
-> SDoc -> SDoc
pp_fam_inst_head thing (HsBSig typats _) context -- explicit type patterns pp_fam_inst_head thing (HsWB { hswb_cts = typats }) context -- explicit type patterns
= hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing) = hsep [ ptext (sLit "instance"), pprHsContext context, pprPrefixOcc (unLoc thing)
, hsep (map (pprParendHsType.unLoc) typats)] , hsep (map (pprParendHsType.unLoc) typats)]
...@@ -661,7 +661,7 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context ...@@ -661,7 +661,7 @@ pp_ty_defn pp_hdr (TyData { td_ND = new_or_data, td_ctxt = L _ context
where where
pp_sig = case mb_sig of pp_sig = case mb_sig of
Nothing -> empty Nothing -> empty
Just (HsBSig kind _) -> dcolon <+> ppr kind Just kind -> dcolon <+> ppr kind
pp_derivings = case derivings of pp_derivings = case derivings of
Nothing -> empty Nothing -> empty
Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)] Just ds -> hsep [ptext (sLit "deriving"), parens (interpp'SP ds)]
...@@ -715,7 +715,7 @@ data ConDecl name ...@@ -715,7 +715,7 @@ data ConDecl name
, con_explicit :: HsExplicitFlag , con_explicit :: HsExplicitFlag
-- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy')
, con_qvars :: [LHsTyVarBndr name] , con_qvars :: LHsTyVarBndrs name
-- ^ Type variables. Depending on 'con_res' this describes the -- ^ Type variables. Depending on 'con_res' this describes the
-- following entities -- following entities
-- --
...@@ -808,7 +808,7 @@ type LFamInstDecl name = Located (FamInstDecl name) ...@@ -808,7 +808,7 @@ type LFamInstDecl name = Located (FamInstDecl name)
data FamInstDecl name data FamInstDecl name
= FamInstDecl = FamInstDecl
{ fid_tycon :: Located name { fid_tycon :: Located name
, fid_pats :: HsBndrSig [LHsType name] -- ^ Type patterns (with bndrs) , fid_pats :: HsWithBndrs [LHsType name] -- ^ Type patterns (with kind and type bndrs)
, fid_defn :: HsTyDefn name -- Type or data family instance , fid_defn :: HsTyDefn name -- Type or data family instance
, fid_fvs :: NameSet } , fid_fvs :: NameSet }
deriving( Typeable, Data ) deriving( Typeable, Data )
...@@ -1060,10 +1060,10 @@ data RuleDecl name ...@@ -1060,10 +1060,10 @@ data RuleDecl name
data RuleBndr name data RuleBndr name
= RuleBndr (Located name) = RuleBndr (Located name)
| RuleBndrSig (Located name) (HsBndrSig (LHsType name)) | RuleBndrSig (Located name) (HsWithBndrs (LHsType name))
deriving (Data, Typeable) deriving (Data, Typeable)
collectRuleBndrSigTys :: [RuleBndr name] -> [HsBndrSig (LHsType name)] collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs (LHsType name)]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
instance OutputableBndr name => Outputable (RuleDecl name) where instance OutputableBndr name => Outputable (RuleDecl name) where
......
...@@ -132,7 +132,7 @@ data Pat id ...@@ -132,7 +132,7 @@ data Pat id
------------ Pattern type signatures --------------- ------------ Pattern type signatures ---------------
| SigPatIn (LPat id) -- Pattern with a type signature | SigPatIn (LPat id) -- Pattern with a type signature
(HsBndrSig (LHsType id)) (HsWithBndrs (LHsType id)) -- Signature can bind both kind and type vars
| SigPatOut (LPat id) -- Pattern with a type signature | SigPatOut (LPat id) -- Pattern with a type signature
Type Type
......
...@@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types ...@@ -17,7 +17,9 @@ HsTypes: Abstract syntax: user-defined types
module HsTypes ( module HsTypes (
HsType(..), LHsType, HsKind, LHsKind, HsType(..), LHsType, HsKind, LHsKind,
HsBndrSig(..), HsTyVarBndr(..), LHsTyVarBndr, HsTyVarBndr(..), LHsTyVarBndr,
LHsTyVarBndrs(..),
HsWithBndrs(..),
HsTupleSort(..), HsExplicitFlag(..), HsTupleSort(..), HsExplicitFlag(..),
HsContext, LHsContext, HsContext, LHsContext,
HsQuasiQuote(..), HsQuasiQuote(..),
...@@ -29,15 +31,14 @@ module HsTypes ( ...@@ -29,15 +31,14 @@ module HsTypes (
ConDeclField(..), pprConDeclFields, ConDeclField(..), pprConDeclFields,
mkHsQTvs, hsQTvBndrs,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, hsTyVarName, hsTyVarNames, mkHsWithBndrs,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe, splitLHsInstDeclTy_maybe,
splitHsForAllTy, splitLHsForAllTy,
splitHsClassTy_maybe, splitLHsClassTy_maybe, splitHsClassTy_maybe, splitLHsClassTy_maybe,
splitHsFunType, splitHsFunType,
splitHsAppTys, mkHsAppTys, mkHsOpTy, splitHsAppTys, mkHsAppTys, mkHsOpTy,
placeHolderBndrs,
-- Printing -- Printing
pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context,
...@@ -112,6 +113,17 @@ getBangStrictness _ = HsNoBang ...@@ -112,6 +113,17 @@ getBangStrictness _ = HsNoBang
This is the syntax for types as seen in type signatures. This is the syntax for types as seen in type signatures.
Note [HsBSig binder lists]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider a binder (or pattern) decoarated with a type or kind,
\ (x :: a -> a). blah
forall (a :: k -> *) (b :: k). blah
Then we use a LHsBndrSig on the binder, so that the
renamer can decorate it with the variables bound
by the pattern ('a' in the first example, 'k' in the second),
assuming that neither of them is in scope already
See also Note [Kind and type-variable binders] in RnTypes
\begin{code} \begin{code}
type LHsContext name = Located (HsContext name) type LHsContext name = Located (HsContext name)
...@@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name) ...@@ -123,29 +135,29 @@ type LHsKind name = Located (HsKind name)
type LHsTyVarBndr name = Located (HsTyVarBndr name) type LHsTyVarBndr name = Located (HsTyVarBndr name)
data HsBndrSig sig data LHsTyVarBndrs name
= HsBSig = HsQTvs { hsq_kvs :: [Name] -- Kind variables
sig -- The signature; typically a type , hsq_tvs :: [LHsTyVarBndr name] -- Type variables
([Name], [Name]) -- The *binding* (kind, type) names of -- See Note [HsForAllTy tyvar binders]
-- this signature }
-- See Note [HsBSig binder lists] deriving( Data, Typeable )
mkHsQTvs :: [LHsTyVarBndr name] -> LHsTyVarBndrs name
mkHsQTvs tvs = HsQTvs { hsq_kvs = panic "mkHsQTvs", hsq_tvs = tvs }
hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name]
hsQTvBndrs = hsq_tvs
data HsWithBndrs thing
= HsWB { hswb_cts :: thing -- Main payload (type or list of types)
, hswb_kvs :: [Name] -- Kind vars
, hswb_tvs :: [Name] -- Type vars
}
deriving (Data, Typeable) deriving (Data, Typeable)
-- Note [HsBSig binder lists] mkHsWithBndrs :: thing -> HsWithBndrs thing
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = panic "mkHsTyWithBndrs:kvs"
-- Consider a binder (or pattern) decoarated with a type or kind, , hswb_tvs = panic "mkHsTyWithBndrs:tvs" }
-- \ (x :: a -> a). blah
-- forall (a :: k -> *) (b :: k). blah
-- Then we use a LHsBndrSig on the binder, so that the
-- renamer can decorate it with the variables bound
-- by the pattern ('a' in the first example, 'k' in the second),
-- assuming that neither of them is in scope already
-- See also Note [Kind and type-variable binders] in RnTypes
placeHolderBndrs :: [Name]
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderBndrs = panic "placeHolderBndrs"
data HsTyVarBndr name data HsTyVarBndr name
= UserTyVar -- No explicit kinding