Weditor

app/Main.hs

@@ -74,11 +74,13 @@ drawUI :: AppState -> [Widget ClickableName]
 drawUI app = case _appModal app of
   Nothing -> [ui]
   Just modalState -> case modalState of
-    CommentModalState {} -> [renderModal app modalState, forceAttr pageEllipsesAttr ui]
-    NewIssueModalState {} -> [renderNewIssueModal app modalState, forceAttr pageEllipsesAttr ui]
-    ZoomModalState {} -> [renderZoomModal app modalState, forceAttr pageEllipsesAttr ui]
-    LogModalState {} -> [renderLogModal app modalState, forceAttr pageEllipsesAttr ui]
+    CommentModalState {} -> [renderModal app modalState, dimmedUi]
+    NewIssueModalState {} -> [renderNewIssueModal app modalState, dimmedUi]
+    ZoomModalState {} -> [renderZoomModal app modalState, dimmedUi]
+    LogModalState {} -> [renderLogModal app modalState, dimmedUi]
   where
+    colorMode = fromMaybe (_appActualColorMode app) (_appCliColorMode app)
+    dimmedUi = updateAttrMap (const (buildAdaptiveDimmedAttrMap colorMode 0.35)) ui
     ui = if _appSplitLogs app then splitUI else mainUI
 
     mainUI = reportExtent MainUI $ vBox [

app/Sauron/Actions.hs

@@ -18,7 +18,7 @@
 import qualified Data.Vector as V
 import GitHub
 import Relude
-import Sauron.Actions.Util (findRepoParent, openBrowserToUrl)
+import Sauron.Actions.Util
 import Sauron.Fetch.Branch
 import Sauron.Fetch.Issue
 import Sauron.Fetch.Job
@@ -28,20 +28,17 @@
 import Sauron.Fetch.Workflow
 import Sauron.HealthCheck.Job (startJobHealthCheckIfNeeded)
 import Sauron.HealthCheck.Workflow (startWorkflowHealthCheckIfNeeded)
+import Sauron.Logging
 import Sauron.Types
 import Sauron.UI.Util (isFetchingOrFetched)
 import UnliftIO.Async
 
--- import Sauron.HealthCheck.Job (startJobHealthCheckIfNeeded)
-
 
 refreshSelected :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Async ())
 refreshSelected = fetchOnOpen
 
-refreshOnZoom :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m ()
-refreshOnZoom bc node parents = fetchOnOpenIfNecessary bc node parents >>= \case
-  Nothing -> return ()
-  Just asy -> wait asy
+refreshOnZoom :: (MonadIO m, SomeNodeConstraints Fixed a) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m ()
+refreshOnZoom bc node parents = fetchOnOpenIfNecessary bc node parents >>= wait
 
 refreshLine :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Async ())
 refreshLine bc (RepoNode (EntityData {_static=(owner, name), _state})) _parents =
@@ -72,29 +69,44 @@
   ) => V.Vector (SomeNode Variable) -> m ()
 refreshVisibleLines elems = do
   baseContext <- ask
-  refreshVisibleLines' baseContext [] (V.toList elems)
+  let cb (SomeNode node) parents = liftIO $ refreshLine baseContext node parents
+  forM_ (V.toList elems) $ forEachVisibleNode cb []
 
-refreshVisibleLines' :: MonadIO m => BaseContext -> [SomeNode Variable] -> [SomeNode Variable] -> m ()
-refreshVisibleLines' baseContext parents nodes = do
+forEachVisibleNode :: (MonadIO m) => (SomeNode Variable -> NonEmpty (SomeNode Variable) -> IO (Async ())) -> [SomeNode Variable] -> SomeNode Variable -> m ()
+forEachVisibleNode cb parents someNode@(SomeNode node) = do
   -- Be careful not to log from the calling thread of this function, because
   -- this function is called in Main.hs, before the event loop starts. Logging
   -- writes to the Brick event chan, and it is bounded, so if we fill it up
   -- before starting the event loop, we can crash with an STM deadlock.
 
-  forM_ nodes $ \someNode@(SomeNode node) -> do
-    parentAsy <- refreshLine baseContext node (someNode :| parents)
+  parentAsy <- liftIO $ cb someNode (someNode :| parents)
 
-    whenM (readTVarIO (_toggled (getEntityData node))) $ void $ liftIO $ async $ do
-      wait parentAsy
-      atomically (getExistentialChildrenWrapped node)
-        >>= refreshVisibleLines' baseContext (someNode : parents)
+  whenM (readTVarIO (_toggled (getEntityData node))) $ void $ liftIO $ async $ do
+    wait parentAsy
+    atomically (getExistentialChildrenWrapped node)
+      >>= mapM_ (forEachVisibleNode cb (someNode : parents))
 
