module TclPrimWidgets where

-- This module defines each of the individual TclHaskell widgets that
-- comes with TclHaskell. This is the primitive stuff without type 
-- classes.

import Char
import List
import IO
import TclGUI
import TclPrimCore
import Monad
import Maybe
import IOExts
import Remover
import Utils

-- packing widgets

isIn :: [TclPack] -> Maybe TclPack
isIn ps = find eq ps
 where
   eq (Tcl_Any "in" _) = True
   eq _ = False

handleIn :: [TclPack] -> WPath -> [String]
handleIn ps me = 
 case isIn ps of
  Just (Tcl_Any "in" x) | parentWPath' me /= x -> [";raise",me,x]
  _ -> []

gridAdd :: PWidget a -> [TclPack] -> IO ()
gridAdd w pi = 
 tclW_ w $ \w -> ["grid",w] ++ fmap fromTclPack pi ++
		 handleIn pi w
  
gridForget :: PWidget a -> IO ()
gridForget w = tclW_ w $ \w -> ["grid forget",w] 

packAdd :: PWidget a -> [TclPack] -> IO ()
packAdd w pi = tclW_ w $ \w -> ["pack",w] ++ fmap fromTclPack pi ++
			       handleIn pi w

packForget :: PWidget a -> IO ()
packForget w = tclW_ w $ \w -> ["pack forget ",w]

fromTclPack :: TclPack -> String
fromTclPack (Tcl_Any "" "") = ""
fromTclPack (Tcl_Any s1 s2) = "-" ++ s1 ++ " " ++ s2

data TclPack = Tcl_Any String String
 deriving Eq

-- Events ----------------------------------------------------

bind ::  (w -> (Bool,Bool,TkEvent,String) -> ([String] -> m ()) 
          -> m a)
     -> w -> TkEvent -> m () -> m a
bind bindArgs wgt e a = bindArgs wgt (False,False,e,"") (\_ -> a)

bindxy :: (w -> (Bool,Bool,TkEvent,String) -> ([String] -> m ()) 
           -> m a)
       -> w -> TkEvent -> ((Int,Int)-> m ()) -> m a
bindxy bindArgs wgt ev f = bindCoords bindArgs "xy" wgt ev f

bindXY ::  (w -> (Bool,Bool,TkEvent,String) -> ([String] -> m ()) 
            -> m a)
       -> w -> TkEvent -> ((Int,Int)-> m ()) -> m a
bindXY bindArgs wgt ev f = bindCoords bindArgs "XY" wgt ev f

bindCoords :: (w -> (Bool,Bool,TkEvent,String) -> ([String] -> m ()) 
               -> m a)
           -> String -> w -> TkEvent -> ((Int,Int)-> m ()) 
	   -> m a
bindCoords bindArgs prm_str wgt ev f = 
  bindArgs wgt (False,False,ev,prm_str)  (f . parseCoords)

parseCoords :: [String] -> Coord
parseCoords [x,y] = (parseInt x,parseInt y)
parseCoords _ = error "parse coords"

-- dialog boxes

getOpenFileName :: TclGUI (Maybe FilePath)
getOpenFileName gui =
     do fn <- tcl gui ["tk_getOpenFile"]
        if null fn
           then return Nothing
           else return (Just fn)

getSaveFileName :: TclGUI (Maybe FilePath)
getSaveFileName gui = do
        fn <- tcl gui ["tk_getSaveFile"]
        if null fn
           then return Nothing
           else return (Just fn)

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

type Window = WWidget Win
data Win    = TkTop

data Geometry =
	WinSz   (Int,Int)	    | -- size
	WinPn   (Int,Int)	    | -- position
	WinSzPn (Int,Int) (Int,Int)   -- size position
 deriving Eq
rootWin :: TclGUI Window
rootWin = totcl_wwidget "." TkTop

window' :: WPath -> [Config] -> TclGUI Window
window' nm cfgs = tcl_wwidget nm cfgs "toplevel" TkTop

window :: [Config] -> TclGUI Window
window cfgs gui = do
     do nm <- tcl_newWgtName gui
	window' nm cfgs gui

title :: Window -> String -> IO ()
title w s = tclW_ w $ \w -> ["wm title",w,tcl_string s]

geometry :: Window -> Geometry -> IO ()
geometry w g = tclW_ w $ \w -> ["wm geometry",w,geometry_string g]

geometry_string :: Geometry -> String
geometry_string (WinSz (x,y)) =        show x ++ "x" ++ show y
geometry_string (WinPn (x,y)) = "+" ++ show x ++ "+" ++ show y
geometry_string (WinSzPn sz pn) =
		geometry_string (WinSz sz) ++ geometry_string (WinPn pn)


showWindow,hideWindow,iconifyWindow :: Window -> IO ()
showWindow t = tclW_ t $ \t -> ["wm deiconify",t]
hideWindow t = tclW_ t $ \t -> ["wm withdraw",t]
iconifyWindow t = tclW_ t $ \t -> ["wm iconify",t]

getPointerLoc :: Window -> IO Coord
getPointerLoc w = fmap (parseCoords . words) $ tclW w $ \w -> ["winfo pointerxy",w]

getRootPointerLoc :: TclGUI Coord
getRootPointerLoc g = fmap (parseCoords . words) $ tcl g ["winfo pointerxy ."]

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

trapDeleteWindow :: Window -> IO () -> IO ()
trapDeleteWindow top p =
     do (tcl_cb,rm) <- tcl_callback gui "" (\_->p)
	addFinaliserW top rm
	tcl_ gui ["wm protocol", wpath top, "WM_DELETE_WINDOW", tcl_cb]
  where
    gui = getTclGUIInfo top


