Hatena::ブログ(Diary)

取り急ぎブログです このページをアンテナに追加 RSSフィード

2008-05-23

Programming Windows in Haskell

| 16:31 | Programming Windows in Haskellを含むブックマーク

えー、いまさら何をやってんだという声も聞こえてきそうですが、普段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

pr1pr1 2008/12/26 20:01 Hello,
which version of GHC did you use to compile the above code?
Which flags did you use?
I have tried this with ghci, but to no avail:
ghci Win32.hs -fglasgow-exts -LC:/WINDOWS/system32 -luser32
Many thanks.
Best regards,
pr1

Otter_OOtter_O 2008/12/27 17:05 Hello!

I've used GHC 6.8.3 with additional compiler option of -optl-mwindows.
I've also tried GHC 6.10.1 and it will compile without -optl-mwindows option.

I also tried
ghci -glasgow-exts simwin1.hs
on GHC 6.10.1 and it worked.

It looks like GHCI is confused of the file name win32.hs with something else. I get error binding the FFI declaration if I rename the file to win32.hs...

Hope this helps.

Connection: close