Commit eb33419f authored by Michael Hanus 's avatar Michael Hanus
Browse files

tools and libs updated

parent 2abfcf85
Subproject commit dc2f77c2993d7aad247fe2e51ff28ea757e1f356
Subproject commit 4f1ae1cfea09ec7875dbcb6dec781f02f1cc4cbe
Subproject commit 30f377a15d45a86c02203933662ca86300707a5e
Subproject commit 79e5be7bc6e4f02d8036bdf9cc68bc3ba25d452b
......@@ -27,7 +27,7 @@ module GUI(GuiPort,Widget(..),Button,ConfigButton,
getCursorPosition,seeText,
focusInput,addCanvas,setConfig,
getOpenFile,getOpenFileWithTypes,getSaveFile,getSaveFileWithTypes,
chooseColor,popup_message,debugTcl,
chooseColor,popupMessage,debugTcl,
cmd,command,button) where
import Read
......@@ -40,11 +40,11 @@ import Char(isSpace,toUpper)
-- Tcl/Tk communication are shown (such errors should only occur on
-- slow machines in exceptional cases; they should be handled by this library
-- but might be interesting to see for debugging)
showTclTkErrors = False -- True -- False
showTclTkErrors = False
-- If showTclTkCommunication is true, the all strings sent to and from
-- the Tcl/Tk GUI are shown in stdout:
showTclTkCommunication = False -- True -- False
showTclTkCommunication = False
--- The port to a GUI is just the stream connection to a GUI
--- where Tcl/Tk communication is done.
......@@ -135,6 +135,18 @@ data ConfItem =
| TclOption String
| Display Bool
isFill :: ConfItem -> Bool
isFill ci = case ci of Fill -> True
_ -> False
isFillX :: ConfItem -> Bool
isFillX ci = case ci of FillX -> True
_ -> False
isFillY :: ConfItem -> Bool
isFillY ci = case ci of FillY -> True
_ -> False
--- Data type for describing configurations that are applied
--- to a widget or GUI by some event handler.
--- @cons WidgetConf wref conf - reconfigure the widget referred by wref
......@@ -164,6 +176,7 @@ data Event = DefaultEvent
| MouseButton3
| KeyPress
| Return
deriving Eq
-- translate event into corresponding Tcl string (except for DefaultEvent)
-- with a leading blank:
......@@ -207,15 +220,15 @@ data CanvasItem = CLine [(Int,Int)] String
--- The (hidden) data type of references to a widget in a GUI window.
--- Note that the constructor WRefLabel will not be exported so that values
--- can only be created inside this module.
--- @cons WRefLabel wp label type - here "wp" is the GUI port related
--- to the widget, "label" is the (globally unique) identifier of
--- @cons WRefLabel label type -
--- "label" is the (globally unique) identifier of
--- this widget used in Tk, and "type" is one of
--- button / canvas / checkbutton / entry / label / listbox /
--- message / scale / scrollbar / textedit
data WidgetRef = WRefLabel GuiPort String String
data WidgetRef = WRefLabel String String
wRef2Label (WRefLabel _ var _) = wRefname2Label var
wRef2Wtype (WRefLabel _ _ wtype) = wtype
wRef2Label (WRefLabel var _) = wRefname2Label var
wRef2Wtype (WRefLabel _ wtype) = wtype
--- The data type of possible text styles.
--- @cons Bold - text in bold font
......@@ -304,8 +317,8 @@ type EventHandler = (String,Event,GuiPort -> IO [ReconfigureItem])
-- result: pair of (Tcl command string,
-- list of (eventname, eventtype, eventhandler))
widget2tcl :: GuiPort -> String -> Widget -> (String,[EventHandler])
widget2tcl wp label (PlainButton confs) =
widget2tcl :: String -> Widget -> (String,[EventHandler])
widget2tcl label (PlainButton confs) =
("button "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -314,9 +327,9 @@ widget2tcl wp label (PlainButton confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "button" wp label confs
(conf_tcl,conf_evs) = configs2tcl "button" label confs
widget2tcl wp label (Canvas confs) =
widget2tcl label (Canvas confs) =
("canvas "++label++"\n"
++"set "++refname++"_scrollx 100\n"
++"set "++refname++"_scrolly 100\n"
......@@ -332,9 +345,9 @@ widget2tcl wp label (Canvas confs) =
++refname++"_scrollx $"++refname++"_scrolly]}}\n"
++ conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "canvas" wp label confs
(conf_tcl,conf_evs) = configs2tcl "canvas" label confs
widget2tcl wp label (CheckButton confs) =
widget2tcl label (CheckButton confs) =
("checkbutton "++label++"\n" ++
label++" configure -variable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -343,9 +356,10 @@ widget2tcl wp label (CheckButton confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "checkbutton" wp label confs
(conf_tcl,conf_evs) = configs2tcl "checkbutton" label confs
widget2tcl wp label (Entry confs) =
widget2tcl label (Entry confs) = case configs2tcl "entry" label confs of
(conf_tcl,conf_evs) ->
("entry "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -353,10 +367,10 @@ widget2tcl wp label (Entry confs) =
"proc setvar"++refname++" {s} { global "++refname++" ; set "
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "entry" wp label confs
where
refname = wLabel2Refname label
widget2tcl wp label (Label confs) =
widget2tcl label (Label confs) =
("label "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -365,18 +379,18 @@ widget2tcl wp label (Label confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "label" wp label confs
(conf_tcl,conf_evs) = configs2tcl "label" label confs
widget2tcl wp label (ListBox confs) =
widget2tcl label (ListBox confs) =
("listbox "++label++" -exportselection false\n" ++
"proc getvar"++refname++" {} { return ["++label++" curselection]}\n" ++
"proc setvar"++refname++" {s} { "++label++" selection clear 0 end ; "
++label++" selection set $s ; "++label++" see $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "listbox" wp label confs
(conf_tcl,conf_evs) = configs2tcl "listbox" label confs
widget2tcl wp label (Message confs) =
widget2tcl label (Message confs) =
("message "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -385,9 +399,9 @@ widget2tcl wp label (Message confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "message" wp label confs
(conf_tcl,conf_evs) = configs2tcl "message" label confs
widget2tcl wp label (MenuButton confs) =
widget2tcl label (MenuButton confs) =
("menubutton "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $"
......@@ -396,9 +410,9 @@ widget2tcl wp label (MenuButton confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "menubutton" wp label confs
(conf_tcl,conf_evs) = configs2tcl "menubutton" label confs
widget2tcl wp label (Scale from to confs) =
widget2tcl label (Scale from to confs) =
("scale "++label++" -from "++show from++" -to "++show to++
" -orient horizontal -length 200\n" ++
"variable "++refname++" "++show from++"\n"++ -- initialize scale variable
......@@ -409,23 +423,23 @@ widget2tcl wp label (Scale from to confs) =
++refname++" $s}\n" ++
conf_tcl , conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "scale" wp label confs
(conf_tcl,conf_evs) = configs2tcl "scale" label confs
widget2tcl wp label (ScrollH widget confs) =
widget2tcl label (ScrollH widget confs) =
("scrollbar "++label++" -orient horizontal -command {"++
wRef2Label widget++" xview}\n" ++
wRef2Label widget++" configure -xscrollcommand {"++label++" set}\n" ++
wRef2Label widget++" configure -wrap none\n" ++ -- no line wrap
conf_tcl , conf_evs)
where (conf_tcl,conf_evs) = configs2tcl "scrollbar" wp label confs
where (conf_tcl,conf_evs) = configs2tcl "scrollbar" label confs
widget2tcl wp label (ScrollV widget confs) =
widget2tcl label (ScrollV widget confs) =
("scrollbar "++label++" -command {"++wRef2Label widget++" yview}\n" ++
wRef2Label widget++" configure -yscrollcommand {"++label++" set}\n" ++
conf_tcl , conf_evs)
where (conf_tcl,conf_evs) = configs2tcl "scrollbar" wp label confs
where (conf_tcl,conf_evs) = configs2tcl "scrollbar" label confs
widget2tcl wp label (TextEdit confs) =
widget2tcl label (TextEdit confs) =
("text "++label++"\n"++ --" -height 15\n" ++
"proc getvar"++refname++" {} { "++label++" get 1.0 {end -1 chars}}\n" ++
"proc setvar"++refname++" {s} { "++label++" delete 1.0 end ; "
......@@ -438,7 +452,7 @@ widget2tcl wp label (TextEdit confs) =
unlines (map enableBackground colors)
, conf_evs)
where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "textedit" wp label confs
(conf_tcl,conf_evs) = configs2tcl "textedit" label confs
enableFont tag style
= label ++ " tag configure " ++ tag ++ " -font \"[font actual [" ++
......@@ -456,46 +470,49 @@ widget2tcl wp label (TextEdit confs) =
= label++" tag configure "++ camelCase color ++
" -background \"" ++ color ++ "\""
widget2tcl wp label (Row confs ws) =
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++
wstcl ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label ++ labelIndex2string (96+n)
++" -row 1 -column "++show n++" "
++confCollection2tcl confs
++gridInfo2tcl n label "col" l ++ "\n"))
(1,"")
wsGridInfo),
wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws
wsGridInfo = widgets2gridinfo ws
widget2tcl label (Row confs ws) = case widgets2tcl label 97 ws of
(wstcl,wsevs) ->
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++
wstcl ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label++labelIndex2string (96+n)
++" -row 1 -column "++show n++" "
++confCollection2tcl confs
++gridInfo2tcl n label "col" l ++ "\n"))
(1,"")
wsGridInfo),
wsevs)
where
wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (Col confs ws) =
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++
wstcl ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label ++ labelIndex2string (96+n)
++" -column 1 -row "++show n++" "
++confCollection2tcl confs
++gridInfo2tcl n label "row" l ++ "\n"))
(1,"")
(widgets2gridinfo ws)),
wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws
wsGridInfo = widgets2gridinfo ws
widget2tcl label (Col confs ws) = case widgets2tcl label 97 ws of
(wstcl,wsevs) ->
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++
wstcl ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label
++labelIndex2string (96+n)
++" -column 1 -row "++show n++" "
++confCollection2tcl confs
++gridInfo2tcl n label "row" l ++ "\n"))
(1,"")
(widgets2gridinfo ws)),
wsevs)
where
wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (Matrix confs ws) =
widget2tcl label (Matrix confs ws) =
((if label == "" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++ wstcl,wsevs)
where
(wstcl,wsevs) = matrix2tcl 97 1 wp label confs ws
(wstcl,wsevs) = matrix2tcl 97 1 label confs ws
wsGridInfo = concatMap widgets2gridinfo ws
--
widget2tcl wp label (RowC confs confitems ws) =
widget2tcl label (RowC confs confitems ws) =
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++
wstcl ++
......@@ -506,12 +523,12 @@ widget2tcl wp label (RowC confs confitems ws) =
(1,"")
wsGridInfo),
conf_evs ++ wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws
(conf_tcl,conf_evs) = configs2tcl "row" wp label confitems
where (wstcl,wsevs) = widgets2tcl label 97 ws
(conf_tcl,conf_evs) = configs2tcl "row" label confitems
wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (ColC confs confitems ws) =
widget2tcl label (ColC confs confitems ws) =
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++
wstcl ++
......@@ -522,32 +539,33 @@ widget2tcl wp label (ColC confs confitems ws) =
(1,"")
(widgets2gridinfo ws)),
conf_evs ++ wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws
(conf_tcl,conf_evs) = configs2tcl "col" wp label confitems
where (wstcl,wsevs) = widgets2tcl label 97 ws
(conf_tcl,conf_evs) = configs2tcl "col" label confitems
wsGridInfo = widgets2gridinfo ws
-- actual translation function of the list of lists of widgets in a matrix
matrix2tcl :: Int -> Int -> GuiPort -> String -> [ConfCollection]
matrix2tcl :: Int -> Int -> String -> [ConfCollection]
-> [[Widget]] -> (String,[EventHandler])
matrix2tcl _ _ _ _ _ [] = ("",[])
matrix2tcl nextLabel n wp label confs (ws:wss) =
matrix2tcl _ _ _ _ [] = ("",[])
matrix2tcl nextLabel n label confs (ws:wss) =
(wstcl ++
(snd $ foldl (\ (m,g) l->(m+1,g++"grid "++label ++ labelIndex2string (nextLabel+m-1)
(snd $ foldl (\ (m,g) l->(m+1,g++"grid "++label
++labelIndex2string (nextLabel+m-1)
++" -row "++show n ++" -column "++show m++" "
++confCollection2tcl confs
++gridInfo2tcl m label "col" l ++ "\n"))
(1,"")
wsGridInfo) ++ wsstcl, wsevs++wssevs)
where (wsstcl,wssevs) = matrix2tcl (nextLabel+length ws) (n+1) wp label confs wss
(wstcl,wsevs) = widgets2tcl wp label nextLabel ws
where (wsstcl,wssevs) = matrix2tcl (nextLabel+length ws) (n+1) label confs wss
(wstcl,wsevs) = widgets2tcl label nextLabel ws
wsGridInfo = widgets2gridinfo ws
-- compute the required resize behavior of the top window
resizeBehavior :: [[ConfItem]] -> String
resizeBehavior ws = if any (elem Fill) ws then "1 1" else
if any (elem FillX) ws then "1 0" else
if any (elem FillY) ws then "0 1" else "0 0"
resizeBehavior ws = if any (any isFill) ws then "1 1" else
if any (any isFillX) ws then "1 0" else
if any (any isFillY) ws then "0 1" else "0 0"
-- list of labels of the widgets
......@@ -562,26 +580,17 @@ widgets2gridinfo (w:ws) =
if fillx then [FillX] else
if filly then [FillY] else []
hasFillX w = any isFillXConf (propagateFillInfo w)
isFillXConf conf = case conf of
FillX -> True
_ -> False
hasFillX w = any isFillX (propagateFillInfo w)
hasFillY w = any isFillYConf (propagateFillInfo w)
isFillYConf conf = case conf of
FillY -> True
_ -> False
hasFillY w = any isFillY (propagateFillInfo w)
hasFill w = any isFillConf (propagateFillInfo w)
isFillConf conf = case conf of
Fill -> True
_ -> False
hasFill w = any isFill (propagateFillInfo w)
isFillInfo conf = case conf of
FillX -> True
FillY -> True
Fill -> True
_ -> False
_ -> False
-- propagate FillInfo for those kinds of widgets which are resizable on their on
propagateFillInfo (PlainButton _) = []
......@@ -633,25 +642,25 @@ confCollection2tcl (BottomAlign : confs) = "-sticky s " ++ confCollection2tcl co
-- translate the Fill - options to sticky options and grid configures
gridInfo2tcl :: Int -> String -> String -> [ConfItem] -> String
gridInfo2tcl n label "col" confs
| elem Fill confs || (elem FillX confs && elem FillY confs)
| any isFill confs || (any isFillX confs && any isFillY confs)
= "-sticky nsew \ngrid columnconfigure "++lab++" "++show n++
" -weight 1\ngrid rowconfigure "++lab++" 1 -weight 1"
| elem FillX confs = "-sticky we \ngrid columnconfigure "++lab++
" "++show n++" -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" 1 -weight 1"
| any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++
" "++show n++" -weight 1"
| any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" 1 -weight 1"
| otherwise = ""
where
lab = if label=="" then "." else label
gridInfo2tcl n label "row" confs
| elem Fill confs || (elem FillX confs && elem FillY confs)
| any isFill confs || (any isFillX confs && any isFillY confs)
= "-sticky nsew \ngrid columnconfigure "++lab++
" 1 -weight 1\ngrid rowconfigure "++lab++" "++show n++" -weight 1"
| elem FillX confs = "-sticky we \ngrid columnconfigure "++lab++
" 1 -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" "++show n++" -weight 1"
| any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++
" 1 -weight 1"
| any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" "++show n++" -weight 1"
| otherwise = ""
where
lab = if label=="" then "." else label
......@@ -662,12 +671,12 @@ gridInfo2tcl n label "row" confs
-- (button/canvas/checkbutton/entry/label/listbox/message/scale/scrollbar/
-- textedit)
-- and the third argument is the widget label
config2tcl :: String -> GuiPort -> String -> ConfItem -> String
config2tcl :: String -> String -> ConfItem -> String
-- is the state of the widget active ("normal" in Tcl/Tk) or
-- inactive ("disabled" in Tcl/Tk)?
-- (inactive widgets do not accept any events)
config2tcl wtype _ label (Active active) =
config2tcl wtype label (Active active) =
if wtype=="button" || wtype=="checkbutton" || wtype=="entry" ||
wtype=="menubutton" || wtype=="scale" || wtype=="textedit"
then if active
......@@ -677,22 +686,22 @@ config2tcl wtype _ label (Active active) =
-- alignment of information inside a widget
-- argument must be: n, ne, e, se, s, sw, w, nw, or center
config2tcl wtype _ label (Anchor align) =
config2tcl wtype label (Anchor align) =
if wtype=="button" || wtype=="checkbutton" || wtype=="label" ||
wtype=="menubutton" || wtype=="message"
then label++" configure -anchor "++align++"\n"
else trace ("WARNING: GUI.Anchor ignored for widget type \""++wtype++"\"\n") ""
-- background color:
config2tcl _ _ label (Background color)
config2tcl _ label (Background color)
= label++" configure -background \""++color++"\"\n"
-- foreground color:
config2tcl _ _ label (Foreground color)
config2tcl _ label (Foreground color)
= label++" configure -foreground \""++color++"\"\n"
-- command associated to various widgets:
config2tcl wtype _ label (Handler evtype _)
config2tcl wtype label (Handler evtype _)
| evtype == DefaultEvent
= if wtype=="button"
then label++" configure -command"++writeEvent else
......@@ -715,7 +724,7 @@ config2tcl wtype _ label (Handler evtype _)
writeEvent = " { writeevent \""++label++event2tcl evtype++"\" }\n"
-- height of a widget (not defined for all widget types):
config2tcl wtype _ label (Height h)
config2tcl wtype label (Height h)
| wtype=="entry" || wtype=="message" || wtype=="menubutton" ||
wtype=="scale"
= trace ("WARNING: GUI.Height ignored for widget type \""++wtype++"\"\n") ""
......@@ -726,13 +735,13 @@ config2tcl wtype _ label (Height h)
= label++" configure -height "++show h++"\n"
-- show/hide widget
config2tcl _ _ label (Display b)
config2tcl _ label (Display b)
= if b then "grid " ++ label ++ "\n"
else "grid remove " ++ label ++ "\n"
-- value of checkbuttons:
config2tcl wtype _ label (CheckInit s)
config2tcl wtype label (CheckInit s)
| wtype=="checkbutton"
= "setvar"++wLabel2Refname label++" \""++s++"\"\n"
| wtype=="listbox"
......@@ -741,13 +750,13 @@ config2tcl wtype _ label (CheckInit s)
= trace ("WARNING: GUI.CheckInit ignored for widget type \""++wtype++"\"\n") ""
-- items in a canvas:
config2tcl wtype _ label (CanvasItems items)
config2tcl wtype label (CanvasItems items)
| wtype=="canvas" = canvasItems2tcl label items
| otherwise
= trace ("WARNING: GUI.CanvasItems ignored for widget type \""++wtype++"\"\n") ""
-- value lists for listboxes:
config2tcl wtype _ label (List l)
config2tcl wtype label (List l)
| wtype=="listbox"
= label++" delete 0 end\n" ++ setlistelems (ensureSpine l)
| otherwise
......@@ -755,11 +764,11 @@ config2tcl wtype _ label (List l)
where
setlistelems [] = ""
setlistelems (e:es) = label++" insert end \""++escape_tcl e++"\"\n"++
setlistelems (e:es) = label++" insert end \""++escapeTcl e++"\"\n"++
setlistelems es
-- items in a menu button:
config2tcl wtype _ label (Menu l)
config2tcl wtype label (Menu l)
| wtype=="menubutton"
= label++" configure -menu "++label++".a\n" ++
menu2tcl (label++".a") l
......@@ -767,20 +776,20 @@ config2tcl wtype _ label (Menu l)
= trace ("WARNING: GUI.Menu ignored for widget type \""++wtype++"\"\n") ""
-- references to widgets are bound to actual widget labels:
config2tcl wtype wp label (WRef r)
| r =:= WRefLabel wp (wLabel2Refname label) wtype = ""
config2tcl wtype label (WRef r)
| r =:= WRefLabel (wLabel2Refname label) wtype = ""
-- initial text value of widgets:
config2tcl wtype _ label (Text s)
config2tcl wtype label (Text s)
| wtype=="canvas"
= trace "WARNING: GUI.Text ignored for Canvas\n" ""
| wtype=="checkbutton"
= label++" configure -text \""++escape_tcl s++"\"\n"
= label++" configure -text \""++escapeTcl s++"\"\n"
| otherwise
= "setvar"++wLabel2Refname label++" \""++escape_tcl s++"\"\n"
= "setvar"++wLabel2Refname label++" \""++escapeTcl s++"\"\n"
-- width of a widget:
config2tcl wtype _ label (Width w)
config2tcl wtype label (Width w)
| wtype=="canvas"
= label++" configure -width "++show w++"\n"++
"set"++wLabel2Refname label++"_scrollx "++show w++"\n"
......@@ -788,12 +797,12 @@ config2tcl wtype _ label (Width w)
-- configuration options for widget composition are ignored here
-- since they are used during geometry management
config2tcl _ _ _ Fill = ""
config2tcl _ _ _ FillX = ""
config2tcl _ _ _ FillY = ""
config2tcl _ _ Fill = ""
config2tcl _ _ FillX = ""
config2tcl _ _ FillY = ""
-- for testing, put arbitrary Tk options for this widget:
config2tcl _ _ label (TclOption tcloptions)
config2tcl _ label (TclOption tcloptions)
= label++" configure "++tcloptions++"\n"
......@@ -804,14 +813,14 @@ menu2tcl label menu =
setmenuelems menu 0
where setmenuelems [] _ = ""
setmenuelems (MButton _ text : es) i =
label++" add command -label \""++escape_tcl text++
label++" add command -label \""++escapeTcl text++
"\" -command { writeevent \""++label++"."++show i++
event2tcl DefaultEvent++"\" }\n"++
setmenuelems es (i+1)
setmenuelems (MSeparator : es) i =
label++" add separator\n"++ setmenuelems es (i+1)
setmenuelems (MMenuButton text l : es) i =
label++" add cascade -label \""++escape_tcl text++
label++" add cascade -label \""++escapeTcl text++
"\" -menu "++label++labelIndex2string (i+97)++"\n"++
menu2tcl (label++labelIndex2string (i+97)) l ++
setmenuelems es (i+1)
......@@ -834,10 +843,10 @@ menu2handler label (MMenuButton _ menu : ms) i =
menu2handler label ms (i+1)
-- translate configuration options into Tcl/Tk commands and event handler map:
configs2tcl :: String -> GuiPort -> String -> [ConfItem]
configs2tcl :: String -> String -> [ConfItem]
-> (String,[EventHandler])
configs2tcl wtype wp label confs =
(concatMap (config2tcl wtype wp label) confs,
configs2tcl wtype label confs =
(concatMap (config2tcl wtype label) confs,
configs2handler label confs)
......@@ -868,7 +877,7 @@ canvasItem2tcl label (COval (x1,y1) (x2,y2) opts) =
where refname = wLabel2Refname label
canvasItem2tcl label (CText (x,y) text opts) =
label++ " create text "++show x++" "++show y++
" -text \""++escape_tcl text++"\" "++opts++"\n"++
" -text \""++escapeTcl text++"\" "++opts++"\n"++
"set"++refname++"_scrollx "++show (x+5*(length text))++"\n"++
"set"++refname++"_scrolly "++show y++"\n"
where refname = wLabel2Refname label
......@@ -885,10 +894,11 @@ wRefname2Label l = map (\c -> if c=='_' then '.' else c) l
-- translate a list of widgets into pair Tcl string / event list:
widgets2tcl _ _ _ [] = ("",[])
widgets2tcl wp lab nr (w:ws) = (wtcl ++ wstcl, wevs ++ wsevs)
where (wtcl,wevs) = widget2tcl wp (lab++labelIndex2string nr) w
(wstcl,wsevs) = widgets2tcl wp lab (nr+1) ws
widgets2tcl _ _ [] = ("",[])
widgets2tcl lab nr (w:ws) =
case widget2tcl (lab++labelIndex2string nr) w of
(wtcl,wevs) -> case widgets2tcl lab (nr+1) ws of
(wstcl,wsevs) -> (wtcl ++ wstcl, wevs ++ wsevs)
-- translate a label index into a textual label
-- (e.g., 97->".a" or 123->".z1"):
......@@ -897,18 +907,18 @@ labelIndex2string li = if li<123 then ['.',chr li]
else ['.','z'] ++ show (li-122)
-- translate main widget:
mainWidget2tcl :: GuiPort -> Widget -> (String,[EventHandler])
mainWidget2tcl wp widget =
mainWidget2tcl :: Widget -> (String,[EventHandler])
mainWidget2tcl widget =
("proc writeevent {l} { puts \":EVT$l\" }\n" ++
"proc putlabel {l v} { writeevent $l }\n" ++
"proc putvar {var value} { puts \":VAR$var%[string length $value]*$value\"}\n" ++
widgettcl, evs)
where (widgettcl,evs) = widget2tcl wp "" widget
where (widgettcl,evs) = widget2tcl "" widget
--- Prints the generated Tcl commands of a main widget (useful for debugging).
debugTcl :: Widget -> IO ()
debugTcl widget = putStrLn (fst (mainWidget2tcl wp widget)) where wp free
debugTcl widget = putStrLn (fst (mainWidget2tcl widget))
------------------------------------------------------------------------
......@@ -984,8 +994,8 @@ openWish title params = do
--- @param widget - the widget shown in the new window
runPassiveGUI :: String -> Widget -> IO GuiPort
runPassiveGUI title widget = do
gport <- openWish (escape_tcl title) ""
send2tk (fst (mainWidget2tcl gport widget)) gport
gport <- openWish (escapeTcl title) ""
send2tk (fst (mainWidget2tcl widget)) gport
return gport
......@@ -993,7 +1003,7 @@ runPassiveGUI title widget = do
--- @param title - the title of the main window containing the widget
--- @param widget - the widget shown in the new window
runGUI :: String -> Widget -> IO ()
runGUI title widget = runInitGUIwithParams title "" widget (const done)
runGUI title widget = runInitGUIwithParams title "" widget (const (return []))
--- IO action to run a Widget in a new window.
--- @param title - the title of the main window containing the widget
......@@ -1001,17 +1011,17 @@ runGUI title widget = runInitGUIwithParams title "" widget (const done)
--- @param widget - the widget shown in the new window
runGUIwithParams :: String -> String -> Widget -> IO ()
runGUIwithParams title params widget =
runInitGUIwithParams title params widget (const done)
runInitGUIwithParams title params widget (const (return []))
--- IO action to run a Widget in a new window. The GUI events
--- are processed after executing an initial action on the GUI.
--- @param title - the title of the main GUI window
--- @param widget - the widget shown in the new GUI window
--- @param initcmd - the initial command executed before activating the GUI
runInitGUI :: String -> Widget -> (GuiPort -> IO ()) -> IO ()