module Graphics.UI.Sifflet.Tool
(
ToolId(..)
, checkMods
, functionArgToolSpecs
, functionTool
, functionToolsFromLists
, makeConnectTool
, makeCopyTool
, makeDeleteTool
, makeDisconnectTool
, 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 (ColumnId)
import Graphics.UI.Gtk.Gdk.EventM
import System.Glib.UTFString (glibToString)
import Data.Sifflet.Functoid
import Data.Sifflet.Geometry
import Data.Sifflet.Tree (putTree, repr)
import Data.Sifflet.TreeGraph (graphToOrderedTreeFrom)
import Data.Sifflet.WGraph
import Language.Sifflet.Expr
import Language.Sifflet.ExprTree
import Language.Sifflet.Parser
import Graphics.UI.Sifflet.Callback
import Graphics.UI.Sifflet.Canvas
import Graphics.UI.Sifflet.Frame
import Graphics.UI.Sifflet.LittleGtk
import Graphics.UI.Sifflet.Types
import Language.Sifflet.Util
data ToolId
= ToolConnect
| ToolDisconnect
| ToolIf
| ToolMove
| ToolDelete
| ToolFunction String
| ToolLiteral Expr
| ToolArg String Int
deriving (Eq, Show)
functionArgToolSpecs :: Function -> [ArgSpec]
functionArgToolSpecs (Function _mname argTypes _rtype impl) =
let atspec :: (String, Type) -> ArgSpec
atspec (name, t) = ArgSpec name (typeInlets t)
typeInlets :: Type -> Int
typeInlets (TypeCons "Function" [_t1, t2]) = 1 + typeInlets t2
typeInlets _ = 0
argNames =
case impl of
Primitive _ -> ["arg" ++ show i | i <- [1 .. length argTypes]]
Compound anames _body -> anames
in map atspec (zip argNames argTypes)
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 -> makeBoundLiteralTool e
ToolArg argname n -> makeBoundArgTool argname n
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
makeBoundLiteralTool :: Expr -> Tool
makeBoundLiteralTool 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 ["makeBoundLiteralTool: ",
"non-literal list expression",
show e]
_ ->
errcats ["makeBoundLiteralTool: non-literal or",
"extended expression", show e]
makeBoundArgTool :: String -> Int -> Tool
makeBoundArgTool label n =
let node = ENode (NSymbol (Symbol label)) EvalUntried
addArgNode vc toolContext _mods x y =
case toolContext of
TCEditFrame frame ->
vcFrameAddNode vc frame node (map show [1..n]) x y
_ ->
return vc
in Tool ("Argument: " ++ label ++ "/" ++ show n)
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
{
; root <- eventBoxNew
; frame <- frameNew
; frameSetLabel frame prompt
; entry <- entryNew
; case mcompletions of
Nothing -> return ()
Just comps -> addEntryCompletions entry comps
; containerAdd frame entry
; containerAdd root frame
; layoutPut layout root (round xx) (round yy)
; widgetShowAll root
; grabAdd entry
; widgetGrabFocus entry
; _ <- on entry keyPressEvent (entryKeyPress root entry)
; uimgr (OnEntryActivate entry
(entryActivated root 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 :: ColumnId a String)
; entrySetCompletion entry ec
; return ()
}
entryKeyPress :: (ContainerClass c) => c -> Entry -> EventM EKey Bool
entryKeyPress container entry =
tryEvent $ do
{
kname <- eventKeyName
; case glibToString 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 =
printWGraph . 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 :: IO (Int, String, String)
; 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