{-# LANGUAGE LambdaCase, ScopedTypeVariables, TypeApplications #-}
module Main where
import Control.Applicative ((<$>))
import Control.Exception (SomeException, try)
import Control.Monad
import Data.List
import Data.List.Split (splitOn)
import Data.Semigroup ((<>))
import Options.Applicative
import System.Directory (removeDirectoryRecursive, getCurrentDirectory, createDirectoryIfMissing)
import System.Exit (ExitCode(..))
import System.FilePath (FilePath, (</>))
import System.FilePath.Glob ()
import System.Process
main :: IO ()
main = testStackage =<< execParser opts
where opts = info (options <**> helper)
(fullDesc
<> progDesc "Tests the Haskell-tools framework with stackage packages."
<> header "ht-test-stackage: a tester utility for Haskell-tools")
options :: Parser StackageTestConfig
options = StackageTestConfig <$> noload <*> noretest <*> noclean <*> result <*> srcdir <*> logdir <*> inputfile <*> snapshot
where noload = switch (long "no-load"
<> help "Don't download the package, use the existing sources.")
noretest = switch (long "no-retest"
<> help "Don't run the test on packages already in the results file.")
noclean = switch (long "no-clean"
<> help "Keep the refactored files.")
srcdir
= strOption (long "src-dir"
<> short 't'
<> metavar "PATH"
<> showDefault
<> value "stackage-test"
<> help "The directory where the downloaded sources should be stored.")
logdir
= strOption (long "log-dir"
<> short 'l'
<> metavar "PATH"
<> showDefault
<> value "stackage-test-logs"
<> help "The directory where the log files should be stored.")
snapshot
= optional (strOption (long "snapshot"
<> metavar "SNAPSHOT"
<> help "The stackage snapshots identifier."))
result
= strOption (long "result"
<> short 'r'
<> metavar "FILE"
<> showDefault
<> value ("results.csv")
<> help "The text file where the results are stored in csv format.")
inputfile = strArgument (metavar "FILE")
data StackageTestConfig = StackageTestConfig { noLoad :: Bool
, noRetest :: Bool
, noClean :: Bool
, resultFile :: FilePath
, sourceDirectory :: FilePath
, logDirectory :: FilePath
, inputFile :: FilePath
, stackageSnapshot :: Maybe String
}
testStackage :: StackageTestConfig -> IO ()
testStackage config = do
packages <- lines <$> readFile (inputFile config)
alreadyTested
<- if noRetest config
then do appendFile (resultFile config) ""
map (head . splitOn ";") . filter (not . null) . lines
<$> readFile (resultFile config)
else writeFile (resultFile config) "" >> return []
let filteredPackages = packages \\ alreadyTested
createDirectoryIfMissing False (logDirectory config)
mapM_ testAndEvaluate filteredPackages
where testAndEvaluate p = do
(res, problem) <- testPackage (noLoad config) (noClean config) (sourceDirectory config)
(logDirectory config) (stackageSnapshot config) p
appendFile (resultFile config) (p ++ ";" ++ show res ++ " ; " ++ problem ++ "\n")
testPackage :: Bool -> Bool -> FilePath -> FilePath -> Maybe String -> String -> IO (Result, String)
testPackage noLoad noClean sourceDirectory logDirectory resolver pack = do
baseDir <- getCurrentDirectory
let pkgLoc = baseDir </> sourceDirectory </> pack
buildLogPath = baseDir </> logDirectory </> (pack ++ "-build-log.txt")
refLogPath = baseDir </> logDirectory </> (pack ++ "-refact-log.txt")
reloadLogPath = baseDir </> logDirectory </> (pack ++ "-reload-log.txt")
res <- runCommands (if noClean then return () else cleanup pkgLoc)
$ init
++ load
++ [ Left ("stack init" ++ (maybe "" (" --resolver="++) resolver) ++ " > " ++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure)
, Left ("stack build --test --no-run-tests --bench --no-run-benchmarks --ghc-options=\"-w\" > "
++ buildLogPath ++ " 2>&1", pkgLoc, BuildFailure)
-- correct rts option handling (on windows) requires stack 1.4
, Left ("stack exec --RTS -- ht-refact +RTS -M4G -RTS --no-watch --ghc-options=\"-w\" "
++ " --execute=\"ProjectOrganizeImports\" . > "
++ refLogPath ++ " 2>&1", pkgLoc, RefactError)
, Left ("stack build > " ++ reloadLogPath ++ " 2>&1", pkgLoc, WrongCodeError)
]
problem <- case res of
RefactError -> map (\case '\n' -> ' '; c -> c) <$> readFile refLogPath
WrongCodeError -> map (\case '\n' -> ' '; c -> c) <$> readFile reloadLogPath
_ -> return ""
return (res, problem)
where load = if noLoad
then []
else [ Right $ (either (\(_ :: SomeException) -> return ()) return =<<)
$ try (removeDirectoryRecursive (sourceDirectory </> pack))
, Left ("cabal get -d " ++ sourceDirectory ++ " " ++ pack, ".", GetFailure) ]
init = [ Right (forM_ [sourceDirectory,logDirectory] (createDirectoryIfMissing True)) ]
cleanup pkgLoc = either (print @SomeException) return =<< try (removeDirectoryRecursive pkgLoc)
data Result = GetFailure
| BuildFailure
| RefactError
| WrongCodeError
| OK
deriving Show
runCommands :: IO () -> [Either (String, FilePath, Result) (IO ())] -> IO Result
runCommands final [] = final >> return OK
runCommands final (Left (cmd,wd,failRes) : rest) = do
baseDir <- getCurrentDirectory
let sh = shell cmd
(_, _, _, pr) <- createProcess sh{ cwd = Just (baseDir </> wd) }
exitCode <- waitForProcess pr
case exitCode of ExitSuccess -> runCommands final rest
ExitFailure _ -> final >> return failRes
runCommands final (Right act : rest) = act >> runCommands final rest