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 Graphics.UI.Sifflet.Workspace
    (
     -- VPUI and Workspace
     vpuiNew
    , workspaceNewDefault
    , workspaceNewEditing
    , addFedWinButtons
    , defineFunction
    , workspaceId
    , openNode

     -- Quitting:
    , removeWindow
    , vpuiQuit

     -- Windows:
    , forallWindowsIO

    , baseFunctionsRows
    )

where

-- for debugging
-- import System.IO.Unsafe

import Control.Monad
import System.Directory (getCurrentDirectory)

import Data.IORef
import Data.List
import Data.Map ((!), keys)
import qualified Data.Map as Map (empty)
import Data.Maybe

import Data.Graph.Inductive as G hiding (nfilter)

import Data.Sifflet.Functoid
import Data.Sifflet.Geometry
import Data.Sifflet.TreeGraph
import Data.Sifflet.TreeLayout
import Data.Sifflet.WGraph

import Language.Sifflet.Expr
import Language.Sifflet.ExprTree

import Graphics.UI.Sifflet.Callback
import Graphics.UI.Sifflet.Canvas
import Graphics.UI.Sifflet.EditArgsPanel
import Graphics.UI.Sifflet.Frame
import Graphics.UI.Sifflet.GtkUtil

import Graphics.UI.Sifflet.LittleGtk
-- FIX!!
-- import Graphics.UI.Gtk (widgetSizeRequest, windowResize)

import Graphics.UI.Sifflet.Tool
import Graphics.UI.Sifflet.Types

import Language.Sifflet.Util

-- | 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 -> Bool -> IO VPUI
vpuiNew style env debugging = do
  dir <- getCurrentDirectory
  return VPUI {vpuiWindows = Map.empty,
               vpuiToolkits = [],
               vpuiCurrentFile = Nothing,
               vpuiInitialDir = dir,
               vpuiCurrentDir = dir,
               vpuiStyle = style,
               vpuiInitialEnv = env,
               vpuiGlobalEnv = env,
               vpuiFileEnv = env,
               vpuiDebugging = debugging
              }



-- | 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 funcFrame = fedFuncFrame style func initEnv -- throw-away
        Size fwidth fheight = bbSize (cfBox funcFrame)
        canvSize = Size (max fwidth 300) (max fheight 300)
        mViewSize = Nothing
        specs = functionArgToolSpecs func
        addNoMenu _ = return ()        
  ; workspaceNew style canvSize mViewSize specs addNoMenu
  }

-- Add the buttons for argument tools, apply, close, etc.,
-- to a function editor window

