buildbox 1.0.2.0 → 1.2.0.0

raw patch · 16 files changed

+425/−163 lines, 16 filesdep +randomdep −unixPVP ok

version bump matches the API change (PVP)

Dependencies added: random

Dependencies removed: unix

API changes (from Hackage documentation)

Files

• BuildBox/Benchmark/Compare.hs +2/−2
• BuildBox/Benchmark/Pretty.hs +8/−8
• BuildBox/Build.hs +31/−7
• BuildBox/Build/Base.hs +50/−106
• BuildBox/Build/BuildError.hs +78/−0
• BuildBox/Build/BuildState.hs +36/−0
• BuildBox/Build/Testable.hs +1/−0
• BuildBox/Command/File.hs +34/−9
• BuildBox/Command/Mail.hs +1/−1
• BuildBox/Cron.hs +1/−0
• BuildBox/Cron/Schedule.hs +10/−10
• BuildBox/FileFormat/BuildResults.hs +62/−0
• BuildBox/IO/Directory.hs +73/−0
• BuildBox/IO/File.hs +9/−0
• BuildBox/Pretty.hs +22/−18
• buildbox.cabal +7/−2

@@ -42,9 +42,9 @@ 		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelSys	 mBaseline current ]     in	vcat-	[ nest 15 pprBenchResultAspectHeader+	[ nest 30 pprBenchResultAspectHeader 	, vcat	$ punctuate (text "\n")-		$ map (\c -> (text (benchResultName c) $$ (nest 15 $ comparison c)))+		$ map (\c -> (text (benchResultName c) $$ (nest 30 $ comparison c))) 		$ currents ]  

@@ -13,8 +13,8 @@ pprBenchResultAspectHeader :: Doc pprBenchResultAspectHeader  	=  vcat-	[ text "    aspect       min   ref%   avg   ref%   max   ref%   spread% "-	, text "    ---------    ----------   ----------   ----------   ------- " ]+	[ text "    aspect       min    ref%   avg    ref%   max    ref%   spread% "+	, text "    ---------    -----------   -----------   -----------   ------- " ]   -- | Pretty print an aspect of a benchmark result.@@ -33,9 +33,9 @@ 	, Just (tmin', tavg', tmax')	<- takeMinAvgMaxOfBenchResult aspect result' 	= Just	$   text "    " 		<>  padL 10 (ppr aspect)-		<+> (padR 12 $ pprFloatRef tmin tmin')-		<+> (padR 12 $ pprFloatRef tavg tavg')-		<+> (padR 12 $ pprFloatRef tmax tmax')+		<+> (padR 13 $ pprFloatRef tmin tmin')+		<+> (padR 13 $ pprFloatRef tavg tavg')+		<+> (padR 13 $ pprFloatRef tmax tmax') 		<+> (padR 8  $ ppr spreadPercent)   	| Just (tmin, tavg, tmax)	<- takeMinAvgMaxOfBenchResult aspect result@@ -43,9 +43,9 @@ 	, spreadPercent			<- (floor $ (spread / tavg) * 100) :: Integer 	= Just	$   text "    " 		<>  padL 10 (ppr aspect)-		<+> (padR 12 $ (pprFloatTime tmin <> text "     "))-		<+> (padR 12 $ (pprFloatTime tavg <> text "     "))-		<+> (padR 12 $ (pprFloatTime tmax <> text "     "))+		<+> (padR 13 $ (pprFloatTime tmin <> text "     "))+		<+> (padR 13 $ (pprFloatTime tavg <> text "     "))+		<+> (padR 13 $ (pprFloatTime tmax <> text "     ")) 		<+> (padR 8 $ ppr spreadPercent) 	 	| otherwise

@@ -2,25 +2,49 @@ -- | Defines the main `Build` monad and common utils. module BuildBox.Build  	( module BuildBox.Build.Testable+	, module BuildBox.Build.BuildError+	, module BuildBox.Build.BuildState 	, Build-	, BuildError(..)-	, BuildConfig(..)-	, buildConfigDefault++	-- * Building 	, runBuild 	, runBuildPrint-	, runBuildPrintWithConfig+	, runBuildPrintWithState++	-- * Errors 	, throw+	, needs++	-- * Utils 	, io-	, logSystem+	, whenM++	-- * Output 	, out 	, outLn 	, outBlank 	, outLine 	, outLINE-	, whenM)+	, logSystem)+ where import BuildBox.Build.Base import BuildBox.Build.Testable+import BuildBox.Build.BuildState+import BuildBox.Build.BuildError+import Control.Monad.State+import System.IO -	++-- | Log a system command to the handle in our `BuildConfig`, if any.+logSystem :: String -> Build ()+logSystem cmd+ = do	mHandle	<- gets buildStateLogSystem+	case mHandle of+	 Nothing	-> return ()+	 Just handle	+	  -> do	io $ hPutStr   handle "buildbox system: "+		io $ hPutStrLn handle cmd+		return ()+ 

@@ -1,123 +1,43 @@ {-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE ExistentialQuantification #-}  module BuildBox.Build.Base where import BuildBox.Pretty+import BuildBox.Build.BuildError+import BuildBox.Build.BuildState import Control.Monad.Error-import Control.Monad.Reader+import Control.Monad.State import System.IO import System.IO.Error-import System.Exit-import BuildBox.Data.Log		(Log)-import qualified BuildBox.Data.Log	as Log-+import System.Random+import System.Directory  -- | The builder monad encapsulates and IO action that can fail with an error,  --   and also read some global configuration info.-type Build a 	= ErrorT BuildError (ReaderT BuildConfig IO) a---- BuildError ---------------------------------------------------------------------------------------- | The errors we recognise.-data BuildError-	-- | Some generic error-	= ErrorOther String--	-- | Some system command fell over, and it barfed out the given stdout and stderr.-	| ErrorSystemCmdFailed-		{ buildErrorCmd 	:: String-		, buildErrorCode	:: ExitCode-		, buildErrorStdout	:: Log-		, buildErrorStderr	:: Log }-		-	-- | Some other IO action failed.-	| ErrorIOError IOError--	-- | Some property `check` was supposed to return the given boolean value, but it didn't.-	| forall prop. Show prop => ErrorCheckFailed Bool prop	--instance Error BuildError where- strMsg s = ErrorOther s--instance Pretty BuildError where- ppr err-  = case err of-	ErrorOther str-	 -> text "Other error: " <> text str--	ErrorSystemCmdFailed{}-	 -> vcat -		[ text "System command failure."-		, text "    command: " <> (text $ buildErrorCmd err)-		, text "  exit code: " <> (text $ show $ buildErrorCode err)-		, blank-		, if (not $ Log.null $ buildErrorStdout err)-		   then vcat 	[ text "-- stdout (last 10 lines) ------------------------------------------------------"-				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStdout err]-		   else text ""-		, blank-		, if (not $ Log.null $ buildErrorStderr err)-		   then vcat	[ text "-- stderr (last 10 lines) ------------------------------------------------------"-				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStderr err]-		   else text ""-		-		, 		  text "--------------------------------------------------------------------------------" ]-	-	ErrorIOError ioerr-	 -> text "IO error: " <> (text $ show ioerr)--	ErrorCheckFailed expected prop-	 -> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)--instance Show BuildError where- show err = render $ ppr err+type Build a 	= ErrorT BuildError (StateT BuildState IO) a  --- BuildConfig --------------------------------------------------------------------------------------- | Global builder configuration.-data BuildConfig-	= BuildConfig-	{ -- | Log all system commands executed to this file handle.-	  buildConfigLogSystem	:: Maybe Handle }---- | The default build config.-buildConfigDefault :: BuildConfig-buildConfigDefault-	= BuildConfig-	{ buildConfigLogSystem	= Nothing }---- | Log a system command to the handle in our `BuildConfig`, if any.-logSystem :: String -> Build ()-logSystem cmd- = do	mHandle	<- asks buildConfigLogSystem-	case mHandle of-	 Nothing	-> return ()-	 Just handle	-	  -> do	io $ hPutStr   handle "buildbox system: "-		io $ hPutStrLn handle cmd-		return ()- -- Build --------------------------------------------------------------------------------------------- | Throw an error in the build monad.-throw :: BuildError -> Build a-throw	= throwError- -- | Run a build command.-runBuild :: Build a -> IO (Either BuildError a)-runBuild build-	= runReaderT (runErrorT build) buildConfigDefault+runBuild :: FilePath -> Build a -> IO (Either BuildError a)+runBuild scratchDir build+ = do	uid		<- getUniqueId+	let state	= buildStateDefault uid scratchDir+	evalStateT (runErrorT build) state   -- | Run a build command, reporting whether it succeeded to the console. --   If it succeeded then return Just the result, else Nothing.-runBuildPrint :: Build a -> IO (Maybe a)-runBuildPrint - 	= runBuildPrintWithConfig buildConfigDefault+runBuildPrint :: FilePath -> Build a -> IO (Maybe a)+runBuildPrint scratchDir build+ = do	uid		<- getUniqueId+	let state	= buildStateDefault uid scratchDir+	runBuildPrintWithState state build   -- | Like `runBuildPrintWithConfig` but also takes a `BuildConfig`.-runBuildPrintWithConfig :: BuildConfig -> Build a -> IO (Maybe a)-runBuildPrintWithConfig config build- = do	result	<- runReaderT (runErrorT build) config+runBuildPrintWithState :: BuildState -> Build a -> IO (Maybe a)+runBuildPrintWithState state build+ = do	result	<- evalStateT (runErrorT build) state 	case result of 	 Left err 	  -> do	putStrLn "\nBuild failed"@@ -130,6 +50,29 @@ 		return $ Just x  +-- | Get a unique(ish) id for this process.+--   The random seeds the global generator with the cpu time in psecs, which should be good enough.+getUniqueId :: IO Integer+getUniqueId+ 	= randomRIO (0, 1000000000)	++-- Errors -----------------------------------------------------------------------------------------+-- | Throw an error in the build monad.+throw :: BuildError -> Build a+throw	= throwError+++-- | Throw a needs error saying we needs the given file.+needs :: FilePath -> Build ()+needs filePath+ = do	isFile	<- io $ doesFileExist filePath+	isDir	<- io $ doesDirectoryExist filePath+	+	if isFile || isDir+	 then return ()+	 else throw $ ErrorNeeds filePath++ -- Utils ------------------------------------------------------------------------------------------ -- | Lift an IO action into the build monad. --   If the action throws any exceptions they get caught and turned into@@ -144,6 +87,14 @@ 	 Right res	-> return res  +-- | Like `when`, but with teh monadz.+whenM :: Monad m => m Bool -> m () -> m ()+whenM cb cx+ = do	b	<- cb+	if b then cx else return ()+++-- Output ----------------------------------------------------------------------------------------- -- | Print some text to stdout. out :: Pretty a => a -> Build () out str	@@ -169,11 +120,4 @@ -- | Print a @=====@ line to stdout outLINE :: Build () outLINE		= io $ putStr (replicate 80 '=' ++ "\n")----- | Like `when`, but with teh monadz.-whenM :: Monad m => m Bool -> m () -> m ()-whenM cb cx- = do	b	<- cb-	if b then cx else return () 	

@@ -0,0 +1,78 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS_HADDOCK hide #-}++module BuildBox.Build.BuildError+	(BuildError(..))+where+import BuildBox.Pretty+import System.Exit+import Control.Monad.Error+import BuildBox.Data.Log		(Log)+import qualified BuildBox.Data.Log	as Log+++-- BuildError -------------------------------------------------------------------------------------+-- | The errors we recognise.+data BuildError+	-- | Some generic error+	= ErrorOther String++	-- | Some system command fell over, and it barfed out the given stdout and stderr.+	| ErrorSystemCmdFailed+		{ buildErrorCmd 	:: String+		, buildErrorCode	:: ExitCode+		, buildErrorStdout	:: Log+		, buildErrorStderr	:: Log }+		+	-- | Some miscellanous IO action failed.+	| ErrorIOError IOError++	-- | Some property `check` was supposed to return the given boolean value, but it didn't.+	| forall prop. Show prop => ErrorCheckFailed Bool prop	++	-- | A build command needs the following file to continue.+	--   This can be used for writing make-like bots.+	| ErrorNeeds FilePath+	++instance Error BuildError where+ strMsg s = ErrorOther s++instance Pretty BuildError where+ ppr err+  = case err of+	ErrorOther str+	 -> text "Other error: " <> text str++	ErrorSystemCmdFailed{}+	 -> vcat +		[ text "System command failure."+		, text "    command: " <> (text $ buildErrorCmd err)+		, text "  exit code: " <> (text $ show $ buildErrorCode err)+		, blank+		, if (not $ Log.null $ buildErrorStdout err)+		   then vcat 	[ text "-- stdout (last 10 lines) ------------------------------------------------------"+				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStdout err]+		   else text ""+		, blank+		, if (not $ Log.null $ buildErrorStderr err)+		   then vcat	[ text "-- stderr (last 10 lines) ------------------------------------------------------"+				, text $ Log.toString $ Log.lastLines 10 $ buildErrorStderr err]+		   else text ""+		+		, 		  text "--------------------------------------------------------------------------------" ]+	+	ErrorIOError ioerr+	 -> text "IO error: " <> (text $ show ioerr)++	ErrorCheckFailed expected prop+	 -> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)++	ErrorNeeds filePath+	 -> text "Build needs: " <> text filePath+++instance Show BuildError where+ show err = render $ ppr err++

@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK hide #-}++module BuildBox.Build.BuildState+	( BuildState(..)+	, buildStateDefault)+where+import System.IO++-- BuildConfig ------------------------------------------------------------------------------------+-- | Global builder configuration.+data BuildState+	= BuildState+	{ -- | Log all system commands executed to this file handle.+	  buildStateLogSystem	:: Maybe Handle+	+	  -- | Uniqueish id for this build process.+	  --   On POSIX we'd use the PID, but that doesn't work on Windows.+	  --   The id is initialised by the Haskell random number generator on startup.+	, buildStateId		:: Integer+	+	  -- | Sequence number for generating fresh file names.+	, buildStateSeq		:: Integer +	+	  -- | Scratch directory for making temp files.+	, buildStateScratchDir	:: FilePath }+++-- | The default build config.+buildStateDefault :: Integer -> FilePath -> BuildState+buildStateDefault uniqId scratchDir +	= BuildState+	{ buildStateLogSystem	= Nothing+	, buildStateId		= uniqId+	, buildStateSeq		= 0 +	, buildStateScratchDir	= scratchDir }+

@@ -10,6 +10,7 @@ 	, outCheckFalseOk) where import BuildBox.Build.Base	+import BuildBox.Build.BuildError import Control.Monad.Error  

@@ -8,12 +8,10 @@ 	, ensureDir 	, withTempFile) where-import BuildBox.Build.Base-import BuildBox.Build.Testable+import BuildBox.Build import BuildBox.Command.System-import System.Posix.Temp import System.Directory-import System.IO+import Control.Monad.State  -- | Properties of the file system we can test for. data PropFile@@ -98,12 +96,8 @@ -- | Create a temp file, pass it to some command, then delete the file after the command finishes. withTempFile :: (FilePath -> Build a) -> Build a withTempFile build- = do	(fileName, handle)	<- io $ mkstemp "/tmp/buildbox-XXXXXX"+ = do	fileName	<- newTempFile -	-- We just want the file name here, so close the handle to let the real-	-- build command write to it however it wants.-	io $ hClose handle-	 	-- run the real command 	result	<- build fileName 	@@ -112,3 +106,34 @@ 	 	return result 	++-- | Allocate a new temporary file name+newTempFile :: Build FilePath+newTempFile + = do	buildDir	<- gets buildStateScratchDir+	buildId		<- gets buildStateId +	buildSeq	<- gets buildStateSeq +	+	-- Increment the sequence number.+	modify $ \s -> s { buildStateSeq = buildStateSeq s + 1 }+	+	-- Build the file name we'll try to use.+	fileName	<- io $ canonicalizePath +			$  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+++++

