wxHaskell での「応答なし」を回避する。(Haskell によるメッセージ処理)

Haskell によるメッセージ処理

　以前の「wxHaskell での「応答なし」を回避する」はメッセージ処理をCでやっていましたが、Esa Ilari Vuokko氏製のDirectXバインディングを使ってみるを参考にHaskellでメッセージ処理をします。

-- ghc --make Main.hs -o msg.exe
 {-# LANGUAGE ForeignFunctionInterface #-}
module Main where

import System.Win32.Process (sleep)
import Graphics.UI.WX   
import Graphics.UI.WXCore.Frame (frameCenter)
import Graphics.UI.WXCore.WxcClassesMZ
import Graphics.Win32.Window
import System.Win32.Types
import System.Time
import Data.DateTime

main :: IO ()
main = start gui

gui :: IO ()
gui = do 
    form    <- frame [text := "Message test" ]
    p       <- panel form []
    textlog <- textCtrl p [enabled := True, wrap := WrapNone,
                          font := fontFixed{ _fontSize=11,_fontFace = "Monospace"} ] 
    ok   <- button p [text := "実行",   on command := doCommand textlog]
    clr  <- button p [text := "クリア", on command := textCtrlClear textlog, clientSize := sz 50 24]
    quit <- button p [text := "終了" , on command := close form,clientSize := sz 50 24]
    set ok   [clientSize := sz 50 24 ]
    set form [layout :=
                container p $
                  column 0
                    [floatRight 
                       (margin 10 $ row 5 [widget ok, widget clr, widget quit])
                 , hfill $ minsize (sz 350 250) $ widget textlog ]
             , clientSize := sz 350 300]
    frameCenter form
    return ()


doCommand :: (Textual w) => w -> IO ()
doCommand log = do 
    writeDate log 20
    writeText log "done.\n"

writeDate :: (Num t,Textual w) => w -> t -> IO ()
writeDate log 0 = return ()
writeDate log n = do
    delay 10 -- 重い処理の中にメッセージ処理
    ctime <- getClockTime
    writeText log $ show (fromClockTime ctime) ++ "\n"
    writeDate log (n-1)

delay :: Int -> IO()
delay 0 = return ()
delay n = sleep 100 >> messagePump >> delay (n-1)
	
writeText :: (Textual w) => w -> String -> IO ()
writeText log str = appendText log str

pM_REMOVE :: UINT
pM_REMOVE	= 0x0001

-- Haskellによるメッセージ処理
--
messagePump ::  IO ()
messagePump = allocaMessage $ \ msg ->
  c_PeekMessage msg (maybePtr Nothing) 0 0 pM_REMOVE >>= \r ->
    if r /= 0 then translateMessage msg >> dispatchMessage msg >> messagePump
              else return ()

allocaMessage :: (LPMSG -> IO a) -> IO a

Windows からメッセージへのポインタを取得して、引数の関数に渡す関数。