Fix test coverage support on GHC-7.10 #785

src/Stack/Build/Coverage.hs

@@ -34,61 +34,77 @@ import           Path
 import           Path.IO
 import           Prelude                        hiding (FilePath, writeFile)
 import           Stack.Constants
+import           Stack.Package
 import           Stack.Types
 import           System.Process.Read
 import           Text.Hastache                  (htmlEscape)
 
 -- | Generates the HTML coverage report and shows a textual coverage
 -- summary.
 generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
-                  => Path Abs Dir -> Text -> Text -> Text -> m ()
-generateHpcReport pkgDir pkgName pkgId testName = do
-    let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""
-    -- Compute destination directory.
-    installDir <- installationRootLocal
-    testNamePath <- parseRelDir (T.unpack testName)
-    pkgIdPath <- parseRelDir (T.unpack pkgId)
-    let destDir = installDir </> hpcDirSuffix </> pkgIdPath </> testNamePath
-    -- Directories for .mix files.
-    hpcDir <- hpcDirFromDir pkgDir
-    hpcRelDir <- (</> dotHpc) <$> hpcRelativeDir
-    -- Compute arguments used for both "hpc markup" and "hpc report".
-    pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig
-    let args =
-            -- Use index files from all packages (allows cross-package
-            -- coverage results).
-            concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs ++
-            -- Look for index files in the correct dir (relative to
-            -- each pkgdir).
-            ["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"
-            -- Restrict to just the current library code (see #634 -
-            -- this will likely be customizable in the future)
-            ,"--include", T.unpack (pkgId <> ":")]
-    -- If a .tix file exists, generate an HPC report for it.
-    tixFile <- parseRelFile (T.unpack testName ++ ".tix")
-    let tixFileAbs = hpcDir </> tixFile
-    tixFileExists <- fileExists tixFileAbs
-    if not tixFileExists
-        then $logError $ T.concat
-            [ "Didn't find .tix coverage file for "
-            , whichTest
-            , " - expected to find it at "
-            , T.pack (toFilePath tixFileAbs)
-            , "."
-            ]
-        else (`onException` $logError ("Error occurred while producing coverage report for " <> whichTest)) $ do
-            menv <- getMinimalEnvOverride
-            $logInfo $ "Generating HTML coverage report for " <> whichTest
-            _ <- readProcessStdout (Just hpcDir) menv "hpc"
-                ("markup" : toFilePath tixFileAbs : ("--destdir=" ++ toFilePath destDir) : args)
-            output <- readProcessStdout (Just hpcDir) menv "hpc"
-                ("report" : toFilePath tixFileAbs : args)
-            -- Print output, stripping @\r@ characters because
-            -- Windows.
-            forM_ (S8.lines output) ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))
-            $logInfo
-                ("The HTML coverage report for " <> whichTest <> " is available at " <>
-                 T.pack (toFilePath (destDir </> $(mkRelFile "hpc_index.html"))))
+                  => Path Abs Dir -> Package -> [Text] -> (PackageName -> m (Maybe Text)) -> m ()
+generateHpcReport pkgDir package tests getGhcPkgKey = do
+    -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a
+    -- ghc package key. See
+    -- https://github.com/commercialhaskell/stack/issues/785
+    let pkgName = packageNameText (packageName package)
+        pkgId = packageIdentifierString (packageIdentifier package)
+    compilerVersion <- asks (envConfigCompilerVersion . getEnvConfig)
+    includeName <-
+        if getGhcVersion compilerVersion < $(mkVersion "7.10")
+            then return pkgId
+            else do
+                mghcPkgKey <- getGhcPkgKey (packageName package)
+                case mghcPkgKey of
+                    Nothing -> fail $ "Before computing test coverage report, failed to find GHC package key for " ++ T.unpack pkgName
+                    Just ghcPkgKey -> return $ T.unpack ghcPkgKey
+    forM_ tests $ \testName -> do
+        let whichTest = pkgName <> "'s test-suite \"" <> testName <> "\""
+        -- Compute destination directory.
+        installDir <- installationRootLocal
+        testNamePath <- parseRelDir (T.unpack testName)
+        pkgIdPath <- parseRelDir pkgId
+        let destDir = installDir </> hpcDirSuffix </> pkgIdPath </> testNamePath
+        -- Directories for .mix files.
+        hpcDir <- hpcDirFromDir pkgDir
+        hpcRelDir <- (</> dotHpc) <$> hpcRelativeDir
+        -- Compute arguments used for both "hpc markup" and "hpc report".
+        pkgDirs <- Map.keys . envConfigPackages <$> asks getEnvConfig
+        let args =
+                -- Use index files from all packages (allows cross-package
+                -- coverage results).
+                concatMap (\x -> ["--srcdir", toFilePath x]) pkgDirs ++
+                -- Look for index files in the correct dir (relative to
+                -- each pkgdir).
+                ["--hpcdir", toFilePath hpcRelDir, "--reset-hpcdirs"
+                -- Restrict to just the current library code (see #634 -
+                -- this will likely be customizable in the future)
+                ,"--include", includeName ++ ":"]
+        -- If a .tix file exists, generate an HPC report for it.
+        tixFile <- parseRelFile (T.unpack testName ++ ".tix")
+        let tixFileAbs = hpcDir </> tixFile
+        tixFileExists <- fileExists tixFileAbs
+        if not tixFileExists
+            then $logError $ T.concat
+                [ "Didn't find .tix coverage file for "
+                , whichTest
+                , " - expected to find it at "
+                , T.pack (toFilePath tixFileAbs)
+                , "."
+                ]
+            else (`onException` $logError ("Error occurred while producing coverage report for " <> whichTest)) $ do
+                menv <- getMinimalEnvOverride
+                $logInfo $ "Generating HTML coverage report for " <> whichTest
+                _ <- readProcessStdout (Just hpcDir) menv "hpc"
+                    ("markup" : toFilePath tixFileAbs : ("--destdir=" ++ toFilePath destDir) : args)
+                output <- readProcessStdout (Just hpcDir) menv "hpc"
+                    ("report" : toFilePath tixFileAbs : args)
+                -- Print output, stripping @\r@ characters because
+                -- Windows.
+                forM_ (S8.lines output) ($logInfo . T.decodeUtf8 . S8.filter (not . (=='\r')))
+                $logInfo
+                    ("The HTML coverage report for " <> whichTest <> " is available at " <>
+                     T.pack (toFilePath (destDir </> $(mkRelFile "hpc_index.html"))))
 
 generateHpcMarkupIndex :: (MonadIO m,MonadReader env m,MonadLogger m,MonadCatch m,HasEnvConfig env)
                        => m ()

