From 9b69d74f05582ccf140c007128a52274aa49bd65 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 31 Dec 2008 14:35:21 +0000 Subject: [PATCH] Improve error reporting for 'deriving' a) Improve the extra suggested fix when there's a "no instance" error in a deriving clause. b) Improve error location recording in tcInstDecl2 Many of the changes in tcInstDecl2 are simple reformatting. --- compiler/typecheck/TcDeriv.lhs | 4 +- compiler/typecheck/TcInstDcls.lhs | 167 +++++++++++++++++++------------------ compiler/typecheck/TcSimplify.lhs | 26 +++--- 3 files changed, 100 insertions(+), 97 deletions(-) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 5053a06..419ec94 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -1314,9 +1314,7 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for" derivInstCtxt :: Class -> [Type] -> Message derivInstCtxt clas inst_tys - = vcat [ptext (sLit "Alternative fix: use a standalone 'deriving instance' declaration"), - nest 2 (ptext (sLit "instead, so you can specify the instance context yourself")), - ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys)] + = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) badDerivedPred :: PredType -> Message badDerivedPred pred diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index baa7515..177a16f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -564,11 +564,21 @@ tcInstDecls2 tycl_decls inst_decls unionManyBags inst_binds_s ; tcl_env <- getLclEnv -- Default method Ids in here ; return (binds, tcl_env) } + +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) + = recoverM (return emptyLHsBinds) $ + setSrcSpan loc $ + addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ + tc_inst_decl2 dfun_id ibinds + where + dfun_id = instanceDFunId ispec + loc = getSrcSpan dfun_id \end{code} \begin{code} -tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) +tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun ------------------------ @@ -590,9 +600,8 @@ tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- If there are no superclasses, matters are simpler, because we don't need the case -- see Note [Newtype deriving superclasses] in TcDeriv.lhs -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) - = do { let dfun_id = instanceDFunId ispec - rigid_info = InstSkol +tc_inst_decl2 dfun_id (NewTypeDerived coi) + = do { let rigid_info = InstSkol origin = SigOrigin rigid_info inst_ty = idType dfun_id ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty @@ -693,103 +702,95 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived }) ------------------------ -- Ordinary instances -tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) - = let - dfun_id = instanceDFunId ispec - rigid_info = InstSkol - inst_ty = idType dfun_id - loc = getSrcSpan dfun_id - in - -- Prime error recovery - recoverM (return emptyLHsBinds) $ - setSrcSpan loc $ - addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do +tc_inst_decl2 dfun_id (VanillaInst monobinds uprags) + = do { let rigid_info = InstSkol + inst_ty = idType dfun_id -- Instantiate the instance decl with skolem constants - (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty + ; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty -- These inst_tyvars' scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit -- bizarre, but OK so long as you realise it! - let - (clas, inst_tys') = tcSplitDFunHead inst_head' - (class_tyvars, sc_theta, _, op_items) = classBigSig clas + ; let + (clas, inst_tys') = tcSplitDFunHead inst_head' + (class_tyvars, sc_theta, _, op_items) = classBigSig clas - -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta - origin = SigOrigin rigid_info + -- Instantiate the super-class context with inst_tys + sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta + origin = SigOrigin rigid_info -- Create dictionary Ids from the specified instance contexts. - sc_loc <- getInstLoc InstScOrigin - sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted - inst_loc <- getInstLoc origin - dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities - this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') + ; sc_loc <- getInstLoc InstScOrigin + ; sc_dicts <- newDictOccs sc_loc sc_theta' -- These are wanted + ; inst_loc <- getInstLoc origin + ; dfun_dicts <- newDictBndrs inst_loc dfun_theta' -- Includes equalities + ; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys') -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. -- Typecheck the methods - let this_dict_id = instToId this_dict - dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities - prag_fn = mkPragFun uprags - tc_meth = tcInstanceMethod loc clas inst_tyvars' - dfun_dicts - dfun_theta' inst_tys' - this_dict dfun_id - prag_fn monobinds - (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ + ; let this_dict_id = instToId this_dict + dfun_lam_vars = map instToVar dfun_dicts -- Includes equalities + prag_fn = mkPragFun uprags + loc = getSrcSpan dfun_id + tc_meth = tcInstanceMethod loc clas inst_tyvars' + dfun_dicts + dfun_theta' inst_tys' + this_dict dfun_id + prag_fn monobinds + ; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $ mapAndUnzipM tc_meth op_items - -- Figure out bindings for the superclass context - -- Don't include this_dict in the 'givens', else - -- sc_dicts get bound by just selecting from this_dict!! - sc_binds <- addErrCtxt superClassCtxt $ - tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts + -- Figure out bindings for the superclass context + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + ; sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts -- Note [Recursive superclasses] -- It's possible that the superclass stuff might unified something -- in the envt with one of the inst_tyvars' - checkSigTyVars inst_tyvars' - - -- Deal with 'SPECIALISE instance' pragmas - prags <- tcPrags dfun_id (filter isSpecInstLSig uprags) - - -- Create the result bindings - let - dict_constr = classDataCon clas - inline_prag | null dfun_dicts = [] - | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] - -- Always inline the dfun; this is an experimental decision - -- because it makes a big performance difference sometimes. - -- Often it means we can do the method selection, and then - -- inline the method as well. Marcin's idea; see comments below. - -- - -- BUT: don't inline it if it's a constant dictionary; - -- we'll get all the benefit without inlining, and we get - -- a **lot** of code duplication if we inline it - -- - -- See Note [Inline dfuns] below - - sc_dict_vars = map instToVar sc_dicts - dict_bind = L loc (VarBind this_dict_id dict_rhs) - dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs - inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys') - (dataConWrapId dict_constr) - -- We don't produce a binding for the dict_constr; instead we - -- rely on the simplifier to unfold this saturated application - -- We do this rather than generate an HsCon directly, because - -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId code rather - -- than needing to be repeated here. - - - main_bind = noLoc $ AbsBinds - inst_tyvars' - dfun_lam_vars - [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)] - (dict_bind `consBag` sc_binds) - - showLIE (text "instance") - return (main_bind `consBag` unionManyBags meth_binds) + ; checkSigTyVars inst_tyvars' + + -- Deal with 'SPECIALISE instance' pragmas + ; prags <- tcPrags dfun_id (filter isSpecInstLSig uprags) + + -- Create the result bindings + ; let dict_constr = classDataCon clas + inline_prag | null dfun_dicts = [] + | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] + -- Always inline the dfun; this is an experimental decision + -- because it makes a big performance difference sometimes. + -- Often it means we can do the method selection, and then + -- inline the method as well. Marcin's idea; see comments below. + -- + -- BUT: don't inline it if it's a constant dictionary; + -- we'll get all the benefit without inlining, and we get + -- a **lot** of code duplication if we inline it + -- + -- See Note [Inline dfuns] below + + sc_dict_vars = map instToVar sc_dicts + dict_bind = L loc (VarBind this_dict_id dict_rhs) + dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs + inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys') + (dataConWrapId dict_constr) + -- We don't produce a binding for the dict_constr; instead we + -- rely on the simplifier to unfold this saturated application + -- We do this rather than generate an HsCon directly, because + -- it means that the special cases (e.g. dictionary with only one + -- member) are dealt with by the common MkId.mkDataConWrapId code rather + -- than needing to be repeated here. + + + main_bind = noLoc $ AbsBinds + inst_tyvars' + dfun_lam_vars + [(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)] + (dict_bind `consBag` sc_binds) + + ; showLIE (text "instance") + ; return (main_bind `consBag` unionManyBags meth_binds) } \end{code} Note [Recursive superclasses] diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 932cb68..ad7e5c2 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -1281,7 +1281,7 @@ tcSimplifySuperClasses loc this givens sc_wanteds = do { traceTc (text "tcSimplifySuperClasses") ; (irreds,binds1) <- checkLoop env sc_wanteds ; let (tidy_env, tidy_irreds) = tidyInsts irreds - ; reportNoInstances tidy_env (Just (loc, givens)) tidy_irreds + ; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds ; return binds1 } where env = RedEnv { red_doc = pprInstLoc loc, @@ -2980,7 +2980,8 @@ tcSimplifyDeriv orig tyvars theta ; (irreds, _) <- tryHardCheckLoop doc wanteds ; let (tv_dicts, others) = partition ok irreds - ; addNoInstanceErrs others + (tidy_env, tidy_insts) = tidyInsts others + ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts -- See Note [Exotic derived instance contexts] in TcMType ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars) @@ -2994,6 +2995,8 @@ tcSimplifyDeriv orig tyvars theta ok dict | isDict dict = validDerivPred (dictPred dict) | otherwise = False + alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"), + ptext (sLit "so you can specify the instance context yourself")] \end{code} @@ -3008,7 +3011,7 @@ tcSimplifyDefault :: ThetaType -- Wanted; has no type variables in it tcSimplifyDefault theta = do wanteds <- newDictBndrsO DefaultOrigin theta (irreds, _) <- tryHardCheckLoop doc wanteds - addNoInstanceErrs irreds + addNoInstanceErrs irreds if null irreds then return () else @@ -3104,7 +3107,7 @@ addNoInstanceErrs :: [Inst] -- Wanted (can include implications) -> TcM () addNoInstanceErrs insts = do { let (tidy_env, tidy_insts) = tidyInsts insts - ; reportNoInstances tidy_env Nothing tidy_insts } + ; reportNoInstances tidy_env Nothing [] tidy_insts } reportNoInstances :: TidyEnv @@ -3112,14 +3115,15 @@ reportNoInstances -- Nothing => top level -- Just (d,g) => d describes the construct -- with givens g + -> [SDoc] -- Alternative fix for no-such-instance -> [Inst] -- What is wanted (can include implications) -> TcM () -reportNoInstances tidy_env mb_what insts - = groupErrs (report_no_instances tidy_env mb_what) insts +reportNoInstances tidy_env mb_what alt_fix insts + = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts -report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [Inst] -> TcM () -report_no_instances tidy_env mb_what insts +report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM () +report_no_instances tidy_env mb_what alt_fixes insts = do { inst_envs <- tcGetInstEnvs ; let (implics, insts1) = partition isImplicInst insts (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1 @@ -3137,7 +3141,7 @@ report_no_instances tidy_env mb_what insts complain_implic inst -- Recurse! = reportNoInstances tidy_env (Just (tci_loc inst, tci_given inst)) - (tci_wanted inst) + alt_fixes (tci_wanted inst) check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc -- Right msg => overlap message @@ -3185,13 +3189,13 @@ report_no_instances tidy_env mb_what 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) ] + , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ] | otherwise -- Top level = vcat [ addInstLoc insts $ ptext (sLit "No instance") <> plural insts <+> ptext (sLit "for") <+> pprDictsTheta insts - , show_fixes fixes2 ] + , show_fixes (fixes2 ++ alt_fixes) ] where fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts -- 1.7.10.4