@@ -64,7 +64,7 @@ 	hostName	<- getHostName 	let dayNum	= toModifiedJulianDay $ utctDay utime 	let secTime	= utctDayTime utime-	let messageId	=  "<" ++ show dayNum ++ "." ++ show secTime+	let messageId	=  "<" ++ show dayNum ++ "." ++ (init $ show secTime) 			++ "@" ++ hostName ++ ">" 		 	return	$ Mail

@@ -35,6 +35,7 @@ 				, eventLastEnded	= Just endTime }  		let schedule'	= adjustEventOfSchedule event' schedule+	 		cronLoop schedule' 				 		

@@ -116,6 +116,13 @@ --   The `SkipFirst` modifier is ignored, as this is handled separately. eventCouldStartAt :: UTCTime -> Event -> Bool eventCouldStartAt curTime event+	-- If the event has never started or ended, and is marked as immediate,+	-- then start it right away.+	| Nothing		<- eventLastStarted  event+	, Nothing		<- eventLastEnded    event+	, Just Immediate	<- eventWhenModifier event+	= True+ 	-- If the current end time is before the start time, then the most 	-- recent iteration is still running, so don't start it again. 	| Just lastStarted	<- eventLastStarted event@@ -128,13 +135,6 @@ 	, curTime < waitTime 	= False -	-- If the event has never started or ended, and is marked as immediate,-	-- then start it right away.-	| Nothing		<- eventLastStarted  event-	, Nothing		<- eventLastEnded    event-	, Just Immediate	<- eventWhenModifier event-	= True- 	-- Otherwise we have to look at the real schedule. 	| otherwise 	= case eventWhen event of@@ -152,10 +152,10 @@ 			(eventLastEnded event) 	 		Daily timeOfDay-		 -- If it's been more than a day since we last started it, then do it now.+		 -- If it's been less than a day since we last started it, then don't do it yet. 		 | Just lastStarted	<- eventLastStarted event-		 , (curTime `diffUTCTime` lastStarted) > day-		 -> True+		 , (curTime `diffUTCTime` lastStarted) < day+		 -> False 		 		 | otherwise 		 -> let	-- If we were going to run it today, this is when it would be.

