tore out the tui

README.md

@@ -5,7 +5,7 @@
 Working on nix code?
 
 ```
-feedback nix-build
+feedback -- nix-build --no-out-link
 ```
 
 ## Comparison with other tools

feedback/feedback.cabal

@@ -22,12 +22,6 @@ library
   exposed-modules:
       Feedback
       Feedback.OptParse
-      Feedback.TUI
-      Feedback.TUI.Draw
-      Feedback.TUI.Env
-      Feedback.TUI.Handle
-      Feedback.TUI.State
-      Feedback.TUI.Worker
   other-modules:
       Paths_feedback
   hs-source-dirs:
@@ -37,13 +31,11 @@ library
     , autodocodec
     , autodocodec-yaml
     , base >=4.7 && <5
-    , brick
     , bytestring
     , conduit
     , conduit-extra
     , containers
     , cursor
-    , cursor-brick
     , envparse
     , fsnotify
     , mtl
@@ -51,11 +43,12 @@ library
     , path
     , path-io
     , process
+    , safe-coloured-text
+    , safe-coloured-text-terminfo
     , text
     , time
     , typed-process
     , unliftio
-    , vty
     , yaml
   default-language: Haskell2010
 

feedback/package.yaml

@@ -15,14 +15,11 @@ library:
   - async
   - autodocodec
   - autodocodec-yaml
-  - brick
   - bytestring
   - conduit
   - conduit-extra
-  - conduit-extra
   - containers
   - cursor
-  - cursor-brick
   - envparse
   - fsnotify
   - mtl
@@ -30,11 +27,12 @@ library:
   - path
   - path-io
   - process
+  - safe-coloured-text
+  - safe-coloured-text-terminfo
   - text
   - time
   - typed-process
   - unliftio
-  - vty
   - yaml
 
 executables:

feedback/src/Feedback.hs

@@ -1,21 +1,29 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
 
 module Feedback where
 
-import Brick.BChan
+import Control.Monad
 import Data.List
+import qualified Data.Text as T
+import Data.Time
 import Feedback.OptParse
-import Feedback.TUI
-import Feedback.TUI.Env
 import Path
 import Path.IO
+import System.Exit
 import System.FSNotify as FS
+import System.Process (showCommandForUser)
+import System.Process.Typed as Typed
+import Text.Colour
+import Text.Colour.Capabilities.FromEnv (getTerminalCapabilitiesFromEnv)
+import UnliftIO
 
 runFeedbackMain :: IO ()
 runFeedbackMain = do
   Settings {..} <- getSettings
-  requestChan <- newBChan 1000
+  eventChan <- newChan
+  outputChan <- newChan
   here <- getCurrentDir
   -- 0.1 second debouncing, 0.001 was too little
   let conf = FS.defaultConfig {confDebounce = Debounce 0.1}
@@ -26,8 +34,10 @@ runFeedbackMain = do
         (fromAbsDir here) -- Where to watch
         (eventFilter here)
         $ \event -> do
-          writeBChan requestChan $ ReceiveEvent event
+          writeChan eventChan event
-    feedbackTUI settingCommand requestChan
+    concurrently_
+      (processWorker settingCommand eventChan outputChan)
+      (outputWorker outputChan)
     stopListeningAction
 
 eventFilter :: Path Abs Dir -> FS.Event -> Bool
@@ -59,3 +69,98 @@ isHiddenIn curdir ad =
   case stripProperPrefix curdir ad of
     Nothing -> False
     Just rp -> "." `isPrefixOf` toFilePath rp
