summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/typecheck/TcSplice.hs28
-rw-r--r--libraries/ghci/GHCi/Message.hs17
-rw-r--r--libraries/ghci/GHCi/TH.hs13
-rw-r--r--testsuite/tests/th/T15481.hs10
-rw-r--r--testsuite/tests/th/T15481.stderr8
-rw-r--r--testsuite/tests/th/TH_recover_warns.hs10
-rw-r--r--testsuite/tests/th/TH_recover_warns.stderr15
-rw-r--r--testsuite/tests/th/all.T2
8 files changed, 81 insertions, 22 deletions
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index c26ba0d90b..8f0522553b 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -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]]
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 012dd884ba..bc0a19ca62 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -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
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 5779b5073e..04c5fcffcc 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -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)
diff --git a/testsuite/tests/th/T15481.hs b/testsuite/tests/th/T15481.hs
new file mode 100644
index 0000000000..0d9931d0df
--- /dev/null
+++ b/testsuite/tests/th/T15481.hs
@@ -0,0 +1,10 @@
+{-# 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"))
diff --git a/testsuite/tests/th/T15481.stderr b/testsuite/tests/th/T15481.stderr
new file mode 100644
index 0000000000..69a8c7b0e7
--- /dev/null
+++ b/testsuite/tests/th/T15481.stderr
@@ -0,0 +1,8 @@
+T15481.hs:(7,19)-(10,63): Splicing expression
+ recover
+ (stringE "reifyFixity failed")
+ (do foo <- newName "foo"
+ _ <- reifyFixity foo
+ stringE "reifyFixity successful")
+ ======>
+ "reifyFixity failed"
diff --git a/testsuite/tests/th/TH_recover_warns.hs b/testsuite/tests/th/TH_recover_warns.hs
new file mode 100644
index 0000000000..9d1153930e
--- /dev/null
+++ b/testsuite/tests/th/TH_recover_warns.hs
@@ -0,0 +1,10 @@
+{-# 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 |])
diff --git a/testsuite/tests/th/TH_recover_warns.stderr b/testsuite/tests/th/TH_recover_warns.stderr
new file mode 100644
index 0000000000..c92ee71bc9
--- /dev/null
+++ b/testsuite/tests/th/TH_recover_warns.stderr
@@ -0,0 +1,15 @@
+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
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 9a25591937..948c7db8d7 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -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'])
View Lorry Controller Status