Win32 SDKを使ってウィンドウを表示してみる
hello.lhsを参考に、Win32 SDKを使ってウィンドウを表示するプログラムを書いてみました。ウィンドウを表示するだけなのにこんなにコードが必要なのか。うーむ。
module Main (main) where
import Data.Bits ((.|.))
import Graphics.Win32
import System.Exit (exitWith, ExitCode (ExitSuccess))
import System.Win32
createMainWindow :: String -> Pos -> Pos -> IO HWND
createMainWindow title width height = do
hinst <- getModuleHandle Nothing
icon <- loadIcon Nothing iDI_APPLICATION
cursor <- loadCursor Nothing iDC_ARROW
brush <- getStockBrush gRAY_BRUSH
registerClass
((cS_HREDRAW .|. cS_VREDRAW), hinst,
Just icon, Just cursor, Just brush,
Nothing, mkClassName $ title)
hwnd <- createWindow
(mkClassName $ title) title wS_OVERLAPPEDWINDOW Nothing Nothing
(Just width) (Just height) Nothing Nothing hinst wndProc
showWindow hwnd sW_SHOWNORMAL
updateWindow hwnd
return hwnd
wndProc :: HWND -> WindowMessage -> WPARAM -> LPARAM -> IO LRESULT
wndProc hwnd wmsg wParam lParam
| wmsg == wM_DESTROY = sendMessage hwnd wM_QUIT 1 0
| wmsg == wM_PAINT = onPaint hwnd
| otherwise = defWindowProc (Just hwnd) wmsg wParam lParam
onPaint :: HWND -> IO LRESULT
onPaint hwnd =
allocaPAINTSTRUCT $ \ lpps -> do
hdc <- beginPaint hwnd lpps
setBkMode hdc tRANSPARENT
setTextColor hdc $ rgb 255 255 0
textOut hdc 20 10 "Hello, world!!"
endPaint hwnd lpps
return 0
messageLoop :: HWND -> IO ()
messageLoop = allocaMessage . loop
where
loop hwnd msg = do
getMessage msg (Just hwnd)
`catch` \ _ -> exitWith ExitSuccess
translateMessage msg
dispatchMessage msg
loop hwnd msg
main :: IO ()
main = messageLoop =<< createMainWindow "Hello, World!!" 200 100
