------------------------------------------------------------------------------
--- 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 this paper](http://www.informatik.uni-kiel.de/~mh/papers/PADL00.html)
---
--- @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 = " <ButtonPress-1>"
event2tcl MouseButton2 = " <ButtonPress-2>"
event2tcl MouseButton3 = " <ButtonPress-3>"
event2tcl KeyPress     = " <KeyPress>"
event2tcl Return       = " <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++" <Return>"++writeEvent else
   if wtype=="scale"
   then label++" configure -command { putlabel \""++label++event2tcl evtype++"\"}\n" else
   if wtype=="listbox"
   then "bind "++label++" <ButtonPress-1>"++writeEvent else
   if wtype=="textedit"
   then "bind "++label++" <KeyPress>"++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 <w>" by
-- 1. executing the Tcl procedure "putvar [getvar_<w>]"
-- 2. reading the message ":VAR<w>%<len>*<value>
--    (where <len> is the length of <value> 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 <code>Bold</code>, <code>Italic</code> and 
--- <code>Underline</code> 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 <code>getCursorPosition</code>.
--- Different styles can be combined, e.g., to get bold blue text on a 
--- red background. If <code>Bold</code>, <code>Italic</code> and 
--- <code>Underline</code> 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 <code>getCursorPosition</code>.
--- 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