Explicit run command in separate module

Changelog: Explicit run command

3 files changed, 145 insertions, 63 deletions

diff --git a/src/Command.hs b/src/Command.hs
new file mode 100644
index 0000000..78d0d6c
--- /dev/null
+++ b/src/Command.hs
@@ -0,0 +1,23 @@
+module Command (
+    Command(..),
+
+    CommandExec(..),
+    getConfig,
+) where
+
+import Control.Monad.Reader
+
+import Config
+
+class Command c where
+    commandName :: proxy c -> String
+
+    commandInit :: proxy c -> c
+    commandExec :: c -> CommandExec ()
+
+
+newtype CommandExec a = CommandExec (ReaderT Config IO a)
+    deriving (Functor, Applicative, Monad, MonadIO)
+
+getConfig :: CommandExec Config
+getConfig = CommandExec ask
diff --git a/src/Command/Run.hs b/src/Command/Run.hs
new file mode 100644
index 0000000..3b997b5
--- /dev/null
+++ b/src/Command/Run.hs
@@ -0,0 +1,86 @@
+module Command.Run (
+    RunCommand,
+) where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Monad
+import Control.Monad.Reader
+
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+
+import System.IO
+import System.Process
+
+import Command
+import Config
+import Job
+
+data RunCommand = RunCommand
+
+instance Command RunCommand where
+    commandName _ = "run"
+
+    commandInit _ = RunCommand
+    commandExec _ = cmdRun
+
+cmdRun :: CommandExec ()
+cmdRun = do
+    config <- getConfig
+    liftIO $ do
+        commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
+            readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
+
+        putStr $ replicate (8 + 50) ' '
+        forM_ (configJobs config) $ \job -> do
+            T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
+        putStrLn ""
+
+        forM_ commits $ \(cid, desc) -> do
+            let shortCid = T.pack $ take 7 cid
+            outs <- runJobs "./.minici" cid $ configJobs config
+            displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+
+
+fitToLength :: Int -> Text -> Text
+fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
+                       | otherwise     = T.take (maxlen - 1) str <> "…"
+    where len = T.length str
+
+showStatus :: Bool -> JobStatus a -> Text
+showStatus blink = \case
+    JobQueued       -> "\ESC[94m…\ESC[0m      "
+    JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
+    JobSkipped      ->  "\ESC[0m-\ESC[0m      "
+    JobRunning      -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m      "
+    JobError _      -> "\ESC[91m!!\ESC[0m     "
+    JobFailed       -> "\ESC[91m✗\ESC[0m      "
+    JobDone _       -> "\ESC[92m✓\ESC[0m      "
+
+displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
+displayStatusLine prefix1 prefix2 statuses = do
+    blinkVar <- newTVarIO False
+    t <- forkIO $ forever $ do
+        threadDelay 500000
+        atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
+    go blinkVar ""
+    killThread t
+  where
+    go blinkVar prev = do
+        (ss, cur) <- atomically $ do
+            ss <- mapM readTVar statuses
+            blink <- readTVar blinkVar
+            let cur = T.concat $ map ((" " <>) . showStatus blink) ss
+            when (cur == prev) retry
+            return (ss, cur)
+        when (not $ T.null prev) $ putStr "\r"
+        let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
+                                                 else prefix1
+        T.putStr $ prefix1' <> prefix2 <> cur
+        hFlush stdout
+
+        if all jobStatusFinished ss
+           then T.putStrLn ""
+           else go blinkVar cur
diff --git a/src/Main.hs b/src/Main.hs
index 363fad8..1300024 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,22 +1,19 @@
 module Main (main) where
 
-import Control.Concurrent
-import Control.Concurrent.STM
-
 import Control.Monad
+import Control.Monad.Reader
 
-import Data.Text (Text)
-import Data.Text qualified as T
-import Data.Text.IO qualified as T
+import Data.List
+import Data.Proxy
 
 import System.Console.GetOpt
 import System.Environment
 import System.Exit
 import System.IO
-import System.Process
 
+import Command
+import Command.Run
 import Config
-import Job
 import Version
 
 data CmdlineOptions = CmdlineOptions
@@ -40,58 +37,29 @@ options =
         "show version and exit"
     ]
 
