Merge pull request #497 from WolframResearch/bugfix/model-menu-clipping

Bugfix: Add scrollbars to submenus when large to avoid content clipping
WolframResearch · Dec 15, 2023 · b4e3991 · b4e3991
2 parents e1a87d3 + 6979069
commit b4e3991
Show file tree

Hide file tree

Showing 2 changed files with 86 additions and 35 deletions.
diff --git a/Source/Chatbook/Menus.wl b/Source/Chatbook/Menus.wl
@@ -36,6 +36,11 @@ Needs[ "Wolfram`Chatbook`Common`"     ];
 Needs[ "Wolfram`Chatbook`ErrorUtils`" ];
 Needs[ "Wolfram`Chatbook`FrontEnd`"   ];
 
+(* ::**************************************************************************************************************:: *)
+(* ::Section::Closed:: *)
+(*Configuration*)
+$submenuItems = False;
+
 (* ::**************************************************************************************************************:: *)
 (* ::Section::Closed:: *)
 (*MakeMenu*)
@@ -53,20 +58,26 @@ MakeMenu[ items_List, Automatic, width_ ] :=
 MakeMenu[ items_List, frameColor_, Automatic ] :=
     MakeMenu[ items, frameColor, 200 ];
 
+MakeMenu[ items_List, frameColor_, width_ ] /;
+    ! $submenuItems && MemberQ[ items, KeyValuePattern[ "Type" -> "Submenu" ] ] :=
+        Block[ { $submenuItems = True }, MakeMenu[ items, frameColor, width ] ];
+
 MakeMenu[ items_List, frameColor_, width_ ] :=
