sifflet-0.1.7: WindowManagement.hs
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)
]