Callback.hs

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

where

import Data.IORef

import Graphics.UI.Gtk

import Graphics.UI.Sifflet.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 ()

type CBMgrAction = IORef VPUI -> IO ()

-- | Commands for the CBMgr
data CBMgrCmd
 =  -- window events
    OnWindowConfigure Window (IORef VPUI -> EventM EConfigure Bool)
  | OnWindowDestroy Window CBMgrAction
  | AfterWindowKeyPress 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 CBMgrAction
  | AfterButtonClicked Button CBMgrAction

    -- Surrender the UIRef to an arbitrary action
  | WithUIRef CBMgrAction 

  | 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 ()
      AfterWindowKeyPress window action ->
          after 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 action uiref) >> return ()
      OnEntryActivate entry action ->
         onEntryActivate entry (action uiref) >> return ()
      AfterButtonClicked button action ->
          afterClicked button (action uiref) >> return ()

      -- Not an event at all; the fact that I need this means the
      -- CBMgr concept was misguided!
      WithUIRef action -> action uiref

      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 (flip modifyIORef), but the type of the 
-- first argument is (a -> IO a) instead of (a -> a).
-- Note that if a = VPUI, then updateIO :: VPUI -> IO VPUI
-- and consequently modifyIORefIO updateIO :: CBMgrAction.

modifyIORefIO :: (a -> IO a) -> IORef a -> IO ()
modifyIORefIO updateIO ref = readIORef ref >>= updateIO >>= writeIORef ref