module TclPrimCore where

-- This module defines the Widget type and the support definitions for the
-- five classes of widgets: window, panel, menu, canvas and tag.
 
import Char
import List
import TclGUI
import qualified TclTrie as T
import TclTrie (TrieObjV)
import IOExts
import Remover
import Utils
import Monad
import Maybe
import PlacePos

-- RGB Colors ------------------------------------------

rgb :: Int -> Int -> Int -> String
rgb r g b = "#" ++ hex r ++ hex g ++ hex b
      where
	hex n = hex1 (if n < 0 then 0 else if n > 255 then 255 else n)
	hex1 n = [hex2 (n `div` 16), hex2 (n `mod` 16)]
	hex2 n = if n<10 then chr(ord '0'+n) else chr(ord 'A'+n-10)


-- Timer Support ---------------------------------------

after :: Int -> IO () -> TclGUI (IO ())
after n p gui =
     do x <- tcl_newName gui
        remref <- newIORef undefined
        (tcl_cb,rm) <- 
            tcl_callback gui "" 
                 (\_-> do 
		    p
                    callRemoverRef remref) 
        writeIORef remref rm
	nm <- tcl gui ["after", show n, tcl_cb]
	cancel <- mkRemover $ tcl_ gui ["after cancel",nm]
	return (cancel >> callRemoverRef remref)

-- Widget ----------------------------------------------------

data Widget c w = TkWgt TkWOps c w

instance Eq (Widget a b) where
 w1 == w2 = wtag w1 == wtag w2


data TkWOps = TkWOps {
	wpath_ :: ! WPath,
	wtag_ :: ! WTag,
	cset_ :: ! ([Config] -> IO ()),
	cget_ :: ! (Config -> IO String),
	bindArgs_ :: ! ((Bool,Bool,TkEvent,String) 
			-> ([String]-> IO ())
			-> IO Remover),
	destroy_ :: ! (IO ()),
        trieObj_ :: ! TrieObjV,
	guiState_ :: ! GUIInfo
	}

type WPath  = String

type WTag   = String

type TkEvent = String

(%%) :: String -> String -> Config
s %% s2 = Tk_Generic s s2

(%#) :: String -> TclGUI () -> Config
s %# act = Tk_Action s act

parentWPath :: Widget c w -> WPath
parentWPath w = parentWPath' $ wpath w

parentWPath' :: WPath -> WPath
parentWPath' w =  
 case dropWhile (/= '.') $ reverse w of
   "." -> "."
   ('.':xs) -> reverse xs

wpath :: Widget c w -> WPath
wpath (TkWgt (TkWOps {wpath_ = nm}) _ _) = nm

wtag :: Widget c w -> WTag
wtag (TkWgt (TkWOps {wtag_ = nm}) _ _) = nm

cset' :: Widget c w -> [Config] -> IO ()
cset' (TkWgt (TkWOps {cset_ = cset}) _ _) cfgs = cset cfgs

cget' :: Widget c w -> Config -> IO String
cget' (TkWgt (TkWOps {cget_ = cget}) _ _) c = cget c

destroy :: Widget c w -> IO ()
destroy (TkWgt (TkWOps {destroy_ = destroy}) _ _) = destroy

bindArgs :: Widget c w -> (Bool,Bool,TkEvent,String) -> ([String] -> IO ()) 
	 -> IO (IO ())
bindArgs (TkWgt (TkWOps {bindArgs_ = bind}) _ _) = bind

trieObj :: Widget c w -> TrieObjV
trieObj (TkWgt (TkWOps {trieObj_ = obj}) _ _) = obj

getTclGUIInfo :: Widget c w -> GUIInfo
getTclGUIInfo (TkWgt (TkWOps {guiState_ = st}) _ _) = st

bindCommand :: Widget c w -> IO () -> IO (IO ())
bindCommand (TkWgt (TkWOps {trieObj_ = obj, cset_ = cset,
			    wpath_ = wpath,guiState_ = gui}) _ _)
            act = 
  bindAnAction "command" "" (const $ act) obj 
               (\s -> (cset ["command" %% s],cset ["command" %% "{}"])) 
               True gui

tclW :: Widget c w -> (WPath -> [String]) -> IO String
tclW w f = tcl (getTclGUIInfo w) $ f (wpath w)
 
tclW_ :: Widget c w -> (WPath -> [String]) -> IO ()
tclW_ w f = tcl_ (getTclGUIInfo w) $ f (wpath w)

tcl_append :: String -> String -> String
tcl_append "." child    = child
tcl_append parent child = parent++child

checkAlive :: Widget c w -> IO Bool
checkAlive (TkWgt (TkWOps {trieObj_ = obj}) _ _) = T.checkAlive obj

addFinaliserW :: Widget c w -> Remover -> IO ()
addFinaliserW (TkWgt (TkWOps {trieObj_ = obj}) _ _) = T.addFinaliserW obj

mkChildOf :: Widget c w -> IO WPath
mkChildOf w = do
 nm <- tcl_newWgtName (getTclGUIInfo w)
 return $ tcl_append (wpath w) nm

mkSibling :: Widget c w -> IO WPath
mkSibling w = do
 nm <- tcl_newWgtName (getTclGUIInfo w)
 return $ tcl_append (parentWPath w) nm


mkChildOf' :: WPath -> TclGUI WPath
mkChildOf' w gui = do
 nm <- tcl_newWgtName gui
 return $ tcl_append w nm

mkSibling' :: Widget c w -> TclGUI WPath
mkSibling' w gui = do
 nm <- tcl_newWgtName gui
 return $ tcl_append (parentWPath w) nm

{-
  when we bind an action to an event we create a callback that Tcl
  will refer to it by. We then bind the callback name to the event
  and TclGUI.hs (tcl_callback) deals with connecting the haskell 
  callback to the Tcl name. (Note that the remove action returned
  by tcl_callback is already idempotent (one shot action)).
  We want to be able to remove callbacks too. We add a finaliser to
  the widget so that the haskell callback is deleted when the widget is
  destroyed. We return an action that both deletes the haskell
  callback and unbinds the event.
  We only want this to happen once. So we use a remover ref, that
  is a idempotent (onceshot) remove action. We also update the binding. When
  an event binding is overridden we clear all the unbind remover refs
  so they can't interfere again, as they are no longer valid. When
  and event binding is added we just add the invalidation action
  to the TrieObj object. 
-}
 
bindAnAction :: String -> String -> ([String] -> IO ())
             -> TrieObjV -> (String -> (IO (),IO ()))
             -> Bool -> TclGUI Remover 
bindAnAction event args op obj mkBinds clearall gui = do 
 (s,rm) <- tcl_callback gui args op
 case mkBinds s of
  (bind,bindCleanUp) -> do
   bind
   rmref <- newIORef $ bindCleanUp
   rmold <- T.updBinding obj event s clearall 
                         (Just $  rm >> writeIORef rmref (return ()))
   maybe (return ()) id rmold 
   return $ callRemoverRef rmref >> rm

removeBind :: (String -> IO String) -> String -> IO ()
removeBind tke op = do
  ops <- tke ""
  let ops' =  map toCommand $ lines ops
  case filter (/= op) ops' of
   [] -> do tke "{}";return ()
   (x:xs) -> do tke $ unlines $ x:xs;return ()
 where
  toCommand s = "{" ++ s ++ "}"

-- WWidget -------------------------------------------------

type WWidget a = Widget WClass a

data WClass = TkW String

tcl_wwidget :: WPath -> [Config] -> String -> w -> TclGUI (WWidget w)
tcl_wwidget nm cfgs k w gui =
     do tov <- register gui nm
        let wgt = TkWgt (tcl_wops nm gui tov) (TkW nm) w
        let (cfgs',act) = tcl_configure cfgs  
	tcl_ gui [k, nm, cfgs']
        act (cset' wgt) tov gui
	return wgt

totcl_wwidget :: WPath -> w -> TclGUI (WWidget w)
totcl_wwidget nm w gui = do
 mb <- register gui nm
 return $ TkWgt (tcl_wops nm gui mb) (TkW nm) w 

tcl_wops :: String -> GUIInfo -> TrieObjV -> TkWOps
tcl_wops nm gui tov = TkWOps nm nm csetW cgetW bindArgsW destroy tov gui
      where
	csetW [] = return ()
	csetW cfgs = do
           let (cfgs',act) = tcl_configure cfgs
           tcl_ gui [nm, "configure", cfgs']
	   act csetW tov gui
	cgetW cfg = tcl gui [nm,"cget",'-':cstr]
		      where
			(cstr,_) = configText cfg

	destroy = do
	  b <- T.checkAlive tov
	  when b $ do
	    b <- runDeletes gui nm 
	    when b $
  	      tcl_ gui ["destroy",nm]	

	bindArgsW (brk,add,ev,args) a =
         bindAnAction ev args a tov mkBinds (not add) gui
          where
            mkBinds cb =  
		let op = bind_break_munge brk cb
		in (tcl_ gui [ "bind", nm, ev,addOrOverwrite add op ],
		    removeBind (\op -> tcl gui ["bind",nm,ev,op]) op)

-- WWidget -------------------------------------------------
 
type PWidget a = Widget PClass a

data PClass = TkP String

tcl_pwidget :: WPath -> [Config] -> String -> w -> TclGUI (PWidget w)
tcl_pwidget nm cfgs k w gui =
     do tov <- register gui nm
        let wgt = TkWgt (tcl_wops nm gui tov) (TkP nm) w
        let (cfgs',act) = tcl_configure cfgs  
	tcl_ gui [k, nm,cfgs']
        act (cset' wgt) tov gui
	return wgt

totcl_pwidget :: WPath -> w -> TclGUI (PWidget w)
totcl_pwidget nm w gui = do
 mb <- register gui nm
 return $ TkWgt (tcl_wops nm gui mb) (TkP nm) w 

tcl_pops :: String -> GUIInfo -> TrieObjV -> TkWOps
tcl_pops nm gui tov = TkWOps nm nm csetW cgetW bindArgsW destroy tov gui
      where
	csetW [] = return ()
	csetW cfgs = do
           let (cfgs',act) = tcl_configure cfgs
           tcl_ gui [nm, "configure", cfgs']
	   act csetW tov gui
	
	cgetW cfg = tcl gui [nm,"cget",'-':cstr]
		      where
			(cstr,_) = configText cfg

	destroy = do
	  b <- T.checkAlive tov
	  when b $ do
	    b <- runDeletes gui nm 
	    when b $
  	      tcl_ gui ["destroy",nm]	

	bindArgsW (brk,add,ev,args) a =
         bindAnAction ev args a tov mkBinds (not add) gui
          where
            mkBinds cb =  
		let op = bind_break_munge brk cb
		in (tcl_ gui [ "bind", nm, ev,addOrOverwrite add op ],
		    removeBind (\op -> tcl gui ["bind",nm,ev,op]) op)

raise :: PWidget a -> Maybe WPath -> IO ()
raise w sMb = tclW_ w $ \w -> ["raise " ++ w ++ " " ++ maybe "" id sMb]

lower :: PWidget a -> Maybe WPath -> IO ()
lower w sMb = tclW_ w $ \w -> ["lower " ++ w ++ " " ++ maybe "" id sMb]

-- MWidget -------------------------------------------------
 
type MWidget a = Widget MClass a

data MClass = TkM String (IO (Maybe Int))

type Menu   = WWidget Men
data Men    = TkMen

-- move a menu item by deleting it and replacing it in tcl land.
-- but we don't need to zap all the haskell state associated with it.
-- remove it from menu item list, calculate its new location and then
-- replace.


moveMItem :: Menu -> WTag -> PlacePos WTag -> IO ()
moveMItem m tg pos = moveMItem' m tg pos $ \i _ -> 
			mkconfigs (wpath m) (getTclGUIInfo m) i
              -- basic move function, note that mkconfigs is not very efficient
              -- frantk has something better, that relies on all options being
              -- set through frantk rather than directly

moveMItem' :: Menu -> WTag -> PlacePos WTag 
	   -> (Int -> String -> IO (String,String)) 
                      -- get the item name and config info
	   -> IO ()
moveMItem' m tg pos mkconfigs = do
 mb <- T.removeItemObj (trieObj m) tg
 case mb of 
  Nothing -> return ()
  Just ptg' -> do
   p <- getItemPos m pos
   T.insertItemObj (trieObj m) tg p
   ptg <- checkTearOff m ptg'
   p <- checkTearOff m p
   let nm = wpath m
       gui = getTclGUIInfo m
   removeAndReplace'' nm gui ptg p $ mkconfigs ptg tg
  
-- there is a bug in tcl8.0, at least under nt. If you delete a 
-- menu item, then the item after it becomes disabled. Removing
-- and replacing it seems to fix this problem. Odd but true.
   when (p > ptg) $ do
    tg2 <- T.atIndexItemObj (trieObj m) ptg'
    maybe (return ()) 
	  (\tg -> removeAndReplace'' nm gui ptg ptg $ mkconfigs ptg tg)
          tg2

removeAndReplace :: Menu -> Int -> Int -> IO ()
removeAndReplace m ptg nptg = 
  removeAndReplace' (wpath m) (getTclGUIInfo m) ptg nptg

-- when replacing an item, if it at the end of the menu, don't need
-- and we're placing it in it's new position, we're doing it for the
-- bug mentioned above. This ain't necessary with the last item.

removeAndReplace' :: WPath -> GUIInfo -> Int -> Int -> IO ()
removeAndReplace' nm gui ptg nptg = removeAndReplace'' nm gui ptg nptg $ 
  mkconfigs nm gui ptg
   -- see moveMItem for commens on mkconfigs

removeAndReplace'' :: WPath -> GUIInfo -> Int -> Int 
		   -> IO (String,String) -> IO ()
removeAndReplace'' nm gui ptg nptg mkconfigs = 
  if ptg /= nptg then 
   rem
  else do 
   sz <- lastMItem nm gui
   unless (ptg >= sz) rem
 where
  -- calculate all the current configuration options for the widget
  -- before deleting it. Then when redisplayed do so with its current
  -- configuration list.
  rem = do
   (typ,cfgs) <- mkconfigs
   tcl_ gui [nm,"delete",show ptg]
   tcl_ gui [nm,"insert",show nptg,typ,cfgs]

-- get all the configuration options using entrycget, then
-- make a new list of actions. Note that different types of
-- menu item have different configuration options.
-- not very efficient, frantk does this better, but relies
-- on all configs being set in frantk and not directly
mkconfigs :: WPath -> GUIInfo -> Int -> IO (String,String)
mkconfigs nm gui ptg = do
      t <- tcl gui [nm,"type",show ptg]
      let cs = convert t
      vs <- mapM (\s -> tcl gui [nm,"entrycget",show ptg,'-':s])
                 cs
      let mkc _ "" = ""
          -- note that haskell events need to be surrounded by brackets,
          -- as there is more than one word in the event, 
          -- but they are not in form returned by entrycget,
          mkc a@("command") b = "-" ++ a ++ " {" ++ b ++ "}"
          mkc a b = "-" ++ a ++ " " ++ b
      return (t,unwords $ zipWith mkc cs vs)
   where    
     convert "command" = button
     convert "separator" = all
     convert "radiobutton" = rnc ++ ["value"]
     convert "checkbutton" = rnc ++ ["offvalue","onvalue"]
     convert "cascade" = button ++ ["menu"]

     all = ["columnbreak","hidemargin"]
     button =  ["activebackground","activeforeground",
		"accelerator",
		"background","bitmap","command","font",
		"foreground","hidemargin","image","label",
		"state","underline"] ++ all
     rnc = button ++ 
	   ["variable","indicatoron","selectcolor","selectimage"]

		

getMItemLoc :: Menu -> WTag -> IO (Maybe Int)
getMItemLoc menu tag = do
		p <- T.indexItemObj (trieObj menu) tag 
		maybe (return Nothing) (fmap Just . checkTearOff menu) p

getItemPos :: Menu -> PlacePos WTag -> IO Int
getItemPos m PlaceTop = return 0
getItemPos m PlaceBottom = menuSize m
getItemPos m (PlaceBefore tg) = do
  p <- T.indexItemObj (trieObj m) tg
  case p of
   Nothing -> return 0
   Just p -> return p
getItemPos m (PlaceAfter tg) = do
 p <- T.indexItemObj (trieObj m) tg
 case p of
  Nothing -> menuSize m
  Just p -> return $ p + 1

menuSize :: Menu -> IO Int
menuSize m = menuSize' (trieObj m)

menuSize' :: TrieObjV -> IO Int
menuSize' t = T.sizeItems t

lastMItem :: WPath -> GUIInfo -> IO Int
lastMItem w g = do
 n <- tcl g [w,"index end"]
 case n of
  "none" -> return 0
  x -> return $ read x

checkTearOff' :: Menu -> IO Bool
checkTearOff' m = do
 t <- cget' m ("tearoff" %% "")
 return $ if t == "0" then False else True 

checkTearOff :: Menu -> Int -> IO Int
checkTearOff m p = do
 b <- checkTearOff' m
 if b then return $ p + 1
  else return $ p

-- create the haskell data for the mwidget
totcl_mwidget :: Menu -> WTag -> Int -> w -> IO (MWidget w)
totcl_mwidget men tag n w = do
 obj <- register gui tag
 mb <- T.indexItemObj menobj tag
 unless (isJust mb) (T.insertItemObj menobj tag n)
 let getItemLoc :: IO (Maybe Int)
     getItemLoc = getMItemLoc men tag
 let remItem :: IO (Maybe Int)
     remItem = T.removeItemObj menobj tag >>= 
			maybe (return Nothing)
			      (fmap Just . checkTearOff men)
 let wgt = TkWgt (tcl_mops getItemLoc remItem nm tag gui obj) 
	         (TkM nm getItemLoc) w
 return $! wgt
      where
	nm = wpath men
        menobj = trieObj men 
        gui = getTclGUIInfo men

-- create the tclhaskell mwidget
tcl_mwidget :: Menu -> [Config] -> String -> w -> Int -> IO (MWidget w)
tcl_mwidget m = tcl_mwidget' mk m
 where
  mk i _ = mkconfigs (wpath m) (getTclGUIInfo m) i

-- create the tclhaskell mwidget, but given a function to get config and
-- name info (for destroy)
tcl_mwidget' :: (Int -> String -> IO (String,String))
	     -> Menu -> [Config] -> String -> w -> Int -> IO (MWidget w)
tcl_mwidget' mkconfigs men cfgs k w n =
     do un <- tcl_newName gui
	let tag = nm ++ ".menuItem" ++ show un
	obj <- register gui tag
        T.insertItemObj menobj tag n
	let getItemLoc :: IO (Maybe Int)
	    getItemLoc = getMItemLoc men tag
	let remItem :: IO (Maybe Int)
	    remItem = T.removeItemObj menobj tag >>= 
			maybe (return Nothing)
			      (fmap Just . checkTearOff men)
 
        let wgt = TkWgt (tcl_mops' getItemLoc remItem nm tag gui obj mkconfigs)
			(TkM nm getItemLoc) w
        let (cfgs',act) = tcl_configure cfgs  
        mb <- getItemLoc
	tcl_ gui [ nm, "insert ", maybe "end" show mb, k, cfgs']
        act (cset' wgt) obj gui
	return wgt
      where
	nm = wpath men
        menobj = trieObj men 
        gui = getTclGUIInfo men

tcl_mops :: IO (Maybe Int) -> IO (Maybe Int)
	 -> String -> String 
         -> GUIInfo -> TrieObjV 
         -> TkWOps
tcl_mops getLoc remLoc nm tag gui obj = 
 tcl_mops' getLoc remLoc nm tag gui obj $ \i _ -> mkconfigs nm gui i

tcl_mops' :: IO (Maybe Int) -> IO (Maybe Int)
	 -> String -> String 
         -> GUIInfo -> TrieObjV 
	 -> (Int -> String -> IO (String,String))
         -> TkWOps
tcl_mops' getLoc remLoc nm tag gui obj mkconfigs = 
  TkWOps nm tag csetM cgetM bindArgsM destroy obj gui
      where
       csetM [] = return ()
       csetM cs = do
         i <- getLoc
	 maybeDo i $ \i ->  do
          let (cs',act) = tcl_configure cs
          tcl_ gui [nm, "entryconfigure", show i, cs']
	  act csetM obj gui

       cgetM cfg = do
        i <- getLoc
	maybe (return "") 
	      (\i -> tcl gui [nm, "entrycget", show i, '-':cstr])
	      i
          where
	   (cstr,_) = configText cfg
	
       destroy = do
	 b <- T.checkAlive obj
         when b $ do
 	  i <- remLoc
	  maybeDo i $ \i -> do
	    b <- runDeletes gui tag 
 	    when b $ tcl_ gui [nm,"delete",show i]

-- there is a bug in tcl8.0, at least under nt. If you delete a 
-- menu item, then the item after it becomes disabled. Removing
-- and replacing it seems to fix this problem. Odd but true.
            removeAndReplace'' nm gui i i $ mkconfigs i ""
       bindArgsM (brk,add,ev,args) w = fail "cannot bind menu widgets"


-- CWidget -------------------------------------------------

type CWidget a = Widget CClass a

data CClass = TkC String 

type CCoord = String

ccoord :: (Int,Int) -> String
ccoord (x,y) = show x ++ " " ++ show y

-- create cwidget haskell data, assuming we're creating the actual tcl
-- wigdet separtely 
totcl_cwidget :: PWidget w' -> w -> IO (CWidget w)
totcl_cwidget ww w = do
 i <- tcl_newName gui
 let tag = nm ++ ".childOfCanvas" ++ show i
 tov <- register gui tag
 return $ TkWgt (tcl_cops tag nm tov gui) (TkC nm) w
  where
    nm = wpath ww
    gui = getTclGUIInfo ww

-- draw a cwidget given the tclhaskell object, current coords, config info, 
-- and the name of the type of widget we wish to create.
tcl_mapcwidget :: CWidget w -> [CCoord] -> [Config] -> String -> IO () 
tcl_mapcwidget cw@(TkWgt _ (TkC nm) _) ps cfgs k = do
 let (cfgs',act) = tcl_configure cfgs
 i <- tcl gui $ [nm,"create",k] ++ ps ++ [cfgs']
 tcl_ gui [nm,"itemconfigure",i,"-tags","\"",wtag cw,
                          "[",nm,"itemcget",i,"-tags]\""]
 act (cset' cw) (trieObj cw) gui
 return ()
  where
   gui = getTclGUIInfo cw

-- create a cwidget
tcl_cwidget :: PWidget w' -> [CCoord] 
	    -> [Config] -> String -> w -> IO (CWidget w)
tcl_cwidget c ps cfgs k w = do
    w <- totcl_cwidget c w 
    tcl_mapcwidget w ps cfgs k 
    return w

tcl_cops :: String -> String -> TrieObjV -> GUIInfo 
         -> TkWOps
tcl_cops tag nm tov gui = 
  TkWOps nm tag csetC cgetC bindArgsC destroy tov gui
      where
	csetC [] = return ()
	csetC cfgs = do
           let (cfgs',act) = tcl_configure cfgs  
	   tcl_ gui [nm, "itemconfigure", tag, cfgs']
	   act csetC tov gui

	cgetC cfg = tcl gui [nm, "itemcget", tag, '-':cstr]
		      where
			(cstr,_) = configText cfg
	 
        destroy = do
	 b <- T.checkAlive tov
         when b $ do
	   b <- runDeletes gui tag
 	   when b $ tcl_ gui [nm, "delete", tag]
	   	   
	bindArgsC (brk,add,ev,args) a =
         bindAnAction ev args a tov mkBinds (not add) gui
          where
            mkBinds cb =  
		let op = bind_break_munge brk cb
		in (tcl_ gui [nm, "bind", tag, ev,addOrOverwrite add op ],
		    removeBind (\op -> tcl gui [nm,"bind",tag,ev,op]) op)

	

 
-- TWidget -------------------------------------------------

type TWidget a = Widget TClass a

data TClass    = TkT String TagId

type TagId     = String
 
tcl_tgwidget :: PWidget w' -> TagId -> String -> [Config] -> w -> IO (TWidget w)
tcl_tgwidget e ti indx cs w =
     do 
        let nm = wpath e
	let wtag = nm ++ ".tagof" ++ ti
        tov <- register gui wtag
	let tg = TkWgt (tcl_tgops wtag nm ti tov gui) (TkT nm ti) w 
        unless (null indx) $ tcl_ gui [nm,"tag add",ti,indx]
	cset' tg cs
	return tg
  where
   gui = getTclGUIInfo e

totcl_tgwidget :: PWidget w' -> TagId -> w -> IO (TWidget w)
totcl_tgwidget ww ti w = do
  let wtag = nm ++ ".tagof" ++ ti
  tov <- register gui wtag
  let tg = TkWgt (tcl_tgops wtag nm ti tov gui) (TkT nm ti) w 
  return tg
 where
  gui = getTclGUIInfo ww
  nm = wpath ww

tcl_tgops :: WTag -> WPath -> TagId -> TrieObjV -> GUIInfo -> TkWOps
tcl_tgops wtag nm ti tov gui = 
 TkWOps nm wtag csetTg cgetTg onArgsTg destroy tov gui
      where
	csetTg [] = return ()
	csetTg cfgs = do
                let (cfgs',act) = tcl_configure cfgs 
		tcl_ gui [nm, "tag configure", ti, cfgs']
	 	act csetTg tov gui

	cgetTg cfg = tcl gui [nm, "tag cget", ti, '-':cstr]
		      where
			(cstr,_) = configText cfg
	 
	destroy = do
	   b <- T.checkAlive tov
	   when b $ do
	     b <- runDeletes gui wtag
	     when b $ tcl_ gui [nm,"tag delete",ti]

	onArgsTg (brk,add,ev,args) a =
         bindAnAction ev args a tov mkBinds (not add) gui
          where
            mkBinds cb =  
		let op = bind_break_munge brk cb
		in (tcl_ gui [nm, "tag bind", show ti, ev,addOrOverwrite add op ],
		    removeBind (\op -> tcl gui [nm,"tag bind",show ti,ev,op]) op)

-- EWidget -------------------------------------------------

type EWidget a = Widget EClass a

data EClass    = TkE WPath WTag
 
tcl_ewidget :: PWidget w' -> WPath -> String -> [Config] -> w -> IO (EWidget w)
tcl_ewidget e wtag indx cs w =
     do 
        let nm = wpath e
        tov <- register gui wtag
	let tg = TkWgt (tcl_eops nm wtag tov gui) (TkE nm wtag) w
        let (cs',act) = tcl_configure cs  
        tcl_ gui [nm,"window create",indx,cs']
	act (cset' tg) tov gui
	return tg
  where
   gui = getTclGUIInfo e

totcl_ewidget :: PWidget w' -> WPath -> w -> IO (EWidget w)
totcl_ewidget ww wtag w = do
  tov <- register gui wtag
  let tg = TkWgt (tcl_eops nm wtag tov gui) (TkE nm wtag) w 
  return tg
 where
  gui = getTclGUIInfo ww
  nm = wpath ww

tcl_eops :: WPath -> WTag -> TrieObjV -> GUIInfo -> TkWOps
tcl_eops wpath wtag tov gui = 
 TkWOps wpath wtag csetTg cgetTg onArgsTg destroy tov gui
      where
	csetTg [] = return ()
	csetTg cs = do
                let (cs',act) = tcl_configure cs  
		tcl_ gui [wpath, "window configure", wtag, cs']
	 	act csetTg tov gui
	cgetTg cfg = tcl gui [wpath, "window cget", wtag, '-':cstr]
		      where
			(cstr,_) = configText cfg
	 
	destroy = do
	   b <- T.checkAlive tov
	   when b $ do
	     b <- runDeletes gui wtag
	     when b $ tcl_ gui ["destroy",wtag]

	onArgsTg (brk,add,ev,args) a = 
         bindAnAction ev args a tov mkBinds (not add) gui
          where
            mkBinds cb =  
		let op = bind_break_munge brk cb
		in (tcl_ gui ["bind",wtag, ev,addOrOverwrite add op ],
		    removeBind (\op -> tcl gui ["bind",wtag,ev,op]) op)

-- Generic Canvas Operations -------------------------------

moveObject :: CWidget w -> (Int,Int) -> IO ()
moveObject w@(TkWgt _ (TkC nm) _) c  =
	tcl_ (getTclGUIInfo w) [nm, "move",wtag w,ccoord c]

removeObject :: CWidget w -> IO ()
removeObject w@(TkWgt _ (TkC nm) _) =
	tcl_ (getTclGUIInfo w) [nm, "delete", wtag w]

scaleObject :: CWidget a -> (Int,Int) -> Double -> Double -> IO ()
scaleObject w@(TkWgt _ (TkC nm) _) (x,y) xs ys =
   tcl_ (getTclGUIInfo w) 
	[nm,"scale",wtag w,show x ++ " " ++ show y,show xs,show ys]

lowerObject :: CWidget w -> Maybe String -> IO ()
lowerObject w@(TkWgt _ (TkC nm) _) s =
 tcl_ (getTclGUIInfo w) $ [nm, "lower", wtag w] ++ maybe [] (\x -> [x])  s

raiseObject :: CWidget w -> Maybe String -> IO ()
raiseObject w@(TkWgt _ (TkC nm) _) s  =
 tcl_ (getTclGUIInfo w) $ [nm,"raise",wtag w] ++ maybe [] (\x -> [x])  s

bboxObjects :: [CWidget a] -> IO (Int,Int,Int,Int)
bboxObjects [] = return (0,0,0,0)
bboxObjects (w@(TkWgt _ (TkC nm) _):cws') = 
     do let cws = filter chk cws' 
	s <- tcl (getTclGUIInfo w) 
	         ([nm,"bbox", wtag w]++[wtag cw | cw<-cws])
	let ps = map parseInt (words s)
	case ps of
	  [a,b,c,d] -> return (a,b,c,d)
	  xs         -> return (0,0,0,0)
      where
	chk (TkWgt _ (TkC nm') _) = nm == nm'

getCoords :: CWidget w -> IO [(Int,Int)]
getCoords w@(TkWgt _ (TkC nm) _) =
     do	s <- tcl (getTclGUIInfo w) [nm, "coords",wtag w]
 	let ps = map (parseInt . takeWhile (/='.')) (words s)
	return (makeCoords ps)
      where
	makeCoords [] = []
	makeCoords [_] = error "getCoords:makeCoords"
	makeCoords (x:y:ss) = (x,y):makeCoords ss

setCoords :: CWidget w -> [(Int,Int)] -> IO ()
setCoords w@(TkWgt _ (TkC nm) _) ll =
	tcl_ (getTclGUIInfo w) ([nm, "coords",wtag w] ++ map ccoord ll)
 

-- Preparing for Widget Configurartion ----------------


tcl_configure :: [Config] -> (String,
			      ([Config] -> IO ()) -> TrieObjV -> TclGUI ())
tcl_configure cs = foldr config ("",\_ _ _ -> return ()) cs
 where
     config :: Config 
            -> (String,([Config] -> IO ()) -> TrieObjV -> TclGUI ())
            -> (String,([Config] -> IO ()) -> TrieObjV -> TclGUI ())  
     config (Tk_Action nm f) (s,a) = (s,op)
       where
	  op :: ([Config] -> IO ()) -> TrieObjV -> TclGUI ()
          op cset obj gui =
           do bindAnAction nm "" (\_-> f gui) obj 
			  (\cb -> (cset [nm %% cb],cset [nm %% "{}"]))
                          True gui
              a cset obj gui
     config c (s,a) = (" -" ++ tcl_config c ++ s ,a)


-- Config ----------------------------------------------------
 
data Config = Tk_Generic    String String 
	    | Tk_Action String (GUIInfo -> IO ())

identifyConfig :: Config -> String
identifyConfig (Tk_Generic nm _) = nm
identifyConfig (Tk_Action nm _) = nm

sameConfig :: Config -> Config -> Bool
sameConfig (Tk_Generic s1 _) (Tk_Generic s2 _) = s1 == s2
sameConfig (Tk_Action s1 _) (Tk_Generic s2 _) = s1 == s2
sameConfig _ _ = False

tcl_config :: Config -> String
tcl_config c =
	case configText c of
	  (act,arg) -> act ++ " " ++ arg
          
configText :: Config -> (String,String)
configText cfg =
        case cfg of
	  Tk_Generic          nm s -> (nm,s) 
          Tk_Action nm s -> (nm,"")

-- Munging Event Scripts -------------------------------
 
bind_break_munge :: Bool -> String -> String
bind_break_munge True  script = "{eval " ++ script ++ "; break}"
bind_break_munge False script = script

addOrOverwrite :: Bool -> String -> String
addOrOverwrite True ('{':xs) = "{+" ++ xs
addOrOverwrite False xs = xs

-- Protecting Strings -- only for static texts ---------
 
tcl_string :: String -> String
tcl_string s = "\"" ++ protect s ++ "\""
  where
    protect [] = []
    protect (x:xs) = x' ++ protect xs where
      x' = case x of
             '\n'       -> "\\n"
             '\t'       -> "\\t"
             '['        -> "\\["
             ']'        -> "\\]"
             '{'        -> "\\{"
             '}'        -> "\\}"
             '\\'       -> "\\\\"
             '\"'       -> "\\\""
             '$'        -> "\\$"
             otherwise  -> [x]