buildbox 1.5.3.1 → 2.2.1.2
raw patch · 44 files changed
Files
- BuildBox.hs +18/−35
- BuildBox/Aspect.hs +0/−86
- BuildBox/Aspect/Aspect.hs +0/−231
- BuildBox/Aspect/Comparison.hs +0/−91
- BuildBox/Aspect/Detail.hs +0/−63
- BuildBox/Aspect/Single.hs +0/−26
- BuildBox/Aspect/Stats.hs +0/−54
- BuildBox/Aspect/Units.hs +0/−237
- BuildBox/Benchmark.hs +0/−94
- BuildBox/Benchmark/BenchResult.hs +0/−369
- BuildBox/Benchmark/Benchmark.hs +0/−25
- BuildBox/Build.hs +38/−30
- BuildBox/Build/Base.hs +56/−69
- BuildBox/Build/Benchmark.hs +66/−0
- BuildBox/Build/BuildError.hs +63/−50
- BuildBox/Build/BuildState.hs +17/−23
- BuildBox/Build/Testable.hs +28/−26
- BuildBox/Command/Darcs.hs +8/−9
- BuildBox/Command/Environment.hs +102/−93
- BuildBox/Command/File.hs +91/−82
- BuildBox/Command/Mail.hs +79/−80
- BuildBox/Command/Network.hs +26/−26
- BuildBox/Command/Sleep.hs +6/−6
- BuildBox/Command/System.hs +152/−135
- BuildBox/Command/System/Internals.hs +50/−48
- BuildBox/Control/Cron.hs +43/−0
- BuildBox/Control/Gang.hs +172/−140
- BuildBox/Cron.hs +0/−43
- BuildBox/Cron/Schedule.hs +0/−210
- BuildBox/Data/Comparison.hs +48/−0
- BuildBox/Data/Detail.hs +64/−0
- BuildBox/Data/Dividable.hs +5/−5
- BuildBox/Data/Log.hs +35/−35
- BuildBox/Data/Physical.hs +61/−0
- BuildBox/Data/Range.hs +43/−0
- BuildBox/Data/Schedule.hs +210/−0
- BuildBox/FileFormat/BuildResults.hs +0/−112
- BuildBox/IO/Directory.hs +38/−38
- BuildBox/Pretty.hs +145/−59
- BuildBox/Quirk.hs +0/−37
- BuildBox/Reports/BenchResult.hs +0/−58
- BuildBox/Time.hs +43/−44
- LICENSE +21/−20
- buildbox.cabal +33/−36
BuildBox.hs view
@@ -1,39 +1,22 @@ module BuildBox- ( module BuildBox.Aspect- , module BuildBox.Benchmark- , module BuildBox.Build- , module BuildBox.Command.Sleep- , module BuildBox.Command.System- , module BuildBox.Command.Network- , module BuildBox.Command.Mail- , module BuildBox.Command.Environment- , module BuildBox.Command.File- , module BuildBox.Command.Darcs- , module BuildBox.Control.Gang- , module BuildBox.Cron- , module BuildBox.FileFormat.BuildResults- , module BuildBox.IO.Directory- , module BuildBox.Pretty- , module BuildBox.Quirk- , module BuildBox.Reports.BenchResult- , module BuildBox.Time)+ ( Build++ -- * Building+ , runBuild+ , runBuildWithState++ -- * Errors+ , BuildError (..)+ , throw+ , catch+ , needs++ -- * Utils+ , io++ -- * Output+ , out+ , outLn) where-import BuildBox.Aspect-import BuildBox.Benchmark import BuildBox.Build-import BuildBox.Command.Sleep-import BuildBox.Command.System-import BuildBox.Command.Network-import BuildBox.Command.Mail-import BuildBox.Command.Environment-import BuildBox.Command.File-import BuildBox.Command.Darcs-import BuildBox.Control.Gang-import BuildBox.Cron-import BuildBox.FileFormat.BuildResults-import BuildBox.IO.Directory-import BuildBox.Pretty-import BuildBox.Quirk-import BuildBox.Reports.BenchResult-import BuildBox.Time
− BuildBox/Aspect.hs
@@ -1,86 +0,0 @@---- | 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-----
− BuildBox/Aspect/Aspect.hs
@@ -1,231 +0,0 @@-{-# 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"
− BuildBox/Aspect/Comparison.hs
@@ -1,91 +0,0 @@--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-
− BuildBox/Aspect/Detail.hs
@@ -1,63 +0,0 @@---- | 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"- -
− BuildBox/Aspect/Single.hs
@@ -1,26 +0,0 @@--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--
− BuildBox/Aspect/Stats.hs
@@ -1,54 +0,0 @@--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)---
− BuildBox/Aspect/Units.hs
@@ -1,237 +0,0 @@-{-# 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.Aspect.Stats-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 (Stats a) a where- hasUnits (Stats 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)-
− BuildBox/Benchmark.hs
@@ -1,94 +0,0 @@--module BuildBox.Benchmark- ( module BuildBox.Benchmark.BenchResult- , Benchmark(..)- , runTimedCommand- , runBenchmarkOnce- , outRunBenchmarkOnce- , outRunBenchmarkWith)-where-import BuildBox.Build -import BuildBox.Aspect-import BuildBox.Benchmark.Benchmark-import BuildBox.Benchmark.BenchResult-import Data.Time---- Running Commands ---------------------------------------------------------------------------------- | Run a command, returning its elapsed time.-runTimedCommand - :: Build a- -> Build (NominalDiffTime, a) - -runTimedCommand cmd- = do start <- io $ getCurrentTime- result <- cmd- finish <- io $ getCurrentTime- return (diffUTCTime finish start, result)----- | Run a benchmark once.-runBenchmarkOnce- :: Integer -- ^ Iteration number to tag results with.- -> Benchmark -- ^ Benchmark to run.- -> Build (BenchRunResult Single)- -runBenchmarkOnce iteration bench- = do -- Run the setup command- benchmarkSetup bench-- (diffTime, asRun) - <- runTimedCommand - $ benchmarkCommand bench- - asCheck <- benchmarkCheck bench- - return $ BenchRunResult- { benchRunResultIndex = iteration-- -- Combine the aspects reported by the benchmark directly,- -- also include our total runtime.- , benchRunResultAspects - = Time TotalWall `secs` (fromRational $ toRational diffTime)- : asRun ++ asCheck- - , benchRunResultQuirks = [] }- - --- | Run a benchmark once, logging activity and timings to the console.-outRunBenchmarkOnce- :: Integer -- ^ Iteration number to tag results with- -> Benchmark -- ^ Benchmark to run.- -> Build (BenchRunResult Single)- -outRunBenchmarkOnce iteration bench- = do out $ "Running " ++ benchmarkName bench ++ "..."- result <- runBenchmarkOnce iteration bench- outLn "ok"- outLn result- outBlank - return result-- --- | 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 <- mapM ((flip runBenchmarkOnce) bench) $ take iterations [1..]- outLn "ok"-- let result = BenchResult- { benchResultName = benchmarkName bench- , benchResultRuns = runResults }-- outLn $ compareBenchResultWith priors - $ statBenchResult result- - outBlank- return result-
− BuildBox/Benchmark/BenchResult.hs
@@ -1,369 +0,0 @@-{-# LANGUAGE PatternGuards, StandaloneDeriving, FlexibleContexts, UndecidableInstances, RankNTypes #-}-module BuildBox.Benchmark.BenchResult- ( - -- * Benchmark results - BenchResult (..)- , BenchRunResult (..)-- -- * Concatenation- , concatBenchResult- - -- * Collation- , collateBenchResult-- -- * Statistics- , statCollatedBenchResult- , statBenchResult-- -- * Comparison- , compareBenchResults- , compareBenchResultWith- , compareManyBenchResults- , predBenchResult- , swungBenchResult-- -- * Merging- , mergeBenchResults-- -- * Advancement- , splitBenchResults- , advanceBenchResults- - -- * Application functions- , appBenchRunResult- , appRunResultAspects-- -- * Lifting functions- , liftBenchRunResult- , liftBenchRunResult2- , liftToAspectsOfBenchResult- , liftToAspectsOfBenchResult2- , liftRunResultAspects- , 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.--- 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)----- 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 benchRunResultQuirks bsResults) - (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)) ----- 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-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----- 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 quirks as)- = BenchRunResult ix quirks (f as) ----- | 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 quirks1 as) (BenchRunResult ix2 quirks2 bs)- | ix1 == ix2 = BenchRunResult ix1 (quirks1 ++ quirks2) (f as bs) - | otherwise = error "liftRunResultAspects2: indices don't match"-
− BuildBox/Benchmark/Benchmark.hs
@@ -1,25 +0,0 @@--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)]- }--
BuildBox/Build.hs view
@@ -1,33 +1,34 @@ -- | Defines the main `Build` monad and common utils. module BuildBox.Build - ( module BuildBox.Build.Testable- , module BuildBox.Build.BuildError- , module BuildBox.Build.BuildState- , Build+ ( module BuildBox.Build.Testable+ , module BuildBox.Build.BuildState+ , Build - -- * Building- , runBuild- , runBuildWithState- , runBuildPrint- , runBuildPrintWithState- , successfully+ -- * Building+ , runBuild+ , runBuildWithState+ , runBuildPrint+ , runBuildPrintWithState+ , successfully - -- * Errors- , throw- , needs+ -- * Errors+ , BuildError (..)+ , throw+ , catch+ , needs - -- * Utils- , io- , whenM+ -- * Utils+ , io+ , whenM - -- * Output- , out- , outLn- , outBlank- , outLine- , outLINE- , logSystem)+ -- * Output+ , out+ , outLn+ , outBlank+ , outLine+ , outLINE+ , logSystem) where import BuildBox.Build.Base@@ -35,18 +36,25 @@ import BuildBox.Build.BuildState import BuildBox.Build.BuildError import Control.Monad.State+import Control.Monad.Catch import System.IO+import Prelude +-- | Alias for 'throwM' from Control.Monad.Catch.+throw :: (MonadThrow m, Exception e) => e -> m a+throw = throwM++ -- | 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 ()+ = do mHandle <- gets buildStateLogSystem+ case mHandle of+ Nothing -> return ()+ Just h + -> do io $ hPutStr h "buildbox system: "+ io $ hPutStrLn h cmd+ return ()
BuildBox/Build/Base.hs view
@@ -4,16 +4,16 @@ import BuildBox.Pretty import BuildBox.Build.BuildError import BuildBox.Build.BuildState-import Control.Monad.Error+import Control.Monad.Catch import Control.Monad.State-import Control.Exception (try) import System.IO-import System.Random import System.Directory+import qualified Data.Text as T --- | The builder monad encapsulates and IO action that can fail with an error, ++-- | 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 (StateT BuildState IO) a+type Build a = StateT BuildState IO a -- Build ------------------------------------------------------------------------------------------@@ -21,125 +21,112 @@ -- temporary files (like \"/tmp\") runBuild :: FilePath -> Build a -> IO (Either BuildError a) runBuild scratchDir build- = do uid <- getUniqueId- let s = buildStateDefault uid scratchDir- evalStateT (runErrorT build) s+ = do let s = buildStateDefault scratchDir+ try $ evalStateT build s -- | Like 'runBuild`, but report 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 s = buildStateDefault uid scratchDir- runBuildPrintWithState s build+ = do let s = buildStateDefault scratchDir+ runBuildPrintWithState s build -- | Like `runBuild` but also takes a `BuildState`. runBuildWithState :: BuildState -> Build a -> IO (Maybe a) runBuildWithState s build- = do result <- evalStateT (runErrorT build) s- case result of- Left err- -> do putStrLn $ render $ ppr err- return $ Nothing- - Right x- -> do return $ Just x+ = do result <- try $ evalStateT build s+ case result of+ Left (err :: BuildError)+ -> do putStrLn $ T.unpack $ ppr err+ return $ Nothing + Right x+ -> do return $ Just x + -- | Like `runBuildPrint` but also takes a `BuildState`. runBuildPrintWithState :: BuildState -> Build a -> IO (Maybe a) runBuildPrintWithState s build- = do result <- evalStateT (runErrorT build) s- case result of- Left err- -> do putStrLn "\nBuild failed"- putStr " due to "- putStrLn $ render $ ppr err- return $ Nothing- - Right x- -> do putStrLn "Build succeeded."- return $ Just x+ = do result <- try $ evalStateT build s+ case result of+ Left (err :: BuildError)+ -> do putStrLn "\nBuild failed"+ putStr " due to "+ putStrLn $ T.unpack $ ppr err+ return $ Nothing + 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 ()+successfully f = f >> return () --- | 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.--- A catcher could then usefully create the file, or defer the compuation until it has been +-- 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- isDir <- io $ doesDirectoryExist filePath- - if isFile || isDir- then return ()- else throw $ ErrorNeeds filePath+ = do isFile <- io $ doesFileExist filePath+ isDir <- io $ doesDirectoryExist filePath + if isFile || isDir+ then return ()+ else throwM $ ErrorNeeds filePath + -- Utils ------------------------------------------------------------------------------------------ -- | Lift an IO action into the build monad. -- If the action throws any exceptions they get caught and turned into -- `ErrorIOError` exceptions in our `Build` monad. io :: IO a -> Build a io x- = do -- catch IOError exceptions- result <- liftIO $ try x- - case result of- Left err -> throw $ ErrorIOError err- Right res -> return res+ = do -- catch IOError exceptions+ result <- liftIO $ try x + case result of+ Left err -> throwM $ ErrorIOError err+ 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 ()+ = do b <- cb+ if b then cx else return () -- Output ----------------------------------------------------------------------------------------- -- | Print some text to stdout.-out :: Pretty a => a -> Build ()-out str - = io - $ do putStr $ render $ ppr str- hFlush stdout+out :: Text -> Build ()+out tx+ = io+ $ do putStr $ T.unpack tx+ hFlush stdout -- | Print some text to stdout followed by a newline.-outLn :: Pretty a => a -> Build ()-outLn str = io $ putStrLn $ render $ ppr str+outLn :: Text -> Build ()+outLn tx = io $ putStrLn $ T.unpack tx -- | Print a blank line to stdout outBlank :: Build ()-outBlank = out $ text "\n"+outBlank = out $ string "\n" --- | Print a @-----@ line to stdout +-- | Print a @-----@ line to stdout outLine :: Build ()-outLine = io $ putStr (replicate 80 '-' ++ "\n")+outLine = io $ putStr (replicate 80 '-' ++ "\n") -- | Print a @=====@ line to stdout outLINE :: Build ()-outLINE = io $ putStr (replicate 80 '=' ++ "\n")- +outLINE = io $ putStr (replicate 80 '=' ++ "\n")+
+ BuildBox/Build/Benchmark.hs view
@@ -0,0 +1,66 @@++module BuildBox.Build.Benchmark+ ( Benchmark (..)+ , BenchResult (..)+ , runBenchmark+ , iterateBenchmark+ , timeBuild)+where+import BuildBox.Build.Base+import BuildBox.Data.Physical+import Data.Time++-- | Benchmark definition.+data Benchmark result+ = forall a. Benchmark+ { -- | A unique name for the benchmark+ benchmarkName :: String++ -- | Setup command to run before the main benchmark.+ -- This does not contribute to the reported time of the overall result.+ , benchmarkSetup :: Build ()++ -- | The main command to benchmark.+ , benchmarkCommand :: Build a++ -- | Check and post-process the result of the main command.+ -- This does not contribute to the reported time of the overall result.+ , benchmarkCheck :: a -> Build result }+++-- | Benchmark result.+data BenchResult result+ = BenchResult+ { benchResultName :: String+ , benchResultIteration :: Int+ , benchResultTime :: Seconds+ , benchResultValue :: result }+++-- | Run a benchmark a single time.+runBenchmark :: Benchmark result -> Int -> Build (BenchResult result)+runBenchmark (Benchmark name setup cmd check) i+ = do setup + (secs, x) <- timeBuild cmd+ r <- check x+ return $ BenchResult name i secs r+++-- | Run a benchmark the given number of times.+iterateBenchmark :: Int -> Benchmark result -> Build [BenchResult result]+iterateBenchmark 0 _ = return []+iterateBenchmark count bench+ = do result <- runBenchmark bench count+ rest <- iterateBenchmark (count - 1) bench+ return $ result : rest+++-- | Run a command, returning its elapsed time.+timeBuild :: Build a -> Build (Seconds, a) +timeBuild cmd+ = do start <- io $ getCurrentTime+ result <- cmd+ finish <- io $ getCurrentTime+ let time = fromRational $ toRational $ diffUTCTime finish start+ return (Seconds time, result)+
BuildBox/Build/BuildError.hs view
@@ -2,77 +2,90 @@ {-# OPTIONS_HADDOCK hide #-} module BuildBox.Build.BuildError- (BuildError(..))+ (BuildError(..)) where import BuildBox.Pretty+import Control.Monad.Catch+import Data.Typeable import System.Exit-import Control.Monad.Error-import BuildBox.Data.Log (Log)-import qualified BuildBox.Data.Log as Log+import BuildBox.Data.Log (Log)+import qualified BuildBox.Data.Log as Log+import qualified Data.Text as T -- BuildError ------------------------------------------------------------------------------------- -- | The errors we recognise. data BuildError- -- | Some generic error- = ErrorOther String+ -- | 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 system command fell over, and it barfed out the given stdout and stderr.+ | ErrorSystemCmdFailed+ { buildErrorCmd :: String+ , buildErrorCode :: ExitCode+ , buildErrorStdout :: Log+ , buildErrorStderr :: Log } - -- | Some property `check` was supposed to return the given boolean value, but it didn't.- | forall prop. Show prop => ErrorCheckFailed Bool prop + -- | Some miscellanous IO action failed.+ | ErrorIOError IOError - -- | A build command needs the following file to continue.- -- This can be used for writing make-like bots.- | ErrorNeeds FilePath- + -- | 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+ -- | A build command needs the following file to continue.+ -- This can be used for writing make-like bots.+ | ErrorNeeds FilePath+ deriving Typeable +instance Exception BuildError+++ instance Pretty BuildError where ppr err = case err of- ErrorOther str- -> text "Other error: " <> text str+ ErrorOther str+ -> string "Other error: "+ % string 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)+ ErrorSystemCmdFailed{}+ -> vcat+ $ [ string "System command failure."+ , string " command: " % (string $ buildErrorCmd err)+ , string " exit code: " % (string $ show $ buildErrorCode err)+ , string "" ] - ErrorCheckFailed expected prop- -> text "Check failure: " <> (text $ show prop) <> (text " expected ") <> (text $ show expected)+ ++ (if (not $ Log.null $ buildErrorStdout err)+ then [ string "-- stdout (last 10 lines) ------------------------------------------------------"+ , string $ Log.toString $ Log.lastLines 10 $ buildErrorStdout err]+ else []) - ErrorNeeds filePath- -> text "Build needs: " <> text filePath+ ++ (if (not $ Log.null $ buildErrorStderr err)+ then [ string "-- stderr (last 10 lines) ------------------------------------------------------"+ , string $ Log.toString $ Log.lastLines 10 $ buildErrorStderr err ]+ else []) + ++ (if ( (not $ Log.null $ buildErrorStdout err)+ || (not $ Log.null $ buildErrorStderr err))+ then [ string "--------------------------------------------------------------------------------" ]+ else []) + ErrorIOError ioerr+ -> string "IO error: "+ % (string $ show ioerr)++ ErrorCheckFailed expected prop+ -> string "Check failure: "+ % (string $ show prop)+ % (string " expected ")+ % (string $ show expected)++ ErrorNeeds filePath+ -> string "Build needs: "+ % string filePath++ instance Show BuildError where- show err = render $ ppr err+ show err = T.unpack $ ppr err
BuildBox/Build/BuildState.hs view
@@ -1,36 +1,30 @@ {-# OPTIONS_HADDOCK hide #-} module BuildBox.Build.BuildState- ( BuildState(..)- , buildStateDefault)+ ( 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 }+ = BuildState+ { -- | Log all system commands executed to this file handle.+ buildStateLogSystem :: Maybe Handle+ + -- | 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 }+buildStateDefault :: FilePath -> BuildState+buildStateDefault scratchDir + = BuildState+ { buildStateLogSystem = Nothing+ , buildStateSeq = 0 + , buildStateScratchDir = scratchDir }
BuildBox/Build/Testable.hs view
@@ -3,57 +3,59 @@ -- -- They have `Show` instances so we can make nice error messages if a `check` fails. module BuildBox.Build.Testable- ( Testable(..)- , check- , checkFalse- , outCheckOk- , outCheckFalseOk)+ ( Testable(..)+ , check+ , checkFalse+ , outCheckOk+ , outCheckFalseOk) where-import BuildBox.Build.Base +import BuildBox.Build.Base import BuildBox.Build.BuildError-import Control.Monad.Error+import BuildBox.Pretty+import Control.Monad.Catch -- | Some testable property. class Testable prop where test :: prop -> Build Bool + -- | Testable properties are checkable. -- If the check returns false then throw an error. check :: (Show prop, Testable prop) => prop -> Build () check prop- = do result <- test prop- if result- then return ()- else throwError $ ErrorCheckFailed True prop+ = do result <- test prop+ if result+ then return ()+ else throwM $ ErrorCheckFailed True prop -- | Testable properties are checkable. -- If the check returns true then throw an error. checkFalse :: (Show prop, Testable prop) => prop -> Build () checkFalse prop- = do result <- test prop- if result- then throwError $ ErrorCheckFailed False prop- else return ()- + = do result <- test prop+ if result+ then throwM $ ErrorCheckFailed False prop+ else return () + -- | Check some property while printing what we're doing.-outCheckOk - :: (Show prop, Testable prop) - => String -> prop -> Build ()+outCheckOk+ :: (Show prop, Testable prop)+ => String -> prop -> Build () outCheckOk str prop- = do outLn str- check prop+ = do outLn (string str)+ check prop -- | Check some property while printing what we're doing.-outCheckFalseOk - :: (Show prop, Testable prop) - => String -> prop -> Build ()+outCheckFalseOk+ :: (Show prop, Testable prop)+ => String -> prop -> Build () outCheckFalseOk str prop- = do outLn str- checkFalse prop+ = do outLn (string str)+ checkFalse prop
BuildBox/Command/Darcs.hs view
@@ -11,9 +11,8 @@ -- standard libraries import Data.Time import Data.Maybe-import System.Locale import qualified Data.Sequence as Seq-import qualified Data.ByteString.Char8 as B+import qualified Data.Text as Text -- friends import BuildBox.Build@@ -51,14 +50,12 @@ -- -- | 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 ++ "\"'"@@ -67,7 +64,6 @@ -- 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@@ -78,16 +74,19 @@ 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)+ | otherwise = let (h,t) = Seq.breakl Text.null l+ in patch h : splitPatches (Seq.dropWhileL Text.null t) where patch p =- let toks = words . B.unpack $ Seq.index p 0+ let toks = words . Text.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)+ darcsTimestamp = parseTimeOrError True + defaultTimeLocale+ "%a %b %e %H:%M:%S %Z %Y"+ (unwords time) , darcsAuthor = unwords author , darcsComment = Seq.drop 1 p }
BuildBox/Command/Environment.hs view
@@ -1,22 +1,22 @@ -- | Gathering information about the build environment. module BuildBox.Command.Environment- ( -- * Build Environment- Environment(..)- , getEnvironmentWith- - -- * Build platform- , Platform(..)- , getHostPlatform- , getHostName- , getHostArch- , getHostProcessor- , getHostOS- , getHostRelease- - -- * Software versions- , getVersionGHC- , getVersionGCC)+ ( -- * Build Environment+ Environment(..)+ , getEnvironmentWith++ -- * Build platform+ , Platform(..)+ , getHostPlatform+ , getHostName+ , getHostArch+ , getHostProcessor+ , getHostOS+ , getHostRelease++ -- * Software versions+ , getVersionGHC+ , getVersionGCC) where import BuildBox.Build import BuildBox.Command.System@@ -26,135 +26,144 @@ -- Environment ------------------------------------------------------------------------------------ -- | The environment consists of the `Platform`, and some tool versions.-data Environment - = Environment- { environmentPlatform :: Platform- , environmentVersions :: [(String, String)] }- deriving (Show, Read)+data Environment+ = Environment+ { environmentPlatform :: Platform+ , environmentVersions :: [(String, String)] }+ deriving (Show, Read) instance Pretty Environment where ppr env- = hang (ppr "Environment") 2 $ vcat- [ ppr $ environmentPlatform env- , hang (ppr "Versions") 2 - $ vcat - $ map (\(name, ver) -> ppr name <+> ppr ver) - $ environmentVersions env ]+ = vcat+ [ ppr "Environment"+ , indents 2+ [ ppr $ environmentPlatform env+ , indents 2+ $ ppr "Versions"+ : ( map (\(name, ver) -> ppr name %% ppr ver)+ $ environmentVersions env)+ ]+ ] -- | Get the current environment, including versions of these tools.-getEnvironmentWith - :: [(String, Build String)] -- ^ List of tool names and commands to get their versions.- -> Build Environment- -getEnvironmentWith nameGets - = do platform <- getHostPlatform+getEnvironmentWith+ :: [(String, Build String)] -- ^ List of tool names and commands to get their versions.+ -> Build Environment - versions <- mapM (\(name, get) -> do- ver <- get- return (name, ver))- $ nameGets- - return $ Environment- { environmentPlatform = platform - , environmentVersions = versions }- +getEnvironmentWith nameGets+ = do platform+ <- getHostPlatform + versions+ <- mapM (\(name, get) -> do+ ver <- get+ return (name, ver))+ $ nameGets + return $ Environment+ { environmentPlatform = platform+ , environmentVersions = versions }+++ -- Platform --------------------------------------------------------------------------------------- -- | Generic information about the platform we're running on. data Platform- = Platform- { platformHostName :: String- , platformHostArch :: String- , platformHostProcessor :: String- , platformHostOS :: String- , platformHostRelease :: String }- deriving (Show, Read)- - + = Platform+ { platformHostName :: String+ , platformHostArch :: String+ , platformHostProcessor :: String+ , platformHostOS :: String+ , platformHostRelease :: String }+ deriving (Show, Read)++ instance Pretty Platform where ppr plat- = hang (ppr "Platform") 2 $ vcat- [ ppr "host: " <> (ppr $ platformHostName plat)- , ppr "arch: " <> (ppr $ platformHostArch plat)- , ppr "processor: " <> (ppr $ platformHostProcessor plat)- , ppr "system: " <> (ppr $ platformHostOS plat) <+> (ppr $ platformHostRelease plat) ]+ = vcat+ [ ppr "Platform"+ , indents 2+ [ ppr "host: " % (ppr $ platformHostName plat)+ , ppr "arch: " % (ppr $ platformHostArch plat)+ , ppr "processor: " % (ppr $ platformHostProcessor plat)+ , ppr "system: " % (ppr $ platformHostOS plat)+ %% (ppr $ platformHostRelease plat) ]] -- | Get information about the host platform. getHostPlatform :: Build Platform-getHostPlatform - = do name <- getHostName- arch <- getHostArch- processor <- getHostProcessor- os <- getHostOS- release <- getHostRelease- - return $ Platform- { platformHostName = name- , platformHostArch = arch- , platformHostProcessor = processor- , platformHostOS = os- , platformHostRelease = release }- +getHostPlatform+ = do name <- getHostName+ arch <- getHostArch+ processor <- getHostProcessor+ os <- getHostOS+ release <- getHostRelease + return $ Platform+ { platformHostName = name+ , platformHostArch = arch+ , platformHostProcessor = processor+ , platformHostOS = os+ , platformHostRelease = release }++ -- Platform Tests --------------------------------------------------------------------------------- -- | Get the name of this host, using @uname@. getHostName :: Build String getHostName- = do check $ HasExecutable "uname"- name <- qssystemOut "uname -n"- return $ init name+ = do check $ HasExecutable "uname"+ name <- sesystemq "uname -n"+ return $ init name -- | Get the host architecture, using @uname@. getHostArch :: Build String getHostArch- = do check $ HasExecutable "arch"- name <- qssystemOut "arch"- return $ init name+ = do check $ HasExecutable "arch"+ name <- sesystemq "arch"+ return $ init name -- | Get the host processor name, using @uname@. getHostProcessor :: Build String getHostProcessor- = do check $ HasExecutable "uname"- name <- qssystemOut "uname -p"- return $ init name+ = do check $ HasExecutable "uname"+ name <- sesystemq "uname -p"+ return $ init name -- | Get the host operating system, using @uname@. getHostOS :: Build String getHostOS- = do check $ HasExecutable "uname"- os <- qssystemOut "uname -s"- return $ init os+ = do check $ HasExecutable "uname"+ name <- sesystemq "uname -s"+ return $ init name -- | Get the host operating system release, using @uname@. getHostRelease :: Build String getHostRelease- = do check $ HasExecutable "uname"- str <- qssystemOut "uname -r"- return $ init str+ = do check $ HasExecutable "uname"+ str <- sesystemq "uname -r"+ return $ init str -- Software version tests ------------------------------------------------------------------------- -- | Get the version of this GHC, or throw an error if it can't be found. getVersionGHC :: FilePath -> Build String getVersionGHC path- = do check $ HasExecutable path- str <- qssystemOut $ path ++ " --version"- return $ init str- --- | Get the version of this GCC, or throw an error if it can't be found. + = do check $ HasExecutable path+ str <- sesystemq $ path ++ " --version"+ return $ init str++-- | Get the version of this GCC, or throw an error if it can't be found. getVersionGCC :: FilePath -> Build String getVersionGCC path- = do check $ HasExecutable path- str <- qssystemOut $ path ++ " --version"- return $ head $ lines str+ = do check $ HasExecutable path+ str <- sesystemq $ path ++ " --version"+ return $ head $ lines str
BuildBox/Command/File.hs view
@@ -1,65 +1,71 @@ -- | Working with the file system. module BuildBox.Command.File- ( PropFile(..)- , inDir- , inScratchDir- , clobberDir- , ensureDir- , withTempFile- , atomicWriteFile)+ ( PropFile(..)+ , inDir+ , inScratchDir+ , clobberDir+ , ensureDir+ , withTempFile+ , atomicWriteFile+ , exe ) where import BuildBox.Build-import BuildBox.Command.System import System.Directory import Control.Monad.State+import Control.Monad.Catch+import System.Info+import qualified System.IO.Temp as System+import qualified System.IO as System -- | Properties of the file system we can test for. data PropFile - -- | Some executable is in the current path.- = HasExecutable String+ -- | Some executable is in the current path.+ = HasExecutable String - -- | Some file exists.- | HasFile FilePath+ -- | Some file exists.+ | HasFile FilePath - -- | Some directory exists.- | HasDir FilePath+ -- | Some directory exists.+ | HasDir FilePath - -- | Some file is empty.- | FileEmpty FilePath- deriving Show+ -- | Some file is empty.+ | FileEmpty FilePath+ deriving Show instance Testable PropFile where test prop = case prop of- HasExecutable name- -> do code <- qsystem $ "which " ++ name- return $ code == ExitSuccess+ HasExecutable name+ -> do bin <- io $ findExecutable name+ return $ case bin of+ Just _ -> True+ Nothing -> False - HasFile path- -> io $ doesFileExist path+ HasFile path+ -> io $ doesFileExist path - HasDir path- -> io $ doesDirectoryExist path+ HasDir path+ -> io $ doesDirectoryExist path - FileEmpty path- -> do contents <- io $ readFile path- return (null contents)+ FileEmpty path+ -> do contents <- io $ readFile path+ return (null contents) -- | Run a command in a different working directory. Throws an error if the directory doesn't exist. inDir :: FilePath -> Build a -> Build a inDir name build- = do check $ HasDir name- oldDir <- io $ getCurrentDirectory+ = do check $ HasDir name+ oldDir <- io $ getCurrentDirectory - io $ setCurrentDirectory name- x <- build- io $ setCurrentDirectory oldDir+ io $ setCurrentDirectory name+ x <- build+ io $ setCurrentDirectory oldDir - return x+ return x -- | Create a new directory with the given name, run a command within it, -- then change out and recursively delete the directory. Throws an error if a directory@@ -67,80 +73,83 @@ inScratchDir :: FilePath -> Build a -> Build a inScratchDir name build = do- -- Make sure a dir with this name doesn't already exist.- checkFalse $ HasDir name+ -- Make sure a dir with this name doesn't already exist.+ checkFalse $ HasDir name - ssystem $ "mkdir -p " ++ name- x <- inDir name build+ ensureDir name+ x <- inDir name build+ clobberDir name - ssystem $ "rm -Rf " ++ name- return x+ return x -- | Delete a dir recursively if it's there, otherwise do nothing.--- Unlike `removeDirectoryRecursive`, this function does--- not follow symlinks, it just deletes them. clobberDir :: FilePath -> Build () clobberDir path- = ssystem $ "rm -Rf " ++ path+ = do e <- io $ try $ removeDirectoryRecursive path+ case (e :: Either SomeException ()) of+ _ -> return () -- | Create a new directory if it isn't already there, or return successfully if it is. ensureDir :: FilePath -> Build () ensureDir path- = do already <- io $ doesDirectoryExist path- if already- then return ()- else ssystem $ "mkdir -p " ++ path+ = do already <- io $ doesDirectoryExist path+ if already+ then return ()+ else do e <- io $ try $ createDirectoryIfMissing True path+ case (e :: Either SomeException ()) of+ _ -> return () -- | 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 <- newTempFile-- -- run the real command- result <- build fileName+ = do buildDir <- gets buildStateScratchDir+ buildSeq <- gets buildStateSeq - -- cleanup- io $ removeFile fileName+ -- File name template.+ let sTemplate = "buildbox-" ++ show buildSeq ++ ".tmp" - return result+ System.withTempFile+ buildDir sTemplate+ (\ fileName h+ -> do io $ System.hClose h+ build fileName) --- | 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 }+-- | Atomically write a file by first writing it to a tmp file then renaming it.+-- This prevents concurrent processes from reading half-written files.+atomicWriteFile :: FilePath -> String -> Build ()+atomicWriteFile filePath str+ = do buildDir <- gets buildStateScratchDir+ buildSeq <- gets buildStateSeq - -- Ensure the build directory exists, or canonicalizePath will fail- ensureDir buildDir+ -- File name template.+ let sTemplate = "buildbox-" ++ show buildSeq ++ ".tmp" - -- Build the file name we'll try to use.- let fileName = buildDir ++ "/buildbox-" ++ show buildId ++ "-" ++ show buildSeq+ -- Create a new temp file.+ (tmp, h) <- io $ System.openBinaryTempFile buildDir sTemplate+ io $ System.hClose h - -- 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."+ -- Write the data to the temp file.+ io $ writeFile tmp str+ e <- io $ try $ renameFile tmp filePath - -- Touch the file for good measure.- -- If the unique id wasn't then we want to detect this.- io $ writeFile fileName ""+ -- renameFile may not be able to rename files across physical devices,+ -- depending on the implementation. If renameFile fails then try copyFile.+ case (e :: Either SomeException ()) of+ Right _+ -> return () - io $ canonicalizePath fileName+ Left _+ -> do io $ copyFile tmp filePath+ io $ removeFile tmp+ return () --- | Atomically write a file by first writing it to a tmp file then renaming it.--- This prevents concurrent processes from reading half-written files.-atomicWriteFile :: FilePath -> String -> Build ()-atomicWriteFile filePath str- = do tmp <- newTempFile- io $ writeFile tmp str- ssystem $ "mv " ++ tmp ++ " " ++ filePath+-- | The file extension for an executable on the current system.+exe :: String+exe+ | os == "mingw32" = "exe"+ | otherwise = ""
BuildBox/Command/Mail.hs view
@@ -1,123 +1,122 @@ --- | Sending email. We've got baked in support for @msmtp@, which is easy to set up. Adding support for other mailers --- should be easy. Get @msmtp@ here: <http://msmtp.sourceforge.net>+-- | Sending email.+-- If you're on a system with a working @sendmail@ then use that.+-- Otherwise, the stand-alone @msmtp@ server is easy to set up.+-- Get @msmtp@ here: <http://msmtp.sourceforge.net> module BuildBox.Command.Mail- ( Mail(..)- , Mailer(..)- , createMailWithCurrentTime- , renderMail- , sendMailWithMailer)+ ( Mail(..)+ , Mailer(..)+ , createMailWithCurrentTime+ , renderMail+ , sendMailWithMailer) where import BuildBox.Build import BuildBox.Pretty import BuildBox.Command.Environment import BuildBox.Command.System-import System.Locale (defaultTimeLocale) import Data.Time.Clock import Data.Time.LocalTime import Data.Time.Format import Data.Time.Calendar+import qualified Data.Text as T -- | An email message that we can send. data Mail- = Mail- { mailFrom :: String- , mailTo :: String- , mailSubject :: String- , mailTime :: UTCTime- , mailTimeZone :: TimeZone- , mailMessageId :: String- , mailBody :: String }- deriving Show+ = Mail+ { mailFrom :: String+ , mailTo :: String+ , mailSubject :: String+ , mailTime :: UTCTime+ , mailTimeZone :: TimeZone+ , mailMessageId :: String+ , mailBody :: String }+ deriving Show -- | An external mailer that can send messages.--- Also contains mail server info if needed.+-- Also contains mail server info if needed. data Mailer- -- | 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 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+ -- | 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 -- | Create a mail with a given from, to, subject and body. -- Fill in the date and message id based on the current time. -- Valid dates and message ids are needed to prevent the mail--- being bounced by spambots.-createMailWithCurrentTime - :: String -- ^ ''from'' field. Should be an email address.- -> String -- ^ ''to'' field. Should be an email address.- -> String -- ^ Subject line.- -> String -- ^ Message body.- -> Build Mail+-- being bounced by anti-spam systems.+createMailWithCurrentTime+ :: String -- ^ ''from'' field. Should be an email address.+ -> String -- ^ ''to'' field. Should be an email address.+ -> String -- ^ Subject line.+ -> String -- ^ Message body.+ -> Build Mail createMailWithCurrentTime from to subject body = do- -- We need to add the date otherwise our messages will get marked as spam.- -- Use RFC 2822 format timestamp.- utime <- io $ getCurrentTime- zone <- io $ getCurrentTimeZone+ -- We need to add the date otherwise our messages will get marked as spam.+ -- Use RFC 2822 format timestamp.+ utime <- io $ getCurrentTime+ zone <- io $ getCurrentTimeZone - -- Generate a messageid based on the clock time.- hostName <- getHostName- let dayNum = toModifiedJulianDay $ utctDay utime- let secTime = utctDayTime utime- let messageId = "<" ++ show dayNum ++ "." ++ (init $ show secTime)- ++ "@" ++ hostName ++ ">"- - return $ Mail- { mailFrom = from- , mailTo = to- , mailSubject = subject- , mailTime = utime- , mailTimeZone = zone- , mailMessageId = messageId- , mailBody = body }+ -- Generate a messageid based on the clock time.+ hostName <- getHostName+ let dayNum = toModifiedJulianDay $ utctDay utime+ let secTime = utctDayTime utime+ let messageId = "<" ++ show dayNum ++ "." ++ (init $ show secTime)+ ++ "@" ++ hostName ++ ">" + return $ Mail+ { mailFrom = from+ , mailTo = to+ , mailSubject = subject+ , mailTime = utime+ , mailTimeZone = zone+ , mailMessageId = messageId+ , mailBody = body } + -- | Render an email message as a string.-renderMail :: Mail -> Doc+renderMail :: Mail -> Text renderMail mail = vcat- [ ppr "From: " <> ppr (mailFrom mail)- , ppr "To: " <> ppr (mailTo mail)- , ppr "Subject: " <> ppr (mailSubject mail)- , ppr "Date: " <> (ppr $ formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z"- $ utcToZonedTime (mailTimeZone mail) (mailTime mail))+ [ ppr "From: " % ppr (mailFrom mail)+ , ppr "To: " % ppr (mailTo mail)+ , ppr "Subject: " % ppr (mailSubject mail)+ , ppr "Date: " % (ppr $ formatTime defaultTimeLocale "%a, %e %b %Y %H:%M:%S %z"+ $ utcToZonedTime (mailTimeZone mail) (mailTime mail)) - , ppr "Message-Id: " <> ppr (mailMessageId mail)- , ppr ""- , ppr (mailBody mail) ]+ , ppr "Message-Id: " % ppr (mailMessageId mail)+ , ppr ""+ , ppr (mailBody mail) ] -- | Send a mail message. sendMailWithMailer :: Mail -> Mailer -> Build () sendMailWithMailer mail mailer = case mailer of- MailerSendmail{} - -> ssystemTee False- (mailerPath mailer- ++ " -t ") -- read recipients from the mail- (render $ renderMail mail)-- MailerMSMTP{} - -> ssystemTee False- (mailerPath mailer - ++ " -t " -- read recipients from the mail- ++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer))- (render $ renderMail mail)- -+ MailerSendmail{}+ -> ssystemTee False+ (mailerPath mailer+ ++ " -t ") -- read recipients from the mail+ (T.unpack $ renderMail mail) + MailerMSMTP{}+ -> ssystemTee False+ (mailerPath mailer+ ++ " -t " -- read recipients from the mail+ ++ (maybe "" (\port -> " --port=" ++ show port) $ mailerPort mailer))+ (T.unpack $ renderMail mail)
BuildBox/Command/Network.hs view
@@ -1,46 +1,46 @@ -- | Working with the network. module BuildBox.Command.Network- (PropNetwork(..))+ (PropNetwork(..)) where import BuildBox.Build import BuildBox.Command.File import BuildBox.Command.System -type HostName = String-type URL = String+type HostName = String+type URL = String data PropNetwork - -- | The given host is reachable with @ping@.- = HostReachable HostName+ -- | The given host is reachable with @ping@.+ = HostReachable HostName - -- | Use @wget@ to check if a web-page is gettable.- -- The page is deleted after downloading.- | UrlGettable URL+ -- | Use @wget@ to check if a web-page is gettable.+ -- The page is deleted after downloading.+ | UrlGettable URL - deriving Show- + deriving Show+ instance Testable PropNetwork where test prop = case prop of - -- Works on OSX 10.6.2- -- -o exit successfully after recieving one reply packet.- HostReachable hostName- -> do check $ HasExecutable "ping"- code <- qsystem $ "ping -o " ++ hostName- return $ code == ExitSuccess- - -- Works on OSX 10.6.2, wget 1.12- -- -q quiet- -- --delete-after delete page after downloading.- UrlGettable url- -> do check $ HasExecutable "wget"- code <- qsystem $ "wget -q --delete-after " ++ url- return $ code == ExitSuccess- + -- Works on OSX 10.6.2+ -- -o exit successfully after recieving one reply packet.+ HostReachable hostName+ -> do check $ HasExecutable "ping"+ (code, _, _) <- systemq $ "ping -o " ++ hostName+ return $ code == ExitSuccess+ + -- Works on OSX 10.6.2, wget 1.12+ -- -q quiet+ -- --delete-after delete page after downloading.+ UrlGettable url+ -> do check $ HasExecutable "wget"+ (code, _, _) <- systemq $ "wget -q --delete-after " ++ url+ return $ code == ExitSuccess+ - +
BuildBox/Command/Sleep.hs view
@@ -1,8 +1,8 @@ -- | What do build 'bots dream about? module BuildBox.Command.Sleep- ( sleep- , msleep)+ ( sleep+ , msleep) where import BuildBox.Build import Control.Concurrent@@ -10,11 +10,11 @@ -- | Sleep for a given number of seconds. sleep :: Int -> Build ()-sleep secs - = io $ threadDelay $ secs * 1000000+sleep secs + = io $ threadDelay $ secs * 1000000 - + -- | Sleep for a given number of milliseconds. msleep :: Int -> Build () msleep msecs- = io $ threadDelay $ msecs * 1000+ = io $ threadDelay $ msecs * 1000
BuildBox/Command/System.hs view
@@ -1,29 +1,29 @@ {-# LANGUAGE PatternGuards, BangPatterns #-} --- | Running system commands. On some platforms this may cause the command to be executed directly, so +-- | Running system commands. On some platforms this may cause the command to be executed directly, so -- shell tricks won't work. The `Build` monad can be made to log commands executed with all versions -- of `system` by setting `buildConfigLogSystem` in the `BuildConfig` passed to `runBuildPrintWithConfig`. ----- We define a lot of wrappers because executing system commands is the bread-and-butter of +-- We define a lot of wrappers because executing system commands is the bread-and-butter of -- buildbots, and we usually need all the versions... -module BuildBox.Command.System - ( module System.Exit+module BuildBox.Command.System+ ( module System.Exit - -- * Wrappers- , system- , ssystem- , qsystem- , qssystem- , ssystemOut- , qssystemOut- , systemTee- , systemTeeLog- , ssystemTee- , systemTeeIO+ -- * Wrappers+ , system+ , systemq+ , ssystem+ , ssystemq+ , sesystem+ , sesystemq+ , systemTee+ , systemTeeLog+ , ssystemTee+ , systemTeeIO - -- * The real function- , systemTeeLogIO)+ -- * The real function+ , systemTeeLogIO) where import BuildBox.Command.System.Internals import BuildBox.Build@@ -33,76 +33,86 @@ import Control.Monad.STM import System.Exit import System.IO-import Data.ByteString.Char8 (ByteString)-import BuildBox.Data.Log (Log)-import System.Process hiding (system)-import qualified BuildBox.Data.Log as Log+import Data.ByteString (ByteString)+import BuildBox.Data.Log (Log)+import System.Process hiding (system)+import qualified BuildBox.Data.Log as Log+import qualified Data.Text.Encoding as Text debug :: Bool-debug = False+debug = False trace :: String -> IO ()-trace s = when debug $ putStrLn s+trace s = when debug $ putStrLn s -- Wrappers ------------------------------------------------------------------------------------------ | Run a system command, returning its exit code.-system :: String -> Build ExitCode+-- | Run a system command,+-- returning its exit code and what it wrote to @stdout@ and @stderr@.+system :: String -> Build (ExitCode, String, String) system cmd- = do (code, _, _) <- systemTeeLog True cmd Log.empty- return code+ = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty+ return (code, Log.toString logOut, Log.toString logErr) --- | Run a successful system command.+-- | Quietly run a system command,+-- returning its exit code and what it wrote to @stdout@ and @stderr@.+systemq :: String -> Build (ExitCode, String, String)+systemq cmd+ = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty+ return (code, Log.toString logOut, Log.toString logErr)++++-- | Run a successful system command,+-- returning what it wrote to @stdout@ and @stderr@. -- If the exit code is `ExitFailure` then throw an error in the `Build` monad.-ssystem :: String -> Build ()+ssystem :: String -> Build (String, String) ssystem cmd- = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty-- when (code /= ExitSuccess)- $ throw $ ErrorSystemCmdFailed cmd code logOut logErr+ = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty + when (code /= ExitSuccess)+ $ throw $ ErrorSystemCmdFailed cmd code logOut logErr --- | Quietly run a system command, returning its exit code.-qsystem :: String -> Build ExitCode-qsystem cmd- = do (code, _, _) <- systemTeeLog False cmd Log.empty- return code+ return (Log.toString logOut, Log.toString logErr) --- | Quietly run a successful system command.+-- | Quietly run a successful system command,+-- returning what it wrote to @stdout@ and @stderr@. -- If the exit code is `ExitFailure` then throw an error in the `Build` monad.-qssystem :: String -> Build ()-qssystem cmd- = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty+ssystemq :: String -> Build (String, String)+ssystemq cmd+ = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty - when (code /= ExitSuccess)- $ throw $ ErrorSystemCmdFailed cmd code logOut logErr- + when (code /= ExitSuccess)+ $ throw $ ErrorSystemCmdFailed cmd code logOut logErr + return (Log.toString logOut, Log.toString logErr)++ -- | Run a successful system command, returning what it wrote to its @stdout@.--- If anything was written to @stderr@ then treat that as failure. +-- If anything was written to @stderr@ then treat that as failure. -- If it fails due to writing to @stderr@ or returning `ExitFailure` -- then throw an error in the `Build` monad.-ssystemOut :: String -> Build String-ssystemOut cmd- = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty- when (code /= ExitSuccess || (not $ Log.null logErr))- $ throw $ ErrorSystemCmdFailed cmd code logOut logErr+sesystem :: String -> Build String+sesystem cmd+ = do (code, logOut, logErr) <- systemTeeLog True cmd Log.empty+ when (code /= ExitSuccess || (not $ Log.null logErr))+ $ throw $ ErrorSystemCmdFailed cmd code logOut logErr - return $ Log.toString logOut+ return $ Log.toString logOut -- | Quietly run a successful system command, returning what it wrote to its @stdout@.--- If anything was written to @stderr@ then treat that as failure. +-- If anything was written to @stderr@ then treat that as failure. -- If it fails due to writing to @stderr@ or returning `ExitFailure` -- then throw an error in the `Build` monad.-qssystemOut :: String -> Build String-qssystemOut cmd- = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty- when (code /= ExitSuccess || (not $ Log.null logErr))- $ throw $ ErrorSystemCmdFailed cmd code logOut logErr+sesystemq :: String -> Build String+sesystemq cmd+ = do (code, logOut, logErr) <- systemTeeLog False cmd Log.empty+ when (code /= ExitSuccess || (not $ Log.null logErr))+ $ throw $ ErrorSystemCmdFailed cmd code logOut logErr - return $ Log.toString logOut+ return $ Log.toString logOut @@ -111,113 +121,120 @@ -- | Like `systemTeeIO`, but in the `Build` monad. systemTee :: Bool -> String -> String -> Build (ExitCode, String, String) systemTee tee cmd strIn- = do logSystem cmd- io $ systemTeeIO tee cmd strIn+ = do logSystem cmd+ io $ systemTeeIO tee cmd strIn -- | Like `systemTeeLogIO`, but in the `Build` monad. systemTeeLog :: Bool -> String -> Log -> Build (ExitCode, Log, Log) systemTeeLog tee cmd logIn- = do logSystem cmd- io $ systemTeeLogIO tee cmd logIn+ = do logSystem cmd+ io $ systemTeeLogIO tee cmd logIn -- | 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 (code, logOut, logErr) <- systemTeeLog tee cmd (Log.fromString strIn)- when (code /= ExitSuccess)- $ throw $ ErrorSystemCmdFailed cmd code logOut logErr+ = do (code, logOut, logErr) <- systemTeeLog tee cmd (Log.fromString strIn)+ when (code /= ExitSuccess)+ $ throw $ ErrorSystemCmdFailed cmd code logOut logErr -- | Like `systemTeeLogIO`, but with strings. systemTeeIO :: Bool -> String -> String -> IO (ExitCode, String, String) systemTeeIO tee cmd strIn- = do (code, logOut, logErr) <- systemTeeLogIO tee cmd $ Log.fromString strIn- return (code, Log.toString logOut, Log.toString logErr)+ = do (code, logOut, logErr) <- systemTeeLogIO tee cmd $ Log.fromString strIn+ return (code, Log.toString logOut, Log.toString logErr) -- | Run a system command, returning its `ExitCode` and what was written to @stdout@ and @stderr@. systemTeeLogIO- :: Bool -- ^ Whether @stdout@ and @stderr@ should be forwarded to the parent process.- -> String -- ^ Command to run.- -> Log -- ^ What to pass to the command's @stdin@.- -> IO (ExitCode, Log, Log)+ :: Bool -- ^ Whether @stdout@ and @stderr@ should be forwarded to the parent process.+ -> String -- ^ Command to run.+ -> Log -- ^ What to pass to the command's @stdin@.+ -> IO (ExitCode, Log, Log) systemTeeLogIO tee cmd logIn- = do trace $ "systemTeeIO " ++ show tee ++ ": " ++ cmd+ = do trace $ "systemTeeIO " ++ show tee ++ ": " ++ cmd - -- Create some new pipes for the process to write its stdout and stderr to.- trace $ "systemTeeIO: Creating process"- (Just hInWrite, Just hOutRead, Just hErrRead, phProc)- <- createProcess - $ CreateProcess- { cmdspec = ShellCommand cmd- , cwd = Nothing- , env = Nothing- , std_in = CreatePipe- , std_out = CreatePipe- , std_err = CreatePipe- , close_fds = False - , create_group = False }+ -- Create some new pipes for the process to write its stdout and stderr to.+ trace $ "systemTeeIO: Creating process"+ (Just hInWrite, Just hOutRead, Just hErrRead, phProc)+ <- createProcess+ $ CreateProcess+ { cmdspec = ShellCommand cmd+ , cwd = Nothing+ , env = Nothing+ , std_in = CreatePipe+ , std_out = CreatePipe+ , std_err = CreatePipe+ , close_fds = False+ , create_group = False+ , delegate_ctlc = False+ , detach_console = False+ , create_new_console = False+ , new_session = False+ , child_group = Nothing+ , child_user = Nothing+ , use_process_jobs = True } - -- 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 <- newTChanIO- chanErr <- newTChanIO- semOut <- newQSem 0- semErr <- newQSem 0+ -- 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 - -- Make duplicates of the above, which will store everything- -- written to them. This gives us the copy to return from the fn.- chanOutAcc <- atomically $ dupTChan chanOut- chanErrAcc <- atomically $ dupTChan chanErr+ -- 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 <- newTChanIO+ chanErr <- newTChanIO+ semOut <- newQSem 0+ semErr <- newQSem 0 - -- Fork threads to read from the process handles and write to our channels.- _tidOut <- forkIO $ streamIn hOutRead chanOut- _tidErr <- forkIO $ streamIn hErrRead chanErr+ -- Make duplicates of the above, which will store everything+ -- written to them. This gives us the copy to return from the fn.+ chanOutAcc <- atomically $ dupTChan chanOut+ chanErrAcc <- atomically $ dupTChan chanErr - -- If tee-like behavior is turned on, we forward what the process writes to- -- its stdout and stderr to the parent.- _tidStream <- forkIO $ streamOuts- [ (chanOut, if tee then Just stdout else Nothing, semOut)- , (chanErr, if tee then Just stderr else Nothing, semErr) ]+ -- Fork threads to read from the process handles and write to our channels.+ _tidOut <- forkIO $ streamIn hOutRead chanOut+ _tidErr <- forkIO $ streamIn hErrRead chanErr - -- Wait for the main process to complete.- code <- waitForProcess phProc- trace $ "systemTeeIO: Process done, code = " ++ show code+ -- If tee-like behavior is turned on, we forward what the process writes to+ -- its stdout and stderr to the parent.+ _tidStream <- forkIO $ streamOuts+ [ (chanOut, if tee then Just stdout else Nothing, semOut)+ , (chanErr, if tee then Just stderr else Nothing, semErr) ] - trace $ "systemTeeIO: Waiting for sems"- -- Wait for the tee processes to finish.- -- We need to do this to avoid corrupted output on the console due to our forwarding- -- threads writing at the same time as successing Build commands.- mapM_ waitQSem [semOut, semErr]+ -- Wait for the main process to complete.+ code <- waitForProcess phProc+ trace $ "systemTeeIO: Process done, code = " ++ show code - trace $ "systemTeeIO: Getting output"- -- Get what was written to its stdout and stderr.- -- getChanContents is a lazy read, so don't pull from the channel after- -- seeing a Nothing else we'll block forever.- logOut <- slurpChan chanOutAcc Log.empty- logErr <- slurpChan chanErrAcc Log.empty+ trace $ "systemTeeIO: Waiting for sems"+ -- Wait for the tee processes to finish.+ -- We need to do this to avoid corrupted output on the console due to our forwarding+ -- threads writing at the same time as successing Build commands.+ mapM_ waitQSem [semOut, semErr] - trace $ "systemTeeIO stdout: " ++ Log.toString logOut- trace $ "systemTeeIO stderr: " ++ Log.toString logErr+ trace $ "systemTeeIO: Getting output"+ -- Get what was written to its stdout and stderr.+ -- getChanContents is a lazy read, so don't pull from the channel after+ -- seeing a Nothing else we'll block forever.+ logOut <- slurpChan chanOutAcc Log.empty+ logErr <- slurpChan chanErrAcc Log.empty - trace $ "systemTeeIO: All done"- hClose hOutRead- hClose hErrRead- code `seq` logOut `seq` logErr `seq` - return (code, logOut, logErr)+ trace $ "systemTeeIO stdout: " ++ Log.toString logOut+ trace $ "systemTeeIO stderr: " ++ Log.toString logErr + trace $ "systemTeeIO: All done"+ hClose hOutRead+ hClose hErrRead+ code `seq` logOut `seq` logErr `seq`+ return (code, logOut, logErr)+ slurpChan :: TChan (Maybe ByteString) -> Log -> IO Log slurpChan !chan !ll- = do mStr <- atomically $ readTChan chan- case mStr of- Nothing -> return ll- Just str -> slurpChan chan (ll Log.|> str)+ = do mBS <- atomically $ readTChan chan+ case mBS of+ Nothing -> return ll+ Just bs -> slurpChan chan (ll Log.|> Text.decodeUtf8 bs)
BuildBox/Command/System/Internals.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE PatternGuards, BangPatterns, NamedFieldPuns #-} module BuildBox.Command.System.Internals- ( streamIn- , streamOuts)+ ( streamIn+ , streamOuts) where import System.IO import Control.Concurrent@@ -12,9 +12,9 @@ import Data.IORef import Data.Char import Data.Word-import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Internal as BS-import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString as BS import GHC.IO.Handle.Internals import GHC.IO.Handle.Types@@ -60,15 +60,16 @@ -- Check whether we got an actual newline character on the -- end of the string. let hasNewLine- | BS.last str == '\n' = True- | otherwise = False+ | BS.last str == (fromIntegral $ ord '\n') + = True+ | otherwise = False -- For string ending in newline characters, we don't want to -- push the newline to the consumer, but we need to remember -- if we've seen one to handle the end-of-file condition properly. let str'- | hasNewLine = BS.init str- | otherwise = str+ | hasNewLine = BS.init str+ | otherwise = str atomically $ writeTChan chan (Just str') streamIn' hasNewLine hRead chan)@@ -86,52 +87,53 @@ streamOuts !chans = streamOuts' False [] chans - -- There doesn't seem to be a way to perform a unix-style "select" on channels.- -- We want to wait until any of the channels becomes available for reading.- -- We're doing this just by polling them each in turn, and waiting a bit- -- if none of them had any data.- - where -- we're done.- streamOuts' _ [] [] - = return ()+ -- There doesn't seem to be a way to perform a unix-style "select" on channels.+ -- We want to wait until any of the channels becomes available for reading.+ -- We're doing this just by polling them each in turn, and waiting a bit+ -- if none of them had any data.+ + where -- we're done.+ streamOuts' _ [] [] + = return () - -- play it again, sam.- streamOuts' True prev [] - = streamOuts' False [] prev+ -- play it again, sam.+ streamOuts' True prev [] + = streamOuts' False [] prev - streamOuts' False prev []- = do threadDelay 100000- streamOuts' False [] prev+ streamOuts' False prev []+ = do threadDelay 1000+ yield+ streamOuts' False [] prev - -- try to read from the current chan.- streamOuts' !active !prev (!x@(!chan, !mHandle, !qsem) : rest)- = 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)+ -- try to read from the current chan.+ streamOuts' !active !prev (!x@(!chan, !mHandle, !qsem) : rest)+ = 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- (False, _)- -> streamOuts' active (prev ++ [x]) rest+ else do mStr <- readTChan chan+ return (True, mStr)+ + case mStr of+ (False, _)+ -> streamOuts' active (prev ++ [x]) rest - (True, Nothing)- -> do signalQSem qsem- streamOuts' active prev rest+ (True, Nothing)+ -> do signalQSem qsem+ streamOuts' active prev rest - (True, Just str)- | Just h <- mHandle- -> do BS.hPutStr h str- hPutChar h '\n'- streamOuts' True (prev ++ [x]) rest+ (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 + | otherwise+ -> streamOuts' True (prev ++ [x]) rest -- Code hacked out of Data.ByteString library.@@ -181,7 +183,7 @@ -- was no newline character on the input. if r == w then mkBigPS new_len (xs:xss)- else mkBigPS new_len (BS.pack "\n" : xs : xss)+ else mkBigPS new_len (BS.pack [fromIntegral $ ord '\n'] : xs : xss) else do fill h_ buf{ bufL=0, bufR=0 } new_len (xs:xss)
+ BuildBox/Control/Cron.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A simple ''cron'' loop. Used for running commands according to a given schedule.+module BuildBox.Control.Cron+ ( module BuildBox.Data.Schedule+ , cronLoop )+where+import BuildBox.Build+import BuildBox.Data.Schedule+import BuildBox.Command.Sleep+import Data.Time++-- | Given a schedule of commands, run them when their time is due.+-- Only one command is run at a time. If several commands could be started at a specific+-- moment, then we take the one with the earliest potential start time. If any command throws+-- an error in the `Build` monad then the whole loop does.+--+cronLoop :: Schedule (Build ())-> Build ()+cronLoop schedule+ = do startTime <- io $ getCurrentTime++ case earliestEventToStartAt startTime $ eventsOfSchedule schedule of+ Nothing + -> do sleep 1+ cronLoop schedule+ + Just event + -> do let Just build = lookupCommandOfSchedule (eventName event) schedule+ build+ endTime <- io $ getCurrentTime++ let event' = event+ { eventLastStarted = Just startTime+ , eventLastEnded = Just endTime }++ let schedule' = adjustEventOfSchedule event' schedule+ + cronLoop schedule'+ + + +
BuildBox/Control/Gang.hs view
@@ -2,210 +2,242 @@ -- | A gang consisting of a fixed number of threads that can run actions in parallel. -- Good for constructing parallel test frameworks. module BuildBox.Control.Gang- ( Gang- , GangState(..)+ ( Gang+ , GangState(..) - , forkGangActions- , joinGang- , pauseGang- , resumeGang- , flushGang- , killGang- - , getGangState- , waitForGangState)+ , forkGangActions+ , joinGang+ , pauseGang+ , resumeGang+ , flushGang+ , killGang+ + , getGangState+ , waitForGangState) where import Control.Concurrent+import Control.Exception import Data.IORef-import qualified Data.Set as Set-import Data.Set (Set)+import qualified Data.Set as Set+import Data.Set (Set) + -- Gang ----------------------------------------------------------------------- -- | Abstract gang of threads. data Gang- = Gang - { gangThreads :: Int- , gangThreadsAvailable :: QSemN- , gangState :: IORef GangState- , gangActionsRunning :: IORef Int - , gangThreadsRunning :: IORef (Set ThreadId) }+ = Gang + { gangThreads :: Int + -- | Number of worker threads currently waiting.+ , gangThreadsAvailable :: QSemN + , gangState :: IORef GangState++ , gangActionsRunning :: IORef Int ++ , gangThreadsRunning :: IORef (Set ThreadId) }++ data GangState- = -- | Gang is running and starting new actions.- GangRunning+ = -- | Gang is running and starting new actions.+ GangRunning - -- | Gang may be running already started actions, - -- but no new ones are being started.- | GangPaused+ -- | Gang may be running already started actions, + -- but no new ones are being started.+ | GangPaused - -- | Gang is waiting for currently running actions to finish, - -- but not starting new ones.- | GangFlushing+ -- | Gang is waiting for currently running actions to finish, + -- but not starting new ones.+ | GangFlushing - -- | Gang is finished, all the actions have completed.- | GangFinished- - -- | Gang was killed, all the threads are dead (or dying).- | GangKilled- deriving (Show, Eq)+ -- | Gang is finished, all the actions have completed.+ | GangFinished+ + -- | Gang was killed, all the threads are dead (or dying).+ | GangKilled+ deriving (Show, Eq) -- | Get the state of a gang. getGangState :: Gang -> IO GangState getGangState gang- = readIORef (gangState gang)+ = readIORef (gangState gang) -- | Block until all actions have finished executing, -- or the gang is killed. joinGang :: Gang -> IO ()-joinGang gang- = do state <- readIORef (gangState gang)- if state == GangFinished || state == GangKilled- then return ()- else do- threadDelay 10000- joinGang gang+joinGang !gang+ = do + -- Wait for all the threads to become available.+ waitQSemN (gangThreadsAvailable gang)+ (gangThreads gang) + -- See what state the gang is now in.+ state <- readIORef (gangState gang) + if state == GangFinished || state == GangKilled+ -- The gang is done.+ then return ()++ -- Hmm. We're holding all the threads but the gang is still+ -- running. Maybe the controller hasn't started the first+ -- one yet. Just put them all back and try again.+ -- We delay for a moment to allow the controller to run.+ else do+ threadDelay 1000++ signalQSemN (gangThreadsAvailable gang)+ (gangThreads gang)++ joinGang gang++ -- | Block until already started actions have completed, but don't start any more. -- Gang state changes to `GangFlushing`. flushGang :: Gang -> IO ()-flushGang gang- = do writeIORef (gangState gang) GangFlushing- waitForGangState gang GangFinished+flushGang !gang+ = do atomicWriteIORef (gangState gang) GangFlushing+ waitForGangState gang GangFinished -- | Pause a gang. Actions that have already been started continue to run, -- but no more will be started until a `resumeGang` command is issued. -- Gang state changes to `GangPaused`. pauseGang :: Gang -> IO ()-pauseGang gang- = writeIORef (gangState gang) GangPaused+pauseGang !gang+ = do -- Set the gang to paused mode.+ -- This will prevent any new threads from being started.+ atomicWriteIORef (gangState gang) GangPaused -- | Resume a paused gang, which allows it to continue starting new actions.--- Gang state changes to `GangRunning`.+-- If the gang was paused it now changes to `GangRunning`,+-- otherwise nothing happens. resumeGang :: Gang -> IO ()-resumeGang gang- = writeIORef (gangState gang) GangRunning+resumeGang !gang+ = atomicModifyIORef' (gangState gang) $ \state + -> do case state of + GangPaused -> (GangRunning, ())+ _ -> (state, ()) -- | Kill all the threads in a gang. -- Gang stage changes to `GangKilled`. killGang :: Gang -> IO ()-killGang gang- = do writeIORef (gangState gang) GangKilled- tids <- readIORef (gangThreadsRunning gang) - mapM_ killThread $ Set.toList tids+killGang !gang+ = do + atomicWriteIORef (gangState gang) GangKilled + tids <- readIORef (gangThreadsRunning gang) + mapM_ killThread $ Set.toList tids + -- Signal that all the threads are available.+ --+ -- NOTE: There is a race here where a thread might have terminated+ -- cleanly and already bumped the QSemN just before were to add + -- to it, but we've killed the gang anyway so nothing more will+ -- be run.+ signalQSemN (gangThreadsAvailable gang) (length tids)++ -- | Block until the gang is in the given state. waitForGangState :: Gang -> GangState -> IO ()-waitForGangState gang waitState- = do state <- readIORef (gangState gang)- if state == waitState- then return ()- else do- threadDelay 10000- waitForGangState gang waitState+waitForGangState !gang !waitState+ = do + -- Wait for all the threads to become available.+ waitQSemN (gangThreadsAvailable gang)+ (gangThreads gang) + state <- readIORef (gangState gang) + if state == waitState+ then return ()+ else do+ threadDelay 1000++ signalQSemN (gangThreadsAvailable gang)+ (gangThreads gang)++ waitForGangState gang waitState++ -- | Fork a new gang to run the given actions. -- This function returns immediately, with the gang executing in the background. -- Gang state starts as `GangRunning` then transitions to `GangFinished`. -- To block until all the actions are finished use `joinGang`. forkGangActions- :: Int -- ^ Number of worker threads in the gang \/ maximum number- -- of actions to execute concurrenty.- -> [IO ()] -- ^ Actions to run. They are started in-order, but may finish- -- out-of-order depending on the run time of the individual action.- -> IO Gang+ :: Int -- ^ Number of worker threads in the gang \/ maximum number+ -- of actions to execute concurrenty.+ -> [IO ()] -- ^ Actions to run. They are started in-order, but may finish+ -- out-of-order depending on the run time of the individual action.+ -> IO Gang -forkGangActions threads actions- = do semThreads <- newQSemN threads- refState <- newIORef GangRunning- refActionsRunning <- newIORef 0- refThreadsRunning <- newIORef (Set.empty)- let gang - = Gang- { gangThreads = threads- , gangThreadsAvailable = semThreads - , gangState = refState- , gangActionsRunning = refActionsRunning - , gangThreadsRunning = refThreadsRunning }+forkGangActions !threads !actions+ = do semThreads <- newQSemN threads+ refState <- newIORef GangRunning+ refActionsRunning <- newIORef 0+ refThreadsRunning <- newIORef (Set.empty)+ let gang + = Gang+ { gangThreads = threads+ , gangThreadsAvailable = semThreads + , gangState = refState+ , gangActionsRunning = refActionsRunning + , gangThreadsRunning = refThreadsRunning } - _ <- forkIO $ gangLoop gang actions- return gang- + _ <- forkIO $ gangLoop gang actions+ return gang+ -- | Run actions on a gang. gangLoop :: Gang -> [IO ()] -> IO ()-gangLoop gang []- = do -- Wait for all the threads to finish.- waitQSemN - (gangThreadsAvailable gang) - (gangThreads gang)- - -- Signal that the gang is finished running actions.- writeIORef (gangState gang) GangFinished +gangLoop !gang []+ = do -- Signal that the gang is finished running actions.+ writeIORef (gangState gang) GangFinished -gangLoop gang actions@(action:actionsRest)- = do state <- readIORef (gangState gang)- case state of- GangRunning - -> do -- Wait for a worker thread to become available.- waitQSemN (gangThreadsAvailable gang) 1- gangLoop_withWorker gang action actionsRest+gangLoop !gang actions@(action:actionsRest)+ = do + -- Wait for a worker thread to become available.+ waitQSemN (gangThreadsAvailable gang) 1+ + -- See what state the gang is in.+ state <- readIORef (gangState gang) - GangPaused- -> do threadDelay 10000- gangLoop gang actions- - GangFlushing- -> do actionsRunning <- readIORef (gangActionsRunning gang)- if actionsRunning == 0- then writeIORef (gangState gang) GangFinished- else do - threadDelay 10000- gangLoop gang []+ case state of+ GangRunning + -> do -- Fork off the next action.+ -- We need to use the 'finally' to release the thread+ -- in the case that the action throws an exception.+ tid <- forkOS + $ finally action+ $ do -- Remove our ThreadId from the set of+ -- running ThreadIds.+ tid <- myThreadId+ atomicModifyIORef' (gangThreadsRunning gang)+ (\tids -> (Set.delete tid tids, ())) - GangFinished -> return ()- GangKilled -> return ()+ -- Signal that the worker is now available.+ signalQSemN (gangThreadsAvailable gang) 1+ + -- Add the ThreadId of the freshly forked thread to the set+ -- of running ThreadIds. We'll need this set if we want to kill+ -- the gang.+ atomicModifyIORef' (gangThreadsRunning gang)+ (\tids -> (Set.insert tid tids, ()))+ + -- Handle the rest of the actions.+ gangLoop gang actionsRest --- we have an available worker-gangLoop_withWorker :: Gang -> IO () -> [IO ()] -> IO ()-gangLoop_withWorker gang action actionsRest- = do -- See if we're supposed to be starting actions or not.- state <- readIORef (gangState gang)- case state of- GangRunning- -> do -- fork off the first action- tid <- forkOS $ do- -- run the action (and wait for it to complete)- action+ -- TODO: avoid spinning on pause.+ GangPaused+ -> do signalQSemN (gangThreadsAvailable gang) 1+ threadDelay 1000+ gangLoop gang actions+ + GangFlushing -> return ()+ GangFinished -> return ()+ GangKilled -> return () - -- signal that a new worker is available- signalQSemN (gangThreadsAvailable gang) 1- - -- remove our ThreadId from the set of running ThreadIds.- tid <- myThreadId- atomicModifyIORef (gangThreadsRunning gang)- (\tids -> (Set.delete tid tids, ()))- - -- Add the ThreadId of the freshly forked thread to the set- -- of running ThreadIds. We'll need this set if we want to kill- -- the gang.- atomicModifyIORef (gangThreadsRunning gang)- (\tids -> (Set.insert tid tids, ()))- - -- handle the rest of the actions.- gangLoop gang actionsRest - -- someone issued flush or pause command while we- -- were waiting for a worker, so don't start next action.- _ -> do- signalQSemN (gangThreadsAvailable gang) 1- gangLoop gang (action:actionsRest)
− BuildBox/Cron.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}-{-# OPTIONS -fno-warn-orphans #-}---- | A simple ''cron'' loop. Used for running commands according to a given schedule.-module BuildBox.Cron- ( module BuildBox.Cron.Schedule- , cronLoop )-where-import BuildBox.Build-import BuildBox.Cron.Schedule-import BuildBox.Command.Sleep-import Data.Time---- | Given a schedule of commands, run them when their time is due.--- Only one command is run at a time. If several commands could be started at a specific--- moment, then we take the one with the earliest potential start time. If any command throws--- an error in the `Build` monad then the whole loop does.----cronLoop :: Schedule (Build ())-> Build ()-cronLoop schedule- = do startTime <- io $ getCurrentTime-- case earliestEventToStartAt startTime $ eventsOfSchedule schedule of- Nothing - -> do sleep 1- cronLoop schedule- - Just event - -> do let Just build = lookupCommandOfSchedule (eventName event) schedule- build- endTime <- io $ getCurrentTime-- let event' = event- { eventLastStarted = Just startTime- , eventLastEnded = Just endTime }-- let schedule' = adjustEventOfSchedule event' schedule- - cronLoop schedule'- - - -
− BuildBox/Cron/Schedule.hs
@@ -1,210 +0,0 @@-{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}-{-# OPTIONS -fno-warn-orphans #-}---- | A schedule of commands that should be run at a certain time.-module BuildBox.Cron.Schedule- ( - -- * Time Periods- second, minute, hour, day-- -- * When- , When (..)- , WhenModifier (..)-- -- * Events- , EventName- , Event (..)- , earliestEventToStartAt- , eventCouldStartAt-- -- * Schedules- , Schedule (..)- , makeSchedule- , lookupEventOfSchedule- , lookupCommandOfSchedule- , adjustEventOfSchedule- , eventsOfSchedule)-where-import Data.Time-import Data.List-import Data.Function-import Data.Maybe-import Control.Monad-import Data.Map (Map)-import qualified Data.Map as Map--instance Read NominalDiffTime where- readsPrec n str- = let [(secs :: Double, rest)] = readsPrec n str- in case rest of- 's' : rest' -> [(fromRational $ toRational secs, rest')]- _ -> []--second, minute, hour, day :: NominalDiffTime-second = 1-minute = 60-hour = 60 * minute-day = 24 * hour----- When ---------------------------------------------------------------------------------------------- | When to invoke some event.-data When- -- | Just keep doing it.- = Always-- -- | Don't do it, ever.- | Never-- -- | Do it some time after we last started it.- | Every NominalDiffTime- - -- | Do it some time after it last finished.- | After NominalDiffTime- - -- | Do it each day at this time. The ''days'' are UTC days, not local ones.- | Daily TimeOfDay- deriving (Read, Show, Eq)----- | Modifier to when.-data WhenModifier- -- | If the event hasn't been invoked before then do it immediately- -- when we start the cron process.- = Immediate-- -- | Wait until after this time before doing it first.- | WaitUntil UTCTime- deriving (Read, Show, Eq)----- Event -------------------------------------------------------------------------------------------type EventName = String---- | Records when an event should start, and when it last ran.-data Event- = Event- { -- | A unique name for this event.- -- Used when writing the schedule to a file.- eventName :: EventName-- -- | When to run the command.- , eventWhen :: When-- -- | Modifier to the previous.- , eventWhenModifier :: Maybe WhenModifier-- -- | When the event was last started, if any.- , eventLastStarted :: Maybe UTCTime- - -- | When the event last finished, if any.- , eventLastEnded :: Maybe UTCTime }- deriving (Read, Show, Eq)- ---- | Given the current time and a list of events, determine which one should be started now.--- If several events are avaliable then take the one with the earliest start time.-earliestEventToStartAt :: UTCTime -> [Event] -> Maybe Event-earliestEventToStartAt curTime events- = let eventsStartable = filter (eventCouldStartAt curTime) events- eventsSorted = sortBy (compare `on` eventLastStarted) eventsStartable- in listToMaybe eventsSorted----- | Given the current time, decide whether an event could be started.--- If the `WhenModifier` is `Immediate` this always returns true.--- 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- , Just lastEnded <- eventLastEnded event- , lastEnded < lastStarted- = False-- -- Keep waiting if there's a seconday wait modifier.- | Just (WaitUntil waitTime) <- eventWhenModifier event- , curTime < waitTime- = False-- -- Otherwise we have to look at the real schedule.- | otherwise- = case eventWhen event of- Always -> True- Never -> False-- Every diffTime - -> maybe True- (\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)- (eventLastStarted event)-- After diffTime - -> maybe True- (\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)- (eventLastEnded event)- - Daily timeOfDay- -- 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- -> False- - | otherwise- -> let -- If we were going to run it today, this is when it would be.- startTimeToday- = curTime- { utctDayTime = timeOfDayToTime timeOfDay }- - -- If it's after that time then quit fooling around..- in curTime > startTimeToday----- Schedule ------------------------------------------------------------------------------------------ | Map of event names to their details and build commands. -data Schedule cmd- = Schedule (Map EventName (Event, cmd))----- | Get the list of events in a schedule, ignoring the build commands.-eventsOfSchedule :: Schedule cmd -> [Event]-eventsOfSchedule (Schedule sched)- = map fst $ Map.elems sched----- | A nice way to produce a schedule.-makeSchedule :: [(EventName, When, Maybe WhenModifier, cmd)] -> Schedule cmd-makeSchedule tuples- = let makeSched (name, whn, mMod, cmd)- = (name, (Event name whn mMod Nothing Nothing, cmd))- in Schedule $ Map.fromList $ map makeSched tuples----- | Given an event name, lookup the associated event from a schedule.-lookupEventOfSchedule :: EventName -> Schedule cmd -> Maybe Event-lookupEventOfSchedule name (Schedule sched)- = liftM fst $ Map.lookup name sched- - --- | Given an event name, lookup the associated build command from a schedule.-lookupCommandOfSchedule :: EventName -> Schedule cmd -> Maybe cmd-lookupCommandOfSchedule name (Schedule sched)- = liftM snd $ Map.lookup name sched----- | Given a new version of an event, update any matching event in the schedule.--- If the event not already there then return the original schedule.-adjustEventOfSchedule :: Event -> Schedule cmd -> Schedule cmd-adjustEventOfSchedule event (Schedule sched)- = Schedule - $ Map.adjust - (\(_, build) -> (event, build))- (eventName event) - sched
+ BuildBox/Data/Comparison.hs view
@@ -0,0 +1,48 @@++module BuildBox.Data.Comparison+ ( -- * Comparisons+ Comparison (..)+ , makeComparison)+where+import BuildBox.Pretty+import Text.Printf+import qualified Data.Text as T+++-- | 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+ = string $ printf "%s (----)"+ (T.unpack $ ppr recent)++ | otherwise+ = string $ printf "%s (%+4.0f)"+ (T.unpack $ 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)
+ BuildBox/Data/Detail.hs view
@@ -0,0 +1,64 @@++-- | The detail is the name of an `Aspect` seprate from its data.+module BuildBox.Data.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 -> string "runtime (wall clock)"+ TotalCpu -> string "runtime (cpu usage)"+ TotalSys -> string "runtime (sys usage)"++ KernelWall -> string "kernel runtime (wall clock)"+ KernelCpu -> string "kernel runtime (cpu usage)"+ KernelSys -> string "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 -> string "maximum heap usage"+ HeapAlloc -> string "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 -> string "executable size"++
BuildBox/Data/Dividable.hs view
@@ -1,13 +1,13 @@ module BuildBox.Data.Dividable- (Dividable(..))+ (Dividable(..)) where class Dividable a where- divide :: a -> a -> a- + divide :: a -> a -> a+ instance Dividable Integer where- divide = div+ divide = div instance Dividable Float where- divide = (/)+ divide = (/)
BuildBox/Data/Log.hs view
@@ -2,28 +2,28 @@ -- | When the output of a command is long, keeping it as a `String` is a bad idea. module BuildBox.Data.Log- ( Log- , Line- , empty- , null- , toString- , fromString- , (<|)- , (|>)- , (><)- , firstLines- , lastLines)+ ( Log+ , Line+ , empty+ , null+ , toString+ , fromString+ , (<|)+ , (|>)+ , (><)+ , firstLines+ , lastLines) where-import Data.ByteString.Char8 (ByteString)-import Data.Sequence (Seq)-import qualified Data.ByteString.Char8 as BS-import qualified Data.Sequence as Seq-import qualified Data.Foldable as F-import Prelude hiding (null)+import Data.Sequence (Seq)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F+import Prelude hiding (null) -- | A sequence of lines, without newline charaters on the end.-type Log = Seq Line-type Line = ByteString+type Log = Seq Line+type Line = Text -- | O(1) No logs here.@@ -36,39 +36,39 @@ -- | O(n) Convert a `Log` to a `String`. toString :: Log -> String-toString ll - = BS.unpack - $ BS.intercalate (BS.pack "\n") - $ F.toList ll+toString ll + = Text.unpack + $ Text.intercalate (Text.pack "\n") + $ F.toList ll -- | O(n) Convert a `String` to a `Log`. fromString :: String -> Log-fromString str - = Seq.fromList - $ BS.splitWith (== '\n')- $ BS.pack str+fromString str + = Seq.fromList + $ Text.lines + $ Text.pack str -- | O(1) Add a `Line` to the start of a `Log`. (<|):: Line -> Log -> Log-(<|) = (Seq.<|)+(<|) = (Seq.<|) -- | O(1) Add a `Line` to the end of a `Log`.-(|>) :: Log -> Line -> Log-(|>) = (Seq.|>)+(|>) :: Log -> Line -> Log+(|>) = (Seq.|>) -- | O(log(min(n1,n2))) Concatenate two `Log`s.-(><) :: Log -> Log -> Log-(><) = (Seq.><)+(><) :: Log -> Log -> Log+(><) = (Seq.><) -- | O(n) Take the first m lines from a log firstLines :: Int -> Log -> Log firstLines m ll- = Seq.take m ll+ = Seq.take m ll -- | O(n) Take the last m lines from a log lastLines :: Int -> Log -> Log lastLines m ll- = Seq.drop (Seq.length ll - m) ll- + = Seq.drop (Seq.length ll - m) ll+
+ BuildBox/Data/Physical.hs view
@@ -0,0 +1,61 @@++module BuildBox.Data.Physical+ ( Seconds (..)+ , Bytes (..))+where+import BuildBox.Data.Dividable+import BuildBox.Pretty+import Data.Maybe+++-- | Seconds of time, pretty printed in engineering format.+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 (string (show f))+ $ pprEngDouble "s" f+++-- | Bytes of data, pretty printed in engineering format.+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 (string (show b))+ $ pprEngInteger "B" b
+ BuildBox/Data/Range.hs view
@@ -0,0 +1,43 @@++module BuildBox.Data.Range+ ( Range (..)+ , makeRange+ , flattenRange)+where+import BuildBox.Pretty+import BuildBox.Data.Dividable+++-- | A range extracted from many-valued data.+data Range a+ = Range+ { rangeMin :: a+ , rangeAvg :: a+ , rangeMax :: a }+ deriving (Read, Show)+++instance Pretty a => Pretty (Range a) where+ ppr (Range mi av mx)+ = ppr mi %% string "/"+ %% ppr av %% string "/"+ %% ppr mx+++instance Functor Range where+ fmap f (Range mi av mx)+ = Range (f mi) (f av) (f mx)+++-- | Make statistics from a list of values.+makeRange :: (Real a, Dividable a) => [a] -> Range a+makeRange xs+ = Range (minimum xs)+ (sum xs `divide` (fromIntegral $ length xs))+ (maximum xs)+++-- | Flatten a `Range` into a list of its min, avg and max values.+flattenRange :: Range a -> [a]+flattenRange (Range mi av mx)+ = [mi, av, mx]
+ BuildBox/Data/Schedule.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE ScopedTypeVariables, PatternGuards #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | A schedule of commands that should be run at a certain time.+module BuildBox.Data.Schedule+ (+ -- * Time Periods+ second, minute, hour, day++ -- * When+ , When (..)+ , WhenModifier (..)++ -- * Events+ , EventName+ , Event (..)+ , earliestEventToStartAt+ , eventCouldStartAt++ -- * Schedules+ , Schedule (..)+ , makeSchedule+ , lookupEventOfSchedule+ , lookupCommandOfSchedule+ , adjustEventOfSchedule+ , eventsOfSchedule)+where+import Data.Time+import Data.List+import Data.Function+import Data.Maybe+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map++instance Read NominalDiffTime where+ readsPrec n str+ = let [(secs :: Double, rest)] = readsPrec n str+ in case rest of+ 's' : rest' -> [(fromRational $ toRational secs, rest')]+ _ -> []++second, minute, hour, day :: NominalDiffTime+second = 1+minute = 60+hour = 60 * minute+day = 24 * hour+++-- When -------------------------------------------------------------------------------------------+-- | When to invoke some event.+data When+ -- | Just keep doing it.+ = Always++ -- | Don't do it, ever.+ | Never++ -- | Do it some time after we last started it.+ | Every NominalDiffTime++ -- | Do it some time after it last finished.+ | After NominalDiffTime++ -- | Do it each day at this time. The ''days'' are UTC days, not local ones.+ | Daily TimeOfDay+ deriving (Read, Show, Eq)+++-- | Modifier to when.+data WhenModifier+ -- | If the event hasn't been invoked before then do it immediately+ -- when we start the cron process.+ = Immediate++ -- | Wait until after this time before doing it first.+ | WaitUntil UTCTime+ deriving (Read, Show, Eq)+++-- Event ------------------------------------------------------------------------------------------+type EventName = String++-- | Records when an event should start, and when it last ran.+data Event+ = Event+ { -- | A unique name for this event.+ -- Used when writing the schedule to a file.+ eventName :: EventName++ -- | When to run the command.+ , eventWhen :: When++ -- | Modifier to the previous.+ , eventWhenModifier :: Maybe WhenModifier++ -- | When the event was last started, if any.+ , eventLastStarted :: Maybe UTCTime++ -- | When the event last finished, if any.+ , eventLastEnded :: Maybe UTCTime }+ deriving (Read, Show, Eq)+++-- | Given the current time and a list of events, determine which one should be started now.+-- If several events are avaliable then take the one with the earliest start time.+earliestEventToStartAt :: UTCTime -> [Event] -> Maybe Event+earliestEventToStartAt curTime events+ = let eventsStartable = filter (eventCouldStartAt curTime) events+ eventsSorted = sortBy (compare `on` eventLastStarted) eventsStartable+ in listToMaybe eventsSorted+++-- | Given the current time, decide whether an event could be started.+-- If the `WhenModifier` is `Immediate` this always returns true.+-- 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+ , Just lastEnded <- eventLastEnded event+ , lastEnded < lastStarted+ = False++ -- Keep waiting if there's a seconday wait modifier.+ | Just (WaitUntil waitTime) <- eventWhenModifier event+ , curTime < waitTime+ = False++ -- Otherwise we have to look at the real schedule.+ | otherwise+ = case eventWhen event of+ Always -> True+ Never -> False++ Every diffTime+ -> maybe True+ (\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+ (eventLastStarted event)++ After diffTime+ -> maybe True+ (\lastTime -> (curTime `diffUTCTime` lastTime ) > diffTime)+ (eventLastEnded event)++ Daily timeOfDay+ -- 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+ -> False++ | otherwise+ -> let -- If we were going to run it today, this is when it would be.+ startTimeToday+ = curTime+ { utctDayTime = timeOfDayToTime timeOfDay }++ -- If it's after that time then quit fooling around..+ in curTime > startTimeToday+++-- Schedule ---------------------------------------------------------------------------------------+-- | Map of event names to their details and build commands.+data Schedule cmd+ = Schedule (Map EventName (Event, cmd))+++-- | Get the list of events in a schedule, ignoring the build commands.+eventsOfSchedule :: Schedule cmd -> [Event]+eventsOfSchedule (Schedule sched)+ = map fst $ Map.elems sched+++-- | A nice way to produce a schedule.+makeSchedule :: [(EventName, When, Maybe WhenModifier, cmd)] -> Schedule cmd+makeSchedule tuples+ = let makeSched (name, whn, mMod, cmd)+ = (name, (Event name whn mMod Nothing Nothing, cmd))+ in Schedule $ Map.fromList $ map makeSched tuples+++-- | Given an event name, lookup the associated event from a schedule.+lookupEventOfSchedule :: EventName -> Schedule cmd -> Maybe Event+lookupEventOfSchedule name (Schedule sched)+ = liftM fst $ Map.lookup name sched+++-- | Given an event name, lookup the associated build command from a schedule.+lookupCommandOfSchedule :: EventName -> Schedule cmd -> Maybe cmd+lookupCommandOfSchedule name (Schedule sched)+ = liftM snd $ Map.lookup name sched+++-- | Given a new version of an event, update any matching event in the schedule.+-- If the event not already there then return the original schedule.+adjustEventOfSchedule :: Event -> Schedule cmd -> Schedule cmd+adjustEventOfSchedule event (Schedule sched)+ = Schedule+ $ Map.adjust+ (\(_, build) -> (event, build))+ (eventName event)+ sched
− BuildBox/FileFormat/BuildResults.hs
@@ -1,112 +0,0 @@-{-# LANGUAGE PatternGuards #-}--module BuildBox.FileFormat.BuildResults- ( BuildResults(..)- , mergeResults- , acceptResult- , advanceResults)-where-import BuildBox.Time-import BuildBox.Benchmark-import BuildBox.Command.Environment-import BuildBox.Pretty-import BuildBox.Aspect-import Data.List-import Data.Function----- | A simple build results file format.-data BuildResults- = BuildResults- { buildResultTime :: UTCTime- , buildResultEnvironment :: Environment- , buildResultBench :: [BenchResult Single] }- 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 }----- | 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 }--
BuildBox/IO/Directory.hs view
@@ -1,73 +1,73 @@ -- | Directory utils that don't need to be in the Build monad. module BuildBox.IO.Directory- ( lsFilesIn- , lsDirsIn- , traceFilesFrom)+ ( 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+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+ = 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+ 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 :: 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+ contents <- liftIO $ getDirectoryContents path+ + -- only keep directories+ dirs <- filterM (liftIO . doesDirectoryExist)+ $ map (\f -> path ++ "/" ++ f)+ $ dropDotPaths contents - return $ sort dirs+ 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+ = do isDir <- doesDirectoryExist path+ isFile <- doesFileExist path - let result- | isDir - = do contents <- liftM dropDotPaths- $ getDirectoryContents path+ let result+ | isDir + = do contents <- liftM dropDotPaths+ $ getDirectoryContents path - liftM (join . Seq.fromList)- $ mapM traceFilesFrom - $ map (\f -> path ++ "/" ++ f) - $ contents+ liftM (join . Seq.fromList)+ $ mapM traceFilesFrom + $ map (\f -> path ++ "/" ++ f) + $ contents - | isFile- = return $ Seq.singleton path- - | otherwise- = return $ Seq.empty- - result+ | 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+ = filter (\f -> f /= "." && f /= "..") xx
BuildBox/Pretty.hs view
@@ -1,82 +1,167 @@-{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances,- OverlappingInstances, IncoherentInstances #-}+{-# LANGUAGE ScopedTypeVariables, TypeSynonymInstances, FlexibleInstances #-} +-- Don't warn about Data.Monoid import in GHC 8.2 -> 8.4 transition.+{-# OPTIONS_GHC -Wno-unused-imports #-}+ -- | Pretty printing utils. module BuildBox.Pretty- ( module Text.PrettyPrint- , Pretty(..)- , padRc, padR- , padLc, padL- , blank- , pprEngDouble- , pprEngInteger)+ ( Pretty(..)+ , Text+ , (%), (%%), empty+ , char, string, text+ , vcat, vsep+ , hcat, hsep+ , parens, braces, brackets, angles+ , indents+ , padRc, padR+ , padLc, padL+ , pprEngDouble+ , pprEngInteger) where-import Text.PrettyPrint import Text.Printf-import Data.Time import Control.Monad+import Data.Text (Text)+import Data.Time+import Data.Monoid+import Data.List+import qualified Data.Text as T --- Things that can be pretty printed++-- Pretty --------------------------------------------------------------------- class Pretty a where- ppr :: a -> Doc+ ppr :: a -> Text --- Basic instances-instance Pretty Doc where- ppr = id- -instance Pretty Float where- ppr = text . show -instance Pretty Int where- ppr = int- -instance Pretty Integer where- ppr = text . show+-- Basic Combinators ----------------------------------------------------------+-- | An empty text string.+empty :: Text+empty = string " " ++-- | Append two text strings.+(%) :: Text -> Text -> Text+(%) t1 t2 = t1 <> t2+++-- | Append two text strings separated by a space.+(%%) :: Text -> Text -> Text+(%%) t1 t2 = t1 <> string " " <> t2+++-- | Convert a single Char to text.+char :: Char -> Text+char c = T.pack [c]+++-- | Convert a String to text.+string :: String -> Text+string s = T.pack s+++-- | Convert a Text to Text (id).+text :: Text -> Text+text t = t+++-- | Concatenate a list of text.+hcat :: [Text] -> Text+hcat = mconcat+++-- | Concatenate a list of text, with spaces in between.+hsep :: [Text] -> Text+hsep ts = mconcat $ intersperse (string " ") ts+++-- | Concatenate a list of text vertically.+vcat :: [Text] -> Text+vcat ts = mconcat $ intersperse (string "\n") ts+++-- | Concatenate a list of text vertically, with blank lines in between.+vsep :: [Text] -> Text+vsep ts = mconcat $ intersperse (string "\n\n") ts+++-- | Wrap a text thing in round parens.+parens :: Text -> Text+parens tx = string "(" % tx % string ")"+++-- | Wrap a text thing in round parens.+braces :: Text -> Text+braces tx = string "{" % tx % string "}"+++-- | Wrap a text thing in round parens.+brackets :: Text -> Text+brackets tx = string "[" % tx % string "]"+++-- | Wrap a text thing in round parens.+angles :: Text -> Text+angles tx = string "<" % tx % string ">"+++-- | Indent some text by the given number of characters.+indents :: Int -> [Text] -> Text+indents n ts+ = mconcat [ string (replicate n ' ') % t | t <- ts ]+++-- Basic Instances ------------------------------------------------------------ instance Pretty UTCTime where- ppr = text . show- -instance Pretty a => Pretty [a] where- ppr xx - = lbrack <> (hcat $ punctuate (text ", ") (map ppr xx)) <> rbrack+ ppr = T.pack . show +instance Pretty Text where+ ppr = id+ instance Pretty String where- ppr = text+ ppr = T.pack +instance Pretty Int where+ ppr = T.pack . show +instance Pretty Integer where+ ppr = T.pack . show++instance Pretty Char where+ ppr = T.pack . show++ -- | Right justify a doc, padding with a given character.-padRc :: Int -> Char -> Doc -> Doc-padRc n c str- = (text $ replicate (n - length (render str)) c) <> str- +padRc :: Int -> Char -> Text -> Text+padRc n c tx+ = (string $ replicate (n - length (T.unpack tx)) c) <> tx + -- | Right justify a string with spaces.-padR :: Int -> Doc -> Doc-padR n str = padRc n ' ' str+padR :: Int -> Text -> Text+padR n str+ = padRc n ' ' str -- | Left justify a string, padding with a given character.-padLc :: Int -> Char -> Doc -> Doc-padLc n c str- = str <> (text $ replicate (n - length (render str)) c)+padLc :: Int -> Char -> Text -> Text+padLc n c tx+ = tx <> (string $ replicate (n - length (T.unpack tx)) c) -- | Left justify a string with spaces.-padL :: Int -> Doc -> Doc-padL n str = padLc n ' ' str---- | Blank text. This is different different from `empty` because it comes out a a newline when used in a `vcat`.-blank :: Doc-blank = ppr ""+padL :: Int -> Text -> Text+padL n str+ = padLc n ' ' str --- | 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+-- Engineering Numbers --------------------------------------------------------+-- | 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 Text 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+ | k < 0 = fmap (string "-" <>) $ pprEngInteger unit (-k)+ | k > 1000 = pprEngDouble unit (fromRational $ toRational k)+ | otherwise = Just $ string $ printf "%5d%s " k unit -- | Pretty print an engineering value, to 4 significant figures.@@ -90,9 +175,9 @@ -- liftM render $ pprEngDouble \"s\" 0.0000123 ==> Just \"12.30us\" -- @ ---pprEngDouble :: String -> Double -> Maybe Doc+pprEngDouble :: String -> Double -> Maybe Text pprEngDouble unit k- | k < 0 = liftM (text "-" <>) $ pprEngDouble unit (-k)+ | k < 0 = liftM (string "-" <>) $ 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)@@ -112,9 +197,10 @@ | 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+ | otherwise = Just $ string $ printf "%5.0f%s " k unit+ where+ with (t :: Double) (u :: String)+ | t >= 1e3 = string $ printf "%.0f%s" t u+ | t >= 1e2 = string $ printf "%.1f%s" t u+ | t >= 1e1 = string $ printf "%.2f%s" t u+ | otherwise = string $ printf "%.3f%s" t u
− BuildBox/Quirk.hs
@@ -1,37 +0,0 @@--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-
− BuildBox/Reports/BenchResult.hs
@@ -1,58 +0,0 @@-{-# 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---- | 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 (resultWinners, resultLosers, _)- = splitBenchResults swing comparisons- - 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-
BuildBox/Time.hs view
@@ -1,82 +1,81 @@ -- | Time utils useful for writing buildbots. module BuildBox.Time- ( module Data.Time- , readLocalTimeOfDayAsUTC- , getStampyTime- , getMidnightTodayLocal- , getMidnightTodayUTC- , getMidnightTomorrowLocal- , getMidnightTomorrowUTC)+ ( module Data.Time+ , readLocalTimeOfDayAsUTC+ , getStampyTime+ , getMidnightTodayLocal+ , getMidnightTodayUTC+ , getMidnightTomorrowLocal+ , getMidnightTomorrowUTC) where import Data.Time-import System.Locale -- | Read a time of day string like @17:34:05@ in the local time zone -- and convert that to a UTC time of day. Good for parsing command line args to buildbots. readLocalTimeOfDayAsUTC :: String -> IO TimeOfDay readLocalTimeOfDayAsUTC str- = do - -- Get the current timeZone.- curTime <- getZonedTime+ = do + -- Get the current timeZone.+ curTime <- getZonedTime - -- Convert the time of day to what it would be as UTC.- let (_, timeOfDayUTC)- = localToUTCTimeOfDay - (zonedTimeZone curTime)- (read str) + -- Convert the time of day to what it would be as UTC.+ let (_, timeOfDayUTC)+ = localToUTCTimeOfDay + (zonedTimeZone curTime)+ (read str) - return timeOfDayUTC+ return timeOfDayUTC -- | Get a local time stamp with format YYYYMMDD_HHMMSS. Good for naming files with. getStampyTime :: IO String getStampyTime- = do time <- getZonedTime- return $ formatTime defaultTimeLocale "%0Y%0m%0d_%0k%0M%0S" time+ = do time <- getZonedTime+ return $ formatTime defaultTimeLocale "%0Y%0m%0d_%0k%0M%0S" time -- | Get the local midnight we've just had as a `LocalTime`. getMidnightTodayLocal :: IO LocalTime getMidnightTodayLocal- = do curTime <- getZonedTime- return $ LocalTime- { localDay = localDay $ zonedTimeToLocalTime curTime- , localTimeOfDay = midnight }+ = do curTime <- getZonedTime+ return $ LocalTime+ { localDay = localDay $ zonedTimeToLocalTime curTime+ , localTimeOfDay = midnight } -- | Get the local midnight that we've just had, as a `UTCTime`. getMidnightTodayUTC :: IO UTCTime getMidnightTodayUTC- = do curTime <- getZonedTime- return $ zonedTimeToUTC- $ ZonedTime- (LocalTime - { localDay = localDay $ zonedTimeToLocalTime curTime- , localTimeOfDay = midnight })- (zonedTimeZone curTime)+ = do curTime <- getZonedTime+ return $ zonedTimeToUTC+ $ ZonedTime+ (LocalTime + { localDay = localDay $ zonedTimeToLocalTime curTime+ , localTimeOfDay = midnight })+ (zonedTimeZone curTime) -- | Get the local midnight we're about to have as a `LocalTime`. getMidnightTomorrowLocal :: IO LocalTime getMidnightTomorrowLocal- = do curTime <- getZonedTime- return $ LocalTime- { localDay = addDays 1 (localDay (zonedTimeToLocalTime curTime)) - , localTimeOfDay = midnight }+ = do curTime <- getZonedTime+ return $ LocalTime+ { localDay = addDays 1 (localDay (zonedTimeToLocalTime curTime)) + , localTimeOfDay = midnight } -- | Get the local midnight we're about to have as a `UTCTime`.-getMidnightTomorrowUTC :: IO UTCTime+getMidnightTomorrowUTC :: IO UTCTime getMidnightTomorrowUTC- = do curTime <- getZonedTime- return $ zonedTimeToUTC- $ ZonedTime- (LocalTime- { localDay = addDays 1 (localDay (zonedTimeToLocalTime curTime)) - , localTimeOfDay = midnight })- (zonedTimeZone curTime)+ = do curTime <- getZonedTime+ return $ zonedTimeToUTC+ $ ZonedTime+ (LocalTime+ { localDay = addDays 1 (localDay (zonedTimeToLocalTime curTime)) + , localTimeOfDay = midnight })+ (zonedTimeZone curTime) - - + +
LICENSE view
@@ -1,24 +1,25 @@-Copyright (c) 2010, University of New South Wales.-All rights reserved.+Copyright (c) 2010-2013, The Data Parallel Haskell Team Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.- * Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in the- documentation and/or other materials provided with the distribution.- * Neither the name of the University of New South Wales nor the- names of its contributors may be used to endorse or promote products- derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL COPYRIGHT HOLDERS BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+- Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++- Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++- The names of the copyright holders may not be used to endorse or promote+ products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
buildbox.cabal view
@@ -1,5 +1,5 @@ Name: buildbox-Version: 1.5.3.1+Version: 2.2.1.2 License: BSD3 License-file: LICENSE Author: Ben Lippmeier@@ -13,9 +13,6 @@ 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 the Command functions are just wrappers around shell commands, so be careful about passing- them weirdly formed arguments.- Synopsis: Rehackable components for writing buildbots and test harnesses. @@ -23,57 +20,57 @@ GHC == 7.0.3 Library- Build-Depends: - base == 4.5.*,- containers >= 0.4 && < 0.5,- time >= 1.1 && <= 1.4,- directory >= 1.0 && <= 1.2,- mtl >= 2.0 && < 3.0,- old-locale == 1.0.*,- process == 1.1.*,- random == 1.0.*,- pretty == 1.1.*,- bytestring == 0.9.*,- stm == 2.2.*+ Build-Depends:+ base >= 4.4 && < 4.13,+ containers >= 0.4 && < 0.7,+ bytestring >= 0.9 && < 0.11,+ exceptions >= 0.8 && < 0.11,+ old-locale >= 1.0 && < 1.1,+ directory >= 1.1 && < 1.4,+ temporary >= 1.2 && < 1.4,+ process >= 1.2 && < 1.7,+ time >= 1.2 && < 1.9,+ text >= 1.2 && < 1.3,+ mtl >= 2.2 && < 2.3,+ stm >= 2.4 && < 2.6 ghc-options: -Wall+ -fno-warn-unused-do-bind Exposed-modules:- 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.Benchmark BuildBox.Build.BuildError BuildBox.Build.BuildState- BuildBox.Build+ BuildBox.Build.Testable BuildBox.Command.Darcs BuildBox.Command.Environment BuildBox.Command.File BuildBox.Command.Mail BuildBox.Command.Network- BuildBox.Command.System BuildBox.Command.Sleep+ BuildBox.Command.System+ BuildBox.Control.Cron BuildBox.Control.Gang- BuildBox.Cron.Schedule- BuildBox.Cron- BuildBox.Data.Log+ BuildBox.Data.Comparison+ BuildBox.Data.Detail BuildBox.Data.Dividable- BuildBox.FileFormat.BuildResults+ BuildBox.Data.Log+ BuildBox.Data.Physical+ BuildBox.Data.Range+ BuildBox.Data.Schedule BuildBox.IO.Directory+ BuildBox.Build BuildBox.Pretty- BuildBox.Quirk BuildBox.Time+ BuildBox Other-modules: BuildBox.Command.System.Internals BuildBox.Build.Base- BuildBox.Aspect.Aspect- BuildBox.Benchmark.Benchmark++ Extensions:+ ExistentialQuantification+ ScopedTypeVariables+ TypeSynonymInstances+ BangPatterns