Commit d00c3086 authored by Simon Marlow's avatar Simon Marlow

Fix for recover with -fexternal-interpreter (#15418)

Summary:
When using -fexternal-interpreter, recover was not treating a Q
compuation that simply registered an error with addErrTc as failing.

Test Plan:
New unit tests:
* T15418 is the repro from in the ticket
* TH_recover_warns is a new test to ensure that we're keeping warnings when
  the body of recover succeeds.

Reviewers: bgamari, RyanGlScott, angerman, goldfire, erikd

Subscribers: rwbarton, carter

GHC Trac Issues: #15418

Differential Revision: https://phabricator.haskell.org/D5185
parent 1d7b61f9
......@@ -112,6 +112,7 @@ import Panic
import Lexeme
import qualified EnumSet
import Plugins
import Bag
import qualified Language.Haskell.TH as TH
-- THSyntax gives access to internal functions and data types
......@@ -1041,13 +1042,15 @@ runRemoteTH iserv recovers = do
writeTcRef v emptyMessages
runRemoteTH iserv (msgs : recovers)
EndRecover caught_error -> do
v <- getErrsVar
let (prev_msgs, rest) = case recovers of
let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of
[] -> panic "EndRecover"
a : b -> (a,b)
if caught_error
then writeTcRef v prev_msgs
else updTcRef v (unionMessages prev_msgs)
v <- getErrsVar
(warn_msgs,_) <- readTcRef v
-- keep the warnings only if there were no errors
writeTcRef v $ if caught_error
then prev_msgs
else (prev_warns `unionBags` warn_msgs, prev_errs)
runRemoteTH iserv rest
_other -> do
r <- handleTHMessage msg
......@@ -1069,21 +1072,27 @@ Recover is slightly tricky to implement.
The meaning of "recover a b" is
- Do a
- If it finished successfully, then keep the messages it generated
- If it finished with no errors, then keep the warnings it generated
- If it failed, discard any messages it generated, and do b
Note that "failed" here can mean either
(1) threw an exception (failTc)
(2) generated an error message (addErrTcM)
The messages are managed by GHC in the TcM monad, whereas the
exception-handling is done in the ghc-iserv process, so we have to
coordinate between the two.
On the server:
- emit a StartRecover message
- run "a" inside a catch
- if it finishes, emit EndRecover False
- if it fails, emit EndRecover True, then run "b"
- run "a; FailIfErrs" inside a try
- emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed
- if "a; FailIfErrs" failed, run "b"
Back in GHC, when we receive:
FailIfErrrs
failTc if there are any error messages (= failIfErrsM)
StartRecover
save the current messages and start with an empty set.
EndRecover caught_error
......@@ -1140,6 +1149,7 @@ handleTHMessage msg = case msg of
AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str
IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled
FailIfErrs -> wrapTHResult failIfErrsM
_ -> panic ("handleTHMessage: unexpected message " ++ show msg)
getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]
......
......@@ -259,6 +259,7 @@ data THMessage a where
StartRecover :: THMessage ()
EndRecover :: Bool -> THMessage ()
FailIfErrs :: THMessage (THResult ())
-- | Indicates that this RunTH is finished, and the next message
-- will be the result of RunTH (a QResult).
......@@ -289,9 +290,10 @@ getTHMessage = do
14 -> THMsg <$> return ExtsEnabled
15 -> THMsg <$> return StartRecover
16 -> THMsg <$> EndRecover <$> get
17 -> return (THMsg RunTHDone)
18 -> THMsg <$> AddModFinalizer <$> get
19 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
17 -> THMsg <$> return FailIfErrs
18 -> return (THMsg RunTHDone)
19 -> THMsg <$> AddModFinalizer <$> get
20 -> THMsg <$> (AddForeignFilePath <$> get <*> get)
_ -> THMsg <$> AddCorePlugin <$> get
putTHMessage :: THMessage a -> Put
......@@ -313,10 +315,11 @@ putTHMessage m = case m of
ExtsEnabled -> putWord8 14
StartRecover -> putWord8 15
EndRecover a -> putWord8 16 >> put a
RunTHDone -> putWord8 17
AddModFinalizer a -> putWord8 18 >> put a
AddForeignFilePath lang a -> putWord8 19 >> put lang >> put a
AddCorePlugin a -> putWord8 20 >> put a
FailIfErrs -> putWord8 17
RunTHDone -> putWord8 18
AddModFinalizer a -> putWord8 19 >> put a
AddForeignFilePath lang a -> putWord8 20 >> put lang >> put a
AddCorePlugin a -> putWord8 21 >> put a
data EvalOpts = EvalOpts
......
......@@ -106,6 +106,7 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Data
import Data.Dynamic
import Data.Either
import Data.IORef
import Data.Map (Map)
import qualified Data.Map as M
......@@ -170,13 +171,13 @@ instance TH.Quasi GHCiQ where
qReport isError msg = ghcCmd (Report isError msg)
-- See Note [TH recover with -fexternal-interpreter] in TcSplice
qRecover (GHCiQ h) (GHCiQ a) = GHCiQ $ \s -> (do
qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
remoteTHCall (qsPipe s) StartRecover
(r, s') <- a s
remoteTHCall (qsPipe s) (EndRecover False)
return (r,s'))
`catch`
\GHCiQException{} -> remoteTHCall (qsPipe s) (EndRecover True) >> h s
e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
remoteTHCall (qsPipe s) (EndRecover (isLeft e))
case e of
Left GHCiQException{} -> h s
Right r -> return r
qLookupName isType occ = ghcCmd (LookupName isType occ)
qReify name = ghcCmd (Reify name)
qReifyFixity name = ghcCmd (ReifyFixity name)
......
{-# LANGUAGE TemplateHaskell #-}
module Bug where
import Language.Haskell.TH
main :: IO ()
main = putStrLn $(recover (stringE "reifyFixity failed")
(do foo <- newName "foo"
_ <- reifyFixity foo
stringE "reifyFixity successful"))
T15481.hs:(7,19)-(10,63): Splicing expression
recover
(stringE "reifyFixity failed")
(do foo <- newName "foo"
_ <- reifyFixity foo
stringE "reifyFixity successful")
======>
"reifyFixity failed"
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
module Bug where
import Language.Haskell.TH
-- Warnings should be preserved through recover
main :: IO ()
main = putStrLn $(recover (stringE "splice failed")
[| let x = "a" in let x = "b" in x |])
TH_recover_warns.hs:(9,19)-(10,63): Splicing expression
recover
(stringE "splice failed") [| let x = "a" in let x = "b" in x |]
======>
let x = "a" in let x = "b" in x
TH_recover_warns.hs:9:19: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)]
Defined but not used: ‘x’
TH_recover_warns.hs:10:34: warning: [-Wunused-local-binds (in -Wextra, -Wunused-binds)]
Defined but not used: ‘x’
TH_recover_warns.hs:10:49: warning: [-Wname-shadowing (in -Wall)]
This binding for ‘x’ shadows the existing binding
bound at TH_recover_warns.hs:10:34
......@@ -434,3 +434,5 @@ test('TH_implicitParamsErr1', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_implicitParamsErr2', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
test('T15481', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
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