椿の日記

たぶんプログラムの話をします

HaskellでWin32メッセージループをPeekMessageで制御してみる

こんどはEsa Ilari Vuokko氏製のDirectXバインディングを使ってみるを見ながらコピペしつつ修正していきます。
とりあえず、PeekMessageを使った後にMSG構造体の中身を見ることになるので、まずはMSG構造体のHaskell版を定義します。

data MSG =
    MSG {
        msg_hwnd    :: HWND,
        msg_message :: UINT,
        msg_wParam  :: WPARAM,
        msg_lParam  :: LPARAM,
        msg_time    :: DWORD,
        msg_pt      :: POINT
    } deriving (Show, Eq)

instance Storable MSG where
    sizeOf x = 28
    alignment x = 4
    peek p = do
        hwnd    <- peekByteOff p 0
        message <- peekByteOff p 4
        wParam  <- peekByteOff p 8
        lParam  <- peekByteOff p 12
        time    <- peekByteOff p 16
        pt      <- peekPOINT (p `plusPtr` 20)
        return $ MSG { msg_hwnd = hwnd,
                       msg_message = message,
                       msg_wParam = wParam,
                       msg_lParam = lParam,
                       msg_time = time,
                       msg_pt = pt
                     }
    poke p x = do
        pokeByteOff p  0 (msg_hwnd x)
        pokeByteOff p  4 (msg_message x)
        pokeByteOff p  8 (msg_wParam x)
        pokeByteOff p 12 (msg_lParam x)
        pokeByteOff p 16 (msg_time x)
        pokePOINT (p `plusPtr` 20) (msg_pt x)

そしてループするのですが、リンク先のソースの手順が地味に見慣れない(というかバグ?)ので少し修正します。
c_PeekMessageでメッセージを取れたかどうか戻り値を使って判定し、その結果で分岐するようにします。
昨日のエントリのpump関数を次のように変更。

pM_NOREMOVE = 0x0000 :: UINT
pM_REMOVE   = 0x0001 :: UINT
pM_NOYIELD  = 0x0002 :: UINT

onIdle :: IO ()
onIdle = sleep 1

pump :: LPMSG -> IO ()
pump lpmsg = do
  ret <- c_PeekMessage lpmsg (maybePtr Nothing) 0 0 pM_REMOVE
  case ret of
    -1        -> putStrLn "error"
    0         -> onIdle >> pump lpmsg
    otherwise -> do msg <- peek $ castPtr lpmsg
                    when (msg_message msg /= wM_QUIT) $ do
                      translateMessage lpmsg
                      dispatchMessage lpmsg
                      pump lpmsg

LPMSGは型がPtr ()なので、これをPtr MSGにキャストする必要があります。


相変わらずC言語でやってることと大差ないですね。