Fix top-level constraint handling (Trac #12921)
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Jan 2017 10:59:08 +0000 (10:59 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 12 Jan 2017 12:58:03 +0000 (12:58 +0000)
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.

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

index 39a8884..aa1dc34 100644 (file)
@@ -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]
index aac872a..13c8382 100644 (file)
@@ -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
+
index 817989e..4388b44 100644 (file)
@@ -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
index c938adf..2388348 100644 (file)
@@ -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 })
index 9995157..15aaaa8 100644 (file)
@@ -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
diff --git a/testsuite/tests/typecheck/should_fail/T12921.hs b/testsuite/tests/typecheck/should_fail/T12921.hs
new file mode 100644 (file)
index 0000000..4b4aa27
--- /dev/null
@@ -0,0 +1,9 @@
+{-# 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
diff --git a/testsuite/tests/typecheck/should_fail/T12921.stderr b/testsuite/tests/typecheck/should_fail/T12921.stderr
new file mode 100644 (file)
index 0000000..8d84c2e
--- /dev/null
@@ -0,0 +1,32 @@
+
+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
index df3f5c8..c490fec 100644 (file)
@@ -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, [''])