module RnBinds (
rnTopBinds,
rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith,
- rnMethodBinds, renameSigs,
+ rnMethodBinds, renameSigs, mkSigTvFn,
rnMatchGroup, rnGRHSs
) where
\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
-- 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}
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,
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 )
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,
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',
\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"
= 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
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
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
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]
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
; 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
--
--
-- 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
; 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
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 )
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
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
; (_, 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
-> 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.
-- 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
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))
-- *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,
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
projects / ghc-hetmet.git / commitdiff