-fetchOnOpenIfNecessary :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Maybe (Async ()))
+fetchOnOpenIfNecessary :: (MonadIO m, SomeNodeConstraints Fixed a) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Async ())
 fetchOnOpenIfNecessary bc node parents = do
-  shouldFetchOnExpand node >>= \case
+  maybeAsy <- shouldFetchOnExpand node >>= \case
     True -> (Just <$>) $ fetchOnOpen bc node parents
     False -> return Nothing
 
+  liftIO $ async $ do
+    whenJust maybeAsy wait
+
+    let cb (SomeNode node') parents' = liftIO $ onBecameVisible bc node' parents'
+    atomically (getExistentialChildrenWrapped node) >>= \children' ->
+      liftIO $ forConcurrently_ children' (forEachVisibleNode cb (SomeNode node : toList parents))
+
+onBecameVisible :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Async ())
+onBecameVisible bc item@(SingleWorkflowNode (EntityData {_children})) parents = do
+  -- After fetching, start health checks for any running workflows
+  liftIO (startWorkflowHealthCheckIfNeeded bc item (SomeNode item :| toList parents)) >>= \case
+    Just x -> pure x
+    Nothing -> liftIO $ async (return ())
+onBecameVisible _ _ _ = liftIO $ async (return ())
+
 fetchOnOpen :: (MonadIO m) => BaseContext -> Node Variable a -> NonEmpty (SomeNode Variable) -> m (Async ())
 -- Container nodes that just organize other nodes - do nothing
 fetchOnOpen _bc (HeadingNode _) _parents = liftIO $ async (return ())
@@ -149,16 +161,6 @@
 fetchOnOpen _ _ _ = liftIO $ async (return ())
 
 
-withRepoDefaultBranch :: MonadIO m => TVar (Fetchable Repo) -> (Maybe Text -> m ()) -> m ()
-withRepoDefaultBranch = withRepoDefaultBranch' (return ())
-
-withRepoDefaultBranch' :: MonadIO m => m a -> TVar (Fetchable Repo) -> (Maybe Text -> m a) -> m a
-withRepoDefaultBranch' defaultValue fetchableVar action = readTVarIO fetchableVar >>= \case
-  Fetched (Repo {..}) -> action repoDefaultBranch
-  Fetching (Just (Repo {..})) -> action repoDefaultBranch
-  _ -> defaultValue
-
-
 -- | This should be synced up with how fetchOnOpen works
 shouldFetchOnExpand :: MonadIO m => Node Variable a -> m Bool
 shouldFetchOnExpand (HeadingNode (EntityData {_state})) = return False

app/Sauron/Actions/Util.hs

@@ -21,6 +21,9 @@ module Sauron.Actions.Util (
   , findIssuesParent
   , findPullsParent
   , findWorkflowsParent
+
+  , withRepoDefaultBranch
+  , withRepoDefaultBranch'
 ) where
 
 import Brick.BChan
