diff options
| -rw-r--r-- | README.md | 4 | ||||
| -rw-r--r-- | src/Command.hs | 11 | ||||
| -rw-r--r-- | src/Command/Run.hs | 80 |
3 files changed, 58 insertions, 37 deletions
@@ -59,10 +59,6 @@ minici run --range=<commit>..<commit> To run jobs for commits that are in local `<branch>`, but not yet in its upstream: ``` -minici run <branch> -``` -or: -``` minici run --since-upstream=<branch> ``` diff --git a/src/Command.hs b/src/Command.hs index 8ca0655..2c511df 100644 --- a/src/Command.hs +++ b/src/Command.hs @@ -6,6 +6,7 @@ module Command ( CommandArgumentsType(..), CommandExec(..), + tfail, CommandInput(..), getCommonOptions, getConfigPath, @@ -20,6 +21,7 @@ import Control.Monad.Reader import Data.Kind import Data.Text (Text) import Data.Text qualified as T +import Data.Text.IO qualified as T import System.Console.GetOpt import System.Exit @@ -84,9 +86,12 @@ newtype CommandExec a = CommandExec (ReaderT CommandInput IO a) deriving (Functor, Applicative, Monad, MonadIO) instance MonadFail CommandExec where - fail err = liftIO $ do - hPutStrLn stderr err - exitFailure + fail = tfail . T.pack + +tfail :: Text -> CommandExec a +tfail err = liftIO $ do + T.hPutStrLn stderr err + exitFailure data CommandInput = CommandInput { ciOptions :: CommonOptions diff --git a/src/Command/Run.hs b/src/Command/Run.hs index b6fd429..3968196 100644 --- a/src/Command/Run.hs +++ b/src/Command/Run.hs @@ -8,6 +8,7 @@ import Control.Exception import Control.Monad import Control.Monad.Reader +import Data.Either import Data.List import Data.Text (Text) import Data.Text qualified as T @@ -15,7 +16,6 @@ import Data.Text.IO qualified as T import System.Console.GetOpt import System.Directory -import System.Exit import System.FilePath import System.FilePath.Glob import System.IO @@ -45,8 +45,8 @@ instance Command RunCommand where commandUsage _ = T.pack $ unlines $ [ "Usage: minici run" , " run jobs for commits on current branch not yet in upstream branch" - , " or: minici run [--since-upstream=]<ref>" - , " run jobs for commits on <ref> not yet in its upstream ref" + , " or: minici run <job>..." + , " run jobs specified on the command line" , " or: minici run [--range=]<commit>..<commit>" , " run jobs for commits in given range" , " or: minici run <option>..." @@ -82,6 +82,14 @@ instance Command RunCommand where data JobSource = JobSource (TMVar (Maybe ( [ JobSet ], JobSource ))) +emptyJobSource :: MonadIO m => m JobSource +emptyJobSource = JobSource <$> liftIO (newTMVarIO Nothing) + +oneshotJobSource :: MonadIO m => [ JobSet ] -> m JobSource +oneshotJobSource jobsets = do + next <- emptyJobSource + JobSource <$> liftIO (newTMVarIO (Just ( jobsets, next ))) + takeJobSource :: JobSource -> STM (Maybe ( [ JobSet ], JobSource )) takeJobSource (JobSource tmvar) = takeTMVar tmvar @@ -113,12 +121,21 @@ mergeSources sources = do Just (Just ( jobsets, x' )) -> return ( jobsets, x' : xs ) +argumentJobSource :: [ JobName ] -> CommandExec JobSource +argumentJobSource [] = emptyJobSource +argumentJobSource names = do + config <- getConfig + jobsetJobsEither <- fmap Right $ forM names $ \name -> + case find ((name ==) . jobName) (configJobs config) of + Just job -> return job + Nothing -> tfail $ "job `" <> textJobName name <> "' not found" + Just jobsetCommit <- flip readCommit "HEAD" =<< getDefaultRepo + oneshotJobSource [ JobSet {..} ] + rangeSource :: Repo -> Text -> Text -> IO JobSource rangeSource repo base tip = do commits <- listCommits repo (base <> ".." <> tip) - jobsets <- mapM loadJobSetForCommit commits - next <- JobSource <$> newTMVarIO Nothing - JobSource <$> newTMVarIO (Just ( jobsets, next )) + oneshotJobSource =<< mapM loadJobSetForCommit commits watchBranchSource :: Repo -> Text -> IO JobSource watchBranchSource repo branch = do @@ -172,31 +189,34 @@ cmdRun (RunCommand RunOptions {..} args) = do configPath <- getConfigPath let baseDir = takeDirectory configPath - liftIO $ do - repo <- openRepo baseDir >>= \case - Just repo -> return repo - Nothing -> do - absPath <- makeAbsolute baseDir - T.hPutStrLn stderr $ "No repository found at `" <> T.pack absPath <> "'" - exitFailure - - rangeOptions <- concat <$> sequence - [ forM roRanges $ \range -> case T.splitOn ".." range of - [ base, tip ] -> return ( Just base, tip ) - _ -> do - T.hPutStrLn stderr $ "Invalid range: " <> range - exitFailure - , forM roSinceUpstream $ return . ( Nothing, ) - , forM args $ \arg -> case T.splitOn ".." arg of - [ base, tip ] -> return ( Just base, tip ) - [ ref ] -> return ( Nothing, ref ) - _ -> do - T.hPutStrLn stderr $ "Invalid argument: " <> arg - exitFailure - ] + repo <- liftIO (openRepo baseDir) >>= \case + Just repo -> return repo + Nothing -> do + absPath <- liftIO $ makeAbsolute baseDir + fail $ "no repository found at `" <> absPath <> "'" + + ( rangeOptions, jobOptions ) <- partitionEithers . concat <$> sequence + [ forM roRanges $ \range -> case T.splitOn ".." range of + [ base, tip ] -> return $ Left ( Just base, tip ) + _ -> tfail $ "invalid range: " <> range + , forM roSinceUpstream $ return . Left . ( Nothing, ) + , forM args $ \arg -> case T.splitOn ".." arg of + [ base, tip ] -> return $ Left ( Just base, tip ) + [ _ ] -> do + config <- getConfig + if any ((JobName arg ==) . jobName) (configJobs config) + then return $ Right $ JobName arg + else do + liftIO $ T.hPutStrLn stderr $ "standalone `" <> arg <> "' argument deprecated, use `--since-upstream=" <> arg <> "' instead" + return $ Left ( Nothing, arg ) + _ -> tfail $ "invalid argument: " <> arg + ] + argumentJobs <- argumentJobSource jobOptions + + liftIO $ do let rangeOptions' - | null rangeOptions, null roNewCommitsOn, null roNewTags = [ ( Nothing, "HEAD" ) ] + | null rangeOptions, null roNewCommitsOn, null roNewTags, null jobOptions = [ ( Nothing, "HEAD" ) ] | otherwise = rangeOptions ranges <- forM rangeOptions' $ \( mbBase, paramTip ) -> do @@ -212,7 +232,7 @@ cmdRun (RunCommand RunOptions {..} args) = do mngr <- newJobManager (baseDir </> ".minici") optJobs - source <- mergeSources $ concat [ ranges, branches, tags ] + source <- mergeSources $ concat [ [ argumentJobs ], ranges, branches, tags ] headerLine <- newLine tout "" threadCount <- newTVarIO (0 :: Int) |