From: simonpj@microsoft.com Date: Mon, 12 Jun 2006 11:38:55 +0000 (+0000) Subject: Make scoped type variables work for default methods X-Git-Tag: Before_FC_branch_merge~393 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=1dfd77341ec56e9d61f2d78cb7ff2b9900385dac Make scoped type variables work for default methods Consider class C a where op :: forall b. a -> b -> b op = Then 'b' should be in scope in . I had omitted this case. This patch fixes it. --- diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 3a9bae0..59c5959 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -12,7 +12,7 @@ they may be affected by renaming (which isn't fully worked out yet). module RnBinds ( rnTopBinds, rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith, - rnMethodBinds, renameSigs, + rnMethodBinds, renameSigs, mkSigTvFn, rnMatchGroup, rnGRHSs ) where @@ -420,23 +420,25 @@ a binder. \begin{code} rnMethodBinds :: Name -- Class name + -> (Name -> [Name]) -- Signature tyvar function -> [Name] -- Names for generic type variables -> LHsBinds RdrName -> RnM (LHsBinds Name, FreeVars) -rnMethodBinds cls gen_tyvars binds +rnMethodBinds cls sig_fn gen_tyvars binds = foldM do_one (emptyBag,emptyFVs) (bagToList binds) where do_one (binds,fvs) bind = do - (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind + (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) -rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, - fun_matches = MatchGroup matches _ })) - = setSrcSpan loc $ - lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> - let plain_name = unLoc sel_name in +rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, + fun_matches = MatchGroup matches _ })) + = setSrcSpan loc $ + lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> + let plain_name = unLoc sel_name in -- We use the selector name as the binder + bindSigTyVarsFV (sig_fn plain_name) $ mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) -> let new_group = MatchGroup new_matches placeHolderType @@ -460,7 +462,7 @@ rnMethodBind cls gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) +rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = addLocErr mbind methodBindErr `thenM_` returnM (emptyBag, emptyFVs) \end{code} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 9301480..bd9c549 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -20,7 +20,7 @@ import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, globalRdrEnvElts, import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn ) import RnEnv ( lookupLocalDataTcNames, lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, @@ -38,7 +38,7 @@ import NameSet import NameEnv import OccName ( occEnvElts ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import DynFlags ( DynFlag(..) ) import Maybes ( seqMaybe ) import Maybe ( isNothing ) @@ -286,7 +286,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags) extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too - rnMethodBinds cls [] mbinds + rnMethodBinds cls (\n->[]) -- No scoped tyvars + [] mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the prags and signatures. -- Note that the type variables are not in scope here, @@ -538,7 +539,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, in checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - rnMethodBinds (unLoc cname') gen_tyvars mbinds + rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds ) `thenM` \ (mbinds', meth_fvs) -> returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index e71d920..6e40c79 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -6,8 +6,8 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcMonoBinds, - TcPragFun, tcSpecPrag, tcPrags, mkPragFun, - TcSigInfo(..), + TcPragFun, tcSpecPrag, tcPrags, mkPragFun, + TcSigInfo(..), TcSigFun, mkTcSigFun, badBootDeclErr ) where #include "HsVersions.h" @@ -170,7 +170,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside = do { -- Typecheck the signature ; let { prag_fn = mkPragFun sigs ; ty_sigs = filter isVanillaLSig sigs - ; sig_fn = mkSigFun ty_sigs } + ; sig_fn = mkTcSigFun ty_sigs } ; poly_ids <- mapM tcTySig ty_sigs -- No recovery from bad signatures, because the type sigs @@ -560,12 +560,12 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches, bind_fvs = fvs })] sig_fn -- Single function binding non_rec - | Just sig <- sig_fn name -- ...with a type signature + | Just scoped_tvs <- sig_fn name -- ...with a type signature = -- When we have a single function binding, with a type signature -- we can (a) use genuine, rigid skolem constants for the type variables -- (b) bring (rigid) scoped type variables into scope setSrcSpan b_loc $ - do { tc_sig <- tcInstSig True sig + do { tc_sig <- tcInstSig True name scoped_tvs ; mono_name <- newLocalName name ; let mono_ty = sig_tau tc_sig mono_id = mkLocalId mono_name mono_ty @@ -628,7 +628,7 @@ getMonoType (_,_,mono_id) = idType mono_id tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches }) - = do { mb_sig <- tcInstSig_maybe (sig_fn name) + = do { mb_sig <- tcInstSig_maybe sig_fn name ; mono_name <- newLocalName name ; mono_ty <- mk_mono_ty mb_sig ; let mono_id = mkLocalId mono_name mono_ty @@ -638,7 +638,7 @@ tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = m mk_mono_ty Nothing = newFlexiTyVarTy argTypeKind tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss }) - = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names + = do { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names ; let nm_sig_prs = names `zip` mb_sigs tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs] @@ -954,15 +954,24 @@ the variable's type, and after that checked to see whether they've been instantiated. \begin{code} -type TcSigFun = Name -> Maybe (LSig Name) +type TcSigFun = Name -> Maybe [Name] -- Maps a let-binder to the list of + -- type variables brought into scope + -- by its type signature. + -- Nothing => no type signature -mkSigFun :: [LSig Name] -> TcSigFun +mkTcSigFun :: [LSig Name] -> TcSigFun -- Search for a particular type signature -- Precondition: the sigs are all type sigs -- Precondition: no duplicates -mkSigFun sigs = lookupNameEnv env +mkTcSigFun sigs = lookupNameEnv env where - env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs] + env = mkNameEnv [(name, scoped_tyvars hs_ty) + | L span (TypeSig (L _ name) (L _ hs_ty)) <- sigs] + scoped_tyvars (HsForAllTy Explicit tvs _ _) = hsLTyVarNames tvs + scoped_tyvars other = [] + -- The scoped names are the ones explicitly mentioned + -- in the HsForAll. (There may be more in sigma_ty, because + -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) --------------- data TcSigInfo @@ -1016,14 +1025,16 @@ tcTySig (L span (TypeSig (L _ name) ty)) ; return (mkLocalId name sigma_ty) } ------------------- -tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo) +tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo) -- Instantiate with *meta* type variables; -- this signature is part of a multi-signature group -tcInstSig_maybe Nothing = return Nothing -tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig - ; return (Just tc_sig) } +tcInstSig_maybe sig_fn name + = case sig_fn name of + Nothing -> return Nothing + Just tvs -> do { tc_sig <- tcInstSig False name tvs + ; return (Just tc_sig) } -tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo +tcInstSig :: Bool -> Name -> [Name] -> TcM TcSigInfo -- Instantiate the signature, with either skolems or meta-type variables -- depending on the use_skols boolean -- @@ -1036,9 +1047,8 @@ tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo -- -- We must not use the same 'a' from the defn of T at both places!! -tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) - = setSrcSpan loc $ - do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into +tcInstSig use_skols name scoped_names + = do { poly_id <- tcLookupId name -- Cannot fail; the poly ids are put into -- scope when starting the binding group ; let skol_info = SigSkol (FunSigCtxt name) inst_tyvars | use_skols = tcInstSkolTyVars skol_info @@ -1047,19 +1057,15 @@ tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty)) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau, - sig_scoped = scoped_names, sig_loc = loc }) } + sig_scoped = final_scoped_names, sig_loc = loc }) } -- Note that the scoped_names and the sig_tvs will have -- different Names. That's quite ok; when we bring the -- scoped_names into scope, we just bind them to the sig_tvs where - -- The scoped names are the ones explicitly mentioned - -- in the HsForAll. (There may be more in sigma_ty, because - -- of nested type synonyms. See Note [Scoped] with TcSigInfo.) -- We also only have scoped type variables when we are instantiating -- with true skolems - scoped_names = case (use_skols, hs_ty) of - (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs - other -> [] + final_scoped_names | use_skols = scoped_names + | otherwise = [] ------------------- isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 14682a2..31e3d5a 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -24,7 +24,8 @@ import TcEnv ( tcLookupLocatedClass, simpleInstInfoTyCon, simpleInstInfoTy, InstBindings(..), newDFunName ) -import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..) ) +import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..), + TcSigFun, mkTcSigFun ) import TcHsType ( tcHsKindedType, tcHsSigType ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( checkSigTyVars, sigCtxt ) @@ -246,7 +247,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, let (tyvars, _, _, op_items) = classBigSig clas prag_fn = mkPragFun sigs - tc_dm = tcDefMeth clas tyvars default_binds prag_fn + sig_fn = mkTcSigFun sigs + tc_dm = tcDefMeth clas tyvars default_binds sig_fn prag_fn dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] -- Generate code for polymorphic default methods only @@ -259,7 +261,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) -> returnM (listToBag defm_binds, concat dm_ids_s) -tcDefMeth clas tyvars binds_in prag_fn sel_id +tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id) ; let rigid_info = ClsSkol clas clas_tyvars = tcSkolSigTyVars rigid_info tyvars @@ -271,8 +273,8 @@ tcDefMeth clas tyvars binds_in prag_fn sel_id ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth) ; [this_dict] <- newDicts origin theta - ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta - [this_dict] prag_fn meth_info) + ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta [this_dict] + sig_fn prag_fn meth_info) ; addErrCtxt (defltMethCtxt clas) $ do @@ -332,11 +334,12 @@ tcMethodBind -> TcThetaType -- Available theta; it's just used for the error message -> [Inst] -- Available from context, used to simplify constraints -- from the method body - -> TcPragFun -- Pragmas (e.g. inline pragmas) + -> TcSigFun -- For scoped tyvars, indexed by sel_name + -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name -> MethodSpec -- Details of this method -> TcM (LHsBinds Id) -tcMethodBind inst_tyvars inst_theta avail_insts prag_fn +tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn (sel_id, meth_id, meth_bind) = recoverM (returnM emptyLHsBinds) $ -- If anything fails, recover returning no bindings. @@ -346,19 +349,16 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn -- Check the bindings; first adding inst_tyvars to the envt -- so that we don't quantify over them in nested places - - let meth_sig = noLoc (TypeSig (noLoc (idName meth_id)) (noLoc bogus_ty)) - bogus_ty = HsTupleTy Boxed [] -- *Only* used to extract scoped type - -- variables... and there aren't any - lookup_sig name = ASSERT( name == idName meth_id ) - Just meth_sig + let sel_name = idName sel_id + meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name + -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name in tcExtendTyVarEnv inst_tyvars ( tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig addErrCtxt (methodCtxt sel_id) $ getLIE $ - tcMonoBinds [meth_bind] lookup_sig Recursive + tcMonoBinds [meth_bind] meth_sig_fn Recursive ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars @@ -379,7 +379,6 @@ tcMethodBind inst_tyvars inst_theta avail_insts prag_fn meth_tvs = sig_tvs sig all_tyvars = meth_tvs ++ inst_tyvars all_insts = avail_insts ++ meth_dicts - sel_name = idName sel_id in tcSimplifyCheck (ptext SLIT("class or instance method") <+> quotes (ppr sel_id)) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index c31e6aa..1f4c476 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -828,7 +828,7 @@ genInst spec -- *non-renamed* auxiliary bindings ; (rn_meth_binds, _fvs) <- discardWarnings $ bindLocalNames (map varName tyvars) $ - rnMethodBinds clas_nm [] meth_binds + rnMethodBinds clas_nm (\n -> []) [] meth_binds -- Build the InstInfo ; return (InstInfo { iSpec = spec, diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 45338d0..8b53e3e 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -451,7 +451,10 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' let prag_fn = mkPragFun uprags all_insts = avail_insts ++ catMaybes meth_insts - tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts prag_fn + sig_fn n = Just [] -- No scoped type variables, but every method has + -- a type signature, in effect, so that we check + -- the method has the right type + tc_method_bind = tcMethodBind inst_tyvars' dfun_theta' all_insts sig_fn prag_fn meth_ids = [meth_id | (_,meth_id,_) <- meth_infos] in