Tab width is now automatically computed. (#186)

MercuryTechnologies · Apr 30, 2023 · 9da5a47 · 9da5a47
1 parent 1fe3fa5
commit 9da5a47
Show file tree

Hide file tree

Showing 5 changed files with 44 additions and 30 deletions.
diff --git a/daemon/ghc-specter-daemon.cabal b/daemon/ghc-specter-daemon.cabal
@@ -90,6 +90,7 @@ library
     , lens
     , pretty-simple
     , resourcet
+    , safe
     , stdcxx
     , stm
     , text

diff --git a/daemon/src/GHCSpecter/UI/Components/Tab.hs b/daemon/src/GHCSpecter/UI/Components/Tab.hs
@@ -3,27 +3,33 @@ module GHCSpecter.UI.Components.Tab (
   buildTab,
 ) where
 
+import Data.Foldable qualified as F
 import Data.List qualified as L
+import Data.List.NonEmpty qualified as NE
+import Data.Semigroup (sconcat)
 import Data.Text (Text)
 import GHCSpecter.Graphics.DSL (
   Color (..),
   HitEvent (..),
-  Primitive,
+  Primitive (..),
   Scene (..),
   TextFontFace (..),
   TextPosition (..),
   ViewPort (..),
+  getLeastUpperBoundingBox,
   polyline,
   rectangle,
+  viewPortWidth,
  )
+import GHCSpecter.Layouter.Packer (flowInline)
 import GHCSpecter.Layouter.Text (
   MonadTextLayout,
   drawText',
  )
+import Safe (atMay)
 
 data TabConfig tab = TabConfig
   { tabCfgId :: Text
-  , tabCfgSpacing :: Double
   , tabCfgWidth :: Double
   , tabCfgHeight :: Double
   , tabCfgItems :: [(tab, Text)]
@@ -36,8 +42,17 @@ buildTab ::
   Maybe tab ->
   m (Scene (Primitive tab))
 buildTab cfg mtab = do
-  renderedTabItems <- traverse mkTab items
-  let rexp = concat (renderedTabItems ++ [[mkLine mselected]])
+  tabItems_ <- traverse mkTab items
+  let renderedTabItems =
+        case NE.nonEmpty tabItems_ of
+          Nothing -> [polyline (0, height) [] (end, height) Black 1.0]
+          Just tabItems' ->
+            let (_, placed) = flowInline 5 tabItems'
+                placed' :: NE.NonEmpty (Primitive tab)
+                placed' = sconcat placed
+                line = mkLine mselected (F.toList placed)
+             in F.toList placed' ++ [line]
+      rexp = renderedTabItems
   pure
     Scene
       { sceneId = tabCfgId cfg
@@ -47,39 +62,40 @@ buildTab cfg mtab = do
       , sceneExtent = Nothing
       }
   where
-    spacing = tabCfgSpacing cfg
     height = tabCfgHeight cfg
     items = zip [0 ..] (tabCfgItems cfg)
     mselected = do
       tab <- mtab
       L.find (\(_, (tab', _)) -> tab == tab') items
-
-    tabPos n = 5 + spacing * fromIntegral n
     end = tabCfgWidth cfg
     vp = ViewPort (0, 0) (end, height)
     fontSize = 8
-    mkTab (n, (tab, txt)) = do
-      let x = tabPos (n :: Int)
-          hitEvent =
+    mkTab (_, (tab, txt)) = do
+      let hitEvent =
             HitEvent
               { hitEventHoverOn = Nothing
               , hitEventHoverOff = Nothing
               , hitEventClick = Just (Right tab)
               }
-      renderedText <- drawText' (x, 2) UpperLeft Sans Black fontSize txt
-      pure
-        [ rectangle (x, 2) 80 (height - 2) Nothing (Just White) Nothing (Just hitEvent)
-        , renderedText
-        ]
-    mkLine (Just (n, _)) =
-      polyline
-        (0, height)
-        [ (tabPos n - 2, height)
-        , (tabPos n - 2, 1)
-        , (tabPos n - 2 + spacing, 1)
-        , (tabPos n - 2 + spacing, height)
-        ]
-        (end, height)
-        Black
-        1.0
-    mkLine Nothing = polyline (0, height) [] (end, height) Black 1.0
+      renderedText <- drawText' (5, 2) UpperLeft Sans Black fontSize txt
+      let bbox = primBoundingBox renderedText
+          width = viewPortWidth bbox
+      pure $
+        rectangle (0, 2) (width + 10) (height - 2) Nothing (Just White) Nothing (Just hitEvent)
+          NE.:| [renderedText]
+    mkLine (Just (n, _)) tabItems =
+      case Safe.atMay tabItems n of
+        Nothing -> polyline (0, height) [] (end, height) Black 1.0
+        Just e ->
+          let ViewPort (x0, _y0) (x1, _y1) = getLeastUpperBoundingBox e
+           in polyline
+                (0, height)
+                [ (x0, height)
+                , (x0, 1)
+                , (x1, 1)
+                , (x1, height)
+                ]
+                (end, height)
+                Black
+                1.0
+    mkLine Nothing _ = polyline (0, height) [] (end, height) Black 1.0
diff --git a/daemon/src/GHCSpecter/UI/Console.hs b/daemon/src/GHCSpecter/UI/Console.hs
@@ -75,7 +75,6 @@ buildConsoleTab tabs mfocus =
     tabCfg =
       TabConfig
         { tabCfgId = "console-tab"
-        , tabCfgSpacing = 150
         , tabCfgWidth = canvasDim ^. _1
         , tabCfgHeight = 15
         , tabCfgItems = tabs

diff --git a/daemon/src/GHCSpecter/UI/SourceView.hs b/daemon/src/GHCSpecter/UI/SourceView.hs
@@ -95,7 +95,6 @@ buildSuppViewPanel modu srcUI ss = do
     tabCfg =
       Tab.TabConfig
         { Tab.tabCfgId = "supple-view-tab"
-        , Tab.tabCfgSpacing = 80
         , Tab.tabCfgWidth = 500
         , Tab.tabCfgHeight = 15
         , Tab.tabCfgItems = suppViewTabs

diff --git a/daemon/src/GHCSpecter/UI/Tab.hs b/daemon/src/GHCSpecter/UI/Tab.hs
@@ -13,7 +13,6 @@ topLevelTab :: TabConfig Tab
 topLevelTab =
   TabConfig
     { tabCfgId = "tab"
-    , tabCfgSpacing = 80
     , tabCfgWidth = canvasDim ^. _1
     , tabCfgHeight = tabHeight
     , tabCfgItems =