[htoolkit-cvs] gio/src/Graphics/UI/GIO Attributes.hs,1.20,1.21 Controls.hs,1.39,1.40

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

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

Modified Files:
	Attributes.hs Controls.hs 
Log Message:
Add support for Valued class and Choice and SelectionList controls


Index: Attributes.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Attributes.hs,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** Attributes.hs	15 Nov 2003 10:52:30 -0000	1.20
--- Attributes.hs	23 Nov 2003 16:29:13 -0000	1.21
***************
*** 92,95 ****
--- 92,98 ----
               , RangedSelect, range, selectedPos
               
+              -- ** Valued
+              , Valued, value
+              
               -- ** Icon
               , HasIcon, icon
***************
*** 319,328 ****
  
  -- | Widgets that have selectable items, like popup controls.
! class Countable w => CommandItems w where
!   items :: Attr w [(String,IO ())]
!   appendItem :: w -> (String,IO ()) -> IO ()
!   insertItem :: w -> Int -> (String,IO ()) -> IO ()
!   removeItem :: w -> Int -> IO ()
!   removeAllItems :: w -> IO ()
  
  -- | Widgets that have a single selection (like popup control).
--- 322,331 ----
  
  -- | Widgets that have selectable items, like popup controls.
! class CommandItems w where
!   items :: Attr (w a) [(String,a)]
!   appendItem :: w a -> (String,a) -> IO ()
!   insertItem :: w a -> Int -> (String,a) -> IO ()
!   removeItem :: w a -> Int -> IO ()
!   removeAllItems :: w a -> IO ()
  
  -- | Widgets that have a single selection (like popup control).
***************
*** 341,344 ****
--- 344,352 ----
    -- | The selected position
    selectedPos :: Attr w Int
+ 
+ -- | Widgets that edit a value
+ class Valued w a | w -> a where
+   -- The value
+   value :: Attr w a
  
  -- | Widgets which displays an icon.

Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/gio/src/Graphics/UI/GIO/Controls.hs,v
retrieving revision 1.39
retrieving revision 1.40
diff -C2 -d -r1.39 -r1.40
*** Controls.hs	23 Nov 2003 10:31:05 -0000	1.39
--- Controls.hs	23 Nov 2003 16:29:13 -0000	1.40
***************
*** 31,49 ****
                                 , Entry, entry, readOnly, password
  
!                                -- * Popup
!                                -- | A popup control consists of a list box combined with a label control.
!                                -- The list box portion of the control drop down only when the user selects 
!                                -- the drop-down arrow next to the control. The currently selected item in the 
!                                -- list box is displayed in the label control.
!                                , Popup, popup
!                                
!                                -- * ListBox
!                                -- | A list box displays a list of items, that the user can view and select.
!                                -- In a single-selection list box, the user can select only one item. 
!                                -- In a multiple-selection list box, a range of items can be selected. 
!                                -- When the user selects an item, it is highlighted and the list box 
!                                -- the 'command' event is generated.
!                                , ListBox, listBox
!                                
                                 -- * Slider
                                 -- | A slider control is a widget containing a slider and tick marks.
--- 31,61 ----
                                 , Entry, entry, readOnly, password
  
!                                -- * Choice & Popup
!                                -- | The choice control consists of a list box combined with a label control.
!                                -- The list box of the control drops down only when the user selects 
!                                -- the drop-down arrow next to the label. The currently selected item in the 
!                                -- list box is displayed in the label control. When the user 
!                                -- selects an item from the popup list, the 'command' event is generated. 
!                                -- The application can assign a specific value to each item to identify it. 
!                                -- If the value type is an instance of 'Eq', then the application can use
!                                -- the 'value' attribute to select the item by its value. The popup control 
!                                -- is a special kind of choice control where the value assigned to each item 
!                                -- is of (IO ()) type. Each time the user selects an item, 
!                                -- its IO action is executed.
!                                , Choice, Popup, popup, choice
! 
!                                -- * SelectionList & ListBox
!                                -- | A selection list displays a list of items, that the user can view and select.
!                                -- In a single-selection list, the user can select only one item while in
!                                -- a multiple-selection list, a range of items can be selected. When the user 
!                                -- selects an item from the list box, it becomes highlighted and the 
!                                -- 'command' event is generated. The application can assign a specific value to 
!                                -- each item to identify it. If the value type is an instance of 'Eq', 
!                                -- then the application can use the 'value' attribute to specify the set of 
!                                -- selected items. The list box control is a special kind of 
!                                -- selection list control where the value assigned to each item is of (IO ()) type. 
!                                -- Each time the user selects an item, its IO action is executed.
!                                , SelectionList, ListBox, selectionList, listBox
! 
                                 -- * Slider
                                 -- | A slider control is a widget containing a slider and tick marks.
