Commit e7701976 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Deal with exceptions in dsWhenNoErrs

Gracious me.  Ever since this patch

  commit 37445780
  Author: Jan Stolarek <jan.stolarek@p.lodz.pl>
  Date:   Fri Jul 11 13:54:45 2014 +0200

      Injective type families

TcRnMonad.askNoErrs has been wrong. It looked like this

   askNoErrs :: TcRn a -> TcRn (a, Bool)
   askNoErrs m
    = do { errs_var <- newTcRef emptyMessages
         ; res  <- setErrsVar errs_var m
         ; (warns, errs) <- readTcRef errs_var
         ; addMessages (warns, errs)
         ; return (res, isEmptyBag errs) }

The trouble comes if 'm' throws an exception in the TcRn monad.
Then 'errs_var is never read, so any errors are simply lost.

This mistake was then propgated into DsMonad.dsWhenNoErrs, where
it gave rise to Trac #13642.

Thank to Ryan for narrowing it down so sharply.

I did some refactoring, as usual.
parent 81af480a
......@@ -454,19 +454,35 @@ failDs :: DsM a
failDs = failM
-- (askNoErrsDs m) runs m
-- If m fails, (askNoErrsDs m) fails
-- If m succeeds with result r, (askNoErrsDs m) succeeds with result (r, b),
-- where b is True iff m generated no errors
-- Regardless of success or failure, any errors generated by m are propagated
-- If m fails,
-- then (askNoErrsDs m) fails
-- If m succeeds with result r,
-- then (askNoErrsDs m) succeeds with result (r, b),
-- where b is True iff m generated no errors
-- Regardless of success or failure,
-- propagate any errors/warnings generated by m
--
-- c.f. TcRnMonad.askNoErrs
askNoErrsDs :: DsM a -> DsM (a, Bool)
askNoErrsDs m
askNoErrsDs thing_inside
= do { errs_var <- newMutVar emptyMessages
; env <- getGblEnv
; res <- setGblEnv (env { ds_msgs = errs_var }) m
; (warns, errs) <- readMutVar errs_var
; mb_res <- tryM $ -- Be careful to catch exceptions
-- so that we propagate errors correctly
-- (Trac #13642)
setGblEnv (env { ds_msgs = errs_var }) $
thing_inside
-- Propagate errors
; msgs@(warns, errs) <- readMutVar errs_var
; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
; return (res, isEmptyBag errs) }
-- And return
; case mb_res of
Left _ -> failM
Right res -> do { dflags <- getDynFlags
; let errs_found = errorsFound dflags msgs
; return (res, not errs_found) } }
mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
......
......@@ -576,11 +576,7 @@ traceTR = liftTcM . traceOptTcRn Opt_D_dump_rtti
-- recoverM retains the errors in the first action,
-- whereas recoverTc here does not
recoverTR :: TR a -> TR a -> TR a
recoverTR recover thing = do
(_,mb_res) <- tryTcErrs thing
case mb_res of
Nothing -> recover
Just res -> return res
recoverTR = tryTcDiscardingErrs
trIO :: IO a -> TR a
trIO = liftTcM . liftIO
......@@ -747,7 +743,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
then parens (text "already monomorphic: " <> ppr my_ty)
else Ppr.empty)
Right dcname <- dataConInfoPtrToName (infoPtr clos)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing -> do -- This can happen for private constructors compiled -O0
-- where the .hi descriptor does not export them
......@@ -893,7 +889,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
Constr -> do
Right dcname <- dataConInfoPtrToName (infoPtr clos)
traceTR (text "Constr1" <+> ppr dcname)
(_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname)
(_,mb_dc) <- tryTc (tcLookupDataCon dcname)
case mb_dc of
Nothing-> do
forM (elems $ ptrs clos) $ \a -> do
......
......@@ -1953,7 +1953,7 @@ type Plan = TcM PlanResult
runPlans :: [Plan] -> TcM PlanResult
runPlans [] = panic "runPlans"
runPlans [p] = p
runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p
-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
-- GHCi 'environment'.
......
......@@ -67,8 +67,7 @@ module TcRnMonad(
mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,
reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,
tryTc,
askNoErrs, discardErrs,
tryTcErrs, tryTcLIE_,
askNoErrs, discardErrs, tryTcDiscardingErrs,
checkNoErrs, whenNoErrs,
ifErrsM, failIfErrsM,
checkTH, failTH,
......@@ -959,7 +958,8 @@ try_m thing
-----------------------
recoverM :: TcRn r -- Recovery action; do this if the main one fails
-> TcRn r -- Main action: do this first
-> TcRn r -- Main action: do this first;
-- if it generates errors, propagate them all
-> TcRn r
-- Errors in 'thing' are retained
recoverM recover thing
......@@ -997,30 +997,25 @@ tryTc :: TcRn a -> TcRn (Messages, Maybe a)
-- Nothing, if m fails
-- It also returns all the errors and warnings accumulated by m
-- It always succeeds (never raises an exception)
tryTc m
tryTc thing_inside
= do { errs_var <- newTcRef emptyMessages ;
res <- try_m (setErrsVar errs_var m) ;
res <- try_m $ -- Be sure to catch exceptions, so that
-- we guaranteed to read the messages out
-- of that brand-new errs_var!
setErrsVar errs_var $
thing_inside ;
msgs <- readTcRef errs_var ;
return (msgs, case res of
Left _ -> Nothing
Right val -> Just val)
Left _ -> Nothing
Right val -> Just val)
-- The exception is always the IOEnv built-in
-- in exception; see IOEnv.failM
}
-- (askNoErrs m) runs m
-- If m fails, (askNoErrs m) fails
-- If m succeeds with result r, (askNoErrs m) succeeds with result (r, b),
-- where b is True iff m generated no errors
-- Regardless of success or failure, any errors generated by m are propagated
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs m
= do { errs_var <- newTcRef emptyMessages
; res <- setErrsVar errs_var m
; (warns, errs) <- readTcRef errs_var
; addMessages (warns, errs)
; return (res, isEmptyBag errs) }
-----------------------
discardErrs :: TcRn a -> TcRn a
-- (discardErrs m) runs m,
-- discarding all error messages and warnings generated by m
......@@ -1030,36 +1025,43 @@ discardErrs m
; setErrsVar errs_var m }
-----------------------
tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
-- Run the thing, returning
-- Just r, if m succceeds with no error messages
-- Nothing, if m fails, or if it succeeds but has error messages
-- Either way, the messages are returned;
-- even in the Just case there might be warnings
tryTcErrs thing
= do { (msgs, res) <- tryTc thing
tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r
-- (tryTcDiscardingErrs recover main) tries 'main';
-- if 'main' succeeds with no error messages, it's the answer
-- otherwise discard everything from 'main', including errors,
-- and try 'recover' instead.
tryTcDiscardingErrs recover main
= do { (msgs, mb_res) <- tryTc main
; dflags <- getDynFlags
; let errs_found = errorsFound dflags msgs
; return (msgs, case res of
Nothing -> Nothing
Just val | errs_found -> Nothing
| otherwise -> Just val)
}
-----------------------
tryTcLIE_ :: TcM r -> TcM r -> TcM r
-- (tryTcLIE_ r m) tries m;
-- if m succeeds with no error messages, it's the answer
-- otherwise tryTcLIE_ drops everything from m and tries r instead.
tryTcLIE_ recover main
= do { (msgs, mb_res) <- tryTcErrs main
; case mb_res of
Just val -> do { addMessages msgs -- There might be warnings
; return val }
Nothing -> recover -- Discard all msgs
Just res | not (errorsFound dflags msgs)
-> -- 'main' succeeed with no error messages
do { addMessages msgs -- msgs might still have warnings
; return res }
_ -> -- 'main' failed, or produced an error message
recover -- Discard all errors and warnings entirely
}
-----------------------
-- (askNoErrs m) runs m
-- If m fails,
-- then (askNoErrs m) fails
-- If m succeeds with result r,
-- then (askNoErrs m) succeeds with result (r, b),
-- where b is True iff m generated no errors
-- Regardless of success or failure,
-- propagate any errors/warnings generated by m
askNoErrs :: TcRn a -> TcRn (a, Bool)
askNoErrs m
= do { (msgs, mb_res) <- tryTc m
; addMessages msgs -- Always propagate errors
; case mb_res of
Nothing -> failM
Just res -> do { dflags <- getDynFlags
; let errs_found = errorsFound dflags msgs
; return (res, not errs_found) } }
-----------------------
checkNoErrs :: TcM r -> TcM r
-- (checkNoErrs m) succeeds iff m succeeds and generates no errors
-- If m fails then (checkNoErrsTc m) fails.
......@@ -1068,13 +1070,11 @@ checkNoErrs :: TcM r -> TcM r
-- If so, it fails too.
-- Regardless, any errors generated by m are propagated to the enclosing context.
checkNoErrs main
= do { (msgs, mb_res) <- tryTcErrs main
; addMessages msgs
; case mb_res of
Nothing -> failM
Just val -> return val
}
= do { (res, no_errs) <- askNoErrs main
; unless no_errs failM
; return res }
-----------------------
whenNoErrs :: TcM () -> TcM ()
whenNoErrs thing = ifErrsM (return ()) thing
......
......@@ -864,13 +864,7 @@ instance TH.Quasi TcM where
-- For qRecover, discard error messages if
-- the recovery action is chosen. Otherwise
-- we'll only fail higher up.
qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
; case mb_res of
Just val -> do { addMessages msgs -- There might be warnings
; return val }
Nothing -> recover -- Discard all msgs
}
qRecover recover main = tryTcDiscardingErrs recover main
qRunIO io = liftIO io
qAddDependentFile fp = do
......
{-# LANGUAGE GADTs, TypeInType, TemplateHaskell, RankNTypes #-}
module T13642 where
import Data.Kind (Type)
import Language.Haskell.TH (stringE, pprint)
foo :: IO ()
foo = $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |]
>>= \d -> stringE (pprint d))
T13642.hs:8:9: error:
Exotic form of kind not (yet) handled by Template Haskell
forall a. a -> Type
......@@ -383,3 +383,4 @@ test('T11046', normal, multimod_compile, ['T11046','-v0'])
test('T13366', normal, compile_and_run, ['-lstdc++ -v0'])
test('T13587', expect_broken(13587), compile_and_run, ['-v0'])
test('T13618', normal, compile_and_run, ['-v0'])
test('T13642', normal, compile_fail, ['-v0'])
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment