Widgets - Tcl specific
Definition of all the tcl-tk widgets including creation functions, 
and instances for configuring.

\begin{code}
module Widgets (module Widgets, 
                moveMItem,
		TIndex(..),T.ModMove(..)) where
-- standard modules
import IOExts
import Monad
import Maybe
import Utils
import FM

-- from Fran
import FranCore
import qualified StaticTypes as S
import Compatibility (mkWeakIORef)
import MutSet

-- from FranTk
import AbstractInterface

-- tcl-tk specific
import qualified TclPrimImpl as T
import TclPrimImpl (Geometry(..),TIndex(..),ModMove(..))
import WidgetSetImpl
import WidgetConf
import CItem
import MItem
\end{code}

-- open and save file dialog boxes

\begin{code}

getOpenFileName, getSaveFileName :: GUI (Maybe String)
getOpenFileName = withGUIInfo T.getOpenFileName
getSaveFileName = withGUIInfo T.getSaveFileName
\end{code}

\begin{code}

valids :: [Conf Style] -> [ConfigName]
valids ws = getConfNames ws

vl :: a 
vl = error "used in valids: should not be evaluated"
\end{code}


-- Window --------------------------------------------

toplevel windows 
\begin{code}

--type Window = PrimWidget T.Window, from GUI
 
instance Has_background		 Window
instance Has_borderwidth	 Window
instance Has_cursor		 Window
instance Has_height		 Window
instance Has_highlightbackground Window
instance Has_highlightcolor	 Window
instance Has_highlightthickness	 Window
instance Has_relief		 Window
instance Has_takefocus		 Window
instance Has_width		 Window
instance Has_use_menu		 Window

windowNames :: [ConfigName]
windowNames = 
 valids $ [background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl]

onClose :: Listener () -> Conf Window
onClose l = confGUI $ \w -> withGUIDef $ \g -> do
		act <- fireListener l
		trapDeleteWindow w (primAction g $ act ())


window :: [Conf Window] -> GUI Window
window cs = do
 w <- mkPrimWidget (\w cs -> T.window cs) windowNames (kill:cs)
 return w
  where
   kill = confIO  $ \w -> trapDeleteWindow w (destroy w)
 
title :: String -> Conf Window
title s = confPIO (identify "title") $ flip T.title s

titleB :: StringB -> Conf Window
titleB = confBh title

setWinSize :: Window -> S.Vector2 -> IO ()
setWinSize w (S.Vector2XY a b) = 
 T.geometry (widgetPrim w) (T.WinSz (round a,round b)) 

winsize :: S.Vector2 -> Conf Window
winsize v = confIO  $ flip setWinSize v 

winsizeB :: Vector2B -> Conf Window
winsizeB v = confBh winsize v

setWinPos :: Window -> S.Point2 -> IO ()
setWinPos w (S.Point2XY a b) = 
 T.geometry (widgetPrim w) (T.WinPn (round a,round b))

winposition :: S.Point2 -> Conf Window
winposition p = confIO  $ flip setWinPos p

winpositionB :: Point2B -> Conf Window
winpositionB p = confBh winposition p

-- Trapping Window Deletions ---------------------------

trapDeleteWindow :: Window -> IO () -> IO ()
trapDeleteWindow w act = T.trapDeleteWindow (widgetPrim w) act
\end{code}

-- Label -----------------------------------------------

\begin{code} 
type Label = PrimWidget T.Label

instance Has_anchor		 Label
instance Has_background		 Label
instance Has_bitmap		 Label
instance Has_borderwidth	 Label
instance Has_cursor		 Label
instance Has_font		 Label
instance Has_foreground		 Label
instance Has_height		 Label
instance Has_highlightbackground Label
instance Has_highlightcolor	 Label
instance Has_highlightthickness	 Label
instance Has_justify		 Label
instance Has_padx		 Label
instance Has_pady		 Label
instance Has_relief		 Label
instance Has_takefocus		 Label
instance Has_text		 Label
instance Has_underline		 Label
instance Has_width		 Label
instance Has_wraplength		 Label
 

labelNames :: [ConfigName]
labelNames = 
 valids $ [background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl]

label :: [Conf Label] -> GUI Label
label  = mkPWidget T.label labelNames
\end{code}

-- Message ---------------------------------------------

message widgets displaying text

\begin{code}

type Message = PrimWidget T.Message


instance Has_anchor		 Message
instance Has_aspect 		 Message
instance Has_background		 Message
instance Has_borderwidth	 Message
instance Has_cursor		 Message
instance Has_font		 Message
instance Has_foreground		 Message
instance Has_height		 Message
instance Has_highlightbackground Message
instance Has_highlightcolor	 Message
instance Has_highlightthickness	 Message
instance Has_justify		 Message
instance Has_padx		 Message
instance Has_pady		 Message
instance Has_relief		 Message
instance Has_takefocus		 Message
instance Has_text		 Message
instance Has_underline		 Message
instance Has_width		 Message
 


messageNames :: [ConfigName]
messageNames = 
 valids $ [background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl]

message :: [Conf Message] -> GUI Message
message = mkPWidget  T.message messageNames
\end{code}


-- Button  ------------------------------------

\begin{code} 
type Button  = PrimWidget T.Button

instance Has_activebackground	 Button
instance Has_activeforeground	 Button
instance Has_anchor		 Button
instance Has_background		 Button
instance Has_bitmap		 Button
instance Has_borderwidth	 Button
instance Has_cursor		 Button
instance Has_font		 Button
instance Has_foreground		 Button
instance Has_height		 Button
instance Has_highlightbackground Button
instance Has_highlightcolor	 Button
instance Has_highlightthickness	 Button
instance Has_justify		 Button
instance Has_active_state	 Button
instance Has_padx		 Button
instance Has_pady		 Button
instance Has_relief		 Button
instance Has_takefocus		 Button
instance Has_text		 Button
instance Has_underline		 Button
instance Has_width		 Button
instance Has_wraplength		 Button



buttonNames :: [ConfigName]
buttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl]


button :: [Conf Button] -> GUI Button
button = mkPWidgetAct  T.button buttonNames
\end{code}

-- Checkbutton --------------------------------

\begin{code} 
type Checkbutton = PrimWidget T.Checkbutton

instance Has_activebackground	 Checkbutton
instance Has_activeforeground	 Checkbutton
instance Has_anchor		 Checkbutton
instance Has_background		 Checkbutton
instance Has_bitmap		 Checkbutton
instance Has_borderwidth	 Checkbutton
instance Has_cursor		 Checkbutton
instance Has_font		 Checkbutton
instance Has_foreground		 Checkbutton
instance Has_height		 Checkbutton
instance Has_highlightbackground Checkbutton
instance Has_highlightcolor	 Checkbutton
instance Has_highlightthickness	 Checkbutton
instance Has_indicatoron	 Checkbutton
instance Has_justify		 Checkbutton
instance Has_active_state	 Checkbutton
instance Has_padx		 Checkbutton
instance Has_pady		 Checkbutton
instance Has_relief		 Checkbutton
instance Has_selectcolor	 Checkbutton
instance Has_takefocus		 Checkbutton
instance Has_text		 Checkbutton
instance Has_underline		 Checkbutton
instance Has_width		 Checkbutton
instance Has_wraplength		 Checkbutton


checkbuttonNames :: [ConfigName]
checkbuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl,selectcolor vl]


checkbutton :: [Conf Checkbutton] -> GUI Checkbutton
checkbutton = mkPWidgetAct T.checkbutton checkbuttonNames

instance Has_checkVal Checkbutton where
 setCheck w = T.setCheck (widgetPrim w)

getCheck :: Checkbutton -> IO Bool
getCheck w = T.getCheck (widgetPrim w)
\end{code}

-- The Has_checkVal class ----------------------

\begin{code}
class WidgetItem w => Has_checkVal w where
 setCheck :: w -> Bool -> IO ()

checkVal :: Has_checkVal w => Bool -> Conf w
checkVal b = confIO  $ flip setCheck b

checkValB :: Has_checkVal w => Behavior Bool -> Conf w
checkValB b = confBh checkVal b
\end{code}

-- Radiobutton ---------------------------------

\begin{code} 
type Radiobutton  = PrimWidget T.Radiobutton

instance Has_activebackground	 Radiobutton
instance Has_activeforeground	 Radiobutton
instance Has_anchor		 Radiobutton
instance Has_background		 Radiobutton
instance Has_bitmap		 Radiobutton
instance Has_borderwidth	 Radiobutton
instance Has_cursor		 Radiobutton
instance Has_font		 Radiobutton
instance Has_foreground		 Radiobutton
instance Has_height		 Radiobutton
instance Has_highlightbackground Radiobutton
instance Has_highlightcolor	 Radiobutton
instance Has_highlightthickness	 Radiobutton
instance Has_indicatoron	 Radiobutton
instance Has_justify		 Radiobutton
instance Has_active_state	 Radiobutton
instance Has_padx		 Radiobutton
instance Has_pady		 Radiobutton
instance Has_relief		 Radiobutton
instance Has_selectcolor	 Radiobutton
instance Has_takefocus		 Radiobutton
instance Has_text		 Radiobutton
instance Has_underline		 Radiobutton
instance Has_width		 Radiobutton
instance Has_wraplength		 Radiobutton
instance Has_useRadio		 Radiobutton



radiobuttonNames :: [ConfigName]
radiobuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl,selectcolor vl]


radiobutton :: [Conf Radiobutton] -> GUI Radiobutton
radiobutton = mkPWidgetAct T.radiobutton radiobuttonNames
\end{code}

-- Menubutton ------------------------------------------------

\begin{code}
type Menubutton  = PrimWidget T.Menubutton

instance Has_activebackground	 Menubutton
instance Has_activeforeground	 Menubutton
instance Has_anchor		 Menubutton
instance Has_background		 Menubutton
instance Has_bitmap		 Menubutton
instance Has_borderwidth	 Menubutton
instance Has_cursor		 Menubutton
instance Has_font		 Menubutton
instance Has_foreground		 Menubutton
instance Has_height		 Menubutton
instance Has_highlightbackground Menubutton
instance Has_highlightcolor	 Menubutton
instance Has_highlightthickness	 Menubutton
instance Has_justify		 Menubutton
instance Has_active_state 	 Menubutton
instance Has_padx		 Menubutton
instance Has_pady		 Menubutton
instance Has_relief		 Menubutton
instance Has_takefocus		 Menubutton
instance Has_text		 Menubutton
instance Has_underline		 Menubutton
instance Has_width		 Menubutton
instance Has_wraplength		 Menubutton
instance Has_use_menu 		 Menubutton



menubuttonNames :: [ConfigName]
menubuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl]

menubutton :: [Conf Menubutton] -> GUI Menubutton
menubutton = mkPWidget T.menubutton menubuttonNames
\end{code}

-- Radio --------------------------------------

We create a radio object, using mkRadio, that all radiobuttons in a group 
share. This sets them as a group and guarantees that only one of the buttons
may be set at a time.

The Radio itself is implemented as a String name for the group variable 
in tcl-tk, the GUIInfo, and a reference containing the currently selected
element of the group, and a map from element names to actual button names.

\begin{code}
data Radio a = Radio String GUIInfo (IORef (Maybe a,[(a,T.WPath)]))

mkRadio :: Eq a => Maybe a -> GUI (Radio a)
mkRadio mb = withGUIInfo $ \gui -> do
 ref <- newIORef (mb,[])
 n <- T.tcl_newName gui
 let nm = "haskell_radio-"++show n
 return $ Radio nm gui ref

-- We set the initial value of the radio using setRadio.

setRadio :: Eq a => Radio a -> a -> GUI ()
setRadio r v = liftIO $ setRadio' r v

-- We can also set the value of the radio through a listener.

radioInput :: Eq a => Radio a -> Listener a
radioInput r = mkL (setRadio' r)

-- to really set we lookup the actual widget name associated with 
-- the value

setRadio' :: Eq a => Radio a -> a -> IO ()
setRadio' (Radio s g ref) v = do
 (_,fm) <- readIORef ref
 writeIORef ref (Just v,fm)
 case lookup v fm of
  Nothing -> return ()
  Just n -> setR s g n

setR :: String -> GUIInfo -> T.WPath -> IO ()
setR s g n = T.tcl_ g ["set",s,n]

-- The collection of radio objects all share the Radio with useRadio. 
-- to implement this we tell the widget to use the radio variable, 
-- and to have a radio value equal to its path name. We then check
-- the current radio state, if this widget is supposed to be set then
-- we set the radio. We add the value and widget name to the lookup table,
-- and then add then on every input action we set the radio's IORef to
-- contain the relevant name. 	
class Has_Action w => Has_useRadio w where
 useRadio :: Eq a => Radio a -> a -> Conf w
 useRadio (Radio s g ref) id = confIO  $ \w -> do
  let pth = getWPath w
  cset w ["variable" T.%% s,"value" T.%% pth]
  (mb,fm) <- readIORef ref
  let cmp (a,_) (b,_) = if a == b then EQ else GT
  writeIORef ref (mb,insertOrd cmp const (id,pth) fm)
  when (mb == Just id) $ setR s g pth
  action w (mkL_ $ updIORef ref (\(mb,fm) -> (Just id,fm)))
  return ()
\end{code}


-- Scale -----------------------------------------------

\begin{code}
type Scale = PrimWidget T.Scale

instance Has_activebackground	 Scale
instance Has_background		 Scale
instance Has_borderwidth	 Scale
instance Has_cursor		 Scale
instance Has_font		 Scale
instance Has_foreground		 Scale
instance Has_highlightbackground Scale
instance Has_highlightcolor	 Scale
instance Has_highlightthickness	 Scale
instance Has_hor_orient		 Scale
instance Has_active_state	 Scale
instance Has_relief		 Scale
instance Has_sca_from 		 Scale
instance Has_sca_length 	 Scale
instance Has_sca_to 		 Scale
instance Has_takefocus		 Scale
instance Has_tickinterval 	 Scale
instance Has_troughcolor 	 Scale
instance Has_width		 Scale
instance Has_text Scale where
 text = wgt_label


scaleNames :: [ConfigName]
scaleNames = 
 valids $ [activebackground vl,
	   background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   font vl,justify vl,foreground vl]


vscale,hscale :: [Conf Scale] -> GUI Scale
vscale = mkPWidgetAct T.vscale scaleNames
hscale = mkPWidgetAct T.hscale scaleNames

scaleVal :: Int -> Conf Scale
scaleVal v = confIO  $ flip setScale v

scaleValB :: IntB -> Conf Scale
scaleValB v = confBh scaleVal v

setScale :: Scale -> Int -> IO ()
setScale w = T.setScale (widgetPrim w)

getScale :: Scale -> IO Int
getScale w  = T.getScale (widgetPrim w) 
\end{code}

-- Menu -------------------------------------------------

\begin{code} 
type Menu = PrimWidget MenuPrim 
 
instance Has_background  Menu
instance Has_borderwidth Menu
instance Has_cursor	 Menu
instance Has_relief	 Menu
instance Has_tearoff     Menu


menuNames :: [ConfigName]
menuNames = 
 valids $ [background vl]
\end{code}

make a menu, either as a child of another widget item 
(must be done this way with menu buttons), or just as 
a normal menu

\begin{code}
menu' :: WidgetItem w => w -> [Conf Menu] -> GUI Menu
menu' w cs = do
 nm <- withGUIInfo $ T.mkChildOf' (getWPath w)
 mkPrimWidget (\_ c g -> mkMenuPrim nm c g) menuNames cs

menu :: [Conf Menu] -> GUI Menu
menu cs = do
 nm <- withGUIInfo $ T.tcl_newWgtName
 m <- mkPrimWidget (\_ c g -> mkMenuPrim nm c g) menuNames cs
 return m
\end{code}

Make a widget use a menu

\begin{code}
class WidgetItem w => Has_use_menu w where
  use_menu   :: Menu -> Conf w
  use_menu m = confGUI' (identify "menu") $ \w -> do
		-- this makes sure the menu stays alive at least until
		-- the widget it has been added to is destroyed
	 	liftIO $ addFinaliserW w (readIORef (hideRef m) >> return ())
		csetB w ["menu" %% getWPath m]
\end{code}

Make a menu popup or vanish. A value of Just p, causes the menu to popup 
at position p. A value of Nothing causes the menu to vanish.
\begin{code}
popup :: Menu -> Maybe S.Point2 -> IO ()
popup m (Just (S.Point2XY a b)) = T.popup (theMen $widgetPrim m) (round a,round b)
popup m Nothing = T.popdown (theMen $ widgetPrim m)  

popupM :: Menu -> Bool -> IO ()
popupM m True = T.popupM (theMen $ widgetPrim m)
popupM m False = T.popdown (theMen $ widgetPrim m) 
\end{code}

-- Menu items -------------------------------------------------

make a menu item, given a String and value saying what type to create,
a menu to add to, a list of config options for the menu item, and
a position to add to 

\begin{code}
mkMenItem :: [ConfigName] 
	  -> String -> w -> Menu -> [Conf (MItem (T.MWidget w))] 
	  -> PlacePos Ident 
	  -> GUI (MItem (T.MWidget w))
mkMenItem validnms what w m cs n = do
 s <- getStyle
 withConfigs validnms s cs $ \ cs -> mkMItem what w (widgetPrim m) cs n

mkMenItemAct :: Has_Action (T.MWidget w) => 
	     [ConfigName] 
	  -> String -> w -> Menu -> [Conf (MItem (T.MWidget w))] 
	  -> PlacePos Ident 
	  -> GUI (MItem (T.MWidget w))
mkMenItemAct validnms what w m cs n = do
 s <- getStyle
 withConfigs validnms s cs $ \ cs -> mkMItemAct what w (widgetPrim m) cs  n
\end{code}

-- Cascade ---------------------------------------------------

We can make a cascading menu with mcascade'. This creates a button that 
displays a given menu when pressed.

\begin{code}
type MCascade     = MItem T.Cascade

instance Has_activebackground	 MCascade
instance Has_activeforeground	 MCascade
instance Has_background		 MCascade
instance Has_bitmap		 MCascade
instance Has_font		 MCascade
instance Has_foreground		 MCascade
instance Has_active_state	 MCascade
instance Has_underline		 MCascade
instance Has_use_menu		 MCascade
instance Has_text MCascade where
 text = wgt_label

mcascadeNames :: [ConfigName]
mcascadeNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,
	   font vl,foreground vl]

mcascade' :: Menu -> Menu -> [Conf MCascade] -> PlacePos Ident -> GUI MCascade
mcascade' m m' cs n = do
 m <- mkMenItem mcascadeNames "cascade" T.TkCB m cs n
 csetB m [use_menu m']
 return m
\end{code}

-- MButton ------------------------------------

\begin{code}
type MButton = MItem T.MButton

instance Has_activebackground	 MButton
instance Has_activeforeground	 MButton
instance Has_background		 MButton
instance Has_bitmap		 MButton
instance Has_font		 MButton
instance Has_foreground		 MButton
instance Has_active_state	 MButton
instance Has_underline		 MButton
instance Has_text MButton where
 text = wgt_label
 

mbuttonNames :: [ConfigName]
mbuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,
	   font vl,foreground vl]

mbutton' :: Menu -> [Conf MButton] -> PlacePos Ident -> GUI MButton
mbutton' = mkMenItemAct mbuttonNames "command" T.TkMBut
\end{code}

-- MCheckbutton --------------------------------

\begin{code} 
type MCheckbutton = MItem T.MCheckbutton

instance Has_activebackground	 MCheckbutton
instance Has_activeforeground	 MCheckbutton
instance Has_background		 MCheckbutton
instance Has_bitmap		 MCheckbutton
instance Has_font		 MCheckbutton
instance Has_foreground		 MCheckbutton
instance Has_indicatoron	 MCheckbutton
instance Has_active_state	 MCheckbutton
instance Has_selectcolor	 MCheckbutton
instance Has_underline		 MCheckbutton
instance Has_text MCheckbutton where
 text = wgt_label
instance Has_checkVal MCheckbutton where
 setCheck w b = T.setMCheck (mitem w) b


mcheckbuttonNames :: [ConfigName]
mcheckbuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,
	   font vl,foreground vl,selectcolor vl]

mcheckbutton' :: Menu -> [Conf MCheckbutton] -> PlacePos Ident 
              -> GUI MCheckbutton
mcheckbutton' m cs pos = do
 m <- mkMenItemAct mcheckbuttonNames "checkbutton" T.TkMChe m cs pos
 liftIO $ cset m ["offvalue" T.%% "False",
	          "onvalue"  T.%% "True",
	          "variable" T.%% getWPath m]
 return m

getMCheck :: MCheckbutton -> IO Bool
getMCheck w = T.getMCheck (mitem w) 
\end{code}

-- MSeparator -------------------------------------------------
\begin{code} 

type MSeparator  = MItem T.Separator
  
mseparator' :: Menu -> PlacePos Ident -> GUI MSeparator
mseparator' m n = mkMenItem [] "separator" T.TkSep m [] n

-- MRadiobutton ---------------------------------

type MRadiobutton = MItem T.MRadiobutton
 
instance Has_activebackground	 MRadiobutton
instance Has_activeforeground	 MRadiobutton
instance Has_background		 MRadiobutton
instance Has_bitmap		 MRadiobutton
instance Has_font		 MRadiobutton
instance Has_foreground		 MRadiobutton
instance Has_indicatoron	 MRadiobutton
instance Has_active_state	 MRadiobutton
instance Has_selectcolor	 MRadiobutton
instance Has_underline		 MRadiobutton
instance Has_useRadio		 MRadiobutton 
instance Has_text MRadiobutton where
 text = wgt_label


mradiobuttonNames :: [ConfigName]
mradiobuttonNames = 
 valids $ [activebackground vl,activeforeground vl,
	   background vl,
	   font vl,foreground vl,selectcolor vl]


mradiobutton' = mkMenItemAct mradiobuttonNames "radiobutton" T.TkMRB
\end{code}

-- Listbox ---------------------------------------------

\begin{code}
type Listbox = PrimWidget T.Listbox

instance Has_background		 Listbox
instance Has_foreground		 Listbox
instance Has_font		 Listbox
instance Has_borderwidth	 Listbox
instance Has_cursor		 Listbox
instance Has_relief		 Listbox
instance Has_width		 Listbox
instance Has_highlightbackground Listbox
instance Has_highlightcolor	 Listbox
instance Has_highlightthickness	 Listbox
instance Has_takefocus		 Listbox
instance Has_height		 Listbox
instance Has_selectbackground	 Listbox
instance Has_selectforeground	 Listbox
instance Has_selectborderwidth	 Listbox
instance Has_setgrid		 Listbox


listboxNames :: [ConfigName]
listboxNames = 
 valids $ [borderwidth vl,activeforeground vl,
	   background vl,
	   font vl,foreground vl,
   	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   selectcolor vl,selectbackground vl,selectborderwidth vl]


instance Has_useScroll Listbox where
 useScroll = useScrollW

instance XViewScroll Listbox where
 xviewPercent e = T.xview_ (widgetPrim e)
 xviewMoveTo e = T.xMoveTo_ (widgetPrim e)
 xviewScroll e s = T.xScroll_ (widgetPrim e) (fromScroll s)

instance YViewScroll Listbox where
 yviewPercent e = T.yview_ (widgetPrim e)
 yviewMoveTo e = T.yMoveTo_ (widgetPrim e)
 yviewScroll e s = T.yScroll_ (widgetPrim e) (fromScroll s)

listbox :: [Conf Listbox] -> GUI Listbox
listbox = mkPWidget T.listbox listboxNames

resetListbox :: Listbox -> [String] -> IO ()
resetListbox w = T.resetListbox (widgetPrim w)

insertLBox :: Listbox -> String -> PlacePos Int -> IO ()
insertLBox l s p =  T.insertListbox (widgetPrim l) (pos p) [s]
 where
   pos PlaceTop = T.LIndex 0
   pos PlaceBottom = T.LIndexEnd
   pos (PlaceBefore x) = T.LIndex x
   pos (PlaceAfter x) = T.LIndex (x + 1)

deleteLBox :: Listbox -> Int -> IO ()
deleteLBox l x = T.deleteListbox (widgetPrim l) (T.LIndex x) (T.LIndex x)
\end{code}

-- Scrollbars ------------------------------------------

vertical and horizontal scrollbars

\begin{code}
type Scrollbar = PrimWidget T.Scrollbar

instance Has_width		 Scrollbar
instance Has_highlightbackground Scrollbar
instance Has_highlightcolor	 Scrollbar
instance Has_highlightthickness	 Scrollbar
instance Has_takefocus		 Scrollbar
instance Has_borderwidth	 Scrollbar
instance Has_cursor		 Scrollbar
instance Has_relief		 Scrollbar
instance Has_background		 Scrollbar
instance Has_hor_orient		 Scrollbar
instance Has_troughcolor	 Scrollbar
instance Has_useScroll Scrollbar  where
 useScroll = useScrollS


scrollbarNames :: [ConfigName]
scrollbarNames = 
 valids $ [borderwidth vl,
	   background vl,
   	   highlightbackground vl,highlightcolor vl,highlightthickness vl
	   ]


vscroll,hscroll :: [Conf Scrollbar] -> GUI Scrollbar
vscroll = mkPWidget T.scrollbar  scrollbarNames
hscroll cs = mkPWidget  T.scrollbar scrollbarNames $ ori_c:cs
      where
	ori_c = "orient" %% "horizontal"
\end{code}

-- Scroll ---------------------------------------------------

Scrollbars must be connected to scrollable widgets. We do this using the 
Scroll type. This maintains a boolean to say whether we're doing vertical
or horizontal scrolling. It also has an IORef. The first element of the 
pair in the ref is the tcl-name of the scrollbar, the second is the 
tcl-name of the widget to be scrolled.

\begin{code}
data Scroll  = Scroll Bool (IORef (Maybe T.WPath,Maybe T.WPath))

mkScroll :: Bool -> GUI Scroll
mkScroll b = liftIO $ do
 ref <- newIORef (Nothing,Nothing)
 return $ Scroll b ref

-- We create vertical and horizontal scroll data using mkVScroll and mkHScroll.

mkVScroll :: GUI Scroll
mkVScroll = mkScroll True
 
mkHScroll :: GUI Scroll
mkHScroll = mkScroll False

-- We then make the scrollbar and scrollable widget share the scroll data with 
-- useScroll.

class Has_useScroll w where
 useScroll :: Scroll -> Conf w

-- when we add a scrollbar and widget to a the scroll item we add the name
-- to the IORef. When both names are filled in we connect the scrollbar
-- to the widget. We can therefore only ever add one scrollbar and one widget
-- to a scroll data item.

useScrollS :: Scroll -> Conf Scrollbar
useScrollS (Scroll b ref) = confGUI' (identify "scroll") $ \scr -> withGUIInfo $ \g -> do
   (mbs,mbw) <- readIORef ref
   let s = getWPath scr 
   case (mbs,mbw) of
     (Nothing,Just w) -> do     
        writeIORef ref (Just s,mbw)
        T.connectScr b s w g
     (Just _,_) -> return ()
     (Nothing,Nothing) -> writeIORef ref (Just s,Nothing)

useScrollW :: WidgetItem w => Scroll -> Conf w
useScrollW (Scroll b ref) = confGUI' (identify "scroll") $ \wgt -> withGUIInfo $ \g -> do
   (mbs,mbw) <- readIORef ref
   let w = getWPath wgt 
   case (mbs,mbw) of
     (Just s,Nothing) -> do     
        writeIORef ref (mbs,Just w)
        T.connectScr b s w g
     (_,Just _) -> return ()
     (Nothing,Nothing) -> writeIORef ref (mbs,Just w)
\end{code}

-- Entry -----------------------------------------------

simple single line text entry widgets

\begin{code}
type Entry = PrimWidget T.Entry

instance Has_background		 Entry
instance Has_borderwidth	 Entry
instance Has_cursor		 Entry
instance Has_password		 Entry
instance Has_font		 Entry
instance Has_foreground		 Entry
instance Has_highlightbackground Entry
instance Has_highlightcolor	 Entry
instance Has_highlightthickness	 Entry
instance Has_justify		 Entry
instance Has_readOnly		 Entry
instance Has_relief		 Entry
instance Has_takefocus		 Entry
instance Has_width		 Entry


entryNames :: [ConfigName]
entryNames = 
 valids $ [borderwidth vl,
	   background vl,foreground vl,justify vl,font vl,
   	   highlightbackground vl,highlightcolor vl,highlightthickness vl
	   ]


instance Has_useScroll Entry where
 useScroll = useScrollW

instance XViewScroll Entry where
 xviewPercent e = T.xview_ (widgetPrim e)
 xviewMoveTo e = T.xMoveTo_ (widgetPrim e)
 xviewScroll e s = T.xScroll_ (widgetPrim e) (fromScroll s)

instance Has_text Entry where
 text s = confPIO nullId $ \w -> T.setEntry w s

entry :: [Conf Entry] -> GUI Entry
entry = mkPWidget T.entry entryNames

getEntry :: Entry -> IO String
getEntry = T.getEntry . widgetPrim

listenEntry :: Listener String -> Conf Entry
listenEntry l = confPIO nullId $ \w -> do
 T.tclW_ w $ \pth -> ["bindtags "++ pth ++ " {Entry " ++ pth ++ " all}"]
 rm <- bind w (AskKey True Nothing []) (mapMaybeIOL (consume w) l)
 return ()
  where	
   consume :: T.Entry -> UserAction -> IO (Maybe String)
   consume w (CharKey True _ _) = fmap Just $ T.getEntry w
   consume w _ = return Nothing

\end{code}

-- Edit ------------------------------------------------

more powerful text edit areas

\begin{code} 
type Edit = PrimWidget T.Edit

instance Has_background		 Edit
instance Has_borderwidth	 Edit
instance Has_cursor		 Edit
instance Has_font		 Edit
instance Has_foreground		 Edit
instance Has_height		 Edit
instance Has_highlightbackground Edit
instance Has_highlightcolor	 Edit
instance Has_highlightthickness	 Edit
instance Has_readOnly		 Edit
instance Has_padx		 Edit
instance Has_pady		 Edit
instance Has_relief		 Edit
instance Has_selectbackground	 Edit
instance Has_selectborderwidth	 Edit
instance Has_selectforeground	 Edit
instance Has_setgrid		 Edit
instance Has_takefocus		 Edit
instance Has_width		 Edit
instance Has_wrap		 Edit
instance Has_focus 		 Edit

editNames :: [ConfigName]
editNames = 
 valids $ [borderwidth vl,
	   background vl,foreground vl,justify vl,font vl,
   	   highlightbackground vl,highlightcolor vl,highlightthickness vl,
	   selectcolor vl,selectbackground vl,selectborderwidth vl
	   ]

class WidgetItem w => Has_focus w where
 focus :: Conf w 
 focus = confGUI $ \w -> withGUIInfo $ \g -> 
	    T.tcl_ g $ ["focus",getWPath w]

instance Has_useScroll Edit where
 useScroll = useScrollW

instance XViewScroll Edit where
 xviewPercent e = T.xview_ (widgetPrim e)
 xviewMoveTo e = T.xMoveTo_ (widgetPrim e)
 xviewScroll e s = T.xScroll_ (widgetPrim e) (fromScroll s)

instance YViewScroll Edit where
 yviewPercent e = T.yview_ (widgetPrim e)
 yviewMoveTo e = T.yMoveTo_ (widgetPrim e)
 yviewScroll e s = T.yScroll_ (widgetPrim e) (fromScroll s)


instance Has_text Edit where
 text s = confIO  $ flip resetEdit s 

edit :: [Conf Edit] -> GUI Edit
edit cs = mkPWidget T.edit editNames cs

getEdit :: Edit -> IO String
getEdit w = T.getEdit (widgetPrim w)

getTagsAt :: Edit -> TIndex -> IO [Ident]
getTagsAt ed ti = fmap (map identify) $ T.getTagsAt (widgetPrim ed) ti

getSelectedTags :: Edit -> IO ([Ident],[Ident])
getSelectedTags ed = do
 ts1 <- getTagsAt ed (tindexTagFirst selectTagId) 
 ts2 <- getTagsAt ed (tindexTagLast selectTagId)
 return (ts1,ts2)
\end{code}

TIndex - indexes into text edit areas

To define a given point in an edit area we use the TIndex type.

data TIndex 
  deriving (Eq,Show)

This has constructor functions to define a point: 
at a given line number and column number (tindex), starting at 1, 1; 
at the start (tindexStart) or end (tindexEnd) of the text; 
at a particular mark (tindexMark); 
at the start (tindexTagFirst) or end (tindexTagLast) of a tag; 
or at a given offset from an index (tindexModMove).

The possible offsets are to the beginning (LineStart) or end of the current line (LineEnd); beginning (WordStart) or end (WordEnd) of the current word; moving by a given number of characters (ModChars); or moving by a given number of lines (ModLines).

data ModMove = LineStart | LineEnd | WordStart | WordEnd
             | ModChars Int | ModLines Int
  deriving (Eq,Show)

\begin{code}
tindex :: Int -> Int -> TIndex
tindexEnd :: TIndex
tindexStart :: TIndex
tindexMark :: Ident -> TIndex
tindexTagFirst :: Ident -> TIndex
tindexTagLast :: Ident -> TIndex
tindexModMove :: TIndex -> ModMove -> TIndex

tindex = TIndex
tindexEnd = TIndexEnd
tindexStart = TIndex 1 0
tindexMark = TIndexMark . getWPath'
tindexTagFirst = TIndexTagFirst . getWPath'
tindexTagLast = TIndexTagLast . getWPath'
tindexModMove = TModMove

toTIndex :: ((Int,Int),(Int,Int)) -> (TIndex,TIndex)
toTIndex (a,b) = (toTIndex' a,toTIndex' b)

toTIndex' :: (Int,Int) -> TIndex
toTIndex' (x,y) = T.TIndex x y

\end{code}

We can insert and delete text using these indices.
We can also reset the edit area.

\begin{code}
insertEdit :: Edit -> TIndex -> String -> IO ()
insertEdit w = T.insertEdit (widgetPrim w)

insertEditTagged :: Edit -> TIndex -> String -> [Ident] -> IO ()
insertEditTagged w i s ts =
 T.insertEditTagged (widgetPrim w) i s (map get ts)
  where
    get (IdentS s) = s

deleteEdit :: Edit -> TIndex -> TIndex -> IO ()
deleteEdit w = T.deleteEdit (widgetPrim w)

resetEdit :: Edit -> String -> IO ()
resetEdit w = T.resetEdit (widgetPrim w)
\end{code}

We can also get turn the index into a line/column pair

\begin{code}
fromTIndex :: Edit -> TIndex -> IO (Maybe (Int,Int))
fromTIndex w = T.fromTIndex (widgetPrim w)
\end{code}

We can tell the edit to copy cut and paste to the clipboard.
\begin{code}
copyClip = T.copyClipboard . widgetPrim
cutClip = T.cutClipboard . widgetPrim
pasteClip = T.pasteClipboard . widgetPrim
\end{code}

-- EditItem ----------------------------------------------------

An edit item is an item that we can place in an edit area, such
as an EditTag, or EditMark.
It has a unique Id, a reference holding specific values, and a mutable
list of finalisers.

\begin{code}

data EditItem a b = EditItem {
	itemId :: Ident,
	editRef :: IORef (Either a b),
	editFinal :: IORef [IO ()]
	}

useFinals :: EditItem a b -> IO ()
useFinals m@(EditItem {editFinal = ref}) = do
    vs <- readIORef ref
    sequence_ vs
    writeIORef ref []

setFinal :: EditItem a b -> IO () -> IO ()
setFinal (EditItem {editFinal = ref}) act = 
    updIORef ref (act:)

-- we can make edit items

mkEditItem :: b -> [T.Config] -> GUI (EditItem a b)
mkEditItem b cs = do
  id <- getIdent cs
  liftIO $ do
    ref <- newIORef (Right b)
    finals <- newIORef []
    return $ EditItem id ref finals

-- we can update edit items with an IO function that updates its state
 
setEditItem' :: EditItem a b 
	     -> (a -> IO (Either a b)) -> (b -> IO (Either a b)) -> IO ()
setEditItem' (EditItem {editRef = ref}) fa fb = do
 e <- readIORef ref
 e <- either fa fb e
 writeIORef ref e

setEditItem :: EditItem a b -> (a -> IO ()) -> (b -> IO (Either a b)) -> IO ()
setEditItem (EditItem {editRef = ref}) fa fb = do
 e <- readIORef ref
 either fa (\v -> do v <- fb v;writeIORef ref v) e 

\end{code}

-- EditTag -----------------------------------------------------

An EditTag can be used to alter the attributes or bind user input to a 
particular section of text. It is a type of edit item containing a 
tcl-tk tag when added, and until then a set of update actions to 
perform on the tag when it is created.

\begin{code}

type EditTag = EditItem T.Tag (Maybe (T.Tag -> IO ()))

instance Has_background	 EditTag
instance Has_borderwidth EditTag
instance Has_font	 EditTag
instance Has_foreground	 EditTag
instance Has_justify     EditTag
instance Has_relief      EditTag
instance Has_underline   EditTag
instance Has_wrap 	 EditTag

-- we can give it a special identifier

instance Has_useIdent    EditTag

-- We can make an edit tag using mkEditTag. 

mkEditTag :: [Conf EditTag] -> GUI EditTag
mkEditTag cs = withConfigs [] emptyConf cs $ \ cs -> do
 w <- mkEditItem (Just $ const $ return ())  cs
 liftIO $ cset w (filter (not . T.sameConfig ("useident" T.%% "")) cs)
 return w

-- A special form of edit tag is the selection edit tag. This represents the 
-- selected area of an edit widget. An edit widget may only have one of these.

selectEditTag :: [Conf EditTag] -> GUI EditTag
selectEditTag cs = mkEditTag ((useIdent $ selectTagId):cs)

selectTagId :: Ident
selectTagId = identify "sel"

-- we can set its indices
instance Has_withIndex (T.TIndex,T.TIndex) EditTag where
 setIndex t w = setEditTagIndex w t

-- an edit tag can have input bound to it. (See GUI.lhs for more on primAction)
instance Has_Input (GUI EditTag) where
 bindAction a l c = do 
  w <- c 
  withGUIDef $ \g -> 
	applyEdit (\w -> do bind w a (wrapIOL (primAction g) l);return ()) w
  return w

-- an edit tag is a widget item, so that it can be configured
instance WidgetItem EditTag where
 uniqueId = itemId
 cset w cs = applyEdit (flip cset cs) w

 -- to destroy an item, check first it its been added to an edit widget
 -- if so destroy it, if not run its finalisers.

 destroy w = setEditItem' w 
		(\w -> do destroy w;return $ Right Nothing)
		(const $ do useFinals w
			    return (Right Nothing)
		)
 addFinaliserW = setFinal

-- apply a given function to the tag in an edit tag. 
-- if its not yet been added to an edit widget store the function
applyEdit :: (T.Tag -> IO ()) -> EditTag -> IO ()
applyEdit f ed = 
 setEditItem ed f
  (return . Right . maybe Nothing (\act -> Just $ \w -> act w >> f w))

-- get the indices, if its not been added these are obviously empty 
getEditTagIndex :: EditTag -> IO (Maybe ((Int,Int),(Int,Int)))
getEditTagIndex (EditItem _ r _) = do
 e <- readIORef r
 either tagRange' (const $ return Nothing) e

-- we can set the indices of the tag.
setEditTagIndex :: EditTag -> Maybe (T.TIndex,T.TIndex) -> IO ()
setEditTagIndex e mb = applyEdit (flip setTag mb) e


