withStage helper

MercuryTechnologies · Oct 2, 2023 · 6dda5ff · 6dda5ff
1 parent 9415000
commit 6dda5ff
Show file tree

Hide file tree

Showing 5 changed files with 39 additions and 45 deletions.
diff --git a/daemon/app/ghc-specter-daemon/Render/BlockerView.hs b/daemon/app/ghc-specter-daemon/Render/BlockerView.hs
@@ -9,7 +9,7 @@ where
 import Control.Monad.Extra (whenM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.State.Strict (StateT, get)
-import Data.Foldable (for_, traverse_)
+import Data.Foldable (traverse_)
 import Data.List qualified as L
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (secondsToNominalDiffTime)
@@ -18,10 +18,7 @@ import Foreign.Marshal.Utils (fromBool, toBool)
 import GHCSpecter.Channel.Outbound.Types (ModuleGraphInfo (..))
 import GHCSpecter.Data.Map (backwardLookup)
 import GHCSpecter.Data.Timing.Types (PipelineInfo (..), TimingTable (..))
-import GHCSpecter.Graphics.DSL
-  ( Scene (..),
-    Stage (..),
-  )
+import GHCSpecter.Graphics.DSL (Scene (..))
 import GHCSpecter.Server.Types
   ( ModuleGraphState (..),
     ServerState (..),
@@ -37,7 +34,7 @@ import GHCSpecter.UI.Types.Event
   )
 import Handler (sendToControl)
 import ImGui qualified
-import Render.Common (renderComponent)
+import Render.Common (renderComponent, withStage)
 import Util.Render
   ( SharedState (..),
     mkRenderState,
@@ -66,8 +63,7 @@ render _ui ss = do
     Nothing -> pure ()
     Just blockerGraphViz -> do
       renderState <- mkRenderState
-      let Stage stage = shared.sharedStage
-      for_ (L.find ((== "blocker-module-graph") . sceneId) stage) $ \stageBlocker -> do
+      withStage "blocker-module-graph" $ \stageBlocker -> do
         runImRender renderState $
           renderComponent
             True

diff --git a/daemon/app/ghc-specter-daemon/Render/Common.hs b/daemon/app/ghc-specter-daemon/Render/Common.hs
@@ -3,15 +3,21 @@
 
 module Render.Common
   ( renderComponent,
+    withStage,
   )
 where
 
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.State.Strict (StateT, get)
+import Data.Foldable (traverse_)
 import Data.Functor.Identity (runIdentity)
+import Data.List qualified as L
+import Data.Text (Text)
 import GHCSpecter.Graphics.DSL
   ( Primitive,
     Scene (..),
+    Stage (..),
     ViewPort (..),
   )
 import GHCSpecter.Layouter.Text (MonadTextLayout (..))
@@ -25,6 +31,7 @@ import ImGui
 import STD.Deletable (delete)
 import Util.Render
   ( ImRender,
+    SharedState (..),
     addEventMap,
     buildEventMap,
     renderScene,
@@ -61,3 +68,12 @@ renderComponent doesHandleScroll toEv buildScene = do
     (vx1, vy1) = scene.sceneGlobalViewPort.bottomRight
     totalW = vx1 - vx0
     totalH = vy1 - vy0
+
+withStage ::
+  Text ->
+  (Scene () -> StateT (SharedState UserEvent) IO a) ->
+  StateT (SharedState UserEvent) IO ()
+withStage scene_name action = do
+  shared <- get
+  let Stage stage = shared.sharedStage
+  traverse_ action (L.find ((== scene_name) . sceneId) stage)
diff --git a/daemon/app/ghc-specter-daemon/Render/ModuleGraph.hs b/daemon/app/ghc-specter-daemon/Render/ModuleGraph.hs
@@ -10,20 +10,16 @@ where
 import Control.Error.Util (note)
 import Control.Monad.Extra (whenM)
 import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Trans.State.Strict (StateT, get)
+import Control.Monad.Trans.State.Strict (StateT)
 import Data.Bits ((.|.))
-import Data.Foldable (for_)
 import Data.List qualified as L
 import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
 import Foreign.C.String (CString)
 import Foreign.Marshal.Utils (fromBool, toBool)
 import GHCSpecter.Channel.Outbound.Types (ModuleGraphInfo (..))
 import GHCSpecter.Data.Timing.Util (isModuleCompilationDone)
-import GHCSpecter.Graphics.DSL
-  ( Scene (..),
-    Stage (..),
-  )
+import GHCSpecter.Graphics.DSL (Scene (..))
 import GHCSpecter.Server.Types
   ( ModuleGraphState (..),
     ServerState (..),
@@ -41,7 +37,7 @@ import GHCSpecter.UI.Types.Event
   )
 import ImGui qualified
 import ImGui.Enum (ImGuiTableFlags_ (..))
-import Render.Common (renderComponent)
+import Render.Common (renderComponent, withStage)
 import STD.Deletable (delete)
 import Text.Printf (printf)
 import Util.GUI (windowFlagsNoScroll)
@@ -88,9 +84,7 @@ renderMainModuleGraph ui ss = do
           mainModuleClicked = mgrui._modGraphUIClick
           mainModuleHovered = mgrui._modGraphUIHover
       renderState <- mkRenderState
-      shared <- get
-      let Stage stage = shared.sharedStage
-      for_ (L.find ((== "main-module-graph") . sceneId) stage) $ \stageMain -> do
+      withStage "main-module-graph" $ \stageMain -> do
         runImRender renderState $
           renderComponent
             True
@@ -134,9 +128,7 @@ renderSubModuleGraph ui ss = do
             | isModuleCompilationDone drvModMap timing name = 1
             | otherwise = 0
       renderState <- mkRenderState
-      shared <- get
-      let Stage stage = shared.sharedStage
-      for_ (L.find ((== "sub-module-graph") . sceneId) stage) $ \stageSub -> do
+      withStage "sub-module-graph" $ \stageSub -> do
         runImRender renderState $
           renderComponent
             True

diff --git a/daemon/app/ghc-specter-daemon/Render/SourceView.hs b/daemon/app/ghc-specter-daemon/Render/SourceView.hs
@@ -19,7 +19,7 @@ import Data.Text qualified as T
 import Foreign.C.String (CString)
 import Foreign.Marshal.Utils (fromBool, toBool)
 import GHCSpecter.Data.GHC.Hie (ModuleHieInfo (..))
-import GHCSpecter.Graphics.DSL (Scene (..), Stage (..))
+import GHCSpecter.Graphics.DSL (Scene (..))
 import GHCSpecter.Server.Types
   ( HieState (..),
     ServerState (..),
@@ -39,7 +39,7 @@ import GHCSpecter.UI.Types.Event
 import GHCSpecter.Worker.CallGraph (getReducedTopLevelDecls)
 import Handler (sendToControl)
 import ImGui qualified
-import Render.Common (renderComponent)
+import Render.Common (renderComponent, withStage)
 import STD.Deletable (delete)
 import Util.GUI
   ( defTableFlags,
@@ -55,33 +55,30 @@ import Util.Render
 
 render :: UIState -> ServerState -> StateT (SharedState UserEvent) IO ()
 render ui ss = do
-  vec1 <- liftIO $ ImGui.newImVec2 400 0
-  vec2 <- liftIO $ ImGui.newImVec2 400 0
-  vec3 <- liftIO $ ImGui.newImVec2 400 0
+  zero <- liftIO $ ImGui.newImVec2 0 0
   whenM (toBool <$> liftIO (ImGui.beginTable ("##table" :: CString) 3 defTableFlags)) $ do
     liftIO $ ImGui.tableSetupColumn_ ("graph" :: CString)
     liftIO $ ImGui.tableNextRow 0
     liftIO $ ImGui.tableSetColumnIndex 0
-    _ <- liftIO $ ImGui.beginChild ("#module-tree" :: CString) vec1 (fromBool False) windowFlagsNoScrollbar
+    _ <- liftIO $ ImGui.beginChild ("#module-tree" :: CString) zero (fromBool False) windowFlagsNoScrollbar
     renderModuleTree srcUI ss
     liftIO ImGui.endChild
     --
     liftIO $ ImGui.tableSetColumnIndex 1
-    _ <- liftIO $ ImGui.beginChild ("#source-view" :: CString) vec2 (fromBool False) windowFlagsNoScroll
+    _ <- liftIO $ ImGui.beginChild ("#source-view" :: CString) zero (fromBool False) windowFlagsNoScroll
     for_ mexpandedModu $ \modu ->
       renderSourceTextView modu ss
     liftIO ImGui.endChild
+    --  updateStage "source-view"
     --
     liftIO $ ImGui.tableSetColumnIndex 2
-    _ <- liftIO $ ImGui.beginChild ("#supp-view" :: CString) vec3 (fromBool False) windowFlagsNoScroll
+    _ <- liftIO $ ImGui.beginChild ("#supp-view" :: CString) zero (fromBool False) windowFlagsNoScroll
     for_ mexpandedModu $ \modu ->
       renderSuppViewPanel modu srcUI ss
     liftIO ImGui.endChild
   --
   liftIO ImGui.endTable
-  liftIO $ delete vec1
-  liftIO $ delete vec2
-  liftIO $ delete vec3
+  liftIO $ delete zero
   where
     srcUI = ui._uiModel._modelSourceView
     mexpandedModu = srcUI._srcViewExpandedModule
@@ -102,9 +99,7 @@ renderSourceTextView modu ss = do
     let topLevelDecls = getReducedTopLevelDecls modHieInfo
         src = modHieInfo._modHieSource
     renderState <- mkRenderState
-    shared <- get
-    let Stage stage = shared.sharedStage
-    for_ (L.find ((== "source-view") . sceneId) stage) $ \stage_source ->
+    withStage "source-view" $ \stage_source ->
       runImRender renderState $
         renderComponent
           True
@@ -149,9 +144,7 @@ renderSuppViewPanel modu srcUI ss = do
 renderSuppViewContents :: Text -> SourceViewUI -> ServerState -> StateT (SharedState UserEvent) IO ()
 renderSuppViewContents modu srcUI ss = do
   renderState <- mkRenderState
-  shared <- get
-  let Stage stage = shared.sharedStage
-  for_ (L.find ((== "supple-view-contents") . sceneId) stage) $ \stage_supp -> do
+  withStage "supple-view-contents" $ \stage_supp ->
     runImRender renderState $ do
       renderComponent
         True

diff --git a/daemon/app/ghc-specter-daemon/Render/TimingView.hs b/daemon/app/ghc-specter-daemon/Render/TimingView.hs
@@ -10,7 +10,6 @@ import Control.Monad.Extra (whenM)
 import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.State.Strict (StateT, get)
 import Data.Foldable (for_)
-import Data.List qualified as L
 import Data.Maybe (fromMaybe, isNothing)
 import Foreign.C.String (CString)
 import Foreign.Marshal.Alloc (alloca)
@@ -22,7 +21,6 @@ import GHCSpecter.Data.Timing.Types
   )
 import GHCSpecter.Graphics.DSL
   ( Scene (..),
-    Stage (..),
     ViewPort (..),
   )
 import GHCSpecter.Server.Types
@@ -46,7 +44,7 @@ import GHCSpecter.UI.Types.Event
 import Handler (sendToControl)
 import ImGui qualified
 import ImGui.ImVec2.Implementation (imVec2_x_get, imVec2_y_get)
-import Render.Common (renderComponent)
+import Render.Common (renderComponent, withStage)
 import STD.Deletable (delete)
 import Util.GUI (windowFlagsNoScroll)
 import Util.Render
@@ -72,10 +70,9 @@ render ui ss = do
       sendToControl shared (TimingEv (snd freezeOrThaw))
 
   renderState <- mkRenderState
-  let Stage stage = shared.sharedStage
-  for_ (L.find ((== "timing-chart") . sceneId) stage) $ \stageTiming ->
-    for_ (L.find ((== "mem-chart") . sceneId) stage) $ \stageMemory ->
-      for_ (L.find ((== "timing-range") . sceneId) stage) $ \stageRange -> do
+  withStage "timing-chart" $ \stageTiming ->
+    withStage "mem-chart" $ \stageMemory ->
+      withStage "timing-range" $ \stageRange -> do
         let ViewPort (_, vy0) (_, vy1) = stageTiming.sceneLocalViewPort
         runImRender renderState $ do
           renderComponent