-fitToLength :: Int -> Text -> Text
-fitToLength maxlen str | len <= maxlen = str <> T.replicate (maxlen - len) " "
-                       | otherwise     = T.take (maxlen - 1) str <> "…"
-    where len = T.length str
-
-showStatus :: Bool -> JobStatus a -> Text
-showStatus blink = \case
-    JobQueued       -> "\ESC[94m…\ESC[0m      "
-    JobWaiting uses -> "\ESC[94m~" <> fitToLength 6 (T.intercalate "," (map textJobName uses)) <> "\ESC[0m"
-    JobSkipped      ->  "\ESC[0m-\ESC[0m      "
-    JobRunning      -> "\ESC[96m" <> (if blink then "*" else "•") <> "\ESC[0m      "
-    JobError _      -> "\ESC[91m!!\ESC[0m     "
-    JobFailed       -> "\ESC[91m✗\ESC[0m      "
-    JobDone _       -> "\ESC[92m✓\ESC[0m      "
-
-displayStatusLine :: Text -> Text -> [TVar (JobStatus JobOutput)] -> IO ()
-displayStatusLine prefix1 prefix2 statuses = do
-    blinkVar <- newTVarIO False
-    t <- forkIO $ forever $ do
-        threadDelay 500000
-        atomically $ writeTVar blinkVar . not =<< readTVar blinkVar
-    go blinkVar ""
-    killThread t
+data SomeCommandType = forall c. Command c => SC (Proxy c)
+
+commands :: [ SomeCommandType ]
+commands =
+    [ SC $ Proxy @RunCommand
+    ]
+
+lookupCommand :: String -> Maybe SomeCommandType
+lookupCommand name = find p commands
   where
-    go blinkVar prev = do
-        (ss, cur) <- atomically $ do
-            ss <- mapM readTVar statuses
-            blink <- readTVar blinkVar
-            let cur = T.concat $ map ((" " <>) . showStatus blink) ss
-            when (cur == prev) retry
-            return (ss, cur)
-        when (not $ T.null prev) $ putStr "\r"
-        let prefix1' = if any jobStatusFailed ss then "\ESC[91m" <> prefix1 <> "\ESC[0m"
-                                                 else prefix1
-        T.putStr $ prefix1' <> prefix2 <> cur
-        hFlush stdout
-
-        if all jobStatusFinished ss
-           then T.putStrLn ""
-           else go blinkVar cur
+    p (SC cmd) = commandName cmd == name
 
 main :: IO ()
 main = do
     args <- getArgs
-    opts <- case getOpt Permute options args of
-        (o, _, []) -> return (foldl (flip id) defaultCmdlineOptions o)
+    (opts, cmdargs) <- case getOpt Permute options args of
+        (o, cmdargs, []) -> return (foldl (flip id) defaultCmdlineOptions o, cmdargs)
         (_, _, errs) -> do
             hPutStrLn stderr $ concat errs <> "Try `minici --help' for more information."
             exitFailure
 
     when (optShowHelp opts) $ do
-        let header = "Usage: minici [<option>...]"
+        let header = "Usage: minici [<option>...] <command> [<args>]"
         putStr $ usageInfo header options
         exitSuccess
 
@@ -99,18 +67,23 @@ main = do
         putStrLn versionLine
         exitSuccess
 
+    (ncmd, cargs) <- case cmdargs of
+        [] -> return (head commands, [])
+        (cname : cargs)
+            | Just nc <- lookupCommand cname -> return (nc, cargs)
+            | otherwise -> do
+                hPutStr stderr $ unlines
+                    [ "Unknown command `" <> cname <> "'."
+                    , "Try `minici --help' for more information."
+                    ]
+                exitFailure
+
+    runSomeCommand ncmd cargs
+
+runSomeCommand :: SomeCommandType -> [ String ] -> IO ()
+runSomeCommand (SC tproxy) _ = do
     Just configPath <- findConfig
     config <- parseConfig configPath
-
-    commits <- map (fmap (drop 1) . (span (/=' '))) . lines <$>
-        readProcess "git" ["log", "--pretty=oneline", "--first-parent", "--reverse", "origin/master..HEAD"] ""
-
-    putStr $ replicate (8 + 50) ' '
-    forM_ (configJobs config) $ \job -> do
-        T.putStr $ (" "<>) $ fitToLength 7 $ textJobName $ jobName job
-    putStrLn ""
-
-    forM_ commits $ \(cid, desc) -> do
-        let shortCid = T.pack $ take 7 cid
-        outs <- runJobs "./.minici" cid $ configJobs config
-        displayStatusLine shortCid (" " <> fitToLength 50 (T.pack desc)) outs
+    let cmd = commandInit tproxy
+    let CommandExec exec = commandExec cmd
+    flip runReaderT config exec