Consider calls to and co after RPC exception (#253)

fpco · Sep 13, 2014 · f89ae08 · f89ae08
1 parent deb1331
commit f89ae08
Show file tree

Hide file tree

Showing 3 changed files with 60 additions and 22 deletions.
diff --git a/IdeSession/Update/ExecuteSessionUpdate.hs b/IdeSession/Update/ExecuteSessionUpdate.hs
@@ -644,7 +644,7 @@ executeBuildExe extraOpts ms = do
       if any (== KindError) $ map errorKind errors then do
         exceptionFree $ do
           writeFile beStderrLog
-            "Source errors encountered. Not attempting to build executables."
+            "Source or other errors encountered. Not attempting to build executables."
           return $ ExitFailure 1
       else do
         let ghcOpts' = "-rtsopts=some" : ghcOpts ++ extraOpts
@@ -698,7 +698,17 @@ executeBuildDoc = do
     exceptionFree $ Dir.createDirectoryIfMissing False $ ideDistDir </> "doc"
     let beStdoutLog = ideDistDir </> "doc/ide-backend-doc.stdout"
         beStderrLog = ideDistDir </> "doc/ide-backend-doc.stderr"
-    exitCode <- exceptionFree $ do
+        errors = case toLazyMaybe mcomputed of
+          Nothing ->
+            error "This session state does not admit artifact generation."
+          Just Computed{computedErrors} -> toLazyList computedErrors
+    exitCode <-
+      if any (== KindError) $ map errorKind errors then do
+        exceptionFree $ do
+          writeFile beStderrLog
+            "Source or other errors encountered. Not attempting to build documentation."
+          return $ ExitFailure 1
+      else exceptionFree $ do
                   (loadedMs, pkgs) <- buildDeps mcomputed
                   libDeps <- externalDeps pkgs
                   let beArgs =
@@ -731,20 +741,30 @@ executeBuildLicenses cabalsDir = do
       fail "Features using cabal API require configGenerateModInfo, currently (#86)."
     let liStdoutLog = ideDistDir </> "licenses.stdout"  -- progress
         liStderrLog = ideDistDir </> "licenses.stderr"  -- warnings and errors
-    exitCode <- exceptionFree $ do
-      (_, pkgs) <- buildDeps mcomputed
-      let liArgs =
-            LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig
-                       , liExtraPathDirs = configExtraPathDirs ideConfig
-                       , liLicenseExc = configLicenseExc ideConfig
-                       , liDistDir = ideDistDir
-                       , liStdoutLog
-                       , liStderrLog
-                       , licenseFixed = configLicenseFixed ideConfig
-                       , liCabalsDir = cabalsDir
-                       , liPkgs = pkgs
-                       }
-      invokeExeCabal ideStaticInfo (ReqExeLic liArgs) callback
+        errors = case toLazyMaybe mcomputed of
+          Nothing ->
+            error "This session state does not admit artifact generation."
+          Just Computed{computedErrors} -> toLazyList computedErrors
+    exitCode <-
+      if any (== KindError) $ map errorKind errors then do
+        exceptionFree $ do
+          writeFile liStderrLog
+            "Source or other errors encountered. Not attempting to build licenses."
+          return $ ExitFailure 1
+      else exceptionFree $ do
+        (_, pkgs) <- buildDeps mcomputed
+        let liArgs =
+              LicenseArgs{ liPackageDBStack = configPackageDBStack ideConfig
+                         , liExtraPathDirs = configExtraPathDirs ideConfig
+                         , liLicenseExc = configLicenseExc ideConfig
+                         , liDistDir = ideDistDir
+                         , liStdoutLog
+                         , liStderrLog
+                         , licenseFixed = configLicenseFixed ideConfig
+                         , liCabalsDir = cabalsDir
+                         , liPkgs = pkgs
+                         }
+        invokeExeCabal ideStaticInfo (ReqExeLic liArgs) callback
     Acc.set ideBuildLicensesStatus (Just exitCode)
 
 {-------------------------------------------------------------------------------

diff --git a/TestSuite/TestSuite/Tests/BuildExe.hs b/TestSuite/TestSuite/Tests/BuildExe.hs
@@ -280,7 +280,7 @@ test_typeErrors env = withAvailableSession env $ \session -> do
     status <- getBuildExeStatus session
     assertEqual "" (Just $ ExitFailure 1) status
     buildStderr <- readFile $ distDir </> "build/ide-backend-exe.stderr"
-    assertEqual "" "Source errors encountered. Not attempting to build executables." buildStderr
+    assertEqual "" "Source or other errors encountered. Not attempting to build executables." buildStderr
   where
     upd1 = (updateCodeGeneration True)
         <> (updateSourceFile "Main.hs" "main = foo")

diff --git a/TestSuite/TestSuite/Tests/BuildLicenses.hs b/TestSuite/TestSuite/Tests/BuildLicenses.hs
@@ -16,7 +16,8 @@ import TestSuite.Assertions
 
 testGroupBuildLicenses :: TestSuiteEnv -> TestTree
 testGroupBuildLicenses env = testGroup "Build licenses" [
-    stdTest env "Build licenses from NamedFieldPuns (with errors)"                       test_NamedFieldPuns
+    stdTest env "Build licenses from NamedFieldPuns without errors"                      test_NamedFieldPunsCorrect
+  , stdTest env "Build licenses from NamedFieldPuns (with errors)"                       test_NamedFieldPunsErrors
   , stdTest env "Build licenses with wrong cabal files and fail"                         test_wrongCabalFile
   , stdTest env "Build licenses from ParFib"                                             test_ParFib
   , stdTest env "Build licenses from Cabal"                                              test_Cabal
@@ -25,14 +26,17 @@ testGroupBuildLicenses env = testGroup "Build licenses" [
   , stdTest env "Build licenses from TH with a wrong cabals dir and don't fail"          test_TH
   ]
 
-test_NamedFieldPuns :: TestSuiteEnv -> Assertion
-test_NamedFieldPuns env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do
+test_NamedFieldPunsCorrect :: TestSuiteEnv -> Assertion
+test_NamedFieldPunsCorrect env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do
+    let punOpts = ["-XNamedFieldPuns", "-XRecordWildCards"]
+        update2 = updateGhcOpts punOpts
+    updateSessionD session update2 0
     loadModulesFrom session "test/Puns"
-    assertMoreErrors session
+    assertNoErrors session
     cabalsPath <- canonicalizePath "test/Puns/cabals"
     let upd = buildLicenses cabalsPath
     updateSessionD session upd 99
-    assertMoreErrors session
+    assertNoErrors session
     distDir <- getDistDir session
     licensesWarns <- readFile $ distDir </> "licenses.stderr"
     assertEqual "licensesWarns length" 3 (length $ lines licensesWarns)
@@ -41,6 +45,20 @@ test_NamedFieldPuns env = withAvailableSession' env (withGhcOpts ["-hide-package
     licenses <- readFile $ distDir </> "licenses.txt"
     assertBool "licenses length" $ length licenses >= 27142
 
+test_NamedFieldPunsErrors :: TestSuiteEnv -> Assertion
+test_NamedFieldPunsErrors env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do
+    loadModulesFrom session "test/Puns"
+    assertMoreErrors session
+    cabalsPath <- canonicalizePath "test/Puns/cabals"
+    let upd = buildLicenses cabalsPath
+    updateSessionD session upd 99
+    assertMoreErrors session
+    distDir <- getDistDir session
+    licensesWarns <- readFile $ distDir </> "licenses.stderr"
+    assertEqual "licensesError length" 1 (length $ lines licensesWarns)
+    status <- getBuildLicensesStatus session
+    assertEqual "after license build" (Just $ ExitFailure 1) status
+
 test_wrongCabalFile :: TestSuiteEnv -> Assertion
 test_wrongCabalFile env = withAvailableSession' env (withGhcOpts ["-hide-package monads-tf"]) $ \session -> do
     loadModulesFrom session "test/Puns"