EditArgsPanel.hs

-- | A "panel" to be shown on the Function Editor, for adjusting the
-- arguments of the function being edited -- adding and deleting arguments,
-- or modifying their "kind" (number of inlets, needed for higher order
-- functions)

module Graphics.UI.Sifflet.EditArgsPanel
    (
     ArgSpecAction
    , EditArgsPanel
    , makeEditArgsPanel
    , editArgsPanelRoot
    , expandToFit
    )

where

import Data.IORef

import Graphics.UI.Gtk (EventBox, hButtonBoxNew, 
                        containerRemove,
                        ButtonBoxClass, buttonActivated,
                        widgetGetParent,
                        widgetQueueResize)

import Language.Sifflet.Expr
import Graphics.UI.Sifflet.Callback
import Graphics.UI.Sifflet.LittleGtk
import Language.Sifflet.Util (SuccFail(..), parseInt)

type ArgSpecAction = [ArgSpec] -> IO ()

type PanelRoot = EventBox

data EditArgsPanel = 
    EditArgsPanel {editArgsPanelRoot :: PanelRoot,
                   editArgsPanelAction :: ArgSpecAction}

type StateRef = IORef State

data State = State Model UI

newtype Model = Model [ArgSpec]
           deriving (Show)

data UI = UI PanelRoot Table Label [ArgRow]

data ArgRow = ArgRow Entry Entry Button


-- | Create an EditArgsPanel
-- It currently returns a EditArgsPanel object, 
-- and you can put the root of it into a container, e.g.,
--     set window [containerChild := editArgsPanelRoot panel]

-- I think it needs to return some more information than this, though,
-- and maybe know about its parent or larger context, so that when
-- applied, it can have a "global" effect.
-- Maybe just in the form of IO () actions, though.
-- 
-- It has this structure (for n existing arguments):

-- EventBox ( = editArgsPanelRoot panel)
-- +----------------------------------+
-- | Frame                            |
-- | +------------------------------+ |
-- | | VBox                         | |
-- | | +--------------------------+ | |
-- | | | Table (n+2 rows)x(3 cols)| | |
-- | | | +----------------------+ | | |
-- | | | |                      | | | |
-- | | | | (arguments)          | | | |
-- | | | +----------------------+ | | |
-- | | |                          | | |
-- | | | HButtonBox               | | |
-- | | | +----------------------+ | | |
-- | | | | (buttons)            | | | |
-- | | | +----------------------+ | | |
-- | | |                          | | |
-- | | | Label                    | | |
-- | | | +----------------------+ | | |
-- | | | | (status messages)    | | | |
-- | | | +----------------------+ | | |
-- | | +--------------------------+ | |
-- | +------------------------------+ |
-- +----------------------------------+

makeEditArgsPanel :: CBMgr -> [ArgSpec] -> ArgSpecAction
                  -> IO EditArgsPanel
makeEditArgsPanel cbMgr argSpecs okayAction = do
  root <- eventBoxNew         -- needed for everything to be visible!
  frame <- frameNew
  frameSetLabel frame "Edit Arguments"

  let panel = EditArgsPanel {editArgsPanelRoot = root,
                             editArgsPanelAction = okayAction}

  vbox <- vBoxNew False 5 -- non-homogeneous sizes,  5 pixels separation

  -- Create a table of n + 2 rows x 3 cols, non-homogeneous sizes
  table <- tableNew (length argSpecs + 2) 3 False 
  status <- labelNew (Just "")

  stateRef <- newIORef (State (Model argSpecs) (UI root table status []))
  dressTable stateRef

  btnBox <- hButtonBoxNew
  fillButtonBox cbMgr btnBox stateRef panel

  containerAdd root frame
  containerAdd frame vbox
  boxPackStartDefaults vbox table
  boxPackStartDefaults vbox btnBox
  boxPackStartDefaults vbox status

  widgetShowAll root
  return panel

-- | Fill the table with rows for each argument in the model and more

dressTable :: StateRef -> IO ()
dressTable sref = do
  -- read state
  State (Model args) ui@(UI root table status _rows) <- readIORef sref

  -- add "headings"
  argLabel <- labelNew (Just "Name")
  inputsLabel <- labelNew (Just "Inlets")
  tableAttachCell table argLabel 0 0
  tableAttachCell table inputsLabel 0 1

-- add rows for existing and new arguments
  let n = length args
  argRows <- mapM (uncurry (argRowNew sref)) 
                  (zip (args ++ [ArgSpec "" 0]) [0 .. n])
  mapM_ (uncurry (attachRow table)) 
        (zip argRows [1 .. n + 1])
  setStatusOK ui
  widgetShowAll table

  -- write state
  writeIORef sref (State (Model args) (UI root table status argRows))


-- | Resize a widget to be at least as big as a(nother) widget.
-- Normally the widget being resized is one that contains the other.

expandToFit :: (WidgetClass v, WidgetClass w) => v -> w -> IO ()
expandToFit container widget = do
  Requisition w1 h1 <- widgetSizeRequest container
  Requisition w2 h2 <- widgetSizeRequest widget
  let (w, h) = (max w1 w2, max h1 h2)
  widgetSetSizeRequest container w h
  widgetQueueResize container

-- | Remove from table and destroy all arg rows
-- (does not alter model)

stripTable :: StateRef -> IO ()
stripTable sref = do
  State model ui@(UI root table status _rows) <- readIORef sref
  let stripWidget widget = 
          do
            containerRemove table widget
            widgetDestroy widget

  widgets <- containerGetChildren table
  mapM_ stripWidget widgets
  -- Why is this /not/ equivalent to above two statements?
  --   liftM (mapM_ stripWidget) (containerGetChildren table)
  setStatusOK ui

  writeIORef sref (State model (UI root table status []))

attachRow :: Table -> ArgRow -> Int -> IO ()
attachRow table (ArgRow nameEntry nEntry btn) nrow = do
  tableAttachCell table nameEntry nrow 0
  tableAttachCell table nEntry nrow 1
  tableAttachCell table btn nrow 2

-- | Attach a widget to a table in a single cell, specified by its
-- row column (top lef = 0 0) coordinates

tableAttachCell :: (WidgetClass w) => Table -> w -> Int -> Int -> IO ()
tableAttachCell t w top left = 
    tableAttachDefaults t w left (left + 1) top (top + 1)


fillButtonBox :: (ButtonBoxClass b) => 
                 CBMgr -> b -> StateRef -> EditArgsPanel -> IO ()
fillButtonBox cbMgr btnBox sref panel = 
    let addButton (label, action) = do
          b <- buttonNewWithLabel label
          containerAdd btnBox b
          --   on b buttonActivated action
          cbMgr (AfterButtonClicked b action)                   
        addButton' label action = do
          b <- buttonNewWithLabel label
          containerAdd btnBox b
          _ <- on b buttonActivated action
          return ()

        applyAction :: IO ()
        applyAction = applyArgRows sref (editArgsPanelAction panel)

        okayAction = 
            applyAction >> closePanel panel

    in do
      -- addButton' "OK" (cbMgr (WithUIRef okayAction))
      addButton' "OK" okayAction
      mapM_ addButton [
                       -- ("Strip", \ _ -> stripTable sref),
                       -- ("Dress", \ _ -> dressTable sref),
                       ("Cancel", \ _ -> closePanel panel)]

-- | Close (destroy) the panel.
-- I hope this also removes it from its parent.

closePanel :: EditArgsPanel -> IO ()
closePanel panel = widgetDestroy (editArgsPanelRoot panel)

-- | Create a new ArgRow
argRowNew :: StateRef -> ArgSpec -> Int -> IO ArgRow
argRowNew sref (ArgSpec name inlets) n = do
  e1 <- makeEntry name
  e2 <- makeEntry (show inlets)
  -- Create and set up button
  let (label, action) = 
          case name of
            "" -> ("Add", addArg sref n)
            _ -> ("Remove", removeArg sref n)
  b <- buttonNewWithLabel label
  _ <- on b buttonActivated action
  return (ArgRow e1 e2 b)

-- | Add a new argument, nth in the model, from the (n+1)th row in the table

-- Still to do: make sure the name is non-blank, and doesn't duplicate
-- an existing argument (or global variable??)
-- and is a valid symbol name (not a number, etc.)?

addArg :: StateRef -> Int -> IO ()
addArg sref n = do
  State (Model argSpecs) ui@(UI root _table _status argRows) <- readIORef sref
  readResult <- readArgRow (argRows !! n)

  case readResult of

    Succ argTool -> 
        do
          writeIORef sref (State (Model (argSpecs ++ [argTool])) ui)
          stripTable sref
          dressTable sref
          -- Make sure the container (layout) is big enough 
          -- to show the enlarged panel
          mparent <- widgetGetParent root
          case mparent of
            Nothing -> return ()       -- shouldn't happen
            Just parent -> expandToFit parent root
          setStatusOK ui

    Fail msg -> setStatus ui $ "Add: " ++ msg

readArgRow :: ArgRow -> IO (SuccFail ArgSpec)
readArgRow (ArgRow e1 e2 _) = do
  name <- entryGetText e1
  case name of
    "" -> return $ Fail "blank name is not allowed"
    _ -> do
      inletsStr <- entryGetText e2
      return $ case parseInt ("Inlets for " ++ name) inletsStr of
                 Succ inlets -> Succ (ArgSpec name inlets)
                 Fail msg -> Fail msg

-- | Remove an argument, nth in the model, (n+1)th row in the table
removeArg :: StateRef -> Int -> IO ()
removeArg sref n = do
  State (Model argSpecs) ui <- readIORef sref
  writeIORef sref (State (Model (listRemove argSpecs n)) ui)
  stripTable sref
  dressTable sref
  setStatusOK ui

-- | Remove the nth element of a list (0 is the head)
listRemove :: [a] -> Int -> [a]
listRemove [] _ = error "listRemove: empty"
listRemove (_:xs) 0 = xs
listRemove (x:xs) n = x : (listRemove xs (n - 1))

makeEntry :: String -> IO Entry
makeEntry text = do
  entry <- entryNew
  entrySetText entry text
  return entry

applyArgRows :: StateRef -> ArgSpecAction -> IO ()
applyArgRows sref action = do
  State _model ui@(UI _root _table _status argRows) <- readIORef sref
  readResult <- readArgRows argRows
  case readResult of
    Succ newSpecs -> 
        do
          setStatusOK ui
          writeIORef sref (State (Model newSpecs) ui)
          action newSpecs
    Fail msg ->
        setStatus ui ("Apply: " ++ msg) >> 
        return ()


-- Use a monad transformer or "lift" here???

readArgRows :: [ArgRow] -> IO (SuccFail [ArgSpec])
readArgRows [] = return (Succ []) -- shouldn't happen!
readArgRows (_:[]) = return (Succ []) -- last row is for the "add" button
readArgRows (row:rows) = do
  results <- readArgRows rows
  case results of
    Fail msg -> return $ Fail msg
    Succ specs -> 
        do
          result <- readArgRow row
          case result of
            Fail msg -> return $ Fail msg
            Succ spec -> return $ Succ (spec:specs)
   
setStatusOK :: UI -> IO ()
setStatusOK ui = setStatus ui ""
           
setStatus :: UI -> String -> IO ()
setStatus (UI _ _ status _) msg = 
    labelSetText status msg