Полоса меню снова настоящая, цвет задаётся по-своему на каждой системе

Самодельная полоса из кнопок стоила поведения: наведение на соседнее
название не перекидывало туда раскрытый список, не работал переход по
меню с Alt и стрелками. Подражать настоящему меню своими руками пришлось
бы до бесконечности, а причина отказа была одна — цвет.

Цвет решается иначе. Под gtk2 своими руками меню не рисуется, и это
записано в самом LCL: OwnerDraw, OnDrawItem и OnMeasureItem там помечены
как неподдерживаемые (interfaces/gtk2/issues.xml), вызывает DoDrawItem
только win32. Зато gtk принимает описание стиля текстом —
gtk_rc_parse_string, разбирается один раз до создания окон. Под win32
наоборот: строк стиля нет, зато отрисовка пунктов работает, в том числе
для названий в самой полосе.

Проверено отдельным пробником (probe/menu): настоящее TMainMenu под gtk2
берёт наши цвета и в полосе, и в раскрытом списке, включая цвет
выделенного пункта.

Отрисовка пунктов теперь отличает полосу от раскрытого списка: в полосе
не нужно место под галочку и сочетание клавиш, иначе название разошлось
бы с шириной, которую мы же и посчитали.

Остаток полосы правее последнего названия под Windows по-прежнему рисует
система — это уступка, а не решение.

.gitignore

@@ -42,3 +42,8 @@ shot*.png
 
 # Журнал последнего запуска
 /nlve.log