+
+processWorker :: [String] -> Chan FS.Event -> Chan Output -> IO ()
+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
+                $ unwords command
+        processHandleProcess <- startProcess processConfig
+        processHandleWaiter <- async $ do
+          ec <- waitExitCode processHandleProcess
+          sendOutput $ OutputProcessExited ec
+        putMVar currentProcessVar ProcessHandle {..}
+        sendOutput $ OutputProcessStarted command
+  -- Start one process ahead of time
+  startNewProcess
+  forever $ do
+    -- Output the event that made the rerun happen
+    event <- readChan eventChan
+    sendOutput $ OutputEvent event
+    -- Kill the current process
+    mCurrentProcess <- tryTakeMVar currentProcessVar
+    forM_ mCurrentProcess $ \currentProcess -> do
+      sendOutput OutputKilling
+      stopProcess $ processHandleProcess currentProcess
+      -- No need to cancel the waiter thread.
+      sendOutput OutputKilled
+    startNewProcess
+
+data ProcessHandle = ProcessHandle
+  { processHandleProcess :: !P,
+    processHandleWaiter :: Async ()
+  }
+
+type P = Process () () ()
+
+data Output
+  = OutputEvent !FS.Event
+  | OutputKilling
+  | OutputKilled
+  | OutputProcessStarted ![String]
+  | OutputProcessExited !ExitCode
+  deriving (Show)
+
+outputWorker :: Chan Output -> IO ()
+outputWorker outputChan = do
+  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 ""
+  forever $ do
+    event <- readChan outputChan
+    case event of
+      OutputEvent fsEvent -> do
+        put
+          [ fore cyan "event:   ",
+            case fsEvent of
+              Added {} -> fore green "added    "
+              Modified {} -> fore yellow "modified "
+              Removed {} -> fore red "removed  "
+              Unknown {} -> "unknown  ",
+            chunk $ T.pack $ eventPath fsEvent
+          ]
+      OutputKilling -> put [fore cyan "killing"]
+      OutputKilled -> put [fore cyan "killed"]
+      OutputProcessStarted command -> do
+        let commandString = case command of
+              [] -> ""
+              (bin : args) -> showCommandForUser bin args
+        put
+          [ fore cyan "started:",
+            " ",
+            fore blue $ chunk $ T.pack commandString
+          ]
+      OutputProcessExited ec ->
+        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/TUI.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-
-module Feedback.TUI where
-
-import Brick.BChan
-import Brick.Main
-import Control.Concurrent
-import Control.Concurrent.Async
-import Control.Monad.Reader
-import Feedback.TUI.Draw
-import Feedback.TUI.Env
-import Feedback.TUI.Handle
-import Feedback.TUI.State
-import Feedback.TUI.Worker
-import Graphics.Vty (defaultConfig, mkVty)
-
-feedbackTUI :: [String] -> BChan Request -> IO ()
-feedbackTUI command requestChan = do
-  -- Define the tui thread
-  initialState <- buildInitialState command
-  responseChan <- newBChan 1000
-  let vtyBuilder = mkVty defaultConfig
-  firstVty <- vtyBuilder
-  let runTui = customMain firstVty vtyBuilder (Just responseChan) (tuiApp requestChan) initialState
-  -- Define the worker thread
-  envCurrentProcess <- newEmptyMVar
-  let envCommand = command
-  let envRequestChan = requestChan
-  let envResponseChan = responseChan
-  let env = Env {..}
-  let runWorker = runReaderT tuiWorker env
-  -- Left always works because the worker runs forever
-  Left _ <- race runTui runWorker
-  pure ()
-
-tuiApp :: BChan Request -> App State Response ResourceName
-tuiApp chan =
-  App
-    { appDraw = drawTui,
-      appChooseCursor = showFirstCursor,
-      appHandleEvent = handleTuiEvent chan,
-      appStartEvent = pure,
-      appAttrMap = buildAttrMap
-    }
-
-buildInitialState :: [String] -> IO State
-buildInitialState stateCommand = do
-  let stateEvents = []
-  let stateCurrentProcess = Nothing
-  let stateOutput = emptyOutput
-  pure State {..}

feedback/src/Feedback/TUI/Draw.hs

