Введение⌗

В данной заметке мы исследуем один из способов структурирования на Haskell графических программ (GTK3) архитектурным паттерном Model-View-Controller.

Для этих целей мы будем применять пакет mvc и Haskell-биндинги к GTK3 gi-gtk. Поскольку поток выполнения любой GTK+ программы обычно (после инициализации, настройки коллбэков, и т.д.) рано или поздно входит в бесконечный библиотечный цикл gtk_main(), нам придётся что-то придумать для одновременного применения графической подсистемы вместе с пакетом mvc.

Любой GUI является лишь частью некоторой программы, но не наоборот, поэтому мы считаем запуск и выполнение MVC более общим и первичным, а GTK+ – вторичным и потому запускаемым и выполняемым “внутри” нашей архитектуры MVC.

Идея⌗

Ниже предлагается такое решение:

Современная система GTK+ имеет не только традиционную функцию gtk_main, бесконечно обрабатывающую поступающие события оконной подсистемы, но и неблокирующиеся эквиваленты поштучной (итеративной) обработки событий: процедуры gtk_main_iteration и другие. Мы будем использовать Gtk.mainIteration для управляемого “стробирования” оконной подсистемы.
В пакете mvc имеется специальный контроллер MVC.Prelude.tick :: Double -> Managed (Controller ()), который генерирует прерывания для Модели n раз в секунду. Используем эти прерывания для обработки очередных событий GUI!
Виджеты в GTK+ обычно работают по принципу коллбэков: для каждой кнопочки, меню и т.д. и манипуляций с ними мы указываем код, который будет выполнен графической подсистемой при соответствующем действии (движении мышкой, клике, вводе, и т.д.) пользователя в будущем. Коллбэки могут выполнятся в других нитях; для обмена данными между нитями мы используем пакет stm (Software Transactional Memory).
Собственно идея такова:
1. при активации коллбэка, нить коллбэка пишет нужные из GUI данные в заранее ивзестный канал TChan
2. соответствующий Контроллер просыпается и снабжает Модель этими данными, считанными им из известного канала
3. Модель трансформирует эти данные для ввода в один или несколько Видов (View), может быть мутирует свой State
4. Виды, как и нити коллбэков, напрямую взаимодействуют с соответствующими виджетами GTK+

Тестовая программа⌗

Применим данный подход на практике и создадим следующую программу на GTK+:

Пользователь вводит в поле для ввода текст и нажимает кнопку “Копировать”
При нажатии на эту кнопку, лэйбл (Gtk.Label) принимает вид данного текста
При нажатии ещё на одну кнопку, регистр букв текста в лэйбле переключается с нижнего (lowercase) на верхний и на “заглавный” (titlecase)
При копировании текста в Пункте 2, учитываются текущие настройки регистра

Из диаграммы ниже видно, что нам понадобятся типы для (де)мультиплексирования “сигнальных линий” (как всегда с пакетом mvc), а также тип Case, который будет содержать текущую настройку регистра и выолнять функцию состояния (стэйта) Модели. О базовом применении mvc я писал ранее.

Реализация⌗

Типы⌗

Начнём с типов:

data Case = Lower | Upper | Title

nextCase :: Case -> Case
nextCase Lower = Upper
nextCase Upper = Title
nextCase Title = Lower

data ModelInput =
    InputText Text
  | InputToggleCase ()
  | InputExit ()
  | InputTick ()

data ModelOutput =
    OutputText Text
  | OutputCase Case
  | OutputExit
  | OutputTick
makePrisms ''ModelOutput

Контроллеры⌗

Наша идея о том, что соответствующие Контроллеры читают из соответствующих каналов и генерируют дынные определённого типа легко обобщается до Контроллера-шаблона ctrlFromChan для каналов с любыми данными (формально, контроллеров всё же несколько: для каждого отдельного сигнала).

ctrlFromChan :: TChan a -> Managed (Controller a)
ctrlFromChan chan = MVCP.producer unbounded $ forever $ do
  a <- lift $ atomically $ readTChan chan
  yield a

ctrlTick :: Managed (Controller ())
ctrlTick = MVCP.tick (1/1000)

Получается так, что ни один Контроллер не трогает и не знает ничего о GTK+ и работает только с асбстрактными данными.

Виды⌗

Вид viewUpdateCase берёт текущее содержание лэйбла (GTK+ хранить стэйт за нас!) и переустанавливает его в соответствии с текущими настройками регистра (Вид поглощает эти настройки из Модели). Внутри viewTick мы стробируем GTK+, т.е. просим обработать очередное событие или заблокироваться до прихода новых (новых срабатываний Контроллера тиков всё равно не возникнет, пока не отработает Gtk.mainIteration и текущая инкарнация этого Контроллера не выйдет). Все хэндлы виджетов GTK заранее известны на стадии инициализации, когда мы объединяем Контроллеры и Виды с помощью Managed (см. ниже).

viewUpdateCase :: Gtk.Label -> View Case
viewUpdateCase l = asSink $ \c -> do
  let endo = case c of
        Lower -> toLower
        Upper -> toUpper
        Title -> toTitle
  t <- get l #label
  set l [#label := endo t]

viewUpdateText :: Gtk.Label -> View Text
viewUpdateText l = asSink $ \t ->
  set l [#label := t]

viewQuit :: Gtk.Window -> View ()
viewQuit w = asSink $ const $ do
  putStrLn "Exiting ..."
  #destroy w
  Gtk.mainQuit
  exitSuccess

viewTick :: View ()
viewTick = asSink $ const $ void Gtk.mainIteration

Модель⌗

Модель “чиста” и представляет собой простую трансформацию. При сигнале InputText t мы запросто генерируем (вызываем) два Вида подряд: устанавливаем текст лэйбла, форматируем текст лэйбла согласно текущим настройкам регистра (т.е. стэйта Модели).

model :: Model Case ModelInput ModelOutput
model = asPipe $ forever $ do
  i <- await
  case i of
    InputTick () -> yield OutputTick
    InputExit () -> yield OutputExit
    InputText t -> do
      yield $ OutputText t
      State.get >>= yield . OutputCase
    InputToggleCase () -> do
      State.modify nextCase
      State.get >>= yield . OutputCase

Если внутри Модели нам вдруг потребуется поддерживать динамическую кучу хэндлов виджетов, то, похоже, придётся уходить от монады Identity и делать всю Модель на основе MonadIO, так как “грязный” GTK+-код Контроллеров и/или Видов не сможет адекватно синхронизироваться с хэндлами в стэйте Модели: новые хэндлы виджетов получаются только при “грязных вычислениях”.

Это не проблема, поскольку тип Model внутри mvc определён так:

type Model = ModelM Identity

Инициализация Контроллеров и Видов⌗

В функции под названием external мы с нуля инициализируем GTK+, загружаем .glade файл с описанием UI и получаем хэндлы наших виджетов. Далее мы создаём STM-каналы и используем их и хэндлы виджетов (в коллбэке клика кнопки нужен хэндл другого виджета, textEntry, чтобы считывать текст из поля для ввода) для установки коллбэков на события в этих виджетах. В конце мы используем каналы и хэндлы для создания “пучка” Видов и Контроллеров.

external :: Managed (View ModelOutput, Controller ModelInput)
external = do
  liftIO $ Gtk.init Nothing

  gui <- liftIO Gtk.builderNew
  Gtk.builderAddFromFile gui "main.ui"

  mainWindow <- liftIO $ Gtk.builderGetObject gui "window1"
                >>= unsafeCastTo Gtk.Window . fromJust
  textEntry <- liftIO $ Gtk.builderGetObject gui "entry1"
                >>= unsafeCastTo Gtk.Entry . fromJust
  textButton <- liftIO $ Gtk.builderGetObject gui "button1"
                >>= unsafeCastTo Gtk.Button . fromJust
  caseButton <- liftIO $ Gtk.builderGetObject gui "button2"
                >>= unsafeCastTo Gtk.Button . fromJust
  textLabel  <- liftIO $ Gtk.builderGetObject gui "label1"
                >>= unsafeCastTo Gtk.Label . fromJust

  quitChan <- liftIO $ atomically newTChan
  textChan <- liftIO $ atomically newTChan
  tcaseChan <- liftIO $ atomically newTChan

  on mainWindow #destroy (callbackWriteChan quitChan ())
  on caseButton #clicked (callbackWriteChan tcaseChan ())
  on textButton #clicked (callbackTextButton textChan textEntry)

  #showAll mainWindow

  let cs = fmap (fmap InputExit) (ctrlFromChan quitChan)
        <> fmap (fmap InputToggleCase) (ctrlFromChan tcaseChan)
        <> fmap (fmap InputText) (ctrlFromChan textChan)
        <> fmap (fmap InputTick) ctrlTick

  let vs = handles _OutputExit (viewQuit mainWindow)
        <> handles _OutputCase (viewUpdateCase textLabel)
        <> handles _OutputText (viewUpdateText textLabel)
        <> handles _OutputTick viewTick

  liftA2 (,) (return vs) cs

Коллбэки GTK+⌗

Имеется коллбэк-шаблон, который просто пишет известные данные в известный канал при срабатывании. Коллбэк посложнее установлен на клик кнопки “Копировать”, т.к. для пробуждения им соответствующего Контроллера требуется пользовательский текст, который мы и считываем из соседнего виджета.

callbackWriteChan :: TChan a -> a -> IO ()
callbackWriteChan chan a = atomically $ writeTChan chan a

callbackTextButton :: TChan Text -> Gtk.Entry -> IO ()
callbackTextButton chan e = do
  t <- get e #text
  atomically $ writeTChan chan t

Точка входа в программу⌗

А вот main нашей Haskell-программы:

main :: IO ()
main =
  void $ runMVC Lower model external

Haskell: Применение паттерна MVC для программ с GTK+