@@ -91,6 +94,15 @@ findPullsParent elems = viaNonEmpty head [x | SomeNode x@(PaginatedPullsNode _)
 findWorkflowsParent :: NonEmpty (SomeNode Variable) -> Maybe (Node Variable PaginatedWorkflowsT)
 findWorkflowsParent elems = viaNonEmpty head [x | SomeNode x@(PaginatedWorkflowsNode _) <- toList elems]
 
+withRepoDefaultBranch :: MonadIO m => TVar (Fetchable Repo) -> (Maybe Text -> m ()) -> m ()
+withRepoDefaultBranch = withRepoDefaultBranch' (return ())
+
+withRepoDefaultBranch' :: MonadIO m => m a -> TVar (Fetchable Repo) -> (Maybe Text -> m a) -> m a
+withRepoDefaultBranch' defaultValue fetchableVar action = readTVarIO fetchableVar >>= \case
+  Fetched (Repo {..}) -> action repoDefaultBranch
+  Fetching (Just (Repo {..})) -> action repoDefaultBranch
+  _ -> defaultValue
+
 requestToUrl :: GenRequest mt k a -> Text
 requestToUrl req = case req of
   Query paths queryString -> pathsToUrl paths <> formatQueryString queryString

app/Sauron/Event.hs

@@ -7,6 +7,7 @@ module Sauron.Event (appEvent) where
 import Brick as B
 import Brick.Forms
 import Brick.Widgets.Edit (handleEditorEvent)
+import qualified WEditorBrick.WrappingEditor as WEditorBrick
 import Brick.Widgets.List
 import Control.Monad
 import Control.Monad.IO.Unlift
@@ -71,8 +72,10 @@ appEvent s@(_appModal -> Just modalState) e = case e of
         modify (appModal . _Just . submissionState .~ SubmittingCloseWithComment)
         liftIO $ closeWithComment s modalState
       _ -> do
-        unlessM (handleModalScrolling CommentModalContent ev) $
-          zoom (appModal . _Just . commentEditor) $ handleEditorEvent (VtyEvent ev)
+        unlessM (handleModalScrolling CommentModalContent ev) $ do
+          let ed = _commentEditor modalState
+          ed' <- WEditorBrick.handleEditor ed ev
+          modify (appModal . _Just . commentEditor .~ ed')
     NewIssueModalState {} -> case ev of
       (V.EvKey V.KEsc []) -> closeModal s
       (V.EvKey (V.KChar 'q') [V.MCtrl]) -> closeModal s
@@ -86,8 +89,10 @@ appEvent s@(_appModal -> Just modalState) e = case e of
       _ -> case modalState of
         NewIssueModalState {_newIssueFocusTitle=True} ->
           zoom (appModal . _Just . newIssueTitleEditor) $ handleEditorEvent (VtyEvent ev)
-        _ ->
-          zoom (appModal . _Just . newIssueBodyEditor) $ handleEditorEvent (VtyEvent ev)
+        _ -> do
+          let bodyEd = _newIssueBodyEditor modalState
+          bodyEd' <- WEditorBrick.handleEditor bodyEd ev
+          modify (appModal . _Just . newIssueBodyEditor .~ bodyEd')
     ZoomModalState {} -> case ev of
       (V.EvKey V.KEsc []) -> closeModal s
       (V.EvKey (V.KChar 'q') [V.MCtrl]) -> closeModal s
@@ -161,6 +166,17 @@ appEvent s (MouseDown LogSplitContent V.BLeft _ _) = switchToLogPane s
 appEvent s (MouseDown MainPane V.BLeft _ _) = switchToMainPane s
 appEvent s (MouseDown LogPane V.BLeft _ _) = switchToLogPane s
 
+-- Clickable scrollbar events
+appEvent _ (MouseDown (ScrollbarClick SBHandleBefore vpName) V.BLeft _ _) =
+  vScrollBy (viewportScroll vpName) (-1)
+appEvent _ (MouseDown (ScrollbarClick SBHandleAfter vpName) V.BLeft _ _) =
+  vScrollBy (viewportScroll vpName) 1
+appEvent _ (MouseDown (ScrollbarClick SBTroughBefore vpName) V.BLeft _ _) =
+  vScrollPage (viewportScroll vpName) Up
+appEvent _ (MouseDown (ScrollbarClick SBTroughAfter vpName) V.BLeft _ _) =
+  vScrollPage (viewportScroll vpName) Down
+appEvent _ (MouseDown (ScrollbarClick _ _) _ _ _) = return ()
+
 -- Catch-all
 appEvent _ _ = return ()
 

app/Sauron/Event/CommentModal.hs

@@ -12,7 +12,8 @@ module Sauron.Event.CommentModal (
 
 import Brick as B
 import Brick.BChan
-import Brick.Widgets.Edit (editorText, getEditContents)
+import WEditor.LineWrap (breakWords, noHyphen)
+import WEditorBrick.WrappingEditor (dumpEditor, newEditor)
 import Control.Monad.IO.Unlift
 import qualified Data.Text as T
 import Data.Time
@@ -31,7 +32,7 @@ handleCommentModalEvent s (CommentSubmitted result) = case result of
   Right _comment -> do
     -- Reset submission state and clear editor
     modify (appModal . _Just . submissionState .~ NotSubmitting)
-    modify (appModal . _Just . commentEditor .~ editorText CommentEditor Nothing "")
+    modify (appModal . _Just . commentEditor .~ newEditor (breakWords noHyphen) CommentEditor [])
     -- Refresh issue comments and scroll to bottom
     case s ^. appModal of
       Just (CommentModalState _editor issue _comments isPR owner name _submissionState) -> do
@@ -59,13 +60,13 @@ handleCommentModalEvent _s (CommentsRefreshed comments) = do
 
 handleCommentModalEvent _s (OpenCommentModal issue comments isPR owner name) = do
   -- Open the comment modal with fresh comments and scroll to bottom
-  let editor = editorText CommentEditor Nothing ""
+  let editor = newEditor (breakWords noHyphen) CommentEditor []
   modify (appModal ?~ CommentModalState editor issue comments isPR owner name NotSubmitting)
   vScrollToEnd (viewportScroll CommentModalContent)
 
 submitComment :: AppState -> ModalState Fixed -> IO ()
 submitComment s (CommentModalState editor issue _comments _isPR owner name _submissionState) = do
-  let commentText = T.unlines $ getEditContents editor
+  let commentText = T.intercalate "\n" $ map toText $ dumpEditor editor
   unless (T.null $ T.strip commentText) $ do
     let baseContext = s ^. appBaseContext
     let issueNum = case issueNumber issue of IssueNumber n -> n
@@ -78,7 +79,7 @@ submitComment _ _ = return () -- ZoomModalState doesn't support comments
 
 closeWithComment :: AppState -> ModalState Fixed -> IO ()
 closeWithComment s (CommentModalState editor issue _comments _isPR owner name _submissionState) = do
-  let commentText = T.unlines $ getEditContents editor
+  let commentText = T.intercalate "\n" $ map toText $ dumpEditor editor
   let baseContext = s ^. appBaseContext
   let issueNum = case issueNumber issue of IssueNumber n -> n
   void $ async $ do

app/Sauron/Event/NewIssueModal.hs

@@ -17,6 +17,8 @@ import Sauron.Event.Helpers (withFixedElemAndParents)
 import qualified Sauron.Mutations.Issue as Issue
 import Sauron.Types
 import UnliftIO.Async
+import WEditor.LineWrap (breakWords, noHyphen)
+import WEditorBrick.WrappingEditor (dumpEditor, newEditor)
 
 
 handleNewIssueModalEvent :: AppState -> NewIssueModalEvent -> EventM ClickableName AppState ()
@@ -36,7 +38,7 @@ submitNewIssue :: AppState -> ModalState Fixed -> IO ()
 submitNewIssue s (NewIssueModalState {..}) = do
   let titleText = T.strip $ T.unlines $ getEditContents _newIssueTitleEditor
   unless (T.null titleText) $ do
-    let bodyText = T.unlines $ getEditContents _newIssueBodyEditor
+    let bodyText = T.unlines $ map toText $ dumpEditor _newIssueBodyEditor
     let baseContext = s ^. appBaseContext
     void $ async $ do
       result <- Issue.createNewIssue baseContext _newIssueRepoOwner _newIssueRepoName titleText bodyText
@@ -48,4 +50,4 @@ openNewIssueModal owner name =
   modify (appModal ?~ NewIssueModalState titleEditor bodyEditor owner name NotSubmitting True)
    where
      titleEditor = editorText NewIssueTitleEditor (Just 1) ""
-     bodyEditor = editorText NewIssueBodyEditor Nothing ""
+     bodyEditor = newEditor (breakWords noHyphen) NewIssueBodyEditor []

app/Sauron/HealthCheck/Workflow.hs

@@ -40,44 +40,48 @@ startWorkflowHealthCheckIfNeeded ::
   -> Node Variable 'SingleWorkflowT
   -> NonEmpty (SomeNode Variable)
   -> IO (Maybe (Async ()))
-startWorkflowHealthCheckIfNeeded baseContext node@(SingleWorkflowNode (EntityData {_static=workflowRun, ..})) parents = do
-  case findRepoParent parents of
-    Just (RepoNode (EntityData {_static=(owner, name)})) | hasRunningWorkflow workflowRun -> do
-      readTVarIO _healthCheckThread >>= \case
-        Nothing -> do
-          log baseContext LevelInfo [i|Starting health check thread for workflow: #{untagName $ workflowRunName workflowRun} \##{workflowRunRunNumber workflowRun} (period: #{workflowHealthCheckPeriodUs}us)|] Nothing
-          newThread <- async $ runWorkflowHealthCheckLoop baseContext owner name node
-          atomically $ writeTVar _healthCheckThread (Just (newThread, workflowHealthCheckPeriodUs))
-          return (Just newThread)
-        Just (thread, _) -> return (Just thread)
+startWorkflowHealthCheckIfNeeded baseContext node@(SingleWorkflowNode (EntityData {_static=workflowRun, _ident=nodeIdent, ..})) parents = do
+  case (findRepoParent parents, findWorkflowsParent parents) of
+    (Just (RepoNode (EntityData {_static=(owner, name)})), Just (PaginatedWorkflowsNode (EntityData {_children=workflowsChildren})))
+      | isRunningWorkflow workflowRun -> do
+        info' baseContext [i|Considering whether to start workflow healthcheck thread for run: #{workflowRun}|]
+        readTVarIO _healthCheckThread >>= \case
+          Nothing -> do
+            log baseContext LevelInfo [i|Starting health check thread for workflow: #{untagName $ workflowRunName workflowRun} \##{workflowRunRunNumber workflowRun} (period: #{workflowHealthCheckPeriodUs}us)|] Nothing
+            newThread <- async $ runWorkflowHealthCheckLoop baseContext owner name node workflowsChildren nodeIdent
+            atomically $ writeTVar _healthCheckThread (Just (newThread, workflowHealthCheckPeriodUs))
+            return (Just newThread)
+          Just (thread, _) -> return (Just thread)
     _ -> return Nothing
   where
-    runWorkflowHealthCheckLoop :: BaseContext -> Name Owner -> Name Repo -> Node Variable 'SingleWorkflowT -> IO ()
-    runWorkflowHealthCheckLoop bc owner name (SingleWorkflowNode (EntityData {_static=staticWorkflowRun})) =
+    runWorkflowHealthCheckLoop :: BaseContext -> Name Owner -> Name Repo -> Node Variable 'SingleWorkflowT -> TVar [Node Variable 'SingleWorkflowT] -> Int -> IO ()
+    runWorkflowHealthCheckLoop bc owner name (SingleWorkflowNode (EntityData {_static=staticWorkflowRun})) workflowsChildren nodeIdent' =
       flip runReaderT bc $
       handleAny (\e -> putStrLn [i|Workflow health check thread crashed: #{e}|]) $
-      fix $ \loop -> do
+      fix $ \loop ->
         fetchWorkflowJobs owner name (workflowRunWorkflowRunId staticWorkflowRun) node >>= \case
-          Left _err -> checkWorkflowForDoneness bc owner name (workflowRunWorkflowRunId staticWorkflowRun) loop
+          Left _err ->
+            checkWorkflowForDoneness bc owner name (workflowRunWorkflowRunId staticWorkflowRun) loop workflowsChildren nodeIdent'
           Right jobs
-            | all isJobCompleted jobs -> checkWorkflowForDoneness bc owner name (workflowRunWorkflowRunId staticWorkflowRun) loop
+            | all isJobCompleted jobs ->
+                checkWorkflowForDoneness bc owner name (workflowRunWorkflowRunId staticWorkflowRun) loop workflowsChildren nodeIdent'
             | otherwise -> do
                 -- Save an API call by not checking the workflow for doneness. Just sleep and loop.
                 threadDelay workflowHealthCheckPeriodUs
                 loop
 
-    checkWorkflowForDoneness bc owner name workflowRunId loop =
+    checkWorkflowForDoneness bc owner name workflowRunId loop workflowsChildren nodeIdent' = do
       withGithubApiSemaphore (githubWithLogging (workflowRunR owner name workflowRunId)) >>= \case
         Left err -> warn' bc [i|(#{untagName owner}/#{untagName name}) Couldn't fetch workflow run #{workflowRunId}: #{err}|]
-        Right response ->
-          case hasRunningWorkflow response of
-            True -> do
-              threadDelay workflowHealthCheckPeriodUs
-              loop
-            False -> do
-              -- Stop ourselves by clearing the thread reference and returning
-              atomically $ writeTVar _healthCheckThread Nothing
-              return ()
+        Right workflowRun'
+          | isRunningWorkflow workflowRun' -> threadDelay workflowHealthCheckPeriodUs >> loop
+          | otherwise -> liftIO $ atomically $ do
+              -- Update the parent's _children, replacing our node with updated _static
+              modifyTVar' workflowsChildren $ map $ \child@(SingleWorkflowNode childEd) ->
+                if _ident childEd == nodeIdent'
+                then SingleWorkflowNode (childEd { _static = workflowRun' })
+                else child
+              writeTVar _healthCheckThread Nothing
 
-    hasRunningWorkflow :: WorkflowRun -> Bool
-    hasRunningWorkflow wr = not $ isWorkflowCompleted $ fromMaybe (workflowRunStatus wr) (workflowRunConclusion wr)
+    isRunningWorkflow :: WorkflowRun -> Bool
+    isRunningWorkflow wr = not $ isWorkflowCompleted $ fromMaybe (workflowRunStatus wr) (workflowRunConclusion wr)