@@ -1,41 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-module Feedback.TUI.Draw where
-
-import Brick.AttrMap
-import Brick.Types
-import Brick.Widgets.Border
-import Brick.Widgets.Core
-import qualified Data.ByteString as SB
-import qualified Data.Map as M
-import qualified Data.Text.Encoding as TE
-import qualified Data.Text.Encoding.Error as TE
-import Feedback.TUI.State
-import Graphics.Vty.Attributes
-import System.Process
-
-buildAttrMap :: State -> AttrMap
-buildAttrMap = const $ attrMap defAttr []
-
-drawTui :: State -> [Widget ResourceName]
-drawTui State {..} =
-  [ vBox
-      [ case stateCommand of
-          [] -> emptyWidget
-          (command : args) -> str $ showCommandForUser command args,
-        hBorder,
-        str $ show stateCurrentProcess,
-        hBorder,
-        vBox $ map (str . show) stateEvents,
-        hBorder,
-        drawOutput stateOutput
-      ]
-  ]
-
-drawOutput :: Output -> Widget n
-drawOutput (Output m) =
-  txtWrap
-    . TE.decodeUtf8With TE.lenientDecode
-    . SB.concat
-    . map (snd . snd)
-    $ M.toAscList m

feedback/src/Feedback/TUI/Env.hs

@@ -1,41 +0,0 @@
-module Feedback.TUI.Env where
-
-import Brick.BChan
-import Conduit
-import Control.Monad.Reader
-import Data.ByteString
-import System.Exit
-import System.FSNotify as FS
-import System.Process.Typed as Typed
-import UnliftIO
-
-data Env = Env
-  { envCommand :: ![String],
-    envCurrentProcess :: !(MVar ProcessHandle),
-    envRequestChan :: !(BChan Request),
-    envResponseChan :: !(BChan Response)
-  }
-
-data ProcessHandle = ProcessHandle
-  { processHandleProcess :: !P,
-    processHandleWaiter :: Async (),
-    processHandleStdoutReader :: Async (),
-    processHandleStderrReader :: Async ()
-  }
-
-type P =
-  Typed.Process
-    ()
-    (ConduitT () ByteString W ())
-    (ConduitT () ByteString W ())
-
-type W = ReaderT Env IO
-
-data Request = ReceiveEvent !FS.Event
-
-data Response
-  = ReceivedEvent !FS.Event
-  | ProcessStarted
-  | ProcessExited !ExitCode
-  | StdoutChunk !ByteString
-  | StderrChunk !ByteString

feedback/src/Feedback/TUI/Handle.hs

@@ -1,37 +0,0 @@
-module Feedback.TUI.Handle where
-
-import Brick.BChan
-import Brick.Main
-import Brick.Types
-import Control.Monad.IO.Class
-import Feedback.TUI.Env
-import Feedback.TUI.State
-import GHC.Clock (getMonotonicTimeNSec)
-import Graphics.Vty.Input.Events
-
-handleTuiEvent :: BChan Request -> State -> BrickEvent n Response -> EventM n (Next State)
-handleTuiEvent _requestChan s e =
-  case e of
-    VtyEvent vtye ->
-      case vtye of
-        EvKey (KChar 'q') [] -> halt s
-        _ -> continue s
-    AppEvent resp -> case resp of
-      ReceivedEvent fsEvent ->
-        continue $ s {stateEvents = fsEvent : stateEvents s}
-      ProcessStarted ->
-        continue $
-          s
-            { stateEvents = [],
-              stateCurrentProcess = Nothing,
-              stateOutput = emptyOutput
-            }
-      ProcessExited ec ->
-        continue $ s {stateCurrentProcess = Just ec}
-      StdoutChunk contents -> do
-        now <- liftIO getMonotonicTimeNSec
-        continue $ s {stateOutput = addOutput Stdout now contents (stateOutput s)}
-      StderrChunk contents -> do
-        now <- liftIO getMonotonicTimeNSec
-        continue $ s {stateOutput = addOutput Stderr now contents (stateOutput s)}
-    _ -> continue s

feedback/src/Feedback/TUI/State.hs

@@ -1,30 +0,0 @@
-module Feedback.TUI.State where
-
-import Data.ByteString (ByteString)
-import Data.Map
-import qualified Data.Map as M
-import Data.Word
-import System.Exit
-import System.FSNotify as FS
-
-data State = State
-  { stateCommand :: [String],
-    stateCurrentProcess :: !(Maybe ExitCode),
-    stateEvents :: [FS.Event],
-    stateOutput :: !Output
-  }
-
-newtype Output = Output {unOutput :: Map Word64 (OutputStream, ByteString)}
-  deriving (Show)
-
-data OutputStream = Stdout | Stderr
-  deriving (Show)
-
-emptyOutput :: Output
-emptyOutput = Output M.empty
-
-addOutput :: OutputStream -> Word64 -> ByteString -> Output -> Output
-addOutput os u bs (Output m) = Output $ M.insert u (os, bs) m
-
-data ResourceName = ResourceName
-  deriving (Show, Eq, Ord)

feedback/src/Feedback/TUI/Worker.hs

@@ -1,88 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-
-module Feedback.TUI.Worker where
-
-import Brick.BChan
-import Conduit
-import Control.Monad
-import Control.Monad.IO.Class
-import Control.Monad.Reader
-import qualified Data.Conduit.Combinators as C
-import Data.Conduit.Process.Typed
-import Data.Word
-import Feedback.TUI.Env
-import Feedback.TUI.State
-import GHC.Clock
-import System.Process.Typed as Typed
-import UnliftIO
-
-tuiWorker :: W ()
-tuiWorker = do
-  doRun -- Start immediately
-  requestChan <- asks envRequestChan
-  forever $ do
-    req <- liftIO $ readBChan requestChan
-    case req of
-      ReceiveEvent event -> do
-        -- Immediately notify of the last-received event.
-        sendResponse $ ReceivedEvent event
-        doRun
-
-doRun :: W ()
-doRun = do
-  currentProcessVar <- asks envCurrentProcess
-  -- Stop the current process
-  mCurrentProcess <- tryTakeMVar currentProcessVar
-  mapM_ stopProcessHandle mCurrentProcess
-  -- Start the new process
-  processHandle <- startNewProcess
-  putMVar currentProcessVar processHandle
-
-stopProcessHandle :: ProcessHandle -> W ()
-stopProcessHandle ProcessHandle {..} = do
-  stopProcess processHandleProcess
-  -- No need to cancel the waiter, it will finish automatically
-  -- liftIO $ cancel processHandleWaiter
-  -- TODO: figure out if that's true
-  cancel processHandleStdoutReader
-  cancel processHandleStderrReader
-  pure ()
-
-startNewProcess :: W ProcessHandle
-startNewProcess = do
-  command <- asks envCommand
-  let processConfig =
-        setStdout createSource
-          . setStderr createSource
-          . setStdin inherit
-          . shell
-          $ unwords command
-  -- Start a new process
-  processHandleProcess <- startProcess processConfig
-  processHandleWaiter <- async $ waiterThread processHandleProcess
-  processHandleStdoutReader <- async $ stdoutThread processHandleProcess
-  processHandleStderrReader <- async $ stderrThread processHandleProcess
-  sendResponse ProcessStarted
-  pure ProcessHandle {..}
-
-waiterThread :: P -> W ()
-waiterThread process = do
-  ec <- waitExitCode process
-  sendResponse $ ProcessExited ec
-
-stdoutThread :: P -> W ()
-stdoutThread process =
-  runConduit $
-    getStdout process
-      .| C.mapM_ (sendResponse . StdoutChunk)
-
-stderrThread :: P -> W ()
-stderrThread process =
-  runConduit $
-    getStdout process
-      .| C.mapM_ (sendResponse . StdoutChunk)
-
-sendResponse :: Response -> W ()
-sendResponse response = do
-  responseChan <- asks envResponseChan
-  liftIO $ writeBChan responseChan response

stack.yaml

@@ -4,6 +4,11 @@ packages:
 - feedback
 
 extra-deps:
+- github: NorfairKing/safe-coloured-text
+  commit: f30fe0e4d2a0fa036967ffe17538b60e5f9861f5
+  subdirs:
+    - safe-coloured-text
+    - safe-coloured-text-terminfo
 - github: NorfairKing/autodocodec
   commit: 9880ec062f1166bdac50b8eb59c6dd010bc9af0c
   subdirs: