Patchset parameter for `run' command

4 files changed, 92 insertions, 27 deletions

diff --git a/minici.cabal b/minici.cabal
index 80027ae..f295d2b 100644
--- a/minici.cabal
+++ b/minici.cabal
@@ -34,22 +34,26 @@ executable minici
         Version
         Version.Git
 
-    -- LANGUAGE extensions used by modules in this package.
-    other-extensions:    TemplateHaskell
-    default-extensions:  ExistentialQuantification
-                         FlexibleContexts
-                         FlexibleInstances
-                         GADTs
-                         GeneralizedNewtypeDeriving
-                         ImportQualifiedPost
-                         LambdaCase
-                         MultiParamTypeClasses
-                         MultiWayIf
-                         OverloadedStrings
-                         ScopedTypeVariables
-                         TupleSections
-                         TypeApplications
-    -- other-extensions:
+    default-extensions:
+        DefaultSignatures
+        ExistentialQuantification
+        FlexibleContexts
+        FlexibleInstances
+        GADTs
+        GeneralizedNewtypeDeriving
+        ImportQualifiedPost
+        LambdaCase
+        MultiParamTypeClasses
+        MultiWayIf
+        OverloadedStrings
+        ScopedTypeVariables
+        TupleSections
+        TypeApplications
+        TypeFamilies
+
+    other-extensions:
+        TemplateHaskell
+
     build-depends:    base              >=4.15 && <5
                     , bytestring        >=0.10 && <0.12
                     , containers        >=0.6 && <0.7
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