-- we can add the edit tag to one, and only one, edit widget.
addEditTag :: EditTag -> Edit -> IO ()
addEditTag ei@(EditItem (IdentS s) ref fs) edit = do
 e <- readIORef ref
 case e of
  Left _ -> return ()
  Right op -> do
   -- if it's not yet been added add it. 
   -- check to see if it's the selection tag which is special
   t <- if s == "sel" then selectionTag edit else tag edit s 
   -- apply all the updates 
   maybe (return ()) ($ t) op
   -- add its finalisers to the finalisers for the tag
   addFinaliserW t (useFinals ei)
   -- update the edit item
   writeIORef ref $ Left t

-- get the tag's indices
tagRange' :: T.Tag -> IO (Maybe ((Int,Int),(Int,Int)))
tagRange' tg = do
  T.tagNextRange tg (T.TIndex 1 0) T.TIndexEnd 

-- move the tag's indices
setTag :: T.Tag -> Maybe (TIndex,TIndex) -> IO ()
setTag tg Nothing = T.tagRemove tg [T.TIndex 1 0,T.TIndexEnd]
setTag tg (Just (t1,t2)) = do
 T.tagRemove tg [T.TIndex 1 0,T.TIndexEnd]
 T.setTag tg [t1,t2]

selectionTag :: Edit -> IO T.Tag
selectionTag w = T.selectionTag (widgetPrim w)

tag :: Edit -> String -> IO T.Tag
tag w tid = T.tag' (widgetPrim w) tid [] []

setTag' :: Edit -> Ident -> Maybe (TIndex,TIndex) -> IO ()
setTag' ed (IdentS s) Nothing = do
 T.tagRemove' (widgetPrim ed) s [T.TIndex 1 0,T.TIndexEnd]
setTag' ed (IdentS s) (Just (a,b)) = do
 T.tagRemove' e s [T.TIndex 1 0,T.TIndexEnd]
 T.setTag' e s [a,b]
  where
   e = widgetPrim ed
\end{code}

-- Use Ident ---------------------------------------------------

Items with a given unique identifier

\begin{code}
class Has_useIdent w where
 useIdent :: Ident -> Conf w
 useIdent (IdentS s) = "useident" %% s

findIdent' :: [T.Config] -> Maybe Ident
findIdent' = listToMaybe . mapMaybe isIdent
 where
  isIdent c = 
    case T.configText c of
     ("useident",id) -> Just $ identify id
     _ -> Nothing
 
getIdent :: [T.Config] -> GUI Ident
getIdent ts = 
 maybe (fmap identify $ getUniqueName) return $ findIdent' ts
\end{code}

-- withIndex ------------------------------------------------

Elements that can have their indices set

\begin{code}
class WidgetItem w => Has_withIndex t w where
 setIndex :: Maybe t -> w -> IO ()

withIndex :: Has_withIndex t w => Maybe t -> Conf w
withIndex ti = confIO  $ setIndex ti

withIndexE :: Has_withIndex t w => Event (Maybe t) -> Conf w
withIndexE ev = 
 confGUI $ \w -> addListenerW ev (mkL $ flip setIndex w) w

withIndexB :: Has_withIndex t w => Behavior (Maybe t) -> Conf w
withIndexB b = confGUI $ \w -> setB' (\_ _ -> False) w withIndex b
\end{code}

-- EditMark ----------------------------------------------------

An EditMark is a mark that can be placed in an edit area. It moves around as
the text moves, and so is a way of marking important points in the text such 
as the beginning of a section. 

It consists of a tcl-tk mark once added to an edit area, or a maybe index 
to use until then.

\begin{code}
type EditMark = EditItem T.Mark (Maybe T.TIndex)

mkEditMark :: [Conf EditMark] -> GUI EditMark
mkEditMark cs = withConfigs [] emptyConf cs $ mkEditItem Nothing 

-- The insertion cursor in an edit widget is just a special type of edit mark. 

insertEditMark :: GUI EditMark
insertEditMark = mkEditMark [useIdent $ identify "insert"] 

-- an edit mark is a widget item
instance WidgetItem EditMark where
  uniqueId = itemId
  cset w _ = return ()
  destroy w = do setEditMarkIndex w Nothing
	         useFinals w
  addFinaliserW = setFinal

-- it can be given a unique identifier
instance Has_useIdent EditMark

-- we can set its index
instance Has_withIndex T.TIndex EditMark where
 setIndex t w = setEditMarkIndex w t

-- to get its index read its position.
getEditMarkIndex :: EditMark -> IO (Maybe (Int,Int))
getEditMarkIndex (EditItem _ ed _) = do
 m <- readIORef ed
 either (T.getMarkPos) (const $ return Nothing) m

-- to set its index, either 
setEditMarkIndex :: EditMark -> Maybe T.TIndex -> IO () 
setEditMarkIndex ed ti = do
 setEditItem ed (flip setMark ti) (const $ return $ Right ti) 

-- add the edit mark to one, and only one, edit widget
addEditMark :: EditMark -> Edit -> IO ()
addEditMark ei@(EditItem idn@(IdentS s) ref fins) edit = do
  e <- readIORef ref
  case e of
   Left m -> return ()
   Right ti -> do
    -- if its not already been added, connect its finalisers to the edit widget
    addFinaliserW edit (useFinals ei)
    -- if its an insertion cursor treat it specially, otherwise mark the point
    m <- if s == "insert" then return $insertionMark edit else mark edit idn ti
    writeIORef ref $ Left m  