***************
*** 241,244 ****
--- 253,259 ----
  instance Control Entry where
    pack = stdPack eparent ehandle Port.getEditRequestSize
+   
+ instance Valued Entry String where
+   value = title
      
  -- | Determines if the user can edit the text in the editable widget or not. 
***************
*** 250,418 ****
  password = newStdAttr ehandle Port.getEditPassword Port.setEditPassword
  
! {--------------------------------------------------------------------
!   Popup box
  --------------------------------------------------------------------}
! -- | A popup selection box. Allthough it is 'Commanding', the default
! -- command handler automatically calls a handler associated with a
! -- selected item.
! data Popup  = Popup    { phandle  :: !WindowHandle
!                        , pparent  :: !WindowHandle
!                        , pitems   :: Var [(String,IO ())]
                         }
  
  -- | Create a popup selection box.
! popup :: Container w => [Prop Popup] -> w -> IO Popup
! popup props w
    = do p <- do hpop <- Port.createPopUp (hwindow w)
!                pitems <- newVar []
!                return (Popup hpop (hwindow w) pitems)
!        set p [on command =: popupCommand p]
         set p props
         return p
  
! -- default command handler
! popupCommand :: Popup -> IO ()
! popupCommand p
!   = do i  <- get p selected
!        xs <- getVar (pitems p)
!        when (i>=0 && i < length xs) (snd (xs!!i))  -- invoke appropiate handler
  
! instance Countable Popup where
!   count = readAttr "count" (fmap length . getVar . pitems)
  
! instance CommandItems Popup where
    items
!     = newAttr (\w -> getVar (pitems w))
!               (\w xs -> do Port.removeAllPopUpItems (phandle w)
!                            mapM_ (Port.appendPopUpItem (phandle w) . fst) xs
!                            setVar (pitems w) xs
!                            set w [selected =: 0])
  
    appendItem p item@(title,action) = do
!     items <- takeVar (pitems p)
!     Port.appendPopUpItem (phandle p) title
!     putVar (pitems p) (items++[item])
  
    insertItem p pos item@(title,action) = do
!     items <- takeVar (pitems p)
!     Port.insertPopUpItem (phandle p) pos title
!     putVar (pitems p) (insertAt pos item items)
  
    removeItem p pos = do
!     items <- takeVar (pitems p)
!     Port.removePopUpItem (phandle p) pos
!     putVar (pitems p) (removeAt pos items)
  
    removeAllItems p = do
!     items <- takeVar (pitems p)
!     Port.removeAllPopUpItems (phandle p)
!     putVar (pitems p) []
  
! instance SingleSelect Popup where
!   selected = newStdAttr phandle Port.getPopUpSelection Port.setPopUpSelection
  
! instance Dimensions Popup where
!   frame = newStdAttr phandle Port.getControlFrame Port.moveResizeControl
  
! instance Able Popup where
!   enabled = newStdAttr phandle Port.getControlEnabled Port.setControlEnabled
  
! instance Tipped Popup where
!   tooltip = newStdAttr phandle Port.getControlTip Port.setControlTip
  
! instance Control Popup where
!   pack = stdPack pparent phandle Port.getPopUpRequestSize
  
! instance Commanding Popup where
!   command = newStdEvent phandle Port.getControlCommandHandler Port.setControlCommandHandler Port.setControlCommandDefHandler
  
! {--------------------------------------------------------------------
!   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 :: Container w => Bool -> [Prop ListBox] -> w -> 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)
!   xs <- getVar (lbitems lb)
!   when (i>=0 && i < length xs) (snd (xs!!i))  -- invoke appropiate handler
! 
! instance Countable ListBox where
!   count = readAttr "count" (fmap length . getVar . lbitems)
  
