module Graphics.UI.Sifflet.Tool
    (
      ToolId(..)
    , checkMods
    , functionArgToolSpecs
    , functionTool
    , functionToolsFromLists
    , makeConnectTool
    , makeCopyTool
    , makeDeleteTool
    , makeDisconnectTool
    , 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 (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          -- ^ function name
 | ToolLiteral Expr
 | ToolArg String Int            -- ^ argument name, no. of inputs
   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)
          
-- 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 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}
                           }
                       _ ->     -- 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

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

-- | 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 -> 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
    
-- | 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
                  parseLiteral      -- 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

-- *** Consider merging this with the other "light dialog"
-- in EditArgsPanel.hs

-- 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
               {
               ; root <- eventBoxNew     -- needed for Label visibility
               ; frame <- frameNew
               ; frameSetLabel frame prompt
               ; entry <- entryNew
               ; case mcompletions of
                   Nothing -> return ()
                   Just comps -> addEntryCompletions entry comps

               -- Organize as (eventbox (frame (entry)))
               ; containerAdd frame entry
               ; containerAdd root frame
               ; layoutPut layout root (round xx) (round yy)
               ; widgetShowAll root

               -- 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 root entry)
               ; uimgr (OnEntryActivate entry
                        (entryActivated root 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 v -> 
          grabRemove entry >>
          widgetDestroy container >>
          readIORef uiref >>= 
          vpuiSetTool (toolType v) 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 :: ColumnId a String)

  -- 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 glibToString 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 = 
    printWGraph . 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 :: 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))
  }

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