diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Command.hs | 39 | ||||
| -rw-r--r-- | src/Command/Run.hs | 27 | ||||
| -rw-r--r-- | src/Main.hs | 17 |
3 files changed, 72 insertions, 11 deletions
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 |