Parse package key out of package.conf.inplace #785

commercialhaskell · Oct 15, 2015 · e26dc62 · e26dc62
1 parent 956489f
commit e26dc62
Show file tree

Hide file tree

Showing 3 changed files with 14 additions and 24 deletions.
diff --git a/src/Stack/Build/Coverage.hs b/src/Stack/Build/Coverage.hs
@@ -20,7 +20,7 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader           (MonadReader, asks)
 import           Control.Monad.Trans.Resource
 import qualified Data.ByteString.Char8          as S8
-import           Data.Foldable                  (forM_)
+import           Data.Foldable                  (forM_, asum)
 import           Data.Function
 import           Data.List
 import qualified Data.Map.Strict                as Map
@@ -69,8 +69,8 @@ tixFilePath pkgId tixName = do
 -- | Generates the HTML coverage report and shows a textual coverage
 -- summary for a package.
 generateHpcReport :: (MonadIO m,MonadReader env m,HasConfig env,MonadLogger m,MonadBaseControl IO m,MonadCatch m,HasEnvConfig env)
-                  => Package -> [Text] -> (PackageName -> m (Maybe Text)) -> m ()
-generateHpcReport package tests getGhcPkgKey = do
+                  => Path Abs Dir -> Package -> [Text] -> m ()
+generateHpcReport pkgDir package tests = 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
@@ -81,7 +81,7 @@ generateHpcReport package tests getGhcPkgKey = do
         if getGhcVersion compilerVersion < $(mkVersion "7.10")
             then return pkgId
             else do
-                mghcPkgKey <- getGhcPkgKey (packageName package)
+                mghcPkgKey <- findPackageKeyForBuiltPackage pkgDir (packageIdentifier 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
@@ -257,3 +257,12 @@ generateHpcMarkupIndex = do
 
 pathToHtml :: Path b t -> Text
 pathToHtml = T.dropWhileEnd (=='/') . LT.toStrict . htmlEscape . LT.pack . toFilePath
+
+findPackageKeyForBuiltPackage :: (MonadIO m, MonadReader env m, MonadThrow m, HasEnvConfig env)
+                              => Path Abs Dir -> PackageIdentifier -> m (Maybe Text)
+findPackageKeyForBuiltPackage pkgDir pkgId = do
+    distDir <- distDirFromDir pkgDir
+    path <- liftM (distDir </>) $
+        parseRelFile ("package.conf.inplace/" ++ packageIdentifierString pkgId ++ "-inplace.conf")
+    contents <- liftIO $ T.readFile (toFilePath path)
+    return $ asum (map (T.stripPrefix "key: ") (T.lines contents))
diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs
@@ -1192,13 +1192,7 @@ singleTest runInBase topts lptb ac ee task installedMap = do
                             ]
                         return $ Map.singleton testName Nothing
 
-            when needHpc $ do
-                wc <- getWhichCompiler
-                let pkgDbs =
-                        [ bcoSnapDB (eeBaseConfigOpts ee)
-                        , bcoLocalDB (eeBaseConfigOpts ee)
-                        ]
-                generateHpcReport package testsToRun (findGhcPkgKey (eeEnvOverride ee) wc pkgDbs)
+            when needHpc $ generateHpcReport pkgDir package testsToRun
 
             bs <- liftIO $
                 case mlogFile of

diff --git a/src/Stack/GhcPkg.hs b/src/Stack/GhcPkg.hs
@@ -11,7 +11,6 @@
 
 module Stack.GhcPkg
   (findGhcPkgId
-  ,findGhcPkgKey
   ,getGlobalDB
   ,EnvOverride
   ,envHelper
@@ -147,18 +146,6 @@ 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