Fix for recover with -fexternal-interpreter (#15418)
authorSimon Marlow <marlowsd@gmail.com>
Wed, 26 Sep 2018 20:32:29 +0000 (15:32 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sat, 13 Oct 2018 17:26:18 +0000 (13:26 -0400)
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

(cherry picked from commit d00c308633fe7d216d31a1087e00e63532d87d6d)

compiler/typecheck/TcSplice.hs
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/TH.hs
testsuite/tests/th/T15481.hs [new file with mode: 0644]
testsuite/tests/th/T15481.stderr [new file with mode: 0644]
testsuite/tests/th/TH_recover_warns.hs [new file with mode: 0644]
testsuite/tests/th/TH_recover_warns.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index 31695e3..737ddcc 100644 (file)
@@ -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
@@ -1039,13 +1040,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
@@ -1067,21 +1070,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
@@ -1138,6 +1147,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]]
index 3f0bad9..7ae1614 100644 (file)
@@ -245,6 +245,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).
@@ -275,9 +276,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
@@ -299,10 +301,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
index aebc32c..858e556 100644 (file)
@@ -105,6 +105,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
@@ -169,13 +170,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 (file)
index 0000000..0d9931d
--- /dev/null
@@ -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 (file)
index 0000000..69a8c7b
--- /dev/null
@@ -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 (file)
index 0000000..9d11539
--- /dev/null
@@ -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 (file)
index 0000000..c92ee71
--- /dev/null
@@ -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
index 55452b5..6e56446 100644 (file)
@@ -423,3 +423,5 @@ test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15481', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])