mkPWidget :: (WPath -> [Config] -> TclGUI w) 
	  -> Widget a b 
	  -> [Config]
	  -> IO w
mkPWidget f t cs = do
 let gui = getTclGUIInfo t
 nm <- mkChildOf t
 f nm cs gui
 
-- Message ---------------------------------------------

type Message = PWidget Messg
data Messg = TkMessg

message' :: WPath -> [Config] -> TclGUI Message
message' nm cs = tcl_pwidget nm cs "message" TkMessg

message :: Window -> [Config] -> IO Message
message = mkPWidget message'
 

-- Menu ------------------------------------------------
 
-- type Menu = WWidget Men	-- see TclCore
-- data Men  = TkMen
 
menu' :: WPath -> [Config] -> TclGUI Menu
menu' nm cfgs = tcl_wwidget nm cfgs' "menu" TkMen
 where
 cfgs' = case find (sameConfig c) cfgs of
          Nothing -> (c:cfgs)
          Just _ -> cfgs 
 c = "tearoff" %% "False"

menu :: Widget a b -> [Config] -> IO Menu
menu w cfgs = do
 nm <- mkChildOf w
 menu' nm cfgs gui
  where 
   gui = getTclGUIInfo w

popup :: Menu -> (Int,Int) -> IO ()
popup w (x,y) = tclW_ w $ \w -> ["haskell_popup",w,show x,show y]

popupM :: Menu -> IO ()
popupM m = tclW_ m $ \m -> [m,"post [winfo pointerx .] [winfo pointery .]"]

popdown :: Menu -> IO ()
popdown w = tclW_ w $ \w -> [w,"unpost"]

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

type Menubutton  = PWidget MB
data MB = TkMB
 
menubutton' :: WPath -> Maybe WPath -> [Config] -> TclGUI Menubutton
menubutton' nm ext cs = tcl_pwidget nm (mc ++ cs) "menubutton" TkMB
      where
	mc = maybe [] (\x -> ["menu" %% x]) ext

menubutton :: Window -> [Config] -> IO Menubutton
menubutton win cs = 
 mkPWidget (\path cs -> menubutton' path Nothing cs) win cs

-- Making menu item -----------------------------------------

mkMWidget :: String -> w
          -> Menu -> [Config] -> Int -> IO (MWidget w)
mkMWidget s w m cs i = tcl_mwidget m cs s w i 
 
-- Cascade ---------------------------------------------------

type Cascade     = MWidget CB
data CB = TkCB
  
cascade :: Menu -> Menu -> [Config] -> Int -> IO Cascade
cascade w w' cs = mkMWidget "cascade" TkCB w (mc:cs) 
      where
	mc = "menu" %% (wpath w')

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

type MButton = MWidget MBut
data MBut    = TkMBut
 
mbutton :: Menu -> [Config] -> Int -> IO MButton
mbutton = mkMWidget "command" TkMBut


-- MCheckbutton --------------------------------
 
type MCheckbutton = MWidget MChe
data MChe         = TkMChe
 
mcheckbutton :: Menu -> [Config] -> Int -> IO MCheckbutton
mcheckbutton w cs x =
     do c <- mkMWidget "checkbutton" TkMChe w cs x
	cset' c ["offvalue" %% "False",
		 "onvalue"  %% "True",
		 "variable" %% wtag c]
     	return c

getMCheck :: MCheckbutton -> IO Bool
getMCheck w =
     do s <- tclW w $ const [ "set", wtag w ]
	case s of
	  "True" -> return True
	  _      -> return False
 
setMCheck :: MCheckbutton -> Bool -> IO ()
setMCheck w b = tclW_ w $ const [ "set", wtag w, show b ]

varMCheck :: MCheckbutton -> String
varMCheck = wtag

-- Separator -------------------------------------------------
 
type Separator  = MWidget Sep
data Sep = TkSep
  
separator :: Menu -> Int -> IO Separator
separator w n = mkMWidget "separator" TkSep w [] n

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

type MRadiobutton = MWidget MRB
data MRB          = TkMRB
 
mradiobutton :: Menu -> [Config] -> Int -> IO MRadiobutton
mradiobutton = mkMWidget "radiobutton" TkMRB


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

data Radio = TkRad String GUIInfo (IORef [String])

radio :: [Radiobutton] -> TclGUI Radio
radio = tcl_radio

mradio :: [MRadiobutton] -> TclGUI Radio
mradio = tcl_radio

tcl_radio :: [Widget c w] -> TclGUI Radio
tcl_radio ws gui = do
     do	n <- tcl_newName gui 
	ref <- newIORef (map wtag ws)
	let nm = "haskell_radio-"++show n
	    rd = TkRad nm gui ref
	mapM_ (su nm) ws
	return rd
      where
	su nm w = cset' w ["variable" %% nm,"value" %% wtag w]

removeRadio :: Radio -> Widget a b -> IO ()
removeRadio (TkRad nm gui ref) r = do
 cset' r ["variable" %% ""]
 updIORef ref (\xs -> delete (wtag r) xs)

appendRadio :: Radio -> Widget a b -> IO ()
appendRadio (TkRad nm gui ref) r = do
 cset' r ["variable" %% nm,"value" %% wtag r]
 updIORef ref (\xs -> xs ++ [wtag r])

setRadio :: Radio -> Int -> IO ()
setRadio (TkRad nm gui ref) n = do
 xs <- readIORef ref
 if n + 1 > length xs then
   return ()
  else do
    tcl_ gui [ "set", nm, xs !! n]
    
getRadio :: Radio -> IO Int
getRadio (TkRad v gui ref) = do
 s <- tcl gui ["set",v]
 xs <- readIORef ref
 case findIndex (== s) xs of
  Nothing -> fail $ "Invalid radio element: " ++ s
  Just n -> return n

setRadio' :: Radio -> WTag -> IO ()
setRadio' (TkRad nm gui ref) t = tcl_ gui [ "set", nm, t]

getRadio' :: Radio -> IO WTag
getRadio' (TkRad v gui ref) = tcl gui ["set", v]

varRadio :: Radio -> String
varRadio (TkRad v _ ref) = v


-- Radiobutton ---------------------------------
 
type Radiobutton  = PWidget RB
data RB           = TkRB

radiobutton' :: WPath -> [Config] -> TclGUI Radiobutton
radiobutton' nm cs = tcl_pwidget nm cs "radiobutton" TkRB

radiobutton :: Window -> [Config] -> IO Radiobutton
radiobutton = mkPWidget radiobutton' 


-- Checkbutton --------------------------------
 
type Checkbutton = PWidget Che
data Che         = TkChe

checkbutton' :: WPath -> [Config] -> TclGUI Checkbutton
checkbutton' nm cs gui =
     do c <- tcl_pwidget nm cs "checkbutton" TkChe gui
	cset' c ["offvalue" %% "False",
		 "onvalue"  %% "True",
		 "variable" %% nm]
     	return c

checkbutton :: Window -> [Config] -> IO Checkbutton
checkbutton = mkPWidget checkbutton'

getCheck :: Checkbutton -> IO Bool
getCheck w =
     do s <- tclW w $ \w -> ["set", w ]
	case s of
	  "True" -> return True
	  _      -> return False
 
setCheck :: Checkbutton -> Bool -> IO ()
setCheck w b = tclW_ w $ \w -> [ "set", w, show b ]
 
varCheck :: Checkbutton -> String
varCheck w = wpath w

-- Button  ------------------------------------
 
type Button  = PWidget But
data But     = TkBut

button' :: WPath -> [Config] -> TclGUI Button
button' nm cs = tcl_pwidget nm (cs) "button" TkBut

button :: Window -> [Config] -> IO Button
button = mkPWidget button' 

-- Frame -----------------------------------------------
 
type Frame = PWidget Fra
data Fra   = TkFra
  
frame' :: WPath -> [Config] -> TclGUI Frame
frame' nm cs = tcl_pwidget nm (cs) "frame" TkFra

frame :: Widget a b -> [Config] -> IO Frame
frame = mkPWidget frame'

-- Label -----------------------------------------------
 
type Label = PWidget Lab
data Lab   = TkLab
 
label' :: WPath -> [Config] -> TclGUI Label
label' nm cs = tcl_pwidget nm (cs) "label" TkLab

label :: Window -> [Config] -> IO Label
label = mkPWidget label'

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

type Scale = PWidget Sca
data Sca = TkSca

vscale', hscale' :: WPath -> [Config] -> TclGUI Scale
vscale' nm cs = tcl_pwidget nm cs' "scale" TkSca
      where
	cs'  = cs
hscale' nm cs = tcl_pwidget nm cs' "scale" TkSca
      where
	cs'  = ("orient" %% "horizontal"):cs

vscale,hscale :: Window -> [Config] -> IO Scale
vscale = mkPWidget vscale'
hscale = mkPWidget hscale'

getScale :: Scale -> IO Int
getScale w =
    do s <- tclW w $ \w -> [w,"get"]
       return (parseInt s)

setScale :: Scale -> Int -> IO ()
setScale w i = tclW_ w $ \w -> [w,"set", show i]

-- Scanable --------------------------------------------

scanMark :: Widget a b -> Int -> Int -> IO ()
scanMark w x y = tclW_ w $ \w -> [w,"scan mark",show x,show y]

scanDrag :: Widget a b -> Int -> Int -> IO ()
scanDrag w x y = tclW_ w $ \w -> [w,"scan dragto ",show x,show y]

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

type Listbox = PWidget Lis
data Lis     = TkLis 

listbox' :: WPath -> [Config] -> TclGUI Listbox
listbox' nm cs = tcl_pwidget nm cs "listbox" TkLis 

listbox :: Window -> [Config] -> IO Listbox
listbox = mkPWidget listbox'

data LIndex = LIndex Int | LIndexActive | LIndexAnchor | LIndexEnd 
            | LIndexAt ! Int ! Int | LFree String

showIndex :: LIndex -> String
showIndex (LIndex n) = show n
showIndex LIndexActive = "active"
showIndex LIndexAnchor = "anchor"
showIndex LIndexEnd = "end"
showIndex (LIndexAt x y) = "@" ++ show x ++ "," ++ show y

getListboxSelection :: Listbox -> IO [Int]
getListboxSelection w =
     do sel_str <- tclW w $ \w -> [w,"curselection"]
	return (map parseInt (words sel_str))

getListboxEntries :: Listbox -> LIndex -> LIndex -> IO [String]
getListboxEntries l x y = 
 fmap words $ tclW l $ \w -> [w,"get",showIndex x,showIndex y]

getListboxSize :: Listbox -> IO Int
getListboxSize l = fmap parseInt $ tclW l $ \w -> [w,"size"]

listboxScanMark :: Listbox -> Int -> Int -> IO ()
listboxScanMark w x y = tclW_ w $ \w -> [w,"scan mark",show x,show y]

listboxScanDrag :: Listbox -> Int -> Int -> IO ()
listboxScanDrag w x y = tclW_ w $ \w -> [w,"scan dragto ",show x,show y]

listboxMoveToSee :: Listbox -> LIndex -> IO ()
listboxMoveToSee l n = tclW_ l $ \w -> [w,"see",showIndex n]

insertListbox :: Listbox -> LIndex -> [String] -> IO ()
insertListbox l x xs = tclW_ l $ \w -> [w,"insert",showIndex x] ++ xs

deleteListbox :: Listbox -> LIndex -> LIndex -> IO ()
deleteListbox l x1 x2 = tclW_ l $ \w -> [w,"delete",showIndex x1,showIndex x2]

resetListbox :: Listbox -> [String] -> IO ()
resetListbox w ls =
     do tclW_ w $ \w -> [w,"delete","0","end;",w,"insert","end"] ++ ls

addListboxSelection :: Listbox -> LIndex -> LIndex -> IO ()
addListboxSelection l x1 x2 = 
 tclW_ l $ \w -> [w,"selection set",showIndex x1,showIndex x2]

clearListboxSelection :: Listbox -> LIndex -> LIndex -> IO ()
clearListboxSelection l x1 x2 = 
  tclW_ l $ \w -> [w,"selection clear",showIndex x1,showIndex x2]

setListboxSelectionAnchor :: Listbox -> LIndex -> IO ()
setListboxSelectionAnchor l x = 
  tclW_ l $ \w -> [w,"selection anchor",showIndex x]

-- Scrollable in X and Y

-- Scrollable Widget Class -----------------------------
{-
class (ScrollableX w,ScrollableY w) => Scrollable w 

class ScrollableX w where
 xview :: w -> IO (Double,Double)
 xviewSet :: w -> Int -> IO ()
 xMoveTo :: w -> Double -> IO ()
 xScroll :: w -> ScrollUnit -> IO ()
-}
data ScrollUnit = ScrollPages ! Int | ScrollUnits ! Int
 
fromScrollUnit :: ScrollUnit -> (String,Int)
fromScrollUnit (ScrollPages x) = ("pages",x)
fromScrollUnit (ScrollUnits x) = ("units",x)

showScrollUnit :: ScrollUnit -> String
showScrollUnit x =
 case fromScrollUnit x of
  (s,x) -> show x ++ " " ++ s
{-
class ScrollableY w where
 yview :: w -> IO (Double,Double)
 yviewSet :: w -> Int -> IO ()
 yMoveTo :: w -> Double -> IO ()
 yScroll :: w -> ScrollUnit -> IO ()
-}
xview_ :: Widget a b -> IO (Double,Double)
xviewSet_ :: Widget a b -> Int -> IO ()
xMoveTo_ :: Widget a b -> Double -> IO ()
xScroll_ :: Widget a b -> ScrollUnit -> IO ()

xview_ w = do
 s <- tclW w $ \w -> [w,"xview"]
 case words s of
  [a,b] -> return (read a,read b)
  _ -> fail $ "invalid return value for xview: " ++ s 

xviewSet_ w x = tclW_ w $ \w -> [w,"xview",show x]
xMoveTo_ w x = tclW_ w $ \w -> [w,"xview",show x]
xScroll_ w x = tclW_ w $ \w -> [w,"xview",showScrollUnit x]

yview_ :: Widget a b -> IO (Double,Double)
yviewSet_ :: Widget a b -> Int -> IO ()
yMoveTo_ :: Widget a b -> Double -> IO ()
yScroll_ :: Widget a b -> ScrollUnit -> IO ()

yview_ w = do
 s <- tclW w $ \w -> [w,"yview"]
 case words s of
  [a,b] -> return (read a,read b)
  _ -> fail $ "invalid return value for xview: " ++ s 
yviewSet_ w x = tclW_ w $ \w -> [w,"yview",show x]
yMoveTo_ w x = tclW_ w $ \w -> [w,"yview",show x]
yScroll_ w x = tclW_ w $ \w -> [w,"yview",showScrollUnit x]


-- Scrollbar -------------------------------------------
 
type Scrollbar = PWidget Scr
data Scr       = TkScr
 
scrollbar :: Window -> [Config] -> IO Scrollbar
scrollbar w cs = do
 nm <- mkChildOf w;scrollbar' nm cs (getTclGUIInfo w)

scrollbar' :: WPath -> [Config] -> TclGUI Scrollbar
scrollbar' nm cs = tcl_pwidget nm (cs) "scrollbar" TkScr

connectScr :: Bool -> WPath -> WPath -> TclGUI ()
connectScr isV scr wgt gui = do
 tcl_ gui [wgt, "configure -" ++ char ++ "scrollcommand {",scr,"set}"]
 tcl_ gui [scr,"configure -command {",wgt,char ++ "view}"]
   where
    char = if isV then "y" else "x"

vscroll' :: WPath -> PWidget w -> [Config] -> IO Scrollbar
vscroll' nm w cs =
     do v <- scrollbar' nm (cmd_c:cs) gui
	tcl_ gui [wnm, "configure -yscrollcommand {",nm,"set}"]
	return v
      where
	cmd_c = "command" %% ("{"++wnm++" yview}")
	wnm = wpath w
        gui = getTclGUIInfo w

hscroll' :: WPath -> PWidget w -> [Config] -> IO Scrollbar
hscroll' nm w cs =
     do h <- scrollbar' nm (ori_c:cmd_c:cs) gui
	tcl_ gui [wnm, "configure -xscrollcommand {",nm,"set}"]
	return h
      where
	ori_c = "orient" %% "horizontal"
	cmd_c = "command" %% ("{"++wnm++" xview}")
	wnm   = wpath w
	gui = getTclGUIInfo w

vscroll :: PWidget w -> [Config] -> IO Scrollbar
hscroll :: PWidget w -> [Config] -> IO Scrollbar
vscroll p cs = do nm <- mkSibling p;vscroll' nm p cs
hscroll p cs = do nm <- mkSibling p;hscroll' nm p cs
		  
 
-- Canvas ----------------------------------------------
 
type Canvas  = PWidget Can
data Can     = TkCan
 
canvas' :: WPath -> [Config] -> TclGUI Canvas
canvas' nm cs = tcl_pwidget nm (cs) "canvas" TkCan

canvas :: Window -> [Config] -> IO Canvas
canvas w cs = do nm <- mkChildOf w;canvas' nm cs (getTclGUIInfo w)

citem_canvas :: CWidget a -> IO Canvas
citem_canvas w@(TkWgt _ (TkC nm) _) = do
 totcl_pwidget nm TkCan (getTclGUIInfo w)

type Coord = (Int,Int)

mkCWidget :: String -> w -> Canvas -> [CCoord] -> [Config] -> IO (CWidget w)
mkCWidget s w c crds cs = tcl_cwidget c crds cs s w

-- CImage -------------------------------------------------------

type CImage = CWidget CIm
data CIm = TkCIm

type Image = String

cimage :: Canvas -> Coord -> [Config] -> IO CImage
cimage c crd = cimage' c (ccoord crd)

cimage' :: Canvas -> CCoord -> [Config] -> IO CImage
cimage' c crd = mkCWidget "image" TkCIm c [crd]

-- COval -------------------------------------------------------
 
type COval = CWidget COva
data COva  = TkCOva
 
coval :: Canvas -> Coord -> Coord -> [Config] -> IO COval
coval c crd1 crd2  = coval' c (ccoord crd1) (ccoord crd2)

coval' :: Canvas -> CCoord -> CCoord -> [Config] -> IO COval
coval' c crd1 crd2  = mkCWidget "oval" TkCOva c [crd1,crd2]

-- CLine ------------------------------------------------------
 
type CLine = CWidget CLin
data CLin  = TkCLin
   
cline :: Canvas -> [Coord] -> [Config] -> IO CLine
cline c cs cfgs = cline' c (map ccoord cs) cfgs

cline' :: Canvas -> [CCoord] -> [Config] -> IO CLine
cline' = mkCWidget "line" TkCLin

-- CRectangle --------------------------------------------
 
type CRectangle = CWidget CRec
data CRec       = TkCRec
 
crectangle :: Canvas -> Coord -> Coord -> [Config] -> IO CRectangle
crectangle c crd1 crd2 = crectangle' c (ccoord crd1) (ccoord crd2)

crectangle' :: Canvas -> CCoord -> CCoord -> [Config] -> IO CRectangle
crectangle' c crd1 crd2 = mkCWidget "rectangle" TkCRec c [crd1,crd2]

-- CArc --------------------------------------------------
 
type CArc = CWidget CAr
data CAr  = TkCAr
 
carc :: Canvas -> Coord -> Coord -> [Config] -> IO CArc
carc c crd1 crd2 = carc' c (ccoord crd1) (ccoord crd2)

carc' :: Canvas -> CCoord -> CCoord -> [Config] -> IO CArc
carc' c crd1 crd2 = mkCWidget "arc" TkCAr c [crd1,crd2]

 
-- CPoly -------------------------------------------------
 
type CPoly = CWidget CPol
data CPol  = TkCPol
 

cpoly :: Canvas -> [Coord] -> [Config] -> IO CPoly
cpoly c cs cfgs = cpoly' c (map ccoord cs) cfgs

cpoly' :: Canvas -> [CCoord] -> [Config] -> IO CPoly
cpoly'  = mkCWidget "polygon" TkCPol 

-- CText -----------------------------------------------------
 
type CText = CWidget CTex
data CTex  = TkCTex
 
ctext :: Canvas -> Coord -> [Config] -> IO CText
ctext c crd = ctext' c (ccoord crd) 

ctext' :: Canvas -> CCoord -> [Config] -> IO CText
ctext' c crd = mkCWidget "text" TkCTex c [crd]

-- CBitmap ---------------------------------------------------
 
type CBitmap = CWidget CBit
data CBit    = TkCBit
 
cbitmap :: Canvas -> Coord -> [Config] -> IO CBitmap
cbitmap c crd = cbitmap' c (ccoord crd)

cbitmap' :: Canvas -> CCoord -> [Config] -> IO CBitmap
cbitmap' c crd = mkCWidget "bitmap" TkCBit c [crd]


-- CWindow ---------------------------------------------------
 
type CWindow = CWidget CWin
data CWin = TkCWin
 

cwindow :: Canvas -> Coord -> PWidget w -> [Config] -> IO CWindow
cwindow c crd = cwindow' c (ccoord crd)

cwindow' :: Canvas -> CCoord -> PWidget w -> [Config] -> IO CWindow
cwindow' c crd w cs = mkCWidget "window" TkCWin c [crd] cs'
 where
   cs' = ("window" %% wpath w):cs

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

type Entry = PWidget Ent
data Ent = TkEnt

entry' :: WPath -> [Config] -> TclGUI Entry
entry' nm cs = tcl_pwidget nm (cs) "entry" TkEnt

entry :: Window -> [Config] -> IO Entry
entry w cs = do nm <- mkChildOf w;entry' nm cs (getTclGUIInfo w)

getEntry :: Entry -> IO String
getEntry w = tclW w $ \w -> [w,"get"]

setEntry :: Entry -> String -> IO()
setEntry w s = 
 tclW_ w $ \w -> [w,"delete 0 end;", w,"insert 0",tcl_string s]

insertEntry :: Entry -> EIndex -> String -> IO ()
insertEntry e t s = 
 tclW_ e $ \w -> [w,"insert",showEIndex t,tcl_string s]

deleteEntry :: Entry -> EIndex -> EIndex -> IO ()
deleteEntry e t1 t2 = tclW_ e $ \w -> [w,"delete",showEIndex t1,showEIndex t2]

setICursor :: Entry -> EIndex -> IO ()
setICursor e t = tclW_ e $ \w -> [w,"icursor"]

data EIndex = EIndex Int | EIndexSelStart | EIndexSelEnd | EIndexAnchor 
	    | EIndexEnd | EIndexAt ! Int ! Int | EFree String

showEIndex :: EIndex -> String
showEIndex (EIndex n) = show n
showEIndex EIndexSelStart = "sel.first"
showEIndex EIndexSelEnd = "sel.last"
showEIndex EIndexAnchor = "anchor"
showEIndex EIndexEnd = "end"
showEIndex (EIndexAt x y) = "@" ++ show x ++ "," ++ show y

clearEntrySelection :: Entry -> IO ()
clearEntrySelection e = tclW_ e $ \w -> [w,"selection clear"]

setEntrySelectionAnchor :: Entry -> EIndex -> IO ()
setEntrySelectionAnchor e t = tclW_ e $ \w -> [w,"selection from",showEIndex t]

isEntrySelected :: Entry -> IO Bool
isEntrySelected e =  do
 b <- tclW e $ \w -> [w,"selection present"]
 case b of
  "1" -> return True
  _ -> return False

setEntrySelection :: Entry -> EIndex -> EIndex -> IO ()
setEntrySelection e t1 t2 = 
 tclW_ e $ \w -> [w,"selection range",showEIndex t1,showEIndex t2]

adjustEntrySelection :: Entry -> EIndex -> IO ()
adjustEntrySelection e t = tclW_ e $ \w -> [w,"selection adjust",showEIndex t]

setToEntrySelection :: Entry -> EIndex -> IO ()
setToEntrySelection e t = tclW_ e $ \w -> [w,"selection to",showEIndex t]

-- instance ScrollableX
  
tclToBool :: String -> Bool
tclToBool "1" = True
tclToBool _ = False

-- Edit ------------------------------------------------
 
type Edit = PWidget Edi
data Edi = Edi
 
isReadOnly :: PWidget a -> IO Bool
isReadOnly ed = do
 fmap get $ cget' ed ("state" %% "")
  where
    get "disabled" = True
    get "normal" = False
    get "" = False

doinsert :: PWidget a -> IO () -> IO ()
doinsert e act = do
 b <- isReadOnly e
 if b then do
   cset' e ["state" %% "normal"]
   act
   cset' e ["state" %% "disabled"]
  else
   act

edit' :: WPath -> [Config] -> TclGUI Edit
edit' nm cs = tcl_pwidget nm (cs) "text" Edi
 
edit :: Window -> [Config] -> IO Edit
edit w cs = do nm <- mkChildOf w;edit' nm cs (getTclGUIInfo w)

data TIndex = TIndex ! Int ! Int -- Line and Char
	    | TIndexAt ! Int ! Int
	    | TIndexEnd 	  
	    | TIndexMark ! MarkId
	    | TIndexTagFirst ! TagId
	    | TIndexTagLast ! TagId  
	    | TIndexEmbeddedWin ! WPath
	    | TFree String
            | TModMove TIndex ModMove
 deriving (Eq,Show)
	    
data ModMove = LineStart | LineEnd | WordStart | WordEnd 
             | ModChars Int | ModLines Int
 deriving (Eq,Show)

showTIndex' :: TIndex -> String
showTIndex' (TIndex x y) = show x ++ "." ++ show y
showTIndex' (TIndexAt x y) = "@" ++ show x ++ "," ++ show y
showTIndex' TIndexEnd = "end"
showTIndex' (TIndexMark s) = s
showTIndex' (TIndexTagFirst tg) = tg ++ ".first"
showTIndex' (TIndexTagLast tg) = tg ++ ".last"
showTIndex' (TIndexEmbeddedWin w) = w
showTIndex' (TModMove ti m) = showTIndex' ti ++ " " ++ showModMove m

fromIntS :: Int -> String
fromIntS n = if n < 0 then show n else "+ " ++ show n

showTIndex :: TIndex -> String
showTIndex ti = "{" ++ showTIndex' ti ++ "}"

showModMove :: ModMove -> String
showModMove LineStart = "linestart"
showModMove LineEnd = "lineend"
showModMove WordStart = "wordstart"
showModMove WordEnd = "wordend"
showModMove (ModChars n) = fromIntS n ++ " chars"
showModMove (ModLines n) = fromIntS n ++ " lines"

cmpIndex_ :: String -> Edit -> TIndex -> TIndex -> IO Bool
cmpIndex_ s e t1 t2 = 
  fmap tclToBool $ 
       (tclW e $ \w -> [w,"compare",s,showTIndex t1,showTIndex t2])

eqTIndex,ltTIndex,gtTIndex :: Edit -> TIndex -> TIndex 
                           -> IO Bool
eqTIndex = cmpIndex_ "=="
ltTIndex = cmpIndex_ "<"
gtTIndex = cmpIndex_ ">"

cmpTIndex :: Edit -> TIndex -> TIndex -> IO Ordering
cmpTIndex e t1 t2 = do
 eq <- eqTIndex e t1 t2
 if eq then return EQ
  else do
   lt <- ltTIndex e t1 t2
   return $ if lt then LT else GT
 
fromPlainIndex' :: String -> Maybe (Int,Int)
fromPlainIndex' s = 
  case splitWith (== '.') s of 
    [x1,x2] -> Just (parseInt x1,parseInt x2)
    _ -> Nothing

lineAreaEdit :: Edit -> TIndex -> IO (Int,Int,Int,Int,Int)
lineAreaEdit e t = do
 s <- tclW e $ \w -> [w,"dlineinfo",showTIndex t]
 case words s of
  [x,y,w,h,b] -> 
    return (parseInt x,parseInt y,parseInt w,parseInt h,parseInt b)
  _ -> fail $ "lineAreaEdit: invalid return value " ++ s

getEdit :: Edit -> IO String
getEdit e = getFromTo e (TIndex 0 0) TIndexEnd

getFromTo :: Edit -> TIndex -> TIndex -> IO String
getFromTo e t1 t2 = 
 tclW e $ \w -> [w,"get",showTIndex t1,showTIndex t2] 

fromTIndex :: Edit -> TIndex -> IO (Maybe (Int,Int))
fromTIndex e t1 = do
 s <- tclW e $ \w -> [w,"index",showTIndex t1]
 return $! fromPlainIndex' s

insertEdit :: Edit -> TIndex -> String -> IO ()
insertEdit e t s = doinsert e $  
 tclW_ e $ \w -> [w,"insert",showTIndex t,tcl_string s]


deleteEdit :: Edit -> TIndex -> TIndex -> IO ()   
deleteEdit e t1 t2 = doinsert e $
 tclW_ e $ \w -> [w,"delete",showTIndex t1,showTIndex t2]

resetEdit :: Edit -> String -> IO ()
resetEdit w s = doinsert w $ 
     do deleteEdit w (TIndex 1 0) (TIndexEnd)
	insertEdit w (TIndex 1 0) s
	tclW_ w $ \w -> [w,"mark set insert 1.0"]

searchEdit :: Edit 
	       -> Bool -- forward if True (back otherwise) 
	       -> Bool -- ignore case if True
	       -> Bool -- treat pattern as regexp
	       -> String -- pattern
	       -> TIndex -- start at
	       -> TIndex -- stop at
               -> IO (Maybe ((Int,Int),Int))
searchEdit e forward nocase isregexp pat start stop = 
 do v <- tclW e $ \w -> [w,"search",
		    if not forward then "-backwards" else "",
		    if nocase then "-nocase" else "",
		    if isregexp then "-regexp" else "",
		    "-count count" ++ wpath e,
		    "--",
		    pat,showTIndex start,showTIndex stop]
    case fromPlainIndex' v of
      Nothing -> return Nothing
      Just p -> do n <- tclW e $ const ["set count",wpath e]
		   return $ Just $ (p,parseInt n)
      
editMoveTo :: Edit -> TIndex -> IO ()
editMoveTo e t = tclW_ e $ \w -> [w,"see",showTIndex t] 

insertEditTagged :: Edit -> TIndex -> String -> [TagId] 
                 -> IO ()
insertEditTagged e t s tgs = doinsert e $ 
     do tclW_ e $ \w -> [w, "insert",showTIndex t,tcl_string s, prep tgs]
      where
	prep []       = "{}"
	prep (tg:tgs) = "{"++tg++foldr (\h t->' ':h++t) "}" tgs

clearSelEdit :: Edit -> IO ()
clearSelEdit e = doinsert e $ tclW_ e $ \w -> ["tk_textClear",w]

cutClipboard :: Edit -> IO ()
cutClipboard e = doinsert e $ tclW_ e $ \w -> ["tk_textCut",w]

copyClipboard :: Edit -> IO ()
copyClipboard e = doinsert e $ tclW_ e $ \w -> ["tk_textCopy",w]

pasteClipboard :: Edit -> IO ()
pasteClipboard e = doinsert e $ tclW_ e $ \w -> ["tk_textPaste",w]

-- Mark ------------------------------------------------

data Mark = Mark {markId :: ! MarkId,markEdit :: ! Edit}
type MarkId = String

mark' :: Edit -> MarkId -> TIndex -> IO Mark
mark' e s t = do 
 tclW_ e $ \w -> [w,"mark set",s,showTIndex t]
 return $! Mark s e

mark :: Edit -> TIndex -> IO Mark
mark e t = do nm <- tcl_newName (getTclGUIInfo e)
	      mark' e (show nm) t

getMarkPos :: Mark -> IO (Maybe (Int,Int))
getMarkPos m = fromTIndex (markEdit m) (TIndexMark (markId m))

setMark :: Mark -> TIndex -> IO ()
setMark (Mark s e) t = 
 tclW_ e $ \w -> [w,"mark set",s,showTIndex t]

removeMark :: Mark -> IO ()
removeMark (Mark s e) = 
 tclW_ e $ \w -> [w,"mark unset",s]

data Gravity = GLeft | GRight
 deriving (Eq,Show)

showGravity GLeft = "left"
showGravity GRight = "right"

setMarkGravity :: Mark -> Gravity -> IO ()
setMarkGravity (Mark s e) g = do 
 tclW_ e $ \w -> [w,"mark gravity",s,showGravity g]

getMarkGravity :: Mark -> IO Gravity
getMarkGravity (Mark s e) = do
 g <- tclW e $ \w -> [w,"mark gravity",s]
 case g of
  "left" -> return $! GLeft 
  _ -> return $! GRight

getAllMarks :: Edit -> IO [Mark]
getAllMarks e = do
 s <- tclW e $ \w -> [w,"mark names"]
 return $! map (\s -> Mark s e) $! words s

getMark :: Edit -> MarkId -> Mark
getMark e m = Mark m e

previousMark :: Edit -> TIndex -> IO Mark
previousMark e t = 
 fmap (flip Mark e) $
    tclW e $ \w -> [w,"mark previous",showTIndex t] 

nextMark :: Edit -> TIndex -> IO Mark
nextMark e t = 
 fmap (flip Mark e) $
    tclW e $ \w -> [w,"mark next",showTIndex t] 

insertionMark :: Edit -> Mark
insertionMark e = Mark "insert" e

currentMark :: Edit -> Mark
currentMark e = Mark "current" e

-- Embedded Text Windows -------------------------------

type Embedded = EWidget Ew
data Ew = Ew

embedded' :: Edit -> WPath -> TIndex -> [Config] -> IO Embedded
embedded' e pth indx cs = tcl_ewidget e pth (showTIndex indx) (("window" %% pth):cs) Ew 

embedded :: Edit -> PWidget a' -> TIndex -> [Config] -> IO Embedded
embedded e w indx cs = embedded' e (wpath w) indx cs

getAllEmbedded :: Edit -> IO [WPath]
getAllEmbedded e = fmap words $ tclW e $ \w -> [wpath e,"window names"]

-- Tag -------------------------------------------------
 
type Tag = TWidget Tg
data Tg  = TkTag

tag' :: Edit -> TagId -> [TIndex] -> [Config] -> IO Tag
tag' w ti indx cs = tcl_tgwidget w ti (fromTIndexes indx) (cs) TkTag

tag :: Edit -> [TIndex] -> [Config] -> IO Tag
tag w xs cs = do x <- tcl_newName (getTclGUIInfo w)
	         tg <- tag' w (show x) xs cs
	         setWithTags w (show x) xs
		 return tg

putPosTag :: Edit -> TIndex -> String -> [Config] -> IO Tag
putPosTag w p1 s cs = do
 t <- tag w [] cs
 insertEditTagged w p1 s [tagId t]
 return t


setWithTags :: Edit -> TagId -> [TIndex] -> IO ()
setWithTags e t [] = return ()
setWithTags e t xs = tclW_ e $ \w -> [w,"tag add",t,fromTIndexes xs]

fromTIndexes :: [TIndex] -> String
fromTIndexes xs = unwords $ map showTIndex xs

tagId :: Tag -> TagId 
tagId (TkWgt _ (TkT _ tg) _) = tg

tagEditWPath :: Tag -> WPath
tagEditWPath (TkWgt _ (TkT nm _) _) = nm

tagEdit :: Tag -> IO Edit
tagEdit w = totcl_pwidget (tagEditWPath w) Edi (getTclGUIInfo w)

lowerTag :: Tag -> Maybe TagId -> IO ()
lowerTag tg mb = tclW_ tg $ \w -> [w,"tag lower",tagId tg,maybe "" id mb]

raiseTag :: Tag -> Maybe TagId -> IO ()
raiseTag tg mb = tclW_ tg $ \w -> [w,"tag raise",tagId tg,maybe "" id mb]
 
getAllTags :: Edit -> IO [TagId]
getAllTags edi = fmap words $ tclW edi $ \w -> [w,"tag names"]

getTagsAt :: Edit -> TIndex -> IO [TagId]
getTagsAt edi t = 
 fmap words $ tclW edi $ \w -> [w,"tag names",showTIndex t]

tagRemove :: Tag -> [TIndex] -> IO ()
tagRemove tg ts = do
 tclW_ tg $ \w -> [w,"tag remove",tagId tg,fromTIndexes ts]

tagRemove' :: Edit -> TagId -> [TIndex] -> IO ()
tagRemove' e t ts = 
 tclW_ e $ \w -> [w,"tag remove",t,fromTIndexes ts]

setTag' :: Edit -> TagId -> [TIndex] -> IO ()
setTag' e t ts = 
 tclW_ e $ \w -> [w,"tag add",t,fromTIndexes ts]

setTag :: Tag -> [TIndex] -> IO ()
setTag tg ts = tclW_ tg $ \w -> [w,"tag add",tagId tg,fromTIndexes ts]

pairOff :: [a] -> [(a,a)]
pairOff (a:b:xs) = (a,b):pairOff xs
pairOff (a:xs) = []
pairOff [] = []

tagRanges :: Tag -> IO [((Int,Int),(Int,Int))]
tagRanges tg = do
 s <- tclW tg $ \w -> [w,"tag ranges"]
 return $ mapMaybe app $ pairOff $ words s
  where
    app (x1,x2) = case (fromPlainIndex' x1,fromPlainIndex' x2) of
                    (Just a,Just b) -> Just (a,b)
		    _ -> Nothing

tagNextRange :: Tag -> TIndex -> TIndex 
	     -> IO (Maybe ((Int,Int),(Int,Int)))   
tagNextRange = tagRange_ "nextrange"

tagPrevRange :: Tag -> TIndex -> TIndex 
	     -> IO (Maybe ((Int,Int),(Int,Int)))   
tagPrevRange = tagRange_ "prevrange"

tagRange_ :: String -> Tag -> TIndex -> TIndex 
	     -> IO (Maybe ((Int,Int),(Int,Int)))
tagRange_ op tg t1 t2 = do 
  s <- tclW tg $ \w -> [w,"tag",op,tagId tg,
	  	        showTIndex t1,showTIndex t2]
  case words s of
   [x,y] -> case fromPlainIndex' x of
	     (Just p1) ->
               case fromPlainIndex' y of
                (Just p2) ->
                  return $ Just (p1,p2) 
		_ -> return Nothing
	     _ -> return Nothing
   _ -> return Nothing

tagText :: Tag -> IO [String]
tagText t = do
 ts <- tagRanges t
 ed <- tagEdit t
 mapM (\((x,y),(x',y')) -> getFromTo ed (TIndex x y) (TIndex x' y')) ts


selectionTag :: Edit -> IO Tag
selectionTag w = do
 totcl_tgwidget w "sel" TkTag