-- make a tcl-tk mark
mark :: Edit -> Ident -> Maybe TIndex -> IO T.Mark
mark w (IdentS s) ti = maybe (return $ T.Mark s w') (T.mark' w' s) ti
 where
  w' = widgetPrim w

-- the insertion cursor
insertionMark :: Edit -> T.Mark
insertionMark w = T.insertionMark (widgetPrim w)

-- set the mark's position
setMark :: T.Mark -> Maybe TIndex -> IO ()
setMark m Nothing = T.removeMark  m
setMark m (Just ti) = T.setMark m ti

-- set the mark with given Id to given index
setMark' :: Edit -> Ident -> Maybe TIndex -> IO ()
setMark' edi (IdentS s) mb = setMark (T.Mark s $ widgetPrim edi) mb

editMarkIndex :: EditMark -> TIndex
editMarkIndex (EditItem i _ _) = tindexMark i
\end{code}

-- Canvas ------------------------------------------------------

\begin{code}
-- type Canvas = PrimWidget T.Canvas (from PrimWidgets)

instance Has_background		 Canvas
instance Has_borderwidth	 Canvas
instance Has_cursor		 Canvas
instance Has_height		 Canvas
instance Has_highlightbackground Canvas
instance Has_highlightcolor	 Canvas
instance Has_highlightthickness	 Canvas
instance Has_relief		 Canvas
instance Has_scrollregion	 Canvas
instance Has_takefocus		 Canvas
instance Has_width		 Canvas


canvasNames :: [ConfigName]
canvasNames = 
 valids $ [background vl,borderwidth vl,
	   highlightbackground vl,highlightcolor vl,highlightthickness vl]

instance Has_useScroll Canvas where
 useScroll = useScrollW

instance XViewScroll Canvas where
 xviewPercent e = T.xview_ (widgetPrim e)
 xviewMoveTo e = T.xMoveTo_ (widgetPrim e)
 xviewScroll e s = T.xScroll_ (widgetPrim e) (fromScroll s)

instance YViewScroll Canvas where
 yviewPercent e = T.yview_ (widgetPrim e)
 yviewMoveTo e = T.yMoveTo_ (widgetPrim e)
 yviewScroll e s = T.yScroll_ (widgetPrim e) (fromScroll s)

canvas :: [Conf Canvas] -> GUI Canvas
canvas cs = mkPWidget T.canvas canvasNames cs 
\end{code}

-- Canvas items ------------------------------------------------

make a canvas item in the current canvas scope. 
Note that this fails if there is no current canvas.

\begin{code}

withCanvas :: WidgetItem w => 
	      [ConfigName] -> [Conf w] 
           -> (T.Canvas -> [T.Config] -> GUIDef -> IO w) -> GUI w
withCanvas validnms cs f = do
 let mk cs g = 
	f (maybe (error "no canvas in scope") widgetPrim $ currentCanvas g)
          cs g
 s <- getStyle
 case getConfigs validnms s cs of
  (cs,act) -> do
    w <- withGUIDef (mk cs) 
    act w
    return w


-- COval ------------------------------------------------------- 


citemNames :: [ConfigName]
citemNames = 
 valids $ [fillColor vl]


type COval = CItem T.COva

instance Has_fillColor	COval
instance Has_outline	COval
instance Has_tags	COval
instance Has_width	COval


coval :: Vector2B -> [Conf COval] -> GUI COval
coval v cs = withCanvas citemNames cs $ mkCItem  Nothing mk 
 where
   mk = mapVectorV v "oval" T.TkCOva 


-- CLine ------------------------------------------------------

type CLine = CItem T.CLin


instance Has_fillColor	CLine
instance Has_tags	CLine
instance Has_width	CLine



cline :: [Point2B] -> [Conf CLine] -> GUI CLine
cline ps cs = withCanvas citemNames cs $ mkCItem  Nothing mk
 where
  mk = mapListV ps "line" T.TkCLin


-- CRectangle --------------------------------------------

type CRectangle = CItem T.CRec
 
instance Has_fillColor	CRectangle
instance Has_outline	CRectangle
instance Has_tags	CRectangle
instance Has_width	CRectangle

clineNames :: [ConfigName]
clineNames = 
 valids $ [fillColor vl]

crectangle :: Vector2B -> [Conf CRectangle] -> GUI CRectangle
crectangle v cs = withCanvas citemNames cs $ mkCItem  Nothing mk
 where
  mk = mapVectorV v "rectangle" T.TkCRec 

-- CArc --------------------------------------------------

type CArc = CItem T.CAr
 
instance Has_fillColor	CArc
instance Has_outline	CArc
instance Has_tags	CArc
instance Has_width	CArc

carc :: Vector2B -> IntB -> IntB -> [Conf CArc] -> GUI CArc
carc v start extent cs = withCanvas citemNames cs' $ mkCItem  Nothing mk
 where
  cs' = [confBh ("extent" %%) (lift1 show extent),
	 confBh ("start" %%) (lift1 show start)] ++ cs 
  mk = mapVectorV v "arc" T.TkCAr 


-- CPolygon -------------------------------------------------

type CPolygon = CItem T.CPol
 
instance Has_fillColor	CPolygon
instance Has_outline	CPolygon
instance Has_tags	CPolygon
instance Has_width	CPolygon

cpolygon :: [Point2B] -> [Conf CPolygon] -> GUI CPolygon
cpolygon ps cs = withCanvas citemNames cs $ mkCItem  Nothing mk
 where
  mk = mapListV ps "polygon" T.TkCPol 


-- CText -----------------------------------------------------
 
type CText = CItem T.CTex


instance Has_anchor	CText
instance Has_fillColor	CText
instance Has_font	CText
instance Has_justify	CText
instance Has_tags	CText
instance Has_text	CText
instance Has_width	CText


ctextNames :: [ConfigName]
ctextNames = 
 valids $ [fillColor vl,font vl,justify vl]



ctext :: [Conf CText] -> GUI CText
ctext cs = withCanvas ctextNames cs $ mkCItem  Nothing mk
 where
  mk = mapFreeV "text" T.TkCTex 

-- CBitmap ---------------------------------------------------
 
type CBitmap = CItem T.CBit
 
instance Has_selectbackground	CBitmap
instance Has_selectforeground	CBitmap
instance Has_selectborderwidth	CBitmap
instance Has_foreground		CBitmap
instance Has_justify		CBitmap
instance Has_anchor		CBitmap
instance Has_bitmap		CBitmap
instance Has_tags	        CBitmap



cbitmapNames :: [ConfigName]
cbitmapNames = 
 valids $ [foreground vl,justify vl,
	   selectcolor vl,selectbackground vl,selectborderwidth vl]


cbitmap :: [Conf CBitmap] -> GUI CBitmap
cbitmap cs = withCanvas cbitmapNames cs $ mkCItem  Nothing mk
 where
  mk = mapFreeV "bitmap" T.TkCBit 
\end{code}

-- CWindow ---------------------------------------------------

The function mkCWindow displays a standard panel item on a canvas.

\begin{code} 
type CWindow = CItem T.CWin

instance Has_anchor  CWindow
instance Has_justify CWindow
instance Has_tags    CWindow
instance Has_width   CWindow
instance Has_height  CWindow
\end{code}

to create one we pass a bind, raise and lower action for the canvas,
along with the identifying name of the panel item.

note that raise and lower are currently broken and should not be used.
Why? because canvas window items must be raised with a different 
mechanism from the rest of the canvas item set. we currently have no
way of working out which is the next lowest canvas window item.
needs some changes to DisplayCItem and the PileArray stuff, eg two piles
one for normal canvas items one for canvas windows. but we'd still need
to be able to disambiguate.

\begin{code}
cwindow  :: (Action -> Listener UserAction -> IO (IO ())) 
         -> (Maybe Ident -> IO ())
         -> (Maybe Ident -> IO ())
         -> Ident -> [Conf CWindow] -> GUI CWindow
cwindow bind raise lower (IdentS s) cs = 
 withCanvas [] cs' $ mkCItem  (Just $ TheWin bind raise lower) mk
 where
  raise _ = return ()
  lower _ = return ()
  mk = mapFreeV "window" T.TkCWin 
  cs' = ("window" %% s):cs
\end{code}
