Hatena::ブログ(Diary)

趣味的にっき このページをアンテナに追加 RSSフィード

2006-12-10

[] Win32 SDKを使ってウィンドウを表示してみる 07:20  Win32 SDKを使ってウィンドウを表示してみるを含むブックマーク  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

参考: Windows SDK編INDEX イントロダクション

トラックバック - http://d.hatena.ne.jp/ha-tan/20061210/1165702832
Connection: close