X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=e7c472b4751cbf3d863b209687da1596e0256eea;hp=c8e4b4649af9435772d1c2cce5ed6ca33fdf5262;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=f16dbbbe59cf3aa19c5fd384560a1b89076d7bc8 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index c8e4b46..e7c472b 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 @@ -94,18 +93,29 @@ Running example: -- Here op1_i, op2_i are the "instance method Ids" {-# 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 = -- Source code; run the type checker on this - -- NB: Type variable 'a' (but not 'b') is in scope in - -- Note [Tricky type variable scoping] + op1_i = /\a. \(d:C a). + let this :: C [a] + this = df_i a d + -- Note [Subtle interaction of recursion and overlap] + + local_op1 :: forall b. Ix b => [a] -> b -> b + 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 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d) -- The dictionary function itself {-# INLINE df_i #-} -- Always inline dictionary functions df_i :: forall a. C a -> C [a] - df_i = /\a. \d:C a. MkC (op1_i a d) ($dmop2 a d) + df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d) + ($dmop2 [a] d') + in d' -- But see Note [Default methods in instances] - -- We can't apply the type checker to the default-nmethod call + -- We can't apply the type checker to the default-method call * The dictionary function itself is inlined as vigorously as we possibly can, so that we expose that dictionary constructor to @@ -130,6 +140,49 @@ Running example: inlined. We need to fix this somehow -- perhaps allowing inlining of INLINE funcitons inside other INLINE functions. +Note [Subtle interaction of recursion and overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + class C a where { op1,op2 :: a -> a } + instance C a => C [a] where + op1 x = op2 x ++ op2 x + op2 x = ... + intance C [Int] where + ... + +When type-checking the C [a] instance, we need a C [a] dictionary (for +the call of op2). If we look up in the instance environment, we find +an overlap. And in *general* the right thing is to complain (see Note +[Overlapping instances] in InstEnv). But in *this* case it's wrong to +complain, because we just want to delegate to the op2 of this same +instance. + +Why is this justified? Because we generate a (C [a]) constraint in +a context in which 'a' cannot be instantiated to anything that matches +other overlapping instances, or else we would not be excecuting this +version of op1 in the first place. + +It might even be a bit disguised: + + nullFail :: C [a] => [a] -> [a] + nullFail x = op2 x ++ op2 x + + instance C a => C [a] where + op1 x = nullFail x + +Precisely this is used in package 'regex-base', module Context.hs. +See the overlapping instances for RegexContext, and the fact that they +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 +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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In our example @@ -478,7 +531,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ %* * -\subsection{Type-checking instance declarations, pass 2} + Type-checking instance declarations, pass 2 %* * %************************************************************************ @@ -518,7 +571,7 @@ tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- newtype N a = MkN (Tree [a]) deriving( Foo Int ) -- -- The newtype gives an FC axiom looking like --- axiom CoN a :: N a :=: Tree [a] +-- axiom CoN a :: N a ~ Tree [a] -- (see Note [Newtype coercions] in TyCon for this unusual form of axiom) -- -- So all need is to generate a binding looking like: @@ -535,7 +588,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) rigid_info = InstSkol origin = SigOrigin rigid_info inst_ty = idType dfun_id - ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty + ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty -- inst_head_ty is a PredType ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty @@ -552,34 +605,39 @@ 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_dicts get bound by just selecting from this_dict!! ; sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc dfun_dicts (rep_dict:sc_dicts) + tcSimplifySuperClasses inst_loc this_dict dfun_dicts + (rep_dict:sc_dicts) - ; let coerced_rep_dict = mkHsWrap the_coercion (HsVar (instToId rep_dict)) + -- It's possible that the superclass stuff might unified something + -- in the envt with one of the clas_tyvars + ; checkSigTyVars inst_tvs' + + ; let coerced_rep_dict = wrapId the_coercion (instToId rep_dict) ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict ; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body) ; return (unitBag $ noLoc $ - AbsBinds tvs (map instToVar dfun_dicts) - [(tvs, dfun_id, instToId this_dict, [])] + AbsBinds inst_tvs' (map instToVar dfun_dicts) + [(inst_tvs', dfun_id, instToId this_dict, [])] (dict_bind `consBag` sc_binds)) } where ----------------------- -- make_coercion -- The inst_head looks like (C s1 .. sm (T a1 .. ak)) -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak))) - -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm ) + -- with kind (C s1 .. sm (T a1 .. ak) ~ C s1 .. sm ) -- where rep_ty is the (eta-reduced) type rep of T -- So we just replace T with CoT, and insert a 'sym' -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced @@ -651,46 +709,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 - monobinds prag_fn - (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_binds <- addErrCtxt superClassCtxt - (tcSimplifySuperClasses inst_loc dfun_insts wanted_sc_insts) + -- sc_dicts get bound by just selecting from this_dict!! + sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc this_dict 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 @@ -699,7 +749,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. @@ -712,8 +762,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 @@ -721,31 +774,31 @@ 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #1470 for why we would *like* to add "this_dict" to the +available instances here. But we can't do so because then the superclases +get satisfied by selection from this_dict, and that leads to an immediate +loop. What we need is to add this_dict to Avails without adding its +superclasses, and we currently have no way to do that. + +%************************************************************************ +%* * + Type-checking an instance method +%* * +%************************************************************************ tcInstanceMethod - Make the method bindings, as a [(NonRec, HsBinds)], one per method @@ -756,51 +809,55 @@ tcInstanceMethod - Use tcValBinds to do the checking \begin{code} -tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Var] - -> TcThetaType -> [TcType] -> Id - -> LHsBinds Name -> TcPragFun +tcInstanceMethod :: SrcSpan -> Class -> [TcTyVar] -> [Inst] + -> TcThetaType -> [TcType] + -> 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 - binds_in prag_fn (sel_id, dm_info) - = 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) - - -- The first predicate should be of form (C a b) - -- where C is the class in question - meth_ty = mkSigmaTy tyvars theta meth_tau - meth_name = mkInternalName uniq sel_occ loc -- Same OccName - meth_id = mkLocalId meth_name meth_ty - - ; MASSERT( case getClassPredTys_maybe first_pred of - { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False } ) - - - ; case (findMethodBind sel_name meth_name binds_in, dm_info) of +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 - (Just user_bind, _) -> typecheck_meth meth_id user_bind + (Just user_bind, _) -> tc_body user_bind -- The user didn't supply a method binding, so we have to make -- up a default binding, in a way depending on the default-method info (Nothing, GenDefMeth) -> do -- Derivable type classes stuff - { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name - ; typecheck_meth meth_id meth_bind } + { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name + ; tc_body meth_bind } (Nothing, NoDefMeth) -> do -- No default method in the class { warn <- doptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && reportIfUnused (getOccName sel_id)) -- Don't warn about _foo methods - (omittedMethodWarn sel_id) - ; return (mk_error_rhs meth_tau, emptyBag) } + omitted_meth_warn + ; return (error_rhs, emptyBag) } (Nothing, DefMeth) -> do -- An polymorphic default method { -- Build the typechecked version directly, @@ -809,30 +866,39 @@ tcInstanceMethod loc clas tyvars dfun_lam_vars theta inst_tys this_dict_id dm_name <- lookupImportedName (mkDefMethRdrName sel_name) -- Might not be imported, but will be an OrigName ; dm_id <- tcLookupId dm_name - ; return (wrap dm_wrapper dm_id, emptyBag) } } + ; return (wrapId dm_wrapper dm_id, emptyBag) } } where sel_name = idName sel_id sel_occ = nameOccName sel_name - tv_names = map tyVarName tyvars - prags = prag_fn sel_name - - typecheck_meth :: Id -> LHsBind Name -> TcM (HsExpr Id, LHsBinds Id) - typecheck_meth meth_id bind - = do { tc_binds <- tcMethodBind tv_names prags meth_id bind - ; return (wrap meth_wrapper meth_id, tc_binds) } - - mk_error_rhs tau = HsApp (mkLHsWrap (WpTyApp tau) error_id) error_msg - 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 ]) - wrap wrapper id = mkHsWrap wrapper (HsVar id) - meth_wrapper = mkWpApps dfun_lam_vars `WpCompose` mkWpTyApps (mkTyVarTys tyvars) - dm_wrapper = WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys + dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys + + omitted_meth_warn :: SDoc + omitted_meth_warn = ptext (sLit "No explicit method nor default method for") + <+> quotes (ppr sel_id) + + dfun_lam_vars = map instToVar dfun_dicts + meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars) + -omittedMethodWarn :: Id -> SDoc -omittedMethodWarn sel_id - = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id) +wrapId :: HsWrapper -> id -> HsExpr id +wrapId wrapper id = mkHsWrap wrapper (HsVar id) \end{code} Note [Default methods in instances]