Programming Windows in Haskell

Haskell Win32

えー、いまさら何をやってんだという声も聞こえてきそうですが、普段Win32を使うことがとても多いので、Haskellで簡単なWin32のアプリを書いてみました。ちょっと長めなサンプルなので、コードは最後につけときます。

Win32でウィンドウを表示する基本的なプログラムの流れは以下のとおりです：

開始
ウィンドウクラスを登録。
ウィンドウを作成
ウィンドウを表示
メッセージをポンプする(以下ループ)
　　キューからメッセージを取り出す
　　ウィンドウプロシジャにディスパッチする
ウィンドウクラスの登録を削除する
終了

ほぼ必要なものは、System.Win32とGraphics.Win32の下にあります。なんですが、不思議なことに、PostQuitMessage　APIだけはライブラリ内でインポートが定義されていませんでした...そこで、Foreign Function Interface (FFI) を使ってAPIのプロトタイプを宣言しています。

pumpがいわゆるメッセージループなわけですが、キューからメッセージを取得するGetMessageはプロセス終了のメッセージであるWM_QUITをキューから取り出したときだけFalseを返すAPIです。そして、WM_QUITをメッセージキューにポストするのがFFIでインポートしなくてはいけなかったPostQuitMessageなわけです。つまり、PosQuitMessageを使わずにはWin32正規なウィンドウアプリの終了はできないはずなのですが、一体ほかのHaskell+Win32の人たちはどうやってアプリを書いてるんでしょう？書いていない？それとも、ほかのライブラリを使っている？

ではでは。

追記：アプリを起動するときにコンソールウィンドウが出ないようにするためには-optl-mwindowsをコンパイルするときに指定する必要があります。（GHCでの話ですが…ほかのコンパイラについては調べていません…）

module Main　where

import System.Win32.DLL (getModuleHandle)
import Graphics.Win32
import Graphics.Win32.Message
import Graphics.Win32.Window
import Data.Int
import Data.Maybe
import Control.Monad
import Foreign.C.String

foreign import stdcall "PostQuitMessage" postQuitMessage
   :: Int32 -> IO ()

main = do
  let clsName =  mkClassName "My Window Class"
  hinst       <- getModuleHandle Nothing
  whiteBrush  <- getStockBrush wHITE_BRUSH
  curArrow    <- loadCursor Nothing iDC_ARROW
  mAtom 	     <- registerClass (
      cS_DBLCLKS, 
      hinst,          -- HINSTANCE
      Nothing,        -- Maybe HICON
      Just curArrow,  -- Maybe HCURSOR
      Just whiteBrush,-- Maybe HBRUSH
      Nothing,        -- Maybe LPCTSTR
      clsName)

  when (isJust mAtom) $ do
    hwnd <- createWindow 
      clsName
      "test window" 
      (wS_THICKFRAME + wS_CAPTION + wS_SYSMENU) 
      Nothing 　
      Nothing 
      Nothing 
      Nothing 
      Nothing 
      Nothing 
      hinst 
      wndProc

    showWindow hwnd sW_SHOWNORMAL
    updateWindow hwnd
    allocaMessage pump
    unregisterClass clsName hinst

pump lpmsg = do
  fContinue <- getMessage lpmsg Nothing
  when fContinue $ do
    translateMessage lpmsg
    dispatchMessage lpmsg
    pump lpmsg

render :: HWND -> HDC -> IO ()
render hwnd hdc = do
  setBkMode hdc tRANSPARENT
  setTextColor hdc $ rgb 0 0 0
  textOut hdc 5 5 "hello world!"

wndProc :: HWND -> 
  WindowMessage -> 
  WPARAM -> 
  LPARAM -> IO LRESULT
wndProc hwnd wm wp lp
  | wm == wM_KEYDOWN     = doFinish
  | wm == wM_LBUTTONDOWN = doFinish
  | wm == wM_DESTROY     = postQuitMessage 0 >> return 0
  | wm == wM_PAINT       = onPaint
  | otherwise            = defWindowProc (Just hwnd) wm wp lp
  where
    doFinish = sendMessage hwnd wM_CLOSE 1 0 >> return 0
    onPaint  = allocaPAINTSTRUCT $ \ lpps -> do
      hdc <- beginPaint hwnd lpps
      render hwnd hdc
      endPaint hwnd lpps
      return 0