diff options
Diffstat (limited to 'compiler/rename')
-rw-r--r-- | compiler/rename/RnEnv.hs | 21 | ||||
-rw-r--r-- | compiler/rename/RnNames.hs | 2 | ||||
-rw-r--r-- | compiler/rename/RnPat.hs | 4 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 98 | ||||
-rw-r--r-- | compiler/rename/RnTypes.hs | 832 |
5 files changed, 627 insertions, 330 deletions
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 7466381cd5..a398e333b2 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -4,7 +4,7 @@ \section[RnEnv]{Environment manipulation for the renamer monad} -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, MultiWayIf #-} module RnEnv ( newTopSrcBinder, @@ -37,7 +37,8 @@ module RnEnv ( extendTyVarEnvFVRn, checkDupRdrNames, checkShadowedRdrNames, - checkDupNames, checkDupAndShadowedNames, checkTupSize, + checkDupNames, checkDupAndShadowedNames, dupNamesErr, + checkTupSize, addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, @@ -57,6 +58,7 @@ import HscTypes import TcEnv import TcRnMonad import RdrHsSyn ( setRdrNameSpace ) +import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) import Name import NameSet import NameEnv @@ -710,10 +712,17 @@ lookupOccRn rdr_name lookupKindOccRn :: RdrName -> RnM Name -- Looking up a name occurring in a kind lookupKindOccRn rdr_name - = do { mb_name <- lookupOccRn_maybe rdr_name - ; case mb_name of - Just name -> return name - Nothing -> reportUnboundName rdr_name } + = do { typeintype <- xoptM Opt_TypeInType + ; if | typeintype -> lookupTypeOccRn rdr_name + | is_star -> return starKindTyConName + | is_uni_star -> return unicodeStarKindTyConName + | otherwise -> lookupOccRn rdr_name } + where + -- With -XNoTypeInType, treat any usage of * in kinds as in scope + -- this is a dirty hack, but then again so was the old * kind. + fs_name = occNameFS $ rdrNameOcc rdr_name + is_star = fs_name == fsLit "*" + is_uni_star = fs_name == fsLit "★" -- lookupPromotedOccRn looks up an optionally promoted RdrName. lookupTypeOccRn :: RdrName -> RnM Name diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index cfe5fc5c27..7d60d6e32a 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -627,7 +627,7 @@ getLocalNonValBinders fixity_env where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty cdflds = case tau of - L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds + L _ (HsFunTy (L _ (HsAppsTy [HsAppPrefix (L _ (HsRecTy flds))])) _) -> flds _ -> [] find_con_flds _ = [] diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 77f08f4049..88496d496b 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -49,7 +49,7 @@ import DynFlags import PrelNames import TyCon ( tyConName ) import ConLike -import TypeRep ( TyThing(..) ) +import Type ( TyThing(..) ) import Name import NameSet import RdrName @@ -614,7 +614,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) HsRecFieldCon {} -> arg_in_scope lbl _other -> True ] - ; addUsedGREs (map thirdOf3 dot_dot_gres) + ; addUsedGREs (map thdOf3 dot_dot_gres) ; return [ L loc (HsRecField { hsRecFieldLbl = L loc (FieldOcc arg_rdr sel) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index b284ec8d88..e6b735211f 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -612,11 +612,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_datafam_insts = adts }) = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' - ; let cls = case splitLHsClassTy_maybe head_ty' of + ; let cls = case hsTyGetAppHead_maybe head_ty' of Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) Just (L _ cls, _) -> cls -- rnLHsInstType has added an error message - -- if splitLHsClassTy_maybe fails + -- if hsTyGetAppHead_maybe fails -- Rename the bindings -- The typechecker (not the renamer) checks that all @@ -667,36 +667,32 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload [] -> pprPanic "rnFamInstDecl" (ppr tycon) (L loc _ : []) -> loc (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) - (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats + ; tv_rdr_names <- extractHsTysRdrTyVars pats - ; rdr_env <- getLocalRdrEnv - ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names - ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names + ; var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) $ + freeKiTyVarsAllVars tv_rdr_names -- All the free vars of the family patterns -- with a sensible binding location ; ((pats', payload'), fvs) - <- bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ - do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats + <- bindLocalNamesFV var_names $ + do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats ; (payload', rhs_fvs) <- rnPayload doc payload -- See Note [Renaming associated types] - ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names - bad_tvs = case mb_cls of + ; let bad_tvs = case mb_cls of Nothing -> [] Just (_,cls_tkvs) -> filter is_bad cls_tkvs + var_name_set = mkNameSet var_names is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs - && not (cls_tkv `elemNameSet` lhs_names) + && not (cls_tkv `elemNameSet` var_name_set) ; unless (null bad_tvs) (badAssocRhs bad_tvs) ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) } - ; let all_fvs = fvs `addOneFV` unLoc tycon' ; return (tycon', - HsIB { hsib_body = pats' - , hsib_kvs = kv_names, hsib_tvs = tv_names }, + HsIB { hsib_body = pats', hsib_vars = var_names }, payload', all_fvs) } -- type instance => use, hence addOneFV @@ -1133,8 +1129,8 @@ rnTyClDecl (FamDecl { tcdFam = decl }) rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = fst (extractHsTyRdrTyVars rhs) - doc = TySynCtx tycon + ; kvs <- freeKiTyVarsKindVars <$> extractHsTyRdrTyVars rhs + ; let doc = TySynCtx tycon ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs) ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> @@ -1147,8 +1143,8 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs }) -- both top level and (for an associated type) in an instance decl rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn }) = do { tycon' <- lookupLocatedTopBndrRn tycon - ; let kvs = extractDataDefnKindVars defn - doc = TyDataCtx tycon + ; kvs <- extractDataDefnKindVars defn + ; let doc = TyDataCtx tycon ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs) ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' -> do { (defn', fvs) <- rnDataDefn doc defn @@ -1201,7 +1197,7 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', sigs', meth_fvs) - <- rnMethodBinds True cls' (hsLKiTyVarNames tyvars') mbinds sigs + <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope @@ -1331,12 +1327,15 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fdInfo = info, fdResultSig = res_sig , fdInjectivityAnn = injectivity }) = do { tycon' <- lookupLocatedTopBndrRn tycon + ; kvs <- extractRdrKindSigVars res_sig ; ((tyvars', res_sig', injectivity'), fv1) <- - bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' -> - do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig + bindHsQTyVars doc mb_cls kvs tyvars $ + \ tyvars'@(HsQTvs { hsq_implicit = rn_kvs }) -> + do { let rn_sig = rnFamResultSig doc rn_kvs + ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig') injectivity - ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } + ; return ( (tyvars', res_sig', injectivity') , fv_kind ) } ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' , fdInfo = info', fdResultSig = res_sig' @@ -1344,7 +1343,6 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fv1 `plusFV` fv2) } where doc = TyFamilyCtx tycon - kvs = extractRdrKindSigVars res_sig ---------------------- rn_info (ClosedTypeFamily (Just eqns)) @@ -1356,29 +1354,24 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) rn_info DataFamily = return (DataFamily, emptyFVs) -rnFamResultSig :: HsDocContext -> FamilyResultSig RdrName +rnFamResultSig :: HsDocContext + -> [Name] -- kind variables already in scope + -> FamilyResultSig RdrName -> RnM (FamilyResultSig Name, FreeVars) -rnFamResultSig _ NoSig +rnFamResultSig _ _ NoSig = return (NoSig, emptyFVs) -rnFamResultSig doc (KindSig kind) +rnFamResultSig doc _ (KindSig kind) = do { (rndKind, ftvs) <- rnLHsKind doc kind ; return (KindSig rndKind, ftvs) } -rnFamResultSig doc (TyVarSig tvbndr) +rnFamResultSig doc kv_names (TyVarSig tvbndr) = do { -- `TyVarSig` tells us that user named the result of a type family by -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to -- be sure that the supplied result name is not identical to an - -- already in-scope type variables: - -- - -- (a) one of already declared type family arguments. Example of - -- disallowed declaration: - -- type family F a = a + -- already in-scope type variable from an enclosing class. -- - -- (b) already in-scope type variable. This second case might happen - -- for associated types, where type class head bounds some type - -- variables. Example of disallowed declaration: + -- Example of disallowed declaration: -- class C a b where -- type F b = a | a -> b - -- Both are caught by the "in-scope" check that comes next rdr_env <- getLocalRdrEnv ; let resName = hsLTyVarName tvbndr ; when (resName `elemLocalRdrEnv` rdr_env) $ @@ -1388,8 +1381,13 @@ rnFamResultSig doc (TyVarSig tvbndr) ] $$ text "shadows an already bound type variable") - ; (tvbndr', fvs) <- rnLHsTyVarBndr doc Nothing rdr_env tvbndr - ; return (TyVarSig tvbndr', fvs) } + ; bindLHsTyVarBndr doc Nothing -- this might be a lie, but it's used for + -- scoping checks that are irrelevant here + (mkNameSet kv_names) emptyNameSet + -- use of emptyNameSet here avoids + -- redundant duplicate errors + tvbndr $ \ _ tvbndr' -> + return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) } -- Note [Renaming injectivity annotation] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1442,7 +1440,7 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) ; injTo' <- mapM rnLTyVar injTo ; return $ L srcSpan (InjectivityAnn injFrom' injTo') } - ; let tvNames = Set.fromList $ hsLKiTyVarNames tvBndrs + ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs resName = hsLTyVarName resTv -- See Note [Renaming injectivity annotation] lhsValid = EQ == (stableNameCmp resName (unLoc injFrom')) @@ -1593,7 +1591,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs ; new_name <- lookupLocatedTopBndrRn name ; let doc = ConDeclCtx [new_name] ; mb_doc' <- rnMbLHsDoc mb_doc - ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) + ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details) ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do { (new_context, fvs1) <- case mcxt of @@ -1607,7 +1605,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs , text "qtvs:" <+> ppr qtvs , text "qtvs':" <+> ppr qtvs' ]) ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 - ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs + ; warnUnusedForAlls (inHsDocContext doc) (hsQTvExplicit new_tyvars) all_fvs ; let new_tyvars' = case qtvs of Nothing -> Nothing Just _ -> Just new_tyvars @@ -1619,14 +1617,14 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs cxt = maybe [] unLoc mcxt get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - get_con_qtvs :: Maybe (LHsQTyVars RdrName) -> [LHsType RdrName] - -> ([RdrName], LHsQTyVars RdrName) - get_con_qtvs Nothing _arg_tys - = ([], mkHsQTvs []) - get_con_qtvs (Just qtvs) arg_tys - = (free_kvs, qtvs) - where - (free_kvs, _) = get_rdr_tvs arg_tys + get_con_qtvs :: [LHsType RdrName] + -> RnM ([Located RdrName], LHsQTyVars RdrName) + get_con_qtvs arg_tys + | Just tvs <- qtvs -- data T = forall a. MkT (a -> a) + = do { free_vars <- get_rdr_tvs arg_tys + ; return (freeKiTyVarsKindVars free_vars, tvs) } + | otherwise -- data T = MkT (a -> a) + = return ([], mkHsQTvs []) rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty , con_doc = mb_doc }) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index b716ee0721..fef7b67000 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -4,8 +4,8 @@ \section[RnSource]{Main pass of renamer} -} -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} module RnTypes ( -- Type related stuff @@ -16,17 +16,18 @@ module RnTypes ( rnLHsInstType, newTyVarNameRn, collectAnonWildCards, rnConDeclFields, - rnLTyVar, rnLHsTyVarBndr, + rnLTyVar, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, checkPrecMatch, checkSectionPrec, -- Binding related stuff - warnUnusedForAlls, - bindSigTyVarsFV, bindHsQTyVars, + warnUnusedForAlls, bindLHsTyVarBndr, + bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames, extractHsTyRdrTyVars, extractHsTysRdrTyVars, - extractRdrKindSigVars, extractDataDefnKindVars + extractRdrKindSigVars, extractDataDefnKindVars, + freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars ) where import {-# SOURCE #-} RnSplice( rnSpliceType ) @@ -37,8 +38,9 @@ import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad import RdrName -import PrelNames ( negateName, dot_tv_RDR, forall_tv_RDR ) +import PrelNames import TysPrim ( funTyConName ) +import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName ) import Name import SrcLoc import NameSet @@ -50,7 +52,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, import Outputable import FastString import Maybes -import Data.List ( nub, nubBy ) +import Data.List ( nubBy ) import Control.Monad ( unless, when ) #if __GLASGOW_HASKELL__ < 709 @@ -98,10 +100,9 @@ rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs -- rn_hs_sig_wc_type is used for source-language type signatures rn_hs_sig_wc_type no_implicit_if_forall ctxt (HsIB { hsib_body = wc_ty }) thing_inside - = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ kvs tvs -> + = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ vars -> rn_hs_wc_type ctxt wc_ty $ \ wc_ty' -> - thing_inside (HsIB { hsib_kvs = kvs - , hsib_tvs = tvs + thing_inside (HsIB { hsib_vars = vars , hsib_body = wc_ty' }) rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) @@ -133,7 +134,7 @@ rnWcSigTy :: HsDocContext -> LHsType RdrName -- on a qualified type, and return info on any extra-constraints -- wildcard. Some code duplication, but no big deal. rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau })) - = bindLHsTyVarBndrs ctxt Nothing tvs $ \ tvs' -> + = bindLHsTyVarBndrs ctxt Nothing [] tvs $ \ _ tvs' -> do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' } @@ -190,10 +191,9 @@ rnHsSigType :: HsDocContext -> LHsSigType RdrName -- Used for source-language type signatures -- that cannot have wildcards rnHsSigType ctx (HsIB { hsib_body = hs_ty }) - = rnImplicitBndrs True hs_ty $ \ kvs tvs -> + = rnImplicitBndrs True hs_ty $ \ vars -> do { (body', fvs) <- rnLHsType ctx hs_ty - ; return (HsIB { hsib_kvs = kvs - , hsib_tvs = tvs + ; return (HsIB { hsib_vars = vars , hsib_body = body' }, fvs) } rnImplicitBndrs :: Bool -- True <=> no implicit quantification @@ -201,22 +201,23 @@ rnImplicitBndrs :: Bool -- True <=> no implicit quantification -- E.g. f :: forall a. a->b -- Do not quantify over 'b' too. -> LHsType RdrName - -> ([Name] -> [Name] -> RnM (a, FreeVars)) + -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside = do { rdr_env <- getLocalRdrEnv - ; let (kv_rdrs, tv_rdrs) = filterInScope rdr_env $ - extractHsTyRdrTyVars hs_ty - real_tv_rdrs -- Implicit quantification only if - -- there is no explicit forall + ; free_vars <- filterInScope rdr_env <$> + extractHsTyRdrTyVars hs_ty + ; let real_tv_rdrs -- Implicit quantification only if + -- there is no explicit forall | no_implicit_if_forall , L _ (HsForAllTy {}) <- hs_ty = [] - | otherwise = tv_rdrs - ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr kv_rdrs $$ ppr tv_rdrs)) - ; kvs <- mapM (newLocalBndrRn . L loc) kv_rdrs - ; tvs <- mapM (newLocalBndrRn . L loc) real_tv_rdrs - ; bindLocalNamesFV (kvs ++ tvs) $ - thing_inside kvs tvs } + | otherwise = freeKiTyVarsTypeVars free_vars + real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs + ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$ + ppr real_rdrs)) + ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs + ; bindLocalNamesFV vars $ + thing_inside vars } rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl @@ -265,6 +266,35 @@ f :: forall a. a -> (() => b) binds "a" and "b" The -fwarn-context-quantification flag warns about this situation. See rnHsTyKi for case HsForAllTy Qualified. + +Note [Dealing with *] +~~~~~~~~~~~~~~~~~~~~~ +As a legacy from the days when types and kinds were different, we use +the type * to mean what we now call GHC.Types.Type. The problem is that +* should associate just like an identifier, *not* a symbol. +Running example: the user has written + + T (Int, Bool) b + c * d + +At this point, we have a bunch of stretches of types + + [[T, (Int, Bool), b], [c], [d]] + +these are the [[LHsType Name]] and a bunch of operators + + [GHC.TypeLits.+, GHC.Types.*] + +Note that the * is GHC.Types.*. So, we want to rearrange to have + + [[T, (Int, Bool), b], [c, *, d]] + +and + + [GHC.TypeLits.+] + +as our lists. We can then do normal fixity resolution on these. The fixities +must come along for the ride just so that the list stays in sync with the +operators. -} rnLHsTyKi :: RnTyKiWhat @@ -276,13 +306,14 @@ rnLHsTyKi what doc (L loc ty) rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $ - rnLHsTyKi RnType cxt ty + rnLHsTyKi (RnTypeBody TypeLevel) cxt ty -rnLHsPred :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnLHsPred = rnLHsTyKi RnConstraint +rnLHsPred :: RnTyKiWhat -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsPred (RnTypeBody level) = rnLHsTyKi (RnConstraint level) +rnLHsPred what = rnLHsTyKi what rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) -rnLHsKind = rnLHsTyKi RnKind +rnLHsKind = rnLHsTyKi (RnTypeBody KindLevel) rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name), FreeVars) @@ -293,43 +324,40 @@ rnLHsMaybeKind doc (Just kind) ; return (Just kind', fvs) } rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsType cxt ty = rnHsTyKi RnType cxt ty +rnHsType cxt ty = rnHsTyKi (RnTypeBody TypeLevel) cxt ty rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) -rnHsKind = rnHsTyKi RnKind +rnHsKind = rnHsTyKi (RnTypeBody KindLevel) -data RnTyKiWhat = RnType - | RnKind - | RnTopConstraint -- Top-level context of HsSigWcTypes - | RnConstraint -- All other constraints +data RnTyKiWhat = RnTypeBody TypeOrKind + | RnTopConstraint -- Top-level context of HsSigWcTypes + | RnConstraint TypeOrKind -- All other constraints instance Outputable RnTyKiWhat where - ppr RnType = ptext (sLit "RnType") - ppr RnKind = ptext (sLit "RnKind") - ppr RnTopConstraint = ptext (sLit "RnTopConstraint") - ppr RnConstraint = ptext (sLit "RnConstraint") - -isRnType :: RnTyKiWhat -> Bool -isRnType RnType = True -isRnType _ = False + ppr (RnTypeBody lev) = text "RnTypeBody" <+> ppr lev + ppr RnTopConstraint = text "RnTopConstraint" + ppr (RnConstraint lev) = text "RnConstraint" <+> ppr lev -isRnKind :: RnTyKiWhat -> Bool -isRnKind RnKind = True -isRnKind _ = False +isRnKindLevel :: RnTyKiWhat -> Bool +isRnKindLevel (RnTypeBody KindLevel) = True +isRnKindLevel (RnConstraint KindLevel) = True +isRnKindLevel _ = False rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi _ doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) - = bindLHsTyVarBndrs doc Nothing tyvars $ \ tyvars' -> - do { (tau', fvs) <- rnLHsType doc tau +rnHsTyKi what doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) + = do { checkTypeInType what ty + ; bindLHsTyVarBndrs doc Nothing [] tyvars $ \ _ tyvars' -> + do { (tau', fvs) <- rnLHsTyKi what doc tau ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' } - , fvs) } + , fvs) }} -rnHsTyKi _ doc (HsQualTy { hst_ctxt = lctxt - , hst_body = tau }) - = do { (ctxt', fvs1) <- rnContext doc lctxt - ; (tau', fvs2) <- rnLHsType doc tau +rnHsTyKi what doc ty@(HsQualTy { hst_ctxt = lctxt + , hst_body = tau }) + = do { checkTypeInType what ty + ; (ctxt', fvs1) <- rnTyKiContext what doc lctxt + ; (tau', fvs2) <- rnLHsTyKi what doc tau ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' } , fvs1 `plusFV` fvs2) } @@ -337,23 +365,15 @@ rnHsTyKi what _ (HsTyVar (L loc rdr_name)) = do { name <- rnTyVar what rdr_name ; return (HsTyVar (L loc name), unitFV name) } --- If we see (forall a . ty), without foralls on, the forall will give --- a sensible error message, but we don't want to complain about the dot too --- Hence the jiggery pokery with ty1 -rnHsTyKi what doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) - = setSrcSpan loc $ - do { ops_ok <- xoptM Opt_TypeOperators - ; op' <- if ops_ok - then rnTyVar what op - else do { addErr (opTyErr op ty) - ; return (mkUnboundNameRdr op) } -- Avoid double complaint - ; let l_op' = L loc op' - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs1) <- rnLHsTyKi what doc ty1 - ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) - op' fix ty1' ty2' - ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } +rnHsTyKi what doc ty@(HsOpTy ty1 l_op ty2) + = setSrcSpan (getLoc l_op) $ + do { (l_op', fvs1) <- rnHsTyOp what ty l_op + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs2) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs3) <- rnLHsTyKi what doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) + (unLoc l_op') fix ty1' ty2' + ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) } rnHsTyKi what doc (HsParTy ty) = do { (ty', fvs) <- rnLHsTyKi what doc ty @@ -385,35 +405,34 @@ rnHsTyKi what doc (HsFunTy ty1 ty2) -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - ; res_ty <- if isRnType what - then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' - else return (HsFunTy ty1' ty2') - + ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' ; return (res_ty, fvs1 `plusFV` fvs2) } rnHsTyKi what doc listTy@(HsListTy ty) = do { data_kinds <- xoptM Opt_DataKinds - ; when (not data_kinds && isRnKind what) + ; when (not data_kinds && isRnKindLevel what) (addErr (dataKindsErr what listTy)) ; (ty', fvs) <- rnLHsTyKi what doc ty ; return (HsListTy ty', fvs) } -rnHsTyKi _ doc (HsKindSig ty k) - = do { kind_sigs_ok <- xoptM Opt_KindSignatures +rnHsTyKi what doc t@(HsKindSig ty k) + = do { checkTypeInType what t + ; kind_sigs_ok <- xoptM Opt_KindSignatures ; unless kind_sigs_ok (badKindSigErr doc ty) - ; (ty', fvs1) <- rnLHsType doc ty + ; (ty', fvs1) <- rnLHsTyKi what doc ty ; (k', fvs2) <- rnLHsKind doc k ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi _ doc (HsPArrTy ty) - = do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi what doc t@(HsPArrTy ty) + = do { notInKinds what t + ; (ty', fvs) <- rnLHsType doc ty ; return (HsPArrTy ty', fvs) } -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys) = do { data_kinds <- xoptM Opt_DataKinds - ; when (not data_kinds && isRnKind what) + ; when (not data_kinds && isRnKindLevel what) (addErr (dataKindsErr what tupleTy)) ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsTupleTy tup_con tys', fvs) } @@ -423,24 +442,83 @@ rnHsTyKi what _ tyLit@(HsTyLit t) = do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what tyLit)) ; when (negLit t) (addErr negLitErr) + ; checkTypeInType what tyLit ; return (HsTyLit t, emptyFVs) } where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit +rnHsTyKi isType doc overall_ty@(HsAppsTy tys) + = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions + let (non_syms, syms) = splitHsAppsTy tys + + -- Step 2: rename the pieces + ; (syms1, fvs1) <- mapFvRn (rnHsTyOp isType overall_ty) syms + ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi isType doc) non_syms + + -- Step 3: deal with *. See Note [Dealing with *] + ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1 + + -- Step 4: collapse the non-symbol regions with HsAppTy + ; non_syms3 <- mapM deal_with_non_syms non_syms2 + + -- Step 5: assemble the pieces, using mkHsOpTyRn + ; L _ res_ty <- build_res_ty non_syms3 syms2 + + -- all done. Phew. + ; return (res_ty, fvs1 `plusFV` fvs2) } + where + -- See Note [Dealing with *] + deal_with_star :: [[LHsType Name]] -> [Located Name] + -> [[LHsType Name]] -> [Located Name] + -> ([[LHsType Name]], [Located Name]) + deal_with_star acc1 acc2 + (non_syms1 : non_syms2 : non_syms) (L loc star : ops) + | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey + = deal_with_star acc1 acc2 + ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms) + ops + deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) + = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops + deal_with_star acc1 acc2 [non_syms] [] + = (reverse (non_syms : acc1), reverse acc2) + deal_with_star _ _ _ _ + = pprPanic "deal_with_star" (ppr overall_ty) + + -- collapse [LHsType Name] to LHsType Name by making applications + -- monadic only for failure + deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name) + deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms + deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) + + -- assemble a right-biased OpTy for use in mkHsOpTyRn + build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name) + build_res_ty (arg1 : args) (op1 : ops) + = do { rhs <- build_res_ty args ops + ; fix <- lookupTyFixityRn op1 + ; res <- + mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs + ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs) + ; return (L loc res) + } + build_res_ty [arg] [] = return arg + build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty) + rnHsTyKi what doc (HsAppTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1 ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) } -rnHsTyKi _ doc (HsIParamTy n ty) - = do { (ty', fvs) <- rnLHsType doc ty +rnHsTyKi what doc t@(HsIParamTy n ty) + = do { notInKinds what t + ; (ty', fvs) <- rnLHsType doc ty ; return (HsIParamTy n ty', fvs) } -rnHsTyKi _ doc (HsEqTy ty1 ty2) - = do { (ty1', fvs1) <- rnLHsType doc ty1 - ; (ty2', fvs2) <- rnLHsType doc ty2 +rnHsTyKi what doc t@(HsEqTy ty1 ty2) + = do { checkTypeInType what t + ; (ty1', fvs1) <- rnLHsTyKi what doc ty1 + ; (ty2', fvs2) <- rnLHsTyKi what doc ty2 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi _ _ (HsSpliceTy sp k) @@ -456,19 +534,18 @@ rnHsTyKi _ _ (HsCoreTy ty) -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi _ _ (HsWrapTy {}) - = panic "rnHsTyKi" - rnHsTyKi what doc ty@(HsExplicitListTy k tys) - = do { data_kinds <- xoptM Opt_DataKinds + = do { checkTypeInType what ty + ; data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what ty)) - ; (tys', fvs) <- rnLHsTypes doc tys + ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsExplicitListTy k tys', fvs) } rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys) - = do { data_kinds <- xoptM Opt_DataKinds + = do { checkTypeInType what ty + ; data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr what ty)) - ; (tys', fvs) <- rnLHsTypes doc tys + ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys ; return (HsExplicitTupleTy kis tys', fvs) } rnHsTyKi what ctxt (HsWildCardTy wc) @@ -490,9 +567,8 @@ rnHsTyKi what ctxt (HsWildCardTy wc) = Just (notAllowed wc) | otherwise = case what of - RnType -> Nothing - RnKind -> Just (notAllowed wc <+> ptext (sLit "in a kind")) - RnConstraint -> Just constraint_msg + RnTypeBody _ -> Nothing + RnConstraint _ -> Just constraint_msg RnTopConstraint -> case wc of AnonWildCard {} -> Just constraint_msg NamedWildCard {} -> Nothing @@ -516,8 +592,8 @@ wildCardMsg ctxt doc -------------- rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name rnTyVar what rdr_name - | isRnKind what = lookupKindOccRn rdr_name - | otherwise = lookupTypeOccRn rdr_name + | isRnKindLevel what = lookupKindOccRn rdr_name + | otherwise = lookupTypeOccRn rdr_name rnLTyVar :: Located RdrName -> RnM (Located Name) rnLTyVar (L loc rdr_name) @@ -525,6 +601,20 @@ rnLTyVar (L loc rdr_name) ; return (L loc tyvar) } -------------- +rnHsTyOp :: Outputable a + => RnTyKiWhat -> a -> Located RdrName -> RnM (Located Name, FreeVars) +rnHsTyOp what overall_ty (L loc op) + = do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- rnTyVar what op + ; unless (ops_ok + || op' == starKindTyConName + || op' == unicodeStarKindTyConName + || op' `hasKey` eqTyConKey) $ + addErr (opTyErr op overall_ty) + ; let l_op' = L loc op' + ; return (l_op', unitFV op') } + +-------------- rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys @@ -592,6 +682,29 @@ rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name)) msg = wildCardMsg ctxt (notAllowed wc) +--------------- +-- | Ensures either that we're in a type or that -XTypeInType is set +checkTypeInType :: Outputable ty + => RnTyKiWhat + -> ty -- ^ type + -> RnM () +checkTypeInType what ty + | isRnKindLevel what + = do { type_in_type <- xoptM Opt_TypeInType + ; unless type_in_type $ + addErr (text "Illegal kind:" <+> ppr ty $$ + text "Did you mean to enable TypeInType?") } +checkTypeInType _ _ = return () + +notInKinds :: Outputable ty + => RnTyKiWhat + -> ty + -> RnM () +notInKinds what ty + | isRnKindLevel what + = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty) +notInKinds _ _ = return () + {- ***************************************************** * * Binding type variables @@ -611,11 +724,24 @@ bindSigTyVarsFV tvs thing_inside else bindLocalNamesFV tvs thing_inside } +-- | Simply bring a bunch of RdrNames into scope. No checking for +-- validity, at all. The binding location is taken from the location +-- on each name. +bindLRdrNames :: [Located RdrName] + -> ([Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindLRdrNames rdrs thing_inside + = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs + ; bindLocalNamesFV var_names $ + thing_inside var_names } + --------------- -bindHsQTyVars :: HsDocContext - -> Maybe a -- Just _ => an associated type decl - -> [RdrName] -- Kind variables from scope - -> LHsQTyVars RdrName -- Type variables +bindHsQTyVars :: forall a b. + HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Kind variables from scope, in l-to-r + -- order, but not from ... + -> (LHsQTyVars RdrName) -- ... these user-written tyvars -> (LHsQTyVars Name -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -- (a) Bring kind variables into scope @@ -623,68 +749,155 @@ bindHsQTyVars :: HsDocContext -- and (ii) mentioned in the kinds of tv_bndrs -- (b) Bring type variables into scope bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside - = do { rdr_env <- getLocalRdrEnv - ; let tvs = hsQTvBndrs tv_bndrs - kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs - , let (_, kvs) = extractHsTyRdrTyVars kind - , kv <- kvs ] - all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs) - all_kvs = filterOut (inScope rdr_env) all_kvs' - - overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ] - -- These variables appear both as kind and type variables - -- in the same declaration; eg type family T (x :: *) (y :: x) - -- We disallow this: too confusing! - - ; poly_kind <- xoptM Opt_PolyKinds - ; unless (poly_kind || null all_kvs) - (addErr (badKindBndrs doc all_kvs)) - ; unless (null overlap_kvs) - (addErr (overlappingKindVars doc overlap_kvs)) - - ; loc <- getSrcSpanM - ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs - ; bindLocalNamesFV kv_names $ - bindLHsTyVarBndrs doc mb_assoc tvs $ \ tv_bndrs' -> - thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) } - -bindLHsTyVarBndrs :: HsDocContext - -> Maybe a -- Just _ => an associated type decl - -> [LHsTyVarBndr RdrName] - -> ([LHsTyVarBndr Name] -> RnM (b, FreeVars)) + = do { bindLHsTyVarBndrs doc mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $ + \ rn_kvs rn_bndrs -> + thing_inside (HsQTvs { hsq_implicit = rn_kvs + , hsq_explicit = rn_bndrs }) } + +bindLHsTyVarBndrs :: forall a b. + HsDocContext + -> Maybe a -- Just _ => an associated type decl + -> [Located RdrName] -- Unbound kind variables from scope, + -- in l-to-r order, but not from ... + -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars + -> ( [Name] -- all kv names + -> [LHsTyVarBndr Name] + -> RnM (b, FreeVars)) -> RnM (b, FreeVars) -bindLHsTyVarBndrs doc mb_assoc tv_bndrs thing_inside - = do { let tv_names_w_loc = map hsLTyVarLocName tv_bndrs - - -- Check for duplicate or shadowed tyvar bindrs - ; checkDupRdrNames tv_names_w_loc - ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) +bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside + = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc) + ; go [] [] emptyNameSet emptyNameSet tv_bndrs } + where + tv_names_w_loc = map hsLTyVarLocName tv_bndrs + + go :: [Name] -- kind-vars found (in reverse order) + -> [LHsTyVarBndr Name] -- already renamed (in reverse order) + -> NameSet -- kind vars already in scope (for dup checking) + -> NameSet -- type vars already in scope (for dup checking) + -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped + -> RnM (b, FreeVars) + go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs) + = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $ + \ kv_nms tv_bndr' -> go (reverse kv_nms ++ rn_kvs) + (tv_bndr' : rn_tvs) + (kv_names `extendNameSetList` kv_nms) + (tv_names `extendNameSet` hsLTyVarName tv_bndr') + tv_bndrs + + go rn_kvs rn_tvs _kv_names tv_names [] + = -- still need to deal with the kv_bndrs passed in originally + bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms -> + do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs) + all_rn_tvs = reverse rn_tvs + ; env <- getLocalRdrEnv + ; traceRn (text "bindHsTyVars" <+> (ppr env $$ + ppr all_rn_kvs $$ + ppr all_rn_tvs)) + ; thing_inside all_rn_kvs all_rn_tvs } + +bindLHsTyVarBndr :: HsDocContext + -> Maybe a -- associated class + -> NameSet -- kind vars already in scope + -> NameSet -- type vars already in scope + -> LHsTyVarBndr RdrName + -> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars)) + -- passed the newly-bound implicitly-declared kind vars, + -- and the renamed LHsTyVarBndr + -> RnM (b, FreeVars) +bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside + = case hs_tv_bndr of + L loc (UserTyVar lrdr@(L lv rdr)) -> + do { check_dup loc rdr + ; nm <- newTyVarNameRn mb_assoc lrdr + ; bindLocalNamesFV [nm] $ + thing_inside [] (L loc (UserTyVar (L lv nm))) } + L loc (KindedTyVar lrdr@(L lv rdr) kind) -> + do { check_dup lv rdr + + -- check for -XKindSignatures + ; sig_ok <- xoptM Opt_KindSignatures + ; unless sig_ok (badKindSigErr doc kind) + + -- deal with kind vars in the user-written kind + ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind + ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms -> + do { (kind', fvs1) <- rnLHsKind doc kind + ; tv_nm <- newTyVarNameRn mb_assoc lrdr + ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $ + thing_inside kv_nms + (L loc (KindedTyVar (L lv tv_nm) kind')) + ; return (b, fvs1 `plusFV` fvs2) }} + where + -- make sure that the RdrName isn't in the sets of + -- names. We can't just check that it's not in scope at all + -- because we might be inside an associated class. + check_dup :: SrcSpan -> RdrName -> RnM () + check_dup loc rdr + = do { m_name <- lookupLocalOccRn_maybe rdr + ; whenIsJust m_name $ \name -> + do { when (name `elemNameSet` kv_names) $ + addErrAt loc (vcat [ ki_ty_err_msg name + , pprHsDocContext doc ]) + ; when (name `elemNameSet` tv_names) $ + dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }} + + ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+> + text "used as a kind variable before being bound" $$ + text "as a type variable. Perhaps reorder your variables?" + + +bindImplicitKvs :: HsDocContext + -> Maybe a + -> [Located RdrName] -- ^ kind var *occurrences*, from which + -- intent to bind is inferred + -> NameSet -- ^ *type* variables, for type/kind + -- misuse check for -XNoTypeInType + -> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names + -> RnM (b, FreeVars) +bindImplicitKvs _ _ [] _ thing_inside = thing_inside [] +bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside + = do { rdr_env <- getLocalRdrEnv + ; let part_kvs lrdr@(L loc kv_rdr) + = case lookupLocalRdrEnv rdr_env kv_rdr of + Just kv_name -> Left (L loc kv_name) + _ -> Right lrdr + (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs + + -- check whether we're mixing types & kinds illegally + ; type_in_type <- xoptM Opt_TypeInType + ; unless type_in_type $ + mapM_ (check_tv_used_in_kind tv_names) bound_kvs + + ; poly_kinds <- xoptM Opt_PolyKinds + ; unless poly_kinds $ + addErr (badKindBndrs doc new_kvs) + + -- bind the vars and move on + ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs + ; bindLocalNamesFV kv_nms $ + thing_inside kv_nms } + where + -- check to see if the variables free in a kind are bound as type + -- variables. Assume -XNoTypeInType. + check_tv_used_in_kind :: NameSet -- ^ *type* variables + -> Located Name -- ^ renamed var used in kind + -> RnM () + check_tv_used_in_kind tv_names (L loc kv_name) + = when (kv_name `elemNameSet` tv_names) $ + addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+> + text "used in a kind." $$ + text "Did you mean to use TypeInType?" + , pprHsDocContext doc ]) + + +newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name +newTyVarNameRn mb_assoc (L loc rdr) + = do { rdr_env <- getLocalRdrEnv + ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of + (Just _, Just n) -> return n + -- Use the same Name as the parent class decl - ; rdr_env <- getLocalRdrEnv - ; (tv_bndrs', fvs1) <- mapFvRn (rnLHsTyVarBndr doc mb_assoc rdr_env) tv_bndrs - ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $ - thing_inside tv_bndrs' - ; return (res, fvs1 `plusFV` fvs2) } - -rnLHsTyVarBndr :: HsDocContext -> Maybe a -> LocalRdrEnv - -> LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) -rnLHsTyVarBndr _ mb_assoc rdr_env (L loc (UserTyVar (L l rdr))) - = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar (L l nm)), emptyFVs) } -rnLHsTyVarBndr doc mb_assoc rdr_env (L loc (KindedTyVar (L lv rdr) kind)) - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badKindSigErr doc kind) - ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) } - -newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name -newTyVarNameRn mb_assoc rdr_env loc rdr - | Just _ <- mb_assoc -- Use the same Name as the parent class decl - , Just n <- lookupLocalRdrEnv rdr_env rdr - = return n - | otherwise - = newLocalBndrRn (L loc rdr) + _ -> newLocalBndrRn (L loc rdr) } --------------------- collectNamedWildCards :: LHsType RdrName -> [Located RdrName] @@ -701,6 +914,7 @@ collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)] collectWildCards lty = go lty where go (L loc ty) = case ty of + HsAppsTy tys -> gos (mapMaybe prefix_types_only tys) HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2 HsListTy ty -> go ty @@ -716,7 +930,6 @@ collectWildCards lty = go lty HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds HsExplicitListTy _ tys -> gos tys HsExplicitTupleTy _ tys -> gos tys - HsWrapTy _ ty -> go (L loc ty) -- Interesting cases HsWildCardTy wc -> [L loc wc] HsForAllTy { hst_body = ty } -> go ty @@ -727,6 +940,9 @@ collectWildCards lty = go lty gos = mconcat . map go + prefix_types_only (HsAppPrefix ty) = Just ty + prefix_types_only (HsAppInfix _) = Nothing + {- ********************************************************* @@ -771,12 +987,16 @@ rnField fl_env doc (L l (ConDeclField names ty haddock_doc)) ********************************************************* -} -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnContext doc (L loc cxt) +rnTyKiContext :: RnTyKiWhat + -> HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnTyKiContext what doc (L loc cxt) = do { traceRn (text "rncontext" <+> ppr cxt) - ; (cxt', fvs) <- mapFvRn (rnLHsPred doc) cxt + ; (cxt', fvs) <- mapFvRn (rnLHsPred what doc) cxt ; return (L loc cxt', fvs) } +rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext = rnTyKiContext (RnConstraint TypeLevel) + {- ************************************************************************ * * @@ -809,10 +1029,10 @@ mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) -> Name -> Fixity -> LHsType Name -> LHsType Name -> RnM (HsType Name) -mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) +mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 (w2, op2) t2) + (\t1 t2 -> HsOpTy t1 op2 t2) (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) @@ -1068,14 +1288,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) * * ***************************************************** -} -overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc -overlappingKindVars doc kvs - = withHsDocContext doc $ - ptext (sLit "Kind variable") <> plural kvs - <+> ptext (sLit "also used as type variable") <> plural kvs - <> colon <+> pprQuotedList kvs - -badKindBndrs :: HsDocContext -> [RdrName] -> SDoc +badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc badKindBndrs doc kvs = withHsDocContext doc $ hang (ptext (sLit "Unexpected kind variable") <> plural kvs @@ -1094,8 +1307,8 @@ dataKindsErr what thing = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing)) 2 (ptext (sLit "Perhaps you intended to use DataKinds")) where - pp_what | isRnKind what = ptext (sLit "kind") - | otherwise = ptext (sLit "type") + pp_what | isRnKindLevel what = ptext (sLit "kind") + | otherwise = ptext (sLit "type") inTypeDoc :: HsType RdrName -> SDoc inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty) @@ -1111,20 +1324,19 @@ warnUnusedForAlls in_doc bound_names used_names vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) , in_doc ] -opTyErr :: RdrName -> HsType RdrName -> SDoc -opTyErr op ty@(HsOpTy ty1 _ _) - = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) +opTyErr :: Outputable a => RdrName -> a -> SDoc +opTyErr op overall_ty + = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty)) 2 extra where - extra | op == dot_tv_RDR && forall_head ty1 + extra | op == dot_tv_RDR = perhapsForallMsg | otherwise = ptext (sLit "Use TypeOperators to allow operators in types") - forall_head (L _ (HsTyVar (L _ tv))) = tv == forall_tv_RDR - forall_head (L _ (HsAppTy ty _)) = forall_head ty - forall_head _other = False -opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) +emptyNonSymsErr :: HsType RdrName -> SDoc +emptyNonSymsErr overall_ty + = text "Operator applied to too few arguments:" <+> ppr overall_ty {- ************************************************************************ @@ -1163,136 +1375,214 @@ Hence we returns a pair (kind-vars, type vars) See also Note [HsBSig binder lists] in HsTypes -} -type FreeKiTyVars = ([RdrName], [RdrName]) -- (Kind vars, type vars) +data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName] + , _fktv_k_set :: OccSet -- for efficiency, + -- only used internally + , fktv_tys :: [Located RdrName] + , _fktv_t_set :: OccSet + , fktv_all :: [Located RdrName] } + +instance Outputable FreeKiTyVars where + ppr (FKTV kis _ tys _ _) = ppr (kis, tys) + +emptyFKTV :: FreeKiTyVars +emptyFKTV = FKTV [] emptyOccSet [] emptyOccSet [] + +freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsAllVars = fktv_all + +freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsKindVars = fktv_kis + +freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName] +freeKiTyVarsTypeVars = fktv_tys filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env (kvs, tvs) - = (filterOut (inScope rdr_env) kvs, filterOut (inScope rdr_env) tvs) +filterInScope rdr_env (FKTV kis k_set tys t_set all) + = FKTV (filterOut in_scope kis) + (filterOccSet (not . in_scope_occ) k_set) + (filterOut in_scope tys) + (filterOccSet (not . in_scope_occ) t_set) + (filterOut in_scope all) + where + in_scope = inScope rdr_env . unLoc + in_scope_occ occ = isJust $ lookupLocalRdrOcc rdr_env occ inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars +extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. -- Does not return any wildcards -- See Note [Kind and type-variable binders] extractHsTyRdrTyVars ty - = case extract_lty ty ([],[]) of - (kvs, tvs) -> (nub kvs, nub tvs) + = do { FKTV kis k_set tys t_set all <- extract_lty TypeLevel ty emptyFKTV + ; return (FKTV (nubL kis) k_set + (nubL tys) t_set + (nubL all)) } -extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars +extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars ty - = case extract_ltys ty ([],[]) of - (kvs, tvs) -> (nub kvs, nub tvs) +extractHsTysRdrTyVars tys + = do { FKTV kis k_set tys t_set all <- extract_ltys TypeLevel tys emptyFKTV + ; return (FKTV (nubL kis) k_set + (nubL tys) t_set + (nubL all)) } -extractRdrKindSigVars :: LFamilyResultSig RdrName -> [RdrName] +extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k - | TyVarSig (L _ (UserTyVar _)) <- resultSig = [] - | otherwise = [] -- this can only be NoSig but pattern exhasutiveness - -- checker complains about "NoSig <- resultSig" - where kindRdrNameFromSig k = nub (fst (extract_lkind k ([],[]))) + | otherwise = return [] + where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k -extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName] +extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName] -- Get the scoped kind variables mentioned free in the constructor decls -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) -- Here k should scope over the whole definition extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig , dd_cons = cons, dd_derivs = derivs }) - = fst $ extract_lctxt ctxt $ - extract_mb extract_lkind ksig $ - extract_mb (extract_sig_tys . unLoc) derivs $ - foldr (extract_con . unLoc) ([],[]) cons + = (nubL . freeKiTyVarsKindVars) <$> + (extract_lctxt TypeLevel ctxt =<< + extract_mb extract_lkind ksig =<< + extract_mb (extract_sig_tys . unLoc) derivs =<< + foldrM (extract_con . unLoc) emptyFKTV cons) where - extract_con (ConDeclGADT { }) acc = acc + extract_con (ConDeclGADT { }) acc = return acc extract_con (ConDeclH98 { con_qvars = qvs , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs (maybe [] hsQTvBndrs qvs) acc $ - extract_mlctxt ctxt $ - extract_ltys (hsConDeclArgTys details) ([],[]) + = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<< + extract_mlctxt ctxt =<< + extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV +extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mlctxt Nothing acc = return acc +extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc -extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> FreeKiTyVars -extract_mlctxt Nothing = mempty -extract_mlctxt (Just ctxt) = extract_lctxt ctxt +extract_lctxt :: TypeOrKind + -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt) -extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lctxt ctxt = extract_ltys (unLoc ctxt) - -extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> FreeKiTyVars +extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars extract_sig_tys sig_tys acc - = foldr (\sig_ty acc -> extract_lty (hsSigType sig_ty) acc) - acc sig_tys + = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc) + acc sig_tys -extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars -extract_ltys tys acc = foldr extract_lty acc tys +extract_ltys :: TypeOrKind + -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys -extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars -extract_mb _ Nothing acc = acc +extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) + -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mb _ Nothing acc = return acc extract_mb f (Just x) acc = f x acc -extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of - (_, res_kvs) -> (res_kvs, acc_tvs) - -- Kinds shouldn't have sort signatures! +extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lkind = extract_lty KindLevel -extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_lty (L _ ty) acc +extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar (L _ tv) -> extract_tv tv acc - HsBangTy _ ty -> extract_lty ty acc - HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc + HsTyVar ltv -> extract_tv t_or_k ltv acc + HsBangTy _ ty -> extract_lty t_or_k ty acc + HsRecTy flds -> foldrM (extract_lty t_or_k + . cd_fld_type . unLoc) acc flds - HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsListTy ty -> extract_lty ty acc - HsPArrTy ty -> extract_lty ty acc - HsTupleTy _ tys -> extract_ltys tys acc - HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsIParamTy _ ty -> extract_lty ty acc - HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc) - HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc)) - HsParTy ty -> extract_lty ty acc - HsCoreTy {} -> acc -- The type is closed - HsSpliceTy {} -> acc -- Type splices mention no type variables - HsDocTy ty _ -> extract_lty ty acc - HsExplicitListTy _ tys -> extract_ltys tys acc - HsExplicitTupleTy _ tys -> extract_ltys tys acc - HsTyLit _ -> acc - HsWrapTy _ _ -> panic "extract_lty" - HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsAppsTy tys -> extract_apps t_or_k tys acc + HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsListTy ty -> extract_lty t_or_k ty acc + HsPArrTy ty -> extract_lty t_or_k ty acc + HsTupleTy _ tys -> extract_ltys t_or_k tys acc + HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsIParamTy _ ty -> extract_lty t_or_k ty acc + HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<< + extract_lty t_or_k ty1 =<< + extract_lty t_or_k ty2 acc + HsParTy ty -> extract_lty t_or_k ty acc + HsCoreTy {} -> return acc -- The type is closed + HsSpliceTy {} -> return acc -- Type splices mention no tvs + HsDocTy ty _ -> extract_lty t_or_k ty acc + HsExplicitListTy _ tys -> extract_ltys t_or_k tys acc + HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc + HsTyLit _ -> return acc + HsKindSig ty ki -> extract_lty t_or_k ty =<< + extract_lkind ki acc HsForAllTy { hst_bndrs = tvs, hst_body = ty } - -> extract_hs_tv_bndrs tvs acc $ - extract_lty ty ([],[]) - HsQualTy { hst_ctxt = cx, hst_body = ty } - -> extract_lctxt cx (extract_lty ty acc) - HsWildCardTy {} -> acc + -> extract_hs_tv_bndrs tvs acc =<< + extract_lty t_or_k ty emptyFKTV + HsQualTy { hst_ctxt = ctxt, hst_body = ty } + -> extract_lctxt t_or_k ctxt =<< + extract_lty t_or_k ty acc + -- We deal with these separately in rnLHsTypeWithWildCards + HsWildCardTy {} -> return acc + +extract_apps :: TypeOrKind + -> [HsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys + +extract_app :: TypeOrKind -> HsAppType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_app t_or_k (HsAppInfix tv) acc = extract_tv t_or_k tv acc +extract_app t_or_k (HsAppPrefix ty) acc = extract_lty t_or_k ty acc extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars - -> FreeKiTyVars -> FreeKiTyVars + -> FreeKiTyVars -> RnM FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have -- 'a' is bound by the forall -- 'b' is a free type variable -- 'e' is a free kind variable extract_hs_tv_bndrs tvs - (acc_kvs, acc_tvs) -- Note accumulator comes first - (body_kvs, body_tvs) + (FKTV acc_kvs acc_k_set acc_tvs acc_t_set acc_all) + -- Note accumulator comes first + (FKTV body_kvs body_k_set body_tvs body_t_set body_all) | null tvs - = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) + = return $ + FKTV (body_kvs ++ acc_kvs) (body_k_set `unionOccSets` acc_k_set) + (body_tvs ++ acc_tvs) (body_t_set `unionOccSets` acc_t_set) + (body_all ++ acc_all) | otherwise - = (acc_kvs ++ bndr_kvs ++ body_kvs, - acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) + = do { FKTV bndr_kvs bndr_k_set _ _ _ + <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs] + + ; let locals = mkOccSet $ map (rdrNameOcc . hsLTyVarName) tvs + ; return $ + FKTV (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_kvs) ++ acc_kvs) + ((body_k_set `minusOccSet` locals) `unionOccSets` acc_k_set `unionOccSets` bndr_k_set) + (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) body_tvs ++ acc_tvs) + ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set) + (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) } + +extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_tv t_or_k ltv@(L _ tv) acc + | isRdrTyVar tv = case acc of + FKTV kvs k_set tvs t_set all + | isTypeLevel t_or_k + -> do { when (occ `elemOccSet` k_set) $ + mixedVarsErr ltv + ; return (FKTV kvs k_set (ltv : tvs) (t_set `extendOccSet` occ) + (ltv : all)) } + | otherwise + -> do { when (occ `elemOccSet` t_set) $ + mixedVarsErr ltv + ; return (FKTV (ltv : kvs) (k_set `extendOccSet` occ) tvs t_set + (ltv : all)) } + | otherwise = return acc where - local_tvs = map hsLTyVarName tvs - (_, bndr_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs] - -extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars -extract_tv tv acc - | isRdrTyVar tv = add_tv tv acc - | otherwise = acc - -add_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars -add_tv tv (kvs,tvs) = (kvs, tv : tvs) + occ = rdrNameOcc tv + +mixedVarsErr :: Located RdrName -> RnM () +mixedVarsErr (L loc tv) + = do { typeintype <- xoptM Opt_TypeInType + ; unless typeintype $ + addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+> + text "used as both a kind and a type" $$ + text "Did you intend to use TypeInType?" } + +-- just used in this module; seemed convenient here +nubL :: Eq a => [Located a] -> [Located a] +nubL = nubBy eqLocated |