From 3127a8a7fb61c18d57feef951ce453283ac28aa1 Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Mon, 2 Oct 2023 09:44:36 -0700 Subject: [PATCH] withStage helper (#253) * withStage helper * remove stale code * a few cosmetic changes --- .../ghc-specter-daemon/Render/BlockerView.hs | 12 +++------ .../app/ghc-specter-daemon/Render/Common.hs | 16 ++++++++++++ .../ghc-specter-daemon/Render/ModuleGraph.hs | 18 ++++--------- .../ghc-specter-daemon/Render/SourceView.hs | 26 +++++++------------ .../ghc-specter-daemon/Render/TimingView.hs | 11 +++----- .../src/GHCSpecter/UI/Components/TextView.hs | 2 +- 6 files changed, 39 insertions(+), 46 deletions(-) diff --git a/daemon/app/ghc-specter-daemon/Render/BlockerView.hs b/daemon/app/ghc-specter-daemon/Render/BlockerView.hs index 447a585d..eb8c1433 100644 --- 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 index 5287916a..8fa031a0 100644 --- 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 index 28fd9b94..855cc909 100644 --- a/daemon/app/ghc-specter-daemon/Render/ModuleGraph.hs +++ b/daemon/app/ghc-specter-daemon/Render/ModuleGraph.hs @@ -10,9 +10,8 @@ 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 @@ -20,10 +19,7 @@ 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 index 87a90b49..72a0dc1e 100644 --- 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,29 @@ 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 -- 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 +98,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 +143,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 index d2e9113b..1e5d357c 100644 --- 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 diff --git a/daemon/src/GHCSpecter/UI/Components/TextView.hs b/daemon/src/GHCSpecter/UI/Components/TextView.hs index 776ed051..7516e712 100644 --- a/daemon/src/GHCSpecter/UI/Components/TextView.hs +++ b/daemon/src/GHCSpecter/UI/Components/TextView.hs @@ -36,7 +36,7 @@ rowSize :: Double rowSize = 8 ratio :: Double -ratio = 1.3 -- 0.625 +ratio = 0.9 charSize :: Double charSize = rowSize * ratio