diff --git a/ghc-bench.cabal b/ghc-bench.cabal --- a/ghc-bench.cabal +++ b/ghc-bench.cabal @@ -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 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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 diff --git a/src/System/Console/GetOpt/Util.hs b/src/System/Console/GetOpt/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/GetOpt/Util.hs @@ -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" diff --git a/test/RunSpec.hs b/test/RunSpec.hs --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -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" ($ "") DryRun NoPrepare [] "/path/to/ghc-9.12.4" 20 + let run = Run.run "~/.cache/ghc-bench" ($ "") 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"])