Convert reqlib tests to a head.hackage testsuite

ci/TestPatches.hs

@@ -70,6 +70,7 @@ data Config = Config { configPatchDir :: FilePath
                      , configConcurrency :: Int
                      , configExtraCabalFragments :: [FilePath]
                      , configExtraPackages :: [(Cabal.PackageName, Version)]
+                     , configTestPackages  :: [(Cabal.PackageName, FilePath)]
                      , configExpectedBrokenPkgs :: BrokenPackages
                      , configBuildToolPkgs :: BuildToolPackages
                      }
@@ -91,6 +92,7 @@ config =
     <*> concurrency
     <*> extraCabalFragments
     <*> extraPackages
+    <*> testPackages
     <*> expectedBrokenPkgs
     <*> buildToolPkgs
   where
@@ -104,6 +106,7 @@ config =
     concurrency = option auto (short 'j' <> long "concurrency" <> value 1 <> help "number of concurrent builds")
     extraCabalFragments = many $ option str (long "extra-cabal-fragment" <> help "path of extra configuration to include in cabal project files")
     extraPackages = many $ option pkgVer (short 'P' <> long "extra-package" <> help "other, un-patched packages to test")
+    testPackages = many $ option pkgNamePath (short 'T' <> long "test-package" <> help "A package to run tests for")
     expectedBrokenPkgs =
       fmap (BrokenPackages . S.fromList) $ many
       $ option
@@ -128,6 +131,19 @@ config =
               , "expected to be in form of PKG_NAME==VERSION"
               ]
 
+
+    pkgNamePath :: ReadM (Cabal.PackageName, FilePath)
+    pkgNamePath = str >>= parse . T.pack
+      where
+        parse s
+          | [name, fp] <- T.splitOn "=" s
+          = pure (Cabal.mkPackageName $ T.unpack name, T.unpack fp)
+          | otherwise
+          = fail $ unlines
+              [ "Invalid test package specified:"
+              , "expected to be in form of PKG_NAME=FILEPATH"
+              ]
+
     pkgName :: ReadM Cabal.PackageName
     pkgName = str >>= maybe (fail "invalid package name") pure . simpleParse
 
@@ -152,14 +168,25 @@ testPatches cfg = do
                                  , patchedPackageResult = res
                                  }
         return [tpatch]
