mirror of
https://github.com/github/semantic.git
synced 2024-12-23 06:41:45 +03:00
291 lines
16 KiB
Haskell
291 lines
16 KiB
Haskell
{-# LANGUAGE LambdaCase #-}
|
|
module Main where
|
|
|
|
import Arguments
|
|
import Control.Exception
|
|
import Data.Aeson
|
|
import Data.Aeson.Encode.Pretty
|
|
import Data.Map.Strict as Map
|
|
import qualified Data.ByteString.Lazy as DL
|
|
import qualified Data.ByteString.Char8 as DC
|
|
import Data.String
|
|
import qualified Data.Text as DT
|
|
import JSONTestCase
|
|
import qualified Prelude
|
|
import Prologue
|
|
import SemanticDiff (fetchDiffs)
|
|
import System.FilePath.Glob
|
|
import System.Process
|
|
import qualified Data.String.Utils as DSUtils
|
|
import Options.Applicative hiding ((<>))
|
|
import qualified Options.Applicative as O
|
|
import qualified Renderer as R
|
|
|
|
data GeneratorArgs = GeneratorArgs { generateResults :: Bool } deriving (Show)
|
|
|
|
generatorArgs :: Parser GeneratorArgs
|
|
generatorArgs = GeneratorArgs <$> switch ( long "generate-results" O.<> short 'g' O.<> help "Use generated expected results for new JSON test cases (rather than defaulting to an empty \"\")" )
|
|
|
|
options :: ParserInfo GeneratorArgs
|
|
options = info (helper <*> generatorArgs) (fullDesc O.<> progDesc "Auto-generate JSON test cases" O.<> header "JSON Test Case Generator")
|
|
|
|
main :: IO ()
|
|
main = do
|
|
opts <- execParser options
|
|
generatorFilePaths <- runFetchGeneratorFiles
|
|
unparsedGeneratorCases <- traverse DL.readFile generatorFilePaths
|
|
let parsedGeneratorCases = eitherDecode <$> unparsedGeneratorCases :: [Either String [JSONMetaRepo]]
|
|
traverse_ (handleGeneratorCases opts generatorFilePaths) parsedGeneratorCases
|
|
where handleGeneratorCases :: GeneratorArgs -> [FilePath] -> Either String [JSONMetaRepo] -> IO ()
|
|
handleGeneratorCases opts generatorFilePaths parsedGeneratorCase =
|
|
case parsedGeneratorCase of
|
|
Left err -> Prelude.putStrLn $ "An error occurred: " <> err
|
|
Right metaTestCases -> do
|
|
traverse_ (runGenerator opts) metaTestCases
|
|
traverse_ runMoveGeneratorFile generatorFilePaths
|
|
|
|
-- | Finds all JSON files within the generators directory.
|
|
runFetchGeneratorFiles :: IO [FilePath]
|
|
runFetchGeneratorFiles = globDir1 (compile "*.json") "test/corpus/generators"
|
|
|
|
-- | First initialize the git submodule repository where commits will be made for the given metaRepo and its syntaxes.
|
|
-- | Second generate the commits for each syntax and generate the associated JSONTestCase objects.
|
|
-- | Finally push the generated commits to the submodule's remote repository.
|
|
runGenerator :: GeneratorArgs -> JSONMetaRepo -> IO ()
|
|
runGenerator opts metaRepo@JSONMetaRepo{..} = do
|
|
runSetupGitRepo metaRepo
|
|
runCommitsAndTestCasesGeneration opts metaRepo
|
|
runPullGitRemote repoUrl repoPath
|
|
runPushGitRemote repoPath
|
|
|
|
-- | Upon successful test case generation for a generator file, move the file to the generated directory.
|
|
-- | This prevents subsequence runs of the test generator from duplicating test cases and adding extraneous
|
|
-- | commits to the git submodule.
|
|
runMoveGeneratorFile :: FilePath -> IO ()
|
|
runMoveGeneratorFile filePath = do
|
|
let updatedPath = DT.unpack $ DT.replace (DT.pack "generators") (DT.pack "generated") (DT.pack filePath)
|
|
Prelude.putStrLn updatedPath
|
|
_ <- readCreateProcess (shell $ "mv " <> filePath <> " " <> updatedPath) ""
|
|
return ()
|
|
|
|
-- | Initializes a new git repository and adds it as a submodule to the semantic-diff git index.
|
|
-- | This repository contains the commits associated with the given JSONMetaRepo's syntax examples.
|
|
runSetupGitRepo :: JSONMetaRepo -> IO ()
|
|
runSetupGitRepo JSONMetaRepo{..} = do
|
|
runInitializeRepo repoUrl repoPath
|
|
runAddSubmodule repoUrl repoPath
|
|
|
|
-- | Performs the system calls for initializing the git repository.
|
|
-- | If the git repository already exists, the operation will result in an error,
|
|
-- | but will not prevent successful completion of the test case generation.
|
|
runInitializeRepo :: String -> FilePath -> IO ()
|
|
runInitializeRepo repoUrl repoPath = do
|
|
result <- try $ readCreateProcess (shell $ mkDirCommand repoPath) ""
|
|
case (result :: Either Prelude.IOError String) of
|
|
Left error -> Prelude.putStrLn $ "Creating the repository directory at " <> repoPath <> " failed with: " <> show error <> ". " <> "Possible reason: repository already initialized. \nProceeding to the next step."
|
|
Right _ -> do
|
|
_ <- executeCommand repoPath (initializeRepoCommand repoUrl)
|
|
Prelude.putStrLn $ "Repository directory successfully initialized for " <> repoPath <> "."
|
|
|
|
-- | Git repositories generated as a side-effect of generating tests cases are
|
|
-- | added to semantic-diff's git index as submodules. If the submodule initialization
|
|
-- | fails (usually because the submodule was already initialized), operations will
|
|
-- | continue.
|
|
runAddSubmodule :: String -> FilePath -> IO ()
|
|
runAddSubmodule repoUrl repoPath = do
|
|
result <- try $ readCreateProcess (shell $ addSubmoduleCommand repoUrl repoPath) ""
|
|
case (result :: Either Prelude.IOError String) of
|
|
Left error -> Prelude.putStrLn $ "Initializing the submodule repository at " <> repoPath <> " failed with: " <> show error <> ". " <> "Possible reason: submodule already initialized. \nProceeding to the next step."
|
|
_ -> Prelude.putStrLn $ "Submodule successfully initialized for " <> repoPath <> "."
|
|
|
|
-- | Performs the system calls for generating the commits and test cases.
|
|
-- | Also appends the JSONTestCases generated to the test case file defined by
|
|
-- | the syntaxes.
|
|
runCommitsAndTestCasesGeneration :: GeneratorArgs -> JSONMetaRepo -> IO ()
|
|
runCommitsAndTestCasesGeneration opts metaRepo@JSONMetaRepo{..} =
|
|
for_ syntaxes generate
|
|
where generate :: JSONMetaSyntax -> IO ()
|
|
generate metaSyntax = do
|
|
_ <- runInitialCommitForSyntax metaRepo metaSyntax
|
|
runSetupTestCaseFile metaSyntax
|
|
runCommitAndTestCaseGeneration opts language metaRepo metaSyntax
|
|
runCloseTestCaseFile metaSyntax
|
|
|
|
-- | For a syntax, we want the initial commit to be an empty file.
|
|
-- | This function performs a touch and commits the empty file.
|
|
runInitialCommitForSyntax :: JSONMetaRepo -> JSONMetaSyntax -> IO ()
|
|
runInitialCommitForSyntax metaRepo@JSONMetaRepo{..} metaSyntax@JSONMetaSyntax{..} = do
|
|
Prelude.putStrLn $ "Generating initial commit for " <> syntax <> " syntax."
|
|
result <- try . executeCommand repoPath $ touchCommand repoFilePath <> commitCommand syntax "Initial commit"
|
|
case ( result :: Either Prelude.IOError String) of
|
|
Left error -> Prelude.putStrLn $ "Initializing the " <> repoFilePath <> " failed with: " <> show error <> ". " <> "Possible reason: file already initialized. \nProceeding to the next step."
|
|
Right _ -> runAddTemplateForSyntax metaRepo metaSyntax
|
|
|
|
runAddTemplateForSyntax :: JSONMetaRepo -> JSONMetaSyntax -> IO ()
|
|
runAddTemplateForSyntax JSONMetaRepo{..} JSONMetaSyntax{..} = case templateText of
|
|
Just templateText -> do
|
|
_ <- executeCommand repoPath $ fileWriteCommand repoFilePath templateText <> commitCommand syntax ("Add " <> repoFilePath <> " template text.")
|
|
pure ()
|
|
Nothing -> pure ()
|
|
|
|
-- | Initializes the test case file where JSONTestCase examples are written to.
|
|
-- | This manually inserts a "[" to open a JSON array.
|
|
runSetupTestCaseFile :: JSONMetaSyntax -> IO ()
|
|
runSetupTestCaseFile metaSyntax = do
|
|
Prelude.putStrLn $ "Opening " <> testCaseFilePath metaSyntax
|
|
DL.writeFile (testCaseFilePath metaSyntax) "["
|
|
|
|
-- | For each command constructed for a given metaSyntax, execute the system commands.
|
|
runCommitAndTestCaseGeneration :: GeneratorArgs -> String -> JSONMetaRepo -> JSONMetaSyntax -> IO ()
|
|
runCommitAndTestCaseGeneration opts language metaRepo metaSyntax@JSONMetaSyntax{..} =
|
|
traverse_ (runGenerateCommitAndTestCase opts language (repoPath metaRepo)) (commands metaRepo metaSyntax)
|
|
|
|
maybeMapSummary :: [R.Output] -> [Maybe (Map Text (Map Text [Value]))]
|
|
maybeMapSummary = fmap $ \case
|
|
R.SummaryOutput 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
|
|
-- | object to the test case file.
|
|
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
|
|
|
|
let jsonTestCase = encodePretty JSONTestCase {
|
|
gitDir = extractGitDir repoPath,
|
|
testCaseDescription = language <> "-" <> syntax <> "-" <> description <> "-" <> "test",
|
|
filePaths = [repoFilePath],
|
|
sha1 = beforeSha,
|
|
sha2 = afterSha,
|
|
expectedResult = Map.fromList [
|
|
("changes", fromMaybe (Map.singleton mempty mempty) summaryChanges),
|
|
("errors", fromMaybe (Map.singleton mempty mempty) summaryErrors)
|
|
]
|
|
}
|
|
|
|
Prelude.putStrLn $ "Generating test case for " <> language <> ": " <> syntax <> " " <> description <> "."
|
|
|
|
DL.appendFile testCaseFilePath $ jsonTestCase <> DL.fromStrict (DC.pack seperator)
|
|
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)
|
|
|
|
-- | Commands represent the various combination of patches (insert, delete, replacement)
|
|
-- | for a given syntax.
|
|
commands :: JSONMetaRepo -> JSONMetaSyntax -> [(JSONMetaSyntax, String, String, String)]
|
|
commands metaRepo metaSyntax@JSONMetaSyntax{..} =
|
|
[ (metaSyntax, "insert", commaSeperator, fileAppendCommand repoFilePath insert <> commitCommand syntax "insert")
|
|
, (metaSyntax, "replacement-insert", commaSeperator, fileWriteCommand repoFilePath templateText' <> fileAppendCommand repoFilePath (Prologue.intercalate "\n" [replacement, insert, insert]) <> commitCommand syntax "replacement + insert + insert")
|
|
, (metaSyntax, "delete-insert", commaSeperator, fileWriteCommand repoFilePath templateText' <> fileAppendCommand repoFilePath (Prologue.intercalate "\n" [insert, insert, insert]) <> commitCommand syntax "delete + insert")
|
|
, (metaSyntax, "replacement", commaSeperator, fileWriteCommand repoFilePath templateText' <> fileAppendCommand repoFilePath (Prologue.intercalate "\n" [replacement, insert, insert]) <> commitCommand syntax "replacement")
|
|
, (metaSyntax, "delete-replacement", commaSeperator, fileWriteCommand repoFilePath templateText' <> fileAppendCommand repoFilePath (Prologue.intercalate "\n" [insert, replacement]) <> commitCommand syntax "delete + replacement")
|
|
, (metaSyntax, "delete", commaSeperator, fileWriteCommand repoFilePath templateText' <> fileAppendCommand repoFilePath replacement <> commitCommand syntax "delete")
|
|
, (metaSyntax, "delete-rest", spaceSeperator, fileWriteCommand repoFilePath templateText' <> commitCommand syntax "delete rest")
|
|
]
|
|
where commaSeperator = "\n,"
|
|
spaceSeperator = ""
|
|
templateText' = fromMaybe "" (templateText metaRepo)
|
|
|
|
-- | Attempts to pull from the git repository's remote repository.
|
|
-- | If the pull fails, the exception is caught and continues to the next step.
|
|
runPullGitRemote :: String -> FilePath -> IO ()
|
|
runPullGitRemote repoUrl repoPath = do
|
|
Prelude.putStrLn "Attempting to fetch from the remote repository."
|
|
_ <- executeCommand repoPath checkoutMasterCommand
|
|
result <- attempt
|
|
handle result next errorMessage
|
|
where attempt :: IO (Either Prelude.IOError String)
|
|
attempt = try $ executeCommand repoPath pullFromRemoteCommand
|
|
|
|
handle :: Either Prelude.IOError String -> IO () -> (Prelude.IOError -> IO ()) -> IO ()
|
|
handle result success err = case (result :: Either Prelude.IOError String) of
|
|
Left error -> err error
|
|
Right _ -> success
|
|
next :: IO ()
|
|
next = Prelude.putStrLn "Remote repository successfully fetched.\n"
|
|
|
|
errorMessage :: Prelude.IOError -> IO ()
|
|
errorMessage err = Prelude.putStrLn $ "Pulling from the remote repository at " <> repoUrl <> " failed with: " <> show err <> ". Proceeding to the next step.\n"
|
|
|
|
-- | Pushes git commits to the submodule repository's remote.
|
|
runPushGitRemote :: FilePath -> IO ()
|
|
runPushGitRemote repoPath = do
|
|
Prelude.putStrLn "Updating git remote."
|
|
result <- try $ executeCommand repoPath pushToGitRemoteCommand
|
|
case (result :: Either Prelude.IOError String) of
|
|
Left err -> die $ "Failed to push to remote repository: " <> show err
|
|
Right _ -> Prelude.putStrLn "Successfully updated git remote."
|
|
|
|
-- | Closes the JSON array and closes the test case file.
|
|
runCloseTestCaseFile :: JSONMetaSyntax -> IO ()
|
|
runCloseTestCaseFile metaSyntax = do
|
|
Prelude.putStrLn $ "Closing " <> testCaseFilePath metaSyntax
|
|
DL.appendFile (testCaseFilePath metaSyntax) "]\n"
|
|
|
|
initializeRepoCommand :: String -> String
|
|
initializeRepoCommand repoUrl = "rm -rf *; rm -rf .git; git init .; git remote add origin " <> repoUrl <> ";"
|
|
|
|
addSubmoduleCommand :: String -> FilePath -> String
|
|
addSubmoduleCommand repoUrl repoPath = "git submodule add " <> repoUrl <> " " <> " ./" <> repoPath <> ";"
|
|
|
|
getLastCommitShaCommand :: String
|
|
getLastCommitShaCommand = "git log --pretty=format:\"%H\" -n 1;"
|
|
|
|
checkoutMasterCommand :: String
|
|
checkoutMasterCommand = "git checkout master;"
|
|
|
|
pullFromRemoteCommand :: String
|
|
pullFromRemoteCommand = "git pull origin master;"
|
|
|
|
touchCommand :: FilePath -> String
|
|
touchCommand repoFilePath = "touch " <> repoFilePath <> ";"
|
|
|
|
-- | In order to correctly record syntax examples that include backticks (like JavaScript template strings)
|
|
-- | we must first escape them for bash (due to the use of the `echo` system command). Additionally,
|
|
-- | we must also escape the escape character `\` in Haskell, hence the double `\\`.
|
|
fileWriteCommand :: FilePath -> String -> String
|
|
fileWriteCommand repoFilePath contents = "echo \"" <> (escapeBackticks . escapeDoubleQuotes) contents <> "\" > " <> repoFilePath <> ";"
|
|
where
|
|
escapeBackticks = DSUtils.replace "`" "\\`"
|
|
escapeDoubleQuotes = DSUtils.replace "\"" "\\\""
|
|
|
|
fileAppendCommand :: FilePath -> String -> String
|
|
fileAppendCommand repoFilePath contents = "echo \"" <> (escapeBackticks . escapeDoubleQuotes) contents <> "\" >> " <> repoFilePath <> ";"
|
|
where
|
|
escapeBackticks = DSUtils.replace "`" "\\`"
|
|
escapeDoubleQuotes = DSUtils.replace "\"" "\\\""
|
|
|
|
commitCommand :: String -> String -> String
|
|
commitCommand syntax commitMessage = "git add .; git commit -m \"" <> syntax <> ": " <> commitMessage <> "\"" <> ";"
|
|
|
|
removeCommand :: FilePath -> String
|
|
removeCommand repoFilePath = "rm " <> repoFilePath <> ";"
|
|
|
|
pushToGitRemoteCommand :: String
|
|
pushToGitRemoteCommand = "git push origin HEAD;"
|
|
|
|
mkDirCommand :: FilePath -> String
|
|
mkDirCommand repoPath = "mkdir " <> repoPath <> ";"
|
|
|
|
executeCommand :: FilePath -> String -> IO String
|
|
executeCommand repoPath command = readCreateProcess (shell command) { cwd = Just repoPath } ""
|