buildbox 1.2.1.0 → 1.3.0.0

raw patch · 22 files changed

+1277/−419 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• BuildBox.hs +12/−4
• BuildBox/Aspect.hs +86/−0
• BuildBox/Aspect/Aspect.hs +231/−0
• BuildBox/Aspect/Comparison.hs +91/−0
• BuildBox/Aspect/Detail.hs +63/−0
• BuildBox/Aspect/Single.hs +26/−0
• BuildBox/Aspect/Stats.hs +54/−0
• BuildBox/Aspect/Units.hs +233/−0
• BuildBox/Benchmark.hs +38/−81
• BuildBox/Benchmark/Base.hs +0/−78
• BuildBox/Benchmark/BenchResult.hs +252/−0
• BuildBox/Benchmark/Benchmark.hs +25/−0
• BuildBox/Benchmark/Compare.hs +0/−50
• BuildBox/Benchmark/Pretty.hs +0/−52
• BuildBox/Benchmark/TimeAspect.hs +0/−86
• BuildBox/Build/Base.hs +2/−0
• BuildBox/Data/Dividable.hs +13/−0
• BuildBox/FileFormat/BuildResults.hs +2/−1
• BuildBox/IO/File.hs +3/−2
• BuildBox/Pretty.hs +61/−54
• BuildBox/Reports/BenchResult.hs +68/−0
• buildbox.cabal +17/−11

@@ -1,8 +1,8 @@  module BuildBox-	( module BuildBox.Build+	( module BuildBox.Aspect 	, module BuildBox.Benchmark-	, module BuildBox.Pretty+	, module BuildBox.Build 	, module BuildBox.Command.Sleep 	, module BuildBox.Command.System 	, module BuildBox.Command.Network@@ -10,11 +10,15 @@ 	, module BuildBox.Command.Environment 	, module BuildBox.Command.File 	, module BuildBox.Cron+	, module BuildBox.FileFormat.BuildResults+	, module BuildBox.IO.Directory+	, module BuildBox.Pretty+	, module BuildBox.Reports.BenchResult 	, module BuildBox.Time) where-import BuildBox.Build+import BuildBox.Aspect import BuildBox.Benchmark-import BuildBox.Pretty+import BuildBox.Build import BuildBox.Command.Sleep import BuildBox.Command.System import BuildBox.Command.Network@@ -22,4 +26,8 @@ import BuildBox.Command.Environment import BuildBox.Command.File import BuildBox.Cron+import BuildBox.FileFormat.BuildResults+import BuildBox.IO.Directory+import BuildBox.Pretty+import BuildBox.Reports.BenchResult import BuildBox.Time

@@ -0,0 +1,86 @@++-- | An aspect is a piece of data obtained from running a benchmark, like its +--   total runtime, heap usage, or executable size. Aspects have physical+--   units, so runtime is in seconds, and executable size is in bytes. The type system+--   ensures that you can't mess up the units, such as by treating executable size as though it was+--   measured in seconds.+--+--   Aspects are also parameterised over a carrier constructor, which is the collection type+--   used to store the data. For single valued data use the `Single` constructor. For multi valued+--   data use the @[]@ (the list constructor). Use this when you have several readings for+--   the same benchmark, like runtimes from multiple independent runs. +--   Other useful constructors are `Stats`, `Comparison` and `StatsComparison`.+--+--   Once you have a many-valued aspect, you can use `makeAspectStats` to compute statistics+--   from the data.+-- +--   Here is a worked example:+--+--  @ +-- -- This is our original, single valued data.+--someData :: [`WithUnits` (`Aspect` `Single`)]+--someData =  [ `Time` `TotalWall` \``secs`\`  100+--            , `Time` `TotalWall` \``secs`\`  85+--            , `Size` `ExeSize`   \``bytes`\` 1024+--            , `Used` `HeapMax`   \``bytes`\` 100000+--            , `Used` `HeapMax`   \``bytes`\` 100100]+--  @+--  +--  @+-- -- Collate the data, which groups all the readings for the same aspect into a list.+-- -- Note that the carrier constructor is now [].+--collated  :: [`WithUnits` (`Aspect` [])]+--collated  = `collateWithUnits` someData+-- ...+--show collated +--  =>   [ `WithSeconds` (`Time` `TotalWall` [`Seconds` 100.0, `Seconds` 85.0])+--       , `WithBytes`   (`Used` `HeapMax`   [`Bytes` 100000,  `Bytes` 100100])+--       , `WithBytes`   (`Size` `ExeSize`   [`Bytes` 1024])]+--  @+--+--  @+-- -- Extract statistics from the collated data.+--analysed   :: [`WithUnits` (`Aspect` `Stats`)]+--analysed   =  map (`liftWithUnits` `makeAspectStats`) collated+-- ...+--show analysed+--  =>   [ `WithSeconds` (`Time` `TotalWall` (`Stats` {`statsMin` = `Seconds` 85.0, `statsAvg` = `Seconds` 92.5, `statsMax` = `Seconds` 100.0}))+--       , `WithBytes`   (`Used` `HeapMax`   (`Stats` {`statsMin` = `Bytes` 100000, `statsAvg` = `Bytes` 100050, `statsMax` = `Bytes` 100100}))+--       , `WithBytes`   (`Size` `ExeSize`   (`Stats` {`statsMin` = `Bytes` 1024,   `statsAvg` = `Bytes` 1024,   `statsMax` = `Bytes` 1024}))]+-- @+module BuildBox.Aspect+	( module BuildBox.Aspect.Units+	, module BuildBox.Aspect.Detail+	, module BuildBox.Aspect.Stats+	, module BuildBox.Aspect.Single+	, module BuildBox.Aspect.Comparison++	-- * Aspects+	, Aspect	(..)+	, makeAspect+	, splitAspect++	-- * Statistics and comparisons+	, makeAspectStats+	, makeAspectComparison+	, makeAspectComparisons++	-- * Application functions+	, appAspect+	, appAspectWithUnits++	-- * Lifting functions+	, liftAspect+	, liftAspect2)+where+import BuildBox.Aspect.Aspect+import BuildBox.Aspect.Detail+import BuildBox.Aspect.Stats+import BuildBox.Aspect.Units+import BuildBox.Aspect.Single+import BuildBox.Aspect.Comparison+++++

@@ -0,0 +1,231 @@+{-# LANGUAGE 	ScopedTypeVariables, StandaloneDeriving,+		GADTs, FlexibleContexts, RankNTypes,+		UndecidableInstances, KindSignatures #-}+{-# OPTIONS_HADDOCK hide #-}+module BuildBox.Aspect.Aspect+	( Aspect	(..)+	, makeAspect+	, splitAspect+	, makeAspectStats+	, makeAspectComparison+	, makeAspectComparisons++	-- * Application functions+	, appAspect+	, appAspectWithUnits++	-- * Lifting functions+	, liftAspect+	, liftAspect2)+where+import BuildBox.Aspect.Single+import BuildBox.Aspect.Units+import BuildBox.Aspect.Detail+import BuildBox.Aspect.Stats+import BuildBox.Aspect.Comparison+import BuildBox.Pretty+import Text.Read+import Data.List+import qualified Data.Map	as Map+++-- | Holds a detail about a benchmark.+--+--   The @c@ is the type constructor of the carrier that holds the data.+--+--   Useful instances for @c@ include `Single`, `[ ]`, `Stats`, `Comparison` and `StatsComparison`.+--+data Aspect (c :: * -> *) units where+	Time	:: Timed	-> c Seconds	-> Aspect c Seconds+	Size	:: Sized	-> c Bytes	-> Aspect c Bytes+	Used	:: Used		-> c Bytes	-> Aspect c Bytes++deriving instance Show (c units) => Show (Aspect c units)	++-- We need to write the read instance manually because it requires makeAspect+instance (  HasUnits (c units) units+	 ,  Read  (c units)) +	 => Read (Aspect c units) where+ readPrec +  = do	tok <- lexP+	case tok of+	 Punc  "("+	  -> do	aspect		<- readPrec+		Punc ")"	<- lexP+		return aspect+		+	 Ident "Time" +	  -> do	timed		<- readPrec+		dat		<- readPrec+		let Just aspect	= makeAspect (DetailTimed timed) dat+		return aspect+	+	 Ident "Size"+	  -> do	sized		<- readPrec+		dat		<- readPrec+		let Just aspect	= makeAspect (DetailSized sized) dat+		return aspect++	 Ident "Used"+	  -> do	used		<- readPrec+		dat		<- readPrec+		let Just aspect	= makeAspect (DetailUsed used) dat+		return aspect+		+	 _ -> pfail+++instance ( Pretty (c Seconds)+	 , Pretty (c Bytes))+ 	 => Pretty (Aspect c units) where+ ppr aa+  = case aa of+	Time timed dat	-> padL 30 (ppr timed) <+> text ":" <+> ppr dat+	Size sized dat	-> padL 30 (ppr sized) <+> text ":" <+> ppr dat+	Used used  dat	-> padL 30 (ppr used)  <+> text ":" <+> ppr dat++	++-- | Split an aspect into its named detail and data.+splitAspect :: Aspect c units -> (Detail, c units)+splitAspect aa+ = case aa of+	Time timed val		-> (DetailTimed timed, val)+	Size sized val		-> (DetailSized sized, val)+	Used used  val		-> (DetailUsed  used,  val)+++-- | Make an aspect from a named detail and data.+--   If the detail doesn't match the units of the data then `Nothing`.+makeAspect+	:: HasUnits (c units) units +	=> Detail -> c units -> Maybe (Aspect c units)++makeAspect detail (val :: c units)+ = case hasUnits val :: Maybe (IsUnits units) of+	Just IsSeconds+	 -> case detail of+		DetailTimed timed	-> Just (Time timed val)+		_			-> Nothing++	Just IsBytes+	 -> case detail of+		DetailUsed  used	-> Just (Used used  val)+		DetailSized sized	-> Just (Size sized val)+		_			-> Nothing++	Nothing -> Nothing++++-- Collate ----------------------------------------------------------------------------------------+instance Collatable Aspect where+ collate as+  = let	-- This Just match will always succeed provided the implementation of gather is correct.+	Just as' = sequence +		 $ map (uncurry makeAspect) +		 $ gather [(detail, val) | (detail, (Single val)) <- map splitAspect as]+    in	as'++++-- | Gather a list of pairs on the first element+--	gather [(0, 1), (0, 2), (3, 2), (4, 5), (3, 1)] +--			= [(0, [1, 2]), (3, [2, 1]), (4, [5])]+gather :: Ord a => [(a, b)] -> [(a, [b])]+gather	xx	+ 	= Map.toList +	$ foldr (\(k, v) m -> +			Map.insertWith +				(\x xs -> x ++ xs) +				k [v] m) +		Map.empty +		xx+++-- Stats ------------------------------------------------------------------------------------------+-- | Compute statistics for many-valued aspects.+makeAspectStats :: Aspect [] units -> Aspect Stats units+makeAspectStats aspect+ = case aspect of+	Time timed dat	-> Time timed (makeStats dat)+	Size sized dat	-> Size sized (makeStats dat)+	Used used  dat	-> Used used  (makeStats dat)+++-- Comparison -------------------------------------------------------------------------------------+-- | Compare lists of aspects. The first argument is the baseline.+makeAspectComparisons +	:: Real units +	=> [Aspect Stats units] -> [Aspect Stats units] -> [Aspect StatsComparison units]+	+makeAspectComparisons base new+	= map (makeAspectComparison base) new+++-- | Lookup the baseline result for some aspect and produce a comparison.+makeAspectComparison+	:: Real units+	=> [Aspect Stats units] -> Aspect Stats units -> Aspect StatsComparison units++makeAspectComparison base aspect+ = case lookupAspect base aspect of+	Just aspectBase	-> liftAspect2 makeStatsComparison    aspectBase aspect+	Nothing		-> liftAspect  makeStatsComparisonNew aspect+++lookupAspect :: [Aspect Stats units] -> Aspect Stats units -> Maybe (Aspect Stats units)+lookupAspect base aspect+ = let	detail	= fst $ splitAspect aspect+   in	find (\a -> (fst $ splitAspect a) == detail) base++++-- Application ------------------------------------------------------------------------------------+-- | Apply a function to the data in an aspect+appAspect +	:: Real units +	=> (c units -> b) -> Aspect c units -> b++appAspect f aa = f (snd $ splitAspect aa)+	++-- | Apply a function to the data in a wrapped aspect.+appAspectWithUnits +	:: (forall units. Real units => c units -> b) +	-> WithUnits (Aspect c) -> b++appAspectWithUnits f+	= appWithUnits (appAspect f)++-- | Transform the data in an aspect, possibly changing the carrier type.+liftAspect +	:: (c1 units -> c2 units)+	-> Aspect c1 units -> Aspect c2 units++liftAspect f aspect+ = case aspect of+	Time timed dat	-> Time timed (f dat)+	Size sized dat	-> Size sized (f dat)+	Used used dat	-> Used used  (f dat)+++-- Lifting ----------------------------------------------------------------------------------------+-- | Apply a function to the aspect data, producing a new aspect.+--   If the aspect details don't match then `error`.+liftAspect2+	:: (c1 units -> c1 units -> c2 units) +	-> Aspect c1 units -> Aspect c1 units -> Aspect c2 units+	+liftAspect2 f a1 a2+ = case (a1, a2) of+	(Time timed1 dat1, Time timed2 dat2)+	 | timed1 == timed2	-> Time timed1 (f dat1 dat2)++	(Size sized1 dat1, Size sized2 dat2)+	 | sized1 == sized2	-> Size sized1 (f dat1 dat2)++	(Used used1 dat1,  Used used2 dat2)+	 | used1  == used2	-> Used used1 (f dat1 dat2)++	_ -> error "liftAspect2: aspects don't match"

@@ -0,0 +1,91 @@++module BuildBox.Aspect.Comparison+	( +	-- * Comparisons+	  Comparison	(..)+	, makeComparison+	, appSwing+	+	-- * Comparisons of Statistics+	, StatsComparison(..)+	, makeStatsComparison+	, makeStatsComparisonNew+	, predSwingStatsComparison)+where+import BuildBox.Aspect.Stats+import BuildBox.Pretty+import Text.Printf+++-- | The comparison of two values.+data Comparison a	+	-- | Comparison of a recent value with a baseline.+	= Comparison+	{ comparisonBaseline	:: a+	, comparisonRecent	:: a+	, comparisonSwing	:: Double }+	+	-- | A new value that doesn't have a baseline.+	| ComparisonNew+	{ comparisonNew		:: a }+	+	deriving (Read, Show)++instance Pretty a => Pretty (Comparison a) where+	ppr (Comparison _ recent ratio)+		| abs ratio < 0.01	+		= text $ printf "%s (----)"+				(render $ ppr recent)++		| otherwise		+		= text $ printf "%s (%+4.0f)"+				(render $ ppr recent)+				(ratio * 100)++	ppr (ComparisonNew new)+		= (padL 10 $ ppr new)+		++-- | Make a comparison from two values.+makeComparison :: Real a => a -> a -> Comparison a+makeComparison base recent+	= Comparison base recent swing+	+	where	dBase	= fromRational $ toRational base+		dRecent	= fromRational $ toRational recent+		swing = ((dRecent - dBase) / dBase)+++-- | Apply a function to the swing of a comparison.+appSwing :: a -> (Double -> a) -> Comparison b -> a+appSwing def f aa+ = case aa of+	Comparison _ _ swing	-> f swing+	ComparisonNew{}		-> def+	++-- StatsComparison --------------------------------------------------------------------------------+-- | Comparisons of statistics+data StatsComparison a+	= StatsComparison (Stats (Comparison a))+	deriving (Read, Show)++instance Pretty a => Pretty (StatsComparison a) where+	ppr (StatsComparison stats) = ppr stats++-- | Make a comparison of two `Stats`.+makeStatsComparison :: Real a => Stats a -> Stats a -> StatsComparison a+makeStatsComparison x y = StatsComparison (liftStats2 makeComparison x y)+	++-- | Make a `ComparisonNew`.+makeStatsComparisonNew :: Stats a -> StatsComparison a+makeStatsComparisonNew x+	= StatsComparison (liftStats ComparisonNew x)+	++-- | Return `True` if any of the swings in the `StatsComparison` match the given function.+predSwingStatsComparison :: (Double -> Bool) -> StatsComparison a -> Bool+predSwingStatsComparison f (StatsComparison ss)+	= (predStats . (appSwing False)) f ss+	

@@ -0,0 +1,63 @@++-- | The detail is the name of an `Aspect` seprate from its data.+module BuildBox.Aspect.Detail+	( Detail (..)+	, Timed	 (..)+	, Used	 (..)+	, Sized	 (..))+where+import BuildBox.Pretty++data Detail+	= DetailTimed Timed+	| DetailUsed   Used+	| DetailSized  Sized+	deriving (Eq, Ord, Show, Read)+	++-- | Something that takes time to evaluate.+data Timed+	= TotalWall+	| TotalCpu+	| TotalSys+	| KernelWall+	| KernelCpu +	| KernelSys+	deriving (Eq, Ord, Show, Read, Enum)+	+instance Pretty Timed where+ ppr timed+  = case timed of+	TotalWall	-> text "runtime        (wall clock)"+	TotalCpu	-> text "runtime        (cpu usage)"+	TotalSys	-> text "runtime        (sys usage)"++	KernelWall	-> text "kernel runtime (wall clock)"+	KernelCpu	-> text "kernel runtime (cpu usage)"+	KernelSys	-> text "kernel runtime (sys usage)"+		++-- | Some resource used during execution.+data Used+	= HeapMax+	| HeapAlloc+	deriving (Eq, Ord, Show, Read, Enum)+	+instance Pretty Used where+ ppr used+  = case used of+	HeapMax		-> text "maximum heap usage"+	HeapAlloc	-> text "heap allocation"+	+	+-- | Some static size of the benchmark that isn't affected during the run.+data Sized+	= ExeSize+	deriving (Eq, Ord, Show, Read, Enum)+	+instance Pretty Sized where+ ppr sized+  = case sized of+	ExeSize		-> text "executable size"+	+	

@@ -0,0 +1,26 @@++module BuildBox.Aspect.Single+	( Single (..))+where +import BuildBox.Pretty++-- | A single valued piece of data.+data Single a +	= Single a+	deriving (Read, Show)++instance Num a => Num (Single a) where+	(+) (Single f1) (Single f2)	= Single (f1 + f2)+	(-) (Single f1) (Single f2)	= Single (f1 - f2)+	(*) (Single f1) (Single f2)	= Single (f1 * f2)+	abs (Single f1) 		= Single (abs f1)+	signum (Single f1)		= Single (signum f1)+	fromInteger i			= Single (fromInteger i)++instance Eq a => Eq (Single a) where+	(==) (Single f1) (Single f2)	= f1 == f2++instance Pretty a => Pretty (Single a) where+	ppr (Single x)	= ppr x++

@@ -0,0 +1,54 @@++module BuildBox.Aspect.Stats+	( Stats	(..)+	, makeStats+	, predStats+	, liftStats+	, liftStats2)+where+import BuildBox.Pretty+import BuildBox.Data.Dividable+++-- | Statistics extracted from many-valued data.+data Stats a	+	= Stats+	{ statsMin	:: a+	, statsAvg	:: a+	, statsMax	:: a }+	deriving (Read, Show)++instance Pretty a => Pretty (Stats a) where+	ppr (Stats mi av mx)+		=   (ppr mi) <+> text "/" +		<+> (ppr av) <+> text "/"+		<+> (ppr mx)+++-- | Make statistics from a list of values.+makeStats :: (Real a, Dividable a) => [a] -> Stats a+makeStats xs+	= Stats (minimum xs)+		(sum xs `divide` (fromIntegral $ length xs)) +		(maximum xs)+++-- | Return `True` if the predicate matches any of the min, avg, max values.+predStats :: (a -> Bool) -> Stats a -> Bool+predStats f (Stats mi av mx) +	= or [f mi, f av, f mx]+++-- | Lift a function to each component of a `Stats`+liftStats :: (a -> b) -> Stats a -> Stats b+liftStats f (Stats mi av mx)+	= Stats (f mi) (f av) (f mx)+++-- | Lift a binary function to each component of a `Stats`+liftStats2 :: (a -> b -> c) -> Stats a -> Stats b -> Stats c+liftStats2 f (Stats min1 avg1 max1) (Stats min2 avg2 max2)+	= Stats (f min1 min2) (f avg1 avg2) (f max1 max2)+++	

@@ -0,0 +1,233 @@+{-# LANGUAGE StandaloneDeriving, GADTs, MultiParamTypeClasses, FunctionalDependencies, +	     FlexibleInstances,  RankNTypes, UndecidableInstances #-}++-- | Physical units of measure.+module BuildBox.Aspect.Units+	( +	  -- * The unit types+	  Seconds	(..)+	, Bytes		(..)++	  -- * IsUnits+	, IsUnits 	(..)++	  -- * HasUnits+	, HasUnits 	(..)+	+	  -- * WithUnits wrappers+	, WithUnits	(..)+	, secs+	, bytes+	, appWithUnits+	, liftWithUnits+	, liftsWithUnits+	, liftsWithUnits2++	  -- * Unit-preserving collation+	, Collatable	(..)+	, collateWithUnits)+	+where+import BuildBox.Aspect.Single+import BuildBox.Data.Dividable+import BuildBox.Pretty+import Data.Maybe+++-- Unit types -------------------------------------------------------------------------------------+-- | Seconds of time.+data Seconds	= Seconds Double+		deriving (Read, Show, Ord, Eq)++instance Real Seconds where+	toRational (Seconds s1) 	= toRational s1++instance Dividable Seconds where+	divide (Seconds s1) (Seconds s2) = Seconds (s1 / s2)	++instance Num Seconds where+	(+) (Seconds f1) (Seconds f2)	= Seconds (f1 + f2)+	(-) (Seconds f1) (Seconds f2)	= Seconds (f1 - f2)+	(*) (Seconds f1) (Seconds f2)	= Seconds (f1 * f2)+	abs (Seconds f1) 		= Seconds (abs f1)+	signum (Seconds f1)		= Seconds (signum f1)+	fromInteger i			= Seconds (fromInteger i)+	+instance Pretty Seconds where+	ppr (Seconds f)			+		= fromMaybe (text (show f))+		$ pprEngDouble "s" f+++-- | Bytes of data.+data Bytes	= Bytes	  Integer+		deriving (Read, Show, Ord, Eq)++instance Real Bytes where+	toRational (Bytes b1)		= toRational b1++instance Dividable Bytes where+	divide (Bytes s1) (Bytes s2)	= Bytes (s1 `div` s2)++instance Num Bytes where+	(+) (Bytes f1) (Bytes f2)	= Bytes (f1 + f2)+	(-) (Bytes f1) (Bytes f2)	= Bytes (f1 - f2)+	(*) (Bytes f1) (Bytes f2)	= Bytes (f1 * f2)+	abs (Bytes f1) 			= Bytes (abs f1)+	signum (Bytes f1)		= Bytes (signum f1)+	fromInteger i			= Bytes (fromInteger i)++instance Pretty Bytes where+	ppr (Bytes b)			+		= fromMaybe (text (show b))+		$ pprEngInteger "B" b+	++-- Type classes -----------------------------------------------------------------------------------+-- | Represents the units used for some thing.+data IsUnits a where+	IsSeconds 	:: IsUnits Seconds+	IsBytes		:: IsUnits Bytes	++class HasUnits a a => Units a where+	isUnits :: a -> Maybe (IsUnits a)++instance Units Seconds where+	isUnits s		= hasUnits s++instance Units Bytes where+	isUnits s		= hasUnits s+++-- | Determine the units used by the elements of some collection, +--   by inspecting the elements directly.+--   Returns `Nothing` when applied to empty collections, as they have no units.+class HasUnits a b | a -> b where+	hasUnits :: a -> Maybe (IsUnits b)++instance HasUnits Seconds Seconds where+	hasUnits _		= Just IsSeconds++instance HasUnits Bytes Bytes where+	hasUnits _		= Just IsBytes++instance HasUnits a a => HasUnits (Single a) a where+	hasUnits (Single x)	= hasUnits x++instance HasUnits a a => HasUnits [a] a where+	hasUnits []		= Nothing+	hasUnits (x : _)	= hasUnits x+++-- WithUnits --------------------------------------------------------------------------------------+-- | A wrapper type used to store data of varying physical units in a homogenous collection structure.+data WithUnits t where+	WithSeconds	:: t Seconds	-> WithUnits t+	WithBytes	:: t Bytes	-> WithUnits t+	+deriving instance (Show (t Bytes), Show (t Seconds)) => Show (WithUnits t)+deriving instance (Read (t Bytes), Read (t Seconds)) => Read (WithUnits t)++instance  (Pretty (t Bytes), Pretty (t Seconds))+	=> Pretty (WithUnits t) where+ ppr withUnits+  = case withUnits of+	WithSeconds s	-> ppr s+	WithBytes   b	-> ppr b++-- | Helpful wrapper for constructing seconds-valued aspect data. Examples:+-- +--   @Time TotalWall \`secs\` 10  ::  WithUnits (Aspect Single)@+-- +secs 	:: (Single Seconds -> c Single Seconds) +	-> Double -> WithUnits (c Single)+secs mk f  = WithSeconds (mk (Single (Seconds f)))+++-- | Similar to `secs`.+bytes 	:: (Single Bytes -> c Single Bytes) +	-> Integer -> WithUnits (c Single)+bytes mk b = WithBytes   (mk (Single (Bytes b)))+++-- | Apply a function to unit-wrapped data+appWithUnits+	:: (forall units. Real units => t1 units -> b)+	-> WithUnits t1 -> b+	+appWithUnits f withUnits+ = case withUnits of+	WithSeconds dat	-> f dat+	WithBytes   dat	-> f dat+++-- | Apply a function to unit-wrapped data.+liftWithUnits +	:: (forall units. Real units => t1 units -> t2 units)+	-> WithUnits t1 -> WithUnits t2++liftWithUnits f withUnits+ = case withUnits of+	WithSeconds dat	-> WithSeconds (f dat)+	WithBytes   dat -> WithBytes   (f dat)+++-- | Transform values of each unit type as a group.+liftsWithUnits +	:: (forall units. Real units => [t1 units] -> [t2 units]) +	-> [WithUnits t1] -> [WithUnits t2]++liftsWithUnits f us+  = let	asSeconds	= [a | WithSeconds a	<- us]+	asBytes		= [a | WithBytes   a	<- us]++    in	   (map WithSeconds $ f asSeconds)+	++ (map WithBytes   $ f asBytes)+	++-- | Transform values of each unit type as a group+liftsWithUnits2+	:: (forall units. Real units => [t1 units] -> [t2 units] -> [t3 units])+	-> [WithUnits t1] -> [WithUnits t2] -> [WithUnits t3]+	+liftsWithUnits2 f as bs+ = let	asSeconds	= [a | WithSeconds a	<- as]+	bsSeconds	= [b | WithSeconds b	<- bs]++	asBytes		= [a | WithBytes   a	<- as]+	bsBytes		= [b | WithBytes   b	<- bs]+	+   in	(map WithSeconds $ f asSeconds bsSeconds)+    ++	(map WithBytes   $ f asBytes   bsBytes)++++-- Unit-safe collation ----------------------------------------------------------------------------+-- | Collate some data, while preserving units.+class Collatable t where+	collate :: forall a. HasUnits a a +		=> [t Single a] -> [t [] a]+++-- | Collate some data.+--+--  @+-- collateWithUnits  [ Time KernelCpu \`secs\`  5+--                   , Time KernelCpu \`secs\`  10+--                   , Time TotalWall \`secs\`  55+--                   , Size ExeSize   \`bytes\` 100884+--                   , Time TotalWall \`secs\`  52 ]+-- =>+--                   [ WithSeconds (Time KernelCpu [Seconds 5.0,  Seconds 10.0])+--                   , WithSeconds (Time TotalWall [Seconds 55.0, Seconds 52.0])+--                   , WithBytes   (Size ExeSize [Bytes 1024])]+--  @+-- +collateWithUnits :: Collatable c => [WithUnits (c Single)] -> [WithUnits (c [])]+collateWithUnits as+  = let	asSeconds	= [a | WithSeconds a	<- as]+	asBytes		= [a | WithBytes   a	<- as]++    in	   (map WithSeconds $ collate asSeconds)+	++ (map WithBytes   $ collate asBytes)+

@@ -1,38 +1,18 @@-{-# LANGUAGE PatternGuards #-} --- | Running benchmarks and collecting timings. ------  These functions expect the given `Build` commands to succeed,---  throwing an error if they don't. If you're not sure whether your command will succeed then test it first. module BuildBox.Benchmark-	( module BuildBox.Benchmark.TimeAspect-	, module BuildBox.Benchmark.Pretty-	, module BuildBox.Benchmark.Compare-	-	-- * Types+	( module BuildBox.Benchmark.BenchResult 	, Benchmark(..)-	, Timing(..)-	, BenchRunResult(..)-	, BenchResult(..)-	-	-- * Benchmarking 	, runTimedCommand 	, runBenchmarkOnce 	, outRunBenchmarkOnce-	, outRunBenchmarkAgainst 	, outRunBenchmarkWith) where import BuildBox.Build	-import BuildBox.Pretty-import BuildBox.Benchmark.Base-import BuildBox.Benchmark.TimeAspect-import BuildBox.Benchmark.Pretty-import BuildBox.Benchmark.Compare+import BuildBox.Aspect+import BuildBox.Benchmark.Benchmark+import BuildBox.Benchmark.BenchResult import Data.Time-import Data.List-import Control.Monad - -- Running Commands ------------------------------------------------------------------------------- -- | Run a command, returning its elapsed time. runTimedCommand @@ -48,88 +28,65 @@  -- | Run a benchmark once. runBenchmarkOnce-	:: Benchmark -	-> Build BenchRunResult+	:: Integer		-- ^ Iteration number to tag results with.+	-> Benchmark 		-- ^ Benchmark to run.+	-> Build (BenchRunResult Single) 	-runBenchmarkOnce bench+runBenchmarkOnce iteration bench  = do	-- Run the setup command 	benchmarkSetup bench -	(diffTime, mKernelTimings)	+	(diffTime, asRun)	 		<- runTimedCommand  		$  benchmarkCommand bench 	-	benchmarkCheck bench+	asCheck	<- benchmarkCheck bench 	 	return	$ BenchRunResult-		{ benchRunResultElapsed		= fromRational $ toRational diffTime-		, benchRunResultKernel		= mKernelTimings }-+		{ benchRunResultIndex		= iteration +		-- Combine the aspects reported by the benchmark directly,+		-- also include our total runtime.+		, benchRunResultAspects		+			= Time TotalWall `secs` (fromRational $ toRational diffTime)+			: asRun ++ asCheck }+			+			 -- | Run a benchmark once, logging activity and timings to the console. outRunBenchmarkOnce-	:: Benchmark-	-> Build BenchRunResult+	:: Integer 		-- ^ Iteration number to tag results with+	-> Benchmark		-- ^ Benchmark to run.+	-> Build (BenchRunResult Single) 	-outRunBenchmarkOnce bench+outRunBenchmarkOnce iteration bench  = do	out $ "Running " ++ benchmarkName bench ++ "..."-	result	<- runBenchmarkOnce bench+	result	<- runBenchmarkOnce iteration bench 	outLn "ok"-	outLn $ text "    elapsed        = " <> (pprFloatTime $ benchRunResultElapsed result)-		-	maybe (return ()) (\t -> outLn $ text "    kernel elapsed = " <> pprFloatTime t) -		$ takeTimeAspectOfBenchRunResult TimeAspectKernelElapsed result--	maybe (return ()) (\t -> outLn $ text "    kernel cpu     = " <> pprFloatTime t) -		$ takeTimeAspectOfBenchRunResult TimeAspectKernelCpu result--	maybe (return ()) (\t -> outLn $ text "    kernel system  = " <> pprFloatTime t)-		$ takeTimeAspectOfBenchRunResult TimeAspectKernelSys result-	-	outBlank-	+	outLn result+	outBlank	 	return result ---- | Run a benchmark several times, logging activity to the console.---   Optionally print a comparison with a prior results.-outRunBenchmarkAgainst-	:: Int			-- ^ Number of iterations.-	-> Maybe BenchResult	-- ^ Optional previous result for comparison.-	-> Benchmark		-- ^ Benchmark to run.-	-> Build BenchResult 	-outRunBenchmarkAgainst iterations mPrior bench  +-- | Run a benchmark serveral times, logging activity to the console.+--   Also lookup prior results and print comparisons during the run.+outRunBenchmarkWith+	:: Int				-- ^ Number of times to run each benchmark to get averages.+	-> [BenchResult Stats]		-- ^ List of prior results.+	-> Benchmark			-- ^ The benchmark to run.+	-> Build (BenchResult Single)++outRunBenchmarkWith iterations priors bench  = do	out $ "Running " ++ benchmarkName bench ++ " " ++ show iterations ++ " times..."-	runResults	<- replicateM iterations (runBenchmarkOnce bench) +	runResults	<- mapM ((flip runBenchmarkOnce) bench) $ take iterations [1..] 	outLn "ok"  	let result	= BenchResult 			{ benchResultName	= benchmarkName bench 			, benchResultRuns	= runResults } -	outLn pprBenchResultAspectHeader+	outLn 	$ compareBenchResultWith priors +		$ statBenchResult result 	-	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectElapsed	mPrior result-	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelElapsed	mPrior result-	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelCpu	mPrior result-	maybe (return ()) outLn	$ pprBenchResultAspect TimeAspectKernelSys	mPrior result-		 	outBlank-	return	result----- | Run a benchmark serveral times, logging activity to the console.---   Also lookup prior results for comparison from the given list.---   If there is no matching entry then run the benchmark anyway, but don't print the comparison.-outRunBenchmarkWith-	:: Int			-- ^ Number of times to run each benchmark to get averages.-	-> [BenchResult]	-- ^ List of prior results.-	-> Benchmark		-- ^ The benchmark to run.-	-> Build BenchResult--outRunBenchmarkWith iterations priors bench- = let	mPrior	= find (\b -> benchResultName b == benchmarkName bench) priors-   in	outRunBenchmarkAgainst iterations mPrior bench-	+	return result 	

@@ -1,78 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}--module BuildBox.Benchmark.Base-	( Benchmark(..)-	, Timing(..)-	, BenchRunResult(..)-	, BenchResult(..))-where-import BuildBox.Build-import BuildBox.Pretty-import Control.Monad---- | Describes a benchmark that we can run.-data Benchmark-	= Benchmark-	{ -- | A unique name for the benchmark.-	  benchmarkName		:: String--	  -- | Setup command to run before the main benchmark.-	, benchmarkSetup	:: Build ()--	  -- | The benchmark command to run. Only the time taken to run this part is measured.-	, benchmarkCommand	:: Build (Maybe Timing)--	  -- | Check \/ cleanup command to run after the main benchmark.-	, benchmarkCheck	:: Build ()-	}----- | Holds elapsed, cpu, and system timings (in seconds).-data Timing-	= Timing-	{ timingElapsed	:: Maybe Float-	, timingCpu	:: Maybe Float-	, timingSys	:: Maybe Float }-	deriving (Eq, Read, Show)----- | The result of running a benchmark once.-data BenchRunResult-	= BenchRunResult--	{ -- | The wall-clock time taken to run the benchmark (in seconds)-	  benchRunResultElapsed		:: Float--	  -- | Time that the benchmark itself reported was taken to run its kernel.-	, benchRunResultKernel		:: Maybe Timing }--	deriving (Show, Read)---instance Pretty BenchRunResult where- ppr result-	= hang (ppr "BenchRunResult") 2 $ vcat-	[ ppr "elapsed:        " <> (ppr $ benchRunResultElapsed result) -	, maybe empty (\r -> ppr "k.elapsed: " <> ppr r) -		$ join $ liftM timingElapsed $ benchRunResultKernel result--	, maybe empty (\r -> ppr "k.cpu:     " <> ppr r)-		$ join $ liftM timingCpu     $ benchRunResultKernel result--	, maybe empty (\r -> ppr "k.system:  " <> ppr r)-		$ join $ liftM timingSys     $ benchRunResultKernel result ]-	-	--- | The result of running a benchmark several times.---   We include the name of the original benchmark to it's easy to lookup the results.-data BenchResult-	= BenchResult-	{ benchResultName	:: String-	, benchResultRuns	:: [BenchRunResult] }-	deriving (Show, Read)--instance Pretty BenchResult where- ppr result-	= hang (ppr "BenchResult") 2 $ vcat-	[ ppr $ benchResultName result-	, vcat $ map ppr $ benchResultRuns result ]

@@ -0,0 +1,252 @@+{-# LANGUAGE PatternGuards, StandaloneDeriving, FlexibleContexts, UndecidableInstances, RankNTypes #-}+module BuildBox.Benchmark.BenchResult+	( +	-- * Benchmark results	+	  BenchResult (..)++	-- * Concatenation+	, concatBenchResult+	+	-- * Collation+	, collateBenchResult++	-- * Statistics+	, statCollatedBenchResult+	, statBenchResult++	-- * Comparison+	, compareBenchResults+	, compareBenchResultWith+	, compareManyBenchResults+	, predBenchResult+	, swungBenchResult+	+	-- * Benchmark run results+	, BenchRunResult (..)++	-- * Application functions+	, appBenchRunResult+	, appRunResultAspects+++	-- * Lifting functions+	, liftBenchRunResult+	, liftBenchRunResult2+	, liftToAspectsOfBenchResult+	, liftToAspectsOfBenchResult2+	, liftRunResultAspects+	, liftRunResultAspects2)+where+import BuildBox.Aspect+import BuildBox.Pretty+import Data.List+++-- BenchResult ------------------------------------------------------------------------------------+-- | We include the name of the original benchmark to it's easy to lookup the results.+--   If the `BenchResult` is carrying data derived directly by running a benchmark, +--   there will be an element of the `benchResultRuns` for each iteration. On the other hand,+--   If the `BenchResult` is carrying statistics or comparison data there should+--   be a single element with an index of 0. This is suggested usage, and  adhered to by+--   the functions in this module, but not required.+data BenchResult c+	= BenchResult+	{ benchResultName	:: String+	, benchResultRuns	:: [BenchRunResult c] }++deriving instance +	(  Show (c Seconds), Show (c Bytes)) +	=> Show (BenchResult c)++deriving instance+	(  HasUnits (c Bytes) Bytes+	,  Read (c Bytes)+	,  HasUnits (c Seconds) Seconds+	,  Read (c Seconds))+	=> Read (BenchResult c)+++instance  ( Pretty (c Seconds), Pretty (c Bytes))+	 => Pretty (BenchResult c) where+ ppr result+	= text (benchResultName result)+	$+$ nest 4 (vcat $ map ppr $ benchResultRuns result)+++-- | 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)]+++-- | Collate the aspects of each run. See `collateWithUnits` for an explanation and example.+collateBenchResult :: BenchResult Single -> BenchResult []+collateBenchResult+	= liftToAspectsOfBenchResult collateWithUnits+++-- | Compute statistics from collated aspects of a run.+statCollatedBenchResult :: BenchResult [] -> BenchResult Stats+statCollatedBenchResult+	= liftToAspectsOfBenchResult (map (liftWithUnits makeAspectStats))+++-- | Collate the aspects, then compute statistics of a run.+statBenchResult :: BenchResult Single -> BenchResult Stats+statBenchResult +	= statCollatedBenchResult . collateBenchResult . concatBenchResult+++-- | Compute comparisons of benchmark results.+--	Both results must have the same `benchResultName` else `error`.+compareBenchResults+	:: BenchResult Stats -> BenchResult Stats -> BenchResult StatsComparison++compareBenchResults +	= liftBenchRunResult2 (zipWith (liftRunResultAspects2 (liftsWithUnits2 makeAspectComparisons)))+++-- | Compute comparisons of benchmark result, looking up the baseline results from a given list.+--	If there are no matching baseline results then this creates a `ComparisonNew` in the output.+compareBenchResultWith +	:: [BenchResult Stats] -> BenchResult Stats -> BenchResult StatsComparison++compareBenchResultWith base result+	| Just baseResult	<- find (\baseResult -> benchResultName baseResult == benchResultName result) base+	= compareBenchResults baseResult result+	+	| otherwise+	= liftToAspectsOfBenchResult (liftsWithUnits (map (liftAspect makeStatsComparisonNew))) result+++-- | Compare some baseline results against new results.+--	If there are no matching baseline results then this creates a `ComparisonNew` in the output.+compareManyBenchResults +	:: [BenchResult Stats] -> [BenchResult Stats] -> [BenchResult StatsComparison]+	+compareManyBenchResults base new+	= map (compareBenchResultWith base) new+++-- | Return true if any of the aspect data in a result matches a given predicate.+predBenchResult+	:: (forall units. Real units => c units -> Bool)+	-> BenchResult c -> Bool++predBenchResult f+	= appBenchRunResult $ or . map (appRunResultAspects $ or . map (appAspectWithUnits f))+++-- | Return true if any of the aspects have swung by more than a given fraction since last time.+--   For example, use @0.1@ for 10 percent.+swungBenchResult :: Double -> BenchResult StatsComparison -> Bool+swungBenchResult limit+	= predBenchResult (predSwingStatsComparison (\x -> abs x > limit)) +++-- Lifting ----------------------------------------------------------------------------------------+-- | Apply a function to the aspects of a `BenchRunResult`+appBenchRunResult :: ([BenchRunResult c1] -> b) -> BenchResult c1 -> b+appBenchRunResult f (BenchResult _ runs) = f runs+++-- | Lift a function to the `BenchRunResult` in a `BenchResult`+liftBenchRunResult +	:: ([BenchRunResult c1] -> [BenchRunResult  c2])+	-> (BenchResult     c1  -> BenchResult      c2)++liftBenchRunResult f (BenchResult name runs)	+	= BenchResult name (f runs)+++-- | Lift a binary function to the `BenchResults` in a `BenchResult`+liftBenchRunResult2+	:: ([BenchRunResult c1] -> [BenchRunResult c2] -> [BenchRunResult c3])+	->  BenchResult c1      ->  BenchResult c2     ->  BenchResult c3++liftBenchRunResult2 f (BenchResult name1 runs1) (BenchResult name2 runs2)+	| name1 == name2	= BenchResult name1 (f runs1 runs2)+	| otherwise		= error "liftBenchRunResult2: names don't match"+	++-- | Lift a function to the aspects of each `BenchRunResult`.+liftToAspectsOfBenchResult +	:: ([WithUnits (Aspect c1)] -> [WithUnits (Aspect c2)])+	-> BenchResult c1           -> BenchResult c2++liftToAspectsOfBenchResult +	= liftBenchRunResult . map . liftRunResultAspects+++-- | Lift a binary function to the aspects of each `BenchRunResult`.+liftToAspectsOfBenchResult2+	:: ([WithUnits (Aspect c1)] -> [WithUnits (Aspect c2)] -> [WithUnits (Aspect c3)])+	-> BenchResult c1           -> BenchResult c2          -> BenchResult c3++liftToAspectsOfBenchResult2+	= 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+++-- | Lift a function to the aspects of a `BenchRunResult`+liftRunResultAspects+	:: ([WithUnits (Aspect c1)] -> [WithUnits (Aspect c2)])+	-> BenchRunResult c1        -> BenchRunResult c2+	+liftRunResultAspects f (BenchRunResult ix as)+	= BenchRunResult ix (f as)+++-- | Lift a binary function to the aspects of a `BenchRunResult`+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)+	| otherwise		= error "liftRunResultAspects2: indices don't match"+

@@ -0,0 +1,25 @@++module BuildBox.Benchmark.Benchmark+	(Benchmark(..))+where+import BuildBox.Build+import BuildBox.Aspect++-- | Describes a benchmark that we can run.+data Benchmark+	= Benchmark+	{ -- | A unique name for the benchmark.+	  benchmarkName		:: String++	  -- | Setup command to run before the main benchmark.+	, benchmarkSetup	:: Build ()++	  -- | The benchmark command to run. +	  --   The time taken to run this part is automatically measured and added to the overall results.+	, benchmarkCommand	:: Build [WithUnits (Aspect Single)]++	  -- | Check \/ cleanup command to run after the main benchmark.+	, benchmarkCheck	:: Build [WithUnits (Aspect Single)]+	}++

@@ -1,50 +0,0 @@---- | Pretty printing comparisons of benchmark results.-module BuildBox.Benchmark.Compare-	( pprComparison-	, pprComparisons)-where-import BuildBox.Pretty-import BuildBox.Benchmark.Base-import BuildBox.Benchmark.Pretty-import BuildBox.Benchmark.TimeAspect-import Data.Maybe-import Data.List---- | Pretty print a comparison of all the aspects of these two benchmark results.---   The first result is the ``baseline'', while the second is the ``current'' one.---   The numbers from the current results are printed, with a percentage relative to the baseline.-pprComparison :: BenchResult -> BenchResult -> Doc-pprComparison baseline current- 	= vcat-	[ pprBenchResultAspectHeader-	, fromMaybe empty $ pprBenchResultAspect TimeAspectElapsed	 (Just baseline) current-	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelElapsed (Just baseline) current-	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelCpu	 (Just baseline) current-	, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelSys	 (Just baseline) current ]----- | Pretty print a comparison of all the aspects of these two benchmark results.---   The first result is the ``baseline'' while the second is the ``current'' one.---   All the numbers from the current results are printed, with a percentage relative to the---   baseline if there is one. If there is no baseline for a particular result then we still---   print the current one.-pprComparisons :: [BenchResult] -> [BenchResult] -> Doc-pprComparisons baselines currents- = let	comparison current-	 = let	mBaseline = find (\b -> benchResultName b == benchResultName current)-			  $ baselines--	   in	vcat-		[ fromMaybe empty $ pprBenchResultAspect TimeAspectElapsed	 mBaseline current-		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelElapsed mBaseline current-		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelCpu	 mBaseline current-		, fromMaybe empty $ pprBenchResultAspect TimeAspectKernelSys	 mBaseline current ]--   in	vcat-	[ nest 30 pprBenchResultAspectHeader-	, vcat	$ punctuate (text "\n")-		$ map (\c -> (text (benchResultName c) $$ (nest 30 $ comparison c)))-		$ currents ]--

@@ -1,52 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Pretty printing benchmark results.-module BuildBox.Benchmark.Pretty-	( pprBenchResultAspectHeader-	, pprBenchResultAspect)-where-import BuildBox.Benchmark.Base-import BuildBox.Benchmark.TimeAspect-import BuildBox.Pretty---- | Header to use when pretty printing benchmark results.-pprBenchResultAspectHeader :: Doc-pprBenchResultAspectHeader -	=  vcat-	[ text "    aspect       min    ref%   avg    ref%   max    ref%   spread% "-	, text "    ---------    -----------   -----------   -----------   ------- " ]----- | Pretty print an aspect of a benchmark result.---   If the given aspect does not exist in the result then `Nothing`.-pprBenchResultAspect -	:: TimeAspect 			-- ^ Aspect of the result to print.-	-> Maybe BenchResult		-- ^ Optional prior result for comparison.-	-> BenchResult			-- ^ The result to print.-	-> Maybe Doc--pprBenchResultAspect aspect prior result- 	| Just (tmin,  tavg,  tmax)	<- takeMinAvgMaxOfBenchResult aspect result-	, spread			<- tmax - tmin-	, spreadPercent			<- (floor $ (spread / tavg) * 100) :: Integer-	, Just result'			<- prior-	, Just (tmin', tavg', tmax')	<- takeMinAvgMaxOfBenchResult aspect result'-	= Just	$   text "    "-		<>  padL 10 (ppr aspect)-		<+> (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-	, spread			<- tmax - tmin-	, spreadPercent			<- (floor $ (spread / tavg) * 100) :: Integer-	= Just	$   text "    "-		<>  padL 10 (ppr aspect)-		<+> (padR 13 $ (pprFloatTime tmin <> text "     "))-		<+> (padR 13 $ (pprFloatTime tavg <> text "     "))-		<+> (padR 13 $ (pprFloatTime tmax <> text "     "))-		<+> (padR 8 $ ppr spreadPercent)-	-	| otherwise-	= Nothing	

@@ -1,86 +0,0 @@-{-# LANGUAGE PatternGuards #-}---- | Dealing with aspects of timing results.-module BuildBox.Benchmark.TimeAspect-	( TimeAspect(..)-	, takeTimeAspectOfBenchRunResult-	, takeAvgTimeOfBenchResult-	, takeMinTimeOfBenchResult-	, takeMaxTimeOfBenchResult-	, takeMinAvgMaxOfBenchResult)-where-import BuildBox.Benchmark.Base-import BuildBox.Pretty-import Control.Monad----- | Aspects of a benchmark runtime we can talk about.-data TimeAspect-	= TimeAspectElapsed-	| TimeAspectKernelElapsed-	| TimeAspectKernelCpu-	| TimeAspectKernelSys-	deriving (Show, Read, Enum)----- | Get the pretty name of a TimeAspect.-instance Pretty TimeAspect where- ppr aspect-  = case aspect of-	TimeAspectElapsed		-> ppr "elapsed"-	TimeAspectKernelElapsed		-> ppr "k.elapsed"-	TimeAspectKernelCpu		-> ppr "k.cpu"-	TimeAspectKernelSys		-> ppr "k.system"----- | Get a particular aspect of a benchmark result.-takeTimeAspectOfBenchRunResult :: TimeAspect -> BenchRunResult -> Maybe Float-takeTimeAspectOfBenchRunResult aspect result- = case aspect of-	TimeAspectElapsed	-> Just $ benchRunResultElapsed result-	TimeAspectKernelElapsed	-> join $ liftM timingElapsed $ benchRunResultKernel result-	TimeAspectKernelCpu	-> join $ liftM timingCpu     $ benchRunResultKernel result-	TimeAspectKernelSys	-> join $ liftM timingSys     $ benchRunResultKernel result----- | Get the average runtime from a benchmark result.-takeAvgTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float-takeAvgTimeOfBenchResult aspect result- = let	mTimes	= sequence -		$ map (takeTimeAspectOfBenchRunResult aspect)-		$ benchResultRuns result-		-   in	liftM (\ts -> sum ts / (fromIntegral $ length ts)) mTimes-	---- | Get the minimum runtime from a benchmark result.-takeMinTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float-takeMinTimeOfBenchResult aspect result- = let	mTimes	= sequence-		$ map (takeTimeAspectOfBenchRunResult aspect)-		$ benchResultRuns result--   in	liftM (\ts -> minimum ts) mTimes----- | Get the maximum runtime from a benchmark result.-takeMaxTimeOfBenchResult :: TimeAspect -> BenchResult -> Maybe Float-takeMaxTimeOfBenchResult aspect result- = let	mTimes	= sequence-		$ map (takeTimeAspectOfBenchRunResult aspect)-		$ benchResultRuns result--   in	liftM (\ts -> maximum ts) mTimes----- | Get the min, avg, and max runtimes from this benchmark result.-takeMinAvgMaxOfBenchResult :: TimeAspect -> BenchResult -> Maybe (Float, Float, Float)-takeMinAvgMaxOfBenchResult aspect result-	| Just tmin	<- takeMinTimeOfBenchResult aspect result-	, Just tavg	<- takeAvgTimeOfBenchResult aspect result-	, Just tmax	<- takeMaxTimeOfBenchResult aspect result-	= Just (tmin, tavg, tmax)-	-	| otherwise-	= Nothing-

@@ -63,6 +63,8 @@   -- | Throw a needs error saying we needs the given file.+--   A catcher could then usefully create the file, or defer the compuation until it has been +--   created. needs :: FilePath -> Build () needs filePath  = do	isFile	<- io $ doesFileExist filePath

@@ -0,0 +1,13 @@++module BuildBox.Data.Dividable+	(Dividable(..))+where++class Dividable a where+	divide :: a -> a -> a+	+instance Dividable Integer where+	divide	= div++instance Dividable Float where+	divide	= (/)

@@ -7,6 +7,7 @@ import BuildBox.Benchmark import BuildBox.Command.Environment import BuildBox.Pretty+import BuildBox.Aspect import Data.List  @@ -15,7 +16,7 @@ 	= BuildResults 	{ buildResultTime		:: UTCTime 	, buildResultEnvironment	:: Environment-	, buildResultBench		:: [BenchResult] }+	, buildResultBench		:: [BenchResult Single] } 	deriving (Show, Read)  instance Pretty BuildResults where

@@ -1,9 +1,10 @@-+{-# OPTIONS_HADDOCK hide #-} module BuildBox.IO.File 	(atomicWriteFile) where -+-- | Should atomically write a file by writing it to a tmp file then renaming it.+--   TODO: Does not yet work as advertised. atomicWriteFile :: FilePath -> String -> IO () atomicWriteFile filePath str  = do	writeFile filePath str

@@ -1,19 +1,19 @@-{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables, OverlappingInstances, IncoherentInstances #-}  -- | Pretty printing utils. module BuildBox.Pretty 	( module Text.PrettyPrint 	, Pretty(..)-	, pprPSecTime-	, pprFloatTime-	, pprFloatSR-	, pprFloatRef 	, padRc, padR 	, padLc, padL-	, blank)+	, blank+	, pprEngDouble+	, pprEngInteger) where import Text.PrettyPrint+import Text.Printf import Data.Time+import Control.Monad  -- Things that can be pretty printed class Pretty a where@@ -22,9 +22,6 @@ -- Basic instances instance Pretty Doc where 	ppr = id--instance Pretty String where-	ppr = text 	 instance Pretty Float where 	ppr = text . show@@ -38,52 +35,12 @@ instance Pretty UTCTime where 	ppr = text . show 	---- To handle type defaulting-ten12i :: Integer-ten12i = 10^(12 :: Integer)----- | Print a number of picoseconds as a time.-pprPSecTime :: Integer -> Doc-pprPSecTime psecs-  	=  text (show (psecs `quot` ten12i))-	<> text "." - 	<> (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 (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	diff		= ((stime - stimeRef) / stimeRef )*100-   in	pprFloatTime stime-	 <> parens (padR 4 $ pprFloatSR diff)----- | Print a float number of seconds, rounding it and, prefixing with @+@ or @-@ appropriately.-pprFloatSR :: Float -> Doc-pprFloatSR p-	| p == 0-	= text "----"+instance Pretty a => Pretty [a] where+	ppr xx +		= lbrack <> (hcat $ punctuate (text ", ") (map ppr xx)) <> rbrack - 	| p > 0-	= text "+" <> (ppr $ (round p :: Integer))-	-	| otherwise-	= text "-" <> (ppr $ (round (negate p) :: Integer))+instance Pretty String where+	ppr = text   -- | Right justify a doc, padding with a given character.@@ -110,3 +67,53 @@ -- | Blank text. This is different different from `empty` because it comes out a a newline when used in a `vcat`. blank :: Doc blank = ppr ""+++-- | Like `pprEngDouble` but don't display fractional part when the value is < 1000.+--   Good for units where fractional values might not make sense (like bytes).+pprEngInteger :: String -> Integer -> Maybe Doc+pprEngInteger unit k+    | k < 0	 = liftM (text "-" <>) $ pprEngInteger unit (-k)+    | k > 1000	 = pprEngDouble unit (fromRational $ toRational k)+    | otherwise  = Just $ text $ printf "%5d%s " k unit+++-- | Pretty print an engineering value, to 4 significant figures.+--   Valid range is  10^(-24) (y\/yocto) to 10^(+24) (Y\/Yotta).+--   Out of range values yield Nothing.+--+--   examples:+--+--   @+--   liftM render $ pprEngDouble \"J\" 102400    ==>   Just \"1.024MJ\"+--   liftM render $ pprEngDouble \"s\" 0.0000123 ==>   Just \"12.30us\"+--   @+--+pprEngDouble :: String -> Double -> Maybe Doc+pprEngDouble unit k+    | k < 0      = liftM (text "-" <>) $ pprEngDouble unit (-k)+    | k >= 1e+27 = Nothing+    | k >= 1e+24 = Just $ (k*1e-24) `with` ("Y" ++ unit)+    | k >= 1e+21 = Just $ (k*1e-21) `with` ("Z" ++ unit)+    | k >= 1e+18 = Just $ (k*1e-18) `with` ("E" ++ unit)+    | k >= 1e+15 = Just $ (k*1e-15) `with` ("P" ++ unit)+    | k >= 1e+12 = Just $ (k*1e-12) `with` ("T" ++ unit)+    | k >= 1e+9  = Just $ (k*1e-9)  `with` ("G" ++ unit)+    | k >= 1e+6  = Just $ (k*1e-6)  `with` ("M" ++ unit)+    | k >= 1e+3  = Just $ (k*1e-3)  `with` ("k" ++ unit)+    | k >= 1     = Just $ k         `with` (unit ++ " ")+    | k >= 1e-3  = Just $ (k*1e+3)  `with` ("m" ++ unit)+    | k >= 1e-6  = Just $ (k*1e+6)  `with` ("u" ++ unit)+    | k >= 1e-9  = Just $ (k*1e+9)  `with` ("n" ++ unit)+    | k >= 1e-12 = Just $ (k*1e+12) `with` ("p" ++ unit)+    | k >= 1e-15 = Just $ (k*1e+15) `with` ("f" ++ unit)+    | k >= 1e-18 = Just $ (k*1e+18) `with` ("a" ++ unit)+    | k >= 1e-21 = Just $ (k*1e+21) `with` ("z" ++ unit)+    | k >= 1e-24 = Just $ (k*1e+24) `with` ("y" ++ unit)+    | k >= 1e-27 = Nothing+    | otherwise  = Just $ text $ printf "%5.0f%s " k unit+     where with (t :: Double) (u :: String)+		| t >= 1e3  = text $ printf "%.0f%s" t u+		| t >= 1e2  = text $ printf "%.1f%s" t u+		| t >= 1e1  = text $ printf "%.2f%s" t u+		| otherwise = text $ printf "%.3f%s" t u

@@ -0,0 +1,68 @@+{-# LANGUAGE PatternGuards #-}+{-# OPTIONS -fno-warn-missing-signatures #-}++module BuildBox.Reports.BenchResult+	(reportBenchResults)+where+import BuildBox.Pretty+import BuildBox.Aspect+import BuildBox.Benchmark.BenchResult+import Text.Printf+import Data.List++-- | Produce a human readable report of benchmark results.+--+--   If you only want the results within a fractional swing from the baseline+--   then pass something like @(Just 0.1)@ as the first parameter for a 10\% swing, +--   otherwise all results are printed.+--      +reportBenchResults :: Maybe Double -> [BenchResult StatsComparison] -> Doc++-- no swing specified, just report all the results.+reportBenchResults Nothing comparisons+	= 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++   in	vcat $	[ text "Total tests = " <> int (length comparisons)+		, blank] ++ [reportBenchResults' swing resultWinners resultLosers]++reportBenchResults' swing resultWinners resultLosers+ 	| []	<- resultWinners+	, []	<- resultLosers+	= text "ALL GOOD\n"+	+	| otherwise+	= let	docWinners +			| []	<- resultWinners+			= []+				+			| otherwise+			= [text "-- WINNERS (had a swing of < "+					<> text (printf "%+2.0f" (negate (swing * 100))) <> text "%)"+			$$ (vcat $ punctuate (text "\n") $ map ppr resultWinners) +			<> text "\n"]+				+		docLosers+			| []	<- resultLosers+			= []+				+			| otherwise+			= [text "-- LOSERS  (had a swing of > " +					<> text (printf "%+2.0f" (swing * 100)) <> text "%)"+			$$ (vcat $ punctuate (text "\n") $ map ppr resultLosers) +			<> text "\n"]+		+	  in	vcat $ docWinners ++ docLosers+		

@@ -1,5 +1,5 @@ Name:                buildbox-Version:             1.2.1.0+Version:             1.3.0.0 License:             BSD3 License-file:        LICENSE Author:              Ben Lippmeier@@ -10,10 +10,10 @@ Category:            Development, Testing Homepage:            http://code.haskell.org/~benl/code/buildbox-head Description:-        Includes functions for checking the host platform, running tests, capturing output,+        Includes utilities for checking the host platform, running tests, capturing output,         handling errors, comparing runtimes against a baseline, sending mail, running events to a schedule etc. -	Some of these functions are just wrappers around shell commands, so be careful about passing+	Some of the Command functions are just wrappers around shell commands, so be careful about passing 	them weirdly formed arguments. 	 Synopsis:@@ -39,11 +39,16 @@         -Wall    Exposed-modules:-        BuildBox.Data.Log-        BuildBox.Benchmark.Compare-        BuildBox.Benchmark.Pretty-        BuildBox.Benchmark.TimeAspect+        BuildBox+        BuildBox.Aspect.Detail+        BuildBox.Aspect.Stats+        BuildBox.Aspect.Units+        BuildBox.Aspect.Single+        BuildBox.Aspect.Comparison+        BuildBox.Aspect+        BuildBox.Benchmark.BenchResult         BuildBox.Benchmark+        BuildBox.Reports.BenchResult         BuildBox.Build.Testable         BuildBox.Build.BuildError         BuildBox.Build.BuildState@@ -56,15 +61,16 @@         BuildBox.Command.Sleep         BuildBox.Cron.Schedule         BuildBox.Cron+        BuildBox.Data.Log+        BuildBox.Data.Dividable         BuildBox.FileFormat.BuildResults         BuildBox.IO.Directory-        BuildBox.IO.File         BuildBox.Pretty         BuildBox.Time-        BuildBox    Other-modules:         BuildBox.Command.System.Internals-        BuildBox.Benchmark.Base         BuildBox.Build.Base-       +        BuildBox.Aspect.Aspect+        BuildBox.Benchmark.Benchmark+        BuildBox.IO.File