Support detailed-0.9 tests #1429

ChangeLog.md

@@ -17,6 +17,8 @@ Other enhancements:
 * Support git-style executable fall-through (`stack something` executes
   `stack-something` if present)
   [#1433](https://github.com/commercialhaskell/stack/issues/1433)
+* Support `detailed-0.9` tests
+  [#1429](https://github.com/commercialhaskell/stack/issues/1429)
 
 Bug fixes:
 

src/Stack/Build/Execute.hs

@@ -56,6 +56,7 @@ import           Data.Text.Encoding (decodeUtf8)
 import           Data.Time.Clock (getCurrentTime)
 import           Data.Traversable (forM)
 import           Data.Word8 (_colon)
+import qualified Distribution.PackageDescription as C
 import           Distribution.System            (OS (Windows),
                                                  Platform (Platform))
 import           Language.Haskell.TH as TH (location)
@@ -1171,15 +1172,23 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
             buildDir <- distDirFromDir pkgDir
             hpcDir <- hpcDirFromDir pkgDir
             when needHpc (createTree hpcDir)
+
             let exeExtension =
                     case configPlatform $ getConfig bconfig of
                         Platform _ Windows -> ".exe"
                         _ -> ""
 
-            errs <- liftM Map.unions $ forM testsToRun $ \testName -> do
-                nameDir <- parseRelDir $ T.unpack testName
-                nameExe <- parseRelFile $ T.unpack testName ++ exeExtension
-                nameTix <- liftM (pkgDir </>) $ parseRelFile $ T.unpack testName ++ ".tix"
+            errs <- liftM Map.unions $ forM (Map.toList (packageTests package)) $ \(testName, suiteInterface) -> do
+                let stestName = T.unpack testName
+                (testName', isTestTypeLib) <-
+                    case suiteInterface of
+                        C.TestSuiteLibV09{} -> return (stestName ++ "Stub", True)
+                        C.TestSuiteExeV10{} -> return (stestName, False)
+                        interface -> throwM (TestSuiteTypeUnsupported interface)
+
+                nameDir <- parseRelDir $ testName'
+                nameExe <- parseRelFile $ testName' ++ exeExtension
+                nameTix <- liftM (pkgDir </>) $ parseRelFile $ testName' ++ ".tix"
                 let exeName = buildDir </> $(mkRelDir "build") </> nameDir </> nameExe
                 exists <- fileExists exeName
                 menv <- liftIO $ configEnvOverride config EnvSettings
@@ -1218,6 +1227,10 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
 
                         -- Use createProcess_ to avoid the log file being closed afterwards
                         (Just inH, Nothing, Nothing, ph) <- liftIO $ createProcess_ "singleBuild.runTests" cp
+                        when isTestTypeLib $ do
+                            logPath <- buildLogPath package (Just stestName)
+                            createTree (parent logPath)
+                            liftIO $ hPutStr inH $ show (logPath, testName)
                         liftIO $ hClose inH
                         ec <- liftIO $ waitForProcess ph
                         -- Move the .tix file out of the package
@@ -1237,7 +1250,13 @@ singleTest runInBase topts testsToRun ac ee task installedMap = do
                             ]
                         return $ Map.singleton testName Nothing
 
-            when needHpc $ generateHpcReport pkgDir package testsToRun
+            when needHpc $ do
+                let testsToRun' = map f testsToRun
+                    f tName =
+                        case Map.lookup tName (packageTests package) of
+                            Just C.TestSuiteLibV09{} -> tName <> "Stub"
+                            _ -> tName
+                generateHpcReport pkgDir package testsToRun'
 
             bs <- liftIO $
                 case mlogFile of

src/Stack/Build/Source.hs

@@ -298,7 +298,7 @@ loadLocalPackage bopts targets (name, (lpv, gpkg)) = do
                 Just STLocalAll ->
                     ( packageExes pkg
                     , if boptsTests bopts
-                        then packageTests pkg
+                        then Map.keysSet (packageTests pkg)
                         else Set.empty
                     , if boptsBenchmarks bopts
                         then packageBenchmarks pkg
@@ -367,7 +367,7 @@ loadLocalPackage bopts targets (name, (lpv, gpkg)) = do
         -- present, then they must not be buildable.
         , lpUnbuildable = toComponents
             (exes `Set.difference` packageExes pkg)
-            (tests `Set.difference` packageTests pkg)
+            (tests `Set.difference` Map.keysSet (packageTests pkg))
             (benches `Set.difference` packageBenchmarks pkg)
         }
 

src/Stack/Ghci.hs

@@ -322,7 +322,7 @@ wantedPackageComponents _ (STLocalComps cs) _ = cs
 wantedPackageComponents bopts STLocalAll pkg = S.fromList $
     (if packageHasLibrary pkg then [CLib] else []) ++
     map CExe (S.toList (packageExes pkg)) <>
-    (if boptsTests bopts then map CTest (S.toList (packageTests pkg)) else []) <>
+    (if boptsTests bopts then map CTest (M.keys (packageTests pkg)) else []) <>
     (if boptsBenchmarks bopts then map CBench (S.toList (packageBenchmarks pkg)) else [])
 wantedPackageComponents _ _ _ = S.empty
 

src/Stack/Package.hs

@@ -196,9 +196,9 @@ resolvePackage packageConfig gpkg =
     , packageFlags = packageConfigFlags packageConfig
     , packageAllDeps = S.fromList (M.keys deps)
     , packageHasLibrary = maybe False (buildable . libBuildInfo) (library pkg)
-    , packageTests = S.fromList
-      [T.pack (testName t) | t <- testSuites pkg
-                           , buildable (testBuildInfo t)]
+    , packageTests = M.fromList
+      [(T.pack (testName t), testInterface t) | t <- testSuites pkg
+                                              , buildable (testBuildInfo t)]
     , packageBenchmarks = S.fromList
       [T.pack (benchmarkName b) | b <- benchmarks pkg
                                 , buildable (benchmarkBuildInfo b)]

src/Stack/Types/Build.hs

@@ -64,6 +64,7 @@ import           Data.Text.Encoding.Error (lenientDecode)
 import           Data.Time.Calendar
 import           Data.Time.Clock
 import           Distribution.System (Arch)
+import           Distribution.PackageDescription (TestSuiteInterface)
 import           Distribution.Text (display)
 import           GHC.Generics
 import           Path (Path, Abs, File, Dir, mkRelDir, toFilePath, parseRelDir, (</>))
@@ -99,6 +100,7 @@ data StackBuildException
     (Map PackageName Version) -- not in snapshot, here's the most recent version in the index
     (Path Abs File) -- stack.yaml
   | TestSuiteFailure PackageIdentifier (Map Text (Maybe ExitCode)) (Maybe (Path Abs File)) S.ByteString
+  | TestSuiteTypeUnsupported TestSuiteInterface
   | ConstructPlanExceptions
         [ConstructPlanException]
         (Path Abs File) -- stack.yaml
@@ -209,6 +211,8 @@ instance Show StackBuildException where
          where
           indent = dropWhileEnd isSpace . unlines . fmap (\line -> "  " ++ line) . lines
           doubleIndent = indent . indent
+    show (TestSuiteTypeUnsupported interface) =
+              ("Unsupported test suite type: " <> show interface)
     show (ConstructPlanExceptions exceptions stackYaml) =
         "While constructing the BuildPlan the following exceptions were encountered:" ++
         appendExceptions exceptions' ++
@@ -725,7 +729,7 @@ configureOptsNoDir econfig bco deps wanted isLocal package = concat
     allGhcOptions = concat
         [ Map.findWithDefault [] Nothing (configGhcOptions config)
         , Map.findWithDefault [] (Just $ packageName package) (configGhcOptions config)
-        , concat [["-fhpc", "-fforce-recomp"] | isLocal && toCoverage (boptsTestOpts bopts)]
+        , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]
         , if includeExtraOptions
             then boptsGhcOptions bopts
             else []

src/Stack/Types/Package.hs

@@ -30,6 +30,7 @@ import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import           Distribution.InstalledPackageInfo (PError)
 import           Distribution.ModuleName (ModuleName)
 import           Distribution.Package hiding (Package,PackageName,packageName,packageVersion,PackageIdentifier)
+import           Distribution.PackageDescription (TestSuiteInterface)
 import           Distribution.System (Platform (..))
 import           Distribution.Text (display)
 import           GHC.Generics
@@ -87,7 +88,7 @@ data Package =
           ,packageAllDeps :: !(Set PackageName)           -- ^ Original dependencies (not sieved).
           ,packageFlags :: !(Map FlagName Bool)           -- ^ Flags used on package.
           ,packageHasLibrary :: !Bool                     -- ^ does the package have a buildable library stanza?
-          ,packageTests :: !(Set Text)                    -- ^ names of test suites
+          ,packageTests :: !(Map Text TestSuiteInterface) -- ^ names and interfaces of test suites
           ,packageBenchmarks :: !(Set Text)               -- ^ names of benchmarks
           ,packageExes :: !(Set Text)                     -- ^ names of executables
           ,packageOpts :: !GetPackageOpts                 -- ^ Args to pass to GHC.