module Sifflet.UI.Tool
(
ToolId(..)
, checkMods
, functionTool
, functionToolsFromLists
, makeConnectTool
, makeCopyTool
, makeDeleteTool
, makeDisconnectTool
, makeFixedArgTool
, makeIfTool
, makeMoveTool
, showFunctionEntry
, showLiteralEntry
, vpuiSetTool
, vpuiWindowSetTool
, vwAddFrame
, vpuiAddFrame
, wsPopStatusbar, wsPushStatusbar
, dumpFrame
, dumpGraph
, dumpWorkWin
, clearFrame
, closeFrame
)
where
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.IORef
import Data.List
import Data.Graph.Inductive as G
import Graphics.UI.Gtk.Gdk.EventM
import Sifflet.Data.Functoid
import Sifflet.Data.Geometry
import Sifflet.Data.Tree (putTree, repr)
import Sifflet.Data.TreeGraph (graphToOrderedTreeFrom)
import Sifflet.Data.WGraph
import Sifflet.Language.Expr
import Sifflet.Language.Parser
import Sifflet.UI.Callback
import Sifflet.UI.Canvas
import Sifflet.UI.Frame
import Sifflet.UI.LittleGtk
import Sifflet.UI.Types
import Sifflet.Util
data ToolId
= ToolConnect
| ToolDisconnect
| ToolIf
| ToolMove
| ToolDelete
| ToolFunction String
| ToolLiteral Expr
| ToolArg String
deriving (Eq, Show)
vpuiSetTool :: ToolId -> WinId -> VPUI -> IO VPUI
vpuiSetTool toolId winId =
vpuiUpdateWindowIO winId (vpuiWindowSetTool (toolIdToTool toolId))
vpuiWindowSetTool :: Tool -> VPUIWindow -> IO VPUIWindow
vpuiWindowSetTool tool vw =
case vw of
VPUIWorkWin ws _ ->
do
{
; wsPopStatusbar ws
; wsPushStatusbar ws ("Tool: " ++ toolName tool)
; let canvas' = (wsCanvas ws) {vcTool = Just tool}
; canvas'' <- toolActivated tool canvas'
; return $ vpuiWindowSetCanvas vw canvas''
}
_ -> return vw
toolIdToTool :: ToolId -> Tool
toolIdToTool toolId =
case toolId of
ToolConnect -> makeConnectTool
ToolDisconnect -> makeDisconnectTool
ToolIf -> makeIfTool
ToolMove -> makeMoveTool
ToolDelete -> makeDeleteTool
ToolFunction funcname -> functionTool funcname
ToolLiteral e -> makeFixedLiteralTool e
ToolArg argname -> makeFixedArgTool argname
defaultContextDescription :: String
defaultContextDescription = "default context"
wsPushStatusbar :: Workspace -> String -> IO ()
wsPushStatusbar ws msg = do
{
let sbar = wsStatusbar ws
; contextId <- statusbarGetContextId sbar defaultContextDescription
; _ <- statusbarPush sbar contextId msg
; return ()
}
wsPopStatusbar :: Workspace -> IO ()
wsPopStatusbar ws = do
{
let sbar = wsStatusbar ws
; contextId <- statusbarGetContextId sbar defaultContextDescription
; statusbarPop sbar contextId
}
makeMoveTool :: Tool
makeMoveTool =
let move canv toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
let graph = vcGraph canv
in case pointSelection graph frame (Position x y) of
sel@(Just (SelectionNode node)) ->
let dragging =
Dragging {draggingNode = node,
draggingPosition = Position x y}
in do
{
vcInvalidateFrameWithParent canv graph frame
; return $ canv {vcSelected = sel,
vcDragging = Just dragging}
}
_ ->
return canv
_ ->
return canv
in Tool "MOVE" return (toToolOpVW move)
makeDeleteTool :: Tool
makeDeleteTool =
let del :: CanvasToolOp
del canv toolContext mods x y =
case toolContext of
TCEditFrame frame ->
let graph = vcGraph canv
in case pointSelection graph frame (Position x y) of
Just (SelectionNode node) ->
if checkMods [Shift] mods
then vcFrameDeleteTree canv frame node
else vcFrameDeleteNode canv frame node
_ ->
return canv
_ ->
return canv
in Tool "DELETE" vcClearSelection (toToolOpVW del)
checkMods :: [Modifier] -> [Modifier] -> Bool
checkMods required found =
all (\ r -> elem r found) required
makeConnectTool :: Tool
makeConnectTool =
Tool "CONNECT" vcClearSelection (toToolOpVW (conn connect))
makeDisconnectTool :: Tool
makeDisconnectTool =
Tool "DISCONNECT" vcClearSelection (toToolOpVW (conn disconnect))
conn :: (VCanvas -> G.Node -> WEdge -> G.Node -> WEdge -> IO VCanvas)
-> CanvasToolOp
conn action canvas toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
let oldSel = vcSelected canvas
graph = vcGraph canvas
requestRedraw =
vcInvalidateFrameWithParent canvas graph frame
in case pointSelection graph frame (Position x y) of
Just sel@(SelectionInlet parent inlet) ->
do
{
requestRedraw
; case oldSel of
Just (SelectionOutlet child outlet) ->
do
{
canvas' <- action canvas parent
inlet child outlet
; return $ canvas' {vcSelected = Nothing}
}
_ -> return $ canvas {vcSelected = Just sel}
}
Just sel@(SelectionOutlet child outlet) ->
do
{
requestRedraw
; case oldSel of
Just (SelectionInlet parent inlet) ->
do
{
canvas' <- action canvas parent
inlet child outlet
; return $ canvas' {vcSelected = Nothing}
}
_ -> return $ canvas {vcSelected = Just sel}
}
_ ->
return canvas
_ ->
return canvas
makeFixedLiteralTool :: Expr -> Tool
makeFixedLiteralTool e =
let enode node = ENode node EvalUntried
addLitNode node vw toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
vcFrameAddNode vw frame (enode node) [] x y
_ ->
return vw
mktool node =
Tool ("Literal: " ++ repr e)
return
(toToolOpVW (addLitNode node))
in case e of
EBool b -> mktool (NBool b)
EChar c -> mktool (NChar c)
ENumber n -> mktool (NNumber n)
EString s -> mktool (NString s)
EList es -> if exprIsLiteral e
then mktool (NList es)
else errcats ["makeFixedLiteralTool: ",
"non-literal list expression",
show e]
_ ->
errcats ["makeFixedLiteralTool: non-literal or",
"extended expression", show e]
makeFixedArgTool :: String -> Tool
makeFixedArgTool label =
let node = ENode (NSymbol (Symbol label)) EvalUntried
addArgNode vw toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
vcFrameAddNode vw frame node [] x y
_ ->
return vw
in Tool ("Argument: " ++ label) return (toToolOpVW addArgNode)
makeIfTool :: Tool
makeIfTool =
let if_ vpui toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
let node = ENode (NSymbol (Symbol "if")) EvalUntried
labels = ["test", "left", "right"]
in vcFrameAddNode vpui frame node labels x y
_ ->
return vpui
in Tool "if" return (toToolOpVW if_)
makeCopyTool :: Tool
makeCopyTool = dummyTool "COPY"
dummyTool :: String -> Tool
dummyTool name =
let op vpui _winId _context _mods x y =
info ("dummyTool", name, x, y) >>
return vpui
in Tool ("*" ++ name ++ "*") return op
functionTool :: String -> Tool
functionTool name =
let op :: ToolOp
op vpui winId toolContext _mods x y =
let env = vpuiGlobalEnv vpui
func = envGetFunction env name
in case toolContext of
TCCallFrame _ ->
return vpui
TCEditFrame frame ->
let modify canvas =
vcFrameAddFunctoidNode canvas frame
(FunctoidFunc func)
x y
in vpuiModCanvasIO vpui winId modify
TCExprNode ->
return vpui
TCWorkspace ->
case functionImplementation func of
Primitive _ ->
return vpui
Compound _ _ ->
vpuiAddFrame vpui winId (FunctoidFunc func)
Nothing CallFrame
env x y 0 Nothing
in Tool name return op
vpuiAddFrame :: VPUI -> WinId -> Functoid -> Maybe [Value] -> FrameType
-> Env -> Double -> Double -> Double -> Maybe G.Node
-> IO VPUI
vpuiAddFrame vpui winId functoid mvalues mode prevEnv x y z mparent =
let update vw =
vwAddFrame vw functoid mvalues mode prevEnv x y z mparent
in vpuiUpdateWindowIO winId update vpui
vwAddFrame :: VPUIWindow -> Functoid -> Maybe [Value] -> FrameType
-> Env -> Double -> Double -> Double -> Maybe G.Node
-> IO VPUIWindow
vwAddFrame vw functoid mvalues mode prevEnv x y z mparent =
let modify canvas = vcAddFrame canvas functoid mvalues mode prevEnv
x y z mparent
in vpuiWindowModCanvasIO vw modify
functionToolsFromLists :: [[String]] -> [[Tool]]
functionToolsFromLists = map2 functionTool
showFunctionEntry :: WinId -> CBMgr -> VPUI -> IO VPUI
showFunctionEntry winId uimgr vpui =
let env = vpuiGlobalEnv vpui
fsymbols = (envFunctionSymbols env)
checkFunctionName :: String -> SuccFail String
checkFunctionName name =
case envLookup env name of
Nothing -> Fail $ name ++ ": unbound variable"
Just (VFun _) -> Succ name
_ -> Fail $ name ++ ": bound to non-function value"
in showToolEntry winId "Function name"
(Just fsymbols)
checkFunctionName
ToolFunction
uimgr
vpui
showLiteralEntry :: WinId -> CBMgr -> VPUI -> IO VPUI
showLiteralEntry winId =
showToolEntry winId "Literal value"
Nothing
parseLiteral
ToolLiteral
showToolEntry :: WinId -> String -> Maybe [String]
-> (String -> SuccFail a) -> (a -> ToolId)
-> CBMgr -> VPUI
-> IO VPUI
showToolEntry winId prompt mcompletions parser toolType uimgr vpui =
let vw = vpuiGetWindow vpui winId
in case vpuiWindowLookupCanvas vw of
Nothing -> error "showToolEntry: no canvas!"
Just canvas ->
let layout = vcLayout canvas
(xx, yy) = vcMousePos canvas
in do
{
; vbox <- vBoxNew False 5
; evtBox <- eventBoxNew
; label <- labelNew (Just prompt)
; entry <- entryNew
; case mcompletions of
Nothing -> return ()
Just comps -> addEntryCompletions entry comps
; containerAdd evtBox label
; boxPackStartDefaults vbox evtBox
; boxPackStartDefaults vbox entry
; layoutPut layout vbox (round xx) (round yy)
; widgetShowAll vbox
; grabAdd entry
; widgetGrabFocus entry
; _ <- on entry keyPressEvent (entryKeyPress vbox entry)
; uimgr (OnEntryActivate entry
(entryActivated vbox winId entry parser toolType))
; return vpui
}
entryActivated :: (ContainerClass c) =>
c -> WinId -> Entry
-> (String -> SuccFail a)
-> (a -> ToolId)
-> IORef VPUI
-> IO ()
entryActivated container winId entry parser toolType uiref = do
{
text <- entryGetText entry
; case parser text of
Fail msg -> info msg
Succ v ->
grabRemove entry >>
widgetDestroy container >>
readIORef uiref >>=
vpuiSetTool (toolType v) winId >>=
writeIORef uiref
}
addEntryCompletions :: Entry -> [String] -> IO ()
addEntryCompletions entry comps = do
{
model <- listStoreNew comps
; ec <- entryCompletionNew
; set ec [entryCompletionModel := Just model]
; customStoreSetColumn model (makeColumnIdString 0) id
; entryCompletionSetTextColumn ec (makeColumnIdString 0)
; entrySetCompletion entry ec
; return ()
}
entryKeyPress :: (ContainerClass c) => c -> Entry -> EventM EKey Bool
entryKeyPress container entry =
tryEvent $ do
{
kname <- eventKeyName
; case kname of
"Escape" ->
liftIO $
grabRemove entry >>
widgetDestroy container
"Tab" ->
liftIO $
entryGetCompletion entry >>=
entryCompletionInsertPrefix
_ -> stopEvent
}
dumpFrame :: VPUI -> WinId -> CanvFrame -> IO ()
dumpFrame vpui winId frame =
let vw = vpuiGetWindow vpui winId
canv = vpuiWindowGetCanvas vw
graph = vcGraph canv
frameNode = cfFrameNode frame
frame' = vcGetFrame canv graph frameNode
tree = graphToOrderedTreeFrom graph frameNode
in
info ("frame functoid:", cfFunctoid frame) >>
info ("frame' functoid:", cfFunctoid frame') >>
info ("frame' all descendants:",
nodeAllSimpleDescendants graph frameNode) >>
info "Tree rooted at frame:" >>
putTree tree
dumpGraph :: VPUI -> WinId -> IO ()
dumpGraph vpui = print . vcGraph . vpuiWindowGetCanvas . vpuiGetWindow vpui
dumpWorkWin :: VPUI -> WinId -> IO ()
dumpWorkWin vpui winId =
case vpuiTryGetWindow vpui winId of
Nothing -> putStrLn ("dumpWorkWin: no window found with id " ++ winId)
Just vpuiWindow ->
let window = vpuiWindowWindow vpuiWindow
in dumpWidget window >>
containerForeach window dumpWidget
dumpWidget :: (WidgetClass w) => w -> IO ()
dumpWidget w = do
{
(_, path, _) <- widgetClassPath w
; cname <- widgetClassName w
; vis <- get w widgetVisible
; print (path, cname, vis)
; when (elem cname ["GtkVBox", "GtkHBox", "GtkLayout"]) $
containerForeach (castToContainer w) dumpWidget
}
widgetClassName :: (WidgetClass w) => w -> IO String
widgetClassName w = do
{
(_len, _path, rpath) <- widgetClassPath w
; return (case elemIndex '.' rpath of
Nothing -> "Nil"
Just n -> reverse (take n rpath))
}
clearFrame :: WinId -> CanvFrame -> VPUI -> IO VPUI
clearFrame winId frame vpui =
let clear canvas = vcClearFrame canvas frame
in vpuiModCanvasIO vpui winId clear
closeFrame :: VPUI -> WinId -> CanvFrame -> IO VPUI
closeFrame vpui winId frame =
let close canvas = vcCloseFrame canvas frame
in vpuiModCanvasIO vpui winId close