diff --git a/app/GenerateTestCases.hs b/app/GenerateTestCases.hs index dd0ead2ca..d7c4ea9ad 100644 --- a/app/GenerateTestCases.hs +++ b/app/GenerateTestCases.hs @@ -20,6 +20,8 @@ import qualified Data.String.Utils as DSUtils import Options.Applicative hiding ((<>)) import qualified Options.Applicative as O import qualified Renderer as R +import Control.Monad.Effect +import Control.Monad.Effect.Internal data GenerateFormat = GenerateSummaries @@ -148,6 +150,12 @@ maybeMapSummary = fmap $ \case R.SummaryOutput output -> Just output _ -> Nothing +maybeMapJSON :: [R.Output] -> [Maybe (Map Text Value)] +maybeMapJSON = fmap $ \case + R.JSONOutput output -> Just output + _ -> Nothing + + -- | This function represents the heart of the test case generation. It keeps track of -- | the git shas prior to running a command, fetches the git sha after a command, so that -- | JSONTestCase objects can be created. Finally, it appends the created JSONTestCase @@ -155,11 +163,12 @@ maybeMapSummary = fmap $ \case runGenerateCommitAndTestCase :: GeneratorArgs -> String -> FilePath -> (JSONMetaSyntax, String, String, String) -> IO () runGenerateCommitAndTestCase opts language repoPath (JSONMetaSyntax{..}, description, seperator, command) = do Prelude.putStrLn $ "Executing " <> syntax <> " " <> description <> " commit." + beforeSha <- executeCommand repoPath getLastCommitShaCommand _ <- executeCommand repoPath command afterSha <- executeCommand repoPath getLastCommitShaCommand - (summaryChanges, summaryErrors) <- runMaybeSummaries beforeSha afterSha repoPath repoFilePath opts + expectedResult' <- runExpectedResultGenerator repoPath beforeSha afterSha repoFilePath opts let jsonTestCase = encodePretty JSONTestCase { gitDir = extractGitDir repoPath, @@ -167,10 +176,7 @@ runGenerateCommitAndTestCase opts language repoPath (JSONMetaSyntax{..}, descrip filePaths = [repoFilePath], sha1 = beforeSha, sha2 = afterSha, - expectedResult = Map.fromList [ - ("changes", fromMaybe (Map.singleton mempty mempty) summaryChanges), - ("errors", fromMaybe (Map.singleton mempty mempty) summaryErrors) - ] + expectedResult = expectedResult' } Prelude.putStrLn $ "Generating test case for " <> language <> ": " <> syntax <> " " <> description <> "." @@ -179,18 +185,48 @@ runGenerateCommitAndTestCase opts language repoPath (JSONMetaSyntax{..}, descrip where extractGitDir :: String -> String extractGitDir fullRepoPath = DC.unpack $ snd $ DC.breakSubstring (DC.pack "test") (DC.pack fullRepoPath) --- | Conditionally generate the diff summaries for the given shas and file path based --- | on the -g | --generate flag. By default diff summaries are not generated when --- | constructing test cases, and the tuple (Nothing, Nothing) is returned. -runMaybeSummaries :: String -> String -> FilePath -> FilePath -> GeneratorArgs -> IO (Maybe (Map Text [Value]), Maybe (Map Text [Value])) -runMaybeSummaries beforeSha afterSha repoPath repoFilePath GeneratorArgs{..} - | generateResults = do - diffs <- fetchDiffs $ args repoPath beforeSha afterSha [repoFilePath] R.Summary - let headResult = Prelude.head $ maybeMapSummary diffs - let changes = fromMaybe (fromList [("changes", mempty)]) headResult ! "changes" - let errors = fromMaybe (fromList [("errors", mempty)]) headResult ! "errors" - return (Just changes, Just errors) - | otherwise = return (Nothing, Nothing) +data GenerateEff a where + GenerateSummaries' :: Arguments -> GenerateEff ExpectedResult + GenerateJSON' :: Arguments -> GenerateEff ExpectedResult + +-- args :: FilePath -> String -> String -> [String] -> R.Format -> Arguments +generateSummaries' :: FilePath -> String -> String -> FilePath -> Eff '[GenerateEff] ExpectedResult +generateSummaries' repoPath beforeSha afterSha repoFilePath = send $ GenerateSummaries' (args repoPath beforeSha afterSha [repoFilePath] R.Summary) + +generateJSON' :: FilePath -> String -> String -> FilePath -> Eff '[GenerateEff] ExpectedResult +generateJSON' repoPath beforeSha afterSha repoFilePath = send $ GenerateJSON' (args repoPath beforeSha afterSha [repoFilePath] R.JSON) + +run :: Eff '[GenerateEff] ExpectedResult -> IO ExpectedResult +run (Val x) = pure x +run (E u queue) = case decompose u of + (Right (GenerateSummaries' args)) -> generateSummaries args >>= \s -> Main.run (apply queue s) + (Right (GenerateJSON' args)) -> generateJSON args >>= \s -> Main.run (apply queue s) + (Left _) -> error "this isn't possible" + +runExpectedResultGenerator :: FilePath -> String -> String -> FilePath -> GeneratorArgs -> IO ExpectedResult +runExpectedResultGenerator repoPath beforeSha afterSha repoFilePath GeneratorArgs{..} = + case generateFormat of + GenerateSummaries -> Main.run $ generateSummaries' repoPath beforeSha afterSha repoFilePath + GenerateJSON -> Main.run $ generateJSON' repoPath beforeSha afterSha repoFilePath + GenerateAll -> pure EmptyResult + _ -> pure EmptyResult + +generateSummaries :: Arguments -> IO ExpectedResult -- (Map Text [Value], Map Text [Value]) +generateSummaries args@Arguments{..} = do + diffs <- fetchDiffs args + let headResult = Prelude.head $ maybeMapSummary diffs + let changes = fromMaybe (fromList [("changes", mempty)]) headResult ! "changes" + let errors = fromMaybe (fromList [("errors", mempty)]) headResult ! "errors" + pure $ SummaryResult ( Map.fromList [ ("changes", changes), ("errors", errors) ] ) + +generateJSON :: Arguments -> IO ExpectedResult -- (Map Text Value) +generateJSON args = do + diffs <- fetchDiffs args + let headResult = Prelude.head $ maybeMapJSON diffs + let oids = fromMaybe (fromList [("oids", "")]) headResult ! "oids" + let paths = fromMaybe (fromList [("output", "")]) headResult ! "paths" + let rows = fromMaybe (fromList [("rows", "")]) headResult ! "rows" + pure $ JSONResult ( Map.fromList [ ("oids", oids), ("paths", paths), ("rows", rows) ] ) -- | Commands represent the various combination of patches (insert, delete, replacement) -- | for a given syntax.