LoginSignup
7
2

More than 5 years have passed since last update.

@aiya000(あいや)

Haskell (Eta) でJavaFXのEDSLを作る雰囲気を醸し出す

Last updated at Posted at 2017-12-24

　この記事はプロ生ちゃん Advent Calendar 2017 - Adventar
の :santa: 25日目 :santa: の記事です！ :tada:

:calendar: 皆さん、アドベントカレンダーお疲れ様でした！ :calendar:

諸注意

　この事はおおよそ冗談で構成されており、
主に以下の主張を雰囲気で感じて貰うことを目的にしています。

  • Haskellでは、こんなにも簡単にEDSLを作れる
  • EtaとJavaFXを使って、HaskellでもマルチOS対応のGUIプログラミングができる

何を言っているのかわからなくとも、Haskellを知らなくとも、
気にせずに雰囲気で読んで、楽しんでください :sunglasses:

そう、雰囲気が大事なんですよ :kissing:

導入

　Etaという、JVMで動くHaskellが登場しました。

JVMで動くということはもちろんJavaFXを使えるということなので、
Haskellの1つの懸念事項である「HaskellでGUIアプリって作りやすいの？」問題についての回答が
ついに成されました。

……
と、思われましたが……

type LicensePane = FlowPane

-- Paneの生成
newLicensePane :: Java a LicensePane
newLicensePane = do
  doromochi       <- newLabel "ドロもち"
  imageAuthor     <- newLabel "The copyright of images in this  is owned by @HassakuTb on （ず・ω・きょ）"
  imageLink       <- newHyperlinkWithOpening "https://github.com/aiya000/eta-doromochi/blob/master/images"
  hassakuLink     <- newHyperlinkWithOpening "https://twitter.com/HassakuTb"
  zunkyoLink      <- newHyperlinkWithOpening "https://zunko.jp/guideline.html"
  bar             <- newLabel "- - -"
  aboutLicense    <- newLabel "This software includes the work that is distributed in the Apache License 2.0."
  bar'            <- newLabel "- - -"
  thisAppDepends  <- newLabel "This software depends below softwares"
  etaExamples     <- newLabel "typelead/eta-examples"
  etaExamplesLink <- newHyperlinkWithOpening "https://github.com/typelead/eta-examples"
  self            <- newFlowPane
  self <.> setOrientation verticalOrient
  let nodes = [ superCast doromochi
              , superCast imageAuthor
              , superCast imageLink
              , superCast hassakuLink
              , superCast zunkyoLink
              , superCast bar
              , superCast aboutLicense
              , superCast bar'
              , superCast thisAppDepends
              , superCast etaExamples
              , superCast etaExamplesLink
              ]
  forM_ (nodes :: [Node]) $ \node ->
    self <.> getChildren >- addChild node
  return self

普通に書きにくいな！？

いえいえ、これは見ての通り、JavaFX8のfxmlを使っていないコードです。

JavaFXではFXMLLoaderという優秀なクラスがあるので、それを使うだけでもっと綺麗に、
簡単に書けるはずです。

-- Appのスタート
start :: Stage -> Java DoromochiApp ()
start stage = do
  stage <.> setTitle "ドロもち"
  configDir <- getAppConfigDir
  fxml      <- newFile (configDir ++ "/fxml/DoromochiApp.fxml") >- toURI >- toURL
  root      <- fXMLLoad fxml
  remakeView stage (root :: BorderPane)
  scene     <- newScene root 512 512
  stage <.> do
    setTitle "ドロもち"
    setScene scene
    showStage
  where
    -- @FXMLが使えない気がするので、FXMLLoader.loadで得たPane値を掘っていく
    remakeView :: Stage -> BorderPane -> Java a ()
    remakeView stage pane = do
      menuBar <- unsafeCast <$> pane <.> getTop
      libraryMenu <- (!! 0) . fromJava . superList <$> menuBar <.> getMenus
      licenseItem <- (!! 0) . fromJava . superList <$> libraryMenu <.> getMenuItems
      licenseItem <.> setOnMenuItemAction (intentToLicenseApp stage)
      return ()

    superList :: ObservableList a -> List a
    superList = superCast

    intentToLicenseApp :: Stage -> ActionEvent -> Java (EventHandler ActionEvent) ()
    intentToLicenseApp stage = \_ -> do
      root        <- newGroup
      licensePane <- newLicensePane
      root <.> getChildren >- addChild licensePane
      scene       <-  newSceneWithoutSize root
      stage <.> setScene scene

もっと書きにくいな！？

そして実行時エラー多いな！？
（本来のHaskellは、実行以前に実行時エラーをより多く除去できる特徴があることで、良く知られています）

Etaはまだまだ進化中なんです

　この問題提起は、被験者（？）である僕の主観に頼り切っていますが
（例えばもっと模索に力を入れれば、@FXMLなどを使用する方法があるかもしれない）、
しかしながら確かな問題点でもあると考えています。

.fxmlに変わるDSLを考えよう

　ここで僕はその対処として、Eta上で使えるHaskellのEDSLを考えようと思いました。

　なぜEDSLか？

EDSL以外の方法として、僕は3つ思いつきました。

  1. @FXMLなどを使用可能か、深く調べてみる
  2. .fxmlをHaskellのデータ型にパースするパーサを書く
  3. .fxmlに変わる外部DSLとそのパーサを書く

なぜそれを行わないかですが

  1. 作る方向でいきたい
  2. めっちゃ良さそうだけど、時間がかかる
  3. めっちゃ良さそうだけど、構文設計分もっと、時間がかかる

という考えです。

だってHaskellの柔軟性知ってるか？

Stateだけでぜってー書ける。

　そこでこの記事では、そのEDSLの利用側コードを構想してみるところまでを記します。

（EDSLのためのライブラリの実装までは書かない）

EDSLの概要を決める

　このようなEDSLには、Hakyllという完全な先駆者がいます。

HakyllのEDSLを見てみましょう。

これは僕のブログで今まさに動いているコード（の一部）です。

main :: IO ()
main = hakyll $ do
  match "images/**" $ do
    route idRoute
    compile copyFileCompiler

  match "css/*" $ do
    route idRoute
    compile compressCssCompiler

  match "js/*" $ do
    route idRoute
    compile copyFileCompiler

  match "about.md" $ do
    route $ setExtension "html"
    compile $ modernPandocCompiler
      >>= loadAndApplyTemplate "templates/default.html" defaultContext
      >>= relativizeUrls

  match "posts/*" $ do
    route $ setExtension "html"
    compile $ modernPandocCompiler
      >>= loadAndApplyTemplate "templates/post.html" postCtx
      >>= loadAndApplyTemplate "templates/default.html" postCtx
      >>= relativizeUrls

  match "templates/*" $ do
    compile templateCompiler

うん、最高ですね。

doはHaskellが提供するMonadへの特殊な構文です。
これはEDSLに非常に使いやすいことで知られています。
（事実、通常のHaskellプログラミングにおいては、手続き型プログラミングのDSLとして機能する）

今回のこのDSL（hakyll関数に渡されているdoブロック）はRulesモナドです。
Rulesモナドの定義を見てみましょう。

-- | The monad used to compose rules
newtype Rules a = Rules
    { unRules :: RWST RulesRead RuleSet RulesState IO a
    } deriving (Monad, Functor, Applicative)

とてもわかりやすいですね。

　やはりこれから作るEDSLにもdoは有用そうです。
なのでこれから作るEDSLの型も、
doを使うためにMonad型として定義したいです。

EDSLの構文を決める

　今回は、この.fxmlをちょうど置き換えるような構文式を考えてみます。

<BorderPane>
  <top>
    <MenuBar>
      <menus>
        <Menu text="Library">
          <items>
            <MenuItem text="License"/>
          </items>
        </Menu>
      </menus>
    </MenuBar>
  </top>
  <center>
    <ImageView fitHeight="512" fitWidth="512">
      <image>
        <Image url="/home/aiya000/zunko.png"/>
      </image>
    </ImageView>
  </center>
</BorderPane>

hakyll関数に習ってrunBetaFX関数にdo式を適用するような形にしてみます。
ところで今EDSLの名前を思いついたのですが、BetaFXです。

aPane = runBetaFX $ do
    BorderPane.top $ do
        MenuBar.menus
          [do
            Menu.text "Library"
            Menu.items
              [do
                MenuItems.text "License"
              ]
          ]
    BorderPane.center $ do
        ImageView.fitHeight 512
        ImageView.fitWidth 512
        ImageView.image $ do
          Image.url "/home/aiya000/zunko.png"

うん、十分実用的そうです、いけそう。

　ところでいくつかの関数の名前がバッティングしています。

ここはOverloadedLabels
の出番かもしれませんが、まだ良くわかってないしここで時間をとってもしょうがないのでとりあえず今は名前空間をレイヤー分けします。

import BetaFX (runBetaFX, _borderPane, _menuBar, _menu, _menuItems, _imageView, _image)
import qualified BetaFX.BorderPane as BorderPane
import qualified BetaFX.MenuBar as MenuBar
import qualified BetaFX.Menu as Menu
import qualified BetaFX.MenuItems as MenuItems
import qualified BetaFX.ImageView as ImageView
import qualified BetaFX.Image as Image

aPane = runBetaFX $ do
    BorderPane.top $ do
        MenuBar.menus
          [do
            Menu.text "Library"
            Menu.items
              [do
                MenuItems.text "License"
              ]
          ]
    BorderPane.center $ do
        ImageView.fitHeight 512
        ImageView.fitWidth 512
        ImageView.image $ do
          Image.url "/home/aiya000/zunko.png"

EDSLの型を決める

　構文は決まったので、あとは型です。
何もかも、型が全てだ。

明らかにこれは、値コンストラクタに対して一部のフィールドのみを適用しているように見えます。
例えばここ

_menu $ do
  Menu.text "Library"
  Menu.items $ do
    _menuItems $ MenuItems.text "License"

は

Menu { text = "Library"
     , items = [ MenuItems { text = "License" }
               ]
     }

こう見えます。

しかしMenuのフィールド（レコード）にはtextとitems以外にonHiddenやonShowingなどが存在するので、
実際はそのようなそれはできません。

その形でやるならこうでしょうか。

Menu { text = "Library"
     , items = [ MenuItems { text             = "License"
                           , accelerator      = KeyConbination.noMatch
                           , disable          = False
                           , graphic          = ...
                           , id               = ""
                           , mnemonicParsing  = True
                           , onAction         = \_ -> return ()
                           , onMenuValidation = \_ -> return ()
                           , parentMenu       = ...
                           , parentPopup      = ...
                           , style            = ...
                           , text             = ...
                           , visible          = ...
                           }
               ]
     , onHidden  = \_ -> return ()
     , onHiding  = \_ -> return ()
     , onShowing = \_ -> return ()
     , onShown   = \_ -> return ()
     , showing   = False
     }

　今まさに設定したいフィールドであるtextとitems以外は隠蔽したいですよね。
そう、こんな感じに。

MenuBar.menus
  [do
    Menu.text "Library"
    Menu.items
      [do
        MenuItems.text "License"
      ]
  ]

ということで各フィールドを、状態変更を行う関数として定義するのが早いと思います。

type BetaFX s a = State s a

MenuItems.text :: String -> BetaFX MenuItems ()

Menu.text :: String -> BetaFX Menu ()
Menu.items :: [BetaFX MenuItems ()] -> BetaFX Menu ()

MenuBar.menus :: [BetaFX Menu ()] -> BetaFX MenuBar ()

MenuBar.menus
  ([do
    Menu.text "Library"
    Menu.items
      [do
        MenuItems.text "License"
      ]
  ] :: [BetaFX Menu ()])

ここでMenu.itemsが各BetaFX MenuItems ()に対して
MenuItemsの初期値と共にexecState :: BetaFX s a -> sしてあげればいけそうです。
（MenuBar.menusも同じように）

型付けが正しいことを確認してみます。

MenuBar.menus
  ([do
    (Menu.text "Library" :: BetaFX Menu)
    (Menu.items [MenuItems.text "License" :: BetaFX MenuItems ()]
        :: BetaFX Menu ())
  ] :: [BetaFX Menu ()])
:: BetaFX MenuBar ()

出来てそうなので、aPane全体を型付けしてみます。

do
    BorderPane.top $ do
        MenuBar.menus
          [do
            Menu.text "Library"
            Menu.items
              [do
                MenuItems.text "License"
              ]
          ]
    BorderPane.center $ do
        ImageView.fitHeight 512
        ImageView.fitWidth 512
        ImageView.image $ do
          Image.url "/home/aiya000/zunko.png"
:: BetaFX BorderPane ()

runBetaFX :: BetaFX s () -> s

aPane :: BorderPane
aPane = runBetaFX $ do
    BorderPane.top $ do
        MenuBar.menus
          [do
            Menu.text "Library"
            Menu.items
              [do
                MenuItems.text "License"
              ]
          ]
    BorderPane.center $ do
        ImageView.fitHeight 512
        ImageView.fitWidth 512
        ImageView.image $ do
          Image.url "/home/aiya000/zunko.png"

runBetaFXは明らかにexecStateですね。

でもせっかくなのでnewtypeして、
このBetaFXは 'Eta + JavaFX' のEDSLのみに使われることを明示してみます。

import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.State.Lazy (StateT, get, put, runStateT)

newtype BetaFX s a = BetaFX
  { unBetaFX :: State s a
  } deriving (Functor, Applicative, Monad, MonadState)

runBetaFX :: BetaFX s () -> s
runBetaFX = execState . unBetaFX

できた！！！

おまけ

　せっかくEDSLですし、ここ

Image.url "/home/aiya000/zunko.png"

は環境固有の絶対パスのままではなく、
~/zunko.pngあたりにしたいですよね。

じゃあIOを合成しちゃいますかね。

import System.Environment (getEnv)

newtype BetaFX s a = BetaFX
  { unBetaFX :: StateT s IO a
  } deriving (Functor, Applicative, Monad, MonadState, MonadIO)

ImageView.image $ do
  homeDir <- liftIO $ getEnv "HOME"
  Image.url $ homeDir ++ "/zunko.png"

できた！！

純粋性を保ちたい場合はIOの代わりにReaderを使って、
外部から注入してあげるといいと思います！

7
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
7
2