src/Stack/Build/Execute.hs

@@ -1133,10 +1133,13 @@ singleTest runInBase topts lptb ac ee task installedMap = do
                             ]
                         return $ Map.singleton testName Nothing
 
-            when needHpc $ forM_ testsToRun $ \testName -> do
-                let pkgName = packageNameText (packageName package)
-                    pkgId = packageIdentifierText (packageIdentifier package)
-                generateHpcReport pkgDir pkgName pkgId testName
+            when needHpc $ do
+                wc <- getWhichCompiler
+                let pkgDbs =
+                        [ bcoSnapDB (eeBaseConfigOpts ee)
+                        , bcoLocalDB (eeBaseConfigOpts ee)
+                        ]
+                generateHpcReport pkgDir package testsToRun (findGhcPkgKey (eeEnvOverride ee) wc pkgDbs)
 
             bs <- liftIO $
                 case mlogFile of

src/Stack/GhcPkg.hs

@@ -11,6 +11,7 @@
 
 module Stack.GhcPkg
   (findGhcPkgId
+  ,findGhcPkgKey
   ,getGlobalDB
   ,EnvOverride
   ,envHelper
@@ -146,6 +147,18 @@ findGhcPkgId menv wc pkgDbs name = do
         Just !pid -> return (parseGhcPkgId (T.encodeUtf8 pid))
         _ -> return Nothing
 
+-- | Get the package key e.g. @foo_9bTCpMF7G4UFWJJvtDrIdB@.
+--
+-- NOTE: GHC > 7.10 only! Will always yield 'Nothing' otherwise.
+findGhcPkgKey :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
+             => EnvOverride
+             -> WhichCompiler
+             -> [Path Abs Dir] -- ^ package databases
+             -> PackageName
+             -> m (Maybe Text)
+findGhcPkgKey menv wc pkgDbs name =
+    findGhcPkgField menv wc pkgDbs (packageNameString name) "key"
+
 -- | Get the version of the package
 findGhcPkgVersion :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m, MonadThrow m)
                   => EnvOverride