-    Pane[
-        RawBoxes @ TemplateBox[
-            {
-                ToBoxes @ Column[ menuItem /@ items, ItemSize -> Automatic, Spacings -> 0, Alignment -> Left ],
-                Background     -> GrayLevel[ 0.98 ],
-                FrameMargins   -> 3,
-                FrameStyle     -> Directive[ AbsoluteThickness[ 1 ], frameColor ],
-                ImageMargins   -> 0,
-                RoundingRadius -> 3
-            },
-            "Highlighted"
-        ],
-        ImageSize -> { width, Automatic }
+    RawBoxes @ TemplateBox[
+        {
+            ToBoxes @ Pane[
+                Column[ menuItem /@ items, ItemSize -> Automatic, Spacings -> 0, Alignment -> Left ],
+                AppearanceElements -> None,
+                ImageSize          -> { width, UpTo[ 450 ] },
+                Scrollbars         -> { False, Automatic }
+            ],
+            Background     -> GrayLevel[ 0.98 ],
+            FrameMargins   -> 3,
+            FrameStyle     -> Directive[ AbsoluteThickness[ 1 ], frameColor ],
+            ImageMargins   -> 0,
+            RoundingRadius -> 3
+        },
+        "Highlighted"
     ];
 
 MakeMenu // endDefinition;
@@ -81,27 +92,30 @@ menuItem[ spec: KeyValuePattern[ "Data" -> content_ ] ] :=
 
 menuItem[ spec: KeyValuePattern @ { "Type" -> "Submenu", "Data" :> content_ } ] :=
     EventHandler[
-        menuItem[
-            Lookup[ spec, "Icon", Spacer[ 0 ] ],
-            submenuLabel @ Lookup[ spec, "Label", "" ],
-            None
+        Block[ { $submenuItems = False },
+            menuItem[
+                Lookup[ spec, "Icon", Spacer[ 0 ] ],
+                submenuLabel @ Lookup[ spec, "Label", "" ],
+                None
+            ]
         ],
         {
-            "MouseEntered" :> With[ { root = EvaluationBox[ ] }, AttachSubmenu[ root, content ] ]
+            "MouseEntered" :> With[ { root = EvaluationBox[ ] }, AttachSubmenu[ root, content ] ],
+            "MouseDown"    :> With[ { root = EvaluationBox[ ] }, AttachSubmenu[ root, content ] ]
         }
     ];
 
 menuItem[ { args__ } ] :=
     menuItem @ args;
 
 menuItem[ Delimiter ] :=
-    RawBoxes @ TemplateBox[ { }, "ChatMenuItemDelimiter" ];
+    addSubmenuHandler @ RawBoxes @ TemplateBox[ { }, "ChatMenuItemDelimiter" ];
 
 menuItem[ label_ :> action_ ] :=
     menuItem[ Graphics[ { }, ImageSize -> 0 ], label, Hold @ action ];
 
 menuItem[ section_ ] :=
-    RawBoxes @ TemplateBox[ { ToBoxes @ section }, "ChatMenuSection" ];
+    addSubmenuHandler @ RawBoxes @ TemplateBox[ { ToBoxes @ section }, "ChatMenuSection" ];
 
 menuItem[ name_String, label_, code_ ] :=
     With[ { icon = chatbookIcon @ name },
@@ -125,16 +139,36 @@ menuItem[ icon_, label_, action_String ] :=
     ];
 
 menuItem[ None, content_, None ] :=
-    content;
+    addSubmenuHandler @ content;
 
 menuItem[ icon_, label_, None ] :=
     menuItem[ icon, label, Hold @ Null ];
 
 menuItem[ icon_, label_, code_ ] :=
-    RawBoxes @ TemplateBox[ { ToBoxes @ icon, ToBoxes @ label, code }, "ChatMenuItem" ];
+    addSubmenuHandler @ RawBoxes @ TemplateBox[ { ToBoxes @ icon, ToBoxes @ label, code }, "ChatMenuItem" ];
 
 menuItem // endDefinition;
 
+(* ::**************************************************************************************************************:: *)
+(* ::Subsubsection::Closed:: *)
+(*addSubmenuHandler*)
+addSubmenuHandler // beginDefinition;
+
+addSubmenuHandler[ expr_ ] /; $submenuItems := EventHandler[
+    expr,
+    {
+        "MouseEntered" :> NotebookDelete @ Cells[
+            EvaluationCell[ ],
+            AttachedCell -> True,
+            CellStyle    -> "AttachedChatMenu"
+        ]
+    }
+];
+
+addSubmenuHandler[ expr_ ] := expr;
+
+addSubmenuHandler // endDefinition;
+
 (* ::**************************************************************************************************************:: *)
 (* ::Subsection::Closed:: *)
 (*submenuLabel*)
@@ -216,17 +250,34 @@ menuMagnification // endDefinition;
 (*determineAttachmentPosition*)
 determineAttachmentPosition // beginDefinition;
 
-determineAttachmentPosition[ info_Association ] :=
-    Lookup[ info, "Position", determineAttachmentPosition @ MousePosition[ "WindowScaled" ] ];
+determineAttachmentPosition[ KeyValuePattern[ "Position" -> { { pH_, pV_ }, { oH_, oV_ } } ] ] :=
+    { { pH, pV }, { oH, chooseVerticalOffset @ MousePosition[ "WindowScaled" ] } };
+
+determineAttachmentPosition[ _Association ] :=
+    determineAttachmentPosition @ MousePosition[ "WindowScaled" ];
 
 determineAttachmentPosition[ pos_List ] :=
     determineAttachmentPosition[ pos, quadrant @ pos ];
 
-determineAttachmentPosition[ _, { h_, v_ } ] :=
-    { { Replace[ h, { Left -> Right, Right -> Left } ], v }, { h, Center } };
+determineAttachmentPosition[ { x_, y_ }, { h_, v_ } ] := {
+    { Replace[ h, { Left -> Right, Right -> Left } ], v },
+    { h, chooseVerticalOffset @ { x, y } }
+};
+
+determineAttachmentPosition[ None ] :=
+    { { Right, Top }, { Left, Top } };
 
 determineAttachmentPosition // endDefinition;
 
+(* ::**************************************************************************************************************:: *)
+(* ::Subsubsection::Closed:: *)
+(*chooseVerticalOffset*)
+chooseVerticalOffset // beginDefinition;
+chooseVerticalOffset[ { x_, y_ } ] /; y < 0.33 := Top;
+chooseVerticalOffset[ { x_, y_ } ] /; y > 0.67 := Bottom;
+chooseVerticalOffset[ { x_, y_ } ] := Center;
+chooseVerticalOffset // endDefinition;
+
 (* ::**************************************************************************************************************:: *)
 (* ::Subsubsection::Closed:: *)
 (*quadrant*)

diff --git a/Source/Chatbook/UI.wl b/Source/Chatbook/UI.wl
@@ -444,20 +444,20 @@ MakeChatInputActiveCellDingbat[cell_CellObject] := Module[{
 			ImageMargins -> 0,
 			ContentPadding -> False
 		],
-		(
+		With[ { pos = Replace[ MousePosition[ "WindowScaled" ], { { _, y_ } :> y, _ :> 0 } ] },
 			attachMenuCell[
 				EvaluationCell[],
 				makeChatActionMenu[
 					"Input",
 					parentCell[EvaluationCell[]],
 					EvaluationCell[]
 				],
-				{Left, Bottom},
+				{Left, If[ pos < 0.5, Bottom, Top ]},
 				Offset[{0, 0}, {Left, Top}],
-				{Left, Top},
+				{Left, If[ pos < 0.5, Top, Bottom ]},
 				RemovalConditions -> {"EvaluatorQuit", "MouseClickOutside"}
-			];
-		),
+			]
+        ],
 		Appearance -> $suppressButtonAppearance,
 		ImageMargins -> 0,
 		FrameMargins -> 0,
@@ -536,20 +536,20 @@ MakeChatDelimiterCellDingbat[cell_CellObject] := Module[{
 			ImageMargins -> 0,
 			ContentPadding -> False
 		],
-		(
+		With[ { pos = Replace[ MousePosition[ "WindowScaled" ], { { _, y_ } :> y, _ :> 0 } ] },
 			attachMenuCell[
 				EvaluationCell[],
 				makeChatActionMenu[
 					"Delimiter",
 					parentCell[EvaluationCell[]],
 					EvaluationCell[]
 				],
-				{Left, Bottom},
+				{Left, If[ pos < 0.5, Bottom, Top ]},
 				Offset[{0, 0}, {Left, Top}],
-				{Left, Top},
+				{Left, If[ pos < 0.5, Top, Bottom ]},
 				RemovalConditions -> {"EvaluatorQuit", "MouseClickOutside"}
 			];
-		),
+		],
 		Appearance -> $suppressButtonAppearance,
 		ImageMargins -> 0,
 		FrameMargins -> 0,