Gather constraints locally in checkMain
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 21 Feb 2017 15:53:06 +0000 (15:53 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Tue, 21 Feb 2017 17:43:36 +0000 (17:43 +0000)
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

compiler/typecheck/TcRnDriver.hs
testsuite/tests/typecheck/should_fail/T13292.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13292.stderr [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/T13292a.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_fail/all.T

index 082b2fd..107162b 100644 (file)
@@ -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 (file)
index 0000000..efc71b6
--- /dev/null
@@ -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 (file)
index 0000000..5d8ccd1
--- /dev/null
@@ -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 (file)
index 0000000..067e086
--- /dev/null
@@ -0,0 +1,4 @@
+module T13292a( someFunc ) where
+
+--someFunc :: IO ()
+someFunc = return ()
index 94c215f..e9cad8f 100644 (file)
@@ -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'])