diff --git a/BuildBox.hs b/BuildBox.hs --- a/BuildBox.hs +++ b/BuildBox.hs @@ -9,10 +9,12 @@ , module BuildBox.Command.Mail , module BuildBox.Command.Environment , module BuildBox.Command.File + , module BuildBox.Command.Darcs , module BuildBox.Cron , module BuildBox.FileFormat.BuildResults , module BuildBox.IO.Directory , module BuildBox.Pretty + , module BuildBox.Quirk , module BuildBox.Reports.BenchResult , module BuildBox.Time) where @@ -25,9 +27,11 @@ import BuildBox.Command.Mail import BuildBox.Command.Environment import BuildBox.Command.File +import BuildBox.Command.Darcs import BuildBox.Cron import BuildBox.FileFormat.BuildResults import BuildBox.IO.Directory import BuildBox.Pretty +import BuildBox.Quirk import BuildBox.Reports.BenchResult import BuildBox.Time diff --git a/BuildBox/Aspect/Units.hs b/BuildBox/Aspect/Units.hs --- a/BuildBox/Aspect/Units.hs +++ b/BuildBox/Aspect/Units.hs @@ -29,6 +29,7 @@ where import BuildBox.Aspect.Single +import BuildBox.Aspect.Stats import BuildBox.Data.Dividable import BuildBox.Pretty import Data.Maybe @@ -113,6 +114,9 @@ instance HasUnits a a => HasUnits (Single a) a where hasUnits (Single x) = hasUnits x + +instance HasUnits a a => HasUnits (Stats a) a where + hasUnits (Stats x _ _) = hasUnits x instance HasUnits a a => HasUnits [a] a where hasUnits [] = Nothing diff --git a/BuildBox/Benchmark.hs b/BuildBox/Benchmark.hs --- a/BuildBox/Benchmark.hs +++ b/BuildBox/Benchmark.hs @@ -49,7 +49,9 @@ -- also include our total runtime. , benchRunResultAspects = Time TotalWall `secs` (fromRational $ toRational diffTime) - : asRun ++ asCheck } + : asRun ++ asCheck + + , benchRunResultQuirks = [] } -- | Run a benchmark once, logging activity and timings to the console. diff --git a/BuildBox/Benchmark/BenchResult.hs b/BuildBox/Benchmark/BenchResult.hs --- a/BuildBox/Benchmark/BenchResult.hs +++ b/BuildBox/Benchmark/BenchResult.hs @@ -3,6 +3,7 @@ ( -- * Benchmark results BenchResult (..) + , BenchRunResult (..) -- * Concatenation , concatBenchResult @@ -20,15 +21,18 @@ , compareManyBenchResults , predBenchResult , swungBenchResult - - -- * Benchmark run results - , BenchRunResult (..) + -- * Merging + , mergeBenchResults + + -- * Advancement + , splitBenchResults + , advanceBenchResults + -- * Application functions , appBenchRunResult , appRunResultAspects - -- * Lifting functions , liftBenchRunResult , liftBenchRunResult2 @@ -38,9 +42,11 @@ , liftRunResultAspects2) where import BuildBox.Aspect +import BuildBox.Quirk import BuildBox.Pretty import Data.List - +import qualified Data.Set as Set +import qualified Data.Map as Map -- BenchResult ------------------------------------------------------------------------------------ -- | We include the name of the original benchmark to it's easy to lookup the results. @@ -73,12 +79,57 @@ $+$ nest 4 (vcat $ map ppr $ benchResultRuns result) +-- BenchRunResult --------------------------------------------------------------------------------- +-- | Holds the result of running a benchmark once. +data BenchRunResult c + = BenchRunResult + { -- | What iteration this run was. + -- Use 1 for the first ''real'' iteration derived by running a program. + -- Use 0 for ''fake'' iterations computed by statistics or comparisons. + benchRunResultIndex :: Integer + + -- | Information about the run that doesn't carry units, + -- eg whether it timed out or segfaulted. + , benchRunResultQuirks :: [Quirk] + + -- | Aspects of the benchmark run that carry units and can have statistics + -- extracted from them. + , benchRunResultAspects :: [WithUnits (Aspect c)] } + + + +deriving instance + ( Show (c Seconds), Show (c Bytes)) + => Show (BenchRunResult c) + +deriving instance + ( HasUnits (c Bytes) Bytes + , Read (c Bytes) + , HasUnits (c Seconds) Seconds + , Read (c Seconds)) + => Read (BenchRunResult c) + + +instance ( Pretty (c Seconds), Pretty (c Bytes)) + => Pretty (BenchRunResult c) where + ppr result + | benchRunResultIndex result == 0 + = (nest 2 $ vcat $ map ppr $ benchRunResultAspects result) + + | otherwise + = ppr (benchRunResultIndex result) + $$ (nest 2 $ vcat $ map ppr $ benchRunResultAspects result) + + +-- Concat ----------------------------------------------------------------------------------------- -- | Concatenate the results of all runs. -- The the resulting `BenchResult` has a single `BenchRunResult` with an index of 0, containing all aspects. concatBenchResult :: BenchResult c1 -> BenchResult c1 concatBenchResult = liftBenchRunResult - $ \bsResults -> [BenchRunResult 0 (concatMap benchRunResultAspects bsResults)] + $ \bsResults -> [BenchRunResult 0 + (concatMap benchRunResultQuirks bsResults) + (concatMap benchRunResultAspects bsResults) ] -- | Collate the aspects of each run. See `collateWithUnits` for an explanation and example. @@ -146,6 +197,107 @@ = predBenchResult (predSwingStatsComparison (\x -> abs x > limit)) +-- Merging ---------------------------------------------------------------------------------------- +-- | Merge lists of `BenchResult`s, preferring results from earlier lists. +-- In the output list there is one result for every named benchmark in the input. +mergeBenchResults :: [[BenchResult c]] -> [BenchResult c] +mergeBenchResults resultss + = let + -- All the available benchResults from all files. + results = concat resultss + + -- Get a the names of all the available benchmarks. + names = sort $ nub + $ map benchResultName results + + -- Merge all the results + Just newBenchResults + = sequence + $ [ find (\br -> benchResultName br == name) results + | name <- names] + + in newBenchResults + + +-- Advancement ----------------------------------------------------------------------------------- +-- | Given a fraction (like 0.1 for 10 percent), split some results into three +-- groups: ''winners'', ''losers'' and ''others''. +-- The losers are benchmarks had any aspect increase by more than the fraction. +-- Winners are non-losers, where any aspect decreased by the fraction. +-- Others are not winners or losers. +-- +splitBenchResults + :: Double + -> [BenchResult StatsComparison] + -> ([BenchResult StatsComparison], [BenchResult StatsComparison], [BenchResult StatsComparison]) + +splitBenchResults swing comparisons + = let + resultLosers + = filter (predBenchResult (predSwingStatsComparison (\x -> x > swing))) + comparisons + + resultWinners_ + = filter (predBenchResult (predSwingStatsComparison (\x -> x < (- swing)))) + comparisons + + -- losers can't be winners + sameName r1 r2 = benchResultName r1 == benchResultName r2 + resultWinners = deleteFirstsBy sameName resultWinners_ resultLosers + + -- others aren't either winners or losers + resultOthers = deleteFirstsBy sameName + (deleteFirstsBy sameName comparisons resultLosers) + resultWinners + + in (resultWinners, resultLosers, resultOthers) + + +-- | Create a new baseline from original baseline, and recent results. +-- If any of the recent results are winners then use them, otherwise use results +-- from the old baseline. +advanceBenchResults + :: Double + -> [BenchResult StatsComparison] -- ^ Comparisons to guide the advancement. + -> [BenchResult Single] -- ^ Baseline results. + -> [BenchResult Single] -- ^ Recent results. + -> [BenchResult Single] -- ^ New baseline. + +advanceBenchResults swing comparisons baselines recents + = let allNames = map benchResultName (baselines ++ recents) + + rsBaseline = Map.fromList [ (benchResultName r, r) | r <- baselines] + rsRecent = Map.fromList [ (benchResultName r, r) | r <- recents] + rsAll = Map.union rsBaseline rsRecent + + -- Do the comparison, note that we only get a comparison back + -- if the benchmark was in both the original lists. + (winners, losers, others) + = splitBenchResults swing comparisons + + nsWinners = Set.fromList $ map benchResultName winners + nsLosers = Set.fromList $ map benchResultName losers + nsOthers = Set.fromList $ map benchResultName others + + getResult name + | Set.member name nsWinners + = let Just r = Map.lookup name rsRecent + in r + + | Set.member name nsLosers || Set.member name nsOthers + = let Just r = Map.lookup name rsBaseline + in r + + -- benchmark wasn't in both input lists, so we have no comparison. + -- just find the data and pass it through + | otherwise + = let Just r = Map.lookup name rsAll + in r + + in map getResult allNames + + + -- Lifting ---------------------------------------------------------------------------------------- -- | Apply a function to the aspects of a `BenchRunResult` appBenchRunResult :: ([BenchRunResult c1] -> b) -> BenchResult c1 -> b @@ -189,47 +341,11 @@ = liftBenchRunResult2 . zipWith . liftRunResultAspects2 - --- BenchRunResult --------------------------------------------------------------------------------- --- | Holds the result of running a benchmark once. -data BenchRunResult c - = BenchRunResult - { -- | What iteration this run was. - -- Use 1 for the first ''real'' iteration derived by running a program. - -- Use 0 for ''fake'' iterations computed by statistics or comparisons. - benchRunResultIndex :: Integer - - -- | Aspects of the benchmark run. - , benchRunResultAspects :: [WithUnits (Aspect c)] } - - -deriving instance - ( Show (c Seconds), Show (c Bytes)) - => Show (BenchRunResult c) - -deriving instance - ( HasUnits (c Bytes) Bytes - , Read (c Bytes) - , HasUnits (c Seconds) Seconds - , Read (c Seconds)) - => Read (BenchRunResult c) - - -instance ( Pretty (c Seconds), Pretty (c Bytes)) - => Pretty (BenchRunResult c) where - ppr result - | benchRunResultIndex result == 0 - = (nest 2 $ vcat $ map ppr $ benchRunResultAspects result) - - | otherwise - = ppr (benchRunResultIndex result) - $$ (nest 2 $ vcat $ map ppr $ benchRunResultAspects result) - - -- Lifting ---------------------------------------------------------------------------------------- -- | Apply a function to the aspects of a `BenchRunResult` appRunResultAspects :: ([WithUnits (Aspect c1)] -> b) -> BenchRunResult c1 -> b -appRunResultAspects f (BenchRunResult _ aspects) = f aspects +appRunResultAspects f (BenchRunResult _ _ aspects) + = f aspects -- | Lift a function to the aspects of a `BenchRunResult` @@ -237,16 +353,17 @@ :: ([WithUnits (Aspect c1)] -> [WithUnits (Aspect c2)]) -> BenchRunResult c1 -> BenchRunResult c2 -liftRunResultAspects f (BenchRunResult ix as) - = BenchRunResult ix (f as) +liftRunResultAspects f (BenchRunResult ix quirks as) + = BenchRunResult ix quirks (f as) --- | Lift a binary function to the aspects of a `BenchRunResult` +-- | Lift a binary function to the aspects of two `BenchRunResult`s. +-- The resulting `BenchRunResult` gets all the quirks from both. liftRunResultAspects2 :: ([WithUnits (Aspect c1)] -> [WithUnits (Aspect c2)] -> [WithUnits (Aspect c3)]) -> BenchRunResult c1 -> BenchRunResult c2 -> BenchRunResult c3 -liftRunResultAspects2 f (BenchRunResult ix1 as) (BenchRunResult ix2 bs) - | ix1 == ix2 = BenchRunResult ix1 (f as bs) +liftRunResultAspects2 f (BenchRunResult ix1 quirks1 as) (BenchRunResult ix2 quirks2 bs) + | ix1 == ix2 = BenchRunResult ix1 (quirks1 ++ quirks2) (f as bs) | otherwise = error "liftRunResultAspects2: indices don't match" diff --git a/BuildBox/Build.hs b/BuildBox/Build.hs --- a/BuildBox/Build.hs +++ b/BuildBox/Build.hs @@ -10,6 +10,7 @@ , runBuild , runBuildPrint , runBuildPrintWithState + , successfully -- * Errors , throw diff --git a/BuildBox/Build/Base.hs b/BuildBox/Build/Base.hs --- a/BuildBox/Build/Base.hs +++ b/BuildBox/Build/Base.hs @@ -17,27 +17,28 @@ -- Build ------------------------------------------------------------------------------------------ --- | Run a build command. +-- | Run a build command. The first argument is a directory that can be used for +-- temporary files (like \"/tmp\") runBuild :: FilePath -> Build a -> IO (Either BuildError a) runBuild scratchDir build - = do uid <- getUniqueId - let state = buildStateDefault uid scratchDir - evalStateT (runErrorT build) state + = do uid <- getUniqueId + let s = buildStateDefault uid scratchDir + evalStateT (runErrorT build) s --- | Run a build command, reporting whether it succeeded to the console. +-- | Like 'runBuild`, but Run a build command, reporting whether it succeeded to the console. -- If it succeeded then return Just the result, else Nothing. runBuildPrint :: FilePath -> Build a -> IO (Maybe a) runBuildPrint scratchDir build - = do uid <- getUniqueId - let state = buildStateDefault uid scratchDir - runBuildPrintWithState state build + = do uid <- getUniqueId + let s = buildStateDefault uid scratchDir + runBuildPrintWithState s build -- | Like `runBuildPrintWithConfig` but also takes a `BuildConfig`. runBuildPrintWithState :: BuildState -> Build a -> IO (Maybe a) -runBuildPrintWithState state build - = do result <- evalStateT (runErrorT build) state +runBuildPrintWithState s build + = do result <- evalStateT (runErrorT build) s case result of Left err -> do putStrLn "\nBuild failed" @@ -48,6 +49,12 @@ Right x -> do putStrLn "Build succeeded." return $ Just x + + +-- | Discard the resulting value of a compuation. +-- Used like @successfully . runBuild ...@ +successfully :: IO a -> IO () +successfully f = f >> return () -- | Get a unique(ish) id for this process. diff --git a/BuildBox/Command/Darcs.hs b/BuildBox/Command/Darcs.hs new file mode 100644 --- /dev/null +++ b/BuildBox/Command/Darcs.hs @@ -0,0 +1,94 @@ +-- | Querying a darcs repository +-- + +module BuildBox.Command.Darcs ( + + EmailAddress, DarcsPath, DarcsPatch(..), + changes, changesN, changesAfter + +) where + +-- standard libraries +import Data.Time +import Data.Maybe +import System.Locale +import qualified Data.Sequence as Seq +import qualified Data.ByteString.Char8 as B + +-- friends +import BuildBox.Build +import BuildBox.Command.System +import qualified BuildBox.Data.Log as Log + + +type DarcsPath = String +type EmailAddress = String + +data DarcsPatch = DarcsPatch + { + darcsTimestamp :: LocalTime -- TLM: use UTC instead? + , darcsAuthor :: EmailAddress + , darcsComment :: Log.Log + } + +instance Show DarcsPatch where + show (DarcsPatch time author desc) = + formatTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" time + ++ " " ++ author + ++ "\n" ++ Log.toString desc + + +-- | List all patches in the given repository. If no repository is given, the +-- current working directory is used. +-- +changes :: Maybe DarcsPath -> Build [DarcsPatch] +changes = darcs . ("darcs changes --repo=" ++) . fromMaybe "." + + +-- The following are more specific invocations of the "darcs changes" command, +-- which may be faster when interacting with very large repositories or over a +-- slow network. +-- + +-- | Retrieve the last N changes from the repository +-- +changesN :: Maybe DarcsPath -> Int -> Build [DarcsPatch] +changesN repo n = + darcs $ "darcs changes --last=" ++ show n + ++ " --repo=" ++ fromMaybe "." repo + +-- | Retrieve all patches submitted to the repository after the given time +-- +changesAfter :: Maybe DarcsPath -> LocalTime -> Build [DarcsPatch] +changesAfter repo time = + darcs $ "darcs changes --matches='date \"after " ++ show time ++ "\"'" + ++ " --repo=" ++ fromMaybe "." repo + + +-- Execute the given darcs command string and split the stdout into a series of +-- patches +-- +darcs :: String -> Build [DarcsPatch] +darcs cmd = do + (status, logOut, logErr) <- systemTeeLog False cmd Log.empty + case status of + ExitSuccess -> return $ splitPatches logOut + _ -> throw $ ErrorSystemCmdFailed cmd status logOut logErr + +splitPatches :: Log.Log -> [DarcsPatch] +splitPatches l + | Seq.null l = [] + | otherwise = let (h,t) = Seq.breakl B.null l + in patch h : splitPatches (Seq.dropWhileL B.null t) + where + patch p = + let toks = words . B.unpack $ Seq.index p 0 + (time,author) = splitAt 6 toks + in + DarcsPatch + { + darcsTimestamp = readTime defaultTimeLocale "%a %b %e %H:%M:%S %Z %Y" (unwords time) + , darcsAuthor = unwords author + , darcsComment = Seq.drop 1 p + } + diff --git a/BuildBox/Command/File.hs b/BuildBox/Command/File.hs --- a/BuildBox/Command/File.hs +++ b/BuildBox/Command/File.hs @@ -31,19 +31,19 @@ instance Testable PropFile where - test prop + test prop = case prop of HasExecutable name -> do code <- qsystem $ "which " ++ name return $ code == ExitSuccess - HasFile path + HasFile path -> io $ doesFileExist path HasDir path -> io $ doesDirectoryExist path - FileEmpty path + FileEmpty path -> do contents <- io $ readFile path return (null contents) @@ -65,14 +65,14 @@ -- with the given name already exists. inScratchDir :: FilePath -> Build a -> Build a inScratchDir name build - = do + = do -- Make sure a dir with this name doesn't already exist. checkFalse $ HasDir name ssystem $ "mkdir -p " ++ name x <- inDir name build - - ssystem $ "rm -Rf " ++ name + + ssystem $ "rm -Rf " ++ name return x @@ -100,38 +100,40 @@ -- run the real command result <- build fileName - - -- cleanup + + -- cleanup io $ removeFile fileName - + return result - + -- | Allocate a new temporary file name newTempFile :: Build FilePath -newTempFile +newTempFile = do buildDir <- gets buildStateScratchDir - buildId <- gets buildStateId - buildSeq <- gets buildStateSeq - + buildId <- gets buildStateId + buildSeq <- gets buildStateSeq + -- Increment the sequence number. modify $ \s -> s { buildStateSeq = buildStateSeq s + 1 } - + + -- Ensure the build directory exists, or canonicalizePath will fail + ensureDir buildDir + -- Build the file name we'll try to use. - fileName <- io $ canonicalizePath - $ buildDir ++ "/buildbox-" ++ show buildId ++ "-" ++ show buildSeq - + let fileName = buildDir ++ "/buildbox-" ++ show buildId ++ "-" ++ show buildSeq + -- If it already exists then something has gone badly wrong. -- Maybe the unique Id for the process wasn't as unique as we thought. exists <- io $ doesFileExist fileName when exists $ error "buildbox: panic, supposedly fresh file already exists." - + -- Touch the file for good measure. -- If the unique id wasn't then we want to detect this. io $ writeFile fileName "" - - return fileName + + io $ canonicalizePath fileName diff --git a/BuildBox/Command/Mail.hs b/BuildBox/Command/Mail.hs --- a/BuildBox/Command/Mail.hs +++ b/BuildBox/Command/Mail.hs @@ -34,10 +34,19 @@ -- | An external mailer that can send messages. -- Also contains mail server info if needed. --- We only support msmtp at the moment. data Mailer - = MailerMSMTP + -- | Send the mail by writing to the stdin of this command. + -- On many systems the command 'sendmail' will be aliased to an appropriate + -- wrapper for whatever Mail Transfer Agent (MTA) you have installed. + = MailerSendmail { mailerPath :: FilePath + , mailerExtraFlags :: [String] } + + -- | Send mail via MSMTP, which is a stand-alone SMTP sender. + -- This might be be easier to set up if you don't have a real MTA installed. + -- Get it from http://msmtp.sourceforge.net/ + | MailerMSMTP + { mailerPath :: FilePath , mailerPort :: Maybe Int } deriving Show @@ -96,14 +105,19 @@ sendMailWithMailer :: Mail -> Mailer -> Build () sendMailWithMailer mail mailer = case mailer of - MailerMSMTP{} -> sendMailWithMSMTP mail mailer + MailerSendmail{} + -> ssystemTee False + (mailerPath mailer + ++ " -t ") -- read recipients from the mail + (render $ renderMail mail) -sendMailWithMSMTP :: Mail -> Mailer -> Build () -sendMailWithMSMTP mail mailer@MailerMSMTP{} - = ssystemTee False + MailerMSMTP{} + -> ssystemTee False (mailerPath mailer ++ " -t " -- read recipients from the mail ++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer)) (render $ renderMail mail) - + + + diff --git a/BuildBox/Command/System.hs b/BuildBox/Command/System.hs --- a/BuildBox/Command/System.hs +++ b/BuildBox/Command/System.hs @@ -28,9 +28,11 @@ import BuildBox.Command.System.Internals import BuildBox.Build import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad +import Control.Monad.STM import System.Exit import System.IO -import Control.Monad import Data.ByteString.Char8 (ByteString) import BuildBox.Data.Log (Log) import System.Process hiding (system) @@ -122,8 +124,7 @@ -- | Like `systemTeeIO`, but in the `Build` monad and throw an error if it returns `ExitFailure`. ssystemTee :: Bool -> String -> String -> Build () ssystemTee tee cmd strIn - = do logSystem cmd - (code, logOut, logErr) <- systemTeeLog tee cmd (Log.fromString strIn) + = do (code, logOut, logErr) <- systemTeeLog tee cmd (Log.fromString strIn) when (code /= ExitSuccess) $ throw $ ErrorSystemCmdFailed cmd code logOut logErr @@ -158,21 +159,23 @@ , std_err = CreatePipe , close_fds = False } - -- Push input into in handle + -- Push input into in handle. Close the handle afterwards to ensure the + -- process gets sent the EOF character. hPutStr hInWrite $ Log.toString logIn + hClose hInWrite -- To implement the tee-like behavior we'll fork some threads that read lines from the -- processes stdout and stderr and write them to these channels. -- When they hit EOF they signal this via the semaphores. - chanOut <- newChan - chanErr <- newChan + chanOut <- newTChanIO + chanErr <- newTChanIO semOut <- newQSem 0 semErr <- newQSem 0 -- Make duplicates of the above, which will store everything -- written to them. This gives us the copy to return from the fn. - chanOutAcc <- dupChan chanOut - chanErrAcc <- dupChan chanErr + chanOutAcc <- atomically $ dupTChan chanOut + chanErrAcc <- atomically $ dupTChan chanErr -- Fork threads to read from the process handles and write to our channels. _tidOut <- forkIO $ streamIn hOutRead chanOut @@ -208,9 +211,9 @@ code `seq` logOut `seq` logErr `seq` return (code, logOut, logErr) -slurpChan :: Chan (Maybe ByteString) -> Log -> IO Log +slurpChan :: TChan (Maybe ByteString) -> Log -> IO Log slurpChan !chan !ll - = do mStr <- readChan chan + = do mStr <- atomically $ readTChan chan case mStr of Nothing -> return ll Just str -> slurpChan chan (ll Log.|> str) diff --git a/BuildBox/Command/System/Internals.hs b/BuildBox/Command/System/Internals.hs --- a/BuildBox/Command/System/Internals.hs +++ b/BuildBox/Command/System/Internals.hs @@ -5,30 +5,32 @@ where import System.IO import Control.Concurrent +import Control.Concurrent.STM.TChan +import Control.Monad.STM import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS -- | Continually read lines from a handle and write them to this channel. -- When the handle hits EOF then write `Nothing` to the channel. -streamIn :: Handle -> Chan (Maybe ByteString) -> IO () +streamIn :: Handle -> TChan (Maybe ByteString) -> IO () streamIn !hRead !chan = do eof <- hIsEOF hRead if eof then do - writeChan chan Nothing + atomically $ writeTChan chan Nothing return () else do str <- BS.hGetLine hRead - writeChan chan (Just str) + atomically $ writeTChan chan (Just str) streamIn hRead chan -- | Continually read lines from some channels and write them to handles. -- When all the channels return `Nothing` then we're done. -- When we're done, signal this fact on the semaphore. -streamOuts :: [(Chan (Maybe ByteString), (Maybe Handle), QSem)] -> IO () +streamOuts :: [(TChan (Maybe ByteString), (Maybe Handle), QSem)] -> IO () streamOuts !chans = streamOuts' False [] chans @@ -51,21 +53,31 @@ -- try to read from the current chan. streamOuts' !active !prev (!x@(!chan, !mHandle, !qsem) : rest) - = isEmptyChan chan >>= \empty -> - if empty - then streamOuts' active (prev ++ [x]) rest - else do - mStr <- readChan chan + = do + -- try and read a string from the channel, but don't block + -- if there aren't any. + mStr <- atomically + $ do isEmpty <- isEmptyTChan chan + if isEmpty + then return (False, Nothing) + + else do mStr <- readTChan chan + return (True, mStr) + case mStr of - Nothing + (False, _) + -> streamOuts' active (prev ++ [x]) rest + + (True, Nothing) -> do signalQSem qsem streamOuts' active prev rest - Just str + (True, Just str) | Just h <- mHandle -> do BS.hPutStr h str hPutChar h '\n' streamOuts' True (prev ++ [x]) rest | otherwise - -> streamOuts' True (prev ++ [x]) rest + -> streamOuts' True (prev ++ [x]) rest + diff --git a/BuildBox/Data/Log.hs b/BuildBox/Data/Log.hs --- a/BuildBox/Data/Log.hs +++ b/BuildBox/Data/Log.hs @@ -25,9 +25,6 @@ type Log = Seq Line type Line = ByteString -instance Show Log where - show = toString - -- | O(1) No logs here. empty :: Log diff --git a/BuildBox/FileFormat/BuildResults.hs b/BuildBox/FileFormat/BuildResults.hs --- a/BuildBox/FileFormat/BuildResults.hs +++ b/BuildBox/FileFormat/BuildResults.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE PatternGuards #-} module BuildBox.FileFormat.BuildResults ( BuildResults(..) - , mergeResults) + , mergeResults + , acceptResult + , advanceResults) where import BuildBox.Time import BuildBox.Benchmark @@ -9,6 +12,7 @@ import BuildBox.Pretty import BuildBox.Aspect import Data.List +import Data.Function -- | A simple build results file format. @@ -39,11 +43,10 @@ mergeResults results = let -- All the available benchResults from all files. - benchResults - = concatMap buildResultBench results + benchResults = concatMap buildResultBench results -- Get a the names of all the available benchmarks. - benchNames + benchNames = sort $ nub $ map benchResultName $ concatMap buildResultBench results @@ -61,3 +64,49 @@ { buildResultTime = buildResultTime lastResults , buildResultEnvironment = buildResultEnvironment lastResults , buildResultBench = newBenchResults } + + +-- | Take test results from the first `BuildResults`, except for the named +-- one which we take from the second. If the named test is not in the second +-- then take it from the first. If it's not anywhere then Nothing. +acceptResult :: String -> BuildResults -> BuildResults -> Maybe BuildResults +acceptResult nameAccept baseline recent + + | Just resultAccept + <- find (\br -> benchResultName br == nameAccept) + $ buildResultBench recent + + = let resultsBaseline + = filter (\br -> benchResultName br /= nameAccept) + $ buildResultBench baseline + + -- use the timestamp from the last one. + in Just $ BuildResults + { buildResultTime = buildResultTime recent + , buildResultEnvironment = buildResultEnvironment recent + , buildResultBench = sortBy (compare `on` benchResultName) + $ resultAccept : resultsBaseline } + + | otherwise + = Nothing + + +-- | Advance benchmark results as per `advanceBenchResults`. +-- The resultTime and environment is taken from the second `BuildResults`. +advanceResults :: Double -> BuildResults -> BuildResults -> BuildResults +advanceResults swing baseline recent + = let comparisons = compareManyBenchResults + (map statBenchResult $ buildResultBench baseline) + (map statBenchResult $ buildResultBench recent) + + results = advanceBenchResults swing + comparisons + (buildResultBench baseline) + (buildResultBench recent) + + in BuildResults + { buildResultTime = buildResultTime recent + , buildResultEnvironment = buildResultEnvironment recent + , buildResultBench = results } + + diff --git a/BuildBox/Quirk.hs b/BuildBox/Quirk.hs new file mode 100644 --- /dev/null +++ b/BuildBox/Quirk.hs @@ -0,0 +1,37 @@ + +module BuildBox.Quirk + (Quirk (..)) +where +import System.Exit +import BuildBox.Aspect.Units +import BuildBox.Pretty + + +-- | A Quirk is some extended information about a benchmark or test that isn't represented +-- by an `Aspect`. These are singleton pieces of data where it doesn't make sense to +-- average them or compute other statistics. +data Quirk + = QuirkSucceeded + | QuirkFailed + | QuirkExitCode ExitCode + | QuirkTimeout Seconds + deriving (Eq, Ord, Read, Show) + +instance Pretty Quirk where + ppr quirk + = case quirk of + QuirkSucceeded + -> text "succeeded" + + QuirkFailed + -> text "failed" + + QuirkExitCode ExitSuccess + -> text "exited successfully" + + QuirkExitCode (ExitFailure code) + -> text "exited with failure code " <> int code + + QuirkTimeout seconds + -> text "timed out after " <> ppr seconds + diff --git a/BuildBox/Reports/BenchResult.hs b/BuildBox/Reports/BenchResult.hs --- a/BuildBox/Reports/BenchResult.hs +++ b/BuildBox/Reports/BenchResult.hs @@ -8,7 +8,6 @@ import BuildBox.Aspect import BuildBox.Benchmark.BenchResult import Text.Printf -import Data.List -- | Produce a human readable report of benchmark results. -- @@ -23,18 +22,9 @@ = vcat $ punctuate (text "\n") $ map ppr comparisons reportBenchResults (Just swing) comparisons - = let resultLosers - = filter (predBenchResult (predSwingStatsComparison (\x -> x > swing))) - comparisons - - resultWinners_ - = filter (predBenchResult (predSwingStatsComparison (\x -> x < (- swing)))) - comparisons - - -- losers can't be winners - resultWinners = deleteFirstsBy (\r1 r2 -> benchResultName r1 == benchResultName r2) - resultWinners_ resultLosers - + = let (resultWinners, resultLosers, _) + = splitBenchResults swing comparisons + in vcat $ [ text "Total tests = " <> int (length comparisons) , blank] ++ [reportBenchResults' swing resultWinners resultLosers] diff --git a/BuildBox/Time.hs b/BuildBox/Time.hs --- a/BuildBox/Time.hs +++ b/BuildBox/Time.hs @@ -34,7 +34,7 @@ getStampyTime :: IO String getStampyTime = do time <- getZonedTime - return $ formatTime defaultTimeLocale "%Y%m%d_%k%M%S" time + return $ formatTime defaultTimeLocale "%0Y%0m%0d_%0k%0M%0S" time -- | Get the local midnight we've just had as a `LocalTime`. diff --git a/buildbox.cabal b/buildbox.cabal --- a/buildbox.cabal +++ b/buildbox.cabal @@ -1,5 +1,5 @@ Name: buildbox -Version: 1.3.0.1 +Version: 1.5.0.1 License: BSD3 License-file: LICENSE Author: Ben Lippmeier @@ -20,20 +20,21 @@ Rehackable components for writing buildbots and test harnesses. Tested-with: - GHC == 6.12.1 + GHC == 7.0.3 Library Build-Depends: base == 4.*, + containers >= 0.4 && < 0.5, time >= 1.1 && <= 1.3, - mtl == 1.1.*, directory >= 1.0 && <= 1.2, + mtl >= 2.0 && < 3.0, + old-locale == 1.0.*, process == 1.0.*, random == 1.0.*, pretty == 1.0.*, - old-locale == 1.0.*, - containers == 0.3.*, - bytestring == 0.9.* + bytestring == 0.9.*, + stm == 2.2.* ghc-options: -Wall @@ -53,6 +54,7 @@ BuildBox.Build.BuildError BuildBox.Build.BuildState BuildBox.Build + BuildBox.Command.Darcs BuildBox.Command.Environment BuildBox.Command.File BuildBox.Command.Mail @@ -66,6 +68,7 @@ BuildBox.FileFormat.BuildResults BuildBox.IO.Directory BuildBox.Pretty + BuildBox.Quirk BuildBox.Time Other-modules: