Commit e7c12cda authored by Facundo Domínguez's avatar Facundo Domínguez Committed by Ben Gamari
Browse files

Have reify work for local variables with functional dependencies.

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

(cherry picked from commit 231a3ae1)
parent 18d04a87
......@@ -476,9 +476,8 @@ tcRnSrcDecls :: Bool -- False => no 'module M(..) where' header at all
-- Reason: solely to report unused imports and bindings
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
; tcg_env <- setEnvs (tcg_env, tcl_env) $
checkMain explicit_mod_hdr
......@@ -490,13 +489,6 @@ tcRnSrcDecls explicit_mod_hdr decls
; setGblEnv tcg_env $ do {
#ifdef GHCI
; finishTH
#endif /* GHCI */
-- wanted constraints from static forms
; stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef
-- Finish simplifying class constraints
--
-- simplifyTop deals with constant or ambiguous InstIds.
......@@ -512,7 +504,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
......@@ -548,6 +550,9 @@ tcRnSrcDecls explicit_mod_hdr decls
; setGlobalTypeEnv tcg_env' final_type_env
#ifdef GHCI
}
#endif /* GHCI */
} } }
#ifdef GHCI
......@@ -561,14 +566,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]
......
......@@ -96,7 +96,7 @@ module TcRnMonad(
getConstraintVar, setConstraintVar,
emitConstraints, emitSimple, emitSimples,
emitImplication, emitImplications, emitInsoluble,
discardConstraints, captureConstraints,
discardConstraints, captureConstraints, captureTopConstraints,
pushLevelAndCaptureConstraints,
pushTcLevelM_, pushTcLevelM,
getTcLevel, setTcLevel, isTouchableTcM,
......@@ -1437,6 +1437,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
......
-- 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 () |]
)
......@@ -76,6 +76,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'])
......
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