Commit 1dfd7734 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Make scoped type variables work for default methods

Consider
  class C a where
    op :: forall b. a -> b -> b
    op = <rhs>

Then 'b' should be in scope in <rhs>.  I had omitted this case.
This patch fixes it.
parent 29e342d1
......@@ -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,
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}
......
......@@ -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',
......
......@@ -7,7 +7,7 @@
module TcBinds ( tcLocalBinds, tcTopBinds,
tcHsBootSigs, tcMonoBinds,
TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
TcSigInfo(..),
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
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
......
......@@ -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.
......@@ -347,18 +350,15 @@ 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))
......
......@@ -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,
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment