From ba789c3413ac996cb65314cb5ac9f77bd9617ff9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sun, 2 Jun 2024 21:00:37 +0200
Subject: Patchset parameter for `run' command
---
src/Command.hs | 39 +++++++++++++++++++++++++++++++++++++--
src/Command/Run.hs | 27 +++++++++++++++++++++------
src/Main.hs | 17 ++++++++++++++---
3 files changed, 72 insertions(+), 11 deletions(-)
(limited to 'src')
diff --git a/src/Command.hs b/src/Command.hs
index 78d0d6c..bb0b26f 100644
--- a/src/Command.hs
+++ b/src/Command.hs
@@ -1,20 +1,55 @@
module Command (
Command(..),
+ CommandArgumentsType(..),
CommandExec(..),
getConfig,
) where
+import Control.Monad.Except
import Control.Monad.Reader
+import Data.Kind
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import System.Console.GetOpt
+
import Config
-class Command c where
+class CommandArgumentsType (CommandArguments c) => Command c where
commandName :: proxy c -> String
- commandInit :: proxy c -> c
+ type CommandOptions c :: Type
+ type CommandOptions c = ()
+ commandOptions :: proxy c -> [OptDescr (CommandOptions c -> CommandOptions c)]
+ commandOptions _ = []
+ defaultCommandOptions :: proxy c -> CommandOptions c
+ default defaultCommandOptions :: CommandOptions c ~ () => proxy c -> CommandOptions c
+ defaultCommandOptions _ = ()
+
+ type CommandArguments c :: Type
+ type CommandArguments c = ()
+
+ commandInit :: CommandArgumentsType (CommandArguments c) => proxy c -> CommandOptions c -> CommandArguments c -> c
commandExec :: c -> CommandExec ()
+class CommandArgumentsType args where
+ argsFromStrings :: [String] -> Except String args
+
+instance CommandArgumentsType () where
+ argsFromStrings [] = return ()
+ argsFromStrings _ = throwError "no argument expected"
+
+instance CommandArgumentsType Text where
+ argsFromStrings [str] = return $ T.pack str
+ argsFromStrings _ = throwError "expected single argument"
+
+instance CommandArgumentsType (Maybe Text) where
+ argsFromStrings [] = return $ Nothing
+ argsFromStrings [str] = return $ Just (T.pack str)
+ argsFromStrings _ = throwError "expected at most one argument"
+
newtype CommandExec a = CommandExec (ReaderT Config IO a)
deriving (Functor, Applicative, Monad, MonadIO)
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
index 3b997b5..28b35c3 100644
--- a/src/Command/Run.hs
+++ b/src/Command/Run.hs
@@ -7,10 +7,12 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Reader
+import Data.Maybe
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
+import System.Exit
import System.IO
import System.Process
@@ -18,20 +20,33 @@ import Command
import Config
import Job
-data RunCommand = RunCommand
+data RunCommand = RunCommand Text
instance Command RunCommand where
commandName _ = "run"
- commandInit _ = RunCommand
- commandExec _ = cmdRun
+ type CommandArguments RunCommand = Maybe Text
-cmdRun :: CommandExec ()
-cmdRun = do
+ commandInit _ _ = RunCommand . fromMaybe "HEAD"
+ commandExec = cmdRun
+
+cmdRun :: RunCommand -> CommandExec ()
+cmdRun (RunCommand changeset) = do
config <- getConfig
+ ( base, tip ) <- case T.splitOn (T.pack "..") changeset of
+ base : tip : _ -> return ( T.unpack base, T.unpack tip )
+ [ param ] -> liftIO $ do
+ [ deref ] <- readProcessWithExitCode "git" [ "symbolic-ref", "--quiet", T.unpack param ] "" >>= \case
+ ( ExitSuccess, out, _ ) -> return $ lines out
+ ( _, _, _ ) -> return [ T.unpack param ]
+ [ _, tip ] : _ <- fmap words . lines <$> readProcess "git" [ "show-ref", deref ] ""
+ [ base ] <- lines <$> readProcess "git" [ "for-each-ref", "--format=%(upstream)", tip ] ""
+ return ( base, tip )
+ [] -> error "splitOn should not return empty list"
+
liftIO $ do
commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
- readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
+ readProcess "git" [ "log", "--pretty=oneline", "--first-parent", "--reverse", base <> ".." <> tip ] ""
putStr $ replicate (8 + 50) ' '
forM_ (configJobs config) $ \job -> do
diff --git a/src/Main.hs b/src/Main.hs
index 1300024..f65c023 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,6 +1,7 @@
module Main (main) where
import Control.Monad
+import Control.Monad.Except
import Control.Monad.Reader
import Data.List
@@ -52,7 +53,7 @@ lookupCommand name = find p commands
main :: IO ()
main = do
args <- getArgs
- (opts, cmdargs) <- case getOpt Permute options args of
+ (opts, cmdargs) <- case getOpt RequireOrder options args of
(o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
(_, _, errs) -> do
hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
@@ -81,9 +82,19 @@ main = do
runSomeCommand ncmd cargs
runSomeCommand :: SomeCommandType -> [ String ] -> IO ()
-runSomeCommand (SC tproxy) _ = do
+runSomeCommand (SC tproxy) args = do
+ let exitWithErrors errs = do
+ hPutStr stderr $ concat errs
+ exitFailure
+
+ (opts, cmdargs) <- case getOpt Permute (commandOptions tproxy) args of
+ (o, strargs, []) -> case runExcept $ argsFromStrings strargs of
+ Left err -> exitWithErrors [ err <> "\n" ]
+ Right cmdargs -> return (foldl (flip id) (defaultCommandOptions tproxy) o, cmdargs)
+ (_, _, errs) -> exitWithErrors errs
+
Just configPath <- findConfig
config <- parseConfig configPath
- let cmd = commandInit tproxy
+ let cmd = commandInit tproxy opts cmdargs
let CommandExec exec = commandExec cmd
flip runReaderT config exec
--
cgit v1.2.3