sifflet-0.1.5: Workspace/Tools.hs

module Workspace.Tools 
    (
     ToolId(..)
    , Tool(..), ToolContext(..)
    , checkMods
    , functionTool
    , functionToolsFromLists
    , makeConnectTool
    , makeCopyTool
    , makeDeleteTool
    , makeDisconnectTool
    , makeFixedArgTool
    , makeIfTool
    , makeMoveTool
    , showFunctionEntry
    , showLiteralEntry
    , vpuiSetTool
    , vpuiWindowSetTool

    , vwAddFrame
    , vpuiAddFrame

    -- Statusbar
    , wsPopStatusbar, wsPushStatusbar

    -- frame context menu commands (do these belong elsewhere?)
    , 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 
    hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth,
            disconnect)
import Graphics.UI.Gtk.Gdk.EventM

import CBMgr
import Expr
import Geometry
import Tree (putTree, repr)
import TreeGraph (graphToOrderedTreeFrom)

import UITypes
import Util
import Workspace.Canvas
import Workspace.Frame
import Workspace.Functoid
import Workspace.WGraph


data ToolId 
 = ToolConnect
 | ToolDisconnect
 | ToolIf
 | ToolMove
 | ToolDelete
 | ToolFunction String          -- ^ function name
 | ToolLiteral Expr
 | ToolArg String               -- ^ argument name
   deriving (Eq, Show)

-- Tools

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 expr -> makeFixedLiteralTool expr
      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}
                           }
                       _ ->     -- no node selected, do nothing
                           return canv
              _ ->
                  return canv     -- not an edit frame, do nothing
    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     -- no node selected, do nothing

              _ -> 
                  return canv         --  not an edit frame, do nothing
          
    in Tool "DELETE" vcClearSelection (toToolOpVW del)

-- | Check that all required modifiers are in found
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
                    
               -- Overall algorithm: If we're on a port and there's
               -- an opposite port selected, apply the action them
               -- and clear the selection.  Otherwise, if we're on
               -- a port, select it.  Otherwise do nothing.

               Just sel@(SelectionInlet parent inlet) ->
                   -- Case 1: we're on an inlet port, 
                   -- opposite port = outlet
                   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) ->
                   -- Case 2: we're on an outlet port, 
                   -- opposite port = inlet
                   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}
                     }

               _ -> 
                      -- Case 3: we're not on an iolet, do nothing
                      return canvas
      _ -> 
          -- not in an edit frame, do nothing
          return canvas

makeFixedLiteralTool :: Expr -> Tool
makeFixedLiteralTool expr =
    case expr of
      ELit literal ->
          let node = ENode (NLit literal) EvalUntried
              addLitNode vw toolContext _mods x y =
                  case toolContext of
                    TCEditFrame frame ->
                        vcFrameAddNode vw frame node [] x y
                    _ ->
                        return vw -- Nothing
          in Tool ("Literal: " ++ repr literal) return (toToolOpVW addLitNode)
      _ ->
          error $ "makeFixedLiteralTool: non-literal expression " ++ show expr

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 -- no effect
    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     -- do nothing
    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 needs the VPUI in its op,
-- because it needs to get an environment.

functionTool :: String -> Tool
functionTool name =
     let op :: ToolOp
         op vpui winId toolContext _mods x y =  
             -- Some of these are not used in some cases,
             -- but with lazy evaluation it doesn't hurt to
             -- declare them all up here:
             let env = vpuiGlobalEnv vpui
                 func = envGetFunction env name
             in case toolContext of
                  TCCallFrame _ -> 
                      return vpui     -- do nothing
                  TCEditFrame frame ->
                         let modify canvas =
                                 vcFrameAddFunctoidNode canvas frame
                                                        (FunctoidFunc func)
                                                        x y
                         in vpuiModCanvasIO vpui winId modify
                  TCExprNode ->
                      return vpui     -- do nothing
                  TCWorkspace ->
                      case functionImplementation func of
                        Primitive _ -> 
                            return vpui -- do nothing
                        Compound _ _ -> 
                            -- Add a call frame to the workspace
                            vpuiAddFrame vpui winId (FunctoidFunc func) []
                                         CallFrame env x y 0 Nothing
    in Tool name return op


-- | Add a frame representing a functoid to the canvas 
-- of a particular window, specified by its window id (title).

vpuiAddFrame :: VPUI -> WinId -> Functoid -> [Value] -> FrameType
              -> Env -> Double -> Double -> Double -> Maybe G.Node 
              -> IO VPUI
vpuiAddFrame vpui winId functoid values mode prevEnv x y z mparent = 
    let update vw = 
            vwAddFrame vw functoid values mode prevEnv x y z mparent
    in vpuiUpdateWindowIO winId update vpui

-- | Add a frame representing a functoid to the canvas 
-- of a VPUIWindow (which ought to have a canvas, of course).
-- Otherwise like vcAddFrame.

vwAddFrame :: VPUIWindow -> Functoid -> [Value] -> FrameType 
           -> Env -> Double -> Double -> Double -> Maybe G.Node 
           -> IO VPUIWindow
vwAddFrame vw functoid values mode prevEnv x y z mparent = 
    let modify canvas = vcAddFrame canvas functoid values mode prevEnv
                                   x y z mparent
    in vpuiWindowModCanvasIO vw modify

