------------------------------------------------------------------------------ --- This library contains definitions and functions to implement --- graphical user interfaces for Curry programs. --- It is based on Tcl/Tk and its basic ideas are described in detail in the --- [PADL 2000 paper](https://doi.org/10.1007/3-540-46584-7_4). --- --- @authors Michael Hanus, Bernd Brassel --- @version November 2020 ------------------------------------------------------------------------------ {-# OPTIONS_FRONTEND --case-mode=free #-} module Graphics.UI ( GuiPort, Widget(..), Button, ConfigButton , TextEditScroll, ListBoxScroll, CanvasScroll, EntryScroll , ConfItem(..), ReconfigureItem(..) , Cmd, Command, Event(..), ConfCollection(..), MenuItem(..) , CanvasItem(..), WidgetRef, Style(..), Color(..) , col, row, matrix , runGUI, runGUIwithParams, runInitGUI, runInitGUIwithParams , runPassiveGUI , runControlledGUI, runConfigControlledGUI, runInitControlledGUI , runHandlesControlledGUI, runInitHandlesControlledGUI , exitGUI, getValue, setValue, updateValue, appendValue , appendStyledValue, addRegionStyle, removeRegionStyle , getCursorPosition, seeText , focusInput, addCanvas, setConfig , getOpenFile, getOpenFileWithTypes, getSaveFile, getSaveFileWithTypes , chooseColor, popupMessage, debugTcl ) where import Control.Monad ( when ) import Data.Char ( isSpace, toUpper ) import Debug.Trace ( trace ) import System.IO import System.IOExts ( connectToCommand ) import System.Process ( system ) -- If showTclTkErrors is true, all synchronization errors occuring in the -- 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 :: Bool showTclTkErrors = False -- If showTclTkCommunication is true, the all strings sent to and from -- the Tcl/Tk GUI are shown in stdout: showTclTkCommunication :: Bool showTclTkCommunication = False --- The port to a GUI is just the stream connection to a GUI --- where Tcl/Tk communication is done. data GuiPort = GuiPort Handle handleOf :: GuiPort -> Handle handleOf (GuiPort h) = h ------------------------------------------------------------------------ -- the basic data types for GUIs: ------------------------------------------------------------------------ --- The type of possible widgets in a GUI. --- @cons PlainButton - a button in a GUI whose event handler is activated --- if the user presses the button --- @cons Canvas - a canvas to draw pictures containing CanvasItems --- @cons CheckButton - a check button: it has value "0" if it is unchecked and --- value "1" if it is checked --- @cons Entry - an entry widget for entering single lines --- @cons Label - a label for showing a text --- @cons ListBox - a widget containing a list of items for selection --- @cons Message - a message for showing simple string values --- @cons MenuButton - a button with a pull-down menu --- @cons Scale - a scale widget to input values by a slider --- @cons ScrollH - a horizontal scroll bar --- @cons ScrollV - a vertical scroll bar --- @cons TextEdit - a text editor widget to show and manipulate larger --- text paragraphs --- @cons Row - a horizontal alignment of widgets --- @cons Col - a vertical alignment of widgets --- @cons Matrix - a 2-dimensional (matrix) alignment of widgets data Widget = PlainButton [ConfItem] | Canvas [ConfItem] | CheckButton [ConfItem] | Entry [ConfItem] | Label [ConfItem] | ListBox [ConfItem] | Message [ConfItem] | MenuButton [ConfItem] | Scale Int Int [ConfItem] | ScrollH WidgetRef [ConfItem] | ScrollV WidgetRef [ConfItem] | TextEdit [ConfItem] | Row [ConfCollection] [Widget] | Col [ConfCollection] [Widget] | Matrix [ConfCollection] [[Widget]] --- The data type for possible configurations of a widget. --- @cons Active - define the active state for buttons, entries, etc. --- @cons Anchor - alignment of information inside a widget where the --- argument must be: n, ne, e, se, s, sw, w, nw, or center --- @cons Background - the background color --- @cons Foreground - the foreground color --- @cons Handler - an event handler associated to a widget. --- The event handler returns a list of widget --- ref/configuration pairs that are applied after the handler --- in order to configure GUI widgets --- @cons Height - the height of a widget (chars for text, pixels for graphics) --- @cons CheckInit - initial value for checkbuttons --- @cons CanvasItems - list of items contained in a canvas --- @cons List - list of values shown in a listbox --- @cons Menu - the items of a menu button --- @cons WRef - a reference to this widget --- @cons Text - an initial text contents --- @cons Width - the width of a widget (chars for text, pixels for graphics) --- @cons Fill - fill widget in both directions --- @cons FillX - fill widget in horizontal direction --- @cons FillY - fill widget in vertical direction --- @cons TclOption - further options in Tcl syntax (unsafe!) data ConfItem = Active Bool | Anchor String | Background String | Foreground String | Handler Event (GuiPort -> IO [ReconfigureItem]) | Height Int | CheckInit String | CanvasItems [CanvasItem] | List [String] | Menu [MenuItem] | WRef WidgetRef | Text String | Width Int | Fill | FillX | FillY | TclOption String 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 --- with configuration item conf --- @cons StreamHandler hdl handler - add a new handler to the GUI --- that processes inputs on an input stream referred by hdl --- @cons RemoveStreamHandler hdl - remove a handler for an input stream --- referred by hdl from the GUI (usually used to remove handlers --- for closed streams) data ReconfigureItem = WidgetConf WidgetRef ConfItem | StreamHandler Handle (Handle -> GuiPort -> IO [ReconfigureItem]) | RemoveStreamHandler Handle --- The data type of possible events on which handlers can react. --- This list is still incomplete and might be extended or restructured --- in future releases of this library. --- @cons DefaultEvent - the default event of the widget --- @cons MouseButton1 - left mouse button pressed --- @cons MouseButton2 - middle mouse button pressed --- @cons MouseButton3 - right mouse button pressed --- @cons KeyPress - any key is pressed --- @cons Return - return key is pressed data Event = DefaultEvent | MouseButton1 | MouseButton2 | MouseButton3 | KeyPress | Return deriving Eq -- translate event into corresponding Tcl string (except for DefaultEvent) -- with a leading blank: event2tcl :: Event -> String event2tcl DefaultEvent = " default" event2tcl MouseButton1 = " " event2tcl MouseButton2 = " " event2tcl MouseButton3 = " " event2tcl KeyPress = " " event2tcl Return = " " --- The data type for possible configurations of widget collections --- (e.g., columns, rows). --- @cons CenterAlign - centered alignment --- @cons LeftAlign - left alignment --- @cons RightAlign - right alignment --- @cons TopAlign - top alignment --- @cons BottomAlign - bottom alignment data ConfCollection = CenterAlign | LeftAlign | RightAlign | TopAlign | BottomAlign --- The data type for specifying items in a menu. --- @cons MButton - a button with an associated command --- and a label string --- @cons MSeparator - a separator between menu entries --- @cons MMenuButton - a submenu with a label string data MenuItem = MButton (GuiPort -> IO [ReconfigureItem]) String | MSeparator | MMenuButton String [MenuItem] --- The data type of items in a canvas. --- The last argument are further options in Tcl/Tk (for testing). data CanvasItem = CLine [(Int,Int)] String | CPolygon [(Int,Int)] String | CRectangle (Int,Int) (Int,Int) String | COval (Int,Int) (Int,Int) String | CText (Int,Int) String 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 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 String String wRef2Label :: WidgetRef -> String wRef2Label (WRefLabel var _) = wRefname2Label var wRef2Wtype :: WidgetRef -> String wRef2Wtype (WRefLabel _ wtype) = wtype --- The data type of possible text styles. --- @cons Bold - text in bold font --- @cons Italic - text in italic font --- @cons Underline - underline text --- @cons Fg - foreground color, i.e., color of the text font --- @cons Bg - background color of the text data Style = Bold | Italic | Underline | Fg Color | Bg Color --- The data type of possible colors. data Color = Black | Blue | Brown | Cyan | Gold | Gray | Green | Magenta | Navy | Orange | Pink | Purple | Red | Tomato| Turquoise | Violet | White | Yellow --- Converts a style value into its textual representation. showStyle :: Style -> String showStyle Bold = "bold" showStyle Italic = "italic" showStyle Underline = "underline" showStyle (Fg fg) = dropSpaces $ showColor fg showStyle (Bg bg) = camelCase $ showColor bg dropSpaces :: String -> String dropSpaces = filter (not . isSpace) camelCase :: String -> String camelCase [] = [] camelCase (c:cs) = toUpper c : cc cs where cc "" = "" cc [x] = [x] cc (x:y:xs) | isSpace x = toUpper y : cc xs | otherwise = x : cc (y:xs) --- Converts a color value into its textual representation. showColor :: Color -> String showColor Black = "black" showColor Blue = "blue" showColor Brown = "brown" showColor Cyan = "cyan" showColor Gold = "gold" showColor Gray = "gray" showColor Green = "forest green" showColor Magenta = "magenta" showColor Navy = "navy" showColor Orange = "orange" showColor Pink = "pink" showColor Purple = "purple" showColor Red = "red" showColor Tomato = "tomato" showColor Turquoise = "turquoise" showColor Violet = "violet" showColor White = "white" showColor Yellow = "yellow" ------------------------------------------------------------------------ -- Some useful abbreviations: ------------------------------------------------------------------------ --- Horizontal alignment of widgets. row :: [Widget] -> Widget row = Row [] --- Vertical alignment of widgets. col :: [Widget] -> Widget col = Col [] --- Matrix alignment of widgets. matrix :: [[Widget]] -> Widget matrix = Matrix [] ------------------------------------------------------------------------ -- internal translation functions from GUI terms into Tcl: ------------------------------------------------------------------------ -- An event handler specification consists of an identifying string of -- the widget for which this handler is repsonsible, an event type -- to which the handler should react, and a handler: type EventHandler = (String,Event,GuiPort -> IO [ReconfigureItem]) -- translate a widget into a pair of Tcl command string / event list -- argument 1: port for the GUI -- argument 2: current label prefix -- argument 3: the widget to translate -- result: pair of (Tcl command string, -- list of (eventname, eventtype, eventhandler)) widget2tcl :: String -> Widget -> (String,[EventHandler]) widget2tcl label (PlainButton confs) = ("button "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "button" label confs widget2tcl label (Canvas confs) = ("canvas "++label++"\n" ++"set "++refname++"_scrollx 100\n" ++"set "++refname++"_scrolly 100\n" ++"proc set"++refname++"_scrollx {x}" ++" { global "++refname++"_scrollx ; global "++refname++"_scrolly ;\n" ++" if {$"++refname++"_scrollx < $x} {set "++refname++"_scrollx $x ;\n" ++" "++label++" configure -scrollregion [list 0 0 $" ++refname++"_scrollx $"++refname++"_scrolly]}}\n" ++"proc set"++refname++"_scrolly {y}" ++" { global "++refname++"_scrollx ; global "++refname++"_scrolly ;\n" ++" if {$"++refname++"_scrolly < $y} {set "++refname++"_scrolly $y ;\n" ++" "++label++" configure -scrollregion [list 0 0 $" ++refname++"_scrollx $"++refname++"_scrolly]}}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "canvas" label confs widget2tcl label (CheckButton confs) = ("checkbutton "++label++"\n" ++ label++" configure -variable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "checkbutton" label 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 $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label widget2tcl label (Label confs) = ("label "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "label" label 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" label confs widget2tcl label (Message confs) = ("message "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "message" label confs widget2tcl label (MenuButton confs) = ("menubutton "++label++"\n" ++ label++" configure -textvariable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "menubutton" label 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 label++" configure -variable "++refname++"\n" ++ "proc getvar"++refname++" {} { global "++refname++" ; return $" ++refname++" }\n" ++ "proc setvar"++refname++" {s} { global "++refname++" ; set " ++refname++" $s}\n" ++ conf_tcl , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "scale" label confs widget2tcl label (ScrollH widget confs) = ("scrollbar "++label++" -orient horizontal -command {"++ wRef2Label widget++" xview}\n" ++ wRef2Label widget++" configure -xscrollcommand {"++label++" set}\n" ++ conf_tcl , conf_evs) where (conf_tcl,conf_evs) = configs2tcl "scrollbar" label 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" label 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 ; " ++label++" insert 1.0 $s}\n" ++ conf_tcl ++ enableFont "italic" "-slant italic" ++ enableFont "underline" "-underline on" ++ enableFont "bold" "-weight bold" ++ unlines (map enableForeground colors) ++ unlines (map enableBackground colors) , conf_evs) where refname = wLabel2Refname label (conf_tcl,conf_evs) = configs2tcl "textedit" label confs enableFont tag style = label ++ " tag configure " ++ tag ++ " -font \"[font actual [" ++ label ++ " cget -font]] " ++ style ++ "\"\n" colors = map showColor [Black,Blue,Brown,Cyan,Gold,Gray,Green,Magenta,Navy,Orange,Pink ,Purple,Red,Tomato,Turquoise,Violet,White,Yellow] enableForeground color = label ++ " tag configure " ++ dropSpaces color ++ " -foreground \"" ++ color ++ "\"" enableBackground color = label++" tag configure "++ camelCase color ++ " -background \"" ++ color ++ "\"" 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 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 label (Matrix confs ws) = ((if label == "" then "wm resizable . " ++ resizeBehavior wsGridInfo++"\n" else "frame "++label++"\n") ++ wstcl,wsevs) where (wstcl,wsevs) = matrix2tcl 97 1 label confs ws wsGridInfo = concatMap widgets2gridinfo ws -- actual translation function of the list of lists of widgets in a matrix matrix2tcl :: Int -> Int -> String -> [ConfCollection] -> [[Widget]] -> (String,[EventHandler]) matrix2tcl _ _ _ _ [] = ("",[]) matrix2tcl nextLabel n label confs (ws:wss) = (wstcl ++ (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) 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 (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 widgets2gridinfo :: [Widget] -> [[ConfItem]] widgets2gridinfo [] = [] widgets2gridinfo (w:ws) = (tclfill ++ getConfs w): widgets2gridinfo ws where fillx = hasFillX w filly = hasFillY w flexible = hasFill w tclfill = if flexible || (fillx && filly) then [Fill] else if fillx then [FillX] else if filly then [FillY] else [] hasFillX :: Widget -> Bool hasFillX w = any isFillX (propagateFillInfo w) hasFillY :: Widget -> Bool hasFillY w = any isFillY (propagateFillInfo w) hasFill :: Widget -> Bool hasFill w = any isFill (propagateFillInfo w) isFillInfo :: ConfItem -> Bool isFillInfo conf = case conf of FillX -> True FillY -> True Fill -> True _ -> False -- propagate FillInfo for those kinds of widgets which are resizable on their on propagateFillInfo :: Widget -> [ConfItem] propagateFillInfo (PlainButton _) = [] propagateFillInfo (Canvas confs) = filter isFillInfo confs propagateFillInfo (CheckButton _) = [] propagateFillInfo (Entry confs) = filter isFillInfo confs propagateFillInfo (Label confs) = filter isFillInfo confs propagateFillInfo (ListBox confs) = filter isFillInfo confs propagateFillInfo (Message confs) = filter isFillInfo confs propagateFillInfo (MenuButton _) = [] propagateFillInfo (Scale _ _ confs) = filter isFillInfo confs propagateFillInfo (ScrollV _ _) = [] propagateFillInfo (ScrollH _ _) = [] propagateFillInfo (TextEdit confs) = filter isFillInfo confs propagateFillInfo (Row _ ws) = concatMap propagateFillInfo ws propagateFillInfo (Col _ ws) = concatMap propagateFillInfo ws propagateFillInfo (Matrix _ wss) = concatMap (concatMap propagateFillInfo) wss -- get the configurations of a widget getConfs :: Widget -> [ConfItem] getConfs (PlainButton confs) = confs getConfs (Canvas confs) = filter isFillInfo confs getConfs (CheckButton confs) = confs getConfs (Entry confs) = filter isFillInfo confs getConfs (Label confs) = filter isFillInfo confs getConfs (ListBox confs) = filter isFillInfo confs getConfs (Message confs) = filter isFillInfo confs getConfs (MenuButton confs) = confs getConfs (Scale _ _ confs) = filter isFillInfo confs getConfs (ScrollV _ confs) = confs getConfs (ScrollH _ confs) = confs getConfs (TextEdit confs) = filter isFillInfo confs getConfs (Row _ _) = [] getConfs (Col _ _) = [] getConfs (Matrix _ _) = [] -- translate configuration options for collections (rows or columns) -- into parameters for the Tcl/Tk command "grid": confCollection2tcl :: [ConfCollection] -> String confCollection2tcl [] = "" confCollection2tcl (CenterAlign : confs) = confCollection2tcl confs confCollection2tcl (LeftAlign : confs) = "-sticky w " ++ confCollection2tcl confs confCollection2tcl (RightAlign : confs) = "-sticky e " ++ confCollection2tcl confs confCollection2tcl (TopAlign : confs) = "-sticky n " ++ confCollection2tcl confs confCollection2tcl (BottomAlign : confs) = "-sticky s " ++ confCollection2tcl confs -- translate the Fill - options to sticky options and grid configures gridInfo2tcl :: Int -> String -> String -> [ConfItem] -> String gridInfo2tcl n label colrow confs | colrow == "col" = gridColInfo2tcl (if null label then "." else label) | colrow == "row" = gridRowInfo2tcl (if null label then "." else label) | otherwise = "" where gridColInfo2tcl lab | any isFill confs || (any isFillX confs && any isFillY confs) = "-sticky nsew \ngrid columnconfigure " ++ lab ++ " " ++ show n ++ " -weight 1\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 = "" gridRowInfo2tcl lab | any isFill confs || (any isFillX confs && any isFillY confs) = "-sticky nsew \ngrid columnconfigure " ++ lab ++ " 1 -weight 1\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 = "" -- translate a single configuration option into Tcl/Tk commands -- to configure the widget: -- the first argument specifies the type of the widget -- (button/canvas/checkbutton/entry/label/listbox/message/scale/scrollbar/ -- textedit) -- and the third argument is the widget label 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) = if wtype=="button" || wtype=="checkbutton" || wtype=="entry" || wtype=="menubutton" || wtype=="scale" || wtype=="textedit" then if active then label ++ " configure -state normal\n" else label ++ " configure -state disabled\n" else trace ("WARNING: GUI.Active ignored for widget type \"" ++ wtype ++ "\"\n") "" -- alignment of information inside a widget -- argument must be: n, ne, e, se, s, sw, w, nw, or center 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) = label ++ " configure -background \"" ++ color ++ "\"\n" -- foreground color: config2tcl _ label (Foreground color) = label ++ " configure -foreground \"" ++ color ++ "\"\n" -- command associated to various widgets: config2tcl wtype label (Handler evtype _) | evtype == DefaultEvent = if wtype=="button" then label++" configure -command"++writeEvent else if wtype=="checkbutton" then label++" configure -command"++writeEvent else if wtype=="entry" then "bind "++label++" "++writeEvent else if wtype=="scale" then label++" configure -command { putlabel \""++label++event2tcl evtype++"\"}\n" else if wtype=="listbox" then "bind "++label++" "++writeEvent else if wtype=="textedit" then "bind "++label++" "++writeEvent else trace ("WARNING: GUI.Handler with DefaultEvent ignored for widget type \""++ wtype++"\"\n") "" | otherwise = "bind "++label++event2tcl evtype++writeEvent where writeEvent = " { writeevent \""++label++event2tcl evtype++"\" }\n" -- height of a widget (not defined for all widget types): config2tcl wtype label (Height h) | wtype=="entry" || wtype=="message" || wtype=="menubutton" || wtype=="scale" = trace ("WARNING: GUI.Height ignored for widget type \""++wtype++"\"\n") "" | wtype=="canvas" = label++" configure -height "++show h++"\n"++ "set"++wLabel2Refname label++"_scrolly "++show h++"\n" | otherwise = label++" configure -height "++show h++"\n" -- value of checkbuttons: config2tcl wtype label (CheckInit s) | wtype=="checkbutton" = "setvar"++wLabel2Refname label++" \""++s++"\"\n" | otherwise = trace ("WARNING: GUI.CheckInit ignored for widget type \""++wtype++"\"\n") "" -- items in a canvas: 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) | wtype=="listbox" = label++" delete 0 end\n" ++ setlistelems (ensureSpine l) | otherwise = trace ("WARNING: GUI.List ignored for widget type \""++wtype++"\"\n") "" where setlistelems [] = "" setlistelems (e:es) = label++" insert end \""++escapeTcl e++"\"\n"++ setlistelems es -- items in a menu button: config2tcl wtype label (Menu l) | wtype=="menubutton" = label++" configure -menu "++label++".a\n" ++ menu2tcl (label++".a") l | otherwise = trace ("WARNING: GUI.Menu ignored for widget type \""++wtype++"\"\n") "" -- references to widgets are bound to actual widget labels: config2tcl wtype label (WRef r) | r =:= WRefLabel (wLabel2Refname label) wtype = "" -- initial text value of widgets: config2tcl wtype label (Text s) | wtype=="canvas" = trace "WARNING: GUI.Text ignored for Canvas\n" "" | wtype=="checkbutton" = label++" configure -text \""++escapeTcl s++"\"\n" | otherwise = "setvar"++wLabel2Refname label++" \""++escapeTcl s++"\"\n" -- width of a widget: config2tcl wtype label (Width w) | wtype=="canvas" = label++" configure -width "++show w++"\n"++ "set"++wLabel2Refname label++"_scrollx "++show w++"\n" | otherwise = label++" configure -width "++show w++"\n" -- configuration options for widget composition are ignored here -- since they are used during geometry management config2tcl _ _ Fill = "" config2tcl _ _ FillX = "" config2tcl _ _ FillY = "" -- for testing, put arbitrary Tk options for this widget: config2tcl _ label (TclOption tcloptions) = label++" configure "++tcloptions++"\n" -- translation of a menu with a given label: menu2tcl :: String -> [MenuItem] -> String menu2tcl label menu = "menu "++label++" -tearoff false\n" ++ label++" delete 0 end\n" ++ setmenuelems menu 0 where setmenuelems [] _ = "" setmenuelems (MButton _ text : es) i = 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 \""++escapeTcl text++ "\" -menu "++label++labelIndex2string (i+97)++"\n"++ menu2tcl (label++labelIndex2string (i+97)) l ++ setmenuelems es (i+1) -- get the event handlers in a list of configuration options: -- and bind widget references: configs2handler :: String -> [ConfItem] -> [EventHandler] configs2handler _ [] = [] configs2handler label (confitem : cs) = case confitem of Handler evtype handler -> (label,evtype,handler) : configs2handler label cs Menu m -> menu2handler (label++".a") m 0 ++ configs2handler label cs _ -> configs2handler label cs menu2handler :: String -> [MenuItem] -> Int -> [(String,Event,GuiPort -> IO [ReconfigureItem])] menu2handler _ [] _ = [] menu2handler label (MButton handler _ : ms) i = (label++"."++show i, DefaultEvent, handler) : menu2handler label ms (i+1) menu2handler label (MSeparator : ms) i = menu2handler label ms (i+1) menu2handler label (MMenuButton _ menu : ms) i = menu2handler (label++labelIndex2string (i+97)) menu 0 ++ menu2handler label ms (i+1) -- translate configuration options into Tcl/Tk commands and event handler map: configs2tcl :: String -> String -> [ConfItem] -> (String,[EventHandler]) configs2tcl wtype label confs = (concatMap (config2tcl wtype label) confs, configs2handler label confs) -- translate a list of canvas items into a Tcl string: canvasItems2tcl :: String -> [CanvasItem] -> String canvasItems2tcl _ [] = "" canvasItems2tcl label (i:is) = canvasItem2tcl label i ++ canvasItems2tcl label is canvasItem2tcl :: String -> CanvasItem -> String canvasItem2tcl label (CLine coords opts) = label++ " create line "++showCoords coords++" "++opts++"\n"++ concatMap (\(x,_)->"set"++refname++"_scrollx "++show x++"\n") coords ++ concatMap (\(_,y)->"set"++refname++"_scrolly "++show y++"\n") coords where refname = wLabel2Refname label canvasItem2tcl label (CPolygon coords opts) = label++ " create polygon "++showCoords coords++" "++opts++"\n"++ concatMap (\(x,_)->"set"++refname++"_scrollx "++show x++"\n") coords ++ concatMap (\(_,y)->"set"++refname++"_scrolly "++show y++"\n") coords where refname = wLabel2Refname label canvasItem2tcl label (CRectangle (x1,y1) (x2,y2) opts) = label++ " create rectangle "++showCoords [(x1,y1),(x2,y2)]++" "++opts++"\n"++ concatMap (\x->"set"++refname++"_scrollx "++show x++"\n") [x1,x2] ++ concatMap (\y->"set"++refname++"_scrolly "++show y++"\n") [y1,y2] where refname = wLabel2Refname label canvasItem2tcl label (COval (x1,y1) (x2,y2) opts) = label++ " create oval "++showCoords [(x1,y1),(x2,y2)]++" "++opts++"\n"++ concatMap (\x->"set"++refname++"_scrollx "++show x++"\n") [x1,x2] ++ concatMap (\y->"set"++refname++"_scrolly "++show y++"\n") [y1,y2] where refname = wLabel2Refname label canvasItem2tcl label (CText (x,y) text opts) = label++ " create text "++show x++" "++show y++ " -text \""++escapeTcl text++"\" "++opts++"\n"++ "set"++refname++"_scrollx "++show (x+5*(length text))++"\n"++ "set"++refname++"_scrolly "++show y++"\n" where refname = wLabel2Refname label showCoords :: [(Int,Int)] -> String showCoords [] = "" showCoords ((x,y):cs) = show x ++ " " ++ show y ++ " " ++ showCoords cs -- translate a widget label into a name (replacing dots by underscores) wLabel2Refname :: String -> String wLabel2Refname l = map (\c -> if c=='.' then '_' else c) l -- translate a name into a widget label (replacing underscores by dots) wRefname2Label :: String -> String wRefname2Label l = map (\c -> if c=='_' then '.' else c) l -- translate a list of widgets into pair Tcl string / event list: widgets2tcl :: String -> Int -> [Widget] -> (String,[(String,Event,GuiPort -> IO [ReconfigureItem])]) 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"): labelIndex2string :: Int -> String labelIndex2string li = if li<123 then ['.',chr li] else ['.','z'] ++ show (li-122) -- translate main 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 "" widget --- Prints the generated Tcl commands of a main widget (useful for debugging). debugTcl :: Widget -> IO () debugTcl widget = putStrLn (fst (mainWidget2tcl widget)) ------------------------------------------------------------------------ -- Operations to communicate with Tcl/Tk: ------------------------------------------------------------------------ reportTclTk :: String -> IO () reportTclTk s = when showTclTkCommunication $ hPutStrLn stdout s reportTclTkError :: String -> IO () reportTclTkError s = when showTclTkErrors $ hPutStrLn stderr s -- Open a GUI port by connecting to new "wish" process. -- The first argument are parameters passed to the wish command. openGuiPort :: String -> IO GuiPort openGuiPort wishparams = do exwish <- system "which wish > /dev/null" when (exwish>0) $ error "Windowing shell `wish' not found. Please install package `tk'!" reportTclTk $ "OPEN CONNECTION TO WISH WITH PARAMS: " ++ wishparams tclhdl <- connectToCommand ("wish " ++ wishparams) return (GuiPort tclhdl) -- Send a string (Tcl/Tk command) to GUI port: send2tk :: String -> GuiPort -> IO () send2tk s (GuiPort tclhdl) = do reportTclTk ("GUI SEND: "++s) hPutStrLn tclhdl s hFlush tclhdl -- Receive an output line from the wish process: receiveFromTk :: GuiPort -> IO String receiveFromTk (GuiPort tclhdl) = do s <- hGetLine tclhdl reportTclTk $ "GUI RECEIVED: " ++ s return s -- Choice over the output of the wish process and handles to input streams: choiceOverHandles :: [Handle] -> IO (Int,Handle) choiceOverHandles hdls = do i <- if length hdls == 1 then return 0 else hWaitForInputs hdls (-1) return (i, hdls!!i) -- Close connection to wish process: closeGuiPort :: GuiPort -> IO () closeGuiPort (GuiPort tclhdl) = do reportTclTk "CLOSE CONNECTION TO WISH" hClose tclhdl ------------------------------------------------------------------------ -- functions for running a GUI: ------------------------------------------------------------------------ --- Creates a new GUI window with a "title" for the top-level window --- (but unspecified contents). A GUI port is returned that can be --- used to start a GUI specification on this port. --- @param title - the title of the top-level window --- @param params - parameter string passed to the initial wish command openWish :: String -> String -> IO GuiPort openWish title params = do gport <- openGuiPort params send2tk ("wm title . \""++title++"\"\n") gport return gport --- IO action to show a Widget in a new GUI window in passive mode, --- i.e., ignore all GUI events. --- @param title - the title of the main window containing the widget --- @param widget - the widget shown in the new window runPassiveGUI :: String -> Widget -> IO GuiPort runPassiveGUI title widget = do gport <- openWish (escapeTcl title) "" send2tk (fst (mainWidget2tcl widget)) gport return gport --- IO action to run a Widget in a new window. --- @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 (return [])) --- IO action to run a Widget in a new window. --- @param title - the title of the main window containing the widget --- @param params - parameter string passed to the initial wish command --- @param widget - the widget shown in the new window runGUIwithParams :: String -> String -> Widget -> IO () runGUIwithParams title params widget = 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 [ReconfigureItem]) -> IO () runInitGUI title widget initcmd = do 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. --- @param title - the title of the main GUI window --- @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 [ReconfigureItem]) -> IO () runInitGUIwithParams title params widget initcmd = do 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 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 written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- @param hdl - the handle of the stream of external messages runControlledGUI :: String -> (Widget, String -> GuiPort -> IO ()) -> Handle -> IO () runControlledGUI title (widget,exth) hdl = runInitControlledGUI title (widget,exth) (\_->return []) hdl --- 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 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 written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- that returns a list of widget reference/configuration pairs --- which is applied after the handler in order to configure --- some GUI widgets --- @param hdl - the handle of the stream of external messages runConfigControlledGUI :: String -> (Widget, String -> GuiPort -> IO [ReconfigureItem]) -> Handle -> IO () runConfigControlledGUI title (widget,exth) hdl = do gport <- openWish (escapeTcl title) "" initSchedule widget gport [msgToIOHandler exth hdl] (\_->return []) --- Runs a Widget in a new GUI window and process GUI events --- after executing an initial action on the GUI window. --- In addition, an event handler is provided that process --- messages received from an external message stream. --- This operation is useful to run a GUI that should react on --- user events as well as messages written to the given handle. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,exth) where widget is the widget shown in the --- new window and exth is the event handler for external messages --- @param initcmd - the initial command executed before starting the GUI --- @param hdl - the handle of the stream of external messages runInitControlledGUI :: String -> (Widget, String -> GuiPort -> IO ()) -> (GuiPort -> IO [ReconfigureItem]) -> Handle -> IO () runInitControlledGUI title (widget,exth) initcmd hdl = do gport <- openWish (escapeTcl title) "" initSchedule widget gport [msgToIOHandler (\ x y -> exth x y >> return []) hdl] initcmd msgToIOHandler :: (String -> GuiPort -> IO [ReconfigureItem]) -> Handle -> ExternalHandler msgToIOHandler hdler hdl = IOHandler (hdl,\ _ hd gp -> do l <- hGetLine hd cfs <- hdler l gp return (Just cfs)) --- Runs a Widget in a new GUI window and process GUI events. --- In addition, a list of event handlers is provided that process --- inputs received from a corresponding list of handles to input streams. --- Thus, if the i-th handle has some data available, the i-th event handler --- is executed with the i-th handle as a parameter. --- This operation is useful to run a GUI that should react on --- inputs provided by other processes, e.g., via sockets. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,handlers) where widget is the widget shown in the --- new window and handlers is a list of event handler for external inputs --- @param handles - a list of handles to the external input streams for the --- corresponding event handlers runHandlesControlledGUI :: String -> (Widget,[Handle -> GuiPort -> IO [ReconfigureItem]]) -> [Handle] -> IO () runHandlesControlledGUI title widgethandlers handles = runInitHandlesControlledGUI title widgethandlers (\_->return []) handles --- Runs a Widget in a new GUI window and process GUI events --- after executing an initial action on the GUI window. --- In addition, a list of event handlers is provided that process --- inputs received from a corresponding list of handles to input streams. --- Thus, if the i-th handle has some data available, the i-th event handler --- is executed with the i-th handle as a parameter. --- This operation is useful to run a GUI that should react on --- inputs provided by other processes, e.g., via sockets. --- @param title - the title of the main window containing the widget --- @param th - a pair (widget,handlers) where widget is the widget shown in the --- new window and handlers is a list of event handler for external inputs --- @param initcmd - the initial command executed before starting the GUI --- @param handles - a list of handles to the external input streams for the --- corresponding event handlers runInitHandlesControlledGUI :: String -> (Widget,[Handle -> GuiPort -> IO [ReconfigureItem]]) -> (GuiPort -> IO [ReconfigureItem]) -> [Handle] -> IO () runInitHandlesControlledGUI title (widget,handlers) initcmd handles = do gport <- openWish (escapeTcl title) "" initSchedule widget gport (map IOHandler (zip handles (map toIOHandler handlers))) initcmd -- The type of external event handlers currently supported. -- It is either a handler processing messages from an external port -- or a handler processing input from various IO streams data ExternalHandler = IOHandler (Handle, [EventHandler] -> Handle -> GuiPort -> IO (Maybe [ReconfigureItem])) -- start the scheduler (see below) with a given Widget on a wish port -- and an initial command: initSchedule :: Widget -> GuiPort -> [ExternalHandler] -> (GuiPort -> IO [ReconfigureItem]) -> IO () initSchedule widget gport exths initcmd = do send2tk tcl gport confs <- initcmd gport -- add handler on wish connection as first handler: configAndProceedScheduler evs gport (IOHandler (handleOf gport, processTkEvent) : exths) (Just confs) where (tcl,evs) = mainWidget2tcl widget -- Scheduler for Tcl/Tk events: -- -- Meaning of arguments: -- evs: list of EventHandlers -- gport: port to a wish -- exth: handler for external messages -- msgs: list of external messages scheduleTkEvents :: [EventHandler] -> GuiPort -> [ExternalHandler] -> IO () -- schedule GUI with handler for external port: scheduleTkEvents evs gport exthds = do (i,hdl) <- choiceOverHandles (map fst iohandlers) if i<0 then return () else snd (iohandlers!!i) evs hdl gport >>= configAndProceedScheduler evs gport exthds where iohandlers = map (\ (IOHandler x) -> x) exthds -- process an event from the wish and return the new configuration items: processTkEvent :: [EventHandler] -> Handle -> GuiPort -> IO (Maybe [ReconfigureItem]) processTkEvent evs str gport = do eof <- hIsEOF str if eof then do reportTclTk "Connection closed (by wish)" return Nothing else do ans <- hGetLine str reportTclTk ("GUI RECEIVED: "++ans) if take 4 ans == ":EVT" then do let (evwidget,evtype) = break (==' ') (drop 4 ans) configs <- selectEvent evwidget evtype evs gport return (Just configs) else do reportTclTkError $ "ERROR in scheduleTkEvents: Received: " ++ ans -- ignore other outputs: return (Just []) -- Reconfigure scheduler with new configurations and proceed. -- If the configs are Nothing, then terminate the scheduler -- (this case occurs of the connection is closed by wish) configAndProceedScheduler :: [(String,Event,GuiPort -> IO [ReconfigureItem])] -> GuiPort -> [ExternalHandler] -> Maybe [ReconfigureItem] -> IO () configAndProceedScheduler _ gport _ Nothing = closeGuiPort gport configAndProceedScheduler evs gport exths (Just configs) = do mapM_ reconfigureGUI configs scheduleTkEvents (configEventHandlers evs configs) gport (configStreamHandlers exths configs) where reconfigureGUI (WidgetConf r ci) = setConfig r ci gport reconfigureGUI (StreamHandler _ _) = return () reconfigureGUI (RemoveStreamHandler _) = return () configEventHandlers :: [(String,Event,GuiPort -> IO [ReconfigureItem])] -> [ReconfigureItem] -> [(String,Event,GuiPort -> IO [ReconfigureItem])] configEventHandlers evs [] = evs configEventHandlers evs (WidgetConf ref confitem : confitems) = let label = wRef2Label ref in case confitem of Handler evtype handler -> configEventHandlers ((label,evtype,handler) : (filter (\ (l,t,_)->l/=label || t/=evtype) evs)) confitems _ -> configEventHandlers evs confitems configEventHandlers evs (StreamHandler _ _ : confitems) = configEventHandlers evs confitems configEventHandlers evs (RemoveStreamHandler _ : confitems) = configEventHandlers evs confitems -- reconfigure external stream handlers: configStreamHandlers :: [ExternalHandler] -> [ReconfigureItem] -> [ExternalHandler] configStreamHandlers exths [] = exths configStreamHandlers exths (WidgetConf _ _ : confitems) = configStreamHandlers exths confitems configStreamHandlers exths (StreamHandler handle handler : confitems) = configStreamHandlers (exths++[IOHandler (handle,\_ hdl gp -> handler hdl gp >>= return . Just)]) confitems configStreamHandlers exths (RemoveStreamHandler handle : confitems) = configStreamHandlers (removeHandler handle exths) confitems where removeHandler _ [] = [] removeHandler h (IOHandler (h',hr) : ehs) = if h==h' then removeHandler h ehs else IOHandler (h',hr) : removeHandler h ehs -- transform external handler into an IO Handler used in the scheduler -- which always returns empty configurations: toIOHandler :: (a -> b -> IO c) -> _ -> a -> b -> IO (Maybe c) toIOHandler handler _ handle gport = handler handle gport >>= return . Just --- Changes the current configuration of a widget --- (deprecated operation, only included for backward compatibility). --- Warning: does not work for Command options! setConfig :: WidgetRef -> ConfItem -> GuiPort -> IO () setConfig (WRefLabel var wtype) confitem gport = send2tk (config2tcl wtype (wRefname2Label var) confitem) gport selectEvent :: String -> String -> [(String,Event,a -> IO [b])] -> a -> IO [b] selectEvent evwidget evtype [] _ = trace ("Internal error in GUI.curry: no handler for event: "++ evwidget++evtype++"\n") (return []) selectEvent evwidget evtype ((ev,hevtype,handler):evs) gport = if evwidget==ev && event2tcl hevtype == evtype then handler gport else selectEvent evwidget evtype evs gport -- get the current value of a widget " by -- 1. executing the Tcl procedure "putvar [getvar_]" -- 2. reading the message ":VAR%* -- (where is the length of which can be more than one line) getWidgetVar :: String -> GuiPort -> IO String getWidgetVar var gport = do send2tk ("putvar "++var++" [getvar"++var++"]") gport getWidgetVarMsg var gport getWidgetVarMsg :: String -> GuiPort -> IO String getWidgetVarMsg var gport = receiveFromTk gport >>= \varmsg -> if takeWhile (/='%') varmsg == ":VAR"++var then let (len,value) = break (=='*') (tail (dropWhile (/='%') varmsg)) in getWidgetVarValue (read len) (tail value) gport else do reportTclTkError ("ERROR in getWidgetVar \""++var++"\": Received: " ++varmsg) getWidgetVarMsg var gport -- ignore other messages and try again getWidgetVarValue :: Int -> String -> GuiPort -> IO String getWidgetVarValue len valmsg gport = if length valmsg < len then do remvalmsg <- getWidgetVarRemValue (len - (length valmsg + 1)) gport return (valmsg++"\n"++remvalmsg) else do when (length valmsg > len) $ reportTclTkError ("ERROR in getWidgetVar: answer too short") return valmsg getWidgetVarRemValue :: Int -> GuiPort -> IO String getWidgetVarRemValue len gport = receiveFromTk gport >>= \valmsg -> if length valmsg < len then getWidgetVarRemValue (len - (length valmsg + 1)) gport >>= \remvalmsg -> return (valmsg++"\n"++remvalmsg) else do when (length valmsg > len) $ reportTclTkError ("ERROR in getWidgetVar: answer too short") return valmsg -- escape some Tcl special characters (brackets, dollars): escapeTcl :: String -> String escapeTcl [] = [] escapeTcl (c:s) = if c=='[' || c==']' || c=='$' || c=='"' || c=='\\' then '\\':c:escapeTcl s else c:escapeTcl s ---------------------------------------------------------------------------- -- Some useful IO actions for implementing event handlers... ---------------------------------------------------------------------------- --- An event handler for terminating the GUI. exitGUI :: GuiPort -> IO () exitGUI gport = send2tk "exit" gport -- this also terminates the scheduler -- due to EOF on the gport handle --- Gets the (String) value of a variable in a GUI. getValue :: WidgetRef -> GuiPort -> IO String getValue (WRefLabel var _) gport = getWidgetVar var gport --- Sets the (String) value of a variable in a GUI. setValue :: WidgetRef -> String -> GuiPort -> IO () setValue (WRefLabel var _) val gport = send2tk ("setvar"++var++" \""++escapeTcl val++"\"") gport --- Updates the (String) value of a variable w.r.t. to an update function. updateValue :: (String->String) -> WidgetRef -> GuiPort -> IO () updateValue upd wref gport = do val <- getValue wref gport setValue wref (upd val) gport --- Appends a String value to the contents of a TextEdit widget and --- adjust the view to the end of the TextEdit widget. appendValue :: WidgetRef -> String -> GuiPort -> IO () appendValue (WRefLabel var wtype) val gport = if wtype /= "textedit" then doWarn $ "GUI.appendValue ignored for widget type '" ++ wtype ++ "'" else send2tk (wRefname2Label var++" insert end \""++escapeTcl val++"\"") gport >> send2tk (wRefname2Label var++" see end") gport --- Appends a String value with style tags to the contents of a TextEdit widget --- and adjust the view to the end of the TextEdit widget. --- Different styles can be combined, e.g., to get bold blue text on a --- red background. If Bold, Italic and --- Underline are combined, currently all but one of these are --- ignored. --- This is an experimental function and might be changed in the future. appendStyledValue :: WidgetRef -> String -> [Style] -> GuiPort -> IO () appendStyledValue (WRefLabel var wtype) val styles gport = if wtype /= "textedit" then doWarn $ "GUI.appendStyledValue ignored for widget type '"++wtype++"'" else send2tk (wRefname2Label var++" insert end \""++escapeTcl val++"\"" ++" \""++showStyles styles++"\"") gport >> send2tk (wRefname2Label var++" see end") gport where showStyles = foldr (\st s -> showStyle st ++ " " ++ s) "" --- Adds a style value in a region of a TextEdit widget. --- The region is specified a start and end position similarly --- to getCursorPosition. --- Different styles can be combined, e.g., to get bold blue text on a --- red background. If Bold, Italic and --- Underline are combined, currently all but one of these are --- ignored. --- This is an experimental function and might be changed in the future. addRegionStyle :: WidgetRef -> (Int,Int) -> (Int,Int) -> Style -> GuiPort -> IO () addRegionStyle (WRefLabel var wtype) (l1,c1) (l2,c2) style gport = if wtype /= "textedit" then doWarn $ "GUI.setRegionStyle ignored for widget type '" ++ wtype ++ "'" else send2tk (wRefname2Label var++" tag add "++showStyle style++" "++ show l1++"."++show c1++" "++show l2++"."++show c2) gport --- Removes a style value in a region of a TextEdit widget. --- The region is specified a start and end position similarly --- to getCursorPosition. --- This is an experimental function and might be changed in the future. removeRegionStyle :: WidgetRef -> (Int,Int) -> (Int,Int) -> Style -> GuiPort -> IO () removeRegionStyle (WRefLabel var wtype) (l1,c1) (l2,c2) style gport = if wtype/="textedit" then doWarn $ "GUI.setRegionStyle ignored for widget type '" ++ wtype ++ "'" else send2tk (wRefname2Label var++" tag remove "++showStyle style++" "++ show l1++"."++show c1++" "++show l2++"."++show c2) gport --- Get the position (line,column) of the insertion cursor in a TextEdit --- widget. Lines are numbered from 1 and columns are numbered from 0. getCursorPosition :: WidgetRef -> GuiPort -> IO (Int,Int) getCursorPosition (WRefLabel var wtype) gport = if wtype/="textedit" then error ("GUI.getCursorPosition not applicable to widget type \""++ wtype++"\"") else do send2tk ("puts [ "++wRefname2Label var++" index insert ]") gport line <- receiveFromTk gport let (ls,ps) = break (=='.') line return (if null ps then (0,0) else (read ls, read (tail ps))) --- Adjust the view of a TextEdit widget so that the specified line/column --- character is visible. --- Lines are numbered from 1 and columns are numbered from 0. seeText :: WidgetRef -> (Int,Int) -> GuiPort -> IO () seeText (WRefLabel var wtype) (line,column) gport = if wtype /= "textedit" then doWarn $ "GUI.seeText ignored for widget type '" ++ wtype ++ "'" else send2tk (wRefname2Label var++" see "++show line++"."++show column) gport --- Sets the input focus of this GUI to the widget referred by the first --- argument. --- This is useful for automatically selecting input entries in an application. focusInput :: WidgetRef -> GuiPort -> IO () focusInput (WRefLabel var _) gport = do send2tk ("focus "++wRefname2Label var) gport --- Adds a list of canvas items to a canvas referred by the first argument. addCanvas :: WidgetRef -> [CanvasItem] -> GuiPort -> IO () addCanvas (WRefLabel var wtype) items gport = do send2tk (config2tcl wtype (wRefname2Label var) (CanvasItems items)) gport ---------------------------------------------------------------------------- -- Example GUIs: ---------------------------------------------------------------------------- --- A simple popup message. popupMessage :: String -> IO () popupMessage s = runGUI "" (Col [] [Label [Text s], Button exitGUI [Text "Dismiss"]]) --- A simple event handler that can be associated to a widget. --- The event handler takes a GUI port as parameter in order to --- read or write values from/into the GUI. Cmd :: (GuiPort -> IO ()) -> ConfItem Cmd cmd = Command (\gport -> cmd gport >> return []) --- An event handler that can be associated to a widget. --- The event handler takes a GUI port as parameter (in order to --- read or write values from/into the GUI) and returns a list --- of widget reference/configuration pairs --- which is applied after the handler in order to configure some GUI widgets. Command :: (GuiPort -> IO [ReconfigureItem]) -> ConfItem Command cmd = Handler DefaultEvent cmd --- A button with an associated event handler which is activated --- if the button is pressed. Button :: (GuiPort -> IO ()) -> [ConfItem] -> Widget Button cmd confs = PlainButton (Cmd cmd : confs) --- A button with an associated event handler which is activated --- if the button is pressed. The event handler is a configuration handler --- (see Command) that allows the configuration of some widgets. ConfigButton :: (GuiPort -> IO [ReconfigureItem]) -> [ConfItem] -> Widget ConfigButton cmd confs = PlainButton (Command cmd : confs) --- A text edit widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the text edit widget. TextEditScroll :: [ConfItem] -> Widget TextEditScroll confs = matrix [[TextEdit ([WRef txtref, Fill]++confs), ScrollV txtref [FillY]], [ScrollH txtref [FillX]]] where txtref free --- A list box widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the list box widget. ListBoxScroll :: [ConfItem] -> Widget ListBoxScroll confs = matrix [[ListBox ([WRef lbref, Fill]++confs), ScrollV lbref [FillY]], [ScrollH lbref [FillX]]] where lbref free --- A canvas widget with vertical and horizontal scrollbars. --- The argument contains the configuration options for the text edit widget. CanvasScroll :: [ConfItem] -> Widget CanvasScroll confs = col [row [Canvas ([WRef cref, Fill]++confs), ScrollV cref [FillY]], ScrollH cref [FillX]] where cref free --- An entry widget with a horizontal scrollbar. --- The argument contains the configuration options for the entry widget. EntryScroll :: [ConfItem] -> Widget EntryScroll confs = col [Entry ([WRef entryref, FillX]++confs), ScrollH entryref [Width 10, FillX]] where entryref free --- Pops up a GUI for selecting an existing file. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getOpenFile :: IO String getOpenFile = getOpenFileWithTypes [] --- Pops up a GUI for selecting an existing file. The parameter is --- a list of pairs of file types that could be selected. --- A file type pair consists of a name and an extension for that file type. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getOpenFileWithTypes :: [(String,String)] -> IO String getOpenFileWithTypes filetypes = do gport <- openWish "" "" send2tk ("wm withdraw .\nputs [tk_getOpenFile" ++ (if null filetypes then "" else " -filetypes {"++ concatMap (\(x,y)->"{{"++x++"} {"++y++"}} ") filetypes ++"}") ++ "]\n") gport filename <- receiveFromTk gport exitGUI gport return filename --- Pops up a GUI for choosing a file to save some data. --- If the user chooses an existing file, she/he will asked to confirm --- to overwrite it. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getSaveFile :: IO String getSaveFile = getSaveFileWithTypes [] --- Pops up a GUI for choosing a file to save some data. The parameter is --- a list of pairs of file types that could be selected. --- A file type pair consists of a name and an extension for that file type. --- If the user chooses an existing file, she/he will asked to confirm --- to overwrite it. --- The file with its full path name will be returned (or "" if the user --- cancels the selection). getSaveFileWithTypes :: [(String,String)] -> IO String getSaveFileWithTypes filetypes = do gport <- openWish "" "" send2tk ("wm withdraw .\nputs [tk_getSaveFile" ++ (if null filetypes then "" else " -filetypes {"++ concatMap (\(x,y)->"{{"++x++"} {"++y++"}} ") filetypes ++"}") ++ "]\n") gport filename <- receiveFromTk gport exitGUI gport return filename --- Pops up a GUI dialog box to select a color. --- The name of the color will be returned (or "" if the user --- cancels the selection). chooseColor :: IO String chooseColor = do gport <- openWish "" "" send2tk "wm withdraw .\nputs [tk_chooseColor]" gport color <- receiveFromTk gport exitGUI gport return color ---------------------------------------------------------------------------- -- Auxiliaries: -- Trace a warning. doWarn :: String -> IO () doWarn s = trace ("WARNING: " ++ s ++ "\n") (return ()) -- end of GUI library