Monomer という Haskell のハイレベル GUI ライブラリ

Windows で動作する GUI アプリケーションを作りたくて、でも Windows では開発したくないのでクロスプラットフォームな GUI ライブラリを模索し、Monomer にたどり着きました。

結果、このライブラリでは要件を満たしていないため使わないことにしましたが、備忘録です。

Monomer とは

内部的に SDL2 を利用していて、その低レベルっぷりを隠蔽し、Elm アーキテクチャに昇華させている良いライブラリだと思いました。

以下のコードで以下のようなアプリが起動できます。

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Main where

import Debug.Trace

import Control.Lens
import Data.Maybe
import Data.Text (Text)
import Monomer
import TextShow

import Monomer.Event.Util
import qualified Monomer.Lens as L

newtype AppModel =
  AppModel
    { _command :: Text
    }
  deriving (Eq, Show)

data AppEvent
  = AppInit
  | GotFocus Path
  | LostFocus Path
  deriving (Eq, Show)

makeLenses 'AppModel

buildUI ::
     WidgetEnv AppModel AppEvent -> AppModel -> WidgetNode AppModel AppEvent
buildUI wenv model = widgetTree
  where
    widgetTree =
      vstack
        [ textField_ command [onFocus GotFocus, onBlur LostFocus] `nodeKey`
          "textField"
        ] `styleBasic`
      [padding 10]

handleEvent ::
     WidgetEnv AppModel AppEvent
  -> WidgetNode AppModel AppEvent
  -> AppModel
  -> AppEvent
  -> [AppEventResponse AppModel AppEvent]
handleEvent wenv node model evt =
  case evt of
    AppInit -> []
    GotFocus _ -> trace "GotFocus" [Model $ model & command .~ "Focused!"] -- ここに追加
    LostFocus _ -> trace "LostFocus" [Model $ model & command .~ "Blurred!"] -- ここに追加

main :: IO ()
main = do
  startApp model handleEvent buildUI config
  where
    config =
      [ appTheme darkTheme
      , appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf"
      , appWindowBorder False
      , appWindowResizable False
      , appInitEvent AppInit
      ]
    model = AppModel ""

Elm アーキテクチャを採用しているため、AppModel というモデルと AppEvent というイベントを定義し、buildUI で GUI を定義、handleEvent でイベントを処理するという感じです。

やりたかったこと

このアプリでやりたいことがいくつかあります。

アプリのウィンドウボーダーをなくす

アプリのコンフィグに appWindowBorder False を指定することでなくせます。未指定だと以下のようになります。

フォーカスロストイベントのハンドリング

ウィンドウボーダーをなくしたことで、アプリを終了させることができません。なのでアプリがバックグラウンドに行ったら終了させます。このためにはそれなりのイベントを取得しなければなりません。

テキストフィールドのイベントとして GotFocus と LostFocus を定義します（GotFocus は検証用）。

data AppEvent
  = AppInit
  | GotFocus Path
  | LostFocus Path
  deriving (Eq, Show)

テキストフィールドにイベントハンドラを定義します。

        [ textField_ command [onFocus GotFocus, onBlur LostFocus] `nodeKey`
          "textField"
        ] `styleBasic`

handleEvent でこれらのイベントを処理するコードを記載します。

handleEvent wenv node model evt =
  case evt of
    AppInit -> []
    GotFocus _ -> trace "GotFocus" [Model $ model & command .~ "Focused!"] -- ここに追加
    LostFocus _ -> trace "LostFocus" [Model $ model & command .~ "Blurred!"] -- ここに追加

これでうまくいくはずだったんですが、アプリをバックグラウンドにしてもイベントが発生しません。このイベントはどうやら同じアプリ内でフォーカスが移動しないと発生しないようで、このやり方ではできませんでした。

どうやらこのイベント処理は Monomer 本体にパッチを当てないと実現できません。

diff --git a/src/Monomer/Main/Core.hs b/src/Monomer/Main/Core.hs
index 7e2b46dd..fcec634f 100644
--- a/src/Monomer/Main/Core.hs
+++ b/src/Monomer/Main/Core.hs
@@ -56,6 +56,7 @@ import Monomer.Helper (catchAny, putStrLnErr, isGhciRunning)
 import Monomer.Widgets.Composite
 
 import qualified Monomer.Lens as L
