module Sifflet.UI.Window
    (
     -- Window utilities
      showWindow
    , newWindowTitled

    , showWorkWin
    , showWorkspaceWindow

    , showFedWin
    , fedWindowTitle

    , showFunctionPadWindow
    , newFunctionDialog

    , openFilePath
    , setWSCanvasCallbacks
    , keyBindingsHelpText
    )

where

import Control.Monad
import Control.Monad.Trans (liftIO) -- for use in EventM
import Data.IORef
import Data.List as List
import Data.Map as Map (fromList, lookup)
import Data.Map (Map)

import Data.Graph.Inductive as G

import Graphics.UI.Gtk.Gdk.EventM

import Sifflet.Data.Functoid
import Sifflet.Data.Geometry
import Sifflet.Data.WGraph

import Sifflet.Foreign.Exporter
import Sifflet.Foreign.ToHaskell (defaultHaskellOptions, exportHaskell)
import Sifflet.Foreign.ToPython (defaultPythonOptions, exportPython)
import Sifflet.Foreign.ToScheme (SchemeOptions(..), exportScheme)

import Sifflet.Language.Expr
import Sifflet.Language.SiffML

import Sifflet.UI.Frame
import Sifflet.UI.Canvas
import Sifflet.UI.Types
import Sifflet.UI.Callback
import Sifflet.UI.Tool
import Sifflet.UI.Workspace
import Sifflet.UI.GtkForeign
import Sifflet.UI.GtkUtil
import Sifflet.UI.LittleGtk
import Sifflet.UI.RPanel

import Sifflet.Util


import Data.Version
import Paths_sifflet_lib as Paths

-- ---------------------------------------------------------------------
-- | Finding, creating, and initializing windows (VPUIWindow)

-- | Find and show a window, if it exists.
--   If not, create the window, put it in the vpui's window map,
--   and initialize it and any auxiliary objects using the initWin function.
--   The 3rd argument of initWin will be the window's title.
-- Always presents the window (shows and raises).
-- Returns a 3-tuple: the VPUIWindow contains the Window,
-- and the Bool value is True if the Window is new
-- (and therefore might need some further initialization).
-- The third tuple element is an IORef to the VPUIWindow;
-- it may be useful for setting up signal and event handling.

showWindow :: WinId -> CBMgr
           -> (VPUI -> Window -> IO VPUIWindow) -- initializes Gtk Window
           -> (VPUI -> WinId -> CBMgr -> IO ()) -- initializes callbacks
           -> VPUI -> IO (VPUI, VPUIWindow, Bool)
showWindow winId uimgr initWin initCB vpui = do
  {
    (vpui', vw, isNew) <- 
        case vpuiTryGetWindow vpui winId of
          Nothing ->
              do
                {
                  window <- newWindowTitled winId
                ; widgetSetName window ("Sifflet-" ++ winId)
                ; vwin <- initWin vpui window
                ; let vpui' = vpuiInsertWindow vpui winId vwin
                -- when window is destroyed, remove it from the map
                ; uimgr (OnWindowDestroy window 
                         (\ uiref ->
                              modifyIORef uiref (vpuiRemoveVPUIWindow winId)))
                ; return (vpui', vwin, True)
                }
          Just vw ->
              return (vpui, vw, False)
  ; when isNew (initCB vpui' winId uimgr) -- add callbacks on new window
  ; windowPresent (vpuiWindowWindow vw)
  ; return (vpui', vw, isNew)
  }

-- | Default "do-nothing" add-callbacks function
initCBDefault :: VPUI -> WinId -> CBMgr -> IO ()
initCBDefault _vpui _winId _uimgr = return ()

newWindowTitled :: String -> IO Window
newWindowTitled winId = do
  window <- windowNew
  set window [windowTitle := winId]
  widgetSetName window ("Sifflet-" ++ winId)
  return window

-- | Show a workspace window, with a given title, _not_ editing a function

showWorkWin :: VPUI -> WinId -> CBMgr -> IO VPUI
showWorkWin vpui winId uimgr = do
  {
    (vpui', _, _) <- showWorkspaceWindow winId uimgr Nothing vpui
  ; return vpui'
  }

-- | Show a workspace window with a given title and maybe function to edit

showWorkspaceWindow :: WinId -> CBMgr -> Maybe Function -> VPUI
                    -> IO (VPUI, VPUIWindow, Bool)
showWorkspaceWindow winId cbmgr mfunc =
    showWindow winId cbmgr (workspaceWindowInit cbmgr winId mfunc) 
               setWSCanvasCallbacks


-- | Initialize a Workspace window.
-- Called in sifflet.hs:Main from showWindow called from showWorkspaceWindow.

workspaceWindowInit :: CBMgr -> WinId -> Maybe Function -> VPUI -> Window
                    -> IO VPUIWindow
workspaceWindowInit cbmgr winId mfunc vpui window = do
  {
    let style = vpuiStyle vpui
        env = vpuiGlobalEnv vpui
  ; ws <- case mfunc of 
            Nothing -> workspaceNewDefault style (buildMainMenu cbmgr)
            Just func -> workspaceNewEditing style env func
  ; set window [windowTitle := winId, containerChild := wsBox ws]

  ; widgetShowAll window
  ; windowPresent window

  ; return $ VPUIWorkWin ws window
  }

-- Menu specs here need to coordinate accelerators (shortcuts)
-- with keyBindingsList in WindowManagement.hs

buildMainMenu :: CBMgr -> VBox -> IO ()
buildMainMenu cbmgr vbox = do
  {
    -- menu bar 
    let mspecs = 
            [MenuSpec "File"
                      [ -- "new" isn't implemented yet
                        -- MenuItem "New ..." menuFileNew
                        -- , 
                        -- Temporarily disabling file I/O operations
                        MenuItem "Open ...     (C-o)" (menuFileOpen cbmgr)
                      , MenuItem "Save         (C-s)" menuFileSave
                      , MenuItem "Save as ..." menuFileSaveAs
                      , MenuItem "Export to Haskell ..." 
                                 menuFileExportHaskell
                      , MenuItem "Export to Python3 ..." menuFileExportPython
                      , MenuItem "Export to Scheme ..." menuFileExportScheme
                      , MenuItem "Quit         (C-q)" menuFileQuit]
            , MenuSpec "Functions"
                       [MenuItem "New ...      (n)"
                                  (newFunctionDialog "ignore" cbmgr)
                       , MenuItem "Function Pad"
                                  (showFunctionPadWindow cbmgr)]
            , MenuSpec "Help"
                       [MenuItem "Help ..." showHelpDialog
                       , MenuItem "Complaints and praise ..." showBugs
                       , MenuItem "About ..." showAboutDialog]
             ]
  ; menubar <- createMenuBar mspecs cbmgr
  ; boxPackStart vbox menubar PackNatural 0
}

-- | Show a function editor window = a workspace window 
-- editing a given function.
-- Use argNames for a new function; ignore them if funcName is bound.

showFedWin :: CBMgr -> String -> [String] -> VPUI -> IO VPUI
showFedWin cbmgr funcName argNames vpui = do
  {
  ; let initEnv = vpuiGlobalEnv vpui
        function = case envLookupFunction initEnv funcName of
                     Nothing -> newUndefinedFunction funcName argNames
                     Just func -> func
        winId = fedWindowTitle funcName

  ; (vpui', vw, isNew) <- showWorkspaceWindow winId cbmgr (Just function) vpui

  ; if isNew
    then do
      {
        let canvas = vpuiWindowGetCanvas vw
      -- Can this use vpuiAddFrame? ***
      ; canvas' <- vcAddFrame canvas (FunctoidFunc function) 
                   Nothing EditFrame
                   initEnv 0 0 0 Nothing
      ; canvas'' <- 
          case vcFrames canvas' of
            [] -> info "showFedWin: ERROR: no frame on canvas" >> 
                  return canvas'
            _:_:_ -> 
                info "showFedWin: ERROR: too many frames on canvas" >> 
                return canvas'
            [frame] -> editFunction canvas' frame 
      ; addArgToolButtons cbmgr winId (functionArgNames function) vpui'
      ; addApplyCloseButtons cbmgr winId vpui'
      ; return (vpuiReplaceWindow vpui' winId 
                                        (vpuiWindowSetCanvas vw canvas''))
      }
    else return vpui'
  }

fedWindowTitle :: String -> WinId
fedWindowTitle funcName = "Edit " ++ funcName

updateFunctionPadIO :: String -> (RPanel -> IO RPanel) -> VPUI -> IO VPUI
updateFunctionPadIO padName update =
    let updateWindow vw =
            case vw of
              FunctionPadWindow window rpAList ->
                  do
                    {
                      rpAList' <- adjustAListM padName update rpAList
                    ; return (FunctionPadWindow window rpAList')
                    }
              _ -> return vw
    in vpuiUpdateWindowIO "Function Pad" updateWindow

showFunctionPadWindow :: CBMgr -> VPUI -> IO VPUI
showFunctionPadWindow cbmgr vpui = 
    let initWindow _vpui window = do
          {
            -- widgetSetName window "SiffletFunctionPadWindow"
          ; vbox <- vBoxNew False 0 -- non-homogenous, 0 padding
          ; set window [containerChild := vbox]

          ; let rpnames = ["Base", "Examples", "My Functions"]
          ; rps <- mapM (makeFunctionPadPanel cbmgr vpui) rpnames
          ; mapM_ (\ rp -> boxPackStart vbox (rpanelRoot rp) PackNatural 0)
                  rps

          ; windowMove window 5 5
          ; widgetShowAll window -- redundant?
          ; windowPresent window -- redundant?

          ; return $ FunctionPadWindow window (zip rpnames rps) 
             -- maybe need reference only the "My Functions" panel though **
          }
    in do
  {
    (vpui', _, windowIsNew) <- 
        showWindow functionPadWinId cbmgr initWindow initCBDefault vpui
     -- "My Functions" default is empty; add any user-defined
     -- functions in the environment to it
  ; if windowIsNew
    then addUserFunctions cbmgr vpui'
    else return vpui'
  }

functionPadWinId :: String
functionPadWinId = "Function Pad"

addUserFunctions :: CBMgr -> VPUI -> IO VPUI
addUserFunctions cbmgr vpui =
    let names = map fst (vpuiUserEnvAList vpui)
        update rp = do
          {
            buttons <- mapM (makeToolButton cbmgr . functionTool) names
          ; rp' <- rpanelAddWidgets rp (zip names buttons)
          ; widgetShowAll (rpanelRoot rp')
          ; return rp'
          }      
    in updateFunctionPadIO "My Functions" update vpui

makeFunctionPadPanel :: CBMgr -> VPUI -> String -> IO RPanel
makeFunctionPadPanel cbmgr vpui name =
    let VPToolkit _ width toolrows = 
            case List.lookup name (vpuiToolkits vpui) of
              Nothing ->
                  errcats ["makeFunctionPadPanel:",
                           "can't find toolkit definition:", name]
              Just atoolkit -> atoolkit
    in do
      {
        buttonRows <- makeToolButtonRows cbmgr toolrows
                      :: IO [[(String, Button)]]
      ; rp <- newRPanel name 3 3 width
      ; rpanelAddRows rp buttonRows
      }

makeToolButtonRows :: CBMgr -> [[Tool]] -> IO [[(String, Button)]]
makeToolButtonRows cbmgr toolRows = 
    mapM2 (makeNamedToolButton cbmgr) toolRows

makeNamedToolButton :: CBMgr -> Tool -> IO (String, Button)
makeNamedToolButton cbmgr tool = do
  {
    button <- makeToolButton cbmgr tool
  ; return (toolName tool, button)
  }

makeToolButton :: CBMgr -> Tool -> IO Button
makeToolButton cbmgr tool = do
  {
    button <- buttonNewWithLabel (toolName tool)
  ; cbmgr (AfterButtonClicked button
           ((flip modifyIORefIO) 
            (forallWindowsIO (vpuiWindowSetTool tool))))
  ; return button
  }

-- | Add a tool button to the function pad window in a specified panel
addFunctionPadToolButton :: CBMgr -> String -> Tool -> VPUIWindow 
                         -> IO VPUIWindow
addFunctionPadToolButton cbmgr panelId tool vw = 
    case vw of
      FunctionPadWindow window panelAList ->
          let adjustPanel :: RPanel -> IO RPanel
              adjustPanel rp = do
                {
                  -- make the tool button from the tool
                  button <- makeToolButton cbmgr tool
                  -- add it to the panel
                ; rp' <- rpanelAddWidget rp (toolName tool) button
                ; widgetShowAll (rpanelRoot rp')
                ; return rp'
                }
          in do
            {
              panelAList' <- adjustAListM panelId adjustPanel panelAList
            ; return $ FunctionPadWindow window panelAList'
            }
      _ -> return vw


-- | Ask user for new function name and arguments,
-- then begin editing the function.

newFunctionDialog :: WinId -> CBMgr -> VPUI -> IO VPUI
newFunctionDialog _winId cbmgr vpui =
    -- _winId is ignored, but needed for use in KeyBindingsList
  let reader :: Reader [String] (String, [String])
      reader inputLines =
          case inputLines of
            [fname, fargs] ->
                return (fname, words fargs)
            _ -> fail "wrong number of lines"
  in do
    {
      inputDialog <- 
          createEntryDialog "New Function"
                            ["Function name", "Argument names (space between)"]
                            ["", ""]
                            reader
                            (-1)
    ; values <- runEntryDialog inputDialog
    ; case values of
        Nothing -> return vpui
        Just (name, args) -> editNewFunction cbmgr name args vpui
    }

-- ------------------------------------------------------------
-- Implementation of menu commands

-- -- | Create a new file, but what does this mean?

-- menuFileNew :: VPUI -> IO VPUI
-- menuFileNew vpui = putStrLn "Not implemented: \"New\"" >> return vpui
-- -- Notes for future implementation:
-- --     checkChangesAndContinue vpui ...


-- | Quit from Sifflet

menuFileQuit :: VPUI -> IO VPUI
menuFileQuit vpui = checkForChanges vpui "quit" False vpuiQuit

-- | Open a file (load its function definitions)

menuFileOpen :: CBMgr -> VPUI -> IO VPUI
menuFileOpen cbmgr vpui =
    checkForChanges vpui "open file" True (continueFileOpen cbmgr)

-- | Offer to save changes, if any, and continue with the continuation.
-- The continuation gets the current vpui if there are no changes
-- or if the offer to save is rejected; otherwise, it gets a
-- vpui which knows it has saved its last changes.
-- The message, if any, is a confirmation that the file was
-- saved and that we are going on to the next operation --
-- useful for open file, but not for quit.

checkForChanges :: VPUI -> String -> Bool -> (VPUI -> IO VPUI) -> IO VPUI
checkForChanges vpui beforeOperation acknowledge continue =
    let mAckIfSaved vpui' = 
            when (not (vpuiFileChanged vpui') && acknowledge)
                 (
                  showInfoMessage "Changes saved" 
                                  ("Your changes are now saved; " ++
                                   "proceeding to " ++
                                   beforeOperation ++ ".")
                 ) 
            >>
            return vpui'
        labels = ["Save them", 
                  "Throw them away", 
                  "Cancel " ++ beforeOperation]
        actions = [menuFileSave vpui >>= mAckIfSaved >>= continue, -- save
                   return vpui >>= continue,                 -- throw away
                   return vpui]                              -- cancel
        offerSaveAndContinue = showChoicesDialog "Save changes?"
                        ("There are unsaved changes.  " ++
                          "Before you " ++ beforeOperation ++
                          ", would you ...")
                        labels
                        actions
                  
    in if vpuiFileChanged vpui
       then offerSaveAndContinue
       else continue vpui

-- | Continue with opening the file, after having possibly saved changes
continueFileOpen :: CBMgr -> VPUI -> IO VPUI
continueFileOpen cbmgr vpui = do
  mpath <- showDialogFileOpen vpui
  case mpath of
    Nothing -> return vpui
    Just filePath -> openFilePath cbmgr filePath vpui

-- | Now that we have a file path, go ahead and open it,
-- loading the function definitions into Sifflet

openFilePath :: CBMgr -> FilePath -> VPUI -> IO VPUI
openFilePath cbmgr filePath vpui = do
  {
    loadResult <- loadFile vpui filePath
  ; case loadResult of
      Fail msg ->
          showErrorMessage msg >> return vpui
      Succ (vpui', functions) -> 
          let title = "My Functions"
              updatePad rp =
                  -- Figure out which functions are new,
                  -- i.e., not already on the pad
                  let oldNames = concat (rpanelContent rp)
                      loadedNames = map functionName functions
                      -- use set difference to avoid duplicates
                      newNames = loadedNames \\ oldNames
                      newTools = map functionTool newNames
                  in do 
                    {
                    ; newPairs <- 
                        mapM (makeNamedToolButton cbmgr) newTools
                    ; rp' <- rpanelAddWidgets rp newPairs
                    ; widgetShowAll (rpanelRoot rp)
                    ; return rp'
                    }
          in do
            {
              vpui'' <- 
                  showFunctionPadWindow cbmgr vpui' >>=
                  updateFunctionPadIO title updatePad 
            ; return $ vpui'' {vpuiFilePath = Just filePath, 
                               vpuiFileEnv = vpuiGlobalEnv vpui'
                              }
            }
  }

showDialogFileOpen :: VPUI -> IO (Maybe FilePath)
showDialogFileOpen _vpui = do
  chooser <- fileChooserDialogNew
               (Just "Open file ...")          -- default title
               Nothing          -- transient parent of the dialog
               FileChooserActionOpen
               [("Open", ResponseOk), ("Cancel", ResponseCancel)] -- buttons
  result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename
  return result

loadFile :: VPUI -> FilePath -> IO (SuccFail (VPUI, [Function]))
loadFile vpui filePath = do
  {
    functions <- consumeSiffMLFile xmlToFunctions filePath
  ; case functions of
      [Functions fs] ->
          let vpui' = foldl bindFunction vpui fs
          in return (Succ (vpui', fs))
      _ ->
          return (Fail "file format error")

  }

bindFunction :: VPUI -> Function -> VPUI
bindFunction vpui function =
    let env = vpuiGlobalEnv vpui
        Function (Just name) _argTypes _resType _impl = function
        env' = envIns env name (VFun function)
    in vpui {vpuiGlobalEnv = env'}

-- | Implements File menu "Save" command.

menuFileSave :: VPUI -> IO VPUI
menuFileSave vpui = 
    case vpuiFilePath vpui of
      Nothing -> menuFileSaveAs vpui
      Just filePath -> saveFile vpui filePath

-- | Implements File menu "Save as" command.
menuFileSaveAs :: VPUI -> IO VPUI
menuFileSaveAs vpui = do
  {
    mFilePath <- chooseOutputFile "Save" vpui
  ; case mFilePath of
      Nothing -> return vpui
      Just filePath -> saveFile vpui filePath
  }

-- | Unconditionally save user functions in SiffML file.
-- Called from menuFileSave and menuFileSaveAs.
-- Updates vpuiFilePath and vpuiFileEnv.
saveFile :: VPUI -> FilePath -> IO VPUI
saveFile vpui filePath =
    produceSiffMLFile (userFunctions vpui) filePath >>
    return vpui {vpuiFilePath = Just filePath, 
                 vpuiFileEnv = vpuiGlobalEnv vpui}

-- | The user-defined functions of the environment
userFunctions :: VPUI -> Functions
userFunctions vpui = 
    Functions (map (valueFunction . snd) 
                   (vpuiUserEnvAList vpui))

-- | Export user functions to a file,
-- given an exporter and a path,
-- returning the vpui unchanged.
maybeExportUserFunctions :: VPUI -> (opts -> Exporter) 
                         -> Maybe (FilePath, opts) -> IO VPUI
maybeExportUserFunctions vpui export mpathOptions =
    case mpathOptions of
      Nothing -> return vpui 
      Just (path, options) -> 
          export options (userFunctions vpui) path >> return vpui

-- | Export user functions to Haskell file
menuFileExportHaskell :: VPUI -> IO VPUI
menuFileExportHaskell vpui =
    chooseOutputFile "Export Haskell" vpui >>=
    maybeDefaultOptions defaultHaskellOptions >>=
    maybeExportUserFunctions vpui exportHaskell

-- | Export user functions to Python file
menuFileExportPython :: VPUI -> IO VPUI
menuFileExportPython vpui =
    chooseOutputFile "Export Python" vpui >>=
    maybeDefaultOptions defaultPythonOptions >>=
    maybeExportUserFunctions vpui exportPython

-- | Export user functions to Scheme file
menuFileExportScheme :: VPUI -> IO VPUI
menuFileExportScheme vpui =
    chooseOutputFile "Export Scheme" vpui >>= 
    maybeRunSchemeOptionsDialog >>=
    -- maybeExportUserFunctions vpui (exportScheme defaultSchemeOptions) 
    maybeExportUserFunctions vpui exportScheme

-- | Choose an output file, for file save, save as, and export commands
chooseOutputFile :: String -> VPUI -> IO (Maybe FilePath)
chooseOutputFile verb _vpui = do
  chooser <- fileChooserDialogNew
               (Just (verb ++ " to file ...")) -- title
               Nothing          -- transient parent of the dialog
               FileChooserActionSave
               [(verb, ResponseOk), ("Cancel", ResponseCancel)] -- buttons
  result <- runDialogM (toDialog chooser) chooser fileChooserGetFilename
  return result

maybeDefaultOptions :: a -> Maybe FilePath -> IO (Maybe (FilePath, a))
maybeDefaultOptions defaultOptions mpath =
    case mpath of
      Nothing -> return Nothing
      Just path -> return $ Just (path, defaultOptions)

maybeRunSchemeOptionsDialog :: Maybe FilePath 
                            -> IO (Maybe (FilePath, SchemeOptions))
maybeRunSchemeOptionsDialog mpath =
    case mpath of
      Nothing -> return Nothing
      Just path ->
          let result :: Bool -> IO (Maybe (FilePath, SchemeOptions))
              result useLambda =
                  return (Just (path, 
                                SchemeOptions {defineWithLambda = useLambda}))
          in showChoicesDialog "Scheme Export Options"
                               "Use lambda in function definitions?"
                               ["Yes", "No"]
                               [result True, result False]

-- | Text shown by the help dialog
helpText :: String
helpText =
  unlines ["Functions menu:",
           "    \"New\" enters a dialog to create a new function.",
           "    \"Function pad\" raises the function pad window.",
           "Keystroke shortcuts for the menu commands are shown " ++
           "using \"C-\" for Control.  For example, Quit " ++
           "is C-q, meaning Control+Q.",
           "",
           "In a function editor, right-click for the context menu.",
           "",
           "For more help, please visit the Sifflet web site,",
           "http://mypage.iu.edu/~gdweber/software/sifflet/",
           "especially the Sifflet Tutorial:",
           "http://mypage.iu.edu/~gdweber/software/sifflet/doc/tutorial.html"
          ]

-- | Show the help dialog
showHelpDialog :: MenuItemAction
showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui

-- | How to report bugs
bugsText :: String
bugsText =
    unlines ["To report bugs, please send mail to " ++ bugReportAddress,
             "and mention \"Sifflet\" in the Subject header.",
             "To send praise, follow the same procedure.",
             "Seriously, whether you like Sifflet or dislike it,",
             "I'd like to hear from you."
            ]

bugReportAddress :: String
bugReportAddress = concat ["gdweber", at, "iue", punctum, "edu"]
                   where at = "@"
                         punctum = "."

showBugs :: MenuItemAction
showBugs vpui = showInfoMessage "Reporting bugs" bugsText >> return vpui

-- | Text for the About dialog
aboutText :: String
aboutText =
    unlines ["Sifflet version " ++ showVersion Paths.version,
             "Copyright (C) 2010 Gregory D. Weber",
             "",
             "BSD3 License",
             "",
             "Sifflet home page:",
             "http://mypage.iu.edu/~gdweber/software/sifflet/"
            ]

showAboutDialog :: MenuItemAction
showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui

-- ----------------------------------------------------------------------

-- Moved here from Callbacks.hs:

setWSCanvasCallbacks :: VPUI -> WinId -> CBMgr -> IO ()
setWSCanvasCallbacks vpui winId cbmgr = do
  {
    let vw = vpuiGetWindow vpui winId
        window = vpuiWindowWindow vw
  ; case vpuiWindowLookupCanvas vw of
      Nothing ->
          errcats ["setWSCanvasCallbacks: VPUIWindow is not a VPUIWorkWin",
                   "and has no canvas"]
      Just canvas ->
          do
            {
            -- Notice when the window size is changed
            ; cbmgr (OnWindowConfigure window (configuredCallback winId))

            -- Keypress events -- send to canvas window because the Gtk.Layout
            -- cannot receive them (why ever not?)
            ; cbmgr (OnWindowKeyPress window (keyPressCallback winId cbmgr))

            -- Send remaining events to the Gtk.Layout (why?)
            ; let layout = vcLayout canvas
            ; widgetSetCanFocus layout True
            ; cbmgr (OnLayoutExpose layout (exposedCallback winId))

            -- Mouse events 
            ; widgetAddEvents layout [PointerMotionMask]
            ; cbmgr (OnLayoutMouseMove layout (mouseMoveCallback winId))
            ; cbmgr (OnLayoutButtonPress layout 
                     (buttonPressCallback winId cbmgr))
            ; cbmgr (OnLayoutButtonRelease layout (buttonReleaseCallback winId))
            }
  }

-- | Context menu command to edit the function displayed in 
-- a CallFrame

editFrameFunction :: CBMgr -> CanvFrame -> VPUI -> IO VPUI
editFrameFunction cbmgr frame vpui =
    let func = cfFunctoid frame
    in showFedWin cbmgr (functoidName func) (functoidArgNames func) vpui

-- | Create a new function, add it to the global environment 
-- with body undefined, and start editing it in a new window.  
-- Also update and show "My Functions" toolbox and
-- update its toolkit.

editNewFunction :: CBMgr -> String -> [String] -> VPUI -> IO VPUI
editNewFunction cbmgr name args vpui = 
    let updateEnv :: VPUI -> IO VPUI
        updateEnv vpui' =
            let env = vpuiGlobalEnv vpui'
                env' = envIns env name (VFun (newUndefinedFunction name args))
            in return $ vpui' {vpuiGlobalEnv = env'}    
    in 
      -- Show window first, with the *old* functions
      showFunctionPadWindow cbmgr vpui >>=
      updateEnv >>=
      vpuiUpdateWindowIO functionPadWinId
                             (addFunctionPadToolButton cbmgr "My Functions" 
                              (functionTool name)) >>=
      showFedWin cbmgr name args

configuredCallback :: WinId -> IORef VPUI -> EventM EConfigure Bool
configuredCallback winId uiref =
    tryEvent $ do
      {
        (w, h) <- eventSize
      ; liftIO $ modifyIORef uiref (handleConfigured winId w h)
      -- We *must* "stop the event", forcing the event handler 
      -- to return False, or else the canvas remains "squeezed in"
      -- -- Weird!!
      ; stopEvent
      }

-- | Handle the Configured event.
handleConfigured :: WinId -> Int -> Int -> VPUI -> VPUI
handleConfigured winId width height vpui = 
    let vw = vpuiGetWindow vpui winId
        vw' = vpuiWindowModCanvas vw 
              (atLeastSize (Size (fromIntegral width) (fromIntegral height)))
    in vpuiReplaceWindow vpui winId vw'

exposedCallback :: WinId -> IORef VPUI -> EventM EExpose Bool
exposedCallback winId uiref =
    tryEvent $ do
      {
        clipbox <- eventArea
      ; liftIO (readIORef uiref >>= handleExposed winId clipbox)
      }

-- | Handle the Exposed event, should be called only for a window
-- with a canvas
handleExposed :: WinId -> Rectangle -> VPUI -> IO ()
handleExposed winId clipbox vpui = 
    let vw = vpuiGetWindow vpui winId -- error if not found
    in case vpuiWindowLookupCanvas vw of
         Nothing -> info "handleExposed: no canvas found!"
         Just canvas -> drawCanvas canvas clipbox 

data KeyBinding = KeyBinding {kbGtkKeyName :: String,
                              kbAltKeyName :: Maybe String, -- for humans
                              kbRequiredModifiers :: [Modifier],
                              kbDescription :: String,
                              kbAction :: KeyAction}

data KeyAction 
 = KeyActionST (WinId -> VPUI -> IO VPUI)          -- ^ set a tool
 | KeyActionDG (WinId -> CBMgr -> VPUI -> IO VPUI) -- ^ start a dialog
 | KeyActionModIO (CBMgr -> VPUI -> IO VPUI)       -- ^ modify VPUI with IO
 | KeyActionHQ (VPUI -> IO ())                     -- ^ help or quit

-- | Key bindings map.  This is derived from keyBindingsList.
keyBindingsMap :: Map String KeyBinding
keyBindingsMap = Map.fromList [(kbGtkKeyName kb, kb) | kb <- keyBindingsList]

-- | KeyBinding list for workspace and function editor windows.

keyBindingsList :: [KeyBinding]
keyBindingsList = 
    [
     -- Bindings to set tools
      KeyBinding "c" Nothing [] "connect" 
                     (KeyActionST (vpuiSetTool ToolConnect))
    , KeyBinding "d" Nothing [] "disconnect" 
                     (KeyActionST (vpuiSetTool ToolDisconnect))
    , KeyBinding "i" Nothing [] "if" (KeyActionST (vpuiSetTool ToolIf))
    , KeyBinding "m" Nothing [] "move" (KeyActionST (vpuiSetTool ToolMove))
    , KeyBinding "KP_Delete" (Just "Keypad-Del") [] "delete" 
                             (KeyActionST (vpuiSetTool ToolDelete))

    -- Bindings to start dialogs
    , KeyBinding "n" Nothing [] "new function" (KeyActionDG newFunctionDialog)
    , KeyBinding "f" Nothing [] "function" (KeyActionDG showFunctionEntry)
    , KeyBinding "l" Nothing [] "literal" (KeyActionDG showLiteralEntry)

     -- Help and quit

    , KeyBinding "question" (Just "?") [] "help" (KeyActionHQ vpuiKeyHelp)

     -- Shortcuts for menu commands (GTK "accelerators", but not done
     -- in the standard GTK way).
     -- These need to be coordinated with buildMainMenu,
     -- in WindowManagement.hs

-- Oops!  Binding Ctrl+F here interferes with binding just plain f above.
--    , KeyBinding "f" (Just "Control-f") [Control] "function-pad"
--                     (KeyActionModIO showFunctionPadWindow)

    , KeyBinding "o" (Just "Control-o") [Control] "open"
                     (KeyActionModIO menuFileOpen)
    , KeyBinding "s" (Just "Control-s") [Control] "save"
                     (KeyActionModIO (\ _cbmgr -> menuFileSave))
    , KeyBinding "q" (Just "Control-q") [Control] "quit" 
                     (KeyActionHQ (\ vpui -> menuFileQuit vpui >> return ()))
    ]

-- | Unused argument needed for key bindings
vpuiKeyHelp :: VPUI -> IO ()
vpuiKeyHelp _vpui = putStrLn keyBindingsHelpText

-- | Help text built from key bindings
keyBindingsHelpText :: String
keyBindingsHelpText = 
    let add :: String -> KeyBinding -> String
        add result (kb@KeyBinding {kbAltKeyName = mkey}) =
            concat [result, " ", 
                    case mkey of 
                      Nothing -> kbGtkKeyName kb
                      Just akey -> akey, 
                    " = ", kbDescription kb, "\n"]
    in foldl add "" keyBindingsList

-- | What to do when a key is pressed
keyPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EKey Bool
keyPressCallback winId cbmgr uiref =
    tryEvent $ do
      {
        kname <- eventKeyName
      ; mods <- eventModifier
      -- ; liftIO $ print mods

      ; let giveUp = 
                -- liftIO (info ("Unrecognized key: " ++ kname)) >> 
                stopEvent

      ; case Map.lookup kname keyBindingsMap of
          Nothing -> 
              giveUp
          Just keyBinding -> 
              if checkMods (kbRequiredModifiers keyBinding) mods
              then liftIO $ 
                     case kbAction keyBinding of
                       KeyActionModIO f0 ->
                           -- update with IO
                           modifyIORefIO uiref (f0 cbmgr)
                       KeyActionST f1 ->
                           -- update with IO and window ID
                           modifyIORefIO uiref (f1 winId)
                       KeyActionDG f2 ->
                           -- update with IO and cbmgr to set further callbacks
                           modifyIORefIO uiref (f2 winId cbmgr)
                       KeyActionHQ f3 ->
                           -- no update, no cbmgr, no further callbacks
                           readIORef uiref >>= f3
              else giveUp
      }

buttonPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EButton Bool
buttonPressCallback winId cbmgr uiref =
    tryEvent $ do
      {
      ; (x, y) <- eventCoordinates
      ; mouseButton <- eventButton
      ; mods <- eventModifier
      ; timestamp <- eventTime
      ; liftIO 
      (modifyIORefIO uiref 
       (handleButtonPress winId cbmgr mouseButton x y mods timestamp))
      }

mouseMoveCallback :: WinId -> IORef VPUI -> EventM EMotion Bool
mouseMoveCallback winId uiref =
    tryEvent $ do
      {
        (x, y) <- eventCoordinates
      ; mods <- eventModifier
      ; liftIO (modifyIORefIO uiref (handleMouseMove winId x y mods))
      }

buttonReleaseCallback :: WinId -> IORef VPUI -> EventM EButton Bool
buttonReleaseCallback winId uiref =
    tryEvent $ do
      {
        mouseButton <- eventButton
      ; liftIO (modifyIORefIO uiref (handleButtonRelease winId mouseButton))
      }

-- | Handle the ButtonPress event.  Should be called only for a window
-- with a canvas.
handleButtonPress :: WinId -> CBMgr -> MouseButton 
                  -> Double -> Double -- x, y
                  -> [Modifier] -> TimeStamp -- timestamp not needed?
                  -> VPUI ->IO VPUI
handleButtonPress winId cbmgr mouseButton x y mods timestamp vpui  =
    let vw = vpuiGetWindow vpui winId
    in case vpuiWindowLookupCanvas vw of
         Nothing -> info "handleButtonPress: no canvas found!" >>
                    return vpui
         Just canvas ->
             case whichFrame canvas x y of
               Nothing ->
                   case vcTool canvas of
                     Nothing -> return vpui
                     Just tool -> toolOp tool vpui winId TCWorkspace mods x y 
               Just frame -> 
                   frameButtonPressed winId cbmgr vw
                                      frame mods (x, y)
                                      mouseButton timestamp vpui

-- | Handles button pressed in a frame
frameButtonPressed :: WinId -> CBMgr -> VPUIWindow -> CanvFrame 
                   -> [Modifier] -> (Double, Double) -> MouseButton 
                   -> TimeStamp 
                   -> VPUI
                   -> IO VPUI
frameButtonPressed winId cbmgr vw frame mods (x, y) mouseButton timestamp vpui =
    let retWrap :: VPUIWindow -> IO VPUI
        retWrap = return . vpuiReplaceWindow vpui winId
    in case mouseButton of
        LeftButton ->
            if  cfPointInHeader frame x y 
            then beginFrameDrag vw frame x y >>= retWrap
            else if cfPointInFooter frame x y
                 then leftButtonPressedInFrameFooter vw frame >>= retWrap
                 else frameBodyButtonPressed vpui winId frame 
                                             mouseButton mods x y
        MiddleButton -> return vpui
        RightButton -> 
            offerContextMenu winId cbmgr frame RightButton timestamp >> 
            return vpui
        OtherButton _ -> return vpui

-- | Handles button pressed in the body of a frame
-- frameBodyButtonPressed needs VPUIWindow because it calls a toolOp.
-- mb (mouse button) is unused, but might be used later.
frameBodyButtonPressed :: VPUI -> WinId -> CanvFrame 
                         -> MouseButton -> [Modifier] -> Double -> Double 
                         -> IO VPUI
frameBodyButtonPressed vpui winId frame _mb mods x y = do
  {
    let vw = vpuiGetWindow vpui winId
        canvas = vpuiWindowGetCanvas vw
        mnode = vcanvasNodeAt canvas (Position x y)
  ; case mnode of
      Nothing -> 
          case vcTool canvas of
            Nothing -> return vpui
            Just tool -> toolOp tool vpui winId (cfContext frame) mods x y
      Just node -> 
          do
            {
              vw' <- openNode vw node
            ; return $ vpuiReplaceWindow vpui winId vw'
            }
  }

-- | Handles left button pressed in the footer of a frame
leftButtonPressedInFrameFooter ::
    VPUIWindow -> CanvFrame -> IO VPUIWindow
leftButtonPressedInFrameFooter vw frame = 
    let canvas = vpuiWindowGetCanvas vw
    in case frameType frame of
         CallFrame -> 
             -- request argument values and evaluate call
             if cfEvalReady frame
             then do
               canvas' <- vcEvalDialog canvas frame
               return $ vpuiWindowSetCanvas vw canvas'
             else return vw
         EditFrame ->
             -- ignore
             return vw

-- | Handles beginning of mouse-drag
beginFrameDrag :: VPUIWindow  -> CanvFrame -> Double -> Double 
               -> IO VPUIWindow
beginFrameDrag vw frame x y = 
    let canvas = vpuiWindowGetCanvas vw
        window = vpuiWindowWindow vw
        dragging = Dragging {draggingNode = cfFrameNode frame,
                             draggingPosition = Position x y}
        canvas' = canvas {vcDragging = Just dragging}
    in setCursor window Fleur >> 
       (return $ vpuiWindowSetCanvas vw canvas')

-- | Handle mouse move event
handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI
handleMouseMove winId x y mods vpui =
-- Needs to be in IO because of drawWindowInvalidateRect
    let vw = vpuiGetWindow vpui winId
    in case vpuiWindowLookupCanvas vw of
         Nothing -> 
             info "SQUAWK!  No canvas!  Shouldn't happen!" >>
             return vpui -- shouldn't happen
         Just canvas -> 
             do
               {
                 -- Highlight the active node, if any
                 let active = vcActive canvas
                     active' = vcanvasNodeAt canvas (Position x y)

                     invalidate :: DrawWindow -> Maybe G.Node -> IO ()
                     invalidate win mnode =
                         case mnode of
                           Nothing -> return ()
                           Just node -> 
                               drawWindowInvalidateRect win 
                                    (vcanvasNodeRect canvas node) False

               ; when (active /= active') $
                 do
                   {
                     win <- layoutGetDrawWindow (vcLayout canvas)
                   ; invalidate win active
                   ; invalidate win active'
                   }
               -- if dragging, continue drag
               ; canvas' <- continueDrag (canvas {vcActive = active', 
                                                  vcMousePos = (x, y)}) 
                            mods x y
               ; let vw' = vpuiWindowSetCanvas vw canvas'
               ; return $ vpuiReplaceWindow vpui winId vw'
               }

continueDrag :: VCanvas -> [Modifier] -> Double -> Double -> IO VCanvas
continueDrag canvas mods x y =
  case vcDragging canvas of
    Nothing -> return canvas
    Just dragging -> 
        let graph = vcGraph canvas
            dnode = draggingNode dragging
            wnode = wlab graph dnode
            Position oldX oldY = draggingPosition dragging
            (dx, dy) = (x - oldX, y - oldY)
        in
          case wnode of
             WSimple _ -> 
                 continueDragSimple canvas dragging dnode mods x y dx dy 
             WFrame frameNode -> 
                 continueDragFrame canvas dragging frameNode x y dx dy 

continueDragSimple :: VCanvas -> Dragging -> G.Node -> [Modifier] 
                   -> Double -> Double -> Double -> Double -> IO VCanvas
continueDragSimple canvas dragging simpleNode mods x y dx dy =
    let graph = vcGraph canvas
        frame = nodeContainerFrame canvas graph simpleNode
        dragging' = dragging {draggingPosition = Position x y}
        translateSelection = if checkMods [Shift] mods
                             then translateTree
                             else translateNode
        graph' = translateSelection dx dy graph simpleNode
        canvas' = canvas {vcGraph = graph'}
    in vcInvalidateFrameWithParent canvas graph frame >>
       return (canvas' {vcDragging = Just dragging'})

continueDragFrame :: 
    VCanvas -> Dragging -> G.Node -> 
    Double -> Double -> Double -> Double -> IO VCanvas
continueDragFrame canvas dragging frameNode x y dx dy =
  let graph = vcGraph canvas
      frame = vcGetFrame canvas graph frameNode
      frame' = translateFrame frame dx dy
      graph' = grTranslateFrameNodes graph frame dx dy
      canvas' = vcUpdateFrameAndGraph canvas frame' graph'
      dragging' = Just dragging {draggingPosition = Position x y}
  in 
    -- Tell the GUI about the changes so they will be redrawn
    -- Mark the frame changed so it will be redrawn
    frameChanged canvas graph frame graph' frame' >>
    -- Also, any frames opened from nodes of this frame
    mapM_ (\f -> frameChanged canvas graph f graph' f)
          (vcFrameSubframes canvas frame) >>
    -- Return the modified canvas
    return (canvas' {vcDragging = dragging'})

handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI
handleButtonRelease winId mouseButton vpui =
    case mouseButton of
      LeftButton -> 
          -- End drag
          let vw = vpuiGetWindow vpui winId
              canvas = vpuiWindowGetCanvas vw
              window = vpuiWindowWindow vw
              vw' = vpuiWindowSetCanvas vw (canvas {vcDragging = Nothing})
              vpui' = vpuiReplaceWindow vpui winId vw'
          in setCursor window LeftPtr >>
             return vpui'
      _ -> return vpui

-- | Show a context menu for mouse click in a frame.
offerContextMenu :: WinId -> CBMgr -> CanvFrame 
                 -> MouseButton -> TimeStamp -> IO ()
offerContextMenu winId cbmgr frame button timestamp = do
  -- Needs CBMgr to specify menu actions.
  {
    let menuSpec = 
            MenuSpec "Context Menu" (contextMenuOptions winId cbmgr frame)
  ; menu <- createMenu menuSpec cbmgr
  ; widgetShowAll menu
  ; menuPopup menu (Just (button, timestamp))
  }

-- | Options for context menu that depend on the frame type.

contextMenuOptions :: WinId -> CBMgr -> CanvFrame -> [MenuItemSpec]
contextMenuOptions winId cbmgr frame =
    let typeDependentOptions :: [MenuItemSpec]
        typeDependentOptions =
            case frameType frame of
              CallFrame -> 
                  [MenuItem "Edit" (editFrameFunction cbmgr frame)
                  , MenuItem "Close" (\ vpui -> closeFrame vpui winId frame)]
              EditFrame -> 
                  [
                  -- The next items duplicate parts of keyBindingsList
                    MenuItem "CONNECT (c)" (vpuiSetTool ToolConnect winId)
                  , MenuItem "DISCONNECT (d)" (vpuiSetTool ToolDisconnect winId)
                  , MenuItem "IF (i)" (vpuiSetTool ToolIf winId)
                  , MenuItem "FUNCTION (f)" (showFunctionEntry winId cbmgr)
                  , MenuItem "LITERAL (l)" (showLiteralEntry winId cbmgr)
                  -- , ("CLEAR (not implemented)", clearFrame winId frame)
                  , MenuItem "MOVE (m)" (vpuiSetTool ToolMove winId)
                  , MenuItem "DELETE (KP-Del)" (vpuiSetTool ToolDelete winId)
                  ]
    in typeDependentOptions ++
       [
--         ("Dump frame (debug)", 
--          \ vpui -> dumpFrame vpui winId frame >> return vpui)
--        , ("Dump graph (debug)", \ vpui -> 
--           dumpGraph vpui winId >> return vpui)
--        , ("--QUIT--", \ vpui -> vpuiQuit vpui >> return vpui)
       ]