Have reify work for local variables with functional dependencies.
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Thu, 17 Nov 2016 15:04:13 +0000 (10:04 -0500)
committerBen Gamari <ben@smart-cactus.org>
Thu, 17 Nov 2016 16:04:02 +0000 (11:04 -0500)
It turned out that finalizers were run too early and information
resulting from simplifying constraints was not available.

This patch runs finalizers after a first call to simplifyTop, and
then calls simplifyTop a second time to deal with constraints
that could result from running the finalizers.

Fixes T12777

Test Plan: ./validate

Reviewers: goldfire, simonpj, bgamari, austin

Reviewed By: simonpj

Subscribers: mpickering, mboes, thomie

Differential Revision: https://phabricator.haskell.org/D2659

GHC Trac Issues: #12777

compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
testsuite/tests/th/TH_reifyLocalDefs2.hs [new file with mode: 0644]
testsuite/tests/th/TH_reifyLocalDefs2.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index 1a6a0cc..65447e3 100644 (file)
@@ -366,9 +366,8 @@ tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all
              -> TcM TcGblEnv
 tcRnSrcDecls explicit_mod_hdr decls
  = do { -- Do all the declarations
-      ; ((tcg_env, tcl_env), lie) <- captureConstraints $
-              do { envs <- tc_rn_src_decls decls
-                 ; (tcg_env, tcl_env) <- setEnvs envs run_th_modfinalizers
+      ; ((tcg_env, tcl_env), lie) <- captureTopConstraints $
+              do { (tcg_env, tcl_env) <- tc_rn_src_decls decls
 
                    -- Check for the 'main' declaration
                    -- Must do this inside the captureConstraints
@@ -381,13 +380,6 @@ tcRnSrcDecls explicit_mod_hdr decls
 
       ; setEnvs (tcg_env, tcl_env) $ do {
 
-#ifdef GHCI
-      ; finishTH
-#endif /* GHCI */
-
-        -- wanted constraints from static forms
-      ; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
-
              --         Simplify constraints
              --
              -- We do this after checkMain, so that we use the type info
@@ -398,7 +390,17 @@ tcRnSrcDecls explicit_mod_hdr decls
              --  * the local env exposes the local Ids to simplifyTop,
              --    so that we get better error messages (monomorphism restriction)
       ; new_ev_binds <- {-# SCC "simplifyTop" #-}
-                        simplifyTop (andWC stWC lie)
+                        simplifyTop lie
+
+#ifdef GHCI
+        -- 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
+      ; setEnvs (tcg_env, tcl_env) $ do {
+
+      ; finishTH
+#endif /* GHCI */
+
       ; traceTc "Tc9" empty
 
       ; failIfErrsM     -- Don't zonk if there have been errors
@@ -434,6 +436,9 @@ tcRnSrcDecls explicit_mod_hdr decls
 
       ; setGlobalTypeEnv tcg_env' final_type_env
 
+#ifdef GHCI
+   }
+#endif /* GHCI */
    } }
 
 #ifdef GHCI
@@ -447,14 +452,21 @@ run_th_modfinalizers = do
   then getEnvs
   else do
     writeTcRef th_modfinalizers_var []
-    sequence_ th_modfinalizers
-    -- Finalizers can add top-level declarations with addTopDecls.
-    envs <- tc_rn_src_decls []
-    -- addTopDecls can add declarations which add new finalizers.
-    setEnvs envs run_th_modfinalizers
-#else
-run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)
-run_th_modfinalizers = getEnvs
+    (envs, lie) <- captureTopConstraints $ do
+      sequence_ th_modfinalizers
+      -- Finalizers can add top-level declarations with addTopDecls.
+      tc_rn_src_decls []
+    setEnvs envs $ do
+      -- Subsequent rounds of finalizers run after any new constraints are
+      -- simplified, or some types might not be complete when using reify
+      -- (see #12777).
+      new_ev_binds <- {-# SCC "simplifyTop2" #-}
+                      simplifyTop lie
+      updGblEnv (\tcg_env ->
+        tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env `unionBags` new_ev_binds }
+        )
+        -- addTopDecls can add declarations which add new finalizers.
+        run_th_modfinalizers
 #endif /* GHCI */
 
 tc_rn_src_decls :: [LHsDecl RdrName]
index b958cf8..eea8dd5 100644 (file)
@@ -95,7 +95,7 @@ module TcRnMonad(
   getConstraintVar, setConstraintVar,
   emitConstraints, emitSimple, emitSimples,
   emitImplication, emitImplications, emitInsoluble,
-  discardConstraints, captureConstraints,
+  discardConstraints, captureConstraints, captureTopConstraints,
   pushLevelAndCaptureConstraints,
   pushTcLevelM_, pushTcLevelM,
   getTcLevel, setTcLevel, isTouchableTcM,
@@ -1477,6 +1477,18 @@ captureConstraints thing_inside
                            ; 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
index 9c4bc75..02c9c09 100644 (file)
@@ -635,12 +635,35 @@ data TcGblEnv
         -- ^ The RealSrcSpan this module came from
 
         tcg_static_wc :: TcRef WantedConstraints
-          -- ^ Wanted constraints of static forms.
+        -- ^ Wanted constraints of static forms.
+        -- See Note [Constraints in static forms].
     }
 
 -- NB: topModIdentity, not topModSemantic!
 -- Definition sites of orphan identities will be identity modules, not semantic
 -- modules.
+
+-- Note [Constraints in static forms]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- When a static form produces constraints like
+--
+-- f :: StaticPtr (Bool -> String)
+-- f = static show
+--
+-- we collect them in tcg_static_wc and resolve them at the end
+-- of type checking. They need to be resolved separately because
+-- we don't want to resolve them in the context of the enclosing
+-- expression. Consider
+--
+-- g :: Show a => StaticPtr (a -> String)
+-- g = static show
+--
+-- If the @Show a0@ constraint that the body of the static form produces was
+-- resolved in the context of the enclosing expression, then the body of the
+-- static form wouldn't be closed because the Show dictionary would come from
+-- g's context instead of coming from the top level.
+
 tcVisibleOrphanMods :: TcGblEnv -> ModuleSet
 tcVisibleOrphanMods tcg_env
     = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env))
diff --git a/testsuite/tests/th/TH_reifyLocalDefs2.hs b/testsuite/tests/th/TH_reifyLocalDefs2.hs
new file mode 100644 (file)
index 0000000..06564eb
--- /dev/null
@@ -0,0 +1,24 @@
+-- Tests that a complete type is yielded by reify for local definitions,
+-- even when using functional dependencies which are resolved at the very end of
+-- type checking.
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module TH_reifyLocalDefs2 where
+import Language.Haskell.TH as TH
+import Language.Haskell.TH.Syntax as TH
+import System.IO
+
+class C a b | a -> b where
+  yo :: a -> IO b
+
+instance C Bool Int where
+  yo _ = return 0
+
+t3 :: IO ()
+t3 = do
+  x <- yo True
+  $(do addModFinalizer $ do
+         VarI _ t _ <- TH.reify 'x
+         runIO $ hPutStrLn stderr $ show t
+       [| return () |]
+   )
diff --git a/testsuite/tests/th/TH_reifyLocalDefs2.stderr b/testsuite/tests/th/TH_reifyLocalDefs2.stderr
new file mode 100644 (file)
index 0000000..e1b28ad
--- /dev/null
@@ -0,0 +1 @@
+ConT GHC.Types.Int
index e0a97fa..4f66960 100644 (file)
@@ -82,6 +82,7 @@ test('TH_spliceD2',
 test('TH_reifyDecl1', normal, compile, ['-v0'])
 test('TH_reifyDecl2', normal, compile, ['-v0'])
 test('TH_reifyLocalDefs', normal, compile, ['-v0'])
+test('TH_reifyLocalDefs2', normal, compile, ['-v0'])
 
 test('TH_reifyMkName', normal, compile, ['-v0'])