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, ...@@ -27,7 +27,7 @@ module GUI(GuiPort,Widget(..),Button,ConfigButton,
getCursorPosition,seeText, getCursorPosition,seeText,
focusInput,addCanvas,setConfig, focusInput,addCanvas,setConfig,
getOpenFile,getOpenFileWithTypes,getSaveFile,getSaveFileWithTypes, getOpenFile,getOpenFileWithTypes,getSaveFile,getSaveFileWithTypes,
chooseColor,popup_message,debugTcl, chooseColor,popupMessage,debugTcl,
cmd,command,button) where cmd,command,button) where
import Read import Read
...@@ -40,11 +40,11 @@ import Char(isSpace,toUpper) ...@@ -40,11 +40,11 @@ import Char(isSpace,toUpper)
-- Tcl/Tk communication are shown (such errors should only occur on -- Tcl/Tk communication are shown (such errors should only occur on
-- slow machines in exceptional cases; they should be handled by this library -- slow machines in exceptional cases; they should be handled by this library
-- but might be interesting to see for debugging) -- 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 -- If showTclTkCommunication is true, the all strings sent to and from
-- the Tcl/Tk GUI are shown in stdout: -- 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 --- The port to a GUI is just the stream connection to a GUI
--- where Tcl/Tk communication is done. --- where Tcl/Tk communication is done.
...@@ -135,6 +135,18 @@ data ConfItem = ...@@ -135,6 +135,18 @@ data ConfItem =
| TclOption String | TclOption String
| Display Bool | 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 --- Data type for describing configurations that are applied
--- to a widget or GUI by some event handler. --- to a widget or GUI by some event handler.
--- @cons WidgetConf wref conf - reconfigure the widget referred by wref --- @cons WidgetConf wref conf - reconfigure the widget referred by wref
...@@ -164,6 +176,7 @@ data Event = DefaultEvent ...@@ -164,6 +176,7 @@ data Event = DefaultEvent
| MouseButton3 | MouseButton3
| KeyPress | KeyPress
| Return | Return
deriving Eq
-- translate event into corresponding Tcl string (except for DefaultEvent) -- translate event into corresponding Tcl string (except for DefaultEvent)
-- with a leading blank: -- with a leading blank:
...@@ -207,15 +220,15 @@ data CanvasItem = CLine [(Int,Int)] String ...@@ -207,15 +220,15 @@ data CanvasItem = CLine [(Int,Int)] String
--- The (hidden) data type of references to a widget in a GUI window. --- 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 --- Note that the constructor WRefLabel will not be exported so that values
--- can only be created inside this module. --- can only be created inside this module.
--- @cons WRefLabel wp label type - here "wp" is the GUI port related --- @cons WRefLabel label type -
--- to the widget, "label" is the (globally unique) identifier of --- "label" is the (globally unique) identifier of
--- this widget used in Tk, and "type" is one of --- this widget used in Tk, and "type" is one of
--- button / canvas / checkbutton / entry / label / listbox / --- button / canvas / checkbutton / entry / label / listbox /
--- message / scale / scrollbar / textedit --- message / scale / scrollbar / textedit
data WidgetRef = WRefLabel GuiPort String String data WidgetRef = WRefLabel String String
wRef2Label (WRefLabel _ var _) = wRefname2Label var wRef2Label (WRefLabel var _) = wRefname2Label var
wRef2Wtype (WRefLabel _ _ wtype) = wtype wRef2Wtype (WRefLabel _ wtype) = wtype
--- The data type of possible text styles. --- The data type of possible text styles.
--- @cons Bold - text in bold font --- @cons Bold - text in bold font
...@@ -304,8 +317,8 @@ type EventHandler = (String,Event,GuiPort -> IO [ReconfigureItem]) ...@@ -304,8 +317,8 @@ type EventHandler = (String,Event,GuiPort -> IO [ReconfigureItem])
-- result: pair of (Tcl command string, -- result: pair of (Tcl command string,
-- list of (eventname, eventtype, eventhandler)) -- list of (eventname, eventtype, eventhandler))
widget2tcl :: GuiPort -> String -> Widget -> (String,[EventHandler]) widget2tcl :: String -> Widget -> (String,[EventHandler])
widget2tcl wp label (PlainButton confs) = widget2tcl label (PlainButton confs) =
("button "++label++"\n" ++ ("button "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++ label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -314,9 +327,9 @@ widget2tcl wp label (PlainButton confs) = ...@@ -314,9 +327,9 @@ widget2tcl wp label (PlainButton confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ("canvas "++label++"\n"
++"set "++refname++"_scrollx 100\n" ++"set "++refname++"_scrollx 100\n"
++"set "++refname++"_scrolly 100\n" ++"set "++refname++"_scrolly 100\n"
...@@ -332,9 +345,9 @@ widget2tcl wp label (Canvas confs) = ...@@ -332,9 +345,9 @@ widget2tcl wp label (Canvas confs) =
++refname++"_scrollx $"++refname++"_scrolly]}}\n" ++refname++"_scrollx $"++refname++"_scrolly]}}\n"
++ conf_tcl , conf_evs) ++ conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ++ ("checkbutton "++label++"\n" ++
label++" configure -variable "++refname++"\n" ++ label++" configure -variable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -343,9 +356,10 @@ widget2tcl wp label (CheckButton confs) = ...@@ -343,9 +356,10 @@ widget2tcl wp label (CheckButton confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ++ ("entry "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++ label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -353,10 +367,10 @@ widget2tcl wp label (Entry confs) = ...@@ -353,10 +367,10 @@ widget2tcl wp label (Entry confs) =
"proc setvar"++refname++" {s} { global "++refname++" ; set " "proc setvar"++refname++" {s} { global "++refname++" ; set "
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label where
(conf_tcl,conf_evs) = configs2tcl "entry" wp label confs refname = wLabel2Refname label
widget2tcl wp label (Label confs) = widget2tcl label (Label confs) =
("label "++label++"\n" ++ ("label "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++ label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -365,18 +379,18 @@ widget2tcl wp label (Label confs) = ...@@ -365,18 +379,18 @@ widget2tcl wp label (Label confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ++ ("listbox "++label++" -exportselection false\n" ++
"proc getvar"++refname++" {} { return ["++label++" curselection]}\n" ++ "proc getvar"++refname++" {} { return ["++label++" curselection]}\n" ++
"proc setvar"++refname++" {s} { "++label++" selection clear 0 end ; " "proc setvar"++refname++" {s} { "++label++" selection clear 0 end ; "
++label++" selection set $s ; "++label++" see $s}\n" ++ ++label++" selection set $s ; "++label++" see $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ++ ("message "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++ label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -385,9 +399,9 @@ widget2tcl wp label (Message confs) = ...@@ -385,9 +399,9 @@ widget2tcl wp label (Message confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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" ++ ("menubutton "++label++"\n" ++
label++" configure -textvariable "++refname++"\n" ++ label++" configure -textvariable "++refname++"\n" ++
"proc getvar"++refname++" {} { global "++refname++" ; return $" "proc getvar"++refname++" {} { global "++refname++" ; return $"
...@@ -396,9 +410,9 @@ widget2tcl wp label (MenuButton confs) = ...@@ -396,9 +410,9 @@ widget2tcl wp label (MenuButton confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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++ ("scale "++label++" -from "++show from++" -to "++show to++
" -orient horizontal -length 200\n" ++ " -orient horizontal -length 200\n" ++
"variable "++refname++" "++show from++"\n"++ -- initialize scale variable "variable "++refname++" "++show from++"\n"++ -- initialize scale variable
...@@ -409,23 +423,23 @@ widget2tcl wp label (Scale from to confs) = ...@@ -409,23 +423,23 @@ widget2tcl wp label (Scale from to confs) =
++refname++" $s}\n" ++ ++refname++" $s}\n" ++
conf_tcl , conf_evs) conf_tcl , conf_evs)
where refname = wLabel2Refname label 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 {"++ ("scrollbar "++label++" -orient horizontal -command {"++
wRef2Label widget++" xview}\n" ++ wRef2Label widget++" xview}\n" ++
wRef2Label widget++" configure -xscrollcommand {"++label++" set}\n" ++ wRef2Label widget++" configure -xscrollcommand {"++label++" set}\n" ++
wRef2Label widget++" configure -wrap none\n" ++ -- no line wrap wRef2Label widget++" configure -wrap none\n" ++ -- no line wrap
conf_tcl , conf_evs) 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" ++ ("scrollbar "++label++" -command {"++wRef2Label widget++" yview}\n" ++
wRef2Label widget++" configure -yscrollcommand {"++label++" set}\n" ++ wRef2Label widget++" configure -yscrollcommand {"++label++" set}\n" ++
conf_tcl , conf_evs) 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" ++ ("text "++label++"\n"++ --" -height 15\n" ++
"proc getvar"++refname++" {} { "++label++" get 1.0 {end -1 chars}}\n" ++ "proc getvar"++refname++" {} { "++label++" get 1.0 {end -1 chars}}\n" ++
"proc setvar"++refname++" {s} { "++label++" delete 1.0 end ; " "proc setvar"++refname++" {s} { "++label++" delete 1.0 end ; "
...@@ -438,7 +452,7 @@ widget2tcl wp label (TextEdit confs) = ...@@ -438,7 +452,7 @@ widget2tcl wp label (TextEdit confs) =
unlines (map enableBackground colors) unlines (map enableBackground colors)
, conf_evs) , conf_evs)
where refname = wLabel2Refname label where refname = wLabel2Refname label
(conf_tcl,conf_evs) = configs2tcl "textedit" wp label confs (conf_tcl,conf_evs) = configs2tcl "textedit" label confs
enableFont tag style enableFont tag style
= label ++ " tag configure " ++ tag ++ " -font \"[font actual [" ++ = label ++ " tag configure " ++ tag ++ " -font \"[font actual [" ++
...@@ -456,46 +470,49 @@ widget2tcl wp label (TextEdit confs) = ...@@ -456,46 +470,49 @@ widget2tcl wp label (TextEdit confs) =
= label++" tag configure "++ camelCase color ++ = label++" tag configure "++ camelCase color ++
" -background \"" ++ color ++ "\"" " -background \"" ++ color ++ "\""
widget2tcl wp label (Row confs ws) = widget2tcl label (Row confs ws) = case widgets2tcl label 97 ws of
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" (wstcl,wsevs) ->
else "frame "++label++"\n") ++ ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
wstcl ++ else "frame "++label++"\n") ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label ++ labelIndex2string (96+n) wstcl ++
++" -row 1 -column "++show n++" " (snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label++labelIndex2string (96+n)
++confCollection2tcl confs ++" -row 1 -column "++show n++" "
++gridInfo2tcl n label "col" l ++ "\n")) ++confCollection2tcl confs
(1,"") ++gridInfo2tcl n label "col" l ++ "\n"))
wsGridInfo), (1,"")
wsevs) wsGridInfo),
where (wstcl,wsevs) = widgets2tcl wp label 97 ws wsevs)
wsGridInfo = widgets2gridinfo ws where
wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (Col confs ws) = widget2tcl label (Col confs ws) = case widgets2tcl label 97 ws of
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" (wstcl,wsevs) ->
else "frame "++label++"\n") ++ ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
wstcl ++ else "frame "++label++"\n") ++
(snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label ++ labelIndex2string (96+n) wstcl ++
++" -column 1 -row "++show n++" " (snd $ foldl (\ (n,g) l->(n+1,g++"grid "++label
++confCollection2tcl confs ++labelIndex2string (96+n)
++gridInfo2tcl n label "row" l ++ "\n")) ++" -column 1 -row "++show n++" "
(1,"") ++confCollection2tcl confs
(widgets2gridinfo ws)), ++gridInfo2tcl n label "row" l ++ "\n"))
wsevs) (1,"")
where (wstcl,wsevs) = widgets2tcl wp label 97 ws (widgets2gridinfo ws)),
wsGridInfo = 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" ((if label == "" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n") ++ wstcl,wsevs) else "frame "++label++"\n") ++ wstcl,wsevs)
where where
(wstcl,wsevs) = matrix2tcl 97 1 wp label confs ws (wstcl,wsevs) = matrix2tcl 97 1 label confs ws
wsGridInfo = concatMap widgets2gridinfo 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" ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++ else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++
wstcl ++ wstcl ++
...@@ -506,12 +523,12 @@ widget2tcl wp label (RowC confs confitems ws) = ...@@ -506,12 +523,12 @@ widget2tcl wp label (RowC confs confitems ws) =
(1,"") (1,"")
wsGridInfo), wsGridInfo),
conf_evs ++ wsevs) conf_evs ++ wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws where (wstcl,wsevs) = widgets2tcl label 97 ws
(conf_tcl,conf_evs) = configs2tcl "row" wp label confitems (conf_tcl,conf_evs) = configs2tcl "row" label confitems
wsGridInfo = widgets2gridinfo ws wsGridInfo = widgets2gridinfo ws
widget2tcl wp label (ColC confs confitems ws) = widget2tcl label (ColC confs confitems ws) =
((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" ((if label=="" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n"
else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++ else "frame "++label++"\n" ++ conf_tcl ++ "\n") ++
wstcl ++ wstcl ++
...@@ -522,32 +539,33 @@ widget2tcl wp label (ColC confs confitems ws) = ...@@ -522,32 +539,33 @@ widget2tcl wp label (ColC confs confitems ws) =
(1,"") (1,"")
(widgets2gridinfo ws)), (widgets2gridinfo ws)),
conf_evs ++ wsevs) conf_evs ++ wsevs)
where (wstcl,wsevs) = widgets2tcl wp label 97 ws where (wstcl,wsevs) = widgets2tcl label 97 ws
(conf_tcl,conf_evs) = configs2tcl "col" wp label confitems (conf_tcl,conf_evs) = configs2tcl "col" label confitems
wsGridInfo = widgets2gridinfo ws wsGridInfo = widgets2gridinfo ws
-- actual translation function of the list of lists of widgets in a matrix -- 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]) -> [[Widget]] -> (String,[EventHandler])
matrix2tcl _ _ _ _ _ [] = ("",[]) matrix2tcl _ _ _ _ [] = ("",[])
matrix2tcl nextLabel n wp label confs (ws:wss) = matrix2tcl nextLabel n label confs (ws:wss) =
(wstcl ++ (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++" " ++" -row "++show n ++" -column "++show m++" "
++confCollection2tcl confs ++confCollection2tcl confs
++gridInfo2tcl m label "col" l ++ "\n")) ++gridInfo2tcl m label "col" l ++ "\n"))
(1,"") (1,"")
wsGridInfo) ++ wsstcl, wsevs++wssevs) wsGridInfo) ++ wsstcl, wsevs++wssevs)
where (wsstcl,wssevs) = matrix2tcl (nextLabel+length ws) (n+1) wp label confs wss where (wsstcl,wssevs) = matrix2tcl (nextLabel+length ws) (n+1) label confs wss
(wstcl,wsevs) = widgets2tcl wp label nextLabel ws (wstcl,wsevs) = widgets2tcl label nextLabel ws
wsGridInfo = widgets2gridinfo ws wsGridInfo = widgets2gridinfo ws
-- compute the required resize behavior of the top window -- compute the required resize behavior of the top window
resizeBehavior :: [[ConfItem]] -> String resizeBehavior :: [[ConfItem]] -> String
resizeBehavior ws = if any (elem Fill) ws then "1 1" else resizeBehavior ws = if any (any isFill) ws then "1 1" else
if any (elem FillX) ws then "1 0" else if any (any isFillX) ws then "1 0" else
if any (elem FillY) ws then "0 1" else "0 0" if any (any isFillY) ws then "0 1" else "0 0"
-- list of labels of the widgets -- list of labels of the widgets
...@@ -562,26 +580,17 @@ widgets2gridinfo (w:ws) = ...@@ -562,26 +580,17 @@ widgets2gridinfo (w:ws) =
if fillx then [FillX] else if fillx then [FillX] else
if filly then [FillY] else [] if filly then [FillY] else []
hasFillX w = any isFillXConf (propagateFillInfo w) hasFillX w = any isFillX (propagateFillInfo w)
isFillXConf conf = case conf of
FillX -> True
_ -> False
hasFillY w = any isFillYConf (propagateFillInfo w) hasFillY w = any isFillY (propagateFillInfo w)
isFillYConf conf = case conf of
FillY -> True
_ -> False
hasFill w = any isFillConf (propagateFillInfo w) hasFill w = any isFill (propagateFillInfo w)
isFillConf conf = case conf of
Fill -> True
_ -> False
isFillInfo conf = case conf of isFillInfo conf = case conf of
FillX -> True FillX -> True
FillY -> True FillY -> True
Fill -> True Fill -> True
_ -> False _ -> False
-- propagate FillInfo for those kinds of widgets which are resizable on their on -- propagate FillInfo for those kinds of widgets which are resizable on their on
propagateFillInfo (PlainButton _) = [] propagateFillInfo (PlainButton _) = []
...@@ -633,25 +642,25 @@ confCollection2tcl (BottomAlign : confs) = "-sticky s " ++ confCollection2tcl co ...@@ -633,25 +642,25 @@ confCollection2tcl (BottomAlign : confs) = "-sticky s " ++ confCollection2tcl co
-- translate the Fill - options to sticky options and grid configures -- translate the Fill - options to sticky options and grid configures
gridInfo2tcl :: Int -> String -> String -> [ConfItem] -> String gridInfo2tcl :: Int -> String -> String -> [ConfItem] -> String
gridInfo2tcl n label "col" confs 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++ = "-sticky nsew \ngrid columnconfigure "++lab++" "++show n++
" -weight 1\ngrid rowconfigure "++lab++" 1 -weight 1" " -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" " "++show n++" -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++ | any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" 1 -weight 1" " 1 -weight 1"
| otherwise = "" | otherwise = ""
where where
lab = if label=="" then "." else label lab = if label=="" then "." else label
gridInfo2tcl n label "row" confs 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++ = "-sticky nsew \ngrid columnconfigure "++lab++
" 1 -weight 1\ngrid rowconfigure "++lab++" "++show n++" -weight 1" " 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" " 1 -weight 1"
| elem FillY confs = "-sticky ns \ngrid rowconfigure "++lab++ | any isFillY confs = "-sticky ns \ngrid rowconfigure "++lab++
" "++show n++" -weight 1" " "++show n++" -weight 1"
| otherwise = "" | otherwise = ""
where where
lab = if label=="" then "." else label lab = if label=="" then "." else label
...@@ -662,12 +671,12 @@ gridInfo2tcl n label "row" confs ...@@ -662,12 +671,12 @@ gridInfo2tcl n label "row" confs
-- (button/canvas/checkbutton/entry/label/listbox/message/scale/scrollbar/ -- (button/canvas/checkbutton/entry/label/listbox/message/scale/scrollbar/
-- textedit) -- textedit)
-- and the third argument is the widget label -- 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 -- is the state of the widget active ("normal" in Tcl/Tk) or
-- inactive ("disabled" in Tcl/Tk)? -- inactive ("disabled" in Tcl/Tk)?
-- (inactive widgets do not accept any events) -- (inactive widgets do not accept any events)
config2tcl wtype _ label (Active active) = config2tcl wtype label (Active active) =
if wtype=="button" || wtype=="checkbutton" || wtype=="entry" || if wtype=="button" || wtype=="checkbutton" || wtype=="entry" ||
wtype=="menubutton" || wtype=="scale" || wtype=="textedit" wtype=="menubutton" || wtype=="scale" || wtype=="textedit"
then if active then if active
...@@ -677,22 +686,22 @@ config2tcl wtype _ label (Active active) = ...@@ -677,22 +686,22 @@ config2tcl wtype _ label (Active active) =
-- alignment of information inside a widget -- alignment of information inside a widget
-- argument must be: n, ne, e, se, s, sw, w, nw, or center -- 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" || if wtype=="button" || wtype=="checkbutton" || wtype=="label" ||
wtype=="menubutton" || wtype=="message" wtype=="menubutton" || wtype=="message"
then label++" configure -anchor "++align++"\n" then label++" configure -anchor "++align++"\n"
else trace ("WARNING: GUI.Anchor ignored for widget type \""++wtype++"\"\n") "" else trace ("WARNING: GUI.Anchor ignored for widget type \""++wtype++"\"\n") ""
-- background color: -- background color:
config2tcl _ _ label (Background color) config2tcl _ label (Background color)
= label++" configure -background \""++color++"\"\n" = label++" configure -background \""++color++"\"\n"
-- foreground color: -- foreground color:
config2tcl _ _ label (Foreground color) config2tcl _ label (Foreground color)
= label++" configure -foreground \""++color++"\"\n" = label++" configure -foreground \""++color++"\"\n"
-- command associated to various widgets: -- command associated to various widgets:
config2tcl wtype _ label (Handler evtype _) config2tcl wtype label (Handler evtype _)
| evtype == DefaultEvent | evtype == DefaultEvent
= if wtype=="button" = if wtype=="button"
then label++" configure -command"++writeEvent else then label++" configure -command"++writeEvent else
...@@ -715,7 +724,7 @@ config2tcl wtype _ label (Handler evtype _) ...@@ -715,7 +724,7 @@ config2tcl wtype _ label (Handler evtype _)
writeEvent = " { writeevent \""++label++event2tcl evtype++"\" }\n" writeEvent = " { writeevent \""++label++event2tcl evtype++"\" }\n"
-- height of a widget (not defined for all widget types): -- 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=="entry" || wtype=="message" || wtype=="menubutton" ||
wtype=="scale" wtype=="scale"
= trace ("WARNING: GUI.Height ignored for widget type \""++wtype++"\"\n") "" = trace ("WARNING: GUI.Height ignored for widget type \""++wtype++"\"\n") ""
...@@ -726,13 +735,13 @@ config2tcl wtype _ label (Height h) ...@@ -726,13 +735,13 @@ config2tcl wtype _ label (Height h)
= label++" configure -height "++show h++"\n" = label++" configure -height "++show h++"\n"
-- show/hide widget -- show/hide widget
config2tcl _ _ label (Display b) config2tcl _ label (Display b)
= if b then "grid " ++ label ++ "\n" = if b then "grid " ++ label ++ "\n"
else "grid remove " ++ label ++ "\n" else "grid remove " ++ label ++ "\n"
-- value of checkbuttons: -- value of checkbuttons:
config2tcl wtype _ label (CheckInit s) config2tcl wtype label (CheckInit s)
| wtype=="checkbutton" | wtype=="checkbutton"
= "setvar"++wLabel2Refname label++" \""++s++"\"\n"