-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/widgets/OptionMenu.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.5 $ from $Date: 2001/12/10 21:29:38 $  
-- Last modification by $Author: ludi $
--
-- -----------------------------------------------------------------------

---
-- HTk's <strong>option menu</strong> widget.<br>
-- A simple clip up menu displaying a set of radiobuttons.
module OptionMenu (

  OptionMenu,
  newOptionMenu

) where

import Core
import BaseClasses(Widget)
import Configuration
import GUIValue
import Button
import MenuItem
import Destructible
import Computation
import Synchronized
import Packer
import Tooltip


-- -----------------------------------------------------------------------
-- datatype
-- -----------------------------------------------------------------------

---
-- The <code>OptionMenu</code> datatype.
newtype OptionMenu a = OptionMenu GUIOBJECT deriving Eq


-- -----------------------------------------------------------------------
-- creation
-- -----------------------------------------------------------------------

---
-- Constructs a new option menu and returns a handler.
-- @param par     - the parent widget, which has to be a container widget
--                  (an instance of <code>class Container</code>).
-- @param el      - the list of selectable elements.
-- @return result - An option menu.
newOptionMenu :: (Container par, GUIValue a) =>
                 par -> [a] -> [Config (OptionMenu a)] ->
                 IO (OptionMenu a)
newOptionMenu par el cnf =
  do
    wid <- createGUIObject (toGUIObject par) (OPTIONMENU el')
                           optionMenuMethods
    configure (OptionMenu wid) cnf
  where el' = map toGUIValue el


-- -----------------------------------------------------------------------
-- instances
-- -----------------------------------------------------------------------

---
-- Internal.
instance GUIObject (OptionMenu a) where 
---
-- Internal.
  toGUIObject (OptionMenu  w) = w
---
-- Internal.
  cname _ = "OptionMenu"

---
-- An option menu can be destroyed.
instance Destroyable (OptionMenu a) where
---
-- Destroys an option menu.
  destroy = destroy . toGUIObject

---
-- An option menu has standard widget properties
-- (concerning focus, cursor).
instance Widget (OptionMenu a)

---
-- An option menu has a configureable border.
instance HasBorder (OptionMenu a)

---
-- An option menu has a normal foreground and background colour and an
-- active/disabled foreground and background colour.
instance HasColour (OptionMenu a) where
---
-- Internal.
  legalColourID = buttonColours

---
-- An option menu is a stateful widget, it can be enabled or disabled.
instance HasEnable (OptionMenu a)

---
-- You can specify the font of an option menu.
instance HasFont (OptionMenu a) 

---
-- You can specify the size of an option menu.
instance HasSize (OptionMenu a)

---
-- An option menu has a value (the selected element), that corresponds to
-- a polymorphic <code>TkVariable</code>.
instance GUIValue a => HasValue (OptionMenu a) a where
---
-- Sets the option menu's value (the selected element).
  value v w =
    setTclVariable ((tvarname . objectID . toGUIObject) w) v >> return w
---
-- Gets the option menu's value.
  getValue w = getTclVariable ((tvarname . objectID . toGUIObject) w)

---
-- An option menu can have a tooltip (only displayed if you are using
-- tixwish).
instance HasTooltip (OptionMenu a)

---
-- An option menu has a text anchor.
instance HasAnchor (OptionMenu a)


-- -----------------------------------------------------------------------
-- OptionMenu methods
-- -----------------------------------------------------------------------

optionMenuMethods = defMethods { cleanupCmd = tkCleanupOptionMenu,
                                 createCmd = tkCreateOptionMenu,
                                 csetCmd = tkSetOptionMenuConfigs }


-- -----------------------------------------------------------------------
-- Unparsing of Tk commands
-- -----------------------------------------------------------------------

tvarname :: ObjectID -> String
tvarname oid = "v" ++ (show oid)

tkDeclOptionMenuVar :: GUIOBJECT -> WidgetName
tkDeclOptionMenuVar = WidgetName . tvarname . objectID

tkCreateOptionMenu :: ObjectName -> ObjectKind -> ObjectName ->
                      ObjectID -> [ConfigOption] -> TclScript
tkCreateOptionMenu _ (OPTIONMENU els) name oid confs =
  ["set " ++ tvarname oid ++ " " ++ firstElem els,
   "tk_optionMenu " ++ show name ++ " " ++ tvarname oid ++ " " ++
   concatMap (++ " ") (map show els)] ++
  tkSetOptionMenuConfigs name confs
  where firstElem [] = ""
        firstElem ((GUIVALUE _ x):l) = x

tkSetOptionMenuConfigs :: ObjectName -> [ConfigOption] -> TclScript
tkSetOptionMenuConfigs name @ (ObjectName wname) confs = 
  (csetCmd defMethods) name confs ++
  (csetCmd defMethods) (ObjectName (wname ++ ".menu")) 
                       (filter isMenuConfig confs)
  where isMenuConfig ("foreground",_) = True
        isMenuConfig ("background",_) = True
        isMenuConfig ("activebackground",_) = True
        isMenuConfig ("activeforeground",_) = True
        isMenuConfig ("disabledforeground",_) = True
        isMenuConfig ("font",_) = True
        isMenuConfig (_,_) = False

tkCleanupOptionMenu :: ObjectID -> ObjectName -> TclScript
tkCleanupOptionMenu oid _ = tkUndeclVar (tvarname oid) 
{-# INLINE tkCleanupOptionMenu #-}