radio box や list box 、choice は on selectによって選択したときのイベントを取得できますが、NotebookにはSelectingインスタンスがありません。
そこで on click イベントによりどこのタブがクリックされたか判定します。
- on click イベントはマウスがクリックされたPointを引数として指定した関数を呼びます。
- notebookHitTest（wxNotebook::HitTest）によりヒットしたタブのインデックスを返します。
- notebookHitTest :: Notebook a -> Point -> Ptr CInt -> IO Int
notebookHitTestの３番目の引数はHaskellなのにポインタ渡しです。
そこで malloc でメモリを確保し、pokeで値を書き込み、そのアドレスを返す関数を作ります。
flag :: Ptr CInt flag = unsafePerformIO flag' where flag' = do work <- malloc::IO (Ptr CInt) poke work (fromIntegral wxBK_HITTEST_ONPAGE) return work
- GetSelectionは変化がひとつ遅れます。タブが変化したときはGetSelection変化せず、ひとつ前のSelectionを返します。
onMouse :: Notebook() -> Point -> IO () onMouse nb p = do propagateEvent i <- notebookHitTest nb p flag n <- notebookGetSelection nb logMessage ("Notebook index: " ++ show i ++ " GetSelection: " ++ show n)
- 以下は付属のサンプルを修正したものです（wxHaskell/samples/wx/Controls.hs）
{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-------------------------------------------------------------------------------- Copyright (c) Daan Leijen 2003 wxWindows License. Demonstrates: - many different kind of controls - message logging. $ ghc -Wall -package wx -o Controls.exe Controls.hs --------------------------------------------------------------------------------} module Main where import Graphics.UI.WX import Graphics.UI.WXCore import System.IO.Unsafe import Foreign.Marshal.Alloc import Foreign.Storable import Foreign.Ptr import Foreign.C.Types main :: IO () main = start gui gui :: IO () gui = do -- main gui elements: frame, panel, text control, and the notebook f <- frame [text := "Controls"] p <- panel f [] nb <- notebook p [] textlog <- textCtrl p [enabled := False, wrap := WrapNone] -- use text control as logger textCtrlMakeLogActiveTarget textlog logMessage "logging enabled" -- set f [on closing :~ \prev -> do logSetActiveTarget oldlog; logDelete log; prev] -- button page p1 <- panel nb [] ok <- button p1 [text := "Ok", on command := logMessage "ok button pressed"] quit <- button p1 [text := "Quit", on command := close f] -- radio box page p2 <- panel nb [] let rlabels = ["first", "second", "third"] r1 <- radioBox p2 Vertical rlabels [text := "radio box", on select ::= logSelect] r2 <- radioBox p2 Horizontal rlabels [tooltip := "radio group two", on select ::= logSelect] rb1 <- button p2 [text := "disable", on command ::= onEnable r1] -- choice p3 <- panel nb [] let clabels = ["mies","noot","aap"] c1 <- choice p3 [tooltip := "unsorted choices", on select ::= logSelect, sorted := False, items := clabels] c2 <- choice p3 [tooltip := "sorted choices", on select ::= logSelect, sorted := True, items := clabels] cb1 <- button p3 [text := "disable", on command ::= onEnable c1] -- list box page p4 <- panel nb [] sl1 <- singleListBox p4 [items := clabels ,tooltip := "unsorted single-selection listbox" ,on select ::= logSelect] sl2 <- singleListBox p4 [items := clabels ,tooltip := "sorted listbox" ,on select ::= logSelect, sorted := True] sc1 <- checkBox p4 [text := "enable the listbox", checked := True, on command := set sl1 [enabled :~ not]] -- slider/gauge page p5 <- panel nb [] s <- hslider p5 True {- show labels -} 1 100 [selection := 50] g <- hgauge p5 100 [selection := 50] set s [on command := do{ i <- get s selection; set g [selection := i]} ] let tab1 = tab "buttons" (container p1(margin 10 (floatCentre(row 5 [widget ok, widget quit])))) tab2 = tab "radio box" (container p2(margin 10 (column 5 [hstretch (widget rb1), row 0 [floatLeft (widget r1),floatRight(widget r2)]]))) tab3 = tab "choice" (container p3(margin 10 (column 5 [hstretch (widget cb1), row 0 [floatLeft (widget c1),floatRight(row 5 [label "sorted: ", widget c2])]]))) tab4 = tab "listbox" (container p4(margin 10 (column 5 [ hstretch (dynamic (widget sc1)), floatLeft (row 0 [widget sl1, widget sl2])]))) tab5 = tab "slider" (container p5(margin 10 (column 5 [hfill (widget s),hfill (widget g) ,glue ]))) nbtab= tabs nb [tab1, tab2,tab3,tab4,tab5] -- ここでNotebookの選択イベントを設定 set nb [on click := onMouse nb] -- specify layout set f [layout := container p $ column 0 [ nbtab, fill $ minsize (sz 100 200) $ widget textlog ] , clientSize := sz 800 300 ] return () where -- logSelect :: (Selection w, Items w String) => w -> IO () logSelect w = do i <- get w selection s <- get w (item i) logMessage ("selected index: " ++ show i ++ ": " ++ s) onEnable w b = do set w [enabled :~ not] enable <- get w enabled set b [text := (if enable then "disable" else "enable")] flag :: Ptr CInt flag = unsafePerformIO flag' where flag' = do work <- malloc::IO (Ptr CInt) poke work (fromIntegral wxBK_HITTEST_ONPAGE) return work onMouse :: Notebook() -> Point -> IO () onMouse nb p = do propagateEvent i <- notebookHitTest nb p flag n <- notebookGetSelection nb putStrLn (show (i,n, i == n)) -- kindof :: Object a -> String -> IO () kindof obj className = do classInfo <- classInfoFindClass className if (objectIsNull classInfo) then logMessage ("kindof " ++ className ++ ": no such class") else if (objectIsNull obj) then logMessage ("kindof " ++ className ++ ": null object") else do haskind <- objectIsKindOf obj classInfo logMessage ("kindof " ++ className ++ ": " ++ show haskind)
- withを使えばunsafePerformIOも使わずにすむ。
import Foreign.Marshal.Utils onMouse :: Notebook() -> Point -> IO () onMouse nb p = do propagateEvent i <- with (fromIntegral wxBK_HITTEST_ONPAGE) (\ptr -> notebookHitTest nb p ptr) n <- notebookGetSelection nb logMessage ("Notebook index: " ++ show i ++ " GetSelection: " ++ show n)
