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) =
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)
(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
where
wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (Col confs 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)
(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
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,20 +580,11 @@ 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
......@@ -633,24 +642,24 @@ 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++
| any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++
" "++show n++" -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++
| 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++
| any isFillX confs = "-sticky we \ngrid columnconfigure "++lab++
" 1 -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++
| any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" "++show n++" -weight 1"
| otherwise = ""
where
......@@ -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 ()
runInitGUI :: String -> Widget -> (GuiPort -> IO [ReconfigureItem]) -> IO ()
runInitGUI title widget initcmd = do
gport <- openWish (escape_tcl title) ""
initSchedule widget gport [] [] initcmd
gport <- openWish (escapeTcl title) ""
initSchedule widget gport [] initcmd
--- IO action to run a Widget in a new window. The GUI events
--- are processed after executing an initial action on the GUI.
......@@ -1019,66 +1029,72 @@ runInitGUI title widget initcmd = do
--- @param params - parameter string passed to the initial wish command
--- @param widget - the widget shown in the new GUI window
--- @param initcmd - the initial command executed before activating the GUI
runInitGUIwithParams :: String -> String -> Widget -> (GuiPort -> IO ()) -> IO ()
runInitGUIwithParams :: String -> String -> Widget
-> (GuiPort -> IO [ReconfigureItem]) -> IO ()
runInitGUIwithParams title params widget initcmd = do
gport <- openWish (escape_tcl title) params
initSchedule widget gport [] [] initcmd
gport <- openWish (escapeTcl title) params
initSchedule widget gport [] initcmd
--- Runs a Widget in a new GUI window and process GUI events.
--- In addition, an event handler is provided that process
--- messages received from an external message stream.
--- messages received from an external stream identified by a handle
--- (third argument).
--- This operation is useful to run a GUI that should react on
--- user events as well as messages sent to an external port.
--- user events as well as messages written to the given handle.
--- @param title - the title of the main window containing the widget