feat: Draw edges

Note that `yellowTertiary` is the exact color we get from making `yellowPrimary` 80% transparent against a white background. We can no longer use actual transparency since it would cause edges to show through pattern boxes. Signed-off-by: George Thomas <[email protected]>
hackworthltd · Dec 12, 2024 · 5f92c09 · 5f92c09
1 parent 8bf649e
commit 5f92c09
Show file tree

Hide file tree

Showing 2 changed files with 72 additions and 30 deletions.
diff --git a/primer-miso/src/Primer/Miso.hs b/primer-miso/src/Primer/Miso.hs
@@ -18,8 +18,8 @@ import Data.Map qualified as Map
 import Data.Tree (Tree)
 import Data.Tree qualified as Tree
 import GHC.Base (error)
-import Linear (R1 (_x), V2 (V2))
-import Linear.Affine ((.+^), (.-^))
+import Linear (Metric (norm), R1 (_x), V2 (V2), unangle)
+import Linear.Affine ((.+^), (.-.), (.-^))
 import Miso hiding (P, node)
 import Optics hiding (view)
 import Optics.State.Operators ((?=))
@@ -187,7 +187,7 @@ viewNode opts extraOuterStyles extraInnerStyles =
               PatternBoxNode{} -> yellowPrimary
             backgroundColor = case opts of
               SyntaxNode{color} -> color
-              PatternBoxNode{} -> yellowPrimary <> "33" -- 1/5 opacity
+              PatternBoxNode{} -> yellowTertiary
               _ -> whitePrimary
     }
   where
@@ -308,6 +308,37 @@ viewTreeKind k =
       KFun{} -> SyntaxNode False bluePrimary "→"
     childViews = map viewTreeKind (children k)
 
+-- | Draw an edge from one point to another.
+viewEdge :: P2 Double -> P2 Double -> View action
+viewEdge p p' =
+  div_
+    [ style_
+        [ ("position", "absolute")
+        , ("transform-origin", "left")
+        , ("z-index", "-1")
+        ,
+          ( "transform"
+          , "translate("
+              <> show p.x
+              <> "px,"
+              <> show p.y
+              <> "px) rotate("
+              <> show theta
+              <> "rad)"
+          )
+        , ("border-style", "solid")
+        , ("border-color", greySecondary)
+        , ("border-width", ".125rem")
+        , ("height", "0px")
+        , ("width", show size <> "px")
+        ]
+    ]
+    []
+  where
+    v = p' .-. p
+    theta = unangle v
+    size = norm v
+
 viewTree :: Tree (MeasuredView action) -> View action
 viewTree = (.view) . viewTreeWithDimensions True
 
@@ -322,41 +353,48 @@ viewTreeWithDimensions outerPadding t =
     { dimensions = bottomRight - topLeft
     , view =
         div_ (mwhen outerPadding [style_ [("padding", show (padding / 2) <> "px")]])
-          $ map
-            ( \(node, p) ->
-                let offset = p .-^ node.dimensions / 2
-                 in div_
-                      [ style_
-                          [ ("position", "absolute")
-                          ,
-                            ( "transform"
-                            , "translate("
-                                <> show offset.x
-                                <> "px,"
-                                <> show offset.y
-                                <> "px)"
-                            )
-                          ]
-                      ]
-                      [node.view]
+          . map fst
+          . toList
+          $ Tree.foldTree
+            ( \(node, p) subs ->
+                Tree.Node
+                  ( div_ [] $
+                      let offset = p .-^ node.dimensions / 2
+                       in div_
+                            [ style_
+                                [ ("position", "absolute")
+                                ,
+                                  ( "transform"
+                                  , "translate("
+                                      <> show offset.x
+                                      <> "px,"
+                                      <> show offset.y
+                                      <> "px)"
+                                  )
+                                ]
+                            ]
+                            [node.view]
+                            : map (viewEdge p . head . map snd) subs
+                  , p
+                  )
+                  subs
             )
-          $ toList nodes
+            nodes
     }
   where
     mins = map (\(v, p) -> p .-^ v.dimensions / 2) nodes
     topLeft = V2 (minimum $ map (.x) mins) (minimum $ map (.y) mins)
     maxs = map (\(v, p) -> p .+^ v.dimensions / 2) nodes
     bottomRight = V2 (maximum $ map (.x) maxs) (maximum $ map (.y) maxs)
     nodes =
-      toNonEmpty $
-        symmLayout' @Double
-          ( Default.def
-              & (slHSep .~ padding)
-              & (slVSep .~ padding)
-              & (slWidth .~ \node -> (-(node.dimensions.x / 2), node.dimensions.x / 2))
-              & (slHeight .~ \node -> (-(node.dimensions.y / 2), node.dimensions.y / 2))
-          )
-          t
+      symmLayout' @Double
+        ( Default.def
+            & (slHSep .~ padding)
+            & (slVSep .~ padding)
+            & (slWidth .~ \node -> (-(node.dimensions.x / 2), node.dimensions.x / 2))
+            & (slHeight .~ \node -> (-(node.dimensions.y / 2), node.dimensions.y / 2))
+        )
+        t
     padding = 20
 
 data MeasuredView action = MeasuredView

diff --git a/primer-miso/src/Primer/Miso/Colors.hs b/primer-miso/src/Primer/Miso/Colors.hs
@@ -20,6 +20,7 @@ module Primer.Miso.Colors (
   greenPrimary,
   yellowPrimary,
   yellowSecondary,
+  yellowTertiary,
 )
 where
 
@@ -87,3 +88,6 @@ yellowPrimary = "#ffb961"
 
 yellowSecondary :: MisoString
 yellowSecondary = "#e5a34f"
+
+yellowTertiary :: MisoString
+yellowTertiary = "#fff1df"