Further improve error handling in TcRn monad
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 13 Oct 2016 11:24:53 +0000 (12:24 +0100)
committerBen Gamari <ben@smart-cactus.org>
Fri, 14 Oct 2016 05:17:04 +0000 (01:17 -0400)
This patch builds on the one for Trac #12124, by dealing properly
with out-of-scope "hole" errors.

This fixes Trac #12529. The hard error coming from visible type application
is still there, but the out-of-scope error is no longer suppressed.

(Arguably the VTA message should be suppressed somehow, but that's a
battle for another day.)

(cherry picked from commit 2fdf21bf26386ac5558ed5b95105bcf78e31f093)

compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/typecheck/should_fail/T12529.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T12529.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 6e38ed8..21035d6 100644 (file)
@@ -913,7 +913,7 @@ try_m thing
             -- captureConstraints/emitContraints dance
        ; case mb_r of
            Left exn -> do { traceTc "tryTc/recoverM recovering from" $
-                                    text (showException exn)
+                            text (showException exn)
                           ; return (Left exn) }
            Right (res, lie) -> do { emitConstraints lie
                                   ; return (Right res) } }
@@ -1081,7 +1081,7 @@ We'll recover in tcPolyBinds, using recoverM.  But then the final
 tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly
 un-filled-in, and will emit a misleading error message.
 
-The underlying problem is that an exception interrupts the connstraint
+The underlying problem is that an exception interrupts the constraint
 gathering process. Bottom line: if we have an exception, it's best
 simply to discard any gathered constraints.  Hence in 'try_m' we
 capture the constraints in a fresh variable, and only emit them into
@@ -1090,6 +1090,18 @@ raised, simply discard the collected constraints... we have a hard
 error to report.  So this capture-the-emit dance isn't as stupid as it
 looks :-).
 
+However suppose we throw an exception inside an invocation of
+captureConstraints.  Then we'll discard all the costraints. But some
+of those contraints might be "variable out of scope" Hole constraints,
+and that might have been the actual original cause of the exception!
+For example (Trac #12529):
+   f = p @ Int
+Here 'p' is out of scope, so we get an insolube Hole constraint. But
+the visible type application fails in the monad (thows an exception).
+We must not discard the out-of-scope error.  Hence the use of tryM in
+captureConstraints to propagate insoluble constraints.
+
+
 ************************************************************************
 *                                                                      *
         Context management for the type checker
@@ -1389,10 +1401,16 @@ emitImplications ct
 
 emitInsoluble :: Ct -> TcM ()
 emitInsoluble ct
-  = do { lie_var <- getConstraintVar ;
-         updTcRef lie_var (`addInsols` unitBag ct) ;
-         v <- readTcRef lie_var ;
-         traceTc "emitInsoluble" (ppr v) }
+  = do { traceTc "emitInsoluble" (ppr ct)
+       ; lie_var <- getConstraintVar
+       ; updTcRef lie_var (`addInsols` unitBag ct) }
+
+emitInsolubles :: Cts -> TcM ()
+emitInsolubles cts
+  | isEmptyBag cts = return ()
+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)
+                        ; lie_var <- getConstraintVar
+                        ; updTcRef lie_var (`addInsols` cts) }
 
 -- | Throw out any constraints emitted by the thing_inside
 discardConstraints :: TcM a -> TcM a
@@ -1401,21 +1419,26 @@ discardConstraints thing_inside = fst <$> captureConstraints thing_inside
 captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 -- (captureConstraints m) runs m, and returns the type constraints it generates
 captureConstraints thing_inside