+
+# Сборка пробников. Сами исходники нужны: они и есть запись замера.
+/probe/*/units/
+/probe/menu/menuprobe
+/probe/menu/menuprobe.exe

nlve.lpr

@@ -18,6 +18,9 @@ begin
   Application.Title := 'nlve';
   Application.Scaled := True;
   Application.Initialize;
+  { Цвета меню задаются до создания окон: под gtk2 это строка стиля, а её
+    разбирают один раз — уже созданные виджеты о ней не узнают. }
+  ApplyMenuStyle;
   { Подписка на появление окон: своим окнам цвета задаются в их же
     обработчике создания, а это подстраховка на случай окна, созданного
     самой библиотекой. }

src/uMainForm.lfm

@@ -13,15 +13,6 @@ object MainForm: TMainForm
   OnKeyDown = FormKeyDown
   OnShow = FormShow
   LCLVersion = '4.6'
-  object pnlMenu: TPanel
-    Left = 0
-    Height = 26
-    Top = 0
-    Width = 1600
-    Align = alTop
-    BevelOuter = bvNone
-    TabOrder = 4
-  end
   object memoLog: TLogView
     Left = 0
     Height = 130

src/uMainForm.pas

@@ -47,7 +47,6 @@ type
     OpenMediaDialog: TOpenDialog;
     OpenProjectDialog: TOpenDialog;
     pnlBottom: TPanel;
-    pnlMenu: TPanel;
     pnlLeft: TPanel;
     pnlMain: TPanel;
     pnlTimelineHost: TPanel;
@@ -87,10 +86,7 @@ type
     FLogFilePath: string;
     FLogFileStarted: Boolean;
     FLogFileBroken: Boolean;
-    { Списки полосы меню. Хранятся, чтобы искать по ним сочетания клавиш:
+    FMenu: TMainMenu;
-      системной полосы меню нет, и форма сама их не найдёт. }
-    FMenus: TFPList;
-    FMenuX: Integer;
     { Отложенный показ списка меню. Номер списка и точка, где его
       раскрыть; таймер срабатывает один раз. }
     { Показ фоновой работы. Пока что-то считается в стороне от окна,
@@ -98,9 +94,6 @@ type
     FJobLabel: TLabel;
     FJobBar: TThemedProgress;
     FJobTimer: TTimer;
-    FMenuPending: Integer;
-    FMenuPendingAt: TPoint;
-    FMenuTimer: TTimer;
     { Уплощённый монтаж, отданный плееру. Хранится, чтобы по времени
       находить звучащий кусок и брать у него громкость. }
     FPreviewSegments: TFlatSegmentArray;
@@ -188,11 +181,8 @@ type
 
     { --- окно и меню --- }
     procedure BuildMenu;
-    procedure MenuBarClick(Sender: TObject);
-    procedure MenuTimerTick(Sender: TObject);
     procedure BuildJobIndicator;
     procedure JobTimerTick(Sender: TObject);
-    procedure FormShortCut(var Msg: TLMKey; var Handled: Boolean);
     procedure BuildTimeline;
     procedure StartPlayer;
     procedure Log(const AText: string);
@@ -403,7 +393,6 @@ begin
   FreeAndNil(FProject);
   { Сами списки принадлежат форме и уничтожатся с ней; здесь только
     перечень ссылок на них. }
-  FreeAndNil(FMenus);
 end;
 
 procedure TMainForm.ApplySettings;
@@ -481,39 +470,26 @@ end;
 { Меню строится кодом: в файле формы оно заняло бы сотню строк описания
   вложенных пунктов, где легко ошибиться и трудно что-то найти.
 
-  Полоса меню тоже своя, из обычных кнопок, а не системная. Причина одна:
+  Полоса меню — настоящая, TMainMenu.
-  системную полосу рисует Windows, и её светлый фон нашим цветом не
-  закрашивается — SetMenuInfo меняет подложку пунктов, но не саму полосу.
-  Сочетания клавиш от этого не теряются: их ищет TMenu.IsShortCut, и
-  вызвать его можно самим, что и делает FormShortCut.
 
-  Ценой отказа от системной полосы становится переход по меню клавишей
+  Некоторое время она была своя, из обычных кнопок: под Windows системную
-  Alt — его больше нет. Сочетания клавиш работают все. }
+  полосу нашим цветом не закрасить, SetMenuInfo меняет подложку пунктов, но
+  не саму полосу. Цена оказалась велика, и вся она в поведении: наведение
+  на соседнее название не перекидывало на него раскрытый список, не
+  работал переход по меню с Alt и стрелками. Подражать настоящему меню
+  своими руками пришлось бы до бесконечности.
+
+  Цвет решается иначе, на каждой системе своим способом: под gtk2 строкой
+  стиля (ApplyMenuStyle), под win32 отрисовкой пунктов своими руками
+  (ApplyDarkMenu). Остаток полосы правее последнего названия под Windows
+  по-прежнему рисует система — это известная и принятая уступка. }
 procedure TMainForm.BuildMenu;
 
   function AddTop(const ACaption: string): TMenuItem;
-  var
-    Popup: TPopupMenu;
-    Btn: TThemedButton;
-    W: Integer;
   begin
-    Popup := TPopupMenu.Create(Self);
+    Result := TMenuItem.Create(Self);
-    FMenus.Add(Popup);
+    Result.Caption := ACaption;
-
+    FMenu.Items.Add(Result);
-    Btn := TThemedButton.Create(Self);
-    Btn.Parent := pnlMenu;
-    W := pnlMenu.Canvas.TextWidth(ACaption) + 24;
-    Btn.SetBounds(FMenuX, 0, W, pnlMenu.ClientHeight);
-    Btn.Caption := ACaption;
-    { Фокус кнопкам меню не нужен: по ним щёлкают, а обходить их клавишей
-      Tab при работе с монтажом только мешает. }
-    Btn.TabStop := False;
-    Btn.Flat := True;
-    Btn.Tag := FMenus.Count - 1;
-    Btn.OnClick := @MenuBarClick;
-    Inc(FMenuX, W);
-
-    Result := Popup.Items;
   end;
 
   procedure AddItem(AParent: TMenuItem; const ACaption: string;
@@ -541,14 +517,7 @@ var
   MFile, MEdit, MView, MProject: TMenuItem;
 begin
   BuildJobIndicator;
-  FMenus := TFPList.Create;
+  FMenu := TMainMenu.Create(Self);
-  FMenuX := 4;
-  FMenuPending := -1;
-  FMenuTimer := TTimer.Create(Self);
-  FMenuTimer.Enabled := False;
-  FMenuTimer.Interval := 1;
-  FMenuTimer.OnTimer := @MenuTimerTick;
-  OnShortCut := @FormShortCut;
 
   MFile := AddTop('Файл');
   AddItem(MFile, 'Новый проект', @MenuNewProject, ShortCut(VK_N, [ssCtrl]));
@@ -602,6 +571,11 @@ begin
   AddSep(MProject);
   AddItem(MProject, 'Добавить дорожку', @MenuAddTrack);
   AddItem(MProject, 'Удалить последнюю дорожку', @MenuRemoveTrack);
+
+  { Цвета назначаются до того, как меню отдано окну: под win32 обработчики
+    отрисовки должны быть на месте к первому показу. }
+  ApplyDarkMenu(FMenu);
+  Menu := FMenu;
 end;
 
 { Показ фоновой работы.
@@ -698,59 +672,6 @@ begin
   end;
 end;
 
-{ Щелчок по названию в полосе меню раскрывает соответствующий список.
-
-  Сам показ откладывается на один оборот очереди сообщений.
-
-  Причина замерена. Пока идёт обработка щелчка, указатель захвачен
-  кнопкой, и раскрытому списку захват уже не достаётся. Внешне это
-  выглядело так, что меню открывается через раз: первый щелчок 175 мс,
-  второй не открывает вовсе, третий снова 175 мс. Попытка открывать по
-  нажатию, как это делают настоящие полосы меню, под gtk2 не открывает
-  список ни разу — захват там держится ещё крепче.
-
-  Таймер отпускает обработчик, захват снимается, и список открывается
-  каждый раз. }
-procedure TMainForm.MenuBarClick(Sender: TObject);
-var
-  Btn: TThemedButton;
-begin
-  Btn := Sender as TThemedButton;
-  if (Btn.Tag < 0) or (Btn.Tag >= FMenus.Count) then
-    Exit;
-  FMenuPending := Btn.Tag;
-  FMenuPendingAt := Btn.ClientToScreen(Point(0, Btn.Height));
-  FMenuTimer.Enabled := False;
-  FMenuTimer.Enabled := True;
-end;
-
-procedure TMainForm.MenuTimerTick(Sender: TObject);
-var
-  Popup: TPopupMenu;
-begin
-  FMenuTimer.Enabled := False;
-  if (FMenuPending < 0) or (FMenuPending >= FMenus.Count) then
-    Exit;
-  Popup := TPopupMenu(FMenus[FMenuPending]);
-  FMenuPending := -1;
-  ApplyDarkMenu(Popup);
-  Popup.PopUp(FMenuPendingAt.X, FMenuPendingAt.Y);
-end;
-
-{ Сочетания клавиш ищем сами: системной полосы меню больше нет, а значит
-  форма их сама не найдёт. }
-procedure TMainForm.FormShortCut(var Msg: TLMKey; var Handled: Boolean);
-var
-  I: Integer;
-begin
-  for I := 0 to FMenus.Count - 1 do
-    if TPopupMenu(FMenus[I]).IsShortCut(Msg) then
-    begin
-      Handled := True;
-      Exit;
-    end;
-end;
-
 procedure TMainForm.FormShow(Sender: TObject);
 var
   I: Integer;

src/uTheme.pas

@@ -18,8 +18,10 @@
     - полосы прокрутки внутри списков и журнала рисует система;
     - рамка окна и её кнопки принадлежат оконному менеджеру;
     - меню под gtk2 своими руками не рисуется — в LCL это прямо помечено
-      как неподдерживаемое (interfaces/gtk2/issues.xml). Под Windows
+      как неподдерживаемое (interfaces/gtk2/issues.xml). Зато сам gtk
-      рисуется, там это и нужно.
+      принимает описание стиля текстом, и цвет меню задаётся так
+      (ApplyMenuStyle). Под Windows наоборот: строк стиля нет, зато
+      работает отрисовка пунктов своими руками (ApplyDarkMenu).
 }
 unit uTheme;
 
@@ -151,9 +153,25 @@ procedure ApplyDarkTheme(AComponent: TComponent);
   при запуске. }
 procedure HookNewForms;
 
-{ Меню в наших цветах. Под gtk2 не действует — там меню рисует GTK. }
+{ Меню в наших цветах отрисовкой своими руками. Действует только под
+  win32; под gtk2 цвет задаётся строкой стиля, см. ApplyMenuStyle. }
 procedure ApplyDarkMenu(AMenu: TMenu);
 
+{ Цвета для меню, которое рисует не программа, а система.
+
+  Вызывать до создания окон: строка стиля разбирается один раз, и уже
+  созданные виджеты о ней не узнают.
+
+  Под gtk2 это единственный способ. Собственных средств у LCL там нет —
+  OwnerDraw, OnDrawItem и OnMeasureItem в gtk2 прямо помечены как
+  неподдерживаемые (lcl/interfaces/gtk2/issues.xml), и событие из
+  инспектора объектов просто никогда не наступит. Зато сам gtk принимает
+  описание стиля текстом.
+
+  Под win32 ничего не делает: там работает отрисовка своими руками через
+  ApplyDarkMenu. }
+procedure ApplyMenuStyle;
+
 { Окно сообщения в наших цветах вместо системного.
 
   Кнопки задаются готовым набором, как у MessageDlg, но рисуются нашими.
@@ -164,6 +182,11 @@ function ThemedMessageDlg(const ACaption, AText: string;
 
 implementation
 
+{$IFDEF LCLGTK2}
+uses
+  glib2, gtk2;
+{$ENDIF}
+
 {$IFDEF WINDOWS}
 { Модуль Windows целиком подключать нельзя: он объявляет свои TRect и
   RegisterClass, а имена в Паскале нечувствительны к регистру — и обычные
@@ -213,6 +236,7 @@ const
   MenuTextLeft = 26;    { отступ слева: место под галочку }
   MenuTextRight = 16;   { отступ справа: место под стрелку подменю }
   MenuGap = 28;         { просвет между названием и сочетанием клавиш }
+  MenuBarSide = 10;     { отступ по краям названия в полосе меню }
 
 { TThemedProgress }
 
@@ -567,6 +591,15 @@ begin
   H := ACanvas.TextHeight('Wg');
   Y := ARect.Top + (ARect.Bottom - ARect.Top - H) div 2;
 
+  { В полосе меню отступ слева другой: место под галочку и под сочетание
+    клавиш там не нужно, а с отступом раскрытого списка названия разошлись
+    бы с шириной, которую мы же и посчитали. }
+  if Item.IsInMenuBar then
+  begin
+    ACanvas.TextOut(ARect.Left + MenuBarSide, Y, Item.Caption);
+    Exit;
+  end;
+
   if Item.Checked then
     ACanvas.TextOut(ARect.Left + 8, Y, '•');
 
@@ -599,6 +632,13 @@ begin
   end;
 
   AHeight := ACanvas.TextHeight('Wg') + 10;
+
+  if Item.IsInMenuBar then
+  begin
+    AWidth := ACanvas.TextWidth(Item.Caption) + MenuBarSide * 2;
+    Exit;
+  end;
+
   W := MenuTextLeft + ACanvas.TextWidth(Item.Caption) + MenuTextRight;
   if Item.ShortCut <> 0 then
     Inc(W, MenuGap + ACanvas.TextWidth(ShortCutToText(Item.ShortCut)));
@@ -772,6 +812,43 @@ begin
     ApplyToChildren(TWinControl(AControl));
 end;
 
+{ Цвет Паскаля хранит составляющие в обратном порядке, а gtk ждёт
+  привычную запись «решётка, красный, зелёный, синий». }
+function GtkColorText(AColor: TColor): string;
+begin
+  Result := Format('#%.2x%.2x%.2x',
+    [AColor and $FF, (AColor shr 8) and $FF, (AColor shr 16) and $FF]);
+end;
+
+procedure ApplyMenuStyle;
+{$IFDEF LCLGTK2}
+var
+  Rc: string;
+{$ENDIF}
+begin
+{$IFDEF LCLGTK2}
+  Rc :=
+    'style "nlve-menu" {' + LineEnding +
+    '  bg[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding +
+    '  bg[PRELIGHT] = "' + GtkColorText(ThemeAccent) + '"' + LineEnding +
+    '  bg[ACTIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding +
+    '  bg[INSENSITIVE] = "' + GtkColorText(ThemePanel) + '"' + LineEnding +
+    '  fg[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding +
+    '  fg[PRELIGHT] = "' + GtkColorText(ThemeAccentText) + '"' + LineEnding +
+    '  fg[ACTIVE] = "' + GtkColorText(ThemeText) + '"' + LineEnding +
+    '  fg[INSENSITIVE] = "' + GtkColorText(ThemeTextDim) + '"' + LineEnding +
+    '  text[NORMAL] = "' + GtkColorText(ThemeText) + '"' + LineEnding +
+    '  base[NORMAL] = "' + GtkColorText(ThemePanel) + '"' + LineEnding +
+    '}' + LineEnding +
+    'class "GtkMenuBar" style "nlve-menu"' + LineEnding +
+    'class "GtkMenu" style "nlve-menu"' + LineEnding +
+    'class "GtkMenuItem" style "nlve-menu"' + LineEnding +
+    'widget_class "*<GtkMenuBar>*" style "nlve-menu"' + LineEnding +
+    'widget_class "*<GtkMenuItem>*" style "nlve-menu"' + LineEnding;
+  gtk_rc_parse_string(PChar(Rc));
+{$ENDIF}
+end;
+
 procedure ApplyDarkMenu(AMenu: TMenu);
 
   procedure Walk(AItem: TMenuItem);