From 25d384c07bfd47e661d21883cfb3a6fe21cfef37 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Roman=20Smr=C5=BE?= <roman.smrz@seznam.cz>
Date: Sat, 1 Jun 2024 15:25:41 +0200
Subject: Explicit run command in separate module

Changelog: Explicit run command
---
 src/Main.hs | 99 ++++++++++++++++++++++---------------------------------------
 1 file changed, 36 insertions(+), 63 deletions(-)

(limited to 'src/Main.hs')

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
-- 
cgit v1.2.3