module Sifflet.UI.Window
(
showWindow
, newWindowTitled
, showWorkWin
, showWorkspaceWindow
, showFedWin
, fedWindowTitle
, showFunctionPadWindow
, newFunctionDialog
, openFilePath
, setWSCanvasCallbacks
, keyBindingsHelpText
)
where
import Control.Monad
import Control.Monad.Trans (liftIO)
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
showWindow :: WinId -> CBMgr
-> (VPUI -> Window -> IO VPUIWindow)
-> (VPUI -> WinId -> CBMgr -> IO ())
-> 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
(\ uiref ->
modifyIORef uiref (vpuiRemoveVPUIWindow winId)))
; return (vpui', vwin, True)
}
Just vw ->
return (vpui, vw, False)
; when isNew (initCB vpui' winId uimgr)
; windowPresent (vpuiWindowWindow vw)
; return (vpui', vw, isNew)
}
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
showWorkWin :: VPUI -> WinId -> CBMgr -> IO VPUI
showWorkWin vpui winId uimgr = do
{
(vpui', _, _) <- showWorkspaceWindow winId uimgr Nothing vpui
; return vpui'
}
showWorkspaceWindow :: WinId -> CBMgr -> Maybe Function -> VPUI
-> IO (VPUI, VPUIWindow, Bool)
showWorkspaceWindow winId cbmgr mfunc =
showWindow winId cbmgr (workspaceWindowInit cbmgr winId mfunc)
setWSCanvasCallbacks
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
}
buildMainMenu :: CBMgr -> VBox -> IO ()
buildMainMenu cbmgr vbox = do
{
let mspecs =
[MenuSpec "File"
[
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
}
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
; 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
{
; vbox <- vBoxNew False 0
; 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
; windowPresent window
; return $ FunctionPadWindow window (zip rpnames rps)
}
in do
{
(vpui', _, windowIsNew) <-
showWindow functionPadWinId cbmgr initWindow initCBDefault vpui
; 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
}
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
{
button <- makeToolButton cbmgr tool
; rp' <- rpanelAddWidget rp (toolName tool) button
; widgetShowAll (rpanelRoot rp')
; return rp'
}
in do
{
panelAList' <- adjustAListM panelId adjustPanel panelAList
; return $ FunctionPadWindow window panelAList'
}
_ -> return vw
newFunctionDialog :: WinId -> CBMgr -> VPUI -> IO VPUI
newFunctionDialog _winId cbmgr vpui =
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
}
menuFileQuit :: VPUI -> IO VPUI
menuFileQuit vpui = checkForChanges vpui "quit" False vpuiQuit
menuFileOpen :: CBMgr -> VPUI -> IO VPUI
menuFileOpen cbmgr vpui =
checkForChanges vpui "open file" True (continueFileOpen cbmgr)
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,
return vpui >>= continue,
return vpui]
offerSaveAndContinue = showChoicesDialog "Save changes?"
("There are unsaved changes. " ++
"Before you " ++ beforeOperation ++
", would you ...")
labels
actions
in if vpuiFileChanged vpui
then offerSaveAndContinue
else continue vpui
continueFileOpen :: CBMgr -> VPUI -> IO VPUI
continueFileOpen cbmgr vpui = do
mpath <- showDialogFileOpen vpui
case mpath of
Nothing -> return vpui
Just filePath -> openFilePath cbmgr filePath vpui
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 =
let oldNames = concat (rpanelContent rp)
loadedNames = map functionName functions
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 ...")
Nothing
FileChooserActionOpen
[("Open", ResponseOk), ("Cancel", ResponseCancel)]
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'}
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
{
mFilePath <- chooseOutputFile "Save" vpui
; case mFilePath of
Nothing -> return vpui
Just filePath -> saveFile vpui filePath
}
saveFile :: VPUI -> FilePath -> IO VPUI
saveFile vpui filePath =
produceSiffMLFile (userFunctions vpui) filePath >>
return vpui {vpuiFilePath = Just filePath,
vpuiFileEnv = vpuiGlobalEnv vpui}
userFunctions :: VPUI -> Functions
userFunctions vpui =
Functions (map (valueFunction . snd)
(vpuiUserEnvAList vpui))
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
menuFileExportHaskell :: VPUI -> IO VPUI
menuFileExportHaskell vpui =
chooseOutputFile "Export Haskell" vpui >>=
maybeDefaultOptions defaultHaskellOptions >>=
maybeExportUserFunctions vpui exportHaskell
menuFileExportPython :: VPUI -> IO VPUI
menuFileExportPython vpui =
chooseOutputFile "Export Python" vpui >>=
maybeDefaultOptions defaultPythonOptions >>=
maybeExportUserFunctions vpui exportPython
menuFileExportScheme :: VPUI -> IO VPUI
menuFileExportScheme vpui =
chooseOutputFile "Export Scheme" vpui >>=
maybeRunSchemeOptionsDialog >>=
maybeExportUserFunctions vpui exportScheme
chooseOutputFile :: String -> VPUI -> IO (Maybe FilePath)
chooseOutputFile verb _vpui = do
chooser <- fileChooserDialogNew
(Just (verb ++ " to file ..."))
Nothing
FileChooserActionSave
[(verb, ResponseOk), ("Cancel", ResponseCancel)]
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]
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"
]
showHelpDialog :: MenuItemAction
showHelpDialog vpui = showInfoMessage "Sifflet Help" helpText >> return vpui
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
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/"
]
siffletVersionString :: String
siffletVersionString = "1.0"
showAboutDialog :: MenuItemAction
showAboutDialog vpui = showInfoMessage "About Sifflet" aboutText >> return vpui
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
{
; cbmgr (OnWindowConfigure window (configuredCallback winId))
; cbmgr (OnWindowKeyPress window (keyPressCallback winId cbmgr))
; let layout = vcLayout canvas
; widgetSetCanFocus layout True
; cbmgr (OnLayoutExpose layout (exposedCallback winId))
; widgetAddEvents layout [PointerMotionMask]
; cbmgr (OnLayoutMouseMove layout (mouseMoveCallback winId))
; cbmgr (OnLayoutButtonPress layout
(buttonPressCallback winId cbmgr))
; cbmgr (OnLayoutButtonRelease layout (buttonReleaseCallback winId))
}
}
editFrameFunction :: CBMgr -> CanvFrame -> VPUI -> IO VPUI
editFrameFunction cbmgr frame vpui =
let func = cfFunctoid frame
in showFedWin cbmgr (functoidName func) (functoidArgNames func) vpui
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
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)
; stopEvent
}
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)
}
handleExposed :: WinId -> Rectangle -> VPUI -> IO ()
handleExposed winId clipbox vpui =
let vw = vpuiGetWindow vpui winId
in case vpuiWindowLookupCanvas vw of
Nothing -> info "handleExposed: no canvas found!"
Just canvas -> drawCanvas canvas clipbox
data KeyBinding = KeyBinding {kbGtkKeyName :: String,
kbAltKeyName :: Maybe String,
kbRequiredModifiers :: [Modifier],
kbDescription :: String,
kbAction :: KeyAction}
data KeyAction
= KeyActionST (WinId -> VPUI -> IO VPUI)
| KeyActionDG (WinId -> CBMgr -> VPUI -> IO VPUI)
| KeyActionModIO (CBMgr -> VPUI -> IO VPUI)
| KeyActionHQ (VPUI -> IO ())
keyBindingsMap :: Map String KeyBinding
keyBindingsMap = Map.fromList [(kbGtkKeyName kb, kb) | kb <- keyBindingsList]
keyBindingsList :: [KeyBinding]
keyBindingsList =
[
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))
, KeyBinding "n" Nothing [] "new function" (KeyActionDG newFunctionDialog)
, KeyBinding "f" Nothing [] "function" (KeyActionDG showFunctionEntry)
, KeyBinding "l" Nothing [] "literal" (KeyActionDG showLiteralEntry)
, KeyBinding "question" (Just "?") [] "help" (KeyActionHQ vpuiKeyHelp)
, 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 ()))
]
vpuiKeyHelp :: VPUI -> IO ()
vpuiKeyHelp _vpui = putStrLn keyBindingsHelpText
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
keyPressCallback :: WinId -> CBMgr -> IORef VPUI -> EventM EKey Bool
keyPressCallback winId cbmgr uiref =
tryEvent $ do
{
kname <- eventKeyName
; mods <- eventModifier
; let giveUp =
stopEvent
; case Map.lookup kname keyBindingsMap of
Nothing ->
giveUp
Just keyBinding ->
if checkMods (kbRequiredModifiers keyBinding) mods
then liftIO $
case kbAction keyBinding of
KeyActionModIO f0 ->
modifyIORefIO uiref (f0 cbmgr)
KeyActionST f1 ->
modifyIORefIO uiref (f1 winId)
KeyActionDG f2 ->
modifyIORefIO uiref (f2 winId cbmgr)
KeyActionHQ f3 ->
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))
}
handleButtonPress :: WinId -> CBMgr -> MouseButton
-> Double -> Double
-> [Modifier] -> TimeStamp
-> 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
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
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'
}
}
leftButtonPressedInFrameFooter ::
VPUIWindow -> CanvFrame -> IO VPUIWindow
leftButtonPressedInFrameFooter vw frame =
let canvas = vpuiWindowGetCanvas vw
in case frameType frame of
CallFrame ->
if cfEvalReady frame
then do
canvas' <- vcEvalDialog canvas frame
return $ vpuiWindowSetCanvas vw canvas'
else return vw
EditFrame ->
return vw
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')
handleMouseMove :: WinId -> Double -> Double -> [Modifier] -> VPUI -> IO VPUI
handleMouseMove winId x y mods vpui =
let vw = vpuiGetWindow vpui winId
in case vpuiWindowLookupCanvas vw of
Nothing ->
info "SQUAWK! No canvas! Shouldn't happen!" >>
return vpui
Just canvas ->
do
{
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'
}
; 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
frameChanged canvas graph frame graph' frame' >>
mapM_ (\f -> frameChanged canvas graph f graph' f)
(vcFrameSubframes canvas frame) >>
return (canvas' {vcDragging = dragging'})
handleButtonRelease :: WinId -> MouseButton -> VPUI -> IO VPUI
handleButtonRelease winId mouseButton vpui =
case mouseButton of
LeftButton ->
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
offerContextMenu :: WinId -> CBMgr -> CanvFrame
-> MouseButton -> TimeStamp -> IO ()
offerContextMenu winId cbmgr frame button timestamp = do
{
let menuSpec =
MenuSpec "Context Menu" (contextMenuOptions winId cbmgr frame)
; menu <- createMenu menuSpec cbmgr
; widgetShowAll menu
; menuPopup menu (Just (button, timestamp))
}
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 ->
[
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)
, MenuItem "MOVE (m)" (vpuiSetTool ToolMove winId)
, MenuItem "DELETE (KP-Del)" (vpuiSetTool ToolDelete winId)
]
in typeDependentOptions ++
[
]