first draft of test command

README.md

@@ -2,15 +2,31 @@
 
 A general purpose tool to set up good feedback loops and share them with your team.
 
-## Example
+## Features
 
-Working on nix code?
+### Run feedback loops
+
+Use the `feedback` command to set up a feedback loop for your work.
+
+For example, if you are working on a nix build, you might use this feedback loop:
 
 ```
 feedback -- nix-build --no-out-link
 ```
 
-## Features & Comparison with other tools
+### Declarative feedback loops
+
+You can declare feedback loops in the `feedback.yaml` configuration file to share them with your team.
+For example, this gives you a [`ci.nix`-based feedback loop](https://cs-syd.eu/posts/2021-04-11-the-ci-nix-pattern):
+
+```
+loops:
+  ci: nix-build ci.nix --no-out-link
+```
+
+To see the full reference of options of the configuration file, run `feedback --help`.
+
+## Comparison with other tools
 
 | | feedback | [steeloverseer](https://github.com/schell/steeloverseer) | [watchexec](https://github.com/watchexec/watchexec) | [entr](https://github.com/eradman/entr)
 |----|-|-|-|-|
@@ -30,6 +46,8 @@ feedback -- nix-build --no-out-link
 * ✖️: Not supported
 * ?: I don't know.
 
+
+
 ## Someday/maybe ideas
 
 * I want to have a good idea of the current state of things:

feedback.yaml

@@ -1,5 +1,5 @@
 loops:
   ci: nix-build ci.nix --no-out-link
-  install: stack build --exec='feedback --help' --no-nix --system-ghc
-  test: stack build --exec='feedback-test' --no-nix --system-ghc
+  install: stack build --exec='feedback --help' --no-nix --system-ghc --with-hpack hpack
+  test: stack build --exec='feedback-test --debug ci' --no-nix --system-ghc --with-hpack hpack
 

feedback/feedback.cabal

@@ -21,6 +21,7 @@ source-repository head
 library
   exposed-modules:
       Feedback.Common.OptParse
+      Feedback.Common.Process
       Feedback.Loop
       Feedback.Loop.OptParse
       Feedback.Test

feedback/src/Feedback/Common/OptParse.hs

@@ -31,7 +31,7 @@ data LoopSettings = LoopSettings
   deriving (Show, Eq, Generic)
 
 combineToLoopSettings :: Flags -> Environment -> Maybe OutputConfiguration -> LoopConfiguration -> IO LoopSettings
-combineToLoopSettings Flags {..} Environment {..} mDefaultOutputConfig LoopConfiguration {..} = do
+combineToLoopSettings Flags {..} Environment {} mDefaultOutputConfig LoopConfiguration {..} = do
   let loopSettingCommand = loopConfigCommand
   let outputConfig = liftA2 (<>) loopConfigOutputConfiguration mDefaultOutputConfig
   let loopSettingOutputSettings = combineToOutputSettings flagOutputFlags outputConfig

feedback/src/Feedback/Common/Process.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Feedback.Common.Process where
+
+import Control.Monad
+import Data.List
+import qualified Data.Text as T
+import Data.Time
+import Feedback.Common.OptParse
+import Feedback.Loop.OptParse
+import Path
+import Path.IO
+import System.Exit
+import System.FSNotify as FS
+import System.Process.Typed as Typed
+import Text.Colour
+import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
+import UnliftIO
+
+data ProcessHandle = ProcessHandle
+  { processHandleProcess :: !P,
+    processHandleWaiter :: Async ()
+  }
+
+type P = Process () () ()
+
+startProcessAndWait :: String -> IO ExitCode
+startProcessAndWait command = do
+  let processConfig = processConfigFor command
+  startProcess processConfig >>= waitExitCode
+
+startProcessHandle :: (ExitCode -> IO ()) -> String -> IO ProcessHandle
+startProcessHandle waiterFunc command = do
+  let processConfig = processConfigFor command
+  processHandleProcess <- startProcess processConfig
+  processHandleWaiter <- async $ do
+    ec <- waitExitCode processHandleProcess
+    waiterFunc ec
+  pure ProcessHandle {..}
+
+processConfigFor :: String -> ProcessConfig () () ()
+processConfigFor =
+  setStdout inherit
+    . setStderr inherit
+    . setStdin closed -- TODO make this configurable?
+    . shell
+
+stopProcessHandle :: ProcessHandle -> IO ()
+stopProcessHandle ProcessHandle {..} = do
+  stopProcess processHandleProcess
+  -- No need to cancel the waiter thread.
+  pure ()

feedback/src/Feedback/Loop.hs

@@ -9,6 +9,7 @@ import Data.List
 import qualified Data.Text as T
 import Data.Time
 import Feedback.Common.OptParse
+import Feedback.Common.Process
 import Feedback.Loop.OptParse
 import Path
 import Path.IO
@@ -75,18 +76,11 @@ processWorker command eventChan outputChan = do
   let sendOutput = writeChan outputChan
   currentProcessVar <- newEmptyMVar
   let startNewProcess = do
-        -- Start a new process
-        let processConfig =
-              setStdout inherit
-                . setStderr inherit
-                . setStdin closed -- TODO make this configurable?
-                . shell
-                $ command
-        processHandleProcess <- startProcess processConfig
-        processHandleWaiter <- async $ do
-          ec <- waitExitCode processHandleProcess
-          sendOutput $ OutputProcessExited ec
-        putMVar currentProcessVar ProcessHandle {..}
+        processHandle <-
+          startProcessHandle
+            (sendOutput . OutputProcessExited)
+            command
+        putMVar currentProcessVar processHandle
         sendOutput $ OutputProcessStarted command
   -- Start one process ahead of time
   startNewProcess
@@ -98,18 +92,10 @@ processWorker command eventChan outputChan = do
     mCurrentProcess <- tryTakeMVar currentProcessVar
     forM_ mCurrentProcess $ \currentProcess -> do
       sendOutput OutputKilling
-      stopProcess $ processHandleProcess currentProcess
-      -- No need to cancel the waiter thread.
+      stopProcessHandle currentProcess
       sendOutput OutputKilled
     startNewProcess
 
-data ProcessHandle = ProcessHandle
-  { processHandleProcess :: !P,
-    processHandleWaiter :: Async ()
-  }
-
-type P = Process () () ()
-
 data Output
   = OutputEvent !FS.Event
   | OutputKilling

feedback/src/Feedback/Test.hs

@@ -1,9 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
 module Feedback.Test where
 
+import Control.Monad
+import qualified Data.Map as M
+import qualified Data.Text as T
+import Data.Time
+import Feedback.Common.OptParse
+import Feedback.Common.Process
 import Feedback.Test.OptParse
+import System.Exit
+import Text.Colour
+import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
 
 runFeedbackTest :: IO ()
 runFeedbackTest = do
-  sets <- getSettings
-  print sets
-  pure ()
+  TestSettings {..} <- getSettings
+  terminalCapabilities <- getTerminalCapabilitiesFromEnv
+  let put chunks = do
+        now <- getCurrentTime
+        let timeChunk = fore yellow $ chunk $ T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now
+        putChunksWith terminalCapabilities $ timeChunk : " " : chunks
+        putStrLn ""
+
+  forM_ (M.toList testSettingLoops) $ \(loopName, LoopSettings {..}) -> do
+    put [fore cyan "testing ", " ", chunk $ T.pack loopName]
+    put [fore cyan "starting", " ", fore blue $ chunk $ T.pack loopSettingCommand]
+    ec <- startProcessAndWait loopSettingCommand
+    case ec of
+      ExitSuccess ->
+        put
+          [ fore cyan "exited: ",
+            " ",
+            fore green "success"
+          ]
+      ExitFailure c ->
+        put
+          [ fore cyan "exited: ",
+            " ",
+            fore red $ chunk $ T.pack $ "failed: " <> show c
+          ]

feedback/src/Feedback/Test/OptParse.hs

@@ -28,4 +28,6 @@ combineToTestSettings flags@Flags {..} environment mConf = do
     traverse
       (combineToLoopSettings flags environment (mConf >>= configOutputConfiguration))
       (maybe M.empty configLoops mConf)
-  pure TestSettings {..}
+  let testSets = TestSettings {..}
+  when flagDebug $ pPrint testSets
+  pure testSets