diff options
Diffstat (limited to 'compiler/rename')
-rw-r--r-- | compiler/rename/RnBinds.hs | 2 | ||||
-rw-r--r-- | compiler/rename/RnExpr.hs | 14 | ||||
-rw-r--r-- | compiler/rename/RnPat.hs | 6 | ||||
-rw-r--r-- | compiler/rename/RnSource.hs | 123 | ||||
-rw-r--r-- | compiler/rename/RnTypes.hs | 53 | ||||
-rw-r--r-- | compiler/rename/RnUtils.hs | 5 |
6 files changed, 126 insertions, 77 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 7cd5c55245..60dead089b 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -958,7 +958,7 @@ renameSig _ (IdSig _ x) renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) - ; (new_ty, fvs) <- rnHsSigWcType doc ty + ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty ; return (TypeSig noExt new_vs new_ty, fvs) } renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index ae2bdf7a2b..46ac6b8724 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -167,10 +167,10 @@ rnExpr (HsApp x fun arg) ; (arg',fvArg) <- rnLExpr arg ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType arg fun) +rnExpr (HsAppType x fun arg) = do { (fun',fvFun) <- rnLExpr fun ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg - ; return (HsAppType arg' fun', fvFun `plusFV` fvArg) } + ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) } rnExpr (OpApp _ e1 op e2) = do { (e1', fv_e1) <- rnLExpr e1 @@ -310,11 +310,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds }) , rupd_flds = rbinds' } , fvExpr `plusFV` fvRbinds) } -rnExpr (ExprWithTySig pty expr) - = do { (pty', fvTy) <- rnHsSigWcType ExprWithTySigCtx pty +rnExpr (ExprWithTySig _ expr pty) + = do { (pty', fvTy) <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr - ; return (ExprWithTySig pty' expr', fvExpr `plusFV` fvTy) } + ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) } rnExpr (HsIf x _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -1820,7 +1820,7 @@ isStrictPattern (L _ pat) = AsPat _ _ p -> isStrictPattern p ParPat _ p -> isStrictPattern p ViewPat _ _ p -> isStrictPattern p - SigPat _ p -> isStrictPattern p + SigPat _ p _ -> isStrictPattern p BangPat{} -> True ListPat{} -> True TuplePat{} -> True @@ -1944,7 +1944,7 @@ isReturnApp monad_names (L _ e) = case e of _otherwise -> Nothing where is_var f (L _ (HsPar _ e)) = is_var f e - is_var f (L _ (HsAppType _ e)) = is_var f e + is_var f (L _ (HsAppType _ e _)) = is_var f e is_var f (L _ (HsVar _ (L _ r))) = f r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 6195309cab..a80a6982eb 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -213,7 +213,7 @@ matchNameMaker ctxt = LamMk report_unused _ -> True rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) -rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig) +rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) newPatLName name_maker rdr_name@(L loc _) @@ -393,7 +393,7 @@ rnPatAndThen mk (VarPat x (L l rdr)) = do { loc <- liftCps getSrcSpanM -- we need to bind pattern variables for view pattern expressions -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPat sig pat ) +rnPatAndThen mk (SigPat x pat sig) -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is -- important to rename its type signature _before_ renaming the rest of the -- pattern, so that type variables are first bound by the _outermost_ pattern @@ -405,7 +405,7 @@ rnPatAndThen mk (SigPat sig pat ) -- ~~~~~~~~~~~~~~~^ the same `a' then used here = do { sig' <- rnHsSigCps sig ; pat' <- rnLPatAndThen mk pat - ; return (SigPat sig' pat' ) } + ; return (SigPat x pat' sig' ) } rnPatAndThen mk (LitPat x lit) | HsString src s <- lit diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 9687e72a10..48739cdf69 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -50,7 +50,7 @@ import NameEnv import Avail import Outputable import Bag -import BasicTypes ( RuleName, pprRuleName ) +import BasicTypes ( pprRuleName ) import FastString import SrcLoc import DynFlags @@ -67,6 +67,7 @@ import Control.Arrow ( first ) import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Maybe ( isNothing, maybe, fromMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) {- | @rnSourceDecl@ "renames" declarations. @@ -693,33 +694,41 @@ rnFamInstEqn :: HsDocContext -> RnM (FamInstEqn GhcRn rhs', FreeVars) rnFamInstEqn doc mb_cls rhs_kvars (HsIB { hsib_body = FamEqn { feqn_tycon = tycon + , feqn_bndrs = mb_bndrs , feqn_pats = pats , feqn_fixity = fixity , feqn_rhs = payload }}) rn_payload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon - ; let loc = case pats of - [] -> pprPanic "rnFamInstEqn" (ppr tycon) - (L loc _ : []) -> loc - (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps)) - - pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats - pat_vars = freeKiTyVarsAllVars $ - rmDupsInRdrTyVars pat_kity_vars_with_dups + ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats -- Use the "...Dups" form because it's needed -- below to report unsed binder on the LHS - ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars - + ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups + + -- all pat vars not explicitly bound (see extractHsTvBndrs) + ; let mb_imp_kity_vars = extractHsTvBndrs <$> mb_bndrs <*> pure pat_kity_vars + imp_vars = case mb_imp_kity_vars of + -- kind vars are the only ones free if we have an explicit forall + Just nbnd_kity_vars -> freeKiTyVarsKindVars nbnd_kity_vars + -- all pattern vars are free otherwise + Nothing -> freeKiTyVarsAllVars pat_kity_vars + ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars + + ; let bndrs = fromMaybe [] mb_bndrs + bnd_vars = map hsLTyVarLocName bndrs + payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars -- Make sure to filter out the kind variables that were explicitly -- bound in the type patterns. - ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars - ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars + ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars - ; let all_var_names = pat_var_names ++ payload_var_names + -- all names not bound in an explict forall + ; let all_imp_var_names = imp_var_names ++ payload_kvar_names -- All the free vars of the family patterns -- with a sensible binding location - ; ((pats', payload'), fvs) - <- bindLocalNamesFV all_var_names $ + ; ((bndrs', pats', payload'), fvs) + <- bindLocalNamesFV all_imp_var_names $ + bindLHsTyVarBndrs doc (Just $ inHsDocContext doc) + mb_cls bndrs $ \bndrs' -> do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats ; (payload', rhs_fvs) <- rn_payload doc payload @@ -728,7 +737,7 @@ rnFamInstEqn doc mb_cls rhs_kvars ; let groups :: [NonEmpty (Located RdrName)] groups = equivClasses cmpLocated $ freeKiTyVarsAllVars pat_kity_vars_with_dups - ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $ + ; nms_dups <- mapM (lookupOccRn . unLoc) $ [ tv | (tv :| (_:_)) <- groups ] -- Add to the used variables -- a) any variables that appear *more than once* on the LHS @@ -736,27 +745,27 @@ rnFamInstEqn doc mb_cls rhs_kvars -- b) for associated instances, the variables -- of the instance decl. See -- Note [Unused type variables in family instances] - ; let tv_nms_used = extendNameSetList rhs_fvs $ - inst_tvs ++ tv_nms_dups + ; let nms_used = extendNameSetList rhs_fvs $ + inst_tvs ++ nms_dups inst_tvs = case mb_cls of Nothing -> [] Just (_, inst_tvs) -> inst_tvs - ; warnUnusedTypePatterns pat_var_names tv_nms_used + all_nms = all_imp_var_names + ++ map hsLTyVarName bndrs' + ; warnUnusedTypePatterns all_nms nms_used -- See Note [Renaming associated types] - ; let bad_tvs = case mb_cls of - Nothing -> [] - Just (_,cls_tkvs) -> filter is_bad cls_tkvs - var_name_set = mkNameSet all_var_names - + ; let bad_tvs = maybe [] (filter is_bad . snd) mb_cls + var_name_set = mkNameSet (map hsLTyVarName bndrs' + ++ all_imp_var_names) is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs - && not (cls_tkv `elemNameSet` var_name_set) + && not (cls_tkv `elemNameSet` var_name_set) ; unless (null bad_tvs) (badAssocRhs bad_tvs) - ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) } + ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } ; let anon_wcs = concatMap collectAnonWildCards pats' - all_ibs = anon_wcs ++ all_var_names + all_ibs = anon_wcs ++ all_imp_var_names -- all_ibs: include anonymous wildcards in the implicit -- binders In a type pattern they behave just like any -- other type variable except for being anoymous. See @@ -768,6 +777,7 @@ rnFamInstEqn doc mb_cls rhs_kvars , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = tycon' + , feqn_bndrs = bndrs' <$ mb_bndrs , feqn_pats = pats' , feqn_fixity = fixity , feqn_rhs = payload' } }, @@ -796,6 +806,7 @@ rnTyFamDefltEqn :: Name -> TyFamDefltEqn GhcPs -> RnM (TyFamDefltEqn GhcRn, FreeVars) rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon + , feqn_bndrs = bndrs , feqn_pats = tyvars , feqn_fixity = fixity , feqn_rhs = rhs }) @@ -805,6 +816,8 @@ rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon ; (rhs', fvs) <- rnLHsType ctx rhs ; return (FamEqn { feqn_ext = noExt , feqn_tycon = tycon' + , feqn_bndrs = ASSERT( isNothing bndrs ) + Nothing , feqn_pats = tyvars' , feqn_fixity = fixity , feqn_rhs = rhs' }, fvs) } } @@ -959,7 +972,7 @@ rnSrcDerivDecl (DerivDecl _ ty mds overlap) ; (mds', ty', fvs) <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty -> rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $ - rnHsSigWcType DerivDeclCtx ty + rnHsSigWcType BindUnlessForall DerivDeclCtx ty ; return (DerivDecl noExt ty' mds' overlap, fvs) } where loc = getLoc $ hsib_body $ hswc_body ty @@ -979,51 +992,75 @@ standaloneDerivErr -} rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) -rnHsRuleDecls (HsRules _ src rules) +rnHsRuleDecls (HsRules { rds_src = src + , rds_rules = rules }) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules - ; return (HsRules noExt src rn_rules,fvs) } + ; return (HsRules { rds_ext = noExt + , rds_src = src + , rds_rules = rn_rules }, fvs) } rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls" rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) -rnHsRuleDecl (HsRule _ rule_name act vars lhs rhs) - = do { let rdr_names_w_loc = map get_var vars +rnHsRuleDecl (HsRule { rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs + , rd_tmvs = tmvs + , rd_lhs = lhs + , rd_rhs = rhs }) + = do { let rdr_names_w_loc = map get_var tmvs ; checkDupRdrNames rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc - ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' -> + ; let doc = RuleCtx (snd $ unLoc rule_name) + ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' -> + bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs' - ; return (HsRule (HsRuleRn fv_lhs' fv_rhs') rule_name act vars' - lhs' rhs', - fv_lhs' `plusFV` fv_rhs') } } + ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs' + , rd_name = rule_name + , rd_act = act + , rd_tyvs = tyvs' + , rd_tmvs = tmvs' + , rd_lhs = lhs' + , rd_rhs = rhs' }, fv_lhs' `plusFV` fv_rhs') } } where get_var (L _ (RuleBndrSig _ v _)) = v get_var (L _ (RuleBndr _ v)) = v get_var (L _ (XRuleBndr _)) = panic "rnHsRuleDecl" + in_rule = text "in the rule" <+> pprFullRuleName rule_name rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl" -bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name] +bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs + -> [LRuleBndr GhcPs] -> [Name] -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -bindHsRuleVars rule_name vars names thing_inside +bindRuleTmVars doc tyvs vars names thing_inside = go vars names $ \ vars' -> bindLocalNamesFV names (thing_inside vars') where - doc = RuleCtx rule_name - go (L l (RuleBndr _ (L loc _)) : vars) (n : ns) thing_inside = go vars ns $ \ vars' -> thing_inside (L l (RuleBndr noExt (L loc n)) : vars') go (L l (RuleBndrSig _ (L loc _) bsig) : vars) (n : ns) thing_inside - = rnHsSigWcTypeScoped doc bsig $ \ bsig' -> + = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' -> go vars ns $ \ vars' -> thing_inside (L l (RuleBndrSig noExt (L loc n) bsig') : vars') go [] [] thing_inside = thing_inside [] go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names) + bind_free_tvs = case tyvs of Nothing -> AlwaysBind + Just _ -> NeverBind + +bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs] + -> (Maybe [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) +bindRuleTyVars doc in_doc (Just bndrs) thing_inside + = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just) +bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing + {- Note [Rule LHS validity checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1062,7 +1099,7 @@ validRuleLhs foralls lhs check (OpApp _ e1 op e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp _ e1 e2) = checkl e1 `mplus` checkl_e e2 - check (HsAppType _ e) = checkl e + check (HsAppType _ e _) = checkl e check (HsVar _ (L _ v)) | v `notElem` foralls = Nothing check other = Just other -- Failure diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 33f9329789..abdaaae7e2 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -12,7 +12,7 @@ module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnHsSigType, rnHsWcType, - rnHsSigWcType, rnHsSigWcTypeScoped, + HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, rnLHsInstType, newTyVarNameRn, collectAnonWildCards, rnConDeclFields, @@ -83,13 +83,29 @@ to break several loop. ********************************************************* -} -rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs - -> RnM (LHsSigWcType GhcRn, FreeVars) -rnHsSigWcType doc sig_ty - = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' -> +data HsSigWcTypeScoping = AlwaysBind + -- ^ Always bind any free tyvars of the given type, + -- regardless of whether we have a forall at the top + | BindUnlessForall + -- ^ Unless there's forall at the top, do the same + -- thing as 'AlwaysBind' + | NeverBind + -- ^ Never bind any free tyvars + +rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) +rnHsSigWcType scoping doc sig_ty + = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' -> return (sig_ty', emptyFVs) -rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs +rnHsSigWcTypeScoped :: HsSigWcTypeScoping + -- AlwaysBind: for pattern type sigs and rules we /do/ want + -- to bring those type variables into scope, even + -- if there's a forall at the top which usually + -- stops that happening + -- e.g \ (x :: forall a. a-> b) -> e + -- Here we do bring 'b' into scope + -> HsDocContext -> LHsSigWcType GhcPs -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Used for @@ -97,33 +113,26 @@ rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs -- - Pattern type signatures -- Wildcards are allowed -- type signatures on binders only allowed with ScopedTypeVariables -rnHsSigWcTypeScoped ctx sig_ty thing_inside +rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty) - ; rn_hs_sig_wc_type True ctx sig_ty thing_inside + ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside } - -- True: for pattern type sigs and rules we /do/ want - -- to bring those type variables into scope, even - -- if there's a forall at the top which usually - -- stops that happening - -- e.g \ (x :: forall a. a-> b) -> e - -- Here we do bring 'b' into scope - -rn_hs_sig_wc_type :: Bool -- True <=> always bind any free tyvars of the - -- type, regardless of whether it has - -- a forall at the top - -> HsDocContext - -> LHsSigWcType GhcPs + +rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- rn_hs_sig_wc_type is used for source-language type signatures -rn_hs_sig_wc_type always_bind_free_tvs ctxt +rn_hs_sig_wc_type scoping ctxt (HsWC { hswc_body = HsIB { hsib_body = hs_ty }}) thing_inside = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars ; let nwc_rdrs = nubL nwc_rdrs' - bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty) + bind_free_tvs = case scoping of + AlwaysBind -> True + BindUnlessForall -> not (isLHsForAllTy hs_ty) + NeverBind -> False ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars -> do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' } diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 0451e288be..2f27720ee5 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -244,11 +244,14 @@ warnUnused1 flag fld_env name = when (reportable name occ) $ addUnusedWarning flag occ (nameSrcSpan name) - (text "Defined but not used") + (text $ "Defined but not used" ++ opt_str) where occ = case lookupNameEnv fld_env name of Just (fl, _) -> mkVarOccFS fl Nothing -> nameOccName name + opt_str = case flag of + Opt_WarnUnusedTypePatterns -> " on the right hand side" + _ -> "" warnUnusedGRE :: GlobalRdrElt -> RnM () warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is }) |