sifflet-lib-1.1: Sifflet/UI/Workspace.hs
{- Currently, this module contains functions for VPUI, VPUIWindow,
Workspace, VCanvas, and more. A reorganization seems called for,
but for now I will just keep adding functions here. -}
module Sifflet.UI.Workspace
(
-- VPUI and Workspace
vpuiNew
, workspaceNewDefault
, workspaceNewEditing
, addArgToolButtons
, addApplyCloseButtons
, defineFunction
, workspaceId
, openNode
-- Quitting:
, removeWindow
, vpuiQuit
-- Windows:
, forallWindowsIO
, baseFunctionsRows
)
where
import Control.Monad
import Data.Map ((!), keys)
import qualified Data.Map as Map (empty)
import Data.Graph.Inductive as G
import Sifflet.Data.Functoid
import Sifflet.Data.Geometry
import Sifflet.Data.TreeLayout
import Sifflet.Language.Expr
import Sifflet.UI.GtkUtil
import Sifflet.UI.LittleGtk
import Sifflet.Util
import Sifflet.UI.Callback
import Sifflet.Data.TreeGraph
import Sifflet.UI.Types
import Sifflet.UI.Canvas
import Sifflet.UI.Frame
import Sifflet.UI.Tool
import Sifflet.Data.WGraph
-- | Create a new VPUI.
-- This used to set up the basic "q to quit" and "on exposed" callbacks,
-- but now does not even do that.
-- The 'init' function argument
-- may perform additional initialization;
-- if there is none, simply use 'return'.
-- The following comment is out of date,
-- but may explain some bizarre features historically:
-- Note that if you want to set up callbacks,
-- there is some trickiness: the vpui contains the workspace,
-- and the layout (which is on the workspace) needs to have callbacks
-- which know the uiref. So, create the workspace, vpui, and uiref,
-- in that order, and then set up the callbacks.
vpuiNew :: Style -> Env -> IO VPUI
vpuiNew style env =
return VPUI {vpuiWindows = Map.empty,
vpuiToolkits = [],
vpuiFilePath = Nothing,
vpuiStyle = style,
vpuiInitialEnv = env,
vpuiGlobalEnv = env,
vpuiFileEnv = env
}
-- | Create a new "main" workspace window, with a given style.
-- The second argument should set up a menu bar and place it on the vbox,
-- or do nothing if no menu is wanted.
workspaceNewDefault :: Style -> (VBox -> IO ()) -> IO Workspace
workspaceNewDefault style =
workspaceNew style (Size 3600.0 2400.0) (Just (Size 900.0 600.0))
workspaceNewEditing :: Style -> Env -> Function -> IO Workspace
workspaceNewEditing style initEnv func = do
{
; let funcFrame = fedFuncFrame style func initEnv -- throw-away
Size fwidth fheight = bbSize (cfBox funcFrame)
canvSize = Size (max fwidth 300) (max fheight 300)
mViewSize = Nothing
addNoMenu _ = return ()
; workspaceNew style canvSize mViewSize addNoMenu
}
addArgToolButtons :: CBMgr -> WinId -> [String] -> VPUI -> IO ()
addArgToolButtons cbmgr winId labels vpui =
case vpuiGetWindow vpui winId of
VPUIWorkWin ws _ ->
let bbar = wsButtonBar ws
in mapM_ (addArgToolButton cbmgr winId bbar) labels
_ -> return ()
addArgToolButton :: CBMgr -> WinId -> HBox -> String -> IO ()
addArgToolButton cbmgr winId buttonBox label = do
{
button <- buttonNewWithLabel label
; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons
; widgetShow button
; cbmgr (AfterButtonClicked button
(\ uiref ->
modifyIORefIO uiref (vpuiSetTool (ToolArg label) winId)))
; return ()
}
-- | Add "Apply" and "Close" buttons to a function-editor window
addApplyCloseButtons :: CBMgr -> WinId -> VPUI -> IO ()
addApplyCloseButtons cbmgr winId vpui =
case vpuiGetWindow vpui winId of
VPUIWorkWin ws window ->
addApplyCloseButtons2 cbmgr winId ws window
_ -> return ()
addApplyCloseButtons2 :: CBMgr -> WinId -> Workspace -> Window -> IO ()
addApplyCloseButtons2 cbmgr winId ws window =
let bbar = wsButtonBar ws
applyFrame :: VPUI -> IO VPUI
applyFrame vpui =
case vcFrames (vpuiWindowGetCanvas (vpuiGetWindow vpui winId)) of
[frame] -> defineFunction winId frame vpui
_ -> info "ApplyFrame: no unique frame found" >> return vpui
-- addButton :: String -> (IORef VPUI -> IO ())
addButton label action = do
{
button <- buttonNewWithLabel label
; boxPackEnd bbar button PackNatural 3
; widgetShow button
; cbmgr (AfterButtonClicked button action)
}
in addButton "Close" (\ _uiref -> widgetDestroy window) >>
addButton "Apply" (\ uiref -> modifyIORefIO uiref applyFrame)
-- | fedFuncFrame generates a throw-away frame for the sole purplse
-- of obtaining its measurements before initializing the canvas
fedFuncFrame :: Style -> Function -> Env -> CanvFrame
fedFuncFrame style func prevEnv =
let (frame, _) =
frameNewWithLayout style (Position 0 0) 0
(FunctoidFunc func) Nothing
CallFrame -- mode may change below
0 prevEnv Nothing
in frame
-- | If mViewSize is Nothing, no scrollbars are put on the canvas,
-- and its display size request is its natural size.
-- If mViewSize = Just viewSize, then scrollbars are wrapped around
-- the canvas, and its displayed size request is viewSize.
-- addMenuBar is an action which, if desired, adds a menu bar;
-- if you don't want one, just pass (\ _ -> return ()).
workspaceNew :: Style -> Size -> Maybe Size -> (VBox -> IO ()) -> IO Workspace
workspaceNew style canvSize mViewSize addMenuBar = do
{
; let Size dcWidth dcHeight = canvSize -- Double, Double
(icWidth, icHeight) = (round dcWidth, round dcHeight)
scrolled :: GtkLayout -> Size -> IO ScrolledWindow
scrolled layout viewSize = do
{
let Size dvWidth dvHeight = viewSize -- Double, Double
(iViewWidth, iViewHeight) = (round dvWidth, round dvHeight)
-- Wrap layout directly in a ScrolledWindow .
-- Adjustments: value lower upper stepIncr pageIncr pageSize
; xAdj <- adjustmentNew 0.0 0.0 dcWidth 10.0 dvWidth dvWidth
; yAdj <- adjustmentNew 0.0 0.0 dcHeight 10.0 dvHeight dvHeight
; scrollWin <- scrolledWindowNew (Just xAdj) (Just yAdj)
-- show scrollbars? (never, always, or if needed)
; scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyAutomatic
-- request view size for _layout_
; widgetSetSizeRequest layout iViewWidth iViewHeight
; set scrollWin [containerChild := layout]
; return scrollWin
}
bare :: GtkLayout -> IO GtkLayout
bare layout = do
{
-- request canvas size for _layout_
; widgetSetSizeRequest layout icWidth icHeight -- new
; return layout
}
-- The canvas itself
; vcanvas <- vcanvasNew style dcWidth dcHeight
; let layout = vcLayout vcanvas
-- Set the actual size of the canvas layout, which may be more
-- than is displayed if scrollbars are used
; layoutSetSize layout icWidth icHeight
-- An empty HBox for buttons (or it may remain empty)
; buttonBar <- hBoxNew False 3
-- The Statusbar
; statusBar <- statusbarNew
-- All together in a VBox
; vbox <- vBoxNew False 0 -- not equal space allotments, 0 spacing
; addMenuBar vbox
; let packGrow :: WidgetClass w => w -> IO ()
packGrow w = boxPackStart vbox w PackGrow 0
; case mViewSize of
Nothing -> bare layout >>= packGrow
Just viewSize -> scrolled layout viewSize >>= packGrow
; boxPackStart vbox buttonBar PackNatural 0
; boxPackStart vbox statusBar PackNatural 0
; return $ Workspace vbox vcanvas buttonBar statusBar
}
vpuiQuit :: VPUI -> IO VPUI
vpuiQuit vpui = do
{
-- This should also check for unsaved changes? ***
vpui' <- foldM (\ vp winId -> removeWindow vp True winId)
vpui
(vpuiAllWindowKeys vpui)
; mainQuit
; return vpui'
}
-- | List of all window ids of the vpui,
vpuiAllWindowKeys :: VPUI -> [WinId]
vpuiAllWindowKeys = keys . vpuiWindows
-- | Perform action on all windows
-- (actually (WinId, VPUIWindow) pairs.
-- Returns updated VPUI (in case any windows are changed).
forallWindowsIO :: (VPUIWindow -> IO VPUIWindow) -> VPUI -> IO VPUI
forallWindowsIO action vpui =
let loop ks vpui' =
case ks of
[] -> return vpui'
k : ks' ->
let w = vpuiGetWindow vpui' k
in do
{
w' <- action w
; loop ks' (vpuiReplaceWindow vpui' k w')
}
in loop (vpuiAllWindowKeys vpui) vpui
-- | This function is called either when a window *has been* destroyed,
-- with destroy = False,
-- or when you *want to* destroy a window, with destroy = True.
-- WOULD BE BETTER to have two functions, windowRemoved and removeWindow???
-- | removeWindow actually *closes* the window if destroy = True,
-- as well as removing it from the vpui's windows map.
removeWindow :: VPUI -> Bool -> WinId -> IO VPUI
removeWindow vpui destroy winId = do
{
-- Remove the window from vpui;
-- if destroy is true, also destroy it.
-- It is an error if the window id does not exist.
let vwMap = vpuiWindows vpui
; when destroy $ widgetDestroy (vpuiWindowWindow (vwMap ! winId))
; return $ vpuiRemoveVPUIWindow winId vpui
}
-- | Context menu command to apply the function definition
-- of an EditFrame.
-- | "Execute" the definition currently represented in the frame,
-- i.e., bind the function name in the global environment
-- to the function definition found in the frame.
defineFunction :: WinId -> CanvFrame -> VPUI -> IO VPUI
defineFunction winId frame vpui =
case frameType frame of
CallFrame ->
showErrorMessage "Software error\nNot in an edit frame!"
>> return vpui
EditFrame ->
case cfFunctoid frame of
FunctoidFunc _function ->
return vpui
fparts@FunctoidParts {} ->
let env = vpuiGlobalEnv vpui
vw = vpuiGetWindow vpui winId
canv = vpuiWindowGetCanvas vw
graph = vcGraph canv
frameNode = cfFrameNode frame
in case functoidToFunction fparts graph frameNode env of
Fail errmsg ->
showErrorMessage errmsg >>
return vpui
Succ function ->
let BBox x y _ _ = cfBox frame
z = cfLevel frame
fname = functionName function
env' = envSet env fname (VFun function)
vpui' = vpui {vpuiGlobalEnv = env'}
in do
{
; canv' <- vcCloseFrame canv frame
-- can this use vpuiAddFrame? ***
; canv'' <-
vcAddFrame canv' (FunctoidFunc function)
Nothing
EditFrame
env' x y z Nothing
; let vw' = vpuiWindowSetCanvas vw canv''
vpui'' = vpuiReplaceWindow vpui' winId vw'
; vpuiUpdateCallFrames vpui'' fname
}
workspaceId :: String
workspaceId = "Sifflet Workspace"
-- | In the workspace window, update each frame calling the named function
-- to reflect the current function definition
vpuiUpdateCallFrames :: VPUI -> String -> IO VPUI
vpuiUpdateCallFrames vpui fname =
case vpuiTryGetWindow vpui workspaceId of
Nothing -> return vpui
Just w -> do
{
; let canvas = vpuiWindowGetCanvas w
env = vpuiGlobalEnv vpui
frames = callFrames canvas fname
update canv frame = canvasUpdateCallFrame canv frame fname env
; canvas' <- foldM update canvas frames
; let w' = vpuiWindowSetCanvas w canvas'
; return $ vpuiReplaceWindow vpui workspaceId w'
}
-- | In the canvas, update a call frame with the current function
-- definition from the environment, returning a new canvas.
-- Root call frames are torn down and rebuilt with the new function definition.
-- Call frames that are called by other call frames are simply torn down.
canvasUpdateCallFrame :: VCanvas -> CanvFrame -> String -> Env -> IO VCanvas
canvasUpdateCallFrame canvas frame fname env = do
{
-- Tear down old frame
canvas' <- vcCloseFrame canvas frame
; case cfParent frame of
Nothing ->
-- root frame; build up new frame
let Position x y = bbPosition (cfBox frame)
z = cfLevel frame
functoid = FunctoidFunc {fpFunc = envGetFunction env fname}
in vcAddFrame canvas' functoid Nothing CallFrame env x y z Nothing
Just _ ->
-- frame with a parent; finished
return canvas'
}
openNode :: VPUIWindow -> G.Node -> IO VPUIWindow
openNode vw node = do
let canvas = vpuiWindowGetCanvas vw
graph = vcGraph canvas
if not (nodeIsSimple graph node)
then return vw -- WFrame node -- is this possible?
else if nodeIsOpen graph node
then info "Already open" >> return vw
else let frame = nodeContainerFrame canvas graph node
in case nodeCompoundFunction graph frame node of
Nothing ->
info "Cannot be opened" >> return vw
Just function ->
case nodeInputValues graph node of
EvalOk (VList values) ->
let env = extendEnv (functionArgNames function)
values (cfEnv frame)
Position x y =
frameOffset (vcStyle canvas) frame
z = succ (cfLevel frame)
in vwAddFrame vw
(FunctoidFunc function)
(Just values) CallFrame
env x y z (Just node)
EvalOk x ->
errcats ["openNode: non-VList result:", show x]
_ ->
info "Cannot be opened: lacking input values" >>
return vw
baseFunctionsRows :: [[String]]
baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"],
["==", "/=", "<", ">", "<=", ">="],
["zero?", "positive?", "negative?"],
["null", "head", "tail", ":"]]