From: simonpj@microsoft.com Date: Fri, 10 Nov 2006 13:31:23 +0000 (+0000) Subject: Use implication constraints to improve type inference X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c Use implication constraints to improve type inference --- diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs index e2e596f..9c5b597 100644 --- a/compiler/typecheck/FamInst.lhs +++ b/compiler/typecheck/FamInst.lhs @@ -163,7 +163,7 @@ checkForConflicts inst_envs famInst Nothing -> panic "FamInst.checkForConflicts" Just (tc, tys) -> tc `mkTyConApp` tys } - ; (tvs', _, tau') <- tcInstSkolType (FamInstSkol tycon) ty + ; (tvs', _, tau') <- tcInstSkolType FamInstSkol ty ; let (fam, tys') = tcSplitTyConApp tau' diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 417e88a..2fc44dd 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -26,17 +26,17 @@ module Inst ( ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, instLoc, getDictClassTys, dictPred, - lookupInst, LookupInstResult(..), lookupPred, + lookupSimpleInst, LookupInstResult(..), lookupPred, tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, - isDict, isClassDict, isMethod, - isIPDict, isInheritableInst, - isTyVarDict, isMethodFor, + isDict, isClassDict, isMethod, isImplicInst, + isIPDict, isInheritableInst, isMethodOrLit, + isTyVarDict, isMethodFor, getDefaultableDicts, zonkInst, zonkInsts, instToId, instToVar, instName, - InstOrigin(..), InstLoc(..), pprInstLoc + InstOrigin(..), InstLoc, pprInstLoc ) where #include "HsVersions.h" @@ -53,6 +53,7 @@ import FunDeps import TcMType import TcType import Type +import Class import Unify import Module import Coercion @@ -73,6 +74,7 @@ import BasicTypes import SrcLoc import DynFlags import Maybes +import Util import Outputable \end{code} @@ -96,6 +98,25 @@ instToVar (Method {tci_id = id}) instToVar (Dict {tci_name = nm, tci_pred = pred}) | isEqPred pred = Var.mkCoVar nm (mkPredTy pred) | otherwise = mkLocalId nm (mkPredTy pred) +instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens, + tci_wanted = wanteds}) + = mkLocalId nm (mkImplicTy tvs givens wanteds) + +instType :: Inst -> Type +instType (LitInst {tci_ty = ty}) = ty +instType (Method {tci_id = id}) = idType id +instType (Dict {tci_pred = pred}) = mkPredTy pred +instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp) + (tci_wanted imp) + +mkImplicTy tvs givens wanteds -- The type of an implication constraint + = -- pprTrace "mkImplicTy" (ppr givens) $ + mkForAllTys tvs $ + mkPhiTy (map dictPred givens) $ + if isSingleton wanteds then + instType (head wanteds) + else + mkTupleTy Boxed (length wanteds) (map instType wanteds) instLoc inst = tci_loc inst @@ -111,9 +132,11 @@ getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst) -- Leaving these in is really important for the call to fdPredsOfInsts -- in TcSimplify.inferLoop, because the result is fed to 'grow', -- which is supposed to be conservative -fdPredsOfInst (Dict {tci_pred = pred}) = [pred] -fdPredsOfInst (Method {tci_theta = theta}) = theta -fdPredsOfInst other = [] -- LitInsts etc +fdPredsOfInst (Dict {tci_pred = pred}) = [pred] +fdPredsOfInst (Method {tci_theta = theta}) = theta +fdPredsOfInst (ImplicInst {tci_given = gs, + tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws) +fdPredsOfInst (LitInst {}) = [] fdPredsOfInsts :: [Inst] -> [PredType] fdPredsOfInsts insts = concatMap fdPredsOfInst insts @@ -123,22 +146,27 @@ isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta isInheritableInst other = True +--------------------------------- +-- Get the implicit parameters mentioned by these Insts +-- NB: the results of these functions are insensitive to zonking + ipNamesOfInsts :: [Inst] -> [Name] ipNamesOfInst :: Inst -> [Name] --- Get the implicit parameters mentioned by these Insts --- NB: ?x and %x get different Names ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst] ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n] ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta] ipNamesOfInst other = [] +--------------------------------- tyVarsOfInst :: Inst -> TcTyVarSet tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id -- The id might have free type variables; in the case of -- locally-overloaded class methods, for example +tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds}) + = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts @@ -164,6 +192,9 @@ isIPDict :: Inst -> Bool isIPDict (Dict {tci_pred = pred}) = isIPPred pred isIPDict other = False +isImplicInst (ImplicInst {}) = True +isImplicInst other = False + isMethod :: Inst -> Bool isMethod (Method {}) = True isMethod other = False @@ -171,9 +202,33 @@ isMethod other = False isMethodFor :: TcIdSet -> Inst -> Bool isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids isMethodFor ids inst = False -\end{code} +isMethodOrLit :: Inst -> Bool +isMethodOrLit (Method {}) = True +isMethodOrLit (LitInst {}) = True +isMethodOrLit other = False +\end{code} +\begin{code} +getDefaultableDicts :: [Inst] -> ([(Inst, Class, TcTyVar)], TcTyVarSet) +-- Look for free dicts of the form (C tv), even inside implications +-- *and* the set of tyvars mentioned by all *other* constaints +-- This disgustingly ad-hoc function is solely to support defaulting +getDefaultableDicts insts + = (concat ps, unionVarSets tvs) + where + (ps, tvs) = mapAndUnzip get insts + get d@(Dict {tci_pred = ClassP cls [ty]}) + | Just tv <- tcGetTyVar_maybe ty = ([(d,cls,tv)], emptyVarSet) + | otherwise = ([], tyVarsOfType ty) + get (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds}) + = ([ up | up@(_,_,tv) <- ups, not (tv `elemVarSet` tv_set)], + ftvs `minusVarSet` tv_set) + where + tv_set = mkVarSet tvs + (ups, ftvs) = getDefaultableDicts wanteds + get inst = ([], tyVarsOfInst inst) +\end{code} %************************************************************************ %* * @@ -197,7 +252,7 @@ newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta newDictBndr :: InstLoc -> TcPredType -> TcM Inst newDictBndr inst_loc pred = do { uniq <- newUnique - ; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred + ; let name = mkPredName uniq inst_loc pred ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) } ---------------- @@ -240,7 +295,7 @@ instCallDicts loc (EqPred ty1 ty2 : preds) instCallDicts loc (pred : preds) = do { uniq <- newUnique - ; let name = mkPredName uniq (instLocSrcLoc loc) pred + ; let name = mkPredName uniq loc pred dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc} ; (dicts, co_fn) <- instCallDicts loc preds ; return (dict:dicts, co_fn <.> WpApp (instToId dict)) } @@ -262,13 +317,22 @@ newIPDict orig ip_name ty newUnique `thenM` \ uniq -> let pred = IParam ip_name ty - name = mkPredName uniq (instLocSrcLoc inst_loc) pred + name = mkPredName uniq inst_loc pred dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc} in returnM (mapIPName (\n -> instToId dict) ip_name, dict) \end{code} +\begin{code} +mkPredName :: Unique -> InstLoc -> PredType -> Name +mkPredName uniq loc pred_ty + = mkInternalName uniq occ (srcSpanStart (instLocSpan loc)) + where + occ = case pred_ty of + ClassP cls tys -> mkDictOcc (getOccName cls) + IParam ip ty -> getOccName (ipNameName ip) +\end{code} %************************************************************************ %* * @@ -340,7 +404,7 @@ newMethod inst_loc id tys meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = inst_loc} - loc = instLocSrcLoc inst_loc + loc = srcSpanStart (instLocSpan inst_loc) in returnM inst \end{code} @@ -411,6 +475,12 @@ zonkInst lit@(LitInst {tci_ty = ty}) = zonkTcType ty `thenM` \ new_ty -> returnM (lit {tci_ty = new_ty}) +zonkInst implic@(ImplicInst {}) + = ASSERT( all isImmutableTyVar (tci_tyvars implic) ) + do { givens' <- zonkInsts (tci_given implic) + ; wanteds' <- zonkInsts (tci_wanted implic) + ; return (implic {tci_given = givens',tci_wanted = wanteds'}) } + zonkInsts insts = mappM zonkInst insts \end{code} @@ -430,36 +500,41 @@ instance Outputable Inst where pprDictsTheta :: [Inst] -> SDoc -- Print in type-like fashion (Eq a, Show b) -pprDictsTheta dicts = pprTheta (map dictPred dicts) +-- The Inst can be an implication constraint, but not a Method or LitInst +pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts))) pprDictsInFull :: [Inst] -> SDoc -- Print in type-like fashion, but with source location pprDictsInFull dicts = vcat (map go dicts) where - go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))] + go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)] pprInsts :: [Inst] -> SDoc -- Debugging: print the evidence :: type -pprInsts insts = brackets (interpp'SP insts) +pprInsts insts = brackets (interpp'SP insts) pprInst, pprInstInFull :: Inst -> SDoc -- Debugging: print the evidence :: type -pprInst (LitInst {tci_name = nm, tci_ty = ty}) = ppr nm <+> dcolon <+> ppr ty -pprInst (Dict {tci_name = nm, tci_pred = pred}) = ppr nm <+> dcolon <+> pprPred pred - -pprInst (Method {tci_id = inst_id, tci_oid = id, tci_tys = tys}) - = ppr inst_id <+> dcolon <+> - braces (sep [ppr id <+> ptext SLIT("at"), - brackets (sep (map pprParendType tys))]) +pprInst inst = ppr (instName inst) <+> dcolon + <+> (braces (ppr (instType inst)) $$ + ifPprDebug implic_stuff) + where + implic_stuff | isImplicInst inst = ppr (tci_reft inst) + | otherwise = empty -pprInstInFull inst - = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))] +pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)] tidyInst :: TidyEnv -> Inst -> Inst tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty} tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred} tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys} +tidyInst env implic@(ImplicInst {}) + = implic { tci_tyvars = tvs' + , tci_given = map (tidyInst env') (tci_given implic) + , tci_wanted = map (tidyInst env') (tci_wanted implic) } + where + (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic) tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst]) -- This function doesn't assume that the tyvars are in scope @@ -509,7 +584,7 @@ addLocalInst home_ie ispec -- We use tcInstSkolType because we don't want to allocate fresh -- *meta* type variables. let dfun = instanceDFunId ispec - ; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun) + ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun) ; let (cls, tys') = tcSplitDFunHead tau' dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') ispec' = setInstanceDFunId ispec dfun' @@ -581,46 +656,46 @@ addDictLoc ispec thing_inside \begin{code} data LookupInstResult = NoInstance - | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal - | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts + | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts + +lookupSimpleInst :: Inst -> TcM LookupInstResult +-- This is "simple" in tthat it returns NoInstance for implication constraints -lookupInst :: Inst -> TcM LookupInstResult -- It's important that lookupInst does not put any new stuff into -- the LIE. Instead, any Insts needed by the lookup are returned in -- the LookupInstResult, where they can be further processed by tcSimplify +--------------------- Impliciations ------------------------ +lookupSimpleInst (ImplicInst {}) = return NoInstance --- Methods - -lookupInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc}) +--------------------- Methods ------------------------ +lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc}) = do { (dicts, dict_app) <- instCallDicts loc theta ; let co_fn = dict_app <.> mkWpTyApps tys ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) } where - span = instLocSrcSpan loc - --- Literals + span = instLocSpan loc +--------------------- Literals ------------------------ -- Look for short cuts first: if the literal is *definitely* a -- int, integer, float or a double, generate the real thing here. -- This is essential (see nofib/spectral/nucleic). -- [Same shortcut as in newOverloadedLit, but we -- may have done some unification by now] -lookupInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc}) +lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc}) | Just expr <- shortCutIntLit i ty - = returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because - -- expr may be a constructor application + = returnM (GenInst [] (noLoc expr)) | otherwise = ASSERT( from_integer_name `isHsVar` fromIntegerName ) -- A LitInst invariant tcLookupId fromIntegerName `thenM` \ from_integer -> tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (mkHsApp (L (instLocSrcSpan loc) + (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) integer_lit)) -lookupInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc}) +lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc}) | Just expr <- shortCutFracLit f ty = returnM (GenInst [] (noLoc expr)) @@ -629,11 +704,11 @@ lookupInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_lo tcLookupId fromRationalName `thenM` \ from_rational -> tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> - returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) + returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) (HsVar (instToId method_inst))) rat_lit)) --- Dictionaries -lookupInst (Dict {tci_pred = pred, tci_loc = loc}) +--------------------- Dictionaries ------------------------ +lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc}) = do { mb_result <- lookupPred pred ; case mb_result of { Nothing -> return NoInstance ; @@ -668,11 +743,11 @@ lookupInst (Dict {tci_pred = pred, tci_loc = loc}) -- any nested for-alls in rho. So the in-scope set is unchanged dfun_rho = substTy tenv' rho (theta, _) = tcSplitPhiTy dfun_rho - src_loc = instLocSrcSpan loc + src_loc = instLocSpan loc dfun = HsVar dfun_id tys = map (substTyVar tenv') tyvars ; if null theta then - returnM (SimpleInst (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) + returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun)) else do { (dicts, dict_app) <- instCallDicts loc theta ; let co_fn = dict_app <.> mkWpTyApps tys @@ -799,7 +874,7 @@ syntaxNameCtxt name orig ty tidy_env msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> ptext SLIT("(needed by a syntactic construct)"), nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)), - nest 2 (pprInstLoc inst_loc)] + nest 2 (ptext SLIT("arising from") <+> pprInstLoc inst_loc)] in returnM (tidy_env, msg) \end{code} diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs index 57cb48c..bfb47d8 100644 --- a/compiler/typecheck/TcArrows.lhs +++ b/compiler/typecheck/TcArrows.lhs @@ -238,7 +238,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..] ; span <- getSrcSpanM - ; [w_tv] <- tcInstSkolTyVars (ArrowSkol span) [alphaTyVar] + ; [w_tv] <- tcInstSkolTyVars ArrowSkol [alphaTyVar] ; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point -- a ((w,t1) .. tn) t @@ -251,7 +251,8 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- Check expr ; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty)) - ; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie + ; loc <- getInstLoc (SigOrigin ArrowSkol) + ; inst_binds <- tcSimplifyCheck loc [w_tv] [] lie -- Check that the polymorphic variable hasn't been unified with anything -- and is not free in res_ty or the cmd_stk (i.e. t, t1..tn) @@ -303,8 +304,6 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) other -> (ty, []) - sig_msg = ptext SLIT("expected type of a command form") - ----------------------------------------------------------------- -- Base case for illegal commands -- This is where expressions that aren't commands get rejected diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 5d80433..9e0b583 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -710,16 +710,17 @@ generalise dflags top_lvl bind_list sig_fn mono_infos lie_req = tcSimplifyInfer doc tau_tvs lie_req | otherwise -- UNRESTRICTED CASE, WITH TYPE SIGS - = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty + = do { sig_lie <- unifyCtxts sigs -- sigs is non-empty; sig_lie is zonked ; let -- The "sig_avails" is the stuff available. We get that from -- the context of the type signature, BUT ALSO the lie_avail -- so that polymorphic recursion works right (see Note [Polymorphic recursion]) local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos] sig_avails = sig_lie ++ local_meths + loc = sig_loc (head sigs) -- Check that the needed dicts can be -- expressed in terms of the signature ones - ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req + ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req -- Check that signature type variables are OK ; final_qtvs <- checkSigsTyVars forall_tvs sigs @@ -754,14 +755,16 @@ might not otherwise be related. This is a rather subtle issue. \begin{code} unifyCtxts :: [TcSigInfo] -> TcM [Inst] +-- Post-condition: the returned Insts are full zonked unifyCtxts (sig1 : sigs) -- Argument is always non-empty = do { mapM unify_ctxt sigs - ; newDictBndrs (sig_loc sig1) (sig_theta sig1) } + ; theta <- zonkTcThetaType (sig_theta sig1) + ; newDictBndrs (sig_loc sig1) theta } where theta1 = sig_theta sig1 unify_ctxt :: TcSigInfo -> TcM () unify_ctxt sig@(TcSigInfo { sig_theta = theta }) - = setSrcSpan (instLocSrcSpan (sig_loc sig)) $ + = setSrcSpan (instLocSpan (sig_loc sig)) $ addErrCtxt (sigContextsCtxt sig1 sig) $ unifyTheta theta1 theta @@ -1060,8 +1063,7 @@ 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 - | otherwise = tcInstSigTyVars skol_info + inst_tyvars = tcInstSigTyVars use_skols skol_info ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id) ; loc <- getInstLoc (SigOrigin skol_info) ; return (TcSigInfo { sig_id = poly_id, diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 30dfc7c..92c7958 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -271,7 +271,7 @@ tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id -- Check the context { dict_binds <- tcSimplifyCheck - (ptext SLIT("class") <+> ppr clas) + loc tyvars [this_dict] insts_needed @@ -362,18 +362,18 @@ tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn let [(_, Just sig, local_meth_id)] = mono_bind_infos + loc = sig_loc sig in addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ - newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts -> + newDictBndrs loc (sig_theta sig) `thenM` \ meth_dicts -> let meth_tvs = sig_tvs sig all_tyvars = meth_tvs ++ inst_tyvars all_insts = avail_insts ++ meth_dicts in tcSimplifyCheck - (ptext SLIT("class or instance method") <+> quotes (ppr sel_id)) - all_tyvars all_insts meth_lie `thenM` \ lie_binds -> + loc all_tyvars all_insts meth_lie `thenM` \ lie_binds -> checkSigTyVars all_tyvars `thenM_` @@ -537,8 +537,8 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth other -> Nothing other -> Nothing -isInstDecl (SigOrigin (InstSkol _)) = True -isInstDecl (SigOrigin (ClsSkol _)) = False +isInstDecl (SigOrigin InstSkol) = True +isInstDecl (SigOrigin (ClsSkol _)) = False \end{code} diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index 2e3b80b..cc50e50 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -400,6 +400,9 @@ refineEnvironment :: Refinement -> TcM a -> TcM a -- I don't think I have to refine the set of global type variables in scope -- Reason: the refinement never increases that set refineEnvironment reft thing_inside + | isEmptyRefinement reft -- Common case + = thing_inside + | otherwise = do { env <- getLclEnv ; let le' = mapNameEnv refine (tcl_env env) ; setLclEnv (env {tcl_env = le'}) thing_inside } diff --git a/compiler/typecheck/TcGadt.lhs b/compiler/typecheck/TcGadt.lhs index 4c1f70e..987a4c6 100644 --- a/compiler/typecheck/TcGadt.lhs +++ b/compiler/typecheck/TcGadt.lhs @@ -11,8 +11,9 @@ \begin{code} module TcGadt ( - Refinement, emptyRefinement, gadtRefine, - refineType, refineResType, + Refinement, emptyRefinement, isEmptyRefinement, + gadtRefine, + refineType, refinePred, refineResType, dataConCanMatch, tcUnifyTys, BindFlag(..) ) where @@ -22,6 +23,7 @@ module TcGadt ( import HsSyn import Coercion import Type + import TypeRep import DataCon import Var @@ -61,6 +63,8 @@ instance Outputable Refinement where emptyRefinement :: Refinement emptyRefinement = (Reft emptyInScopeSet emptyVarEnv) +isEmptyRefinement :: Refinement -> Bool +isEmptyRefinement (Reft _ env) = isEmptyVarEnv env refineType :: Refinement -> Type -> Maybe (Coercion, Type) -- Apply the refinement to the type. @@ -77,6 +81,17 @@ refineType (Reft in_scope env) ty tv_subst = mkTvSubst in_scope (mapVarEnv snd env) co_subst = mkTvSubst in_scope (mapVarEnv fst env) +refinePred :: Refinement -> PredType -> Maybe (Coercion, PredType) +refinePred (Reft in_scope env) pred + | not (isEmptyVarEnv env), -- Common case + any (`elemVarEnv` env) (varSetElems (tyVarsOfPred pred)) + = Just (mkPredTy (substPred co_subst pred), substPred tv_subst pred) + | otherwise + = Nothing -- The type doesn't mention any refined type variables + where + tv_subst = mkTvSubst in_scope (mapVarEnv snd env) + co_subst = mkTvSubst in_scope (mapVarEnv fst env) + refineResType :: Refinement -> Type -> (HsWrapper, Type) -- Like refineType, but returns the 'sym' coercion -- If (refineResType r ty) = (co, ty') diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 3d365ab..6f92e4b 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -800,7 +800,6 @@ pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> co pp_sig (FunSigCtxt n) = pp_n_colon n pp_sig (ConArgCtxt n) = pp_n_colon n pp_sig (ForSigCtxt n) = pp_n_colon n - pp_sig (RuleSigCtxt n) = pp_n_colon n pp_sig other = ppr (unLoc hs_ty) pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ac5c896..10bfed7 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -483,7 +483,7 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) = do { let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id + rigid_info = InstSkol origin = SigOrigin rigid_info inst_ty = idType dfun_id ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty @@ -518,7 +518,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) make_wrapper inst_loc tvs theta (Just preds) -- Case (a) = ASSERT( null tvs && null theta ) do { dicts <- newDictBndrs inst_loc preds - ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts) + ; sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc [] dicts -- Use tcSimplifySuperClasses to avoid creating loops, for the -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify ; return (map instToId dicts, idHsWrapper, sc_binds) } @@ -584,7 +585,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) = let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id + rigid_info = InstSkol inst_ty = idType dfun_id in -- Prime error recovery @@ -626,9 +627,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Don't include this_dict in the 'givens', else -- sc_dicts get bound by just selecting from this_dict!! addErrCtxt superClassCtxt - (tcSimplifySuperClasses inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ sc_binds -> + (tcSimplifySuperClasses inst_loc + dfun_arg_dicts sc_dicts) `thenM` \ sc_binds -> -- It's possible that the superclass stuff might unified one -- of the inst_tyavars' with something in the envt diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs index 4633f49..4a12536 100644 --- a/compiler/typecheck/TcMType.lhs +++ b/compiler/typecheck/TcMType.lhs @@ -78,6 +78,7 @@ import Util import Maybes import ListSetOps import UniqSupply +import SrcLoc import Outputable import Control.Monad ( when ) @@ -160,19 +161,30 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar] tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info | tv <- tyvars ] -tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) --- Instantiate a type with fresh skolem constants -tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty - -tcInstSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar -tcInstSkolTyVar info tyvar +tcInstSkolTyVar :: SkolemInfo -> Maybe SrcLoc -> TyVar -> TcM TcTyVar +-- Instantiate the tyvar, using +-- * the occ-name and kind of the supplied tyvar, +-- * the unique from the monad, +-- * the location either from the tyvar (mb_loc = Nothing) +-- or from mb_loc (Just loc) +tcInstSkolTyVar info mb_loc tyvar = do { uniq <- newUnique - ; let name = setNameUnique (tyVarName tyvar) uniq - kind = tyVarKind tyvar - ; return (mkSkolTyVar name kind info) } + ; let old_name = tyVarName tyvar + kind = tyVarKind tyvar + loc = mb_loc `orElse` getSrcLoc old_name + new_name = mkInternalName uniq (nameOccName old_name) loc + ; return (mkSkolTyVar new_name kind info) } tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar] -tcInstSkolTyVars info tyvars = mapM (tcInstSkolTyVar info) tyvars +-- Get the location from the monad +tcInstSkolTyVars info tyvars + = do { span <- getSrcSpanM + ; mapM (tcInstSkolTyVar info (Just (srcSpanStart span))) tyvars } + +tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType) +-- Instantiate a type with fresh skolem constants +-- Binding location comes from the monad +tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty \end{code} @@ -275,9 +287,14 @@ tcInstTyVars tyvars %************************************************************************ \begin{code} -tcInstSigTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar] --- Instantiate with meta SigTvs -tcInstSigTyVars skol_info tyvars +tcInstSigTyVars :: Bool -> SkolemInfo -> [TyVar] -> TcM [TcTyVar] +-- Instantiate with skolems or meta SigTvs; depending on use_skols +-- Always take location info from the supplied tyvars +tcInstSigTyVars use_skols skol_info tyvars + | use_skols + = mapM (tcInstSkolTyVar skol_info Nothing) tyvars + + | otherwise = mapM (instMetaTyVar (SigTv skol_info)) tyvars zonkSigTyVar :: TcTyVar -> TcM TcTyVar @@ -686,7 +703,6 @@ checkValidType ctxt ty ConArgCtxt _ -> Rank 1 -- We are given the type of the entire -- constructor, hence rank 1 ForSigCtxt _ -> Rank 1 - RuleSigCtxt _ -> Rank 1 SpecInstCtxt -> Rank 1 actual_kind = typeKind ty @@ -1012,7 +1028,9 @@ even in a scope where b is in scope. \begin{code} checkFreeness forall_tyvars theta - = mappM_ complain (filter is_free theta) + = do { gla_exts <- doptM Opt_GlasgowExts + ; if gla_exts then return () -- New! Oct06 + else mappM_ complain (filter is_free theta) } where is_free pred = not (isIPPred pred) && not (any bound_var (varSetElems (tyVarsOfPred pred))) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index c9b5d6e..933adb8 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -531,14 +531,14 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon -> HsConDetails Name (LPat Name) -> (PatState -> TcM a) -> TcM (Pat TcId, [TcTyVar], a) tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside - = do { span <- getSrcSpanM -- Span for the whole pattern - ; let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con - skol_info = PatSkol data_con span + = do { let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con + skol_info = PatSkol data_con origin = SigOrigin skol_info -- Instantiate the constructor type variables [a->ty] ; ctxt_res_tys <- boxySplitTyConAppWithFamily tycon pat_ty - ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs + ; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs -- Get location from monad, + -- not from ex_tvs ; let tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) (ctxt_res_tys ++ mkTyVarTys ex_tvs') eq_spec' = substEqSpec tenv eq_spec @@ -553,7 +553,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; loc <- getInstLoc origin ; dicts <- newDictBndrs loc theta' - ; dict_binds <- tcSimplifyCheck doc ex_tvs' dicts lie_req + ; dict_binds <- tcSimplifyCheckPat loc co_vars (pat_reft pstate') + ex_tvs' dicts lie_req ; addDataConStupidTheta data_con ctxt_res_tys @@ -567,8 +568,6 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ex_tvs' ++ inner_tvs, res) } where - doc = ptext SLIT("existential context for") <+> quotes (ppr data_con) - -- Split against the family tycon if the pattern constructor belongs to a -- representation tycon. -- diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index bd4eb9b..af9a03d 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -65,7 +65,6 @@ import Module import UniqFM import Name import NameSet -import NameEnv import TyCon import SrcLoc import HscTypes @@ -188,6 +187,8 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { + failIfErrsM ; -- reportDeprecations crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) traceRn (text "rn3") ; -- Report the use of any deprecated things @@ -336,29 +337,15 @@ tcRnSrcDecls decls boot_iface <- tcHiBootIface mod ; -- Do all the declarations - (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ; - - -- tcSimplifyTop deals with constant or ambiguous InstIds. - -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) - traceTc (text "Tc8") ; - inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids to tcSimplifyTop, - -- so that we get better error messages (monomorphism restriction) + tcg_env <- tc_rn_src_decls boot_iface decls ; -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs ; - TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) - rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, @@ -375,32 +362,40 @@ tcRnSrcDecls decls return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) } -tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls boot_details ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) - -- Type check the decls up to, but not including, the first splice - tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- rnTopSrcDecls first_group ; + ((tcg_env, tcl_env), lie) <- getLIE $ setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; - -- Bale out if errors; for example, error recovery when checking - -- the RHS of 'main' can mean that 'main' is not in the envt for - -- the subsequent checkMain test - failIfErrsM ; + -- tcSimplifyTop deals with constant or ambiguous InstIds. + -- How could there be ambiguous ones? They can only arise if a + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + traceTc (text "Tc8") ; + inst_binds <- setEnvs (tcg_env, tcl_env) (tcSimplifyTop lie) ; + -- Setting the global env exposes the instances to tcSimplifyTop + -- Setting the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) + + let { tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` inst_binds } } ; - setEnvs tc_envs $ + setEnvs (tcg_env', tcl_env) $ -- If there is no splice, we're nearly done case group_tail of { - Nothing -> do { -- Last thing: check for `main' - tcg_env <- checkMain ; - return (tcg_env, tcl_env) - } ; + Nothing -> -- Last thing: check for `main' + checkMain ; -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr, rest_ds) -> do { + Just (SpliceDecl splice_expr, rest_ds) -> + do { #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else @@ -568,17 +563,6 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) - -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_details decls - = do { -- Rename the declarations - (tcg_env, rn_decls) <- rnTopSrcDecls decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the declarations - tcTopSrcDecls boot_details rn_decls - }} - ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 37f1eab..dc23308 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -28,8 +28,8 @@ module TcRnTypes( ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Insts - Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, - instLocSrcLoc, instLocSrcSpan, + Inst(..), InstOrigin(..), InstLoc(..), + pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, LIE, emptyLIE, unitLIE, plusLIE, consLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -44,6 +44,7 @@ import HscTypes import Packages import Type import TcType +import TcGadt import InstEnv import FamInstEnv import IOEnv @@ -594,6 +595,18 @@ data Inst tci_loc :: InstLoc } + | ImplicInst { -- An implication constraint + -- forall tvs. (reft, given) => wanted + tci_name :: Name, + tci_reft :: Refinement, + tci_tyvars :: [TcTyVar], + tci_given :: [Inst], -- Only Dicts + -- (no Methods, LitInsts, ImplicInsts) + tci_wanted :: [Inst], -- Only Dicts and ImplicInsts + -- (no Methods or LitInsts) + tci_loc :: InstLoc + } + | Method { tci_id :: TcId, -- The Id for the Inst @@ -638,7 +651,8 @@ data Inst @Insts@ are ordered by their class/type info, rather than by their unique. This allows the context-reduction mechanism to use standard finite -maps to do their stuff. +maps to do their stuff. It's horrible that this code is here, rather +than with the Avails handling stuff in TcSimplify \begin{code} instance Ord Inst where @@ -661,6 +675,14 @@ cmpInst (LitInst {}) (Dict {}) = GT cmpInst (LitInst {}) (Method {}) = GT cmpInst l1@(LitInst {}) l2@(LitInst {}) = (tci_lit l1 `compare` tci_lit l2) `thenCmp` (tci_ty l1 `tcCmpType` tci_ty l2) +cmpInst (LitInst {}) other = LT + + -- Implication constraints are compared by *name* + -- not by type; that is, we make no attempt to do CSE on them +cmpInst (ImplicInst {}) (Dict {}) = GT +cmpInst (ImplicInst {}) (Method {}) = GT +cmpInst (ImplicInst {}) (LitInst {}) = GT +cmpInst i1@(ImplicInst {}) i2@(ImplicInst {}) = tci_name i1 `compare` tci_name i2 \end{code} @@ -700,14 +722,22 @@ It appears in TcMonad because there are a couple of error-message-generation functions that deal with it. \begin{code} +------------------------------------------- data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt -instLocSrcLoc :: InstLoc -> SrcLoc -instLocSrcLoc (InstLoc _ src_span _) = srcSpanStart src_span +instLocSpan :: InstLoc -> SrcSpan +instLocSpan (InstLoc _ s _) = s + +instLocOrigin :: InstLoc -> InstOrigin +instLocOrigin (InstLoc o _ _) = o -instLocSrcSpan :: InstLoc -> SrcSpan -instLocSrcSpan (InstLoc _ src_span _) = src_span +pprInstArising :: Inst -> SDoc +pprInstArising loc = ptext SLIT("arising from") <+> pprInstLoc (tci_loc loc) + +pprInstLoc :: InstLoc -> SDoc +pprInstLoc (InstLoc orig span _) = sep [ppr orig, text "at" <+> ppr span] +------------------------------------------- data InstOrigin = SigOrigin SkolemInfo -- Pattern, class decl, inst decl etc; -- Places that bind type variables and introduce @@ -737,27 +767,23 @@ data InstOrigin | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression | ProcOrigin -- Arising from a proc expression -\end{code} - -\begin{code} -pprInstLoc :: InstLoc -> SDoc -pprInstLoc (InstLoc orig locn _) - = sep [text "arising from" <+> pp_orig orig, - text "at" <+> ppr locn] - where - pp_orig (OccurrenceOf name) = hsep [ptext SLIT("use of"), quotes (ppr name)] - pp_orig (IPOccOrigin name) = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)] - pp_orig (IPBindOrigin name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)] - pp_orig RecordUpdOrigin = ptext SLIT("a record update") - pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] - pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] - pp_orig (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] - pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature") - pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration") - pp_orig DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration") - pp_orig StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration") - pp_orig DefaultOrigin = ptext SLIT("a 'default' declaration") - pp_orig DoOrigin = ptext SLIT("a do statement") - pp_orig ProcOrigin = ptext SLIT("a proc expression") - pp_orig (SigOrigin info) = pprSkolInfo info + | ImplicOrigin SDoc -- An implication constraint + +instance Outputable InstOrigin where + ppr (OccurrenceOf name) = hsep [ptext SLIT("a use of"), quotes (ppr name)] + ppr (IPOccOrigin name) = hsep [ptext SLIT("a use of implicit parameter"), quotes (ppr name)] + ppr (IPBindOrigin name) = hsep [ptext SLIT("a binding for implicit parameter"), quotes (ppr name)] + ppr RecordUpdOrigin = ptext SLIT("a record update") + ppr (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)] + ppr (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)] + ppr (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)] + ppr InstSigOrigin = ptext SLIT("instantiating a type signature") + ppr InstScOrigin = ptext SLIT("the superclasses of an instance declaration") + ppr DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration") + ppr StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration") + ppr DefaultOrigin = ptext SLIT("a 'default' declaration") + ppr DoOrigin = ptext SLIT("a do statement") + ppr ProcOrigin = ptext SLIT("a proc expression") + ppr (ImplicOrigin doc) = doc + ppr (SigOrigin info) = pprSkolInfo info \end{code} diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs index ef8e388..0a2babe 100644 --- a/compiler/typecheck/TcRules.lhs +++ b/compiler/typecheck/TcRules.lhs @@ -78,7 +78,8 @@ tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs) -- -- NB: tcSimplifyInferCheck zonks the forall_tvs, and -- knocks out any that are constrained by the environment - tcSimplifyInferCheck (text "tcRule") + getInstLoc (SigOrigin (RuleSkol name)) `thenM` \ loc -> + tcSimplifyInferCheck loc forall_tvs lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> mappM zonkQuantifiedTyVar forall_tvs1 `thenM` \ forall_tvs2 -> @@ -100,7 +101,7 @@ tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside -- e.g x :: a->a -- The tyvar 'a' is brought into scope first, just as if you'd written -- a::*, x :: a->a - = do { let ctxt = RuleSigCtxt (unLoc var) + = do { let ctxt = FunSigCtxt (unLoc var) ; (tyvars, ty) <- tcHsPatSigType ctxt rn_ty ; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index ef019df..23d0b23 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -12,7 +12,7 @@ module TcSimplify ( tcSimplifyRuleLhs, tcSimplifyIPs, tcSimplifySuperClasses, tcSimplifyTop, tcSimplifyInteractive, - tcSimplifyBracket, + tcSimplifyBracket, tcSimplifyCheckPat, tcSimplifyDeriv, tcSimplifyDefault, bindInstsOfLocalFuns @@ -27,10 +27,10 @@ import TcRnMonad import Inst import TcEnv import InstEnv +import TcGadt import TcMType import TcType import TcIface -import Id import Var import TyCon import Name @@ -668,16 +668,17 @@ inferLoop doc tau_tvs wanteds try_me inst | isFreeWhenInferring qtvs inst = Free - | isClassDict inst = DontReduceUnlessConstant -- Dicts - | otherwise = ReduceMe NoSCs -- Lits and Methods + | isClassDict inst = Irred -- Dicts + | otherwise = ReduceMe NoSCs -- Lits and Methods + env = mkRedEnv doc try_me [] in traceTc (text "infloop" <+> vcat [ppr tau_tvs', ppr wanteds', ppr preds, ppr (grow preds tau_tvs'), ppr qtvs]) `thenM_` -- Step 2 - reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> + reduceContext env wanteds' `thenM` \ (improved, frees, binds, irreds) -> -- Step 3 - if no_improvement then + if not improved then returnM (varSetElems qtvs, frees, binds, irreds) else -- If improvement did some unification, we go round again. There @@ -746,12 +747,14 @@ isFreeWhenInferring qtvs inst && isInheritableInst inst -- And no implicit parameter involved -- (see "Notes on implicit parameters") +{- No longer used (with implication constraints) isFreeWhenChecking :: TyVarSet -- Quantified tyvars -> NameSet -- Quantified implicit parameters -> Inst -> Bool isFreeWhenChecking qtvs ips inst = isFreeWrtTyVars qtvs inst && isFreeWrtIPs ips inst +-} isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst)) @@ -768,45 +771,190 @@ isFreeWrtIPs ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst)) we are going to quantify over. For example, a class or instance declaration. \begin{code} -tcSimplifyCheck - :: SDoc - -> [TcTyVar] -- Quantify over these - -> [Inst] -- Given - -> [Inst] -- Wanted - -> TcM TcDictBinds -- Bindings - +----------------------------------------------------------- -- tcSimplifyCheck is used when checking expression type signatures, -- class decls, instance decls etc. --- --- NB: tcSimplifyCheck does not consult the --- global type variables in the environment; so you don't --- need to worry about setting them before calling tcSimplifyCheck -tcSimplifyCheck doc qtvs givens wanted_lie +tcSimplifyCheck :: InstLoc + -> [TcTyVar] -- Quantify over these + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM TcDictBinds -- Bindings +tcSimplifyCheck loc qtvs givens wanteds = ASSERT( all isSkolemTyVar qtvs ) - do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie - ; extendLIEs frees - ; return binds } + do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds + ; implic_bind <- makeImplicationBind loc [] emptyRefinement + qtvs givens irreds + ; return (binds `unionBags` implic_bind) } + +----------------------------------------------------------- +-- tcSimplifyCheckPat is used for existential pattern match +tcSimplifyCheckPat :: InstLoc + -> [CoVar] -> Refinement + -> [TcTyVar] -- Quantify over these + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM TcDictBinds -- Bindings +tcSimplifyCheckPat loc co_vars reft qtvs givens wanteds + = ASSERT( all isSkolemTyVar qtvs ) + do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds + ; implic_bind <- makeImplicationBind loc co_vars reft + qtvs givens irreds + ; return (binds `unionBags` implic_bind) } + +----------------------------------------------------------- +makeImplicationBind :: InstLoc -> [CoVar] -> Refinement + -> [TcTyVar] -> [Inst] -> [Inst] + -> TcM TcDictBinds +-- Make a binding that binds 'irreds', by generating an implication +-- constraint for them, *and* throwing the constraint into the LIE +makeImplicationBind loc co_vars reft qtvs givens irreds + = do { let givens' = filter isDict givens + -- The givens can include methods + + -- If there are no 'givens', then it's safe to + -- partition the 'wanteds' by their qtvs, thereby trimming irreds + -- See Note [Freeness and implications] + ; irreds <- if null givens' + then do + { let qtv_set = mkVarSet qtvs + (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds + ; extendLIEs frees + ; return real_irreds } + else + return irreds + + -- If there are no irreds, we are done! + ; if null irreds then + return emptyBag + else do + + -- Otherwise we must generate a binding + -- The binding looks like + -- (ir1, .., irn) = f qtvs givens + -- where f is (evidence for) the new implication constraint + -- + -- This binding must line up the 'rhs' in reduceImplication + + { uniq <- newUnique + ; span <- getSrcSpanM + ; let all_tvs = qtvs ++ co_vars -- Abstract over all these + name = mkInternalName uniq (mkVarOcc "ic") (srcSpanStart span) + implic_inst = ImplicInst { tci_name = name, tci_reft = reft, + tci_tyvars = all_tvs, + tci_given = givens', + tci_wanted = irreds, tci_loc = loc } + + ; let n_irreds = length irreds + irred_ids = map instToId irreds + tup_ty = mkTupleTy Boxed n_irreds (map idType irred_ids) + pat = TuplePat (map nlVarPat irred_ids) Boxed tup_ty + rhs = L span (mkHsWrap co (HsVar (instToId implic_inst))) + co = mkWpApps (map instToId givens') <.> mkWpTyApps (mkTyVarTys all_tvs) + bind | n_irreds==1 = VarBind (head irred_ids) rhs + | otherwise = PatBind { pat_lhs = L span pat, + pat_rhs = unguardedGRHSs rhs, + pat_rhs_ty = tup_ty, + bind_fvs = placeHolderNames } + ; -- pprTrace "Make implic inst" (ppr implic_inst) $ + extendLIE implic_inst + ; return (unitBag (L span bind)) }} + + +----------------------------------------------------------- +topCheckLoop :: SDoc + -> [Inst] -- Wanted + -> TcM (TcDictBinds, + [Inst]) -- Irreducible + +topCheckLoop doc wanteds + = checkLoop (mkRedEnv doc try_me []) wanteds where --- get_qtvs = zonkTcTyVarsAndFV qtvs - get_qtvs = return (mkVarSet qtvs) -- All skolems + try_me inst = ReduceMe AddSCs + +----------------------------------------------------------- +innerCheckLoop :: InstLoc -> WantSCs + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM (TcDictBinds, + [Inst]) -- Irreducible + +innerCheckLoop inst_loc want_scs givens wanteds + = checkLoop env wanteds + where + env = mkRedEnv (pprInstLoc inst_loc) try_me givens + + try_me inst | isMethodOrLit inst = ReduceMe want_scs + | otherwise = Irred + -- When checking against a given signature + -- we MUST be very gentle: Note [Check gently] +\end{code} + +Note [Check gently] +~~~~~~~~~~~~~~~~~~~~ +We have to very careful about not simplifying too vigorously +Example: + data T a where + MkT :: a -> T [a] + + f :: Show b => T b -> b + f (MkT x) = show [x] + +Inside the pattern match, which binds (a:*, x:a), we know that + b ~ [a] +Hence we have a dictionary for Show [a] available; and indeed we +need it. We are going to build an implication contraint + forall a. (b~[a]) => Show [a] +Later, we will solve this constraint using the knowledge (Show b) + +But we MUST NOT reduce (Show [a]) to (Show a), else the whole +thing becomes insoluble. So we simplify gently (get rid of literals +and methods only, plus common up equal things), deferring the real +work until top level, when we solve the implication constraint +with topCheckLooop. + + +\begin{code} +----------------------------------------------------------- +checkLoop :: RedEnv + -> [Inst] -- Wanted + -> TcM (TcDictBinds, + [Inst]) -- Irreducible +-- Precondition: the try_me never returns Free +-- givens are completely rigid + +checkLoop env wanteds + = do { -- Givens are skolems, so no need to zonk them + wanteds' <- mappM zonkInst wanteds + + ; (improved, _frees, binds, irreds) <- reduceContext env wanteds' + + ; ASSERT( null _frees ) + + if not improved then + return (binds, irreds) + else do + + { (binds1, irreds1) <- checkLoop env irreds + ; return (binds `unionBags` binds1, irreds1) } } +\end{code} +\begin{code} +----------------------------------------------------------- -- tcSimplifyInferCheck is used when we know the constraints we are to simplify -- against, but we don't know the type variables over which we are going to quantify. -- This happens when we have a type signature for a mutually recursive group tcSimplifyInferCheck - :: SDoc + :: InstLoc -> TcTyVarSet -- fv(T) -> [Inst] -- Given -> [Inst] -- Wanted -> TcM ([TcTyVar], -- Variables over which to quantify TcDictBinds) -- Bindings -tcSimplifyInferCheck doc tau_tvs givens wanted_lie - = do { (qtvs', frees, binds) <- tcSimplCheck doc get_qtvs AddSCs givens wanted_lie - ; extendLIEs frees - ; return (qtvs', binds) } - where +tcSimplifyInferCheck loc tau_tvs givens wanteds + = do { (binds, irreds) <- innerCheckLoop loc AddSCs givens wanteds + -- Figure out which type variables to quantify over -- You might think it should just be the signature tyvars, -- but in bizarre cases you can get extra ones @@ -816,60 +964,18 @@ tcSimplifyInferCheck doc tau_tvs givens wanted_lie -- Here we infer g :: forall a b. a -> b -> (b,a) -- We don't want g to be monomorphic in b just because -- f isn't quantified over b. - all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) - - get_qtvs = zonkTcTyVarsAndFV all_tvs `thenM` \ all_tvs' -> - tcGetGlobalTyVars `thenM` \ gbl_tvs -> - let - qtvs = all_tvs' `minusVarSet` gbl_tvs - -- We could close gbl_tvs, but its not necessary for - -- soundness, and it'll only affect which tyvars, not which - -- dictionaries, we quantify over - in - returnM qtvs -\end{code} - -Here is the workhorse function for all three wrappers. - -\begin{code} -tcSimplCheck doc get_qtvs want_scs givens wanted_lie - = do { (qtvs, frees, binds, irreds) <- check_loop givens wanted_lie - - -- Complain about any irreducible ones - ; if not (null irreds) - then do { givens' <- mappM zonkInst given_dicts_and_ips - ; groupErrs (addNoInstanceErrs (Just doc) givens') irreds } - else return () - - ; returnM (qtvs, frees, binds) } - where - given_dicts_and_ips = filter (not . isMethod) givens - -- For error reporting, filter out methods, which are - -- only added to the given set as an optimisation - - ip_set = mkNameSet (ipNamesOfInsts givens) - - check_loop givens wanteds - = -- Step 1 - mappM zonkInst givens `thenM` \ givens' -> - mappM zonkInst wanteds `thenM` \ wanteds' -> - get_qtvs `thenM` \ qtvs' -> - - -- Step 2 - let - -- When checking against a given signature we always reduce - -- until we find a match against something given, or can't reduce - try_me inst | isFreeWhenChecking qtvs' ip_set inst = Free - | otherwise = ReduceMe want_scs - in - reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> - - -- Step 3 - if no_improvement then - returnM (varSetElems qtvs', frees, binds, irreds) - else - check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) -> - returnM (qtvs', frees1, binds `unionBags` binds1, irreds1) + ; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens) + ; all_tvs <- zonkTcTyVarsAndFV all_tvs + ; gbl_tvs <- tcGetGlobalTyVars + ; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs) + -- We could close gbl_tvs, but its not necessary for + -- soundness, and it'll only affect which tyvars, not which + -- dictionaries, we quantify over + + -- Now we are back to normal (c.f. tcSimplCheck) + ; implic_bind <- makeImplicationBind loc [] emptyRefinement + qtvs givens irreds + ; return (qtvs, binds `unionBags` implic_bind) } \end{code} @@ -918,15 +1024,20 @@ Two more nasty cases are in tcrun033 \begin{code} -tcSimplifySuperClasses qtvs givens sc_wanteds - = ASSERT( all isSkolemTyVar qtvs ) - do { (_, frees, binds1) <- tcSimplCheck doc get_qtvs NoSCs givens sc_wanteds - ; ext_default <- doptM Opt_ExtendedDefaultRules - ; binds2 <- tc_simplify_top doc ext_default NoSCs frees - ; return (binds1 `unionBags` binds2) } +tcSimplifySuperClasses + :: InstLoc + -> [Inst] -- Given + -> [Inst] -- Wanted + -> TcM TcDictBinds +tcSimplifySuperClasses loc givens sc_wanteds + = do { (binds1, irreds) <- checkLoop env sc_wanteds + ; let (tidy_env, tidy_irreds) = tidyInsts irreds + ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds + ; return binds1 } where - get_qtvs = return (mkVarSet qtvs) - doc = ptext SLIT("instance declaration superclass context") + env = mkRedEnv (pprInstLoc loc) try_me givens + try_me inst = ReduceMe NoSCs + -- Like topCheckLoop, but with NoSCs \end{code} @@ -1057,8 +1168,9 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds -- BUT do no improvement! See Plan D above -- HOWEVER, some unification may take place, if we instantiate -- a method Inst with an equality constraint - reduceContextWithoutImprovement - doc reduceMe wanteds' `thenM` \ (_frees, _binds, constrained_dicts) -> + let env = mkNoImproveRedEnv doc reduceMe + in + reduceContext env wanteds' `thenM` \ (_imp, _frees, _binds, constrained_dicts) -> -- Next, figure out the tyvars we will quantify over zonkTcTyVarsAndFV (varSetElems tau_tvs) `thenM` \ tau_tvs' -> @@ -1095,9 +1207,9 @@ tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds try_me inst | isFreeWrtTyVars qtvs' inst, (is_nested_group || isDict inst) = Free | otherwise = ReduceMe AddSCs - in - reduceContextWithoutImprovement - doc try_me wanteds' `thenM` \ (frees, binds, irreds) -> + env = mkNoImproveRedEnv doc try_me + in + reduceContext env wanteds' `thenM` \ (_imp, frees, binds, irreds) -> ASSERT( null irreds ) -- See "Notes on implicit parameters, Question 4: top level" @@ -1187,10 +1299,9 @@ tcSimplifyRuleLhs wanteds | otherwise = do { w' <- zonkInst w -- So that (3::Int) does not generate a call -- to fromInteger; this looks fragile to me - ; lookup_result <- lookupInst w' + ; lookup_result <- lookupSimpleInst w' ; case lookup_result of GenInst ws' rhs -> go dicts (addBind binds w rhs) (ws' ++ ws) - SimpleInst rhs -> go dicts (addBind binds w rhs) ws NoInstance -> pprPanic "tcSimplifyRuleLhs" (ppr w) } \end{code} @@ -1205,8 +1316,8 @@ this bracket again at its usage site. \begin{code} tcSimplifyBracket :: [Inst] -> TcM () tcSimplifyBracket wanteds - = simpleReduceLoop doc reduceMe wanteds `thenM_` - returnM () + = do { topCheckLoop doc wanteds + ; return () } where doc = text "tcSimplifyBracket" \end{code} @@ -1236,30 +1347,34 @@ force the binding for ?x to be of type Int. tcSimplifyIPs :: [Inst] -- The implicit parameters bound here -> [Inst] -- Wanted -> TcM TcDictBinds -tcSimplifyIPs given_ips wanteds - = simpl_loop given_ips wanteds `thenM` \ (frees, binds) -> - extendLIEs frees `thenM_` - returnM binds - where - doc = text "tcSimplifyIPs" <+> ppr given_ips - ip_set = mkNameSet (ipNamesOfInsts given_ips) + -- We need a loop so that we do improvement, and then + -- (next time round) generate a binding to connect the two + -- let ?x = e in ?x + -- Here the two ?x's have different types, and improvement + -- makes them the same. - -- Simplify any methods that mention the implicit parameter - try_me inst | isFreeWrtIPs ip_set inst = Free - | otherwise = ReduceMe NoSCs +tcSimplifyIPs given_ips wanteds + = do { wanteds' <- mappM zonkInst wanteds + ; given_ips' <- mappM zonkInst given_ips + -- Unusually for checking, we *must* zonk the given_ips - simpl_loop givens wanteds - = mappM zonkInst givens `thenM` \ givens' -> - mappM zonkInst wanteds `thenM` \ wanteds' -> + ; let env = mkRedEnv doc try_me given_ips' + ; (improved, _frees, binds, irreds) <- reduceContext env wanteds' - reduceContext doc try_me givens' wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> + ; if not improved then + ASSERT( all is_free irreds ) + do { extendLIEs irreds + ; return binds } + else + tcSimplifyIPs given_ips wanteds } + where + doc = text "tcSimplifyIPs" <+> ppr given_ips + ip_set = mkNameSet (ipNamesOfInsts given_ips) + is_free inst = isFreeWrtIPs ip_set inst - if no_improvement then - ASSERT( null irreds ) - returnM (frees, binds) - else - simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) -> - returnM (frees1, binds `unionBags` binds1) + -- Simplify any methods that mention the implicit parameter + try_me inst | is_free inst = Irred + | otherwise = ReduceMe NoSCs \end{code} @@ -1304,12 +1419,12 @@ bindInstsOfLocalFuns wanteds local_ids returnM emptyLHsBinds | otherwise - = simpleReduceLoop doc try_me for_me `thenM` \ (frees, binds, irreds) -> - ASSERT( null irreds ) - extendLIEs not_for_me `thenM_` - extendLIEs frees `thenM_` - returnM binds + = do { (binds, irreds) <- checkLoop env for_me + ; extendLIEs not_for_me + ; extendLIEs irreds + ; return binds } where + env = mkRedEnv doc try_me [] doc = text "bindInsts" <+> ppr local_ids overloaded_ids = filter is_overloaded local_ids is_overloaded id = isOverloadedTy (idType id) @@ -1319,7 +1434,7 @@ bindInstsOfLocalFuns wanteds local_ids -- so it's worth building a set, so that -- lookup (in isMethodFor) is faster try_me inst | isMethod inst = ReduceMe NoSCs - | otherwise = Free + | otherwise = Irred \end{code} @@ -1332,15 +1447,53 @@ bindInstsOfLocalFuns wanteds local_ids The main control over context reduction is here \begin{code} +data RedEnv + = RedEnv { red_doc :: SDoc -- The context + , red_try_me :: Inst -> WhatToDo + , red_improve :: Bool -- True <=> do improvement + , red_givens :: [Inst] -- All guaranteed rigid + -- Always dicts + -- but see Note [Rigidity] + , red_stack :: (Int, [Inst]) -- Recursion stack (for err msg) + -- See Note [RedStack] + } + +-- Note [Rigidity] +-- The red_givens are rigid so far as cmpInst is concerned. +-- There is one case where they are not totally rigid, namely in tcSimplifyIPs +-- let ?x = e in ... +-- Here, the given is (?x::a), where 'a' is not necy a rigid type +-- But that doesn't affect the comparison, which is based only on mame. + +-- Note [RedStack] +-- The red_stack pair (n,insts) pair is just used for error reporting. +-- 'n' is always the depth of the stack. +-- The 'insts' is the stack of Insts being reduced: to produce X +-- I had to produce Y, to produce Y I had to produce Z, and so on. + + +mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv +mkRedEnv doc try_me givens + = RedEnv { red_doc = doc, red_try_me = try_me, + red_givens = givens, red_stack = (0,[]), + red_improve = True } + +mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv +-- Do not do improvement; no givens +mkNoImproveRedEnv doc try_me + = RedEnv { red_doc = doc, red_try_me = try_me, + red_givens = [], red_stack = (0,[]), + red_improve = True } + data WhatToDo = ReduceMe WantSCs -- Try to reduce this - -- If there's no instance, behave exactly like - -- DontReduce: add the inst to the irreductible ones, - -- but don't produce an error message of any kind. + -- If there's no instance, add the inst to the + -- irreductible ones, but don't produce an error + -- message of any kind. -- It might be quite legitimate such as (Eq a)! - | DontReduceUnlessConstant -- Return as irreducible unless it can - -- be reduced to a constant in one step + | Irred -- Return as irreducible unless it can + -- be reduced to a constant in one step | Free -- Return as free @@ -1353,237 +1506,77 @@ data WantSCs = NoSCs | AddSCs -- Tells whether we should add the superclasses -- Note [SUPER-CLASS LOOP 1] \end{code} - - -\begin{code} -type Avails = FiniteMap Inst Avail -emptyAvails = emptyFM - -data Avail - = IsFree -- Used for free Insts - | Irred -- Used for irreducible dictionaries, - -- which are going to be lambda bound - - | Given TcId -- Used for dictionaries for which we have a binding - -- e.g. those "given" in a signature - - | Rhs -- Used when there is a RHS - (LHsExpr TcId) -- The RHS - [Inst] -- Insts free in the RHS; we need these too - -pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)] - | (inst,avail) <- fmToList avails ] - -instance Outputable Avail where - ppr = pprAvail - -pprAvail IsFree = text "Free" -pprAvail Irred = text "Irred" -pprAvail (Given x) = text "Given" <+> ppr x -pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs) -\end{code} - -Extracting the bindings from a bunch of Avails. -The bindings do *not* come back sorted in dependency order. -We assume that they'll be wrapped in a big Rec, so that the -dependency analyser can sort them out later - -The loop startes -\begin{code} -extractResults :: Avails - -> [Inst] -- Wanted - -> TcM (TcDictBinds, -- Bindings - [Inst], -- Irreducible ones - [Inst]) -- Free ones - -extractResults avails wanteds - = go avails emptyBag [] [] wanteds - where - go avails binds irreds frees [] - = returnM (binds, irreds, frees) - - go avails binds irreds frees (w:ws) - = case lookupFM avails w of - Nothing -> pprTrace "Urk: extractResults" (ppr w) $ - go avails binds irreds frees ws - - Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws - Just Irred -> go (add_given avails w) binds (w:irreds) frees ws - - Just (Given id) -> go avails new_binds irreds frees ws - where - new_binds | id == instToId w = binds - | otherwise = addBind binds w (L (instSpan w) (HsVar id)) - -- The sought Id can be one of the givens, via a superclass chain - -- and then we definitely don't want to generate an x=x binding! - - Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws) - where - new_binds = addBind binds w rhs - - add_given avails w = addToFM avails w (Given (instToId w)) - - add_free avails w | isMethod w = avails - | otherwise = add_given avails w - -- NB: Hack alert! - -- Do *not* replace Free by Given if it's a method. - -- The following situation shows why this is bad: - -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b - -- From an application (truncate f i) we get - -- t1 = truncate at f - -- t2 = t1 at i - -- If we have also have a second occurrence of truncate, we get - -- t3 = truncate at f - -- t4 = t3 at i - -- When simplifying with i,f free, we might still notice that - -- t1=t3; but alas, the binding for t2 (which mentions t1) - -- will continue to float out! - -addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst)) - (VarBind (instToId inst) rhs)) -instSpan wanted = instLocSrcSpan (instLoc wanted) -\end{code} - - %************************************************************************ %* * \subsection[reduce]{@reduce@} %* * %************************************************************************ -When the "what to do" predicate doesn't depend on the quantified type variables, -matters are easier. We don't need to do any zonking, unless the improvement step -does something, in which case we zonk before iterating. - -The "given" set is always empty. \begin{code} -simpleReduceLoop :: SDoc - -> (Inst -> WhatToDo) -- What to do, *not* based on the quantified type variables - -> [Inst] -- Wanted - -> TcM ([Inst], -- Free - TcDictBinds, - [Inst]) -- Irreducible - -simpleReduceLoop doc try_me wanteds - = mappM zonkInst wanteds `thenM` \ wanteds' -> - reduceContext doc try_me [] wanteds' `thenM` \ (no_improvement, frees, binds, irreds) -> - if no_improvement then - returnM (frees, binds, irreds) - else - simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) -> - returnM (frees1, binds `unionBags` binds1, irreds1) -\end{code} - - - -\begin{code} -reduceContext :: SDoc - -> (Inst -> WhatToDo) - -> [Inst] -- Given +reduceContext :: RedEnv -> [Inst] -- Wanted - -> TcM (Bool, -- True <=> improve step did no unification - [Inst], -- Free - TcDictBinds, -- Dictionary bindings - [Inst]) -- Irreducible - -reduceContext doc try_me givens wanteds - = - traceTc (text "reduceContext" <+> (vcat [ + -> TcM (ImprovementDone, + [Inst], -- Free + TcDictBinds, -- Dictionary bindings + [Inst]) -- Irreducible + +reduceContext env wanteds + = do { traceTc (text "reduceContext" <+> (vcat [ text "----------------------", - doc, - text "given" <+> ppr givens, + red_doc env, + text "given" <+> ppr (red_givens env), text "wanted" <+> ppr wanteds, text "----------------------" - ])) `thenM_` + ])) -- Build the Avail mapping from "givens" - foldlM addGiven emptyAvails givens `thenM` \ init_state -> + ; init_state <- foldlM addGiven emptyAvails (red_givens env) -- Do the real work - reduceList (0,[]) try_me wanteds init_state `thenM` \ avails -> - - -- Do improvement, using everything in avails - -- In particular, avails includes all superclasses of everything - tcImprove avails `thenM` \ no_improvement -> - - extractResults avails wanteds `thenM` \ (binds, irreds, frees) -> - - traceTc (text "reduceContext end" <+> (vcat [ - text "----------------------", - doc, - text "given" <+> ppr givens, - text "wanted" <+> ppr wanteds, - text "----", - text "avails" <+> pprAvails avails, - text "frees" <+> ppr frees, - text "no_improvement =" <+> ppr no_improvement, - text "----------------------" - ])) `thenM_` + ; avails <- reduceList env wanteds init_state - returnM (no_improvement, frees, binds, irreds) + ; let improved = availsImproved avails + ; (binds, irreds, frees) <- extractResults avails wanteds --- reduceContextWithoutImprovement differs from reduceContext --- (a) no improvement --- (b) 'givens' is assumed empty -reduceContextWithoutImprovement doc try_me wanteds - = - traceTc (text "reduceContextWithoutImprovement" <+> (vcat [ + ; traceTc (text "reduceContext end" <+> (vcat [ text "----------------------", - doc, - text "wanted" <+> ppr wanteds, - text "----------------------" - ])) `thenM_` - - -- Do the real work - reduceList (0,[]) try_me wanteds emptyAvails `thenM` \ avails -> - extractResults avails wanteds `thenM` \ (binds, irreds, frees) -> - - traceTc (text "reduceContextWithoutImprovement end" <+> (vcat [ - text "----------------------", - doc, + red_doc env, + text "given" <+> ppr (red_givens env), text "wanted" <+> ppr wanteds, text "----", text "avails" <+> pprAvails avails, text "frees" <+> ppr frees, + text "improved =" <+> ppr improved, text "----------------------" - ])) `thenM_` + ])) - returnM (frees, binds, irreds) + ; return (improved, frees, binds, irreds) } -tcImprove :: Avails -> TcM Bool -- False <=> no change --- Perform improvement using all the predicates in Avails -tcImprove avails - = tcGetInstEnvs `thenM` \ inst_envs -> - let - preds = [ (pred, pp_loc) - | (inst, avail) <- fmToList avails, - pred <- get_preds inst avail, - let pp_loc = pprInstLoc (instLoc inst) - ] +tcImproveOne :: Avails -> Inst -> TcM ImprovementDone +tcImproveOne avails inst + | not (isDict inst) = return False + | otherwise + = do { inst_envs <- tcGetInstEnvs + ; let eqns = improveOne (classInstances inst_envs) + (dictPred inst, pprInstArising inst) + [ (dictPred p, pprInstArising p) + | p <- availsInsts avails, isDict p ] -- Avails has all the superclasses etc (good) -- It also has all the intermediates of the deduction (good) -- It does not have duplicates (good) -- NB that (?x::t1) and (?x::t2) will be held separately in avails -- so that improve will see them separate - - -- For free Methods, we want to take predicates from their context, - -- but for Methods that have been squished their context will already - -- be in Avails, and we don't want duplicates. Hence this rather - -- horrid get_preds function - get_preds inst IsFree = fdPredsOfInst inst - get_preds inst other | isDict inst = [dictPred inst] - | otherwise = [] - - eqns = improve get_insts preds - get_insts clas = classInstances inst_envs clas - in - if null eqns then - returnM True - else - traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) `thenM_` - mappM_ unify eqns `thenM_` - returnM False + ; traceTc (text "improveOne" <+> ppr inst) + ; unifyEqns eqns } + +unifyEqns :: [(Equation,(PredType,SDoc),(PredType,SDoc))] + -> TcM ImprovementDone +unifyEqns [] = return False +unifyEqns eqns + = do { traceTc (ptext SLIT("Improve:") <+> vcat (map pprEquationDoc eqns)) + ; mappM_ unify eqns + ; return True } where unify ((qtvs, pairs), what1, what2) = addErrCtxtM (mkEqnMsg what1 what2) $ @@ -1605,73 +1598,48 @@ mkEqnMsg (pred1,from1) (pred2,from2) tidy_env The main context-reduction function is @reduce@. Here's its game plan. \begin{code} -reduceList :: (Int,[Inst]) -- Stack (for err msgs) - -- along with its depth - -> (Inst -> WhatToDo) - -> [Inst] - -> Avails - -> TcM Avails -\end{code} - -@reduce@ is passed - try_me: given an inst, this function returns - Reduce reduce this - DontReduce return this in "irreds" - Free return this in "frees" - - wanteds: The list of insts to reduce - state: An accumulating parameter of type Avails - that contains the state of the algorithm - - It returns a Avails. - -The (n,stack) pair is just used for error reporting. -n is always the depth of the stack. -The stack is the stack of Insts being reduced: to produce X -I had to produce Y, to produce Y I had to produce Z, and so on. - -\begin{code} -reduceList (n,stack) try_me wanteds state +reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails +reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state = do { dopts <- getDOpts #ifdef DEBUG ; if n > 8 then - dumpTcRn (text "Interesting! Context reduction stack deeper than 8:" - <+> (int n $$ ifPprDebug (nest 2 (pprStack stack)))) + dumpTcRn (hang (ptext SLIT("Interesting! Context reduction stack depth") <+> int n) + 2 (ifPprDebug (nest 2 (pprStack stk)))) else return () #endif ; if n >= ctxtStkDepth dopts then - failWithTc (reduceDepthErr n stack) + failWithTc (reduceDepthErr n stk) else go wanteds state } where go [] state = return state - go (w:ws) state = do { state' <- reduce (n+1, w:stack) try_me w state + go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state ; go ws state' } -- Base case: we're done! -reduce stack try_me wanted avails +reduce env wanted avails -- It's the same as an existing inst, or a superclass thereof - | Just avail <- isAvailable avails wanted + | Just avail <- findAvail avails wanted = returnM avails | otherwise - = case try_me wanted of { - - ; DontReduceUnlessConstant -> -- It's irreducible (or at least should not be reduced) - -- First, see if the inst can be reduced to a constant in one step - try_simple (addIrred AddSCs) -- Assume want superclasses - - ; Free -> -- It's free so just chuck it upstairs - -- First, see if the inst can be reduced to a constant in one step - try_simple addFree + = case red_try_me env wanted of { + Free -> try_simple addFree -- It's free so just chuck it upstairs + ; Irred -> try_simple (addIrred AddSCs) -- Assume want superclasses ; ReduceMe want_scs -> -- It should be reduced - lookupInst wanted `thenM` \ lookup_result -> + reduceInst env avails wanted `thenM` \ (avails, lookup_result) -> case lookup_result of - GenInst wanteds' rhs -> addIrred NoSCs avails wanted `thenM` \ avails1 -> - reduceList stack try_me wanteds' avails1 `thenM` \ avails2 -> - addWanted want_scs avails2 wanted rhs wanteds' - -- Experiment with temporarily doing addIrred *before* the reduceList, + NoInstance -> -- No such instance! + -- Add it and its superclasses + addIrred want_scs avails wanted + + GenInst [] rhs -> addWanted want_scs avails wanted rhs [] + + GenInst wanteds' rhs -> do { avails1 <- addIrred NoSCs avails wanted + ; avails2 <- reduceList env wanteds' avails1 + ; addWanted want_scs avails2 wanted rhs wanteds' } + -- Temporarily do addIrred *before* the reduceList, -- which has the effect of adding the thing we are trying -- to prove to the database before trying to prove the things it -- needs. See note [RECURSIVE DICTIONARIES] @@ -1680,29 +1648,360 @@ reduce stack try_me wanted avails -- the examples in [SUPERCLASS-LOOP] -- So we do an addIrred before, and then overwrite it afterwards with addWanted - SimpleInst rhs -> addWanted want_scs avails wanted rhs [] - - NoInstance -> -- No such instance! - -- Add it and its superclasses - addIrred want_scs avails wanted } where + -- First, see if the inst can be reduced to a constant in one step + -- Works well for literals (1::Int) and constant dictionaries (d::Num Int) + -- Don't bother for implication constraints, which take real work try_simple do_this_otherwise - = lookupInst wanted `thenM` \ lookup_result -> - case lookup_result of - SimpleInst rhs -> addWanted AddSCs avails wanted rhs [] - other -> do_this_otherwise avails wanted + = do { res <- lookupSimpleInst wanted + ; case res of + GenInst [] rhs -> addWanted AddSCs avails wanted rhs [] + other -> do_this_otherwise avails wanted } \end{code} +Note [SUPERCLASS-LOOP 2] +~~~~~~~~~~~~~~~~~~~~~~~~ +But the above isn't enough. Suppose we are *given* d1:Ord a, +and want to deduce (d2:C [a]) where + + class Ord a => C a where + instance Ord [a] => C [a] where ... + +Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the +superclasses of C [a] to avails. But we must not overwrite the binding +for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just +build a loop! + +Here's another variant, immortalised in tcrun020 + class Monad m => C1 m + class C1 m => C2 m x + instance C2 Maybe Bool +For the instance decl we need to build (C1 Maybe), and it's no good if +we run around and add (C2 Maybe Bool) and its superclasses to the avails +before we search for C1 Maybe. + +Here's another example + class Eq b => Foo a b + instance Eq a => Foo [a] a +If we are reducing + (Foo [t] t) + +we'll first deduce that it holds (via the instance decl). We must not +then overwrite the Eq t constraint with a superclass selection! + +At first I had a gross hack, whereby I simply did not add superclass constraints +in addWanted, though I did for addGiven and addIrred. This was sub-optimal, +becuase it lost legitimate superclass sharing, and it still didn't do the job: +I found a very obscure program (now tcrun021) in which improvement meant the +simplifier got two bites a the cherry... so something seemed to be an Irred +first time, but reducible next time. + +Now we implement the Right Solution, which is to check for loops directly +when adding superclasses. It's a bit like the occurs check in unification. + + +Note [RECURSIVE DICTIONARIES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data D r = ZeroD | SuccD (r (D r)); + + instance (Eq (r (D r))) => Eq (D r) where + ZeroD == ZeroD = True + (SuccD a) == (SuccD b) = a == b + _ == _ = False; + + equalDC :: D [] -> D [] -> Bool; + equalDC = (==); + +We need to prove (Eq (D [])). Here's how we go: + + d1 : Eq (D []) + +by instance decl, holds if + d2 : Eq [D []] + where d1 = dfEqD d2 + +by instance decl of Eq, holds if + d3 : D [] + where d2 = dfEqList d3 + d1 = dfEqD d2 + +But now we can "tie the knot" to give + + d3 = d1 + d2 = dfEqList d3 + d1 = dfEqD d2 + +and it'll even run! The trick is to put the thing we are trying to prove +(in this case Eq (D []) into the database before trying to prove its +contributing clauses. + + +%************************************************************************ +%* * + Reducing a single constraint +%* * +%************************************************************************ + +\begin{code} +--------------------------------------------- +reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult) +reduceInst env avails (ImplicInst { tci_tyvars = tvs, tci_reft = reft, tci_loc = loc, + tci_given = extra_givens, tci_wanted = wanteds }) + = reduceImplication env avails reft tvs extra_givens wanteds loc + +reduceInst env avails other_inst + = do { result <- lookupSimpleInst other_inst + ; return (avails, result) } +\end{code} + \begin{code} +--------------------------------------------- +reduceImplication :: RedEnv + -> Avails + -> Refinement -- May refine the givens; often empty + -> [TcTyVar] -- Quantified type variables; all skolems + -> [Inst] -- Extra givens; all rigid + -> [Inst] -- Wanted + -> InstLoc + -> TcM (Avails, LookupInstResult) +\end{code} + +Suppose we are simplifying the constraint + forall bs. extras => wanted +in the context of an overall simplification problem with givens 'givens', +and refinment 'reft'. + +Note that + * The refinement is often empty + + * The 'extra givens' need not mention any of the quantified type variables + e.g. forall {}. Eq a => Eq [a] + forall {}. C Int => D (Tree Int) + + This happens when you have something like + data T a where + T1 :: Eq a => a -> T a + + f :: T a -> Int + f x = ...(case x of { T1 v -> v==v })... + +\begin{code} + -- ToDo: should we instantiate tvs? I think it's not necessary + -- + -- ToDo: what about improvement? There may be some improvement + -- exposed as a result of the simplifications done by reduceList + -- which are discarded if we back off. + -- This is almost certainly Wrong, but we'll fix it when dealing + -- better with equality constraints +reduceImplication env orig_avails reft tvs extra_givens wanteds inst_loc + = do { -- Add refined givens, and the extra givens + (refined_red_givens, avails) + <- if isEmptyRefinement reft then return (red_givens env, orig_avails) + else foldlM (addRefinedGiven reft) ([], orig_avails) (red_givens env) + ; avails <- foldlM addGiven avails extra_givens + + -- Solve the sub-problem + ; let try_me inst = ReduceMe AddSCs -- Note [Freeness and implications] + env' = env { red_givens = refined_red_givens ++ extra_givens + , red_try_me = try_me } + + ; traceTc (text "reduceImplication" <+> vcat + [ ppr (red_givens env), ppr extra_givens, ppr reft, ppr wanteds ]) + ; avails <- reduceList env' wanteds avails + + -- Extract the binding + ; (binds, irreds, _frees) <- extractResults avails wanteds + -- No frees, because try_me never says Free + + ; let dict_ids = map instToId extra_givens + co = mkWpTyLams tvs <.> mkWpLams dict_ids <.> WpLet binds + rhs = mkHsWrap co payload + loc = instLocSpan inst_loc + payload | isSingleton wanteds = HsVar (instToId (head wanteds)) + | otherwise = ExplicitTuple (map (L loc . HsVar . instToId) wanteds) Boxed + + -- If there are any irreds, we back off and return NoInstance + -- Either way, we discard the extra avails we've generated; + -- but we remember if we have done any (global) improvement + ; let ret_avails = updateImprovement orig_avails avails + ; case irreds of + [] -> return (ret_avails, GenInst [] (L loc rhs)) + other -> return (ret_avails, NoInstance) + } +\end{code} + +Note [Freeness and implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's hard to say when an implication constraint can be floated out. Consider + forall {} Eq a => Foo [a] +The (Foo [a]) doesn't mention any of the quantified variables, but it +still might be partially satisfied by the (Eq a). + +There is a useful special case when it *is* easy to partition the +constraints, namely when there are no 'givens'. Consider + forall {a}. () => Bar b +There are no 'givens', and so there is no reason to capture (Bar b). +We can let it float out. But if there is even one constraint we +must be much more careful: + forall {a}. C a b => Bar (m b) +because (C a b) might have a superclass (D b), from which we might +deduce (Bar [b]) when m later gets instantiated to []. Ha! + +Here is an even more exotic example + class C a => D a b +Now consider the constraint + forall b. D Int b => C Int +We can satisfy the (C Int) from the superclass of D, so we don't want +to float the (C Int) out, even though it mentions no type variable in +the constraints! + +%************************************************************************ +%* * + Avails and AvailHow: the pool of evidence +%* * +%************************************************************************ + + +\begin{code} +data Avails = Avails !ImprovementDone !AvailEnv + +type ImprovementDone = Bool -- True <=> some unification has happened + -- so some Irreds might now be reducible + -- keys that are now + +type AvailEnv = FiniteMap Inst AvailHow +data AvailHow + = IsFree -- Used for free Insts + | IsIrred -- Used for irreducible dictionaries, + -- which are going to be lambda bound + + | Given TcId -- Used for dictionaries for which we have a binding + -- e.g. those "given" in a signature + + | Rhs -- Used when there is a RHS + (LHsExpr TcId) -- The RHS + [Inst] -- Insts free in the RHS; we need these too + +instance Outputable Avails where + ppr = pprAvails + +pprAvails (Avails imp avails) + = vcat [ ptext SLIT("Avails") <> (if imp then ptext SLIT("[improved]") else empty) + , nest 2 (vcat [sep [ppr inst, nest 2 (equals <+> ppr avail)] + | (inst,avail) <- fmToList avails ])] + +instance Outputable AvailHow where + ppr = pprAvail + ------------------------- -isAvailable :: Avails -> Inst -> Maybe Avail -isAvailable avails wanted = lookupFM avails wanted +pprAvail :: AvailHow -> SDoc +pprAvail IsFree = text "Free" +pprAvail IsIrred = text "Irred" +pprAvail (Given x) = text "Given" <+> ppr x +pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs) + +------------------------- +extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv +extendAvailEnv env inst avail = addToFM env inst avail + +findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow +findAvailEnv env wanted = lookupFM env wanted -- NB 1: the Ord instance of Inst compares by the class/type info -- *not* by unique. So -- d1::C Int == d2::C Int +emptyAvails :: Avails +emptyAvails = Avails False emptyFM + +findAvail :: Avails -> Inst -> Maybe AvailHow +findAvail (Avails _ avails) wanted = findAvailEnv avails wanted + +elemAvails :: Inst -> Avails -> Bool +elemAvails wanted (Avails _ avails) = wanted `elemFM` avails + +extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails +-- Does improvement +extendAvails avails@(Avails imp env) inst avail + = do { imp1 <- tcImproveOne avails inst -- Do any improvement + ; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) } + +availsInsts :: Avails -> [Inst] +availsInsts (Avails _ avails) = keysFM avails + +availsImproved (Avails imp _) = imp + +updateImprovement :: Avails -> Avails -> Avails +-- (updateImprovement a1 a2) sets a1's improvement flag from a2 +updateImprovement (Avails _ avails1) (Avails imp2 _) = Avails imp2 avails1 +\end{code} + +Extracting the bindings from a bunch of Avails. +The bindings do *not* come back sorted in dependency order. +We assume that they'll be wrapped in a big Rec, so that the +dependency analyser can sort them out later + +\begin{code} +extractResults :: Avails + -> [Inst] -- Wanted + -> TcM ( TcDictBinds, -- Bindings + [Inst], -- Irreducible ones + [Inst]) -- Free ones + +extractResults (Avails _ avails) wanteds + = go avails emptyBag [] [] wanteds + where + go :: AvailEnv -> TcDictBinds -> [Inst] -> [Inst] -> [Inst] + -> TcM (TcDictBinds, [Inst], [Inst]) + go avails binds irreds frees [] + = returnM (binds, irreds, frees) + + go avails binds irreds frees (w:ws) + = case findAvailEnv avails w of + Nothing -> pprTrace "Urk: extractResults" (ppr w) $ + go avails binds irreds frees ws + + Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws + Just IsIrred -> go (add_given avails w) binds (w:irreds) frees ws + + Just (Given id) -> go avails new_binds irreds frees ws + where + new_binds | id == instToId w = binds + | otherwise = addBind binds w (L (instSpan w) (HsVar id)) + -- The sought Id can be one of the givens, via a superclass chain + -- and then we definitely don't want to generate an x=x binding! + + Just (Rhs rhs ws') -> go (add_given avails w) new_binds irreds frees (ws' ++ ws) + where + new_binds = addBind binds w rhs + + add_given avails w = extendAvailEnv avails w (Given (instToId w)) + + add_free avails w | isMethod w = avails + | otherwise = add_given avails w + -- NB: Hack alert! + -- Do *not* replace Free by Given if it's a method. + -- The following situation shows why this is bad: + -- truncate :: forall a. RealFrac a => forall b. Integral b => a -> b + -- From an application (truncate f i) we get + -- t1 = truncate at f + -- t2 = t1 at i + -- If we have also have a second occurrence of truncate, we get + -- t3 = truncate at f + -- t4 = t3 at i + -- When simplifying with i,f free, we might still notice that + -- t1=t3; but alas, the binding for t2 (which mentions t1) + -- will continue to float out! + +addBind binds inst rhs = binds `unionBags` unitBag (L (instSpan inst) + (VarBind (instToId inst) rhs)) +instSpan wanted = instLocSpan (instLoc wanted) +\end{code} + + +\begin{code} ------------------------- addFree :: Avails -> Inst -> TcM Avails -- When an Inst is tossed upstairs as 'free' we nevertheless add it @@ -1717,7 +2016,7 @@ addFree :: Avails -> Inst -> TcM Avails -- but a is not bound here, then we *don't* want to derive -- dn from df here lest we lose sharing. -- -addFree avails free = returnM (addToFM avails free IsFree) +addFree avails free = extendAvails avails free IsFree addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails addWanted want_scs avails wanted rhs_expr wanteds @@ -1729,29 +2028,44 @@ addGiven :: Avails -> Inst -> TcM Avails addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given)) -- Always add superclasses for 'givens' -- - -- No ASSERT( not (given `elemFM` avails) ) because in an instance + -- No ASSERT( not (given `elemAvails` avails) ) because in an instance -- decl for Ord t we can add both Ord t and Eq t as 'givens', -- so the assert isn't true +addRefinedGiven :: Refinement -> ([Inst], Avails) -> Inst -> TcM ([Inst], Avails) +addRefinedGiven reft (refined_givens, avails) given + | isDict given -- We sometimes have 'given' methods, but they + -- are always optional, so we can drop them + , Just (co, pred) <- refinePred reft (dictPred given) + = do { new_given <- newDictBndr (instLoc given) pred + ; let rhs = L (instSpan given) $ + HsWrap (WpCo co) (HsVar (instToId given)) + ; avails <- addAvailAndSCs AddSCs avails new_given (Rhs rhs [given]) + ; return (new_given:refined_givens, avails) } + -- ToDo: the superclasses of the original given all exist in Avails + -- so we could really just cast them, but it's more awkward to do, + -- and hopefully the optimiser will spot the duplicated work + | otherwise + = return (refined_givens, avails) + addIrred :: WantSCs -> Avails -> Inst -> TcM Avails -addIrred want_scs avails irred = ASSERT2( not (irred `elemFM` avails), ppr irred $$ ppr avails ) - addAvailAndSCs want_scs avails irred Irred +addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails ) + addAvailAndSCs want_scs avails irred IsIrred -addAvailAndSCs :: WantSCs -> Avails -> Inst -> Avail -> TcM Avails +addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails addAvailAndSCs want_scs avails inst avail - | not (isClassDict inst) = return avails_with_inst - | NoSCs <- want_scs = return avails_with_inst + | not (isClassDict inst) = extendAvails avails inst avail + | NoSCs <- want_scs = extendAvails avails inst avail | otherwise = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps]) - ; addSCs is_loop avails_with_inst inst } + ; avails' <- extendAvails avails inst avail + ; addSCs is_loop avails' inst } where - avails_with_inst = addToFM avails inst avail - is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys -- Note: this compares by *type*, not by Unique deps = findAllDeps (unitVarSet (instToId inst)) avail dep_tys = map idType (varSetElems deps) - findAllDeps :: IdSet -> Avail -> IdSet + findAllDeps :: IdSet -> AvailHow -> IdSet -- Find all the Insts that this one depends on -- See Note [SUPERCLASS-LOOP 2] -- Watch out, though. Since the avails may contain loops @@ -1761,9 +2075,9 @@ addAvailAndSCs want_scs avails inst avail find_all :: IdSet -> Inst -> IdSet find_all so_far kid - | kid_id `elemVarSet` so_far = so_far - | Just avail <- lookupFM avails kid = findAllDeps so_far' avail - | otherwise = so_far' + | kid_id `elemVarSet` so_far = so_far + | Just avail <- findAvail avails kid = findAllDeps so_far' avail + | otherwise = so_far' where so_far' = extendVarSet so_far kid_id -- Add the new kid to so_far kid_id = instToId kid @@ -1775,7 +2089,8 @@ addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails -- Invariant: the Inst is already in Avails. addSCs is_loop avails dict - = do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta' + = ASSERT( isDict dict ) + do { sc_dicts <- newDictBndrs (instLoc dict) sc_theta' ; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) } where (clas, tys) = getDictClassTys dict @@ -1785,96 +2100,18 @@ addSCs is_loop avails dict add_sc avails (sc_dict, sc_sel) | is_loop (dictPred sc_dict) = return avails -- See Note [SUPERCLASS-LOOP 2] | is_given sc_dict = return avails - | otherwise = addSCs is_loop avails' sc_dict + | otherwise = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict]) + ; addSCs is_loop avails' sc_dict } where sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel)) co_fn = WpApp (instToId dict) <.> mkWpTyApps tys - avails' = addToFM avails sc_dict (Rhs sc_sel_rhs [dict]) is_given :: Inst -> Bool - is_given sc_dict = case lookupFM avails sc_dict of + is_given sc_dict = case findAvail avails sc_dict of Just (Given _) -> True -- Given is cheaper than superclass selection other -> False \end{code} -Note [SUPERCLASS-LOOP 2] -~~~~~~~~~~~~~~~~~~~~~~~~ -But the above isn't enough. Suppose we are *given* d1:Ord a, -and want to deduce (d2:C [a]) where - - class Ord a => C a where - instance Ord [a] => C [a] where ... - -Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the -superclasses of C [a] to avails. But we must not overwrite the binding -for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just -build a loop! - -Here's another variant, immortalised in tcrun020 - class Monad m => C1 m - class C1 m => C2 m x - instance C2 Maybe Bool -For the instance decl we need to build (C1 Maybe), and it's no good if -we run around and add (C2 Maybe Bool) and its superclasses to the avails -before we search for C1 Maybe. - -Here's another example - class Eq b => Foo a b - instance Eq a => Foo [a] a -If we are reducing - (Foo [t] t) - -we'll first deduce that it holds (via the instance decl). We must not -then overwrite the Eq t constraint with a superclass selection! - -At first I had a gross hack, whereby I simply did not add superclass constraints -in addWanted, though I did for addGiven and addIrred. This was sub-optimal, -becuase it lost legitimate superclass sharing, and it still didn't do the job: -I found a very obscure program (now tcrun021) in which improvement meant the -simplifier got two bites a the cherry... so something seemed to be an Irred -first time, but reducible next time. - -Now we implement the Right Solution, which is to check for loops directly -when adding superclasses. It's a bit like the occurs check in unification. - - -Note [RECURSIVE DICTIONARIES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - data D r = ZeroD | SuccD (r (D r)); - - instance (Eq (r (D r))) => Eq (D r) where - ZeroD == ZeroD = True - (SuccD a) == (SuccD b) = a == b - _ == _ = False; - - equalDC :: D [] -> D [] -> Bool; - equalDC = (==); - -We need to prove (Eq (D [])). Here's how we go: - - d1 : Eq (D []) - -by instance decl, holds if - d2 : Eq [D []] - where d1 = dfEqD d2 - -by instance decl of Eq, holds if - d3 : D [] - where d2 = dfEqList d3 - d1 = dfEqD d2 - -But now we can "tie the knot" to give - - d3 = d1 - d2 = dfEqList d3 - d1 = dfEqD d2 - -and it'll even run! The trick is to put the thing we are trying to prove -(in this case Eq (D []) into the database before trying to prove its -contributing clauses. - - %************************************************************************ %* * \section{tcSimplifyTop: defaulting} @@ -1898,107 +2135,44 @@ It's OK: the final zonking stage should zap y to (), which is fine. \begin{code} tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds tcSimplifyTop wanteds - = do { ext_default <- doptM Opt_ExtendedDefaultRules - ; tc_simplify_top doc ext_default AddSCs wanteds } + = tc_simplify_top doc False wanteds where doc = text "tcSimplifyTop" tcSimplifyInteractive wanteds - = tc_simplify_top doc True {- Interactive loop -} AddSCs wanteds + = tc_simplify_top doc True wanteds where - doc = text "tcSimplifyTop" + doc = text "tcSimplifyInteractive" -- The TcLclEnv should be valid here, solely to improve -- error message generation for the monomorphism restriction -tc_simplify_top doc use_extended_defaulting want_scs wanteds - = do { lcl_env <- getLclEnv - ; traceTc (text "tcSimplifyTop" <+> ppr (lclEnvElts lcl_env)) - - ; wanteds <- mapM zonkInst wanteds +tc_simplify_top doc interactive wanteds + = do { wanteds <- mapM zonkInst wanteds ; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds)) - ; let try_me inst = ReduceMe want_scs - ; (frees, binds, irreds) <- simpleReduceLoop doc try_me wanteds - - ; let - -- First get rid of implicit parameters - (non_ips, bad_ips) = partition isClassDict irreds - - -- All the non-tv or multi-param ones are definite errors - (unary_tv_dicts, non_tvs) = partition is_unary_tyvar_dict non_ips - bad_tyvars = unionVarSets (map tyVarsOfInst non_tvs) - - -- Group by type variable - tv_groups = equivClasses cmp_by_tyvar unary_tv_dicts - - -- Pick the ones which its worth trying to disambiguate - -- namely, the ones whose type variable isn't bound - -- up with one of the non-tyvar classes - (default_gps, non_default_gps) = partition defaultable_group tv_groups - defaultable_group ds - = (bad_tyvars `disjointVarSet` tyVarsOfInst (head ds)) - && defaultable_classes (map get_clas ds) - defaultable_classes clss - | use_extended_defaulting = any isInteractiveClass clss - | otherwise = all isStandardClass clss && any isNumericClass clss - - isInteractiveClass cls = isNumericClass cls - || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) - -- In interactive mode, or with -fextended-default-rules, - -- we default Show a to Show () to avoid graututious errors on "show []" - - - -- Collect together all the bad guys - bad_guys = non_tvs ++ concat non_default_gps - (ambigs, no_insts) = partition isTyVarDict bad_guys - -- If the dict has no type constructors involved, it must be ambiguous, - -- except I suppose that another error with fundeps maybe should have - -- constrained those type variables - - -- Report definite errors - ; ASSERT( null frees ) - groupErrs (addNoInstanceErrs Nothing []) no_insts - ; strangeTopIPErrs bad_ips - - -- Deal with ambiguity errors, but only if - -- if there has not been an error so far: - -- errors often give rise to spurious ambiguous Insts. - -- For example: - -- f = (*) -- Monomorphic - -- g :: Num a => a -> a - -- g x = f x x - -- Here, we get a complaint when checking the type signature for g, - -- that g isn't polymorphic enough; but then we get another one when - -- dealing with the (Num a) context arising from f's definition; - -- we try to unify a with Int (to default it), but find that it's - -- already been unified with the rigid variable from g's type sig - ; binds_ambig <- ifErrsM (returnM []) $ - do { -- Complain about the ones that don't fall under - -- the Haskell rules for disambiguation - -- This group includes both non-existent instances - -- e.g. Num (IO a) and Eq (Int -> Int) - -- and ambiguous dictionaries - -- e.g. Num a - addTopAmbigErrs ambigs - - -- Disambiguate the ones that look feasible - ; mappM disambigGroup default_gps } - - ; return (binds `unionBags` unionManyBags binds_ambig) } - ----------------------------------- -d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 - -is_unary_tyvar_dict :: Inst -> Bool -- Dicts of form (C a) - -- Invariant: argument is a ClassDict, not IP or method -is_unary_tyvar_dict d = case getDictClassTys d of - (_, [ty]) -> tcIsTyVarTy ty - other -> False - -get_tv d = case getDictClassTys d of - (clas, [ty]) -> tcGetTyVar "tcSimplify" ty -get_clas d = case getDictClassTys d of - (clas, _) -> clas + ; (binds1, irreds1) <- topCheckLoop doc wanteds + + ; if null irreds1 then + return binds1 + else do + -- OK, so there are some errors + { -- Use the defaulting rules to do extra unification + -- NB: irreds are already zonked + ; extended_default <- if interactive then return True + else doptM Opt_ExtendedDefaultRules + ; disambiguate extended_default irreds1 -- Does unification + ; (binds2, irreds2) <- topCheckLoop doc irreds1 + + -- Deal with implicit parameter + ; let (bad_ips, non_ips) = partition isIPDict irreds2 + (ambigs, others) = partition isTyVarDict non_ips + + ; topIPErrs bad_ips -- Can arise from f :: Int -> Int + -- f x = x + ?y + ; addNoInstanceErrs others + ; addTopAmbigErrs ambigs + + ; return (binds1 `unionBags` binds2) }} \end{code} If a dictionary constrains a type variable which is @@ -2034,88 +2208,88 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambigGroup :: [Inst] -- All standard classes of form (C a) - -> TcM TcDictBinds - -disambigGroup dicts - = -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT - -- SO, TRY DEFAULT TYPES IN ORDER +disambiguate :: Bool -> [Inst] -> TcM () + -- Just does unification to fix the default types + -- The Insts are assumed to be pre-zonked +disambiguate extended_defaulting insts + | null defaultable_groups + = return () + | otherwise + = do { -- Figure out what default types to use + mb_defaults <- getDefaultTys + ; default_tys <- case mb_defaults of + Just tys -> return tys + Nothing -> -- No use-supplied default; + -- use [Integer, Double] + do { integer_ty <- tcMetaTy integerTyConName + ; checkWiredInTyCon doubleTyCon + ; return [integer_ty, doubleTy] } + ; mapM_ (disambigGroup default_tys) defaultable_groups } + where + unaries :: [(Inst,Class, TcTyVar)] -- (C tv) constraints + bad_tvs :: TcTyVarSet -- Tyvars mentioned by *other* constraints + (unaries, bad_tvs) = getDefaultableDicts insts - -- Failure here is caused by there being no type in the - -- default list which can satisfy all the ambiguous classes. - -- For example, if Real a is reqd, but the only type in the - -- default list is Int. - get_default_tys `thenM` \ default_tys -> - let - try_default [] -- No defaults work, so fail - = failM - - try_default (default_ty : default_tys) - = tryTcLIE_ (try_default default_tys) $ -- If default_ty fails, we try - -- default_tys instead - tcSimplifyDefault theta `thenM` \ _ -> - returnM default_ty - where - theta = [mkClassPred clas [default_ty] | clas <- classes] - in - -- See if any default works - tryM (try_default default_tys) `thenM` \ mb_ty -> - case mb_ty of - Left _ -> bomb_out - Right chosen_default_ty -> choose_default chosen_default_ty + -- Group by type variable + defaultable_groups :: [[(Inst,Class,TcTyVar)]] + defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries) + cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2 + + defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool + defaultable_group ds@((_,_,tv):_) + = not (isSkolemTyVar tv) -- Note [Avoiding spurious errors] + && not (tv `elemVarSet` bad_tvs) + && defaultable_classes [c | (_,c,_) <- ds] + defaultable_group [] = panic "defaultable_group" + + defaultable_classes clss + | extended_defaulting = any isInteractiveClass clss + | otherwise = all isStandardClass clss && any isNumericClass clss + + -- In interactive mode, or with -fextended-default-rules, + -- we default Show a to Show () to avoid graututious errors on "show []" + isInteractiveClass cls + = isNumericClass cls + || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) + + +disambigGroup :: [Type] -- The default types + -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a) + -> TcM () -- Just does unification, to fix the default types + +disambigGroup default_tys dicts + = try_default default_tys where - tyvar = get_tv (head dicts) -- Should be non-empty - classes = map get_clas dicts - - choose_default default_ty -- Commit to tyvar = default_ty - = -- Bind the type variable - unifyType default_ty (mkTyVarTy tyvar) `thenM_` - -- and reduce the context, for real this time - simpleReduceLoop (text "disambig" <+> ppr dicts) - reduceMe dicts `thenM` \ (frees, binds, ambigs) -> - WARN( not (null frees && null ambigs), ppr frees $$ ppr ambigs ) - warnDefault dicts default_ty `thenM_` - returnM binds - - bomb_out = addTopAmbigErrs dicts `thenM_` - returnM emptyBag - -get_default_tys - = do { mb_defaults <- getDefaultTys - ; case mb_defaults of - Just tys -> return tys - Nothing -> -- No use-supplied default; - -- use [Integer, Double] - do { integer_ty <- tcMetaTy integerTyConName - ; checkWiredInTyCon doubleTyCon - ; return [integer_ty, doubleTy] } } + (_,_,tyvar) = head dicts -- Should be non-empty + classes = [c | (_,c,_) <- dicts] + + try_default [] = return () + try_default (default_ty : default_tys) + = tryTcLIE_ (try_default default_tys) $ + do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes] + -- This may fail; then the tryTcLIE_ kicks in + -- Failure here is caused by there being no type in the + -- default list which can satisfy all the ambiguous classes. + -- For example, if Real a is reqd, but the only type in the + -- default list is Int. + + -- After this we can't fail + ; warnDefault dicts default_ty + ; unifyType default_ty (mkTyVarTy tyvar) } \end{code} -[Aside - why the defaulting mechanism is turned off when - dealing with arguments and results to ccalls. - -When typechecking _ccall_s, TcExpr ensures that the external -function is only passed arguments (and in the other direction, -results) of a restricted set of 'native' types. - -The interaction between the defaulting mechanism for numeric -values and CC & CR can be a bit puzzling to the user at times. -For example, - - x <- _ccall_ f - if (x /= 0) then - _ccall_ g x - else - return () - -What type has 'x' got here? That depends on the default list -in operation, if it is equal to Haskell 98's default-default -of (Integer, Double), 'x' has type Double, since Integer -is not an instance of CR. If the default list is equal to -Haskell 1.4's default-default of (Int, Double), 'x' has type -Int. - -End of aside] +Note [Avoiding spurious errors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When doing the unification for defaulting, we check for skolem +type variables, and simply don't default them. For example: + f = (*) -- Monomorphic + g :: Num a => a -> a + g x = f x x +Here, we get a complaint when checking the type signature for g, +that g isn't polymorphic enough; but then we get another one when +dealing with the (Num a) context arising from f's definition; +we try to unify a with Int (to default it), but find that it's +already been unified with the rigid variable from g's type sig %************************************************************************ @@ -2147,18 +2321,18 @@ tcSimplifyDeriv orig tc tyvars theta -- it doesn't see a TcTyVar, so we have to instantiate. Sigh -- ToDo: what if two of them do get unified? newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds -> - simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> - ASSERT( null frees ) -- reduceMe never returns Free + topCheckLoop doc wanteds `thenM` \ (_, irreds) -> doptM Opt_GlasgowExts `thenM` \ gla_exts -> doptM Opt_AllowUndecidableInstances `thenM` \ undecidable_ok -> let inst_ty = mkTyConApp tc (mkTyVarTys tvs) (ok_insts, bad_insts) = partition is_ok_inst irreds - is_ok_inst dict - = isTyVarClassPred pred || (gla_exts && ok_gla_pred pred) + is_ok_inst inst + = isDict inst -- Exclude implication consraints + && (isTyVarClassPred pred || (gla_exts && ok_gla_pred pred)) where - pred = dictPred dict -- reduceMe squashes all non-dicts + pred = dictPred inst ok_gla_pred pred = null (checkInstTermination [inst_ty] [pred]) -- See Note [Deriving context] @@ -2182,11 +2356,11 @@ tcSimplifyDeriv orig tc tyvars theta -- would make checkValidInstance fail; if it were called right after tcSimplifyDeriv -- * wierd_preds ensures unambiguous instances (checkAmbiguity in checkValidInstance) -- * ok_gla_pred ensures termination (checkInstTermination in checkValidInstance) - addNoInstanceErrs Nothing [] bad_insts `thenM_` + addNoInstanceErrs bad_insts `thenM_` mapM_ (addErrTc . badDerivedPred) weird_preds `thenM_` returnM (substTheta rev_env simpl_theta) where - doc = ptext SLIT("deriving classes for a data type") + doc = ptext SLIT("deriving classes for a data type") \end{code} Note [Deriving context] @@ -2219,10 +2393,9 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it -> TcM () tcSimplifyDefault theta - = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds -> - simpleReduceLoop doc reduceMe wanteds `thenM` \ (frees, _, irreds) -> - ASSERT( null frees ) -- try_me never returns Free - addNoInstanceErrs Nothing [] irreds `thenM_` + = newDictBndrsO DefaultOrigin theta `thenM` \ wanteds -> + topCheckLoop doc wanteds `thenM` \ (_, irreds) -> + addNoInstanceErrs irreds `thenM_` if null irreds then returnM () else @@ -2267,7 +2440,7 @@ groupErrs report_err (inst:insts) -- Add the "arising from..." part to a message about bunch of dicts addInstLoc :: [Inst] -> Message -> Message -addInstLoc insts msg = msg $$ nest 2 (pprInstLoc (instLoc (head insts))) +addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts)) addTopIPErrs :: [Name] -> [Inst] -> TcM () addTopIPErrs bndrs [] @@ -2281,10 +2454,10 @@ addTopIPErrs bndrs ips <+> pprBinders bndrs <> colon)], nest 2 (vcat (map ppr_ip ips)), monomorphism_fix] - ppr_ip ip = pprPred (dictPred ip) <+> pprInstLoc (instLoc ip) + ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip -strangeTopIPErrs :: [Inst] -> TcM () -strangeTopIPErrs dicts -- Strange, becuase addTopIPErrs should have caught them all +topIPErrs :: [Inst] -> TcM () +topIPErrs dicts = groupErrs report tidy_dicts where (tidy_env, tidy_dicts) = tidyInsts dicts @@ -2292,54 +2465,59 @@ strangeTopIPErrs dicts -- Strange, becuase addTopIPErrs should have caught them mk_msg dicts = addInstLoc dicts (ptext SLIT("Unbound implicit parameter") <> plural tidy_dicts <+> pprDictsTheta tidy_dicts) -addNoInstanceErrs :: Maybe SDoc -- Nothing => top level - -- Just d => d describes the construct - -> [Inst] -- What is given by the context or type sig - -> [Inst] -- What is wanted +addNoInstanceErrs :: [Inst] -- Wanted (can include implications) -> TcM () -addNoInstanceErrs mb_what givens [] - = returnM () -addNoInstanceErrs mb_what givens dicts - = -- Some of the dicts are here because there is no instances - -- and some because there are too many instances (overlap) - tcGetInstEnvs `thenM` \ inst_envs -> - let - (tidy_env1, tidy_givens) = tidyInsts givens - (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts - - -- Run through the dicts, generating a message for each - -- overlapping one, but simply accumulating all the - -- no-instance ones so they can be reported as a group - (overlap_doc, no_inst_dicts) = foldl check_overlap (empty, []) tidy_dicts - check_overlap (overlap_doc, no_inst_dicts) dict - | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) - | otherwise - = case lookupInstEnv inst_envs clas tys of +addNoInstanceErrs insts + = do { let (tidy_env, tidy_insts) = tidyInsts insts + ; reportNoInstances tidy_env Nothing tidy_insts } + +reportNoInstances + :: TidyEnv + -> Maybe (InstLoc, [Inst]) -- Context + -- Nothing => top level + -- Just (d,g) => d describes the construct + -- with givens g + -> [Inst] -- What is wanted (can include implications) + -> TcM () + +reportNoInstances tidy_env mb_what insts + = groupErrs (report_no_instances tidy_env mb_what) insts + +report_no_instances tidy_env mb_what insts + = do { inst_envs <- tcGetInstEnvs + ; let (implics, insts1) = partition isImplicInst insts + (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 + ; traceTc (text "reportNoInstnces" <+> vcat + [ppr implics, ppr insts1, ppr insts2]) + ; mapM_ complain_implic implics + ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps + ; groupErrs complain_no_inst insts2 } + where + complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts) + + complain_implic inst -- Recurse! + = reportNoInstances tidy_env + (Just (tci_loc inst, tci_given inst)) + (tci_wanted inst) + + check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc + -- Right msg => overlap message + -- Left inst => no instance + check_overlap inst_envs wanted + | not (isClassDict wanted) = Left wanted + | otherwise + = case lookupInstEnv inst_envs clas tys of -- The case of exactly one match and no unifiers means -- a successful lookup. That can't happen here, becuase -- dicts only end up here if they didn't match in Inst.lookupInst #ifdef DEBUG - ([m],[]) -> pprPanic "addNoInstanceErrs" (ppr dict) + ([m],[]) -> pprPanic "reportNoInstance" (ppr wanted) #endif - ([], _) -> (overlap_doc, dict : no_inst_dicts) -- No match - res -> (mk_overlap_msg dict res $$ overlap_doc, no_inst_dicts) + ([], _) -> Left wanted -- No match + res -> Right (mk_overlap_msg wanted res) where - (clas,tys) = getDictClassTys dict - in - - -- Now generate a good message for the no-instance bunch - mk_probable_fix tidy_env2 no_inst_dicts `thenM` \ (tidy_env3, probable_fix) -> - let - no_inst_doc | null no_inst_dicts = empty - | otherwise = vcat [addInstLoc no_inst_dicts heading, probable_fix] - heading | null givens = ptext SLIT("No instance") <> plural no_inst_dicts <+> - ptext SLIT("for") <+> pprDictsTheta no_inst_dicts - | otherwise = sep [ptext SLIT("Could not deduce") <+> pprDictsTheta no_inst_dicts, - nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta tidy_givens] - in - -- And emit both the non-instance and overlap messages - addErrTcM (tidy_env3, no_inst_doc $$ overlap_doc) - where + (clas,tys) = getDictClassTys wanted + mk_overlap_msg dict (matches, unifiers) = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> pprPred (dictPred dict))), @@ -2357,31 +2535,46 @@ addNoInstanceErrs mb_what givens dicts where ispecs = [ispec | (_, ispec) <- matches] - mk_probable_fix tidy_env dicts - = returnM (tidy_env, sep [ptext SLIT("Possible fix:"), nest 2 (vcat fixes)]) + mk_no_inst_err insts + | null insts = empty + + | Just (loc, givens) <- mb_what, -- Nested (type signatures, instance decls) + not (isEmptyVarSet (tyVarsOfInsts insts)) + = vcat [ addInstLoc insts $ + sep [ ptext SLIT("Could not deduce") <+> pprDictsTheta insts + , nest 2 $ ptext SLIT("from the context") <+> pprDictsTheta givens] + , show_fixes (fix1 loc : fixes2) ] + + | otherwise -- Top level + = vcat [ addInstLoc insts $ + ptext SLIT("No instance") <> plural insts + <+> ptext SLIT("for") <+> pprDictsTheta insts + , show_fixes fixes2 ] + where - fixes = add_ors (fix1 ++ fix2) - - fix1 = case mb_what of - Nothing -> [] -- Top level - Just what -> -- Nested (type signatures, instance decls) - [ sep [ ptext SLIT("add") <+> pprDictsTheta dicts, - ptext SLIT("to the") <+> what] ] - - fix2 | null instance_dicts = [] - | otherwise = [ sep [ptext SLIT("add an instance declaration for"), - pprDictsTheta instance_dicts] ] - instance_dicts = [d | d <- dicts, isClassDict d, not (isTyVarDict d)] + fix1 loc = sep [ ptext SLIT("add") <+> pprDictsTheta insts + <+> ptext SLIT("to the context of"), + nest 2 (ppr (instLocOrigin loc)) ] + -- I'm not sure it helps to add the location + -- nest 2 (ptext SLIT("at") <+> ppr (instLocSpan loc)) ] + + fixes2 | null instance_dicts = [] + | otherwise = [sep [ptext SLIT("add an instance declaration for"), + pprDictsTheta instance_dicts]] + instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)] -- Insts for which it is worth suggesting an adding an instance declaration -- Exclude implicit parameters, and tyvar dicts - add_ors :: [SDoc] -> [SDoc] -- The empty case should not happen - add_ors [] = [ptext SLIT("[No suggested fixes]")] -- Strange - add_ors (f1:fs) = f1 : map (ptext SLIT("or") <+>) fs + show_fixes :: [SDoc] -> SDoc + show_fixes [] = empty + show_fixes (f:fs) = sep [ptext SLIT("Possible fix:"), + nest 2 (vcat (f : map (ptext SLIT("or") <+>) fs))] addTopAmbigErrs dicts -- Divide into groups that share a common set of ambiguous tyvars - = mapM report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) + = ifErrsM (return ()) $ -- Only report ambiguity if no other errors happened + -- See Note [Avoiding spurious errors] + mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts]) where (tidy_env, tidy_dicts) = tidyInsts dicts @@ -2392,7 +2585,7 @@ addTopAmbigErrs dicts report :: [(Inst,[TcTyVar])] -> TcM () report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars = mkMonomorphismMsg tidy_env tvs `thenM` \ (tidy_env, mono_msg) -> - setSrcSpan (instLocSrcSpan (instLoc inst)) $ + setSrcSpan (instSpan inst) $ -- the location of the first one will do for the err message addErrTcM (tidy_env, msg $$ mono_msg) where @@ -2401,6 +2594,7 @@ addTopAmbigErrs dicts pprQuotedList tvs <+> in_msg, nest 2 (pprDictsInFull dicts)] in_msg = text "in the constraint" <> plural dicts <> colon + report [] = panic "addTopAmbigErrs" mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message) @@ -2415,7 +2609,7 @@ mkMonomorphismMsg tidy_env inst_tvs mk_msg [] = ptext SLIT("Probable fix: add a type signature that fixes these type variable(s)") -- This happens in things like -- f x = show (read "foo") - -- whre monomorphism doesn't play any role + -- where monomorphism doesn't play any role mk_msg docs = vcat [ptext SLIT("Possible cause: the monomorphism restriction applied to the following:"), nest 2 (vcat docs), monomorphism_fix @@ -2425,10 +2619,12 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+> (ptext SLIT("give these definition(s) an explicit type signature") $$ ptext SLIT("or use -fno-monomorphism-restriction")) -warnDefault dicts default_ty +warnDefault ups default_ty = doptM Opt_WarnTypeDefaults `thenM` \ warn_flag -> addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg) where + dicts = [d | (d,_,_) <- ups] + -- Tidy them first (_, tidy_dicts) = tidyInsts dicts warn_msg = vcat [ptext SLIT("Defaulting the following constraint(s) to type") <+> diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index b71294f..3302b23 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -76,6 +76,7 @@ import Control.Monad ( liftM ) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) + -- None of these functions add constraints to the LIE #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index aa0b0c9..3eb1419 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -69,7 +69,7 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isIPPred, mkPredName, + mkClassPred, isInheritablePred, isIPPred, dataConsStupidTheta, isRefineableTy, --------------------------------- @@ -142,6 +142,7 @@ import TyCon -- others: import DynFlags +import CoreSyn import Name import NameSet import VarEnv @@ -149,7 +150,6 @@ import OccName import PrelNames import TysWiredIn import BasicTypes -import SrcLoc import Util import Maybes import ListSetOps @@ -299,6 +299,8 @@ data MetaDetails -- For a BoxTv, this type must be non-boxy -- For a TauTv, this type must be a tau-type +-- Generally speaking, SkolemInfo should not contain location info +-- that is contained in the Name of the tyvar with this SkolemInfo data SkolemInfo = SigSkol UserTypeCtxt -- A skolem that is created by instantiating -- a programmer-supplied type signature @@ -306,25 +308,26 @@ data SkolemInfo -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl - | InstSkol Id -- Bound at an instance decl - | FamInstSkol TyCon -- Bound at a family instance decl + | InstSkol -- Bound at an instance decl + | FamInstSkol -- Bound at a family instance decl | PatSkol DataCon -- An existential type variable bound by a pattern for - SrcSpan -- a data constructor with an existential type. E.g. + -- a data constructor with an existential type. E.g. -- data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type -- variable for 'a'. - | ArrowSkol SrcSpan -- An arrow form (see TcArrows) + | ArrowSkol -- An arrow form (see TcArrows) + | RuleSkol RuleName -- The LHS of a RULE | GenSkol [TcTyVar] -- Bound when doing a subsumption check for TcType -- (forall tvs. ty) - SrcSpan | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- -- UserTypeCtxt describes the places where a -- programmer-written type signature can occur +-- Like SkolemInfo, no location info data UserTypeCtxt = FunSigCtxt Name -- Function type signature -- Also used for types in SPECIALISE pragmas @@ -340,7 +343,6 @@ data UserTypeCtxt | ResSigCtxt -- Result type sig -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature - | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE | DefaultDeclCtxt -- Types in a default declaration | SpecInstCtxt -- SPECIALISE instance pragma @@ -405,7 +407,6 @@ pprUserTypeCtxt LamPatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt BindPatSigCtxt = ptext SLIT("a pattern type signature") pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature") pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign declaration for") <+> quotes (ppr n) -pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration") pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") @@ -426,7 +427,7 @@ tidySkolemTyVar env tv (env1, info') = tidy_skol_info env info info -> (env, info) - tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc) + tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1) where (env1, tvs1) = tidyOpenTyVars env tvs (env2, ty1) = tidyOpenType env1 ty @@ -444,27 +445,22 @@ pprSkolTvBinding tv ppr_details (MetaTv (SigTv info) _) = ppr_skol info ppr_details (SkolemTv info) = ppr_skol info - ppr_skol UnkSkol = empty -- Unhelpful; omit - ppr_skol (SigSkol ctxt) = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt, - nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] - ppr_skol info = quotes (ppr tv) <+> pprSkolInfo info + ppr_skol UnkSkol = empty -- Unhelpful; omit + ppr_skol info = quotes (ppr tv) <+> ptext SLIT("is bound by") + <+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] pprSkolInfo :: SkolemInfo -> SDoc -pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt -pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (InstSkol df) = - ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) -pprSkolInfo (FamInstSkol tc) = - ptext SLIT("is bound by the family instance declaration at") <+> - ppr (getSrcLoc tc) -pprSkolInfo (ArrowSkol loc) = - ptext SLIT("is bound by the arrow form at") <+> ppr loc -pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc), - nest 2 (ptext SLIT("at") <+> ppr loc)] -pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), - nest 2 (quotes (ppr (mkForAllTys tvs ty)))], - nest 2 (ptext SLIT("at") <+> ppr loc)] --- UnkSkol, SigSkol +pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt +pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls) +pprSkolInfo InstSkol = ptext SLIT("the instance declaration") +pprSkolInfo FamInstSkol = ptext SLIT("the family instance declaration") +pprSkolInfo (RuleSkol name) = ptext SLIT("the RULE") <+> doubleQuotes (ftext name) +pprSkolInfo ArrowSkol = ptext SLIT("the arrow form") +pprSkolInfo (PatSkol dc) = sep [ptext SLIT("the constructor") <+> quotes (ppr dc)] +pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"), + nest 2 (quotes (ppr (mkForAllTys tvs ty)))] + +-- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = panic "UnkSkol" @@ -496,8 +492,8 @@ isSkolemTyVar tv isExistentialTyVar tv -- Existential type variable, bound by a pattern = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol _ _) -> True - other -> False + SkolemTv (PatSkol {}) -> True + other -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -800,10 +796,6 @@ tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas - -mkPredName :: Unique -> SrcLoc -> PredType -> Name -mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc -mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index c8ef3ee..e24ea65 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -756,8 +756,8 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- Hence the tiresome but innocuous fixM ((tvs', theta', rho'), skol_info) <- fixM (\ ~(_, skol_info) -> do { (forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty - ; span <- getSrcSpanM - ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) span + -- Get loation from monad, not from expected_ty + ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) ; return ((forall_tvs, theta, rho_ty), skol_info) }) #ifdef DEBUG @@ -781,8 +781,9 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- Conclusion: include the free vars of the expected_ty in the -- list of "free vars" for the signature check. - ; dicts <- newDictBndrsO (SigOrigin skol_info) theta' - ; inst_binds <- tcSimplifyCheck sig_msg tvs' dicts lie + ; loc <- getInstLoc (SigOrigin skol_info) + ; dicts <- newDictBndrs loc theta' + ; inst_binds <- tcSimplifyCheck loc tvs' dicts lie ; checkSigTyVarsWrt free_tvs tvs' ; traceTc (text "tcGen:done") @@ -794,7 +795,6 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall ; returnM (co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs - sig_msg = ptext SLIT("expected type of an expression") \end{code} @@ -965,6 +965,7 @@ u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2 go _ ty1@(ForAllTy _ _) ty2@(ForAllTy _ _) | length tvs1 == length tvs2 = do { tvs <- tcInstSkolTyVars UnkSkol tvs1 -- Not a helpful SkolemInfo + -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys tvs in_scope = mkInScopeSet (mkVarSet tvs) subst1 = mkTvSubst in_scope (zipTyEnv tvs1 tys) diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs index 06248b7..cad292b 100644 --- a/compiler/types/FunDeps.lhs +++ b/compiler/types/FunDeps.lhs @@ -10,7 +10,7 @@ It's better to read it as: "if we know these, then we're going to know these" \begin{code} module FunDeps ( Equation, pprEquation, - oclose, grow, improve, + oclose, grow, improve, improveOne, checkInstCoverage, checkFunDeps, pprFundeps ) where @@ -229,6 +229,63 @@ improve inst_env preds -- In any case, improvement *generates*, rather than -- *consumes*, equality constraints +improveOne :: (Class -> [Instance]) + -> Pred_Loc + -> [Pred_Loc] + -> [(Equation,Pred_Loc,Pred_Loc)] + +-- Just do improvement triggered by a single, distinguised predicate + +improveOne inst_env pred@(IParam ip ty, _) preds + = [ ((emptyVarSet, [(ty,ty2)]), pred, p2) + | p2@(IParam ip2 ty2, _) <- preds + , ip==ip2 + , not (ty `tcEqType` ty2)] + +improveOne inst_env pred@(ClassP cls tys, _) preds + | tys `lengthAtLeast` 2 + = instance_eqns ++ pairwise_eqns + -- NB: we put the instance equations first. This biases the + -- order so that we first improve individual constraints against the + -- instances (which are perhaps in a library and less likely to be + -- wrong; and THEN perform the pairwise checks. + -- The other way round, it's possible for the pairwise check to succeed + -- and cause a subsequent, misleading failure of one of the pair with an + -- instance declaration. See tcfail143.hs for an example + where + (cls_tvs, cls_fds) = classTvsFds cls + instances = inst_env cls + rough_tcs = roughMatchTcs tys + + -- NOTE that we iterate over the fds first; they are typically + -- empty, which aborts the rest of the loop. + pairwise_eqns :: [(Equation,Pred_Loc,Pred_Loc)] + pairwise_eqns -- This group comes from pairwise comparison + = [ (eqn, pred, p2) + | fd <- cls_fds + , p2@(ClassP cls2 tys2, _) <- preds + , cls == cls2 + , eqn <- checkClsFD emptyVarSet fd cls_tvs tys tys2 + ] + + instance_eqns :: [(Equation,Pred_Loc,Pred_Loc)] + instance_eqns -- This group comes from comparing with instance decls + = [ (eqn, p_inst, pred) + | fd <- cls_fds -- Iterate through the fundeps first, + -- because there often are none! + , let rough_fd_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs + , ispec@(Instance { is_tvs = qtvs, is_tys = tys_inst, + is_tcs = mb_tcs_inst }) <- instances + , not (instanceCantMatch mb_tcs_inst rough_tcs) + , eqn <- checkClsFD qtvs fd cls_tvs tys_inst tys + , let p_inst = (mkClassPred cls tys_inst, + ptext SLIT("arising from the instance declaration at") + <+> ppr (getSrcLoc ispec)) + ] + +improveOne inst_env eq_pred preds + = [] + ---------- checkGroup :: (Class -> [Instance]) -> [Pred_Loc]