refactor out renderDialog

MercuryTechnologies · Sep 26, 2023 · 2dd8821 · 2dd8821
1 parent 07cadca
commit 2dd8821
Show file tree

Hide file tree

Showing 2 changed files with 55 additions and 29 deletions.
diff --git a/daemon/app/ghc-specter-daemon/Render.hs b/daemon/app/ghc-specter-daemon/Render.hs
@@ -13,7 +13,7 @@ import Control.Concurrent.STM
 import Control.Monad (when)
 import Control.Monad.Extra (loopM, whenM)
 import Control.Monad.IO.Class (MonadIO (..))
-import Control.Monad.Trans.State (execStateT, get, modify')
+import Control.Monad.Trans.State (execStateT, get, modify', put)
 import Data.Bits ((.|.))
 import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe (isNothing)
@@ -42,8 +42,7 @@ import GHCSpecter.UI.Types.Event
 import Handler (sendToControl)
 import ImGui
 import ImGui.Enum
-  ( ImGuiCond_ (..),
-    ImGuiDir_ (..),
+  ( ImGuiDir_ (..),
     ImGuiKey (..),
     ImGuiMouseButton_ (..),
     ImGuiStyleVar_ (..),
@@ -88,6 +87,7 @@ import Util.Render
   ( SharedState (..),
     c_detectScaleFactor,
     loadAllFonts,
+    renderDialog,
   )
 
 singleFrame ::
@@ -161,30 +161,23 @@ singleFrame io window ui ss oldShared = do
 
     -- dialog box test
     when newShared.sharedPopup1 $ do
-      liftIO $ openPopup ("About ghc-specter" :: CString) 0
-      center <- liftIO $ imGuiViewport_GetCenter viewport
-      rel_pos <- liftIO $ newImVec2 0.5 0.5
-      liftIO $ setNextWindowPos center (fromIntegral (fromEnum ImGuiCond_Appearing)) rel_pos
-      liftIO $ delete rel_pos
-      let flag = fromIntegral (fromEnum ImGuiWindowFlags_AlwaysAutoResize)
-      whenM (toBool <$> liftIO (beginPopupModal ("About ghc-specter" :: CString) nullPtr flag)) $ do
-        liftIO $ textUnformatted ("ghc-specter 1.0.0.0" :: CString)
-        whenM (toBool <$> liftIO (button ("close" :: CString))) $
-          modify' (\s -> s {sharedPopup1 = False})
-        liftIO endPopup
-
+      newShared' <-
+        liftIO $
+          renderDialog
+            "About ghc-specter"
+            "ghc-specter 1.0.0.0"
+            (\b s -> s {sharedPopup1 = b})
+            newShared
+      put newShared'
     when newShared.sharedPopup2 $ do
-      liftIO $ openPopup ("HelpABC" :: CString) 0
-      center <- liftIO $ imGuiViewport_GetCenter viewport
-      rel_pos <- liftIO $ newImVec2 0.5 0.5
-      liftIO $ setNextWindowPos center (fromIntegral (fromEnum ImGuiCond_Appearing)) rel_pos
-      -- liftIO $ delete rel_pos
-      let flag = fromIntegral (fromEnum ImGuiWindowFlags_AlwaysAutoResize)
-      whenM (toBool <$> liftIO (beginPopupModal ("HelpABC" :: CString) nullPtr flag)) $ do
-        liftIO $ textUnformatted ("I cannot help you now." :: CString)
-        whenM (toBool <$> liftIO (button ("close" :: CString))) $
-          modify' (\s -> s {sharedPopup2 = False})
-        liftIO endPopup
+      newShared' <-
+        liftIO $
+          renderDialog
+            "Help"
+            "I cannot help you now"
+            (\b s -> s {sharedPopup2 = b})
+            newShared
+      put newShared'
 
     -- fullscreen window
     let flags =

diff --git a/daemon/app/ghc-specter-daemon/Util/Render.hs b/daemon/app/ghc-specter-daemon/Util/Render.hs
@@ -31,6 +31,9 @@ module Util.Render
 
     -- * rendering console
     renderConsoleItem,
+
+    -- * render dialog
+    renderDialog,
   )
 where
 
@@ -44,7 +47,7 @@ import Control.Concurrent.STM
     writeTVar,
   )
 import Control.Monad (when)
-import Control.Monad.Extra (whenM)
+import Control.Monad.Extra (ifM, whenM)
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Reader (MonadReader (..))
 import Control.Monad.Trans.Class (lift)
@@ -66,7 +69,7 @@ import Foreign.C.String (CString, withCString)
 import Foreign.C.Types (CFloat (..))
 import Foreign.Marshal.Array (allocaArray)
 import Foreign.Marshal.Utils (fromBool, toBool)
-import Foreign.Ptr (Ptr, castPtr)
+import Foreign.Ptr (Ptr, castPtr, nullPtr)
 import Foreign.Storable (pokeElemOff)
 import GHCSpecter.Graphics.DSL
   ( DrawText (..),
@@ -90,6 +93,10 @@ import GHCSpecter.UI.Types.Event
     UserEvent (..),
   )
 import ImGui
+import ImGui.Enum
+  ( ImGuiCond_ (..),
+    ImGuiWindowFlags_ (..),
+  )
 import ImGui.ImFont.Implementation (imFont_Scale_set)
 import STD.Deletable (delete)
 import Util.Color (getNamedColor)
@@ -109,6 +116,7 @@ data SharedState e = SharedState
     sharedIsMouseMoved :: Bool,
     sharedIsClicked :: Bool,
     sharedTabState :: Maybe Tab,
+    -- TODO: this is impure. should be out of the pure state.
     sharedChanQEv :: TQueue Event,
     sharedFontsSans :: NonEmpty (Int, ImFont),
     sharedFontsMono :: NonEmpty (Int, ImFont),
@@ -125,7 +133,8 @@ data SharedState e = SharedState
   }
 
 data ImRenderState = ImRenderState
-  { currDrawList :: ImDrawList,
+  { -- TODO: this is impure.
+    currDrawList :: ImDrawList,
     currOriginInImGui :: (Double, Double),
     currUpperLeftInGlobalViewport :: (Double, Double),
     currUpperLeftInLocalViewport :: (Double, Double),
@@ -389,3 +398,27 @@ renderConsoleItem s (ConsoleButton buttonss) = do
 renderConsoleItem _ (ConsoleCore forest) = liftIO $ T.withCString (T.unlines $ fmap render1 forest) textUnformatted
   where
     render1 tr = T.pack $ drawTree $ fmap show tr
+
+renderDialog :: Text -> Text -> (Bool -> SharedState e -> SharedState e) -> SharedState e -> IO (SharedState e)
+renderDialog id' content setter shared =
+  T.withCString id' $ \c_id ->
+    T.withCString content $ \c_content -> do
+      viewport <- getMainViewport
+      openPopup c_id 0
+      center <- imGuiViewport_GetCenter viewport
+      rel_pos <- newImVec2 0.5 0.5
+      setNextWindowPos center (fromIntegral (fromEnum ImGuiCond_Appearing)) rel_pos
+      delete rel_pos
+      let flag = fromIntegral (fromEnum ImGuiWindowFlags_AlwaysAutoResize)
+      ifM
+        (toBool <$> beginPopupModal c_id nullPtr flag)
+        ( do
+            textUnformatted c_content
+            isClosePressed <- toBool <$> button ("close" :: CString)
+            let shared'
+                  | isClosePressed = setter False shared
+                  | otherwise = shared
+            endPopup
+            pure shared'
+        )
+        (pure shared)