[commit: ghc] master: Gather constraints locally in checkMain (3c62b1d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/3c62b1d6b672e7727ea5fa56c69bf43e43d0fd8f/ghc

>---------------------------------------------------------------

commit 3c62b1d6b672e7727ea5fa56c69bf43e43d0fd8f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Feb 21 15:53:06 2017 +0000

    Gather constraints locally in checkMain
    
    Wiwth -fdefer-type-errors we were generating some top-level
    equality constraints, just in a corner of checkMain.  The
    fix is easy.
    
    Fixes Trac #13292


>---------------------------------------------------------------

3c62b1d6b672e7727ea5fa56c69bf43e43d0fd8f
 compiler/typecheck/TcRnDriver.hs                   | 18 ++++++++++-------
 testsuite/tests/typecheck/should_fail/T13292.hs    |  6 ++++++
 .../tests/typecheck/should_fail/T13292.stderr      | 23 ++++++++++++++++++++++
 testsuite/tests/typecheck/should_fail/T13292a.hs   |  4 ++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 5 files changed, 45 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 082b2fd..107162b 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -46,6 +46,7 @@ import IfaceEnv( externaliseName )
 import TcHsType
 import TcMatches
 import Inst( deeplyInstantiate )
+import TcUnify( checkConstraints )
 import RnTypes
 import RnExpr
 import MkId
@@ -1604,14 +1605,16 @@ check_main dflags tcg_env explicit_mod_hdr
              Just main_name -> do
 
         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
-        ; let loc = srcLocSpan (getSrcLoc main_name)
+        ; let loc       = srcLocSpan (getSrcLoc main_name)
         ; ioTyCon <- tcLookupTyCon ioTyConName
         ; res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; main_expr
-                <- addErrCtxt mainCtxt    $
-                   tcMonoExpr (L loc (HsVar (L loc main_name)))
-                                            (mkCheckExpType $
-                                             mkTyConApp ioTyCon [res_ty])
+        ; let io_ty = mkTyConApp ioTyCon [res_ty]
+              skol_info = SigSkol (FunSigCtxt main_name False) io_ty
+        ; (ev_binds, main_expr)
+               <- checkConstraints skol_info [] [] $
+                  addErrCtxt mainCtxt    $
+                  tcMonoExpr (L loc (HsVar (L loc main_name)))
+                             (mkCheckExpType io_ty)
 
                 -- See Note [Root-main Id]
                 -- Construct the binding
@@ -1623,7 +1626,8 @@ check_main dflags tcg_env explicit_mod_hdr
               ; root_main_id = Id.mkExportedVanillaId root_main_name
                                                       (mkTyConApp ioTyCon [res_ty])
               ; co  = mkWpTyApps [res_ty]
-              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
+              ; rhs = mkHsDictLet ev_binds $
+                      nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
               ; main_bind = mkVarBind root_main_id rhs }
 
         ; return (tcg_env { tcg_main  = Just main_name,
diff --git a/testsuite/tests/typecheck/should_fail/T13292.hs b/testsuite/tests/typecheck/should_fail/T13292.hs
new file mode 100644
index 0000000..efc71b6
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13292.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import T13292a
+
+-- main :: IO ()
+main = someFunc
diff --git a/testsuite/tests/typecheck/should_fail/T13292.stderr b/testsuite/tests/typecheck/should_fail/T13292.stderr
new file mode 100644
index 0000000..5d8ccd1
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13292.stderr
@@ -0,0 +1,23 @@
+
+T13292a.hs:4:12: warning: [-Wdeferred-type-errors (in -Wdefault)]
+    • Ambiguous type variable ‘m0’ arising from a use of ‘return’
+      prevents the constraint ‘(Monad m0)’ from being solved.
+      Relevant bindings include
+        someFunc :: m0 () (bound at T13292a.hs:4:1)
+      Probable fix: use a type annotation to specify what ‘m0’ should be.
+      These potential instances exist:
+        instance Monad IO -- Defined in ‘GHC.Base’
+        instance Monad Maybe -- Defined in ‘GHC.Base’
+        instance Monoid a => Monad ((,) a) -- Defined in ‘GHC.Base’
+        ...plus one other
+        ...plus one instance involving out-of-scope types
+        (use -fprint-potential-instances to see them all)
+    • In the expression: return ()
+      In an equation for ‘someFunc’: someFunc = return ()
+
+T13292.hs:6:1: warning: [-Wdeferred-type-errors (in -Wdefault)]
+    • Couldn't match type ‘GHC.Types.Any’ with ‘IO’
+      Expected type: IO ()
+        Actual type: GHC.Types.Any ()
+    • In the expression: main
+      When checking the type of the IO action ‘main’
diff --git a/testsuite/tests/typecheck/should_fail/T13292a.hs b/testsuite/tests/typecheck/should_fail/T13292a.hs
new file mode 100644
index 0000000..067e086
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T13292a.hs
@@ -0,0 +1,4 @@
+module T13292a( someFunc ) where
+
+--someFunc :: IO ()
+someFunc = return ()
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 94c215f..e9cad8f 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -425,3 +425,4 @@ test('T12973', normal, compile_fail, [''])
 test('StrictBinds', normal, compile_fail, [''])
 test('T13105', normal, compile_fail, [''])
 test('LevPolyBounded', normal, compile_fail, [''])
+test('T13292', normal, multimod_compile, ['T13292', '-v0 -fdefer-type-errors'])