summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.hs8
-rw-r--r--compiler/rename/RnSource.hs165
-rw-r--r--compiler/rename/RnTypes.hs19
-rw-r--r--compiler/rename/RnUtils.hs2
4 files changed, 145 insertions, 49 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 811a81bdb1..56caee1a2a 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -973,7 +973,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
; when (is_deflt && not defaultSigs_on) $
addErr (defaultSigErr sig)
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
- ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty
+ ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }
where
(v1:_) = vs
@@ -981,7 +981,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)
<+> quotes (ppr v1))
renameSig _ (SpecInstSig _ src ty)
- = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty
+ = do { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx TypeLevel ty
; return (SpecInstSig noExtField src new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
@@ -998,7 +998,7 @@ renameSig ctxt sig@(SpecSig _ v tys inl)
ty_ctxt = GenericCtx (text "a SPECIALISE signature for"
<+> quotes (ppr v))
do_one (tys,fvs) ty
- = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty
+ = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt TypeLevel ty
; return ( new_ty:tys, fvs_ty `plusFV` fvs) }
renameSig ctxt sig@(InlineSig _ v s)
@@ -1015,7 +1015,7 @@ renameSig ctxt sig@(MinimalSig _ s (L l bf))
renameSig ctxt sig@(PatSynSig _ vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
- ; (ty', fvs) <- rnHsSigType ty_ctxt ty
+ ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty
; return (PatSynSig noExtField new_vs ty', fvs) }
where
ty_ctxt = GenericCtx (text "a pattern synonym signature for"
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 229c66fda4..1ab80e755a 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -70,8 +70,9 @@ import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
-import Data.Maybe ( isNothing, isJust, fromMaybe )
+import Data.Maybe ( isNothing, fromMaybe, mapMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
+import Data.Function ( on )
{- | @rnSourceDecl@ "renames" declarations.
It simultaneously performs dependency analysis and precedence parsing.
@@ -370,7 +371,7 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
-- Mark any PackageTarget style imports as coming from the current package
; let unitId = thisPackage $ hsc_dflags topEnv
@@ -382,7 +383,7 @@ rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
= do { name' <- lookupLocatedOccRn name
- ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty
; return (ForeignExport { fd_e_ext = noExtField
, fd_name = name', fd_sig_ty = ty'
, fd_fe = spec }
@@ -607,7 +608,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
= do { (inst_ty', inst_fvs)
- <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty
+ <- rnHsSigType (GenericCtx $ text "an instance declaration") TypeLevel inst_ty
; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
; cls <-
case hsTyGetAppHead_maybe head_ty' of
@@ -1288,17 +1289,17 @@ rnTyClDecls :: [TyClGroup GhcPs]
-- Rename the declarations and do dependency analysis on them
rnTyClDecls tycl_ds
= do { -- Rename the type/class, instance, and role declaraations
- tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
- (tyClGroupTyClDecls tycl_ds)
+ ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
-
+ ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)
; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
-- Do SCC analysis on the type/class decls
; rdr_env <- getGlobalRdrEnv
- ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
+ ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
role_annot_env = mkRoleAnnotEnv role_annots
+ (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
(init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
@@ -1307,15 +1308,16 @@ rnTyClDecls tycl_ds
| null init_inst_ds = []
| otherwise = [TyClGroup { group_ext = noExtField
, group_tyclds = []
+ , group_kisigs = []
, group_roles = []
, group_instds = init_inst_ds }]
(final_inst_ds, groups)
- = mapAccumL (mk_group role_annot_env) rest_inst_ds tycl_sccs
-
+ = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
- all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
- (foldr (plusFV . snd) emptyFVs instds_w_fvs)
+ all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs `plusFV`
+ foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
+ foldr (plusFV . snd) emptyFVs kisigs_w_fvs
all_groups = first_group ++ groups
@@ -1326,32 +1328,91 @@ rnTyClDecls tycl_ds
; return (all_groups, all_fvs) }
where
mk_group :: RoleAnnotEnv
+ -> KindSigEnv
-> InstDeclFreeVarsMap
-> SCC (LTyClDecl GhcRn)
-> (InstDeclFreeVarsMap, TyClGroup GhcRn)
- mk_group role_env inst_map scc
+ mk_group role_env kisig_env inst_map scc
= (inst_map', group)
where
tycl_ds = flattenSCC scc
bndrs = map (tcdName . unLoc) tycl_ds
roles = getRoleAnnots bndrs role_env
+ kisigs = getKindSigs bndrs kisig_env
(inst_ds, inst_map') = getInsts bndrs inst_map
group = TyClGroup { group_ext = noExtField
, group_tyclds = tycl_ds
+ , group_kisigs = kisigs
, group_roles = roles
, group_instds = inst_ds }
+-- | Free variables of standalone kind signatures.
+newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)
+
+lookupKindSig_FV_Env :: KindSig_FV_Env -> Name -> FreeVars
+lookupKindSig_FV_Env (KindSig_FV_Env e) name
+ = fromMaybe emptyFVs (lookupNameEnv e name)
+
+-- | Standalone kind signatures.
+type KindSigEnv = NameEnv (LStandaloneKindSig GhcRn)
+
+mkKindSig_fv_env :: [(LStandaloneKindSig GhcRn, FreeVars)] -> (KindSigEnv, KindSig_FV_Env)
+mkKindSig_fv_env kisigs_w_fvs = (kisig_env, kisig_fv_env)
+ where
+ kisig_env = mapNameEnv fst compound_env
+ kisig_fv_env = KindSig_FV_Env (mapNameEnv snd compound_env)
+ compound_env :: NameEnv (LStandaloneKindSig GhcRn, FreeVars)
+ = mkNameEnvWith (standaloneKindSigName . unLoc . fst) kisigs_w_fvs
+
+getKindSigs :: [Name] -> KindSigEnv -> [LStandaloneKindSig GhcRn]
+getKindSigs bndrs kisig_env = mapMaybe (lookupNameEnv kisig_env) bndrs
+
+rnStandaloneKindSignatures
+ :: NameSet -- names of types and classes in the current TyClGroup
+ -> [LStandaloneKindSig GhcPs]
+ -> RnM [(LStandaloneKindSig GhcRn, FreeVars)]
+rnStandaloneKindSignatures tc_names kisigs
+ = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs
+ get_name = standaloneKindSigName . unLoc
+ ; mapM_ dupKindSig_Err dup_kisigs
+ ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups
+ }
+
+rnStandaloneKindSignature
+ :: NameSet -- names of types and classes in the current TyClGroup
+ -> StandaloneKindSig GhcPs
+ -> RnM (StandaloneKindSig GhcRn, FreeVars)
+rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)
+ = do { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures
+ ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr
+ ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v
+ ; let doc = StandaloneKindSigCtx (ppr v)
+ ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki
+ ; return (StandaloneKindSig noExtField new_v new_ki, fvs)
+ }
+ where
+ standaloneKiSigErr :: SDoc
+ standaloneKiSigErr =
+ hang (text "Illegal standalone kind signature")
+ 2 (text "Did you mean to enable StandaloneKindSignatures?")
+rnStandaloneKindSignature _ (XStandaloneKindSig nec) = noExtCon nec
depAnalTyClDecls :: GlobalRdrEnv
+ -> KindSig_FV_Env
-> [(LTyClDecl GhcRn, FreeVars)]
-> [SCC (LTyClDecl GhcRn)]
-- See Note [Dependency analysis of type, class, and instance decls]
-depAnalTyClDecls rdr_env ds_w_fvs
+depAnalTyClDecls rdr_env kisig_fv_env ds_w_fvs
= stronglyConnCompFromEdgedVerticesUniq edges
where
edges :: [ Node Name (LTyClDecl GhcRn) ]
- edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
- | (d, fvs) <- ds_w_fvs ]
+ edges = [ DigraphNode d name (map (getParent rdr_env) (nonDetEltsUniqSet deps))
+ | (d, fvs) <- ds_w_fvs,
+ let { name = tcdName (unLoc d)
+ ; kisig_fvs = lookupKindSig_FV_Env kisig_fv_env name
+ ; deps = fvs `plusFV` kisig_fvs
+ }
+ ]
-- It's OK to use nonDetEltsUFM here as
-- stronglyConnCompFromEdgedVertices is still deterministic
-- even if the edges are in nondeterministic order as explained
@@ -1391,9 +1452,8 @@ rnRoleAnnots :: NameSet
rnRoleAnnots tc_names role_annots
= do { -- Check for duplicates *before* renaming, to avoid
-- lumping together all the unboundNames
- let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
- role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)
- = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
+ let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots
+ get_name = roleAnnotDeclName . unLoc
; mapM_ dupRoleAnnotErr dup_annots
; mapM (wrapLocM rn_role_annot1) no_dups }
where
@@ -1421,6 +1481,20 @@ dupRoleAnnotErr list
cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2
+dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM ()
+dupKindSig_Err list
+ = addErrAt loc $
+ hang (text "Duplicate standalone kind signatures for" <+>
+ quotes (ppr $ standaloneKindSigName first_decl) <> colon)
+ 2 (vcat $ map pp_kisig $ NE.toList sorted_list)
+ where
+ sorted_list = NE.sortBy cmp_loc list
+ ((dL->L loc first_decl) :| _) = sorted_list
+
+ pp_kisig (dL->L loc decl) =
+ hang (ppr decl) 4 (text "-- written at" <+> ppr loc)
+
+ cmp_loc (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2
{- Note [Role annotations in the renamer]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1495,12 +1569,11 @@ getInsts bndrs inst_decl_map
rnTyClDecl :: TyClDecl GhcPs
-> RnM (TyClDecl GhcRn, FreeVars)
--- All flavours of type family declarations ("type family", "newtype family",
--- and "data family"), both top level and (for an associated type)
--- in a class decl
-rnTyClDecl (FamDecl { tcdFam = decl })
- = do { (decl', fvs) <- rnFamDecl Nothing decl
- ; return (FamDecl noExtField decl', fvs) }
+-- All flavours of top-level type family declarations ("type family", "newtype
+-- family", and "data family")
+rnTyClDecl (FamDecl { tcdFam = fam })
+ = do { (fam', fvs) <- rnFamDecl Nothing fam
+ ; return (FamDecl noExtField fam', fvs) }
rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity, tcdRhs = rhs })
@@ -1515,9 +1588,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
, tcdRhs = rhs', tcdSExt = fvs }, fvs) } }
-- "data", "newtype" declarations
--- both top level and (for an associated type) in an instance decl
-rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) =
- panic "rnTyClDecl: DataDecl with XHsDataDefn"
+rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn nec)) = noExtCon nec
rnTyClDecl (DataDecl
{ tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity,
@@ -1529,8 +1600,7 @@ rnTyClDecl (DataDecl
; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn
- ; cusk <- dataDeclHasCUSK
- tyvars' new_or_data no_rhs_kvs (isJust kind_sig)
+ ; cusk <- data_decl_has_cusk tyvars' new_or_data no_rhs_kvs kind_sig
; let rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
@@ -1608,19 +1678,17 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
rnTyClDecl (XTyClDecl nec) = noExtCon nec
-- Does the data type declaration include a CUSK?
-dataDeclHasCUSK :: LHsQTyVars pass -> NewOrData -> Bool -> Bool -> RnM Bool
-dataDeclHasCUSK tyvars new_or_data no_rhs_kvs has_kind_sig = do
+data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool
+data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do
{ -- See Note [Unlifted Newtypes and CUSKs], and for a broader
-- picture, see Note [Implementation of UnliftedNewtypes].
; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
; let non_cusk_newtype
| NewType <- new_or_data =
- unlifted_newtypes && not has_kind_sig
+ unlifted_newtypes && isNothing kind_sig
| otherwise = False
-- See Note [CUSKs: complete user-supplied kind signatures] in GHC.Hs.Decls
- ; cusks_enabled <- xoptM LangExt.CUSKs
- ; return $ cusks_enabled && hsTvbAllKinded tyvars &&
- no_rhs_kvs && not non_cusk_newtype
+ ; return $ hsTvbAllKinded tyvars && no_rhs_kvs && not non_cusk_newtype
}
{- Note [Unlifted Newtypes and CUSKs]
@@ -1724,7 +1792,7 @@ rnLHsDerivingClause doc
, deriv_clause_strategy = dcs
, deriv_clause_tys = (dL->L loc' dct) }))
= do { (dcs', dct', fvs)
- <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc) dct
+ <- rnLDerivStrategy doc dcs $ mapFvRn (rnHsSigType doc TypeLevel) dct
; warnNoDerivStrat dcs' loc
; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExtField
, deriv_clause_strategy = dcs'
@@ -1766,7 +1834,7 @@ rnLDerivStrategy doc mds thing_inside
AnyclassStrategy -> boring_case AnyclassStrategy
NewtypeStrategy -> boring_case NewtypeStrategy
ViaStrategy via_ty ->
- do (via_ty', fvs1) <- rnHsSigType doc via_ty
+ do (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty
let HsIB { hsib_ext = via_imp_tvs
, hsib_body = via_body } = via_ty'
(via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body
@@ -2249,6 +2317,11 @@ add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds
-- Signatures: fixity sigs go a different place than all others
add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds
= addl (gp {hs_fixds = cL l f : ts}) ds
+
+-- Standalone kind signatures: added to the TyClGroup
+add gp@(HsGroup {hs_tyclds = ts}) l (KindSigD _ s) ds
+ = addl (gp {hs_tyclds = add_kisig (cL l s) ts}) ds
+
add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds
= addl (gp {hs_valds = add_sig (cL l d) ts}) ds
@@ -2289,6 +2362,7 @@ add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_tycld d [] = [TyClGroup { group_ext = noExtField
, group_tyclds = [d]
+ , group_kisigs = []
, group_roles = []
, group_instds = []
}
@@ -2301,6 +2375,7 @@ add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_instd d [] = [TyClGroup { group_ext = noExtField
, group_tyclds = []
+ , group_kisigs = []
, group_roles = []
, group_instds = [d]
}
@@ -2313,6 +2388,7 @@ add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]
-> [TyClGroup (GhcPass p)]
add_role_annot d [] = [TyClGroup { group_ext = noExtField
, group_tyclds = []
+ , group_kisigs = []
, group_roles = [d]
, group_instds = []
}
@@ -2321,6 +2397,19 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
add_role_annot _ (XTyClGroup nec: _) = noExtCon nec
+add_kisig :: LStandaloneKindSig (GhcPass p)
+ -> [TyClGroup (GhcPass p)] -> [TyClGroup (GhcPass p)]
+add_kisig d [] = [TyClGroup { group_ext = noExtField
+ , group_tyclds = []
+ , group_kisigs = [d]
+ , group_roles = []
+ , group_instds = []
+ }
+ ]
+add_kisig d (tycls@(TyClGroup { group_kisigs = kisigs }) : rest)
+ = tycls { group_kisigs = d : kisigs } : rest
+add_kisig _ (XTyClGroup nec : _) = noExtCon nec
+
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs
add_bind _ (XValBindsLR {}) = panic "RdrHsSyn:add_bind"
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index e982e72f82..5f0a1c62c7 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -242,6 +242,7 @@ extraConstraintWildCardsAllowed env
TypeSigCtx {} -> True
ExprWithTySigCtx {} -> True
DerivDeclCtx {} -> True
+ StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls
_ -> False
-- | Finds free type and kind variables in a type,
@@ -295,19 +296,22 @@ of the HsWildCardBndrs structure, and we are done.
* *
****************************************************** -}
-rnHsSigType :: HsDocContext -> LHsSigType GhcPs
+rnHsSigType :: HsDocContext
+ -> TypeOrKind
+ -> LHsSigType GhcPs
-> RnM (LHsSigType GhcRn, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
-rnHsSigType ctx (HsIB { hsib_body = hs_ty })
+rnHsSigType ctx level (HsIB { hsib_body = hs_ty })
= do { traceRn "rnHsSigType" (ppr hs_ty)
; vars <- extractFilteredRdrTyVarsDups hs_ty
; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
- do { (body', fvs) <- rnLHsType ctx hs_ty
+ do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty
+
; return ( HsIB { hsib_ext = vars
, hsib_body = body' }
, fvs ) } }
-rnHsSigType _ (XHsImplicitBndrs nec) = noExtCon nec
+rnHsSigType _ _ (XHsImplicitBndrs nec) = noExtCon nec
rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
-- E.g. f :: forall a. a->b
@@ -563,9 +567,9 @@ rnHsTyKi env t@(HsKindSig _ ty k)
= do { checkPolyKinds env t
; kind_sigs_ok <- xoptM LangExt.KindSignatures
; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
- ; (ty', fvs1) <- rnLHsTyKi env ty
- ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
- ; return (HsKindSig noExtField ty' k', fvs1 `plusFV` fvs2) }
+ ; (ty', lhs_fvs) <- rnLHsTyKi env ty
+ ; (k', sig_fvs) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
+ ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
@@ -734,6 +738,7 @@ wildCardsAllowed env
FamPatCtx {} -> True -- Not named wildcards though
GHCiCtx {} -> True
HsTypeCtx {} -> True
+ StandaloneKindSigCtx {} -> False -- See Note [Wildcards in standalone kind signatures] in GHC/Hs/Decls
_ -> False
diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs
index 6678ad6dbf..0da8e30f6a 100644
--- a/compiler/rename/RnUtils.hs
+++ b/compiler/rename/RnUtils.hs
@@ -458,6 +458,7 @@ checkTupSize tup_size
-- Merge TcType.UserTypeContext in to it.
data HsDocContext
= TypeSigCtx SDoc
+ | StandaloneKindSigCtx SDoc
| PatCtx
| SpecInstSigCtx
| DefaultDeclCtx
@@ -487,6 +488,7 @@ inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt
pprHsDocContext :: HsDocContext -> SDoc
pprHsDocContext (GenericCtx doc) = doc
pprHsDocContext (TypeSigCtx doc) = text "the type signature for" <+> doc
+pprHsDocContext (StandaloneKindSigCtx doc) = text "the standalone kind signature for" <+> doc
pprHsDocContext PatCtx = text "a pattern type-signature"
pprHsDocContext SpecInstSigCtx = text "a SPECIALISE instance pragma"
pprHsDocContext DefaultDeclCtx = text "a `default' declaration"
View Lorry Controller Status