[htoolkit-cvs] gio/src/Graphics/UI/GIO Controls.hs,1.14,1.15

[<kr_...@us...>]

Update of /cvsroot/htoolkit/gio/src/Graphics/UI/GIO
In directory sc8-pr-cvs1:/tmp/cvs-serv2674/src/Graphics/UI/GIO

Modified Files:
	Controls.hs 
Log Message:
ListBox for GIO


Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Controls.hs,v
retrieving revision 1.14
retrieving revision 1.15
diff -C2 -d -r1.14 -r1.15
*** Controls.hs	9 Jul 2003 17:15:14 -0000	1.14
--- Controls.hs	10 Jul 2003 19:41:19 -0000	1.15
***************
*** 11,20 ****
  -}
  -----------------------------------------------------------------------------------------
! module Graphics.UI.GIO.Controls( 
                                 -- * Controls
                                   Button, button
!                                , Label, label 
                                 , Entry, entry, readOnly, visible
                                 , Popup, popup
                                 , Slider, hslider, vslider
                                 , ProgressBar, hProgressBar, vProgressBar
--- 11,21 ----
  -}
  -----------------------------------------------------------------------------------------
! module Graphics.UI.GIO.Controls(
                                 -- * Controls
                                   Button, button
!                                , Label, label
                                 , Entry, entry, readOnly, visible
                                 , Popup, popup
+                                , ListBox, listBox
                                 , Slider, hslider, vslider
                                 , ProgressBar, hProgressBar, vProgressBar
***************
*** 32,36 ****
  import Graphics.UI.GIO.Window
  import Graphics.UI.GIO.Layout
! import Control.Monad(when)
  
  --------------------------------------------------------------------
--- 33,37 ----
  import Graphics.UI.GIO.Window
  import Graphics.UI.GIO.Layout
! import Control.Monad(when, mapM_, filterM)
  
  --------------------------------------------------------------------
***************
*** 209,213 ****
  instance Able Popup where
    enabled = newAttr (Port.getControlEnabled . phandle) (Port.setControlEnabled . phandle)
!   
  instance ToolTip Popup where
    tooltip = newAttr (Port.getControlTip . phandle) (Port.setControlTip . phandle)
--- 210,214 ----
  instance Able Popup where
    enabled = newAttr (Port.getControlEnabled . phandle) (Port.setControlEnabled . phandle)
! 
  instance ToolTip Popup where
    tooltip = newAttr (Port.getControlTip . phandle) (Port.setControlTip . phandle)
***************
*** 215,219 ****
  instance Control Popup where
    pack p = stdPack (pparent p) (Port.getPopUpRequestSize (phandle p)) (Port.moveResizeControl (phandle p))
!              
  instance Commanding Popup where
    command
--- 216,220 ----
  instance Control Popup where
    pack p = stdPack (pparent p) (Port.getPopUpRequestSize (phandle p)) (Port.moveResizeControl (phandle p))
! 
  instance Commanding Popup where
    command
***************
*** 221,227 ****
  
  {--------------------------------------------------------------------
    Check group
  --------------------------------------------------------------------}
! -- | A check control group. 
  data CheckGroup = CheckGroup{ checks   :: [Check]
                              , cgparent :: !WindowHandle
--- 222,295 ----
  
  {--------------------------------------------------------------------
+   ListBox
+ --------------------------------------------------------------------}
+ -- | A list box. Allthough it is 'Commanding', the default
+ -- command handler automatically calls a handler associated with a
+ -- selected item.
+ data ListBox = ListBox { lbhandle  :: !WindowHandle
+                        , lbparent  :: !WindowHandle
+                        , lbitems   :: Var [(String,IO ())]
+                        }
+ 
+ -- | Create a list box.
+ listBox :: Bool -> [Prop ListBox] -> Window -> IO ListBox
+ listBox multi props w = do
+ 	lb <- do
+ 			hlist <- Port.createListBox (hwindow w) multi
+ 			lbitems <- newVar []
+ 			return (ListBox hlist (hwindow w) lbitems)
+ 	set lb [on command =: listBoxCommand lb]
+ 	set lb props
+ 	return lb
+ 
+ -- default command handler
+ listBoxCommand :: ListBox -> IO ()
+ listBoxCommand lb = do
+   i  <- Port.getListBoxCurrentItem (lbhandle lb)
+   print i
+   xs <- getVar (lbitems lb)
+   when (i>=0 && i < length xs) (snd (xs!!i))  -- invoke appropiate handler
+ 
+ instance Select ListBox where
+   items
+     = newAttr (\w -> getVar (lbitems w))
+               (\w xs -> do Port.removeAllListBoxItems (lbhandle w)
+                            mapM_ (Port.appendListBoxItem (lbhandle w) . fst) xs
+                            setVar (lbitems w) xs)
+ 
+ instance SingleSelect ListBox where
+   selected = newAttr (Port.getListBoxSingleSelection . lbhandle) (Port.setListBoxSingleSelection . lbhandle)
+ 
+ instance MultiSelect ListBox where
+   selection = newAttr getter setter
+     where
+       getter w = do
+         items <- getVar (lbitems w)
+         filterM (\i -> Port.getListBoxItemSelectState (lbhandle w) i) [0..length items-1]
+ 
+       setter w xs = do
+         items <- getVar (lbitems w)
+         mapM_ (\x -> Port.setListBoxItemSelectState (lbhandle w) x (elem x xs)) [0..length items-1]
+ 
+ instance Dimensions ListBox where
+   frame = newAttr (Port.getControlFrame . lbhandle) (Port.moveResizeControl . lbhandle)
+ 
+ instance Able ListBox where
+   enabled = newAttr (Port.getControlEnabled . lbhandle) (Port.setControlEnabled . lbhandle)
+ 
+ instance ToolTip ListBox where
+   tooltip = newAttr (Port.getControlTip . lbhandle) (Port.setControlTip . lbhandle)
+ 
+ instance Control ListBox where
+   pack lb = stdPack (lbparent lb) (Port.getListBoxRequestSize (lbhandle lb)) (Port.moveResizeControl (lbhandle lb))
+ 
+ instance Commanding ListBox where
+   command
+     = newControlCommandEvent lbhandle
+ 
+ {--------------------------------------------------------------------
    Check group
  --------------------------------------------------------------------}
! -- | A check control group.
  data CheckGroup = CheckGroup{ checks   :: [Check]
                              , cgparent :: !WindowHandle
***************
*** 257,262 ****
  
  instance MultiSelect CheckGroup where
!   selection 
!     = newAttr getter setter     
      where
        getter w
--- 325,330 ----
  
  instance MultiSelect CheckGroup where
!   selection
!     = newAttr getter setter
      where
        getter w