addFedWinButtons :: CBMgr -> WinId -> VPUI -> IO ()
addFedWinButtons cbmgr winId vpui =
    case vpuiGetWindow vpui winId of
      VPUIWorkWin ws window -> 
          let bbar = wsButtonBar ws
              argSpecs = wsArgToolSpecs ws
              applyFrame :: VPUI -> IO VPUI
              applyFrame vpui' = 
                  let frames = vcFrames 
                               (vpuiWindowGetCanvas 
                                (vpuiGetWindow vpui' winId))
                  in case frames of
                       [] -> info "applyFrame: no frame found on canvas" >>
                             return vpui'
                       _:_:_ -> info ("applyFrame: more than one frame " ++
                                      "found on canvas " ++
                                      show frames) >>
                                return vpui'
                       [frame] -> defineFunction winId frame vpui'

              editParametersOK :: ArgSpecAction
              editParametersOK newSpecs = 
                  cbmgr (WithUIRef (editParametersOK' newSpecs))
              editParametersOK' newSpecs uiref =
                  do
                      stripButtonBar
                      dressButtonBar newSpecs
                      vpui' <- readIORef uiref
                      -- Maybe it should update more than just one window
                      -- here, in view of issues 36 and 31
                      --           VVV
                      let vpui'' = vpuiUpdateWindow vpui' 
                                   winId 
                                   (updateEditWindowArgSpecs newSpecs)
                      -- Should it also resize (smaller)
                      -- since the panel is being removed?
                      writeIORef uiref vpui''
                      -- redrawing must be done AFTER writing the IORef above.
                      redrawCanvas uiref winId

              editParameters :: VPUI -> IO VPUI
              editParameters vpui' =
                  do
                    {
                      let argSpecs' = vpuiWindowArgSpecs vpui' winId
                    ; argPanel <- 
                        makeEditArgsPanel cbmgr argSpecs' editParametersOK
                      -- attach it to the Gtk Layout at top left
                    ; let canv = wsCanvas ws
                          layout = vcLayout canv
                          panelRoot = editArgsPanelRoot argPanel
                    ; layoutPut layout panelRoot 1 1

                    -- Make the layout big enough to see the whole panel
                    ; expandToFit layout panelRoot

                    ; return vpui'
                    }
              addButton :: String -> CBMgrAction -> IO ()
              addButton label action = do
                {
                  button <- buttonNewWithLabel label
                ; boxPackEnd bbar button PackNatural 3
                ; widgetShow button
                ; cbmgr (AfterButtonClicked button action)
                }

              dressButtonBar :: [ArgSpec] -> IO ()
              dressButtonBar argSpecs' = do
                {
                  mapM_ (addArgToolButton cbmgr winId bbar) argSpecs'
                ; addButton "Close" (\ _uiref -> widgetDestroy window)
                ; addButton "Parameters" (modifyIORefIO editParameters)
                ; addButton "Apply" (modifyIORefIO applyFrame)
                }                

              stripButtonBar :: IO ()
              stripButtonBar = do
                {
                  -- the buttons should be the only children
                  children <- containerGetChildren bbar
                ; mapM_ widgetDestroy children
                }

          in dressButtonBar argSpecs

      FunctionPadWindow _ _ -> return () -- should not happen

vpuiWindowArgSpecs :: VPUI -> WinId -> [ArgSpec]
vpuiWindowArgSpecs vpui winId =
    case vpuiGetWindow vpui winId of
      VPUIWorkWin ws _ -> wsArgToolSpecs ws
      FunctionPadWindow _ _ -> [] -- should not happen

-- | Update an Edit Function window after the "Inputs" dialog,
-- which might have given it some new ArgSpec's.
-- In the resulting VPUIWindow, no node inlets or inputs than 
-- its new arity.

updateEditWindowArgSpecs :: [ArgSpec] -> VPUIWindow -> VPUIWindow
updateEditWindowArgSpecs newSpecs vwin =
    case vwin of 
      VPUIWorkWin ws0 window ->
          let canv0 = wsCanvas ws0
              graph0 = vcGraph canv0
              argNames = map argName newSpecs
          in case vcFrames canv0 of
               [frame0] ->
                   let foid0 = cfFunctoid frame0
                       fnodes0 = fpNodes foid0 :: [G.Node]

                       -- Filter out symbol nodes of any removed arguments
                       validNames = 
                           "if" : (argNames ++ envSymbols (cfEnv frame0))
                       validNode' :: G.Node -> Bool
                       validNode' = validNode graph0 validNames

                       fnodes1 = filter validNode' fnodes0
                       foid1 = foid0 {fpNodes = fnodes1,
                                      fpArgs = argNames} -- redundant args here
                       frame1 = frame0 {cfVarNames = argNames, -- and here
                                        cfFunctoid = foid1}
                       graph1 = nfilter validNode' graph0

                       -- Eliminate excess inlets and edges 
                       -- due to reduced arity of functional arguments
                       style = vcStyle canv0
                       graph2 = wLimitOuts style newSpecs graph1
                       -- Frame node adopts orphaned nodes so they are
                       -- not invisible
                       orphans = filter (isWSimple . fromJust . lab graph2)
                                        (graphOrphans graph2)
                       graph3 = 
                           adoptChildren graph2 (cfFrameNode frame1) orphans

                       -- plug back into larger structures
                       canv1 = canv0 {vcGraph = graph3, vcFrames = [frame1]}
                       ws1 = ws0 {wsArgToolSpecs = newSpecs, wsCanvas = canv1}
                   in VPUIWorkWin ws1 window
               _ -> vwin -- shouldn't happen
      FunctionPadWindow _ _ -> vwin -- shouldn't happen


-- | Given a WGraph and a list of valid symbols, a node is valid
-- if it is an ExprNode ... labeled with one of the valid symbols
--
-- (This function is only used above, in updateEditWindowArgSpecs)
validNode :: WGraph -> [String] -> G.Node -> Bool
validNode g validNames n =
    case G.lab g n of
      Nothing -> False
      Just (WFrame _) -> True
      Just (WSimple loNode) ->
          let ENode nodeLabel _ = gnodeValue (nodeGNode loNode)
          in case nodeLabel of
            NSymbol (Symbol name) -> name `elem` validNames
            _ -> True


-- | Require a node to have <= n inlets in the node
-- and <= n successors in the graph, where
-- n is specified in a list of ArgSpec

wLimitOut :: Style -> [ArgSpec] -> WGraph -> Node -> WGraph
wLimitOut style specs g v =
    let ordered :: Adj WEdge -> Adj WEdge
        ordered = sortBy compareAdj
        compareAdj (WEdge i, _nodei) (WEdge j, _nodej) = compare i j
    in case match v g of
         (Nothing, _) -> g
         (Just (ins, _v, wnode, outs), g') -> 
             -- wnode is the graph-node's "label"
             case wnode of
               WFrame _ -> g
               WSimple lonode@(LayoutNode {nodeGNode = gnode}) ->
                   let ENode eLabel _ = gnodeValue gnode -- :: ExprNode
                   in case eLabel of
                        NSymbol (Symbol name) ->
                            case aspecsLookup name specs of
                              Nothing -> g
                              Just n -> 
                                  let (inlets, _) = 
                                          makeIolets style 
                                                     (gnodeNodeBB gnode)
                                                     (n, 1)
                                      gnode' = gnode {gnodeInlets = inlets}
                                      wnode' = 
                                          WSimple (lonode {nodeGNode = gnode'})
                                  in (ins, v, wnode', take n (ordered outs)) & 
                                     g'
                        _ -> g

-- | Like wLimitOut, but applies to a whole graph
wLimitOuts :: Style -> [ArgSpec] -> WGraph -> WGraph
wLimitOuts style specs g = foldl (wLimitOut style specs) g (nodes g)

-- | Redraw the entire canvas of a given window
redrawCanvas :: IORef VPUI -> WinId -> IO ()
redrawCanvas uiref winId = do
  {
    vpui <- readIORef uiref
  ; let mcanvas = vpuiTryGetWindow vpui winId >>= vpuiWindowLookupCanvas 
  ; case mcanvas of
      Nothing -> return ()
      Just canvas ->
          case vcFrames canvas of
            [] -> return ()
            frame:_ -> vcInvalidateBox canvas (cfBox frame)
  }

addArgToolButton :: CBMgr -> WinId -> HBox -> ArgSpec -> IO ()
addArgToolButton cbmgr winId buttonBox (ArgSpec label n) = do
  {
    button <- buttonNewWithLabel label
  ; boxPackStart buttonBox button PackNatural 3 -- spacing between buttons
  ; widgetShow button
  ; cbmgr (AfterButtonClicked button 
           (modifyIORefIO (vpuiSetTool (ToolArg label n) winId)))
  ; return ()
  }


-- | fedFuncFrame generates a throw-away frame for the sole purplse
-- of obtaining its measurements before initializing the canvas

fedFuncFrame :: Style -> Function -> Env -> CanvFrame
fedFuncFrame style func prevEnv = 
  fst (frameNewWithLayout style (Position 0 0) 0 
                          (FunctoidFunc func) Nothing
                          CallFrame -- mode may change below
                          0 prevEnv Nothing)

-- | 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 -> [ArgSpec]
             -> (VBox -> IO ()) 
             -> IO Workspace
workspaceNew style canvSize mViewSize argSpecs addMenuBar = do
  {
  ; let Size dcWidth dcHeight = canvSize -- Double, Double
        (icWidth, icHeight) = (round dcWidth, round dcHeight)

        scrolled :: GtkLayout -> 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 :: GtkLayout -> IO GtkLayout
        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 argSpecs)
}


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
                    friendlyTypeError msg =
                      "Sifflet cannot find any set of " ++
                      "data types that will make this function work.\n" ++
                      "Details from the type checker (may be obscure):\n" ++
                      msg
                in case functoidToFunction fparts graph frameNode env of
                     Fail errmsg -> 
                         showErrorMessage (friendlyTypeError 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) 
                                          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"

-- | 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 = 
    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'
        }

-- | 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 Nothing 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) 
                                  (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", ":"]]