{- 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 LittleGtk

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 =
  return VPUI {vpuiWindows = Map.empty,
               vpuiToolkits = Map.empty,
               vpuiFilePath = Nothing,
               vpuiStyle = style,
               vpuiInitialEnv = env,
               vpuiGlobalEnv = env,
               vpuiFileEnv = 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 funcFrame = fedFuncFrame style func 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 -> Env -> CanvFrame
fedFuncFrame style func prevEnv = 
  let (frame, _) =
          frameNewWithLayout style (Position 0 0) 0 
                             (FunctoidFunc func) Nothing
                             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 :: 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
}


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) 
                                          Nothing 
                                          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 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