! instance CommandItems 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)
                             
    appendItem lb item@(title,action) = do
!     items <- takeVar (lbitems lb)
!     Port.appendListBoxItem (lbhandle lb) title
!     putVar (lbitems lb) (items++[item])
    
    insertItem lb pos item@(title,action) = do
!     items <- takeVar (lbitems lb)
!     Port.insertListBoxItem (lbhandle lb) pos title
!     putVar (lbitems lb) (insertAt pos item items)
    
    removeItem lb pos = do
!     items <- takeVar (lbitems lb)
!     Port.removeListBoxItem (lbhandle lb) pos
!     putVar (lbitems lb) (removeAt pos items)     
    
    removeAllItems lb = do
!     items <- takeVar (lbitems lb)
!     Port.removeAllListBoxItems (lbhandle lb)
!     putVar (lbitems lb) []
  
  
! instance SingleSelect ListBox where
!   selected = newStdAttr lbhandle Port.getListBoxSingleSelection Port.setListBoxSingleSelection
  
! 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 = newStdAttr lbhandle Port.getControlFrame Port.moveResizeControl
  
! instance Able ListBox where
!   enabled = newStdAttr lbhandle Port.getControlEnabled Port.setControlEnabled
  
! instance Tipped ListBox where
!   tooltip = newStdAttr lbhandle Port.getControlTip Port.setControlTip
  
! instance Control ListBox where
!   pack = stdPack lbparent lbhandle Port.getListBoxRequestSize
  
! instance Commanding ListBox where
!   command = newStdEvent lbhandle Port.getControlCommandHandler Port.setControlCommandHandler Port.setControlCommandDefHandler
  
  --------------------------------------------------------------------
--- 265,509 ----
  password = newStdAttr ehandle Port.getEditPassword Port.setEditPassword
  
! --------------------------------------------------------------------
! -- Choice & Popup
  --------------------------------------------------------------------}
! 
! -- | A choice control.
! data Choice a = Choice { chhandle :: !WindowHandle
!                        , chparent :: !WindowHandle
!                        , chitems  :: Var [(String,a)]
                         }
  
+ -- | A popup selection box is a special kind of choice control. The default
+ -- command handler automatically calls a handler associated as a value to the
+ -- selected item.
+ type Popup = Choice (IO ())
+ 
  -- | Create a popup selection box.
! choice :: Container w => [Prop (Choice a)] -> w -> IO (Choice a)
! choice props w
    = do p <- do hpop <- Port.createPopUp (hwindow w)
!                chitems <- newVar []
!                return (Choice hpop (hwindow w) chitems)
         set p props
         return p
  
! -- | Create a popup selection box.
! popup :: Container w => [Prop Popup] -> w -> IO Popup
! popup props w = do
!   c <- choice props w
!   set c [on command =: popupCommand c]
!   return c
!   where 
!     -- default command handler
!     popupCommand :: Popup -> IO ()
!     popupCommand p
!       = do i  <- get p selected
!            xs <- getVar (chitems p)
!            when (i>=0 && i < length xs) (snd (xs!!i))  -- invoke appropiate handler
  
! instance Countable (Choice a) where
!   count = readAttr "count" (fmap length . getVar . chitems)
  
! instance CommandItems Choice where
    items
!     = newAttr (\w -> getVar (chitems w))
!               (\w xs -> do Port.removeAllPopUpItems (chhandle w)
!                            mapM_ (Port.appendPopUpItem (chhandle w) . fst) xs
!                            setVar (chitems w) xs
!                            Port.setPopUpSelection (chhandle w) 0)
  
    appendItem p item@(title,action) = do
!     items <- takeVar (chitems p)
!     Port.appendPopUpItem (chhandle p) title
!     putVar (chitems p) (items++[item])
  
    insertItem p pos item@(title,action) = do
!     items <- takeVar (chitems p)
!     Port.insertPopUpItem (chhandle p) pos title
!     putVar (chitems p) (insertAt pos item items)
  
    removeItem p pos = do
