From af21e38855f7d517774542b360178b05045ecb08 Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Fri, 24 Jun 2016 15:49:05 +0100 Subject: Don't omit any evidence bindings This fixes Trac #12156, where we were omitting to make an evidence binding (because cec_suppress was on), but yet the program was compiled and run. The fix is easy, and involves deleting code :-). --- compiler/typecheck/TcErrors.hs | 57 +++++++++++----------- .../tests/partial-sigs/should_compile/T12156.hs | 4 ++ .../partial-sigs/should_compile/T12156.stderr | 3 ++ testsuite/tests/partial-sigs/should_compile/all.T | 1 + 4 files changed, 37 insertions(+), 28 deletions(-) create mode 100644 testsuite/tests/partial-sigs/should_compile/T12156.hs create mode 100644 testsuite/tests/partial-sigs/should_compile/T12156.stderr diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 990418ac31..9cccb63059 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -246,6 +246,16 @@ data HoleChoice | HoleWarn -- Defer to runtime, emit a compile-time warning | HoleDefer -- Defer to runtime, no warning +instance Outputable HoleChoice where + ppr HoleError = text "HoleError" + ppr HoleWarn = text "HoleWarn" + ppr HoleDefer = text "HoleDefer" + +instance Outputable TypeErrorChoice where + ppr TypeError = text "TypeError" + ppr TypeWarn = text "TypeWarn" + ppr TypeDefer = text "TypeDefer" + data ReportErrCtxt = CEC { cec_encl :: [Implication] -- Enclosing implications -- (innermost first) @@ -427,7 +437,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl , ("skolem eq1", very_wrong, True, mkSkolReporter) , ("skolem eq2", skolem_eq, True, mkSkolReporter) , ("non-tv eq", non_tv_eq, True, mkSkolReporter) - , ("Out of scope", is_out_of_scope, True, mkHoleReporter) + , ("Out of scope", is_out_of_scope, True, mkHoleReporter) , ("Holes", is_hole, False, mkHoleReporter) -- The only remaining equalities are alpha ~ ty, @@ -536,14 +546,14 @@ mkSkolReporter ctxt cts mkHoleReporter :: Reporter -- Reports errors one at a time mkHoleReporter ctxt - = mapM_ $ \ct -> - do { err <- mkHoleError ctxt ct - ; maybeReportHoleError ctxt ct err - ; maybeAddDeferredHoleBinding ctxt err ct } + = mapM_ $ \ct -> do { err <- mkHoleError ctxt ct + ; maybeReportHoleError ctxt ct err + ; maybeAddDeferredHoleBinding ctxt err ct } mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt - = mapM_ $ \ct -> maybeReportError ctxt =<< mkUserTypeError ctxt ct + = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct + ; maybeReportError ctxt err } mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct @@ -561,7 +571,6 @@ mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -- and report only the first (to avoid a cascade) mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt) (equivClasses cmp_loc cts) - where eq_lhs_type :: Ct -> Ct -> Bool eq_lhs_type ct1 ct2 @@ -585,9 +594,13 @@ reportGroup mk_err ctxt cts = (_, cts') -> do { err <- mk_err ctxt cts' ; maybeReportError ctxt err - ; mapM_ (maybeAddDeferredBinding ctxt err) cts' } - -- Add deferred bindings for all - -- But see Note [Always warn with -fdefer-type-errors] + -- But see Note [Always warn with -fdefer-type-errors] + ; traceTc "reportGroup" (ppr cts') + ; mapM_ (addDeferredBinding ctxt err) cts' } + -- Add deferred bindings for all + -- Redundant if we are going to abort compilation, + -- but that's hard to know for sure, and if we don't + -- abort, we need bindings for all (e.g. Trac #12156) where isMonadFailInstanceMissing ct = case ctLocOrigin (ctLoc ct) of @@ -657,23 +670,10 @@ addDeferredBinding ctxt err ct maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () maybeAddDeferredHoleBinding ctxt err ct - | isExprHoleCt ct - , case cec_expr_holes ctxt of - HoleDefer -> True - HoleWarn -> True - HoleError -> False - = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions - | otherwise -- not for holes in partial type signatures - = return () - -maybeAddDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM () -maybeAddDeferredBinding ctxt err ct = - case cec_defer_type_errors ctxt of - TypeDefer -> deferred - TypeWarn -> deferred - TypeError -> return () - where - deferred = addDeferredBinding ctxt err ct + | isExprHoleCt ct + = addDeferredBinding ctxt err ct -- Only add bindings for holes in expressions + | otherwise -- not for holes in partial type signatures + = return () tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True @@ -696,9 +696,10 @@ tryReporters ctxt reporters cts tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct]) tryReporter ctxt (str, keep_me, suppress_after, reporter) cts | null yeses = return (ctxt, cts) - | otherwise = do { traceTc "tryReporter:" (text str <+> ppr yeses) + | otherwise = do { traceTc "tryReporter{ " (text str <+> ppr yeses) ; reporter ctxt yeses ; let ctxt' = ctxt { cec_suppress = suppress_after || cec_suppress ctxt } + ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after) ; return (ctxt', nos) } where (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts diff --git a/testsuite/tests/partial-sigs/should_compile/T12156.hs b/testsuite/tests/partial-sigs/should_compile/T12156.hs new file mode 100644 index 0000000000..b8d639f6fd --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/T12156.hs @@ -0,0 +1,4 @@ +module Main where + +main = print v + diff --git a/testsuite/tests/partial-sigs/should_compile/T12156.stderr b/testsuite/tests/partial-sigs/should_compile/T12156.stderr new file mode 100644 index 0000000000..6508d8a3de --- /dev/null +++ b/testsuite/tests/partial-sigs/should_compile/T12156.stderr @@ -0,0 +1,3 @@ + +T12156.hs:3:14: warning: [-Wtyped-holes (in -Wdefault)] + Variable not in scope: v diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T index 262bf7e794..f4b869c46e 100644 --- a/testsuite/tests/partial-sigs/should_compile/all.T +++ b/testsuite/tests/partial-sigs/should_compile/all.T @@ -64,3 +64,4 @@ test('SuperCls', normal, compile, ['']) test('T12033', normal, compile, ['']) test('T11339a', normal, compile, ['']) test('T11670', normal, compile, ['']) +test('T12156', normal, compile, ['-fdefer-typed-holes']) -- cgit v1.2.1