+
   testedPatches <- fold <$> mapConcurrentlyN (fromIntegral $ configConcurrency cfg) build (S.toList packages')
-  let runResult = RunResult testedPatches compInfo
 
-  print $ resultSummary (configExpectedBrokenPkgs cfg) runResult
+  let test :: (Cabal.PackageName, FilePath) -> IO ([TestedPatch LogOutput])
+      test (pname, fpath) = do
+        res <- testPackage cfg (pname, fpath)
+        let tpatch = TestedPatch { patchedPackageName = PkgName $ T.pack $ display pname
+                                 , patchedPackageVersion = Ver $ []
+                                 , patchedPackageResult = res
+                                 }
+        return [tpatch]
+
+  testResults <- fold <$> mapM test (configTestPackages cfg)
+
+  let runResult = RunResult testedPatches testResults compInfo
+
+  let (okay, msg) = resultSummary (configExpectedBrokenPkgs cfg) runResult
+  print msg
   BSL.writeFile "results.json" . encode =<< writeLogs "logs" runResult
-  let failedBuilds = failedUnits (configExpectedBrokenPkgs cfg) runResult
-      planningFailures = planningErrors runResult
-      okay = null failedBuilds && null planningFailures
   unless okay $ exitWith $ ExitFailure 1
 
 writeLogs :: FilePath -> RunResult LogOutput -> IO (RunResult ())
@@ -191,32 +218,46 @@ failedUnits broken = M.filter didFail . runResultUnits
 planningErrors :: RunResult log -> [(PkgName, Ver)]
 planningErrors runResult =
   [ (patchedPackageName tpatch, patchedPackageVersion tpatch)
-  | tpatch <- testedPatches runResult
+  | tpatch <- testedPatches runResult ++ testedTests runResult
   , PackagePlanningFailed _ <- pure $ patchedPackageResult tpatch
   ]
 
-resultSummary :: forall log. BrokenPackages -> RunResult log -> Doc
-resultSummary broken runResult = vcat
-  [ "Total units built:" <+> pshow (length allUnits)
-  , ""
-  , pshow (length planningErrs) <+> "had no valid install plan:"
-  , PP.indent 4 $ vcat $ map (uncurry prettyPkgVer) planningErrs
-  , ""
-  , pshow (length failedUnits) <+> "units failed to build:"
-  , PP.indent 4 $ vcat
-    [ prettyPkgVer (pkgName binfo) (version binfo) <+> expectedDoc
-    | (binfo, _) <- M.elems failedUnits
-    , let expectedDoc
-            | failureExpected broken (pkgName binfo) = PP.parens $ PP.yellow $ PP.text "expected"
-            | otherwise = mempty
-    ]
-  , ""
-  , pshow (length failedDependsUnits) <+> "units failed to build due to unbuildable dependencies."
-  ]
+resultSummary :: forall log. BrokenPackages -> RunResult log -> (Bool, Doc)
+resultSummary broken runResult = (ok, msg)
+
   where
+    ok = null planningErrs && null failedTests && null failedTestsBuild && null failedUnits
+    msg = vcat
+       [ "Total units built:" <+> pshow (length allUnits)
+       , ""
+       , pshow (length planningErrs) <+> "had no valid install plan:"
+       , PP.indent 4 $ vcat $ map (uncurry prettyPkgVer) planningErrs
+       , ""
+       , pshow (length failedUnits) <+> "units failed to build:"
+       , PP.indent 4 $ vcat
+         [ prettyPkgVer (pkgName binfo) (version binfo) <+> expectedDoc
+         | (binfo, _) <- M.elems failedUnits
+         , let expectedDoc
+                 | failureExpected broken (pkgName binfo) = PP.parens $ PP.yellow $ PP.text "expected"
+                 | otherwise = mempty
+         ]
+       , ""
+       , pshow (length failedDependsUnits) <+> "units failed to build due to unbuildable dependencies."
+       , ""
+       , pshow (length failedTestsBuild) <+> "testsuites failed build."
+       , PP.indent 4 $ vcat
+          [ prettyPkgName pkg_name | pkg_name <- failedTestsBuild ]
+       , pshow (length failedTests) <+> "testsuites failed."
+       , PP.indent 4 $ vcat
+          [ prettyPkgName pkg_name | pkg_name <- failedTests ]
+       ]
     allUnits = runResultUnits runResult
     planningErrs = planningErrors runResult
 
+    failedTests = [ pkg_name | (TestedPatch pkg_name ver (PackageResult (PackageBuildSucceeded PackageTestsFailed) _)) <- testedTests runResult ]
+
+    failedTestsBuild = [ pkg_name | (TestedPatch pkg_name ver (PackageResult PackageBuildFailed _)) <- testedTests runResult ]
+
     failedUnits :: M.Map UnitId (BuildInfo, BuildResult log)
     failedUnits = M.filter failed allUnits
       where failed (_, BuildFailed _) = True
@@ -231,10 +272,15 @@ toPkgName = PkgName . T.pack . display
 toVer :: Version -> Ver
 toVer = Ver . versionNumbers
 
+prettyPkgName :: PkgName -> Doc
+prettyPkgName (PkgName pname) =
+  PP.blue (PP.text $ T.unpack pname)
+
 -- | For @cabal-plan@ types.
 prettyPkgVer :: PkgName -> Ver -> Doc
-prettyPkgVer (PkgName pname) (Ver ver) =
-  PP.blue (PP.text $ T.unpack pname) <+> PP.green (PP.text $ intercalate "." $ map show ver)
+prettyPkgVer pname (Ver ver) =
+  prettyPkgName pname
+  <+> PP.green (PP.text $ intercalate "." $ map show ver)
 
 -- | For @Cabal@ types.
 prettyPackageVersion :: Cabal.PackageName -> Version -> Doc
@@ -258,8 +304,35 @@ buildPackage cfg pname version = do
   code <- runProcess $ setWorkingDir dirName
                      $ proc "cabal"
                      $ ["new-build"] ++ cabalOptions cfg
+  whatHappened ("=> Build of" <+> prettyPackageVersion pname version) cfg dirName code Nothing
+  where
+    dirName = "test-" ++ display pname ++ "-" ++ display version
+
+testPackage :: Config -> (Cabal.PackageName, FilePath) -> IO (PackageResult LogOutput)
+testPackage cfg (pname, fpath) = do
+  logMsg $ "=> Testing" <+> prettyPackageName pname
 
-  -- figure out what happened
+  -- prepare the test package
+  createDirectoryIfMissing True dirName
+  copyFile "cabal.project" (dirName </> "cabal.project")
+  appendFile (dirName </> "cabal.project") ("packages: " ++ fpath ++ "\n")
+  -- run the build
+  code <- runProcess $ setWorkingDir dirName
+                     $ proc "cabal"
+                     $ ["new-build", Cabal.unPackageName pname, "--enable-tests"] ++ cabalOptions cfg
+  case code of
+    ExitSuccess -> do
+      runCode <- runProcess $ setWorkingDir dirName
+                     $ proc "cabal"
+                     $ ["new-test", Cabal.unPackageName pname] ++ cabalOptions cfg
+      whatHappened ("=> Test of" <+>  prettyPackageName pname) cfg dirName code (Just runCode)
+    _ ->
+      whatHappened ("=> Test of" <+>  prettyPackageName pname) cfg dirName code Nothing
+  where
+    dirName = "test-" ++ display pname
+
+whatHappened herald cfg dirName code runCode = do
+  compilerId <- getCompilerId (configCompiler cfg)
   let planPath = dirName </> "dist-newstyle" </> "cache" </> "plan.json"
   planExists <- doesFileExist planPath
   case planExists of
@@ -269,20 +342,29 @@ buildPackage cfg pname version = do
       let logDir = cabalDir </> "logs" </> compilerId
       results <- mapM (checkUnit logDir) (pjUnits plan)
       logMsg $
-        let result = case code of
+        let result = case fromMaybe code runCode of
               ExitSuccess -> PP.cyan "succeeded"
               ExitFailure n -> PP.red "failed" <+> PP.parens ("code" <+> pshow n)
-        in "=> Build of" <+> prettyPackageVersion pname version <+> result
+        in herald <+> result
       -- N.B. we remove the build directory on failure to ensure
       -- that we re-extract the source if the user re-runs after
       -- modifying a patch.
       unless (code == ExitSuccess) $ removeDirectoryRecursive dirName
-      return $ PackageResult (code == ExitSuccess) (mergeInfoPlan (planToBuildInfo plan) results)
+      return $ PackageResult codesToStatus (mergeInfoPlan (planToBuildInfo plan) results)
     False -> do
-      logMsg $ PP.red $ "=> Planning for" <+> prettyPackageVersion pname version <+> "failed"
+      logMsg $ PP.red $ "=> Planning for" <+> herald <+> "failed"
       removeDirectoryRecursive dirName
       return $ PackagePlanningFailed mempty
   where
+    codesToStatus =
+      case code of
+        ExitSuccess -> PackageBuildSucceeded $
+                        case runCode of
+                          Nothing -> NoTests
+                          Just rCode -> case rCode of
+                                           ExitSuccess -> PackageTestsSucceeded
+                                           _ -> PackageTestsFailed
+        _ -> PackageBuildFailed
     planToBuildInfo :: PlanJson -> M.Map UnitId BuildInfo
     planToBuildInfo plan = M.fromList
       [ (uId unit, info)
@@ -330,7 +412,7 @@ buildPackage cfg pname version = do
       where
         err = M.mapMissing $ \_ _ -> error "error merging"
 
-    dirName = "test-" ++ display pname ++ "-" ++ display version
+
 
 makeTestCabalFile :: Config -> Cabal.PackageName -> Version -> T.Text
 makeTestCabalFile cfg pname' ver' =