sifflet-lib-1.2.2: Sifflet/UI/Window.hs
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
; uimgr (OnWindowDestroy window (onWindowDestroy 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)
}
onWindowDestroy :: WinId -> IORef VPUI -> IO ()
onWindowDestroy winId uiref =
if (winId == workspaceId)
then
readIORef uiref >>=
checkForChanges "quit (by closing the workspace window)" True False
(\ vpui -> do { mainQuit; return vpui }) >>
return ()
else modifyIORef uiref (vpuiRemoveVPUIWindow winId)
-- | 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]
-- this should suppress the window close button,
-- but doesn't, at least in Fluxbox
-- windowDeletable := False] -- no close button
; 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 = checkForChanges "quit" False True vpuiQuit
-- | Open a file (load its function definitions)
menuFileOpen :: CBMgr -> VPUI -> IO VPUI
menuFileOpen cbmgr =
checkForChanges "open file" True 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.
-- If offerCancel is true, there is an option to cancel the operation;
-- this won't work if the user is closing the main (workspace) window.
-- 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 :: String -> Bool -> Bool -> (VPUI -> IO VPUI)
-> VPUI -> IO VPUI
checkForChanges beforeOperation acknowledge offerCancel continue vpui =
let mAckIfSaved vpui' =
when (not (vpuiFileChanged vpui') && acknowledge)
(
showInfoMessage "Changes saved"
("Your changes are now saved; " ++
"proceeding to " ++
beforeOperation ++ ".")
)
>>
return vpui'
choices = [("Save them",
menuFileSave vpui >>= mAckIfSaved >>= continue),
("Throw them away",
return vpui >>= continue)] ++
if offerCancel
then [("Cancel " ++ beforeOperation, return vpui)]
else []
labels = map fst choices
actions = map snd choices
-- labels = ["Save them",
-- "Throw them away",
-- ]
-- 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)
]