!     items <- takeVar (chitems p)
!     Port.removePopUpItem (chhandle p) pos
!     putVar (chitems p) (removeAt pos items)
  
    removeAllItems p = do
!     items <- takeVar (chitems p)
!     Port.removeAllPopUpItems (chhandle p)
!     putVar (chitems p) []
  
! instance SingleSelect (Choice a) where
!   selected = newStdAttr chhandle Port.getPopUpSelection Port.setPopUpSelection
  
! instance Dimensions (Choice a) where
!   frame = newStdAttr chhandle Port.getControlFrame Port.moveResizeControl
  
! instance Able (Choice a) where
!   enabled = newStdAttr chhandle Port.getControlEnabled Port.setControlEnabled
  
! instance Tipped (Choice a) where
!   tooltip = newStdAttr chhandle Port.getControlTip Port.setControlTip
  
! instance Control (Choice a) where
!   pack = stdPack chparent chhandle Port.getPopUpRequestSize
  
! instance Commanding (Choice a) where
!   command = newStdEvent chhandle Port.getControlCommandHandler Port.setControlCommandHandler Port.setControlCommandDefHandler
  
! instance Eq a => Valued (Choice a) (Maybe a) where
!   value = newAttr getValue setValue
!     where
!       getValue c = do
!         i  <- get c selected
!         xs <- getVar (chitems c)
!         return (if i>=0 && i < length xs
!                 then Just (snd (xs!!i))
!                 else Nothing)
!           
!       setValue c (Just v) = do
!         xs <- getVar (chitems c)
!         set c [selected =: findValue v 0 xs]
!       setValue c Nothing = do
!         set c [selected =: -1]
!         
!       findValue v n [] = -1
!       findValue v n ((_,v'):vs)
!         | v == v'   = n
!         | otherwise = findValue v (n+1) vs
! 
! --------------------------------------------------------------------
! -- SelectionList & ListBox
! --------------------------------------------------------------------
! 
! -- | A selection list control
! data SelectionList a = SelectionList
! 	{ slIsMulti :: Bool
! 	, slhandle  :: !WindowHandle
! 	, slparent  :: !WindowHandle
! 	, slitems   :: Var [(String,a)]
! 	}
! 
! -- | A list box is a special kind of selection list control.  The default
! -- command handler automatically calls a handler associated as a value to the
! -- selected item.                       
! type ListBox = SelectionList (IO ())
! 
! -- | Create a selection list box.
! selectionList :: Container w => Bool -> [Prop (SelectionList a)] -> w -> IO (SelectionList a)
! selectionList multi props w = do
! 	lb <- do hlist <- Port.createListBox (hwindow w) multi
! 		 slitems <- newVar []
! 		 return (SelectionList multi hlist (hwindow w) slitems)
! 	set lb props
! 	return lb
  
  -- | Create a list box.
  listBox :: Container w => Bool -> [Prop ListBox] -> w -> IO ListBox
  listBox multi props w = do
! 	lb <- selectionList multi props w
  	set lb [on command =: listBoxCommand lb]
  	return lb
+ 	where
+ 		listBoxCommand :: ListBox -> IO ()
+ 		listBoxCommand lb = do
+   			i  <- Port.getListBoxCurrentItem (slhandle lb)
+ 			xs <- getVar (slitems lb)
+ 			when (i>=0 && i < length xs) (snd (xs!!i))  -- invoke appropiate handler
  
! instance Countable (SelectionList a) where
!   count = readAttr "count" (fmap length . getVar . slitems)
  
! instance CommandItems SelectionList where
    items
!     = newAttr (\w -> getVar (slitems w))
!               (\w xs -> do Port.removeAllListBoxItems (slhandle w)
!                            mapM_ (Port.appendListBoxItem (slhandle w) . fst) xs
!                            setVar (slitems w) xs)
                             
    appendItem lb item@(title,action) = do
!     items <- takeVar (slitems lb)
!     Port.appendListBoxItem (slhandle lb) title
!     putVar (slitems lb) (items++[item])
    
    insertItem lb pos item@(title,action) = do
!     items <- takeVar (slitems lb)
!     Port.insertListBoxItem (slhandle lb) pos title
!     putVar (slitems lb) (insertAt pos item items)
    
    removeItem lb pos = do
!     items <- takeVar (slitems lb)
!     Port.removeListBoxItem (slhandle lb) pos
!     putVar (slitems lb) (removeAt pos items)     
    
    removeAllItems lb = do
!     items <- takeVar (slitems lb)
!     Port.removeAllListBoxItems (slhandle lb)
!     putVar (slitems lb) []
  
  
! instance SingleSelect (SelectionList a) where
!   selected = newStdAttr slhandle Port.getListBoxSingleSelection Port.setListBoxSingleSelection
  
! instance MultiSelect (SelectionList a) where
    selection = newAttr getter setter
      where
        getter w = do
!         items <- getVar (slitems w)
!         filterM (\i -> Port.getListBoxItemSelectState (slhandle w) i) [0..length items-1]
  
        setter w xs = do
!         items <- getVar (slitems w)
!         mapM_ (\x -> Port.setListBoxItemSelectState (slhandle w) x (elem x xs)) [0..length items-1]
  
! instance Dimensions (SelectionList a) where
!   frame = newStdAttr slhandle Port.getControlFrame Port.moveResizeControl
  
! instance Able (SelectionList a) where
!   enabled = newStdAttr slhandle Port.getControlEnabled Port.setControlEnabled
  
! instance Tipped (SelectionList a) where
!   tooltip = newStdAttr slhandle Port.getControlTip Port.setControlTip
  
! instance Control (SelectionList a) where
!   pack = stdPack slparent slhandle Port.getListBoxRequestSize
  
! instance Commanding (SelectionList a) where
!   command = newStdEvent slhandle Port.getControlCommandHandler Port.setControlCommandHandler Port.setControlCommandDefHandler
!   
! instance Eq a => Valued (SelectionList a) [a] where
!   value = newAttr getter setter
!     where
!       getter (SelectionList multi handle _ itemsVar)
!         | multi     = do
!                  xs <- getVar itemsVar
! 	         let getSelection _ [] = return []
! 	             getSelection i ((_,v):xs) = do
! 	                selected <- Port.getListBoxItemSelectState handle i
! 	                vs <- getSelection (i+1) xs
! 	                return (if selected then v:vs else vs)
!                  getSelection 0 xs
!         | otherwise = do
!                  index <- Port.getListBoxSingleSelection handle
! 	         xs <- getVar itemsVar
! 	         return (if index>=0 && index < length xs
! 	                  then [snd (xs!!index)]
!                           else [])
!       setter (SelectionList multi handle _ itemsVar) vs
!         | multi     = do
!                 xs <- getVar itemsVar
!                 let setSelection _ [] = return ()
!                     setSelection i ((_,v):xs) = do
!                       Port.setListBoxItemSelectState handle i (elem v vs)
!                       setSelection (i+1) xs
!                 setSelection 0 xs
!         | otherwise = do
!         	xs <- getVar itemsVar
!         	let setSelection _ [] = Port.setListBoxSingleSelection handle (-1)
!         	    setSelection i ((_,v):xs)
!         	      | v `elem` vs = Port.setListBoxSingleSelection handle i
!         	      | otherwise   = setSelection (i+1) xs
!                 setSelection 0 xs
!     
  
  --------------------------------------------------------------------
***************
*** 453,456 ****
--- 544,550 ----
  instance Control CheckBox where
    pack = stdPack cparent chandle Port.getCheckBoxRequestSize
+   
+ instance Valued CheckBox Bool where
+   value = checked
  
  --------------------------------------------------------------------
***************
*** 488,491 ****
--- 582,588 ----
  instance Control RadioBox where
    pack = stdPack rparent rhandle Port.getRadioBoxRequestSize
+   
+ instance Valued RadioBox Bool where
+   value = checked
  
  
***************
*** 531,534 ****
--- 628,634 ----
  instance Control Slider where
    pack = stdPack sparent shandle Port.getSliderRequestSize
+   
+ instance Valued Slider Int where
+   value = selectedPos
  
  
***************
*** 623,626 ****
--- 723,728 ----
    pack = stdPack pbparent pbhandle Port.getProgressBarRequestSize
  
+ instance Valued ProgressBar Int where
+   value = selectedPos
  
  --------------------------------------------------------------------