sifflet-0.1.5: Workspace/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 Workspace.Workspace
    (
     -- VPUI and Workspace
     vpuiNew
    , defaultVPUIToolkits
    , Workspace(..), workspaceNewDefault, workspaceNewEditing
    , addArgToolButtons
    , addApplyCloseButtons
    , defineFunction
    , openNode

     -- Quitting:
    , removeWindow
    , vpuiQuit

     -- Windows:
    , forallWindowsIO
    )

where

import Control.Monad

import Data.Map (Map, (!), fromList, keys)
import qualified Data.Map as Map (empty)

import Data.Graph.Inductive as G
import Graphics.UI.Gtk as Gtk
    hiding (Frame, Function, Style, Size, buttonPressed, fill, lineWidth,
            disconnect, function, remove)

import CBMgr
import Examples
import Expr
import Geometry
import GtkUtil
import TreeGraph
import TreeLayout
import UITypes
import Util
import Workspace.Canvas
import Workspace.Frame
import Workspace.Functoid
import Workspace.Tools
import Workspace.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 = do
  group <- radioToolButtonNew
  return VPUI {vpuiWindows = Map.empty, 
               vpuiToolkits = Map.empty,
               vpuiButtonGroup = group,
               vpuiFilePath = Nothing,
               vpuiFileChanged = False,
               vpuiStyle = style,
               vpuiInitialEnv = env,
               vpuiGlobalEnv = env
              }

baseFunctionsRows :: [[String]]
baseFunctionsRows = [["+", "-", "*", "div", "mod", "add1", "sub1", "/"],
                     ["==", "/=", "<", ">", "<=", ">="],
                     ["zero?", "positive?", "negative?"],
                     ["null", "head", "tail", ":"]]

defaultVPUIToolkits :: Map String VPToolkit
defaultVPUIToolkits =
    let toolkits =
            -- each item has name, width, list of rows tools
            [VPToolkit "Base" 500 (functionToolsFromLists baseFunctionsRows),
             VPToolkit "Examples" 500 
                           (functionToolsFromLists [exampleFunctionNames]),
             VPToolkit "My Functions" 500 (functionToolsFromLists [[]])]
    in fromList (zip (map toolkitName toolkits) toolkits)


-- | 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 argValues = []
        funcFrame = fedFuncFrame style func argValues 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 -> [Value] -> Env -> CanvFrame
fedFuncFrame style func values prevEnv = 
  let (frame, _) =
          frameNewWithLayout style (Position 0 0) 0 
                             (FunctoidFunc func) values 
                             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 :: Gtk.Layout -> 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 :: Gtk.Layout -> IO Gtk.Layout
        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) [] 
                                          EditFrame
                                          env' x y z Nothing
                           ; let vw' = vpuiWindowSetCanvas vw canv''
                                 vpui'' = vpuiReplaceWindow vpui' winId vw'
                           ; vpuiUpdateCallFrames vpui'' fname
                           }

-- | 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 = 
    let winId = "Sifflet Workspace" 
    in case vpuiTryGetWindow vpui winId 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 winId 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 [] 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) values CallFrame
                                  env x y z (Just node)
                       EvalOk x ->
                           error $ "openNode: non-VList result: " ++ show x
                       _ -> 
                           info "Cannot be opened: lacking input values" >>
                           return vw