module Sifflet.UI.Workspace
(
vpuiNew
, workspaceNewDefault
, workspaceNewEditing
, addArgToolButtons
, addApplyCloseButtons
, defineFunction
, workspaceId
, openNode
, removeWindow
, vpuiQuit
, 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
vpuiNew :: Style -> Env -> IO VPUI
vpuiNew style env =
return VPUI {vpuiWindows = Map.empty,
vpuiToolkits = [],
vpuiFilePath = Nothing,
vpuiStyle = style,
vpuiInitialEnv = env,
vpuiGlobalEnv = env,
vpuiFileEnv = env
}
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
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
; widgetShow button
; cbmgr (AfterButtonClicked button
(\ uiref ->
modifyIORefIO uiref (vpuiSetTool (ToolArg label) winId)))
; return ()
}
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 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 :: Style -> Function -> Env -> CanvFrame
fedFuncFrame style func prevEnv =
let (frame, _) =
frameNewWithLayout style (Position 0 0) 0
(FunctoidFunc func) Nothing
CallFrame
0 prevEnv Nothing
in frame
workspaceNew :: Style -> Size -> Maybe Size -> (VBox -> IO ()) -> IO Workspace
workspaceNew style canvSize mViewSize addMenuBar = do
{
; let Size dcWidth dcHeight = canvSize
(icWidth, icHeight) = (round dcWidth, round dcHeight)
scrolled :: GtkLayout -> Size -> IO ScrolledWindow
scrolled layout viewSize = do
{
let Size dvWidth dvHeight = viewSize
(iViewWidth, iViewHeight) = (round dvWidth, round dvHeight)
; 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)
; scrolledWindowSetPolicy scrollWin PolicyAutomatic PolicyAutomatic
; widgetSetSizeRequest layout iViewWidth iViewHeight
; set scrollWin [containerChild := layout]
; return scrollWin
}
bare :: GtkLayout -> IO GtkLayout
bare layout = do
{
; widgetSetSizeRequest layout icWidth icHeight
; return layout
}
; vcanvas <- vcanvasNew style dcWidth dcHeight
; let layout = vcLayout vcanvas
; layoutSetSize layout icWidth icHeight
; buttonBar <- hBoxNew False 3
; statusBar <- statusbarNew
; vbox <- vBoxNew False 0
; 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
{
vpui' <- foldM (\ vp winId -> removeWindow vp True winId)
vpui
(vpuiAllWindowKeys vpui)
; mainQuit
; return vpui'
}
vpuiAllWindowKeys :: VPUI -> [WinId]
vpuiAllWindowKeys = keys . vpuiWindows
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
removeWindow :: VPUI -> Bool -> WinId -> IO VPUI
removeWindow vpui destroy winId = do
{
let vwMap = vpuiWindows vpui
; when destroy $ widgetDestroy (vpuiWindowWindow (vwMap ! winId))
; return $ vpuiRemoveVPUIWindow winId vpui
}
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
; 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"
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'
}
canvasUpdateCallFrame :: VCanvas -> CanvFrame -> String -> Env -> IO VCanvas
canvasUpdateCallFrame canvas frame fname env = do
{
canvas' <- vcCloseFrame canvas frame
; case cfParent frame of
Nothing ->
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 _ ->
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
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", ":"]]