functionToolsFromLists :: [[String]] -> [[Tool]]
functionToolsFromLists = map2 functionTool
    
-- | Open an entry for user input of function name to select a function tool.
-- Returns unaltered VPUI, for convenience in menus and key callbacks.

showFunctionEntry :: WinId -> CBMgr -> VPUI -> IO VPUI
showFunctionEntry winId uimgr vpui = 
    let env = vpuiGlobalEnv vpui
        fsymbols = (envFunctionSymbols env)
        -- Check whether the name is bound to a function
        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)    -- completions
           checkFunctionName  -- parser
           -- activateTool       -- action
           ToolFunction         -- tool type specifier
           uimgr              -- state
           vpui

-- | Show an entry for input of a literal value.
-- Returns unaltered VPUI, for convenience in menus and key callbacks.

showLiteralEntry :: WinId -> CBMgr -> VPUI -> IO VPUI
showLiteralEntry winId = 
    -- Needs uimgr for action when entry is activated
    showToolEntry winId "Literal value" 
                  Nothing              -- completions
                  stringToLiteral      -- parser
                  -- activateTool         -- action
                  ToolLiteral          -- tool type specifier

-- | New, light replacement for most dialogs

-- | Prompt for input in a text entry.
--   When the user presses Return, attempt to parse the input text.
--   If parse succeeds, apply the toolType to the resulting value
--   to produce a ToolId and set the corresponding tool.
--   If user presses Escape, the input is closed with no action.
--   If mcompletions is (Just comps), comps is a list of possible
--   completions for the entry.
-- 
-- Returns the vpui, with NO UPDATE, for convenience in callbacks and menus

-- Note: this has been specialized; the action only sets a tool
-- on the window.  It can be generalized again
-- to any sort of action if needed.
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     -- needed for Label visibility
               ; label <- labelNew (Just prompt)
               ; entry <- entryNew
               ; case mcompletions of
                   Nothing -> return ()
                   Just comps -> addEntryCompletions entry comps

               -- Organize as (vbox (eventbox (label), entry))
               ; containerAdd evtBox label
               ; boxPackStartDefaults vbox evtBox
               ; boxPackStartDefaults vbox entry
               ; layoutPut layout vbox (round xx) (round yy)
               ; widgetShowAll vbox

               -- grab and handle events
               ; grabAdd entry -- all keyboard and mouse events of the app
               ; widgetGrabFocus entry -- grabs keyboard events, still necessary
               -- Set actions for TAB (entry completion) and ESC (cancel)
               ; on entry keyPressEvent (entryKeyPress vbox entry)
               ; uimgr (OnEntryActivate entry
                        (entryActivated vbox winId entry parser toolType))
               ; return vpui
               }

-- | When activated, send a message to set the current tool 
entryActivated :: (ContainerClass c) => 
                  c -> WinId -> Entry 
               -> (String -> SuccFail a) -- parser
               -> (a -> ToolId)          -- tool type
               -> IORef VPUI    -- state
               -> IO ()
entryActivated container winId entry parser toolType uiref = do
-- This could be rewritten in the form of :: ... -> VPUI -> IO VPUI
-- and transformed in the CBMgr, "lifting" the readIORef/writeIORef,
-- in fact streamlining it to "mutateIORef"
  {
    text <- entryGetText entry
  ; case parser text of
      Fail msg -> info msg
      Succ value -> 
          grabRemove entry >>
          widgetDestroy container >>
          readIORef uiref >>= 
          vpuiSetTool (toolType value) winId >>=
          writeIORef uiref
  }

addEntryCompletions :: Entry -> [String] -> IO ()
addEntryCompletions entry comps = do
  {
    -- prepare the model
    model <- listStoreNew comps

  -- make EntryCompletion and set model and column
  ; ec <- entryCompletionNew
  ; set ec [entryCompletionModel := Just model]
  ; customStoreSetColumn model (makeColumnIdString 0) id
  ; entryCompletionSetTextColumn ec (makeColumnIdString 0)

  -- attach EntryCompletion to Entry
  ; entrySetCompletion entry ec
  ; return ()
  }

-- | Set actions for Tab and Escape
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" ->
              -- complete the entry as far as possible
              liftIO $
              entryGetCompletion entry >>=
              entryCompletionInsertPrefix
          _ -> stopEvent
      }          

-- | For debugging (frame context menu command)
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 -- ?? possibly different
        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

-- | For debugging (frame context menu command)
dumpGraph :: VPUI -> WinId -> IO ()
dumpGraph vpui = print . vcGraph . vpuiWindowGetCanvas . vpuiGetWindow vpui

-- | For debugging the window's widget children
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))
  }

-- | Clear frame indicated by mouse location
clearFrame :: WinId -> CanvFrame -> VPUI -> IO VPUI
clearFrame winId frame vpui =
    let clear canvas = vcClearFrame canvas frame
    in vpuiModCanvasIO vpui winId clear

-- | Close frame (context menu command)
closeFrame :: VPUI -> WinId -> CanvFrame -> IO VPUI
closeFrame vpui winId frame =
    let close canvas = vcCloseFrame canvas frame
    in vpuiModCanvasIO vpui winId close