    {-# OPTIONS_GHC -fno-cse #-}

    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.UI.GLUT.Menu
    -- Copyright   :  (c) Sven Panne 2002-2005
    -- License     :  BSD-style (see the file libraries/GLUT/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- Stability   :  stable
    -- Portability :  portable
    --
    -- GLUT supports simple cascading pop-up menus. They are designed to let a user
    -- select various modes within a program. The functionality is simple and
    -- minimalistic and is meant to be that way. Do not mistake GLUT\'s pop-up menu
    -- facility with an attempt to create a full-featured user interface.
    --
    --------------------------------------------------------------------------------

    module Graphics.UI.GLUT.Menu (
       Menu(..), MenuItem(..), MenuCallback, attachMenu,
       numMenuItems
    ) where

    import Data.Array ( listArray, (!) )
    import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
    import qualified Data.Map as Map ( empty, lookup, insert, delete )
    import Data.Map ( Map )
    import Foreign.C.String ( CString, withCString )
    import Foreign.C.Types ( CInt )
    import Foreign.Ptr ( FunPtr, freeHaskellFunPtr )
    import Control.Monad ( unless, zipWithM, when )
    import System.IO.Unsafe ( unsafePerformIO )
    import Graphics.Rendering.OpenGL.GL.StateVar (
       HasGetter(get), HasSetter(($=)),
       GettableStateVar, makeGettableStateVar,
       StateVar, makeStateVar )
    import Graphics.UI.GLUT.Constants ( glut_MENU_NUM_ITEMS )
    import Graphics.UI.GLUT.QueryUtils ( simpleGet )
    import Graphics.UI.GLUT.Types ( marshalMouseButton )
    import Graphics.UI.GLUT.Window ( Window )
    import Graphics.UI.GLUT.Callbacks.Registration ( getCurrentWindow )
    import Graphics.UI.GLUT.Callbacks.Window ( MouseButton )

    --------------------------------------------------------------------------------

    -- | A menu is simply a list of menu items.
    newtype Menu = Menu [MenuItem]

    -- | A single item within a menu can either be a plain menu entry or a sub-menu
    -- entry, allowing for arbitrarily deep nested menus.
    data MenuItem
       = MenuEntry String MenuCallback -- ^ A plain menu entry with an associated
                                       --   callback, which is triggered when the
                                       --   user selects the entry
       | SubMenu   String Menu         -- ^ A sub-menu, which is cascaded when the
                                       --   user selects the entry, allowing
                                       --   sub-menu entries to be selected

    type MenuCallback = IO ()

    -- | Create a new pop-up menu for the /current window,/ attaching it to the
    -- given mouse button. A previously attached menu (if any), is detached before
    -- and won\'t receive callbacks anymore.
    --
    -- It is illegal to call 'attachMenu' while any (sub-)menu is in use, i.e.
    -- popped up.
    --
    -- /X Implementation Notes:/ If available, GLUT for X will take advantage of
    -- overlay planes for implementing pop-up menus. The use of overlay planes can
    -- eliminate display callbacks when pop-up menus are deactivated. The
    -- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals
    -- are available.

    attachMenu :: MouseButton -> Menu -> IO ()
    attachMenu mouseButton menu@(Menu items) = do
       win <- getCurrentWindow "attachMenu"
       let hook = MenuHook win mouseButton
       detachMenu hook
       unless (null items) $ do
          (_, destructor) <- traverseMenu menu
          addToMenuTable hook destructor
          attachMenu_ mouseButton

    detachMenu :: MenuHook -> IO ()
    detachMenu hook@(MenuHook _ mouseButton) = do
       maybeDestructor <- lookupInMenuTable hook
       case maybeDestructor of
          Nothing         -> return ()
          Just destructor -> do detachMenu_ mouseButton
                                destructor
       deleteFromMenuTable hook

    traverseMenu :: Menu -> IO (MenuID, Destructor)
    traverseMenu (Menu items) = do
       let callbackArray = listArray (1, length items) (map makeCallback items)
       cb <- makeMenuFunc (\i -> callbackArray ! (fromIntegral i))
       menuID <- glutCreateMenu cb
       destructors <- zipWithM addMenuItem items [1..]
       let destructor = do sequence_ destructors
                           glutDestroyMenu menuID
                           freeHaskellFunPtr cb
       return (menuID, destructor)

    makeCallback :: MenuItem -> MenuCallback
    makeCallback (MenuEntry _ cb) = cb
    makeCallback _ = error "shouldn't receive a callback for submenus"

    addMenuItem :: MenuItem -> Value -> IO Destructor
    addMenuItem (MenuEntry s _) v = do
       addMenuEntry s v
       return $ glutRemoveMenuItem 1
    addMenuItem (SubMenu s m) _ = do
       (menuID, destructor) <- saveExcursion (traverseMenu m)
       addSubMenu s menuID
       return $ do glutRemoveMenuItem 1
                   destructor

    -- Perform an action, saving/restoring the current menu around it
    saveExcursion :: IO a -> IO a
    saveExcursion act = do
       menuID <- get currentMenu
       returnValue <- act
       when (isRealMenu menuID) $
          currentMenu $= menuID
       return returnValue

    --------------------------------------------------------------------------------
    -- This seems to be a common Haskell hack nowadays: A plain old global variable
    -- with an associated mutator. Perhaps some language/library support is needed?

    {-# NOINLINE theMenuTable #-}
    theMenuTable :: IORef MenuTable
    theMenuTable = unsafePerformIO (newIORef emptyMenuTable)

    getMenuTable :: IO MenuTable
    getMenuTable = readIORef theMenuTable

    modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()
    modifyMenuTable = modifyIORef theMenuTable

    --------------------------------------------------------------------------------
    -- To facilitate cleanup, we have to keep track how to destroy menus which are
    -- currently attached in a window to a mouse button.

    data MenuHook = MenuHook Window MouseButton
       deriving ( Eq, Ord )

    type Destructor = IO ()

    type MenuTable = Map MenuHook Destructor

    emptyMenuTable :: MenuTable
    emptyMenuTable = Map.empty

    lookupInMenuTable :: MenuHook -> IO (Maybe Destructor)
    lookupInMenuTable callbackID =
       fmap (Map.lookup callbackID) getMenuTable

    deleteFromMenuTable :: MenuHook -> IO ()
    deleteFromMenuTable callbackID =
       modifyMenuTable (Map.delete callbackID)

    addToMenuTable :: MenuHook -> Destructor -> IO ()
    addToMenuTable callbackID funPtr =
       modifyMenuTable (Map.insert callbackID funPtr)

    --------------------------------------------------------------------------------

    type MenuID = CInt
    type Value  = CInt
    type Item   = CInt

    --------------------------------------------------------------------------------

    -- | The type of a menu callback action that is called when a menu entry from a
    -- menu is selected. The value passed to the callback is determined by the value
    -- for the selected menu entry.

    type MenuCB = CInt -> IO ()

    -- | Create a new pop-up menu and return a unique identifier for it, which can
    -- be used when setting 'currentMenu'. Implicitly, the /current menu/ is set to
    -- the newly created menu.
    --
    -- When the menu callback is called because a menu entry is selected for the
    -- menu, the /current menu/ will be implicitly set to the menu with the selected
    -- entry before the callback is made.
    --
    -- /X Implementation Notes:/ If available, GLUT for X will take advantage of
    -- overlay planes for implementing pop-up menus. The use of overlay planes can
    -- eliminate display callbacks when pop-up menus are deactivated. The
    -- @SERVER_OVERLAY_VISUALS@ convention is used to determine if overlay visuals
    -- are available.

    foreign import CALLCONV unsafe "glutCreateMenu" glutCreateMenu ::
       FunPtr MenuCB -> IO MenuID

    foreign import ccall "wrapper" makeMenuFunc :: MenuCB -> IO (FunPtr MenuCB)

    -- | Destroy the specified menu. If it was the /current menu/, the /current
    -- menu/ becomes invalid and 'currentMenu' will contain 'Nothing'.

    foreign import CALLCONV unsafe "glutDestroyMenu" glutDestroyMenu ::
       MenuID -> IO ()

    --------------------------------------------------------------------------------

    -- | Controls the /current menu./ If no menus exist or the previous /current
    -- menu/ was destroyed, a pseudo menu is returned, see 'isRealMenu'.

    currentMenu :: StateVar MenuID
    currentMenu = makeStateVar glutGetMenu glutSetMenu

    foreign import CALLCONV unsafe "glutSetMenu" glutSetMenu :: MenuID -> IO ()

    foreign import CALLCONV unsafe "glutGetMenu" glutGetMenu :: IO MenuID

    -- | Returns 'True' if the given menu identifier refers to a real menu, not
    -- a pseudo one.

    isRealMenu :: MenuID -> Bool
    isRealMenu = (/= 0)

    --------------------------------------------------------------------------------

    -- | Add a menu entry to the bottom of the /current menu./ The given string will
    -- be displayed for the newly added menu entry. If the menu entry is selected by
    -- the user, the menu\'s callback will be called passing the given value as the
    -- callback\'s parameter.

    addMenuEntry :: String -> Value -> IO ()
    addMenuEntry name value = withCString name $ \n -> glutAddMenuEntry n value

    foreign import CALLCONV unsafe "glutAddMenuEntry" glutAddMenuEntry ::
       CString -> Value -> IO ()

    -- | Add a sub-menu trigger to the bottom of the /current menu./ The given
    -- string will be displayed for the newly added sub-menu trigger. If the
    -- sub-menu trigger is entered, the sub-menu specified by the given menu
    -- identifier will be cascaded, allowing sub-menu menu items to be selected.

    addSubMenu :: String -> MenuID -> IO ()
    addSubMenu name menuID = withCString name $ \n -> glutAddSubMenu n menuID

    foreign import CALLCONV unsafe "glutAddSubMenu" glutAddSubMenu ::
       CString -> MenuID -> IO ()

    --------------------------------------------------------------------------------

    {- UNUSED
    -- | Change the specified menu entry in the /current menu/ into a menu entry.
    -- The given position determines which menu item should be changed and must be
    -- between 1 (the topmost menu item) and
    -- 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The menu item to change
    -- does not have to be a menu entry already. The given string will be displayed
    -- for the newly changed menu entry. The given value will be returned to the
    -- menu\'s callback if this menu entry is selected.

    foreign import CALLCONV unsafe "glutChangeToMenuEntry" glutChangeToMenuEntry ::
       Item -> CString -> Value -> IO ()

    -- | Change the specified menu item in the /current menu/ into a sub-menu
    -- trigger. The  given position determines which menu item should be changed and
    -- must be between 1 and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. The
    -- menu item to change does not have to be a sub-menu trigger already. The
    -- given name will be displayed for the newly changed sub-menu trigger. The
    -- given menu identifier names the sub-menu to cascade from the newly added
    -- sub-menu trigger.

    foreign import CALLCONV unsafe "glutChangeToSubMenu" glutChangeToSubMenu ::
       Item -> CString -> MenuID -> IO ()
    -}

    --------------------------------------------------------------------------------

    -- | Remove the menu item at the given position, regardless of whether it is a
    -- menu entry or sub-menu trigger. The position must be between 1 (the topmost
    -- menu item) and 'Graphics.UI.GLUT.State.getNumMenuItems' inclusive. Menu items
    -- below the removed menu item are renumbered.

    foreign import CALLCONV unsafe "glutRemoveMenuItem" glutRemoveMenuItem ::
       Item -> IO ()

    --------------------------------------------------------------------------------

    -- | Attach a mouse button for the /current window/ to the identifier of the
    -- /current menu./ By attaching a menu identifier to a button, the named menu
    -- will be popped up when the user presses the specified button. Note that the
    -- menu is attached to the button by identifier, not by reference.

    attachMenu_ :: MouseButton -> IO ()
    attachMenu_ = glutAttachMenu . marshalMouseButton

    foreign import CALLCONV unsafe "glutAttachMenu" glutAttachMenu :: CInt -> IO ()

    -- | Detach an attached mouse button from the /current window./

    detachMenu_ :: MouseButton -> IO ()
    detachMenu_ = glutDetachMenu . marshalMouseButton

    foreign import CALLCONV unsafe "glutDetachMenu" glutDetachMenu :: CInt -> IO ()

    --------------------------------------------------------------------------------

    -- | Contains the number of menu items in the /current menu./

    numMenuItems :: GettableStateVar Int
    numMenuItems = makeGettableStateVar $ simpleGet fromIntegral glut_MENU_NUM_ITEMS