+import Control.Monad (forM_)
 
 {-|
 Type of response an App event handler can return, with __s__ being the model and
@@ -333,6 +334,15 @@ mainLoop window fontManager config loopArgs = do
   let invertY = fromMaybe False (_apcInvertWheelY config)
   let convertCfg = ConvertEventsCfg _mlOS dpr epr invertX invertY
   let baseSystemEvents = convertEvents convertCfg mousePos eventsPayload
+  let keyboardFocusEventHandlers = _apcKeyboardFocusEvent config
+
+  let windowKeyboardFocusGained = isWindowKeyboardFocusGained eventsPayload
+  when windowKeyboardFocusGained $
+    forM_ keyboardFocusEventHandlers $ \handler -> return $ handler True
+
+  let windowKeyboardFocusLost = isWindowKeyboardFocusLost eventsPayload
+  when windowKeyboardFocusLost $
+    forM_ keyboardFocusEventHandlers $ \handler -> return $ handler False
 
 --  when newSecond $
 --    liftIO . putStrLnErr $ "Frames: " ++ show _mlFrameCount
@@ -449,6 +459,20 @@ mainLoop window fontManager config loopArgs = do
     void $ handleWidgetDispose newWenv newRoot
 
   unless shouldQuit (mainLoop window fontManager config newLoopArgs)
+ where
+  isWindowKeyboardFocusGained :: [SDL.EventPayload] -> Bool
+  isWindowKeyboardFocusGained eventsPayload = any isKeyboardFocusGainedEvent eventsPayload
+
+  isKeyboardFocusGainedEvent :: SDL.EventPayload -> Bool
+  isKeyboardFocusGainedEvent SDL.WindowGainedKeyboardFocusEvent{} = True
+  isKeyboardFocusGainedEvent _ = False
+
+  isWindowKeyboardFocusLost :: [SDL.EventPayload] -> Bool
+  isWindowKeyboardFocusLost eventsPayload = any isKeyboardFocusLostEvent eventsPayload
+
+  isKeyboardFocusLostEvent :: SDL.EventPayload -> Bool
+  isKeyboardFocusLostEvent SDL.WindowLostKeyboardFocusEvent{} = True
+  isKeyboardFocusLostEvent _ = False
 
 {-
 Attempts to initialize a GL context in a separate OS thread to handle rendering
diff --git a/src/Monomer/Main/Types.hs b/src/Monomer/Main/Types.hs
index d8826889..df29b9d6 100644
--- a/src/Monomer/Main/Types.hs
+++ b/src/Monomer/Main/Types.hs
@@ -195,6 +195,8 @@ data AppConfig s e = AppConfig {
   _apcExitEvent :: [e],
   -- | Resize event handler.
   _apcResizeEvent :: [Rect -> e],
+  -- | Keyboard focus event handler.
+  _apcKeyboardFocusEvent :: [Bool -> e],
   -- | Defines which mouse button is considered main.
   _apcMainButton :: Maybe Button,
   -- | Defines which mouse button is considered secondary or context button.
@@ -229,6 +231,7 @@ instance Default (AppConfig s e) where
     _apcDisposeEvent = [],
     _apcExitEvent = [],
     _apcResizeEvent = [],
+    _apcKeyboardFocusEvent = [],
     _apcMainButton = Nothing,
     _apcContextButton = Nothing,
     _apcInvertWheelX = Nothing,
@@ -255,6 +258,7 @@ instance Semigroup (AppConfig s e) where
     _apcDisposeEvent = _apcDisposeEvent a1 ++ _apcDisposeEvent a2,
     _apcExitEvent = _apcExitEvent a1 ++ _apcExitEvent a2,
     _apcResizeEvent = _apcResizeEvent a1 ++ _apcResizeEvent a2,
+    _apcKeyboardFocusEvent = _apcKeyboardFocusEvent a1 ++ _apcKeyboardFocusEvent a2,
     _apcMainButton = _apcMainButton a2 <|> _apcMainButton a1,
     _apcContextButton = _apcContextButton a2 <|> _apcContextButton a1,
     _apcInvertWheelX = _apcInvertWheelX a2 <|> _apcInvertWheelX a1,
@@ -439,6 +443,13 @@ appResizeEvent evt = def {
   _apcResizeEvent = [evt]
 }
 
+-- | Keyboard focus event handler.
+-- True if the application has keyboard focus, False otherwise.
+appKeyboardFocusEvent :: (Bool -> e) -> AppConfig s e
+appKeyboardFocusEvent evt = def {
+  _apcKeyboardFocusEvent = [evt]
+}
+
 -- | Defines which mouse button is considered main.
 appMainButton :: Button -> AppConfig s e
 appMainButton btn = def {

Monomer の SDL2 メインループでキーボードフォーカスイベントを補足、コンフィグでキーボードフォーカスイベントのハンドラを設定する、というような感じにします。何度か試してみましたが、稀にフォーカスを失っていないのに失ったイベントが発生してしまうのが厄介です。原因はわかっていません。

スクロール

これで後はアプリを実装するだけかなと思ったのですが、Monomer の、というか SDL2 のスクロールだと思いますが非常に使い勝手が悪いです。

macOS ならスクロールに慣性がかかって欲しいのですが、引っかかるというかピタッと止まるというか、とにかく好みのスクロール挙動ではありません。Windows なら慣性スクロールとかはないと思うのですが、macOS でも使うかもしれないツールなので、ここが気に入らず Monomer を諦めました。

まとめ

Elm アーキテクチャで提供された GUI ライブラリなのでものすごく期待していて、今でも後ろ髪を引かれる思いですが、別の GUI ライブラリを探す旅に出なければなりません。ただ、GUI ライブラリの評価ポイントがわかっただけでも今回は良しとします。