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

Fix top-level constraint handling (Trac #12921)

Some out-of-scope errors were not being reported if anyone
throws an un-caught exception in the TcM monad.  That led to

  ghc: panic! (the 'impossible' happened)
	initTc: unsolved constraints

I fixed this

* Splitting captureConstraints to use an auxilliary
  tryCaptureConstraints (which never fails)

* Define a new TcSimplify.captureTopConstraints (replacing
  the old TcRnMonad.captureTopConstraints), which reports
  any unsolved out-of-scope constraints before propagating
  the exception

That in turn allowed me to do some tidying up of the static-constraint
machinery, reducing duplication.

Also solves #13106.
parent 89ce9cd3
......@@ -604,8 +604,8 @@ tcExpr (HsStatic fvs expr) res_ty
[liftedTypeKind, expr_ty]
-- Insert the constraints of the static form in a global list for later
-- validation.
; stWC <- tcg_static_wc <$> getGblEnv
; updTcRef stWC (andWC lie)
; emitStaticConstraints lie
-- Wrap the static form with the 'fromStaticPtr' call.
; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName p_ty
; let wrap = mkWpTyApps [expr_ty]
......
......@@ -150,6 +150,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax
(const ()) $
initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $
withTcPlugins hsc_env $
tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
| otherwise
......@@ -372,14 +373,11 @@ tcRnSrcDecls explicit_mod_hdr decls
do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
-- Check for the 'main' declaration
-- Must do this inside the captureConstraints
-- Must do this inside the captureTopConstraints
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
; return (tcg_env, tcl_env) }
-- Emit Typeable bindings
; tcg_env <- setGblEnv tcg_env mkTypeableBinds
; setEnvs (tcg_env, tcl_env) $ do {
-- Simplify constraints
......@@ -394,9 +392,12 @@ tcRnSrcDecls explicit_mod_hdr decls
; new_ev_binds <- {-# SCC "simplifyTop" #-}
simplifyTop lie
-- Emit Typeable bindings
; tcg_env <- mkTypeableBinds
-- Finalizers must run after constraints are simplified, or some types
-- might not be complete when using reify (see #12777).
; (tcg_env, tcl_env) <- run_th_modfinalizers
; (tcg_env, tcl_env) <- setGblEnv tcg_env run_th_modfinalizers
; setEnvs (tcg_env, tcl_env) $ do {
; finishTH
......@@ -560,7 +561,7 @@ tcRnHsBootDecls hsc_src decls
<- rnTopSrcDecls first_group
-- The empty list is for extra dependencies coming from .hs-boot files
-- See Note [Extra dependencies from .hs-boot files] in RnSource
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
; (gbl_env, lie) <- captureTopConstraints $ setGblEnv tcg_env $ do {
-- Check for illegal declarations
......@@ -1992,18 +1993,15 @@ tcGhciStmts stmts
-- OK, we're ready to typecheck the stmts
traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
((tc_stmts, ids), lie) <- captureConstraints $
((tc_stmts, ids), lie) <- captureTopConstraints $
tc_io_stmts $ \ _ ->
mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- wanted constraints from static forms
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
-- Simplify the context
traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
const_binds <- checkNoErrs (simplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
traceTc "TcRnDriver.tcGhciStmts: done" empty ;
......@@ -2093,19 +2091,17 @@ tcRnExpr hsc_env mode rdr_expr
else return expr_ty } ;
-- Generalise
((qtvs, dicts, _), lie_top) <- captureConstraints $
((qtvs, dicts, _), lie_top) <- captureTopConstraints $
{-# SCC "simplifyInfer" #-}
simplifyInfer tclvl
infer_mode
[] {- No sig vars -}
[(fresh_it, res_ty)]
lie ;
-- Wanted constraints from static forms
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
-- Ignore the dictionary bindings
_ <- perhaps_disable_default_warnings $
simplifyInteractive (andWC stWC lie_top) ;
simplifyInteractive lie_top ;
let { all_expr_ty = mkInvForAllTys qtvs (mkLamTypes dicts res_ty) } ;
ty <- zonkTcType all_expr_ty ;
......@@ -2537,3 +2533,4 @@ loadTcPlugins hsc_env =
where
load_plugin (_, plug, opts) = tcPlugin plug opts
#endif
......@@ -93,9 +93,9 @@ module TcRnMonad(
getTcEvTyCoVars, getTcEvBindsMap,
chooseUniqueOccTc,
getConstraintVar, setConstraintVar,
emitConstraints, emitSimple, emitSimples,
emitConstraints, emitStaticConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, emitInsoluble,
discardConstraints, captureConstraints, captureTopConstraints,
discardConstraints, captureConstraints, tryCaptureConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
......@@ -930,16 +930,16 @@ reportWarning reason err
try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
-- Does tryM, with a debug-trace on failure
try_m thing
= do { mb_r <- tryM (captureConstraints thing)
= do { (mb_r, lie) <- tryCaptureConstraints thing
; emitConstraints lie
-- See Note [Constraints and errors] for the
-- captureConstraints/emitContraints dance
-- Debug trace
; case mb_r of
Left exn -> do { traceTc "tryTc/recoverM recovering from" $
text (showException exn)
; return (Left exn) }
Right (res, lie) -> do { emitConstraints lie
; return (Right res) } }
Left exn -> traceTc "tryTc/recoverM recovering from" $
text (showException exn)
Right {} -> return ()
; return mb_r }
-----------------------
recoverM :: TcRn r -- Recovery action; do this if the main one fails
......@@ -1089,43 +1089,8 @@ failTH e what -- Raise an error in a stage-1 compiler
2 (ppr e)
, text "Perhaps you are using a stage-1 compiler?" ])
{- Note [Constraints and errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #12124):
foo :: Maybe Int
foo = return (case Left 3 of
Left -> 1 -- Error here!
_ -> 0)
The call to 'return' will generate a (Monad m) wanted constraint; but
then there'll be "hard error" (i.e. an exception in the TcM monad).
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 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
the surrounding context if we exit normally. If an exception is
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 constraints. 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
* *
......@@ -1408,6 +1373,11 @@ getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
emitStaticConstraints :: WantedConstraints -> TcM ()
emitStaticConstraints static_lie
= do { gbl_env <- getGblEnv
; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }
emitConstraints :: WantedConstraints -> TcM ()
emitConstraints ct
= do { lie_var <- getConstraintVar ;
......@@ -1451,35 +1421,38 @@ emitInsolubles cts
discardConstraints :: TcM a -> TcM a
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
tryCaptureConstraints :: TcM a -> TcM (Either IOEnvFailure a, WantedConstraints)
-- (captureConstraints_maybe m) runs m,
-- and returns the type constraints it generates
-- It never throws an exception; instead if thing_inside fails,
-- it returns Left exn and the insoluble constraints
tryCaptureConstraints thing_inside
= 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
-- See Note [Constraints and errors]
; let lie_to_keep = case mb_res of
Left {} -> insolublesOnly lie
Right {} -> lie
; return (mb_res, lie_to_keep) }
captureConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureConstraints m) runs m, and returns the type constraints it generates
captureConstraints thing_inside
= do { (mb_res, lie) <- tryCaptureConstraints thing_inside
-- See Note [Constraints and errors]
-- If the thing_inside threw an exception, emit the insoluble
-- constraints only (returned by tryCaptureConstraints)
-- so that they are not lost
; case mb_res of
Left _ -> do { emitInsolubles (getInsolubles lie)
; failM }
Left _ -> do { emitConstraints lie; failM }
Right res -> return (res, lie) }
captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureTopConstraints m) runs m, and returns the type constraints it
-- generates plus the constraints produced by static forms inside.
captureTopConstraints thing_inside
= do { (res, lie) <- captureConstraints thing_inside ;
-- wanted constraints from static forms
; tcg_static_wc_ref <- tcg_static_wc <$> getGblEnv
; stWC <- readTcRef tcg_static_wc_ref
; writeTcRef tcg_static_wc_ref emptyWC
; return (res, andWC stWC lie)
}
pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)
pushLevelAndCaptureConstraints thing_inside
= do { env <- getLclEnv
......@@ -1552,7 +1525,48 @@ emitWildCardHoleConstraints wcs
-- Wildcards are defined locally, and so have RealSrcSpans
ct_loc' = setCtLocSpan ct_loc real_span
{-
{- Note [Constraints and errors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #12124):
foo :: Maybe Int
foo = return (case Left 3 of
Left -> 1 -- Hard error here!
_ -> 0)
The call to 'return' will generate a (Monad m) wanted constraint; but
then there'll be "hard error" (i.e. an exception in the TcM monad), from
the unsaturated Left constructor pattern.
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 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
the surrounding context if we exit normally. If an exception is
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, and discard all the constraints. 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.
So we /retain the insoluble constraints/ if there is an exception.
Hence:
- insolublesOnly in tryCaptureConstraints
- emitConstraints in the Left case of captureConstraints
************************************************************************
* *
Template Haskell context
......
......@@ -81,7 +81,7 @@ module TcRnTypes(
WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
andWC, unionsWC, mkSimpleWC, mkImplicWC,
addInsols, getInsolubles, addSimples, addImplics,
addInsols, getInsolubles, insolublesOnly, addSimples, addImplics,
tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, dropDerivedInsols,
tyCoVarsOfWCList,
isDroppableDerivedLoc, insolubleImplic,
......@@ -2107,6 +2107,10 @@ addInsols wc cts
getInsolubles :: WantedConstraints -> Cts
getInsolubles = wc_insol
insolublesOnly :: WantedConstraints -> WantedConstraints
-- Keep only the insolubles
insolublesOnly wc = wc { wc_simple = emptyBag, wc_impl = emptyBag }
dropDerivedWC :: WantedConstraints -> WantedConstraints
-- See Note [Dropping derived constraints]
dropDerivedWC wc@(WC { wc_simple = simples, wc_insol = insols })
......
......@@ -5,7 +5,8 @@ module TcSimplify(
growThetaTyVars,
simplifyAmbiguityCheck,
simplifyDefault,
simplifyTop, simplifyInteractive, solveEqualities,
simplifyTop, captureTopConstraints,
simplifyInteractive, solveEqualities,
simplifyWantedsTcM,
tcCheckSatisfiability,
......@@ -58,6 +59,27 @@ import Data.List ( partition )
*********************************************************************************
-}
captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)
-- (captureTopConstraints m) runs m, and returns the type constraints it
-- generates plus the constraints produced by static forms inside.
-- If it fails with an exception, it reports any insolubles
-- (out of scope variables) before doing so
captureTopConstraints thing_inside
= do { static_wc_var <- TcM.newTcRef emptyWC ;
; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $
TcM.tryCaptureConstraints thing_inside
; stWC <- TcM.readTcRef static_wc_var
-- See TcRnMonad Note [Constraints and errors]
-- If the thing_inside threw an exception, but generated some insoluble
-- constraints, report the latter before propagating the exception
-- Otherwise they will be lost altogether
; case mb_res of
Right res -> return (res, lie `andWC` stWC)
Left {} -> do { _ <- reportUnsolved lie; failM } }
-- This call to reportUnsolved is the reason
-- this function is here instead of TcRnMonad
simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
-- Simplify top-level constraints
-- Usually these will be implications,
......@@ -128,7 +150,7 @@ simpl_top wanteds
-- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked
-- filter isMetaTyVar: we might have runtime-skolems in GHCi,
-- and we definitely don't want to try to assign to those!
-- the isTyVar needs to weed out coercion variables
-- The isTyVar is needed to weed out coercion variables
; defaulted <- mapM defaultTyVarTcS meta_tvs -- Has unification side effects
; if or defaulted
......
{-# LANGUAGE OverloadedStrings #-}
module T12921 (stat) where
{-# ANN module "HLint: ignore Reduce duplication" #-}
stat :: Int -> Int
stat = choice []
-- 'choice' is deliberately out of scope in this test
T12921.hs:4:1: error:
• Ambiguous type variable ‘p0’ arising from an annotation
prevents the constraint ‘(Data.Data.Data p0)’ from being solved.
Probable fix: use a type annotation to specify what ‘p0’ should be.
These potential instances exist:
instance (Data.Data.Data a, Data.Data.Data b) =>
Data.Data.Data (Either a b)
-- Defined in ‘Data.Data’
instance Data.Data.Data Ordering -- Defined in ‘Data.Data’
instance Data.Data.Data Integer -- Defined in ‘Data.Data’
...plus 15 others
...plus 40 instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the annotation:
{-# ANN module "HLint: ignore Reduce duplication" #-}
T12921.hs:4:16: error:
• Ambiguous type variable ‘p0’ arising from the literal ‘"HLint: ignore Reduce duplication"’
prevents the constraint ‘(Data.String.IsString
p0)’ from being solved.
Probable fix: use a type annotation to specify what ‘p0’ should be.
These potential instances exist:
instance a ~ Char => Data.String.IsString [a]
-- Defined in ‘Data.String’
...plus two instances involving out-of-scope types
(use -fprint-potential-instances to see them all)
• In the annotation:
{-# ANN module "HLint: ignore Reduce duplication" #-}
T12921.hs:7:8: error:
Variable not in scope: choice :: [a0] -> Int -> Int
......@@ -434,3 +434,4 @@ test('T12803', normal, compile_fail, [''])
test('T12042', extra_clean(['T12042a.hi', 'T12042a.o', 'T12042.hi-boot', 'T12042.o-boot']), multimod_compile_fail, ['T12042', ''])
test('T12966', normal, compile_fail, [''])
test('T12837', normal, compile_fail, [''])
test('T12921', normal, compile_fail, [''])
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