-  = do { lie_var <- newTcRef emptyWC ;
-         res <- updLclEnv (\ env -> env { tcl_lie = lie_var })
-                          thing_inside ;
-         lie <- readTcRef lie_var ;
-         return (res, lie) }
+  = do { lie_var <- newTcRef emptyWC
+       ; mb_res <- tryM $
+                   updLclEnv (\ env -> env { tcl_lie = lie_var }) $
+                   thing_inside
+
+       ; lie <- readTcRef lie_var
+
+            -- See Note [Constraints and errors] for the
+            -- tryM/failM dance here
+       ; case mb_res of
+           Left _    -> do { emitInsolubles (getInsolubles lie)
+                           ; failM }
+           Right res -> return (res, lie) }
 
 pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
 pushLevelAndCaptureConstraints thing_inside
   = do { env <- getLclEnv
-       ; lie_var <- newTcRef emptyWC
        ; let tclvl' = pushTcLevel (tcl_tclvl env)
-       ; res <- setLclEnv (env { tcl_tclvl = tclvl'
-                               , tcl_lie   = lie_var })
-                thing_inside
-       ; lie <- readTcRef lie_var
+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $
+                       captureConstraints thing_inside
        ; return (tclvl', lie, res) }
 
 pushTcLevelM_ :: TcM a -> TcM a
@@ -1458,24 +1481,28 @@ traceTcConstraints :: String -> TcM ()
 traceTcConstraints msg
   = do { lie_var <- getConstraintVar
        ; lie     <- readTcRef lie_var
-       ; traceTc (msg ++ ": LIE:") (ppr lie)
+       ; traceOptTcRn Opt_D_dump_tc_trace $
+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)
        }
 
 emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()
 emitWildCardHoleConstraints wcs
-  = do { ctLoc <- getCtLocM HoleOrigin Nothing
-       ; forM_ wcs $ \(name, tv) -> do {
-       ; let real_span = case nameSrcSpan name of
+  = do { ct_loc <- getCtLocM HoleOrigin Nothing
+       ; emitInsolubles $ listToBag $
+         map (do_one ct_loc) wcs }
+  where
+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct
+    do_one ct_loc (name, tv)
+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv
+                                      , ctev_loc  = ct_loc' }
+                  , cc_hole = TypeHole (occName name) }
+       where
+         real_span = case nameSrcSpan name of
                            RealSrcSpan span  -> span
                            UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"
                                                       (ppr name <+> quotes (ftext str))
                -- Wildcards are defined locally, and so have RealSrcSpans
-             ctLoc' = setCtLocSpan ctLoc real_span
-             ty     = mkTyVarTy tv
-             can    = CHoleCan { cc_ev   = CtDerived { ctev_pred = ty
-                                                     , ctev_loc  = ctLoc' }
-                               , cc_hole = TypeHole (occName name) }
-       ; emitInsoluble can } }
+         ct_loc' = setCtLocSpan ct_loc real_span
 
 {-
 ************************************************************************
index 753b9fb..e0bf852 100644 (file)
@@ -83,7 +83,7 @@ module TcRnTypes(
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         toDerivedWC,
         andWC, unionsWC, mkSimpleWC, mkImplicWC,
-        addInsols, addSimples, addImplics,
+        addInsols, getInsolubles, addSimples, addImplics,
         tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,
         tyCoVarsOfWCList,
         isDroppableDerivedLoc, insolubleImplic,
@@ -2045,6 +2045,9 @@ addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints
 addInsols wc cts
   = wc { wc_insol = wc_insol wc `unionBags` cts }
 
+getInsolubles :: WantedConstraints -> Cts
+getInsolubles = wc_insol
+
 dropDerivedWC :: WantedConstraints -> WantedConstraints
 -- See Note [Dropping derived constraints]
 dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
diff --git a/testsuite/tests/typecheck/should_fail/T12529.hs b/testsuite/tests/typecheck/should_fail/T12529.hs
new file mode 100644 (file)
index 0000000..ac4e31d
--- /dev/null
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
+module T12529 where
+
+f = p @ Int
diff --git a/testsuite/tests/typecheck/should_fail/T12529.stderr b/testsuite/tests/typecheck/should_fail/T12529.stderr
new file mode 100644 (file)
index 0000000..cd9897e
--- /dev/null
@@ -0,0 +1,8 @@
+
+T12529.hs:5:5: error: Variable not in scope: p
+
+T12529.hs:5:5: error:
+    • Cannot apply expression of type ‘t1’
+      to a visible type argument ‘Int’
+    • In the expression: p @Int
+      In an equation for ‘f’: f = p @Int
index ca99441..985a7c4 100644 (file)
@@ -425,3 +425,5 @@ test('T12170a', normal, compile_fail, [''])
 test('T11990a', normal, compile_fail, [''])
 test('T11990b', normal, compile_fail, [''])
 test('T12124', normal, compile_fail, [''])
+test('T12529', normal, compile_fail, [''])
+