module Definitions where
import Prelude hiding ( readFile )
import System.IO.Strict( readFile )
import Control.Applicative
import Data.Array.Vector
import Data.Function
import Data.IORef
import Data.List
import Data.List.Split ( wordsBy, splitOn )
import Data.Maybe
import Data.DateTime( DateTime, formatDateTime )
import Data.Ord
import Data.Time
import Data.Char
import Data.Digest.Pure.SHA
import Network.BSD ( HostName, getHostName )
import Statistics.Sample
import System.Directory
import System.FilePath
import System.Locale
import System.IO.Unsafe
import Text.JSON
import Text.Printf
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BL
import Shellish (Command)
type Darcs = [String] -> Command String
data Test a = Test (Benchmark a) TestRepo TestBinary deriving (Show)
data VCS = VCSDarcs | VCSGit | VCSHg deriving (Eq, Ord, Show, Read)
data TestBinary = TestBinary { binCommand :: String
, binVersionString :: String
, binDate :: DateTime
, binGHC :: String
, binVCS :: VCS
, binContext :: BS.ByteString }
deriving (Eq, Ord, Show, Read)
binVersion :: TestBinary -> [Int]
binVersion = parsever . binVersionString
where parsever = map read . wordsBy (== '.') . takeWhile (`elem` "0123456789.-")
binSha1 :: TestBinary -> String
binSha1 bin = showDigest (sha1 $ BL.fromChunks [BS.pack txt, binContext bin])
where txt = show (binVersionString bin) ++ " " ++
(formatDateTime "%Y-%m-%d %H:%M:%S" $ binDate bin) ++ " "
data ParamStamp = Params { pHostName :: HostName
, pFlush :: Maybe (FilePath -> IO ()) }
type TimeStamp = UTCTime
type Version = [Int] -- we could also use Data.Version
-- the difference here is just that we explicitly
-- do not have a notion of version tags
global :: IORef (ParamStamp, TimeStamp)
global = unsafePerformIO $ do t <- getCurrentTime
hn <- getHostName
newIORef (Params hn Nothing, t)
maybeVMFlush :: FilePath -> IO ()
maybeVMFlush darcs = do
(p,_) <- readIORef global
case pFlush p of
Just f -> f darcs
Nothing -> return ()
-- ----------------------------------------------------------------------
-- benchmarks
-- ----------------------------------------------------------------------
type BenchmarkCmd a = Darcs -> TestRepo -> Command a
data BenchmarkSpeed = FastB | SlowB deriving (Eq)
data Benchmark a = Idempotent String BenchmarkSpeed (BenchmarkCmd a)
| Destructive String BenchmarkSpeed (BenchmarkCmd a)
| Description String
instance Show (Benchmark a) where
show = description -- FIXME: is this right?
description :: Benchmark a -> String
description (Idempotent d _ _) = d
description (Destructive d _ _) = d
description (Description d) = d
speed :: Benchmark a -> BenchmarkSpeed
speed (Idempotent _ s _) = s
speed (Destructive _ s _) = s
speed (Description _) = FastB
-- ----------------------------------------------------------------------
-- repositories
-- ----------------------------------------------------------------------
data TestRepo = TestRepo { trName :: String
, trCoreName :: String -- ^ (variants only) name of the orig repo
, trPath :: FilePath -- ^ relative to the config file
, trAnnotate :: Maybe FilePath -- ^ relative to repo, eg. @Just "README"@
, trVariants :: [Variant]
, trSkip :: [String] -- ^ skip benchmarks w/ description matching any of these strings
}
deriving (Read, Show, Eq, Ord)
instance JSON TestRepo where
readJSON (JSObject o) =
TestRepo <$> jlookup "name"
<*> jlookup "name" -- 2nd time for trCoreName
<*> jlookup "path"
<*> jlookupMaybe "annotate"
<*> (map toVariant . (DefaultVariant :) <$> jlookupMaybeList "variants")
<*> jlookupMaybeList "skip"
where
jlookup a = case lookup a (fromJSObject o) of
Nothing -> fail "Unable to read TestRepo"
Just v -> readJSON v
jlookupMaybe a = case lookup a (fromJSObject o) of
Nothing -> return Nothing
Just JSNull -> return Nothing
Just v -> Just <$> readJSON v
jlookupMaybeList a = case lookup a (fromJSObject o) of
Nothing -> return []
Just v -> readJSONs v
readJSON _ = fail "Unable to read TestRepo"
showJSON = error "showJSON not defined for TestRepo yet"
-- note that the order of the variants is reflected in the tables
data VariantName = DefaultVariant | OptimizePristineVariant | GitVariant | HgVariant
deriving (Enum, Bounded, Eq, Ord, Read, Show)
instance JSON VariantName where
readJSON (JSString s) =
case fromJSString s of
"optimize-pristine" -> return OptimizePristineVariant
"git" -> return GitVariant
"hg" -> return HgVariant
x -> fail $ "Unknown variant: " ++ x
readJSON _ = fail "Unable to VariantName"
showJSON = error "showJSON not defined for VariantName yet"
data Variant = Variant { vId :: VariantName
, vShortName :: String
, vDescription :: String
, vSuffix :: String
}
deriving (Eq, Ord, Show, Read)
toVariant :: VariantName -> Variant
toVariant n@DefaultVariant =
Variant n "default" "default (hashed)" ""
toVariant n@OptimizePristineVariant =
Variant n "opt pris" "optimize --pristine" "op"
toVariant n@GitVariant =
Variant n "git" "git" "git"
toVariant n@HgVariant =
Variant n "hg" "hg" "hg"
-- | Given a name of a repo like "tabular opt pris", figure out what the
-- variant was. If there are no suffixes, like "opt pris", we assume
-- it's not a variant.
nameToVariant :: String -> Variant
nameToVariant n =
case [ v | v <- variants, vShortName v `isSuffixOf` n ] of
[] -> toVariant DefaultVariant
(v:_) -> v
where
variants = sortBy (compare `on` (negate . suffixLength)) -- longest suffixes first
$ allVariants
suffixLength = length . vShortName
allVariants :: [Variant]
allVariants = map toVariant [minBound .. maxBound]
-- | The subset of variants appropriate to the given darcs version
appropriateVariants :: TestBinary -> [Variant] -> [Variant]
appropriateVariants bin = filter (appropriate . vId)
where appropriate GitVariant
| vcs /= VCSGit = False
appropriate HgVariant
| vcs /= VCSHg = False
appropriate OptimizePristineVariant
| vcs /= VCSDarcs || ver < [2,3,97] = False
appropriate DefaultVariant
| vcs /= VCSDarcs || ver > [2,4,96] = False
appropriate _ = True
vcs = binVCS bin
ver = binVersion bin
-- ----------------------------------------------------------------------
-- long-term storage
-- ----------------------------------------------------------------------
-- TODO: machine info? hash this?
paramStampPath :: ParamStamp -> String
paramStampPath p = intercalate "-" [ pHostName p, flushStr ]
where
flushStr = if isJust (pFlush p) then "cold" else "warm"
timeStampPath :: TimeStamp -> String
timeStampPath t = formatTime defaultTimeLocale "%Y-%m-%dT%H%M" t -- we don't need to be super-precise here
resultsDir :: IO FilePath
resultsDir =
do home <- getHomeDirectory
return $ home </> ".darcs-benchmark"
timingsDir :: ParamStamp -> IO FilePath
timingsDir cstmp =
do d <- resultsDir
return $ d </> paramStampPath cstmp <.> "timings"
appendBinary :: TestBinary -> IO ()
appendBinary bin =
do (pstmp, _) <- readIORef global
path <- flip replaceExtension "info" `fmap` timingsDir pstmp
current <- (read `fmap` readFile path) `catch` \_ -> return []
let new = (sha, bin) : [ (s, x) | (s, x) <- current, s /= sha ]
writeFile path (show new)
where sha = binSha1 bin
appendResult :: Test a -> [MemTime] -> IO ()
appendResult (Test benchmark tr bin) times =
do (pstmp, tstmp) <- readIORef global
d <- resultsDir
createDirectoryIfMissing False d
td <- timingsDir pstmp
createDirectoryIfMissing False td
appendFile (td </> timeStampPath tstmp) block
where
block = unlines $ map (intercalate "\t" . fields) times
fields mt = [ trName tr, binSha1 bin, description benchmark ] ++ fieldMt mt
fieldMt (MemTime m t) = [ show (fromRational m :: Float), show t ]
-- ----------------------------------------------------------------------
-- outputs
-- ----------------------------------------------------------------------
precision :: Int
precision = 1
data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)
data MemTimeOutput = MemTimeOutput { mtTimeMean :: Double
, mtTimeDev :: Double
, mtSampleSize :: Int
, mtMemMean :: Rational
}
deriving (Show)
mkMemTimeOutput :: [MemTime] -> MemTimeOutput
mkMemTimeOutput xs =
MemTimeOutput { mtTimeMean = mean time_v
, mtTimeDev = stdDev time_v
, mtMemMean = toRational (mean mem_v)
, mtSampleSize = lengthU time_v
}
where
time_v = toU [ t | MemTime _ t <- xs ]
mem_v = toU [ fromRational m | MemTime m _ <- xs ]
data RepoTable = RepoTable { rtRepo :: String
, rtColumns :: [String]
, rtRows :: [String]
, rtTable :: [(TimeUnit, [Maybe MemTimeOutput])]
}
-- Reformat (test, output) array as a square table by (core) Repository
repoTables :: [Benchmark ()] -> [(Test a, Maybe MemTimeOutput)] -> [RepoTable]
repoTables benchmarks results = [RepoTable { rtRepo = reponame (head repo)
, rtColumns = columns repo
, rtRows = rows
, rtTable = table repo
} | repo <- reposResults]
where
reposResults = groupBy (on (==) reponame) $ sortBy repoOrder results
reponame (Test _ tr _, _) = trCoreName tr
repoOrder = comparing reponame
--
rows = map description . filter hasBenchmark $ benchmarks
hasBenchmark b = any (\ (Test tb _ _, _) -> description tb == description b) results
--
columns repo = map mkColName $ columnInfos repo
columnInfos repo = nub [ (b, trName tr) | (Test _ tr b, _) <- repo ]
mkColName (b, tname) =
let v = nameToVariant tname
prefix = case vId v of
DefaultVariant -> ""
_-> vSuffix v ++ " "
in prefix ++ cutdown (binCommand b)
cutdown d | "darcs-" `isPrefixOf` d = cutdown (drop 6 d)
| takeExtension d == ".exe" = dropExtension d
| otherwise = d
--
table repo = [(tu (tableRow row), map justMemTimeOutput $ tableRow row)
| row <- rows]
where
tableRow row = [find (match row col) repo | col <- columnInfos repo]
getTime (Just (_, Just mt)) = Just (mtTimeMean mt)
getTime _ = Nothing
tu row = case mapMaybe getTime row of
[] -> Milliseconds
xs -> appropriateUnit (minimum xs)
match bench (binary, name) (Test bench' tr binary', _) =
bench == description bench' && binary == binary' && trName tr == name
justMemTimeOutput (Just (_, mt)) = mt
justMemTimeOutput Nothing = Nothing
data TimeUnit = MinutesAndSeconds | Milliseconds
formatTimeElapsed :: TimeUnit -> Double -> String
formatTimeElapsed Milliseconds raw = formatNumber (raw * 1000) ++ "ms"
formatTimeElapsed MinutesAndSeconds raw =
case mins raw of
Nothing -> formatNumber (secs raw) ++ "s"
Just m -> show m ++ "m" ++ formatNumber (secs raw) ++ "s"
where
secs x = (fromInteger (floor x `mod` 60)) + (x - fromInteger (floor x))
mins x | x > 60 = Just (floor x `div` 60 :: Int)
| otherwise = Nothing
appropriateUnit :: Double -> TimeUnit
appropriateUnit s | s < 2 = Milliseconds
| otherwise = MinutesAndSeconds
data Cell h a = ColHeader h | Cell a | MissingCell
formatNumber :: (PrintfArg a, Fractional a) => a -> String
formatNumber = printf $ "%."++(show precision)++"f"
type Formatter = TimeUnit -> Cell String MemTimeOutput -> [String]
formatSampleSize :: Formatter
formatSampleSize _ (ColHeader h) = [ h ]
formatSampleSize _ MissingCell = [ "-" ]
formatSampleSize _ (Cell mt) = [ show (mtSampleSize mt) ++ "x" ]
formatTimeResult :: Formatter
formatTimeResult _ (ColHeader h) = [ h, "sdev" ]
formatTimeResult _ MissingCell = [ "-", "-" ]
formatTimeResult tu (Cell mt) =
[ vouchFor $ time $ combineMeanStddev mt, "(" ++ time (mtTimeDev mt) ++ ")" ]
where
time t = formatTimeElapsed tu t
vouchFor = case mtSampleSize mt of -- FIXME: YUCK! hard coded; cf. criterion
sz | sz < 5 -> showChar '?'
| sz < 20 -> showChar '~'
| otherwise -> id
-- | This is simply mean + stddev, but we could potentially
-- change it in the future to, for example, mean + 2 stddev
combineMeanStddev :: MemTimeOutput -> Double
combineMeanStddev mt = mtTimeMean mt + mtTimeDev mt
formatMemoryResult :: Formatter
formatMemoryResult _ (ColHeader s) = [ s ]
formatMemoryResult _ MissingCell = [ "-" ]
formatMemoryResult _ (Cell mt) =
[ formatNumber ((realToFrac (mtMemMean mt / (1024*1024))) :: Float) ++ "M" ]