build fix for web

MercuryTechnologies · Apr 29, 2023 · 0af5752 · 0af5752
1 parent 7d2ddb7
commit 0af5752
Show file tree

Hide file tree

Showing 5 changed files with 22 additions and 87 deletions.
diff --git a/daemon/app/font-test/Main.hs b/daemon/app/font-test/Main.hs
diff --git a/daemon/app/ghc-specter-daemon/GHCSpecter/Web/ConcurReplicaSVG.hs b/daemon/app/ghc-specter-daemon/GHCSpecter/Web/ConcurReplicaSVG.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module GHCSpecter.Web.ConcurReplicaSVG (
   makePolylineText,
@@ -29,6 +30,7 @@ import GHCSpecter.Graphics.DSL (
   Rectangle (..),
   Shape (..),
  )
+import GHCSpecter.Layouter.Text (MonadTextLayout (..))
 import Text.Printf (printf)
 import Prelude hiding (div)
 
@@ -97,3 +99,9 @@ renderPrimitive _ (Primitive (SDrawText (DrawText (x, y) _pos _font color _fontS
     , SP.pointerEvents "none"
     ]
     [text msg]
+
+-- This is a dummy implementation. There are no easy way to get text dimension from web in concur-replica.
+-- TODO: at least, this should produce a reasonable size, not fixed 120.
+instance MonadTextLayout (Widget IHTML) where
+  calculateTextDimension _ font_size _ =
+    pure (120, fromIntegral font_size + 3)
diff --git a/daemon/app/ghc-specter-daemon/GHCSpecter/Web/ModuleGraph.hs b/daemon/app/ghc-specter-daemon/GHCSpecter/Web/ModuleGraph.hs
@@ -99,17 +99,17 @@ renderModuleGraph
   nameMap
   valueFor
   grVisInfo
-  (mfocused, mhinted) =
+  (mfocused, mhinted) = do
     let Dim canvasWidth canvasHeight = grVisInfo ^. gviCanvasDim
         handlers hitEvent =
           catMaybes
             [ fmap (\ev -> ev <$ onMouseEnter) (hitEventHoverOn hitEvent)
             , fmap (\ev -> ev <$ onMouseLeave) (hitEventHoverOff hitEvent)
             , fmap (\ev -> fromEither ev <$ onClick) (hitEventClick hitEvent)
             ]
-        scene = buildModuleGraph nameMap valueFor grVisInfo (mfocused, mhinted)
-        rexp = sceneElements scene
-        svgProps =
+    scene <- buildModuleGraph nameMap valueFor grVisInfo (mfocused, mhinted)
+    let rexp = sceneElements scene
+    let svgProps =
           [ width (T.pack (show (canvasWidth + 100)))
           , SP.viewBox
               ( "0 0 "
@@ -126,14 +126,14 @@ renderModuleGraph
             ( S.style [] [text ".small { font: 6px Courier,monospace; } text { user-select: none; }"]
                 : fmap (renderPrimitive handlers) rexp
             )
-     in div [classList [("is-fullwidth", True)]] [svgElement]
+    div [classList [("is-fullwidth", True)]] [svgElement]
 
 -- | render graph more simply
 renderGraph :: (Text -> Bool) -> GraphVisInfo -> Widget IHTML a
-renderGraph cond grVisInfo =
+renderGraph cond grVisInfo = do
   let Dim canvasWidth canvasHeight = grVisInfo ^. gviCanvasDim
-      rexp = buildGraph cond grVisInfo
-      svgProps =
+  rexp <- buildGraph cond grVisInfo
+  let svgProps =
         [ width (T.pack (show (canvasWidth + 100)))
         , SP.viewBox
             ( "0 0 "

diff --git a/daemon/app/ghc-specter-daemon/GHCSpecter/Web/Timing.hs b/daemon/app/ghc-specter-daemon/GHCSpecter/Web/Timing.hs
@@ -101,7 +101,9 @@ renderTimingChart ::
   TimingUI ->
   TimingTable ->
   Widget IHTML Event
-renderTimingChart drvModMap tui ttable =
+renderTimingChart drvModMap tui ttable = do
+  scene <- TimingView.buildTimingChart drvModMap tui ttable
+  let rexp = sceneElements scene
   S.svg
     svgProps
     [ S.style [] [text ".small { font: 5px sans-serif; } text { user-select: none; }"]
@@ -113,8 +115,6 @@ renderTimingChart drvModMap tui ttable =
         [ fmap (\ev -> TimingEv ev <$ onMouseEnter) (hitEventHoverOn hitEvent)
         , fmap (\ev -> TimingEv ev <$ onMouseLeave) (hitEventHoverOn hitEvent)
         ]
-    scene = TimingView.buildTimingChart drvModMap tui ttable
-    rexp = sceneElements scene
     vpi = tui ^. timingUIViewPort
     vp = fromMaybe (vpi ^. vpViewPort) (vpi ^. vpTempViewPort)
     svgProps =
@@ -145,15 +145,15 @@ renderMemChart ::
   TimingUI ->
   TimingTable ->
   Widget IHTML Event
-renderMemChart drvModMap tui ttable =
+renderMemChart drvModMap tui ttable = do
+  scene <- TimingView.buildMemChart drvModMap tui ttable
+  let rexp = sceneElements scene
   S.svg
     svgProps
     [ S.style [] [text ".small { font: 5px sans-serif; } text { user-select: none; }"]
     , S.g [] (fmap (renderPrimitive (const [])) rexp)
     ]
   where
-    scene = TimingView.buildMemChart drvModMap tui ttable
-    rexp = sceneElements scene
     vpi = tui ^. timingUIViewPort
     vp = fromMaybe (vpi ^. vpViewPort) (vpi ^. vpTempViewPort)
     viewboxProp =

diff --git a/daemon/ghc-specter-daemon.cabal b/daemon/ghc-specter-daemon.cabal
@@ -163,20 +163,6 @@ executable ghc-specter-daemon
     , websockets
   default-language: GHC2021
 
-executable font-test
-  main-is: Main.hs
-  hs-source-dirs:
-      app/font-test
-  ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
-  build-depends:
-      base >=4.15 && <5
-    , ghc-specter-daemon
-    , ghc-specter-render
-    , gi-pango
-    , gi-pangocairo
-    , transformers
-  default-language: GHC2021
-
 test-suite ghc-specter-daemon-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs