Callback.hs

module Sifflet.UI.Callback
    (
     CBMgr, CBMgrCmd(..), mkCBMgr
    , MenuSpec(..), MenuItemSpec(..), MenuItemAction
    , createMenuBar, addMenu, createMenu, createMenuItem
    , modifyIORefIO
    ) 

where

import Data.IORef

import Graphics.UI.Gtk

import Sifflet.UI.Types

-- | The CBMgr (Callback manager) encapsulates (in an enclosure, no less!)
-- an IORef VPUI.  It is used *solely* to set up callbacks
-- and similar stuff in Gtk, where the callback needs access
-- to the IORef.  By passing a CBMgr to a function, we can
-- avoid passing the IORef directly, and all the harm and
-- confusion that could result.
--
-- We only need *one* CBMgr for the application;
-- however, two CBMgrs with the same IORef are logically equivalent,
-- so there would be no harm in having two as long as they share one IORef.
type CBMgr = CBMgrCmd -> IO ()

-- | Commands for the CBMgr
data CBMgrCmd
 =  -- window events
    OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)
  | OnWindowDestroy Window (IORef VPUI -> IO ())
  | OnWindowKeyPress Window (IORef VPUI -> EventM EKey Bool)
    -- layout events
  | OnLayoutExpose Layout (IORef VPUI -> EventM EExpose Bool)
  | OnLayoutMouseMove Layout (IORef VPUI -> EventM EMotion Bool)
  | OnLayoutButtonPress Layout (IORef VPUI -> EventM EButton Bool)
  | OnLayoutButtonRelease Layout (IORef VPUI -> EventM EButton Bool)
    -- other events
  | OnMenuItemActivateLeaf MenuItem (VPUI -> IO VPUI)
  | OnEntryActivate Entry (IORef VPUI -> IO ())
  | AfterButtonClicked Button (IORef VPUI -> IO ())

  | UMTest

-- | Create the CBMgr
mkCBMgr :: IORef VPUI -> CBMgr
mkCBMgr uiref cmd = 
    case cmd of
      -- window events
      OnWindowConfigure window action ->
          on window configureEvent (action uiref) >> return ()
      OnWindowDestroy window action ->
          onDestroy window (action uiref) >> return ()
      OnWindowKeyPress window action ->
          on window keyPressEvent (action uiref) >> return ()
      -- layout events
      OnLayoutExpose layout action ->
          on layout exposeEvent (action uiref) >> return ()
      OnLayoutMouseMove layout action ->
          on layout motionNotifyEvent (action uiref) >> return ()
      OnLayoutButtonPress layout action ->
          on layout buttonPressEvent (action uiref) >> return ()
      OnLayoutButtonRelease layout action ->
          on layout buttonReleaseEvent (action uiref) >> return ()
      -- other events
      OnMenuItemActivateLeaf menuItem action ->
          onActivateLeaf menuItem (modifyIORefIO uiref action) >> return ()
      OnEntryActivate entry action ->
         onEntryActivate entry (action uiref) >> return ()
      AfterButtonClicked button action ->
          afterClicked button (action uiref) >> return ()

      UMTest -> 
          putStrLn "UMTest"


-- ============================================================
-- MENUS

-- Easy creation of menus from lists.
-- Originally from ~/src/haskell-etudes/gtk2hs/gMenu.hs

data MenuSpec = MenuSpec String [MenuItemSpec]
data MenuItemSpec = MenuItem String MenuItemAction
                  | SubMenu MenuSpec

type MenuItemAction = VPUI -> IO VPUI -- was just IO ()

createMenuBar :: [MenuSpec] -> CBMgr -> IO MenuBar
createMenuBar menuSpecs cbmgr = do
  bar <- menuBarNew
  mapM_ (addMenu bar cbmgr) menuSpecs
  return bar

addMenu :: MenuBar -> CBMgr -> MenuSpec -> IO ()
addMenu mbar cbmgr mspec@(MenuSpec name _itemSpecs) = do
  menuHead <- menuItemNewWithLabel name -- visible "item" at top of the menu
  menuShellAppend mbar menuHead
  -- Right-justify help menu.
  -- Deprecated (bad for right-to-left languages),
  -- but retained for compatibility with menus_hard.py.
  menuItemSetRightJustified menuHead (name == "Help") -- ??????

  -- menu = the container for menu items
  menu <- createMenu mspec cbmgr
  menuItemSetSubmenu menuHead menu

createMenu :: MenuSpec -> CBMgr -> IO Menu
createMenu (MenuSpec _name itemSpecs) cbmgr = do
  menu <- menuNew
  mapM_ (createMenuItem menu cbmgr) itemSpecs
  return menu

createMenuItem :: Menu -> CBMgr -> MenuItemSpec -> IO ()
createMenuItem menu cbmgr mispec = 
    case mispec of
      MenuItem label action ->
          do
            {
              item <- menuItemNewWithLabel label
            ; cbmgr (OnMenuItemActivateLeaf item action)
              -- may need to read/write IORef here ***
            ; menuShellAppend menu item
            }
      SubMenu subspec@(MenuSpec label _itemSpecs) ->
          do
            {
              item <- menuItemNewWithLabel label
            ; submenu <- createMenu subspec cbmgr 
            ; menuItemSetSubmenu item submenu
            ; menuShellAppend menu item
            }

-- | Read an IORef, update with IO, and write the updated value.
-- This is like modifyIORef, but the type of the second argument is (a -> IO a)
-- instead of (a -> a).
modifyIORefIO :: IORef a -> (a -> IO a) -> IO ()
modifyIORefIO ref updateIO = readIORef ref >>= updateIO >>= writeIORef ref