From aaed05e88978688e37dc74177dd4eba51a6ab4d0 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 10 Sep 2008 08:51:21 +0000 Subject: [PATCH] More refactoring of instance declarations (fixes Trac #2572) In refactoring instance declarations I'd taken a short cut over scoped type variables, but it wasn't right as #2572 shows. Fixing it required a significant chunk of further refactoring, alas. But it's done! Quite tidily as it turns out. The main issue is that when typechecking a default method, we need two sets of type variables in scope class C a where op :: forall b. ... op = e In 'e', *both* 'a' and 'b' are in scope. But the type of the default method has a nested flavour op :: forall a. C a => forall b. .... and our normal scoping mechanisms don't bring 'b' into scope. (And probably shouldn't.) Solution (which is done for instance methods too) is to use a local defintion, like this: $dmop :: forall a. C a => forall b. .... $dmop a d = let op :: forall b. ... op = e in op and now the scoping works out. I hope I have now see the last of this code for a bit! --- compiler/typecheck/TcClassDcl.lhs | 166 ++++++++++++++++++------------ compiler/typecheck/TcExpr.lhs | 9 +- compiler/typecheck/TcInstDcls.lhs | 204 ++++++++++++++++--------------------- compiler/typecheck/TcUnify.lhs | 40 ++++---- 4 files changed, 210 insertions(+), 209 deletions(-) diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index b36192c..3814f23 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -7,7 +7,7 @@ Typechecking class declarations \begin{code} module TcClassDcl ( tcClassSigs, tcClassDecl2, - findMethodBind, tcMethodBind, + findMethodBind, tcInstanceMethodBody, mkGenericDefMethBind, getGenericInstances, mkDefMethRdrName, tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where @@ -22,6 +22,7 @@ import Inst import InstEnv import TcEnv import TcBinds +import TcSimplify import TcHsType import TcMType import TcType @@ -167,8 +168,8 @@ tcClassDecl2 :: LTyClDecl Name -- The class declaration tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return (emptyLHsBinds, [])) $ - setSrcSpan loc $ do - clas <- tcLookupLocatedClass class_name + setSrcSpan loc $ + do { clas <- tcLookupLocatedClass class_name -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -178,59 +179,59 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- dm1 = \d -> case ds d of (a,b,c) -> a -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each - let - (tyvars, _, _, op_items) = classBigSig clas - rigid_info = ClsSkol clas - prag_fn = mkPragFun sigs - sig_fn = mkTcSigFun sigs - clas_tyvars = tcSkolSigTyVars rigid_info tyvars - tc_dm = tcDefMeth clas_tyvars default_binds - sig_fn prag_fn - -- tc_dm is called only for a sel_id - -- that has a binding in default_binds - - dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] - -- Generate code for polymorphic default methods only - -- (Generic default methods have turned into instance decls by now.) - -- This is incompatible with Hugs, which expects a polymorphic - -- default method for every class op, regardless of whether or not - -- the programmer supplied an explicit default decl for the class. - -- (If necessary we can fix that, but we don't have a convenient Id to hand.) - - (defm_binds, dm_ids) <- mapAndUnzipM tc_dm dm_sel_ids - return (unionManyBags defm_binds, dm_ids) + ; let + (tyvars, _, _, op_items) = classBigSig clas + rigid_info = ClsSkol clas + prag_fn = mkPragFun sigs + sig_fn = mkTcSigFun sigs + clas_tyvars = tcSkolSigTyVars rigid_info tyvars + pred = mkClassPred clas (mkTyVarTys clas_tyvars) + ; inst_loc <- getInstLoc (SigOrigin rigid_info) + ; this_dict <- newDictBndr inst_loc pred + + ; let tc_dm = tcDefMeth rigid_info clas clas_tyvars [pred] + this_dict default_binds + sig_fn prag_fn + -- tc_dm is called only for a sel_id + -- that has a binding in default_binds + + dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] + -- Generate code for polymorphic default methods only (hence DefMeth) + -- (Generic default methods have turned into instance decls by now.) + -- This is incompatible with Hugs, which expects a polymorphic + -- default method for every class op, regardless of whether or not + -- the programmer supplied an explicit default decl for the class. + -- (If necessary we can fix that, but we don't have a convenient Id to hand.) + + ; (defm_binds, dm_ids) <- tcExtendTyVarEnv clas_tyvars $ + mapAndUnzipM tc_dm dm_sel_ids + + ; return (unionManyBags defm_binds, dm_ids) } + tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) -tcDefMeth :: [TyVar] -> LHsBinds Name +tcDefMeth :: SkolemInfo -> Class -> [TyVar] -> ThetaType -> Inst -> LHsBinds Name -> TcSigFun -> TcPragFun -> Id -> TcM (LHsBinds Id, Id) -tcDefMeth tyvars binds_in sig_fn prag_fn sel_id +tcDefMeth rigid_info clas tyvars theta this_dict binds_in sig_fn prag_fn sel_id = do { let sel_name = idName sel_id - ; dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) - ; uniq <- newUnique - ; let dm_ty = idType sel_id -- Same as dict selector! - local_dm_name = setNameUnique sel_name uniq - local_dm_id = mkLocalId local_dm_name dm_ty - top_dm_id = mkDefaultMethodId dm_name dm_ty - all_tvs = map tyVarName tyvars ++ (sig_fn sel_name `orElse` []) - -- Tyvars in scope are *both* the ones from the - -- class decl *and* ones from the method sig - + ; local_dm_name <- newLocalName sel_name ; let meth_bind = findMethodBind sel_name local_dm_name binds_in `orElse` pprPanic "tcDefMeth" (ppr sel_id) -- We only call tcDefMeth on selectors for which -- there is a binding in binds_in - ; tc_meth_bind <- tcMethodBind all_tvs (prag_fn sel_name) - local_dm_id meth_bind + meth_sig_fn _ = sig_fn sel_name + meth_prag_fn _ = prag_fn sel_name - -- See Note [Silly default-method bind] - ; let loc = getLoc meth_bind - top_bind = L loc $ VarBind top_dm_id $ - L loc $ HsWrap (WpLet tc_meth_bind) $ - HsVar local_dm_id + ; (top_dm_id, bind) <- tcInstanceMethodBody rigid_info + clas tyvars [this_dict] theta (mkTyVarTys tyvars) + Nothing sel_id + local_dm_name + meth_sig_fn meth_prag_fn + meth_bind - ; return (unitBag top_bind, top_dm_id) } + ; return (bind, top_dm_id) } mkDefMethRdrName :: Name -> RdrName mkDefMethRdrName sel_name = mkDerivedRdrName sel_name mkDefaultMethodOcc @@ -249,29 +250,64 @@ findMethodBind sel_name meth_name binds = Just (L loc1 (bind { fun_id = L loc2 meth_name })) f _other = Nothing ---------------------------- -tcMethodBind :: [Name] -> [LSig Name] -> Id - -> LHsBind Name -> TcM (LHsBinds Id) -tcMethodBind tyvars prags meth_id bind - = do { let sig_fn _ = Just tyvars - prag_fn _ = prags +--------------- +tcInstanceMethodBody :: SkolemInfo -> Class -> [TcTyVar] -> [Inst] + -> TcThetaType -> [TcType] + -> Maybe (Inst, LHsBind Id) -> Id + -> Name -- The local method name + -> TcSigFun -> TcPragFun -> LHsBind Name + -> TcM (Id, LHsBinds Id) +tcInstanceMethodBody rigid_info clas tyvars dfun_dicts theta inst_tys + mb_this_bind sel_id local_meth_name + sig_fn prag_fn bind@(L loc _) + = do { let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) + rho_ty = ASSERT( length sel_tyvars == length inst_tys ) + substTyWith sel_tyvars inst_tys sel_rho + + (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty + `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) + + local_meth_id = mkLocalId local_meth_name local_meth_ty + meth_ty = mkSigmaTy tyvars theta local_meth_ty + sel_name = idName sel_id + + -- The first predicate should be of form (C a b) + -- where C is the class in question + ; MASSERT( case getClassPredTys_maybe first_pred of + { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) -- Typecheck the binding, first extending the envt - -- so that when tcInstSig looks up the meth_id to find - -- its signature, we'll find it in the environment - -- - -- If scoped type variables is on, they are brought - -- into scope by tcPolyBinds (via sig_fn) - -- - -- See Note [Polymorphic methods] - ; traceTc (text "tcMethodBind" <+> ppr meth_id <+> ppr tyvars) - ; (tc_binds, ids) <- tcExtendIdEnv [meth_id] $ - tcPolyBinds TopLevel sig_fn prag_fn - NonRecursive NonRecursive - (unitBag bind) - - ; ASSERT( ids == [meth_id] ) -- Binding for ONE method - return tc_binds } + -- so that when tcInstSig looks up the local_meth_id to find + -- its signature, we'll find it in the environment + ; ((tc_bind, _), lie) <- getLIE $ + tcExtendIdEnv [local_meth_id] $ + tcPolyBinds TopLevel sig_fn prag_fn + NonRecursive NonRecursive + (unitBag bind) + + ; meth_id <- case rigid_info of + ClsSkol _ -> do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_name) + ; return (mkDefaultMethodId dm_name meth_ty) } + _other -> do { meth_name <- newLocalName sel_name + ; return (mkLocalId meth_name meth_ty) } + + ; let (avails, this_dict_bind) + = case mb_this_bind of + Nothing -> (dfun_dicts, emptyBag) + Just (this, bind) -> (this : dfun_dicts, unitBag bind) + + ; inst_loc <- getInstLoc (SigOrigin rigid_info) + ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie + + ; let full_bind = L loc $ + AbsBinds tyvars dfun_lam_vars + [(tyvars, meth_id, local_meth_id, [])] + (this_dict_bind `unionBags` lie_binds + `unionBags` tc_bind) + + dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities + + ; return (meth_id, unitBag full_bind) } \end{code} Note [Polymorphic methods] diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index d0052d8..d7708b3 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -85,7 +85,8 @@ tcPolyExpr expr res_ty tcPolyExprNC expr res_ty | isSigmaTy res_ty = do { traceTc (text "tcPolyExprNC" <+> ppr res_ty) - ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing (tcPolyExprNC expr) + ; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty -> + tcPolyExprNC expr res_ty -- Note the recursive call to tcPolyExpr, because the -- type may have multiple layers of for-alls -- E.g. forall a. Eq a => forall b. Ord b => .... @@ -200,8 +201,10 @@ tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty -- Remember to extend the lexical type-variable environment - ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ - tcMonoExprNC expr + ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty -> + tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $ + -- See Note [More instantiated than scoped] in TcBinds + tcMonoExprNC expr res_ty ; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) } diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 193736d..97db7b3 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -40,7 +40,6 @@ import DynFlags import SrcLoc import Util import Outputable -import Maybes import Bag import BasicTypes import HscTypes @@ -95,15 +94,17 @@ Running example: {-# INLINE [2] op1_i #-} -- From the instance decl bindings op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b op1_i = /\a. \(d:C a). - let local_op1 :: forall a. (C a, C [a]) - => forall b. Ix b => [a] -> b -> b + let this :: C [a] + this = df_i a d + + local_op1 :: forall b. Ix b => [a] -> b -> b -- Note [Subtle interaction of recursion and overlap] local_op1 = -- Source code; run the type checker on this -- NB: Type variable 'a' (but not 'b') is in scope in -- Note [Tricky type variable scoping] - in local_op1 a d (df_i a d) + in local_op1 a d op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) @@ -175,10 +176,12 @@ call 'nullFail' just like the example above. The DoCon package also does the same thing; it shows up in module Fraction.hs Conclusion: when typechecking the methods in a C [a] instance, we want -to have C [a] available. That is why we have the strange local let in -the definition of op1_i in the example above. We can typecheck the -defintion of local_op1, and then supply the "this" argument via an -explicit call to the dfun (which in turn will be inlined). +to have C [a] available. That is why we have the strange local +definition for 'this' in the definition of op1_i in the example above. +We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck +we supply 'this' as a given dictionary. Only needed, though, if there +are some type variales involved; otherwise there can be no overlap and +none of this arises. Note [Tricky type variable scoping] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -602,19 +605,23 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) the_coercion = make_coercion cls_tycon initial_cls_inst_tys nt_tycon tc_args -- Coercion of kind (Foo Int (Tree [a]) ~ Foo Int (N a) - ; inst_loc <- getInstLoc origin ; sc_loc <- getInstLoc InstScOrigin - ; dfun_dicts <- newDictBndrs inst_loc theta ; sc_dicts <- newDictBndrs sc_loc sc_theta' + ; inst_loc <- getInstLoc origin + ; dfun_dicts <- newDictBndrs inst_loc theta ; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys) ; rep_dict <- newDictBndr inst_loc rep_pred -- Figure out bindings for the superclass context from dfun_dicts -- Don't include this_dict in the 'givens', else - -- wanted_sc_insts get bound by just selecting from this_dict!! + -- sc_dicst get bound by just selecting from this_dict!! ; sc_binds <- addErrCtxt superClassCtxt $ tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) + -- It's possible that the superclass stuff might unified something + -- in the envt with one of the clas_tyvars + ; checkSigTyVars class_tyvars + ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict @@ -701,48 +708,38 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Instantiate the super-class context with inst_tys sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta - (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta' origin = SigOrigin rigid_info - (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta' -- Create dictionary Ids from the specified instance contexts. - sc_loc <- getInstLoc InstScOrigin - sc_dicts <- newDictBndrs sc_loc dict_sc_theta' - inst_loc <- getInstLoc origin - sc_covars <- mkMetaCoVars eq_sc_theta' - wanted_sc_eqs <- mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars) - dfun_covars <- mkCoVars eq_dfun_theta' - dfun_eqs <- mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars) - dfun_dicts <- newDictBndrs inst_loc dict_dfun_theta' - this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + sc_loc <- getInstLoc InstScOrigin + sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + inst_loc <- getInstLoc origin + dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities + this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. -- Typecheck the methods - let -- These insts are in scope; quite a few, eh? - dfun_insts = dfun_eqs ++ dfun_dicts - wanted_sc_insts = wanted_sc_eqs ++ sc_dicts - this_dict_id = instToId this_dict - sc_dict_ids = map instToId sc_dicts - dfun_dict_ids = map instToId dfun_dicts - prag_fn = mkPragFun uprags - tc_meth = tcInstanceMethod loc clas inst_tyvars' - (dfun_covars ++ dfun_dict_ids) - dfun_theta' inst_tys' - this_dict_id dfun_id - prag_fn monobinds - (meth_exprs, meth_binds) <- mapAndUnzipM tc_meth op_items + let this_dict_id = instToId this_dict + dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities + prag_fn = mkPragFun uprags + tc_meth = tcInstanceMethod loc clas inst_tyvars' + dfun_dicts + dfun_theta' inst_tys' + this_dict dfun_id + prag_fn monobinds + (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ + mapAndUnzipM tc_meth op_items -- Figure out bindings for the superclass context -- Don't include this_dict in the 'givens', else - -- wanted_sc_insts get bound by just selecting from this_dict!! + -- sc_dicts get bound by just selecting from this_dict!! sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc dfun_insts - wanted_sc_insts + tcSimplifySuperClasses inst_loc dfun_dicts sc_dicts -- Note [Recursive superclasses] - -- It's possible that the superclass stuff might unified one - -- of the inst_tyavars' with something in the envt + -- It's possible that the superclass stuff might unified something + -- in the envt with one of the inst_tyvars' checkSigTyVars inst_tyvars' -- Deal with 'SPECIALISE instance' pragmas @@ -751,7 +748,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Create the result bindings let dict_constr = classDataCon clas - inline_prag | null dfun_insts = [] + inline_prag | null dfun_dicts = [] | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] -- Always inline the dfun; this is an experimental decision -- because it makes a big performance difference sometimes. @@ -764,8 +761,11 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- -- See Note [Inline dfuns] below - dict_rhs = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars) - (map HsVar sc_dict_ids ++ meth_exprs) + sc_dict_vars = map instToVar sc_dicts + dict_bind = L loc (VarBind this_dict_id dict_rhs) + dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs + inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys') + (dataConWrapId dict_constr) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because @@ -773,28 +773,15 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. - dict_bind = noLoc (VarBind this_dict_id dict_rhs) main_bind = noLoc $ AbsBinds - (inst_tyvars' ++ dfun_covars) - dfun_dict_ids - [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)] + inst_tyvars' + dfun_lam_vars + [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)] (dict_bind `consBag` sc_binds) showLIE (text "instance") return (main_bind `consBag` unionManyBags meth_binds) - -mkCoVars :: [PredType] -> TcM [TyVar] -mkCoVars = newCoVars . map unEqPred - where - unEqPred (EqPred ty1 ty2) = (ty1, ty2) - unEqPred _ = panic "TcInstDcls.mkCoVars" - -mkMetaCoVars :: [PredType] -> TcM [TyVar] -mkMetaCoVars = mapM eqPredToCoVar - where - eqPredToCoVar (EqPred ty1 ty2) = newMetaCoVar ty1 ty2 - eqPredToCoVar _ = panic "TcInstDcls.mkMetaCoVars" \end{code} Note [Recursive superclasses] @@ -821,23 +808,36 @@ tcInstanceMethod - Use tcValBinds to do the checking \begin{code} -tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var] +tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst] -> TcThetaType -> [TcType] - -> Id -> Id + -> Inst -> Id -> TcPragFun -> LHsBinds Name -> (Id, DefMeth) -> TcM (HsExpr Id, LHsBinds Id) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... -tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys - this_dict_id dfun_id - prag_fn binds_in (sel_id, dm_info) - = do { uniq <- newUnique - ; let local_meth_name = mkInternalName uniq sel_occ loc -- Same OccName - tc_body = tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys - this_dict_id dfun_id sel_id - prags local_meth_name +tcInstanceMethod loc clas tyvars dfun_dicts theta inst_tys + this_dict dfun_id prag_fn binds_in (sel_id, dm_info) + = do { cloned_this <- cloneDict this_dict + -- Need to clone the dict in case it is floated out, and + -- then clashes with its friends + ; uniq1 <- newUnique + ; let local_meth_name = mkInternalName uniq1 sel_occ loc -- Same OccName + this_dict_bind = L loc $ VarBind (instToId cloned_this) $ + L loc $ wrapId meth_wrapper dfun_id + mb_this_bind | null tyvars = Nothing + | otherwise = Just (cloned_this, this_dict_bind) + -- Only need the this_dict stuff if there are type variables + -- involved; otherwise overlap is not possible + -- See Note [Subtle interaction of recursion and overlap] + + tc_body rn_bind = do { (meth_id, tc_binds) <- tcInstanceMethodBody + InstSkol clas tyvars dfun_dicts theta inst_tys + mb_this_bind sel_id + local_meth_name + meth_sig_fn meth_prag_fn rn_bind + ; return (wrapId meth_wrapper meth_id, tc_binds) } ; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of -- There is a user-supplied method binding, so use it @@ -869,12 +869,21 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys where sel_name = idName sel_id sel_occ = nameOccName sel_name - prags = prag_fn sel_name - - error_rhs = HsApp (mkLHsWrap (WpTyApp meth_tau) error_id) error_msg - meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) - error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID) + this_dict_id = instToId this_dict + + meth_prag_fn _ = prag_fn sel_name + meth_sig_fn _ = Just [] -- The 'Just' says "yes, there's a type sig" + -- But there are no scoped type variables from local_method_id + -- Only the ones from the instance decl itself, which are already + -- in scope. Example: + -- class C a where { op :: forall b. Eq b => ... } + -- instance C [c] where { op = } + -- In , 'c' is scope but 'b' is not! + + error_rhs = HsApp error_fun error_msg + error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string))) + meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys @@ -883,53 +892,10 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys omitted_meth_warn = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id) ---------------- -tcInstanceMethodBody :: Class -> [TcTyVar] -> [Var] - -> TcThetaType -> [TcType] - -> Id -> Id -> Id - -> [LSig Name] -> Name -> LHsBind Name - -> TcM (HsExpr Id, LHsBinds Id) -tcInstanceMethodBody clas tyvars dfun_lam_vars theta inst_tys - this_dict_id dfun_id sel_id - prags local_meth_name bind@(L loc _) - = do { uniq <- newUnique - ; let (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id) - rho_ty = ASSERT( length sel_tyvars == length inst_tys ) - substTyWith sel_tyvars inst_tys sel_rho - - (first_pred, meth_tau) = tcSplitPredFunTy_maybe rho_ty - `orElse` pprPanic "tcInstanceMethod" (ppr sel_id) - - meth_name = mkInternalName uniq (getOccName local_meth_name) loc - meth_ty = mkSigmaTy tyvars theta meth_tau - meth_id = mkLocalId meth_name meth_ty - - local_meth_ty = mkSigmaTy tyvars (theta ++ [first_pred]) meth_tau - local_meth_id = mkLocalId local_meth_name local_meth_ty - - tv_names = map tyVarName tyvars - - -- The first predicate should be of form (C a b) - -- where C is the class in question - ; MASSERT( case getClassPredTys_maybe first_pred of - { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) - - ; local_meth_bind <- tcMethodBind tv_names prags local_meth_id bind - - ; let full_bind = unitBag $ L loc $ - VarBind meth_id $ L loc $ - mkHsWrap (mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars) $ - HsLet (HsValBinds (ValBindsOut [(NonRecursive, local_meth_bind)] [])) $ L loc $ - mkHsWrap (WpLet this_dict_bind <.> WpApp this_dict_id) $ - wrapId meth_wrapper local_meth_id - this_dict_bind = unitBag $ L loc $ - VarBind this_dict_id $ L loc $ - wrapId meth_wrapper dfun_id - - ; return (wrapId meth_wrapper meth_id, full_bind) } - where + dfun_lam_vars = map instToVar dfun_dicts meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) + wrapId :: HsWrapper -> id -> HsExpr id wrapId wrapper id = mkHsWrap wrapper (HsVar id) \end{code} diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index 11c0f3f..367536b 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -123,8 +123,8 @@ subFunTys error_herald n_pats res_ty mb_ctxt thing_inside | isSigmaTy res_ty -- Do this before checking n==0, because we -- guarantee to return a BoxyRhoType, not a -- BoxySigmaType - = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ - loop n args_so_far + = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ \ _ res_ty -> + loop n args_so_far res_ty ; return (gen_fn <.> co_fn, res) } loop 0 args_so_far res_ty @@ -770,7 +770,7 @@ tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty if exp_ib then -- SKOL does not apply if exp_ty is inside a box defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty else do - { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ body_exp_ty -> + { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ _ body_exp_ty -> tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty ; return (gen_fn <.> co_fn) } } @@ -896,21 +896,21 @@ wrapFunResCoercion arg_tys co_fn_res %************************************************************************ \begin{code} -tcGen :: BoxySigmaType -- expected_ty - -> TcTyVarSet -- Extra tyvars that the universally - -- quantified tyvars of expected_ty - -- must not be unified - -> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly from - -- a user type sig; bring tyvars into scope - -- Nothing => a higher order situation - -> (BoxyRhoType -> TcM result) +tcGen :: BoxySigmaType -- expected_ty + -> TcTyVarSet -- Extra tyvars that the universally + -- quantified tyvars of expected_ty + -- must not be unified + -> Maybe UserTypeCtxt -- Just ctxt => this polytype arose directly + -- from a user type sig + -- Nothing => a higher order situation + -> ([TcTyVar] -> BoxyRhoType -> TcM result) -> TcM (HsWrapper, result) -- The expression has type: spec_ty -> expected_ty tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty to be a forall-type -- If not, the call is a no-op = do { traceTc (text "tcGen") - ; ((tvs', theta', rho'), skol_info, scoped_tvs) <- instantiate expected_ty + ; ((tvs', theta', rho'), skol_info) <- instantiate expected_ty ; when debugIsOn $ traceTc (text "tcGen" <+> vcat [ @@ -922,10 +922,7 @@ tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty -- Type-check the arg and unify with poly type ; (result, lie) <- getLIE $ - tcExtendTyVarEnv2 (scoped_tvs `zip` mkTyVarTys tvs') $ - -- Extend the lexical type-variable environment - -- if we're in a user-type context - thing_inside rho' + thing_inside tvs' rho' -- Check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables @@ -953,23 +950,22 @@ tcGen expected_ty extra_tvs mb_ctxt thing_inside -- We expect expected_ty where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs - instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo, [Name]) + instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo) instantiate expected_ty - | Just ctxt <- mb_ctxt + | Just ctxt <- mb_ctxt -- This case split is the wohle reason for mb_ctxt = do { let skol_info = SigSkol ctxt - tv_names = map tyVarName (fst (tcSplitForAllTys expected_ty)) ; stuff <- tcInstSigType True skol_info expected_ty - ; return (stuff, skol_info, tv_names) } + ; return (stuff, skol_info) } | otherwise -- We want the GenSkol info in the skolemised type variables to -- mention the *instantiated* tyvar names, so that we get a -- good error message "Rigid variable 'a' is bound by (forall a. a->a)" -- Hence the tiresome but innocuous fixM - = fixM $ \ ~(_, skol_info, _) -> + = fixM $ \ ~(_, skol_info) -> do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty -- Get loation from *monad*, not from expected_ty ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) - ; return (stuff, skol_info, []) } + ; return (stuff, skol_info) } \end{code} -- 1.7.10.4