buildbox 1.3.0.1 → 1.5.0.1

raw patch · 17 files changed

+473/−137 lines, 17 filesdep +stmdep ~containersdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

Dependency ranges changed: containers, mtl

API changes (from Hackage documentation)

Files

• BuildBox.hs +4/−0
• BuildBox/Aspect/Units.hs +4/−0
• BuildBox/Benchmark.hs +3/−1
• BuildBox/Benchmark/BenchResult.hs +166/−49
• BuildBox/Build.hs +1/−0
• BuildBox/Build/Base.hs +17/−10
• BuildBox/Command/Darcs.hs +94/−0
• BuildBox/Command/File.hs +23/−21
• BuildBox/Command/Mail.hs +21/−7
• BuildBox/Command/System.hs +13/−10
• BuildBox/Command/System/Internals.hs +24/−12
• BuildBox/Data/Log.hs +0/−3
• BuildBox/FileFormat/BuildResults.hs +53/−4
• BuildBox/Quirk.hs +37/−0
• BuildBox/Reports/BenchResult.hs +3/−13
• BuildBox/Time.hs +1/−1
• buildbox.cabal +9/−6

@@ -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

@@ -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

@@ -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.

@@ -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" 

@@ -10,6 +10,7 @@ 	, runBuild 	, runBuildPrint 	, runBuildPrintWithState+	, successfully  	-- * Errors 	, throw

@@ -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.

@@ -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+        }+

@@ -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   

@@ -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)- 		+++

@@ -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)

@@ -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					+

@@ -25,9 +25,6 @@ type Log 	= Seq Line type Line	= ByteString -instance Show Log where- show	= toString-	  -- | O(1) No logs here. empty :: Log

@@ -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 }++

@@ -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+

@@ -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] 

@@ -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`.

@@ -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: