module WindowManagement
    (
     -- Window utilities
      showWindow
    , newWindowTitled

    , showWorkWin
    , showWorkspaceWindow

    , showFedWin
    , fedWindowTitle

    , showFunctionPadWindow
    , newFunctionDialog

    , setWSCanvasCallbacks
    , keyBindingsHelpText
    )

where

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

import Data.Graph.Inductive as G

import LittleGtk 
import Graphics.UI.Gtk.Gdk.EventM

import CBMgr
import Expr
import Geometry
import GtkForeign as XCursor
import GtkUtil
import RPanel
import SiffML
import UITypes
import Util
import Workspace

-- ---------------------------------------------------------------------
-- | 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 "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) 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 -> String -> IO RPanel
makeFunctionPadPanel cbmgr name =
    let VPToolkit _ width toolrows = 
            case Map.lookup name defaultVPUIToolkits 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 ->
        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 = mpath, 
                                       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 <- consumeFile 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'}

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

menuFileSaveAs :: VPUI -> IO VPUI
menuFileSaveAs vpui = do
  mpath <- showDialogFileSaveAs vpui
  case mpath of
    Nothing -> return vpui        -- canceled
    Just filePath -> saveFile vpui filePath

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

-- | Returns the updated VPUI with updated fields
-- vpuiFilePath and vpuiFileEnv

-- What about IO errors? ******

saveFile :: VPUI -> FilePath -> IO VPUI
saveFile vpui filePath = 
    let functions = Functions (map (valueFunction . snd)
                              (vpuiUserEnvAList vpui))
    in produceFile functions filePath >>
       return vpui {vpuiFilePath = Just filePath, 
                    vpuiFileEnv = vpuiGlobalEnv vpui}

-- | 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 " ++ siffletVersionString,
             "Copyright (C) 2010 Gregory D. Weber",
             "",
             "BSD3 License",
             "",
             "Sifflet home page:",
             "http://mypage.iu.edu/~gdweber/software/sifflet/"
            ]

-- | The software version number.
-- See ACTION: RELEASE CHECKLIST for a list of
-- places where this version number needs to be synchronized.
siffletVersionString :: String
siffletVersionString = "0.1.7"

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 XCursor.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 XCursor.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)
       ]