packages feed

ghc-bench 0.3.3 → 0.3.4

raw patch · 4 files changed

+120/−47 lines, 4 files

Files

ghc-bench.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           ghc-bench-version:        0.3.3+version:        0.3.4 synopsis:       Benchmark a Haskell development system description:    See the README at <https://github.com/sol/ghc-bench#readme> category:       Development@@ -34,6 +34,7 @@       Imports       Result       Run+      System.Console.GetOpt.Util       SystemInfo       SystemInfo.Type   hs-source-dirs:@@ -77,6 +78,7 @@       Imports       Result       Run+      System.Console.GetOpt.Util       SystemInfo       SystemInfo.Type       CommandSpec
src/Run.hs view
@@ -1,9 +1,9 @@ module Run (   main -, DryRun(..)-, Prepare(..)-, PrintQR(..)+, Mode(..)+, Config(..)+, defaultConfig , parseOptions , run ) where@@ -14,6 +14,8 @@ import Data.Text.IO (putStr, putStrLn) import System.Directory (getXdgDirectory, XdgDirectory(..), getTemporaryDirectory, createDirectoryIfMissing) import System.Exit (die)+import System.Console.GetOpt+import System.Console.GetOpt.Util qualified as GetOpt  import Command qualified import SystemInfo (Concurrency)@@ -51,44 +53,50 @@ ghciPackage :: FilePath ghciPackage = "containers-0.8" -data DryRun = NoDryRun | DryRun-  deriving (Eq, Show, Bounded) -data Prepare = NoPrepare | Prepare-  deriving (Eq, Show, Bounded)--data PrintQR = NoPrintQR | PrintQR-  deriving (Eq, Show, Bounded)--parseOptions :: [FilePath] -> (DryRun, (Prepare, (PrintQR, [FilePath])))-parseOptions = (fmap . fmap) parsePrintQR . fmap parsePrepare . parseDryRun+data Mode = DryRun | Prepare | Run+  deriving (Eq, Show) -parseDryRun :: [FilePath] -> (DryRun, [FilePath])-parseDryRun = parseOption "dry-run"+data Config = Config {+  mode :: Mode+, printQR :: Bool+, jobs :: Maybe Concurrency+} deriving (Eq, Show) -parsePrepare :: [FilePath] -> (Prepare, [FilePath])-parsePrepare = parseOption "prepare"+defaultConfig :: Config+defaultConfig = Config {+    mode = Run+  , printQR = False+  , jobs = Nothing+  } -parsePrintQR :: [FilePath] -> (PrintQR, [FilePath])-parsePrintQR = parseOption "qr"+parseOptions :: [String] -> IO (Config, [String])+parseOptions = GetOpt.evalIOWithHelp defaultConfig [+    Option [] ["dry-run"] (NoArg \ c -> pure c { mode = DryRun }) ""+  , Option [] ["prepare"] (NoArg \ c -> pure c { mode = Prepare }) ""+  , Option [] ["qr"] (NoArg \ c -> pure c { printQR = True }) ""+  , Option ['j'] ["jobs"] (ReqArg parseConcurrency "N") ""+  ] -parseOption :: Bounded a => String -> [String] -> (a, [String])-parseOption name = List.partition (== "--" <> name) >>> first \ case-  [] -> minBound-  _ -> maxBound+parseConcurrency :: String -> Config -> IO Config+parseConcurrency input c = do+  n <- GetOpt.readArgument "--jobs" input+  pure c { jobs = Just n }  main :: [String] -> IO ()-main (parseOptions -> (dryRun, (prepare, (printQR, args)))) = do+main argv = do +  (config, args) <- parseOptions argv+   cacheDir <- getXdgDirectory XdgCache "ghc-bench"   createDirectoryIfMissing True cacheDir   baseDir <- getTemporaryDirectory <&> (</> "ghc-bench")   createDirectoryIfMissing False baseDir -  qrencode <- case printQR of-    NoPrintQR -> do+  qrencode <- case config.printQR of+    False -> do       return Nothing-    PrintQR -> do+    True -> do       let command = "qrencode"       Command.require command       return $ Just (\ url -> Command.call command ["-t", "ANSIUTF8", url])@@ -97,11 +105,11 @@   SystemInfo.requireAll   stage0 <- Command.resolve ghc   system <- SystemInfo.collect-  concurrency <- SystemInfo.nproc+  concurrency <- maybe SystemInfo.nproc pure config.jobs    putStr . unlines $ "" : SystemInfo.pretty system -  times <- run cacheDir (withTempDirectory baseDir "build") dryRun prepare args stage0 concurrency+  times <- run cacheDir (withTempDirectory baseDir "build") config args stage0 concurrency   unless (null times) do     putStrLn "\ntimes:"     for_ times \ (Label name, time) -> do@@ -112,8 +120,8 @@  type WithTempDirectory = forall a. (FilePath -> IO a) -> IO a -run :: FilePath -> WithTempDirectory -> DryRun -> Prepare -> [String] -> FilePath -> Concurrency -> IO [(Label, Seconds)]-run cacheDir withTemp dryRun prepare args stage0 concurrency = requireDependencies >> case args of+run :: FilePath -> WithTempDirectory -> Config -> [String] -> FilePath -> Concurrency -> IO [(Label, Seconds)]+run cacheDir withTemp config args stage0 concurrency = requireDependencies >> case args of   [] -> runAll   [name] | Just action <- lookup name actions -> action   _ -> die usage@@ -138,13 +146,13 @@     runAll = concat <$> sequence (map snd actions)      actions :: [(String, IO [(Label, Seconds)])]-    actions = map (fmap $ withTemp . runBenchmark dryRun prepare) benchmarkActions+    actions = map (fmap $ withTemp . runBenchmark config) benchmarkActions      usage :: FilePath-    usage = "\nusage: ghc-bench [ " <> List.intercalate " | " (map fst actions) <> " ] [ --dry-run ] [ --prepare ]"+    usage = "\nusage: ghc-bench [ " <> List.intercalate " | " (map fst actions) <> " ] [ --dry-run ] [ --prepare ] [ --qr ] [ -j N | --jobs N ]" -runBenchmark :: DryRun -> Prepare -> Benchmark () -> FilePath -> IO [(Label, Seconds)]-runBenchmark dryRun prepare action dir = case (dryRun, prepare) of-  (DryRun, _) -> Benchmark.dryRun $ Benchmark.cd dir action-  (_, Prepare) -> Benchmark.prepare $ Benchmark.cd dir action-  _ -> Benchmark.run $ Benchmark.cd dir action+runBenchmark :: Config -> Benchmark () -> FilePath -> IO [(Label, Seconds)]+runBenchmark config action dir = case config.mode of+  DryRun -> Benchmark.dryRun $ Benchmark.cd dir action+  Prepare -> Benchmark.prepare $ Benchmark.cd dir action+  Run -> Benchmark.run $ Benchmark.cd dir action
+ src/System/Console/GetOpt/Util.hs view
@@ -0,0 +1,63 @@+module System.Console.GetOpt.Util where++import Prelude+import Text.Read (readMaybe)+import System.IO+import System.Exit+import System.Environment+import System.Console.GetOpt++evalWithHelp :: config -> [OptDescr (config -> config)] -> [String] -> IO (config, [String])+evalWithHelp defaults = evalIOWithHelp defaults . liftM++evalIOWithHelp :: config -> [OptDescr (config -> IO config)] -> [String] -> IO (config, [String])+evalIOWithHelp defaults = evalIO defaults . appendHelpOption++eval :: config -> [OptDescr (config -> config)] -> [String] -> IO (config, [String])+eval defaults = evalIO defaults . liftM++evalIO :: config -> [OptDescr (config -> IO config)] -> [String] -> IO (config, [String])+evalIO defaults options argv = case getOpt Permute options argv of+  (_, _, err : _) -> tryHelp err+  (opts, args, []) -> (,) <$> foldM defaults opts <*> pure args++liftM :: Monad m => [OptDescr (config -> config)] -> [OptDescr (config -> m config)]+liftM = map (fmap . fmap $ return)++foldM :: Monad m => config -> [config -> m config] -> m config+foldM = foldl' (>>=) . pure++fold :: config -> [config -> config] -> config+fold = foldl' (flip id)++printHelp :: [OptDescr a] -> IO ()+printHelp options = do+  name <- getProgName+  Prelude.putStr $ usageInfo ("Usage: " ++ name ++ " [OPTION]...\n\nOPTIONS") options++printHelpAndExit :: [OptDescr a] -> IO b+printHelpAndExit options = do+  printHelp options+  exitSuccess++tryHelp :: String -> IO a+tryHelp message = do+  name <- getProgName+  hPutStr stderr $ name ++ ": " ++ message ++ "Try `" ++ name ++ " --help' for more information.\n"+  exitFailure++appendHelpOption :: [OptDescr (a -> IO b)] -> [OptDescr (a -> IO b)]+appendHelpOption options = opts+  where+    opts = options ++ [helpOption opts]++helpOption :: [OptDescr a] -> OptDescr (t -> IO b)+helpOption options = Option [] ["help"] (NoArg \ _ -> printHelpAndExit options) "display this help and exit"++readArgument :: Read a => String -> String -> IO a+readArgument option argument = case readMaybe argument of+  Nothing -> invalidArgument option argument+  Just value -> return value++invalidArgument :: String -> String -> IO a+invalidArgument option argument = tryHelp $ "invalid argument `" ++ argument ++ "' for `" ++ option ++ "'\n"
test/RunSpec.hs view
@@ -4,25 +4,25 @@ import System.IO.Silently import README (ensureFile) +import Run (Config(..), Mode(..), defaultConfig, parseOptions) import Run qualified-import Run (DryRun(..), Prepare(..), PrintQR(..))  spec :: Spec spec = do   describe "--dry-run" do     it "prints commands" do-      let run = Run.run "~/.cache/ghc-bench" ($ "<sandbox>") DryRun NoPrepare [] "/path/to/ghc-9.12.4" 20+      let run = Run.run "~/.cache/ghc-bench" ($ "<sandbox>") defaultConfig { mode = DryRun } [] "/path/to/ghc-9.12.4" 20       capture_ run >>= ensureFile "test/dry-run" . encodeUtf8 . pack    describe "parseOptions" do     it "accepts --dry-run" do-      Run.parseOptions ["--dry-run", "foo", "bar"]-        `shouldBe` (DryRun, (NoPrepare, (NoPrintQR, ["foo", "bar"])))+      parseOptions ["--dry-run", "foo", "bar"]+        `shouldReturn` (defaultConfig { mode = DryRun }, ["foo", "bar"])      it "accepts --prepare" do-      Run.parseOptions ["--prepare", "foo", "bar"]-        `shouldBe` (NoDryRun, (Prepare, (NoPrintQR, ["foo", "bar"])))+      parseOptions ["--prepare", "foo", "bar"]+        `shouldReturn` (defaultConfig { mode = Prepare }, ["foo", "bar"])      it "accepts --qr" do-      Run.parseOptions ["--qr", "foo", "bar"]-        `shouldBe` (NoDryRun, (NoPrepare, (PrintQR, ["foo", "bar"])))+      parseOptions ["--qr", "foo", "bar"]+        `shouldReturn` (defaultConfig { printQR = True }, ["foo", "bar"])