@@ -0,0 +1,62 @@++module BuildBox.FileFormat.BuildResults+	( BuildResults(..)+	, mergeResults)+where+import BuildBox.Time+import BuildBox.Benchmark+import BuildBox.Command.Environment+import BuildBox.Pretty+import Data.List+++-- | A simple build results file format.+data BuildResults+	= BuildResults+	{ buildResultTime		:: UTCTime+	, buildResultEnvironment	:: Environment+	, buildResultBench		:: [BenchResult] }+	deriving (Show, Read)++instance Pretty BuildResults where+ ppr results+	= hang (ppr "BuildResults") 2 $ vcat+	[ ppr "time: " <> (ppr $ buildResultTime results)+	, ppr $ buildResultEnvironment results+	, ppr ""+	, vcat 	$ punctuate (ppr "\n") +		$ map ppr +		$ buildResultBench results ]+++-- | Merge some BuildResults.+--   If we have data for a named benchmark in multiple `BuildResults`,+--   then we take the first one in the list.+--   The resultTime and environment is taken from the last `BuildResults`,+--   in the list.+mergeResults :: [BuildResults] -> BuildResults+mergeResults results+ = let	+	-- All the available benchResults from all files.+	benchResults+		= concatMap buildResultBench results++	-- Get a the names of all the available benchmarks.+	benchNames  +		= sort $ nub+		$ map benchResultName+		$ concatMap buildResultBench results ++	-- Merge all the results+	Just newBenchResults+		= sequence +		$ [ find (\br -> benchResultName br == name) benchResults	+				| name <- benchNames]+			+	-- Use the timestamp and environment from the last one.+	(lastResults : _) = reverse results+		+   in BuildResults+		{ buildResultTime	 = buildResultTime lastResults+		, buildResultEnvironment = buildResultEnvironment lastResults+		, buildResultBench	 = newBenchResults }

@@ -0,0 +1,73 @@++-- | Directory utils that don't need to be in the Build monad.+module BuildBox.IO.Directory+	( lsFilesIn+	, lsDirsIn+	, traceFilesFrom)+where+import System.Directory+import Control.Monad+import Control.Monad.Trans+import Data.List+import Data.Sequence		(Seq)+import qualified Data.Sequence	as Seq+++-- | Get the names of all files in a directory.+--   This filters out the fake files like '.' and '..'+lsFilesIn :: MonadIO m => String -> m [String]+lsFilesIn path+ = do 	contents <- liftIO $ getDirectoryContents path+	+	-- filter out directories+	files	<- filterM (\p -> liftM not $ liftIO $ doesDirectoryExist p) +		$ map (\f -> path ++ "/" ++ f)+		$ dropDotPaths contents++	return	$ sort files+++-- | Get the names of all the dirs in this one.+--   This filters out the fake files like '.' and '..'+lsDirsIn :: MonadIO m => String	 -> m [String]+lsDirsIn path+ = do + 	contents <- liftIO $ getDirectoryContents path+	+	-- only keep directories+	dirs	<- filterM (liftIO . doesDirectoryExist)+		$  map (\f -> path ++ "/" ++ f)+		$  dropDotPaths contents++	return	$ sort dirs+++-- | Get all the files reachable from this directory+traceFilesFrom :: FilePath -> IO (Seq FilePath)+traceFilesFrom path+ = do	isDir	<- doesDirectoryExist path+	isFile	<- doesFileExist      path++	let result+		| isDir 	+		= do	contents <- liftM dropDotPaths+			 	 $  getDirectoryContents path++			liftM (join  . Seq.fromList)+				$ mapM traceFilesFrom +				$ map (\f -> path ++ "/" ++ f) +				$ contents++		| isFile+		=	return	$ Seq.singleton path+		+		| otherwise+		=	return	$ Seq.empty+	+	result+++-- | Drop out the fake '.' and '..' dirst from a list of paths.+dropDotPaths :: [FilePath] -> [FilePath]+dropDotPaths xx+	= filter (\f -> f /= "." && f /= "..") xx

@@ -0,0 +1,9 @@++module BuildBox.IO.File+	(atomicWriteFile)+where+++atomicWriteFile :: FilePath -> String -> IO ()+atomicWriteFile filePath str+ = do	writeFile filePath str

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}  -- | Pretty printing utils. module BuildBox.Pretty@@ -6,7 +6,7 @@ 	, Pretty(..) 	, pprPSecTime 	, pprFloatTime-	, pprFloatSF+	, pprFloatSR 	, pprFloatRef 	, padRc, padR 	, padLc, padL@@ -40,9 +40,6 @@ 	  -- To handle type defaulting-ten12 :: Float-ten12 = 10^(12 :: Integer)- ten12i :: Integer ten12i = 10^(12 :: Integer) @@ -50,36 +47,43 @@ -- | Print a number of picoseconds as a time. pprPSecTime :: Integer -> Doc pprPSecTime psecs-  	=  text (show (psecs `div` ten12i))+  	=  text (show (psecs `quot` ten12i)) 	<> text "." - 	<> (text $ (take 3 $ render $ padRc 12 '0' $ text $ show $ psecs `mod` ten12i))+ 	<> (text $ (take 3 $ render $ padRc 12 '0' $ text $ show $ psecs `rem` ten12i))   -- | Print a float number of seconds as a time. pprFloatTime :: Float -> Doc pprFloatTime stime-  = let	psecs	= truncate (stime * ten12)-    in	pprPSecTime psecs+  = let (secs :: Integer, frac :: Float)	+			= properFraction stime +	msecs		= frac * 1000+    in	text (show secs) +	 <> text "."+	 <> (padRc 3 '0' $ text $ show $ ((round $ msecs) :: Integer) ) + -- | Pretty print a signed float, with a percentage change relative to a reference figure. --   Comes out like @0.235( +5)@ for a +5 percent swing. pprFloatRef :: Float -> Float -> Doc pprFloatRef stime stimeRef - = let	psecs		= truncate (stime    * ten12)-	diff		= (1 - (stimeRef / stime))*100-   in	pprPSecTime psecs-	 <> parens (padR 3 $ pprFloatSF diff)+ = let	diff		= ((stime - stimeRef) / stimeRef )*100+   in	pprFloatTime stime+	 <> parens (padR 4 $ pprFloatSR diff)  --- | Print a float number of seconds, flooring it and, prefixing with @+@ or @-@ appropriately.-pprFloatSF :: Float -> Doc-pprFloatSF p+-- | Print a float number of seconds, rounding it and, prefixing with @+@ or @-@ appropriately.+pprFloatSR :: Float -> Doc+pprFloatSR p+	| p == 0+	= text "----"+  	| p > 0-	= text "+" <> (ppr $ (floor p :: Integer))+	= text "+" <> (ppr $ (round p :: Integer)) 	 	| otherwise-	= text "-" <> (ppr $ (floor (negate p) :: Integer))+	= text "-" <> (ppr $ (round (negate p) :: Integer))   -- | Right justify a doc, padding with a given character.

@@ -1,5 +1,5 @@ Name:                buildbox-Version:             1.0.2.0+Version:             1.2.0.0 License:             BSD3 License-file:        LICENSE Author:              Ben Lippmeier@@ -29,7 +29,7 @@         mtl                  == 1.1.*,         directory            == 1.0.*,         process              == 1.0.*,-        unix                 == 2.4.*,+        random               == 1.0.*,         pretty               == 1.0.*,         old-locale           == 1.0.*,         containers           == 0.3.*,@@ -45,6 +45,8 @@         BuildBox.Benchmark.TimeAspect         BuildBox.Benchmark         BuildBox.Build.Testable+        BuildBox.Build.BuildError+        BuildBox.Build.BuildState         BuildBox.Build         BuildBox.Command.Environment         BuildBox.Command.File@@ -54,6 +56,9 @@         BuildBox.Command.Sleep         BuildBox.Cron.Schedule         BuildBox.Cron+        BuildBox.FileFormat.BuildResults+        BuildBox.IO.Directory+        BuildBox.IO.File         BuildBox.Pretty         BuildBox.Time         BuildBox