Commit 231a3ae1 authored by Facundo Domínguez's avatar Facundo Domínguez Committed by Ben Gamari

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
parent 04b024a9
......@@ -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]
......
......@@ -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
......
......@@ -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))
......
-- 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 () |]
)
......@@ -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'])
......
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