{-# OPTIONS_GHC -fno-cse #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Menu
-- Copyright   :  (c) Sven Panne 2002-2018
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- 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 Control.Monad.IO.Class ( MonadIO(..) )
import Control.Monad ( when, unless, zipWithM )
import Data.Array ( listArray, (!) )
import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )
import qualified Data.Map as M
import Data.StateVar ( get, ($=), GettableStateVar, makeGettableStateVar
                     , StateVar, makeStateVar )
import Foreign.C.String ( withCString )
import Foreign.C.Types ( CInt )
import Foreign.Ptr ( freeHaskellFunPtr )
import System.IO.Unsafe ( unsafePerformIO )

import Graphics.UI.GLUT.Callbacks.Registration
import Graphics.UI.GLUT.QueryUtils
import Graphics.UI.GLUT.Raw
import Graphics.UI.GLUT.Types

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

-- | A menu is simply a list of menu items, possibly with an associated font.
data Menu
   = Menu [MenuItem]
   | MenuWithFont BitmapFont [MenuItem]

menuFont :: Menu -> Maybe BitmapFont
menuFont :: Menu -> Maybe BitmapFont
menuFont (Menu [MenuItem]
_) = Maybe BitmapFont
forall a. Maybe a
Nothing
menuFont (MenuWithFont BitmapFont
font [MenuItem]
_) = BitmapFont -> Maybe BitmapFont
forall a. a -> Maybe a
Just BitmapFont
font

menuItems :: Menu -> [MenuItem]
menuItems :: Menu -> [MenuItem]
menuItems (Menu [MenuItem]
items) = [MenuItem]
items
menuItems (MenuWithFont BitmapFont
_ [MenuItem]
items) = [MenuItem]
items

-- | 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 :: MonadIO m => MouseButton -> Menu -> m ()
attachMenu :: MouseButton -> Menu -> m ()
attachMenu MouseButton
mouseButton Menu
menu = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
   Window
win <- String -> IO Window
getCurrentWindow String
"attachMenu"
   let hook :: MenuHook
hook = Window -> MouseButton -> MenuHook
MenuHook Window
win MouseButton
mouseButton
   MenuHook -> IO ()
detachMenu MenuHook
hook
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([MenuItem] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Menu -> [MenuItem]
menuItems Menu
menu)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      (MenuID
_, IO ()
destructor) <- Menu -> IO (MenuID, IO ())
traverseMenu Menu
menu
      MenuHook -> IO () -> IO ()
addToMenuTable MenuHook
hook IO ()
destructor
      MouseButton -> IO ()
attachMenu_ MouseButton
mouseButton

detachMenu :: MenuHook -> IO ()
detachMenu :: MenuHook -> IO ()
detachMenu hook :: MenuHook
hook@(MenuHook Window
_ MouseButton
mouseButton) = do
   Maybe (IO ())
maybeDestructor <- MenuHook -> IO (Maybe (IO ()))
lookupInMenuTable MenuHook
hook
   case Maybe (IO ())
maybeDestructor of
      Maybe (IO ())
Nothing         -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just IO ()
destructor -> do MouseButton -> IO ()
detachMenu_ MouseButton
mouseButton
                            IO ()
destructor
   MenuHook -> IO ()
deleteFromMenuTable MenuHook
hook

traverseMenu :: Menu -> IO (MenuID, Destructor)
traverseMenu :: Menu -> IO (MenuID, IO ())
traverseMenu Menu
menu = do
   let items :: [MenuItem]
items = Menu -> [MenuItem]
menuItems Menu
menu
       callbackArray :: Array Int (IO ())
callbackArray = (Int, Int) -> [IO ()] -> Array Int (IO ())
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1, [MenuItem] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MenuItem]
items) ((MenuItem -> IO ()) -> [MenuItem] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map MenuItem -> IO ()
makeCallback [MenuItem]
items)
   FunPtr MenuFunc
cb <- MenuFunc -> IO (FunPtr MenuFunc)
makeMenuFunc (\MenuID
i -> Array Int (IO ())
callbackArray Array Int (IO ()) -> Int -> IO ()
forall i e. Ix i => Array i e -> i -> e
! (MenuID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral MenuID
i))
   MenuID
menuID <- FunPtr MenuFunc -> IO MenuID
forall (m :: * -> *). MonadIO m => FunPtr MenuFunc -> m MenuID
glutCreateMenu FunPtr MenuFunc
cb
   IO () -> (BitmapFont -> IO ()) -> Maybe BitmapFont -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (MenuID -> BitmapFont -> IO ()
setMenuFont MenuID
menuID) (Menu -> Maybe BitmapFont
menuFont Menu
menu)
   [IO ()]
destructors <- (MenuItem -> MenuID -> IO (IO ()))
-> [MenuItem] -> [MenuID] -> IO [IO ()]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM MenuItem -> MenuID -> IO (IO ())
addMenuItem [MenuItem]
items [MenuID
1..]
   let destructor :: IO ()
destructor = do [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
destructors
                       MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutDestroyMenu MenuID
menuID
                       FunPtr MenuFunc -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr MenuFunc
cb
   (MenuID, IO ()) -> IO (MenuID, IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (MenuID
menuID, IO ()
destructor)

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

addMenuItem :: MenuItem -> Value -> IO Destructor
addMenuItem :: MenuItem -> MenuID -> IO (IO ())
addMenuItem (MenuEntry String
s IO ()
_) MenuID
v = do
   String -> MenuFunc
addMenuEntry String
s MenuID
v
   IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutRemoveMenuItem MenuID
1
addMenuItem (SubMenu String
s Menu
m) MenuID
_ = do
   (MenuID
menuID, IO ()
destructor) <- IO (MenuID, IO ()) -> IO (MenuID, IO ())
forall a. IO a -> IO a
saveExcursion (Menu -> IO (MenuID, IO ())
traverseMenu Menu
m)
   String -> MenuFunc
addSubMenu String
s MenuID
menuID
   IO () -> IO (IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return (IO () -> IO (IO ())) -> IO () -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ do MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutRemoveMenuItem MenuID
1
               IO ()
destructor

-- Perform an action, saving/restoring the current menu around it
saveExcursion :: IO a -> IO a
saveExcursion :: IO a -> IO a
saveExcursion IO a
act = do
   MenuID
menuID <- StateVar MenuID -> IO MenuID
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar MenuID
currentMenu
   a
returnValue <- IO a
act
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MenuID -> Bool
isRealMenu MenuID
menuID) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      StateVar MenuID
currentMenu StateVar MenuID -> MenuFunc
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= MenuID
menuID
   a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
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 :: IORef MenuTable
theMenuTable = IO (IORef MenuTable) -> IORef MenuTable
forall a. IO a -> a
unsafePerformIO (MenuTable -> IO (IORef MenuTable)
forall a. a -> IO (IORef a)
newIORef MenuTable
emptyMenuTable)

getMenuTable :: IO MenuTable
getMenuTable :: IO MenuTable
getMenuTable = IORef MenuTable -> IO MenuTable
forall a. IORef a -> IO a
readIORef IORef MenuTable
theMenuTable

modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()
modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()
modifyMenuTable = IORef MenuTable -> (MenuTable -> MenuTable) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef MenuTable
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 ( MenuHook -> MenuHook -> Bool
(MenuHook -> MenuHook -> Bool)
-> (MenuHook -> MenuHook -> Bool) -> Eq MenuHook
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MenuHook -> MenuHook -> Bool
$c/= :: MenuHook -> MenuHook -> Bool
== :: MenuHook -> MenuHook -> Bool
$c== :: MenuHook -> MenuHook -> Bool
Eq, Eq MenuHook
Eq MenuHook
-> (MenuHook -> MenuHook -> Ordering)
-> (MenuHook -> MenuHook -> Bool)
-> (MenuHook -> MenuHook -> Bool)
-> (MenuHook -> MenuHook -> Bool)
-> (MenuHook -> MenuHook -> Bool)
-> (MenuHook -> MenuHook -> MenuHook)
-> (MenuHook -> MenuHook -> MenuHook)
-> Ord MenuHook
MenuHook -> MenuHook -> Bool
MenuHook -> MenuHook -> Ordering
MenuHook -> MenuHook -> MenuHook
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MenuHook -> MenuHook -> MenuHook
$cmin :: MenuHook -> MenuHook -> MenuHook
max :: MenuHook -> MenuHook -> MenuHook
$cmax :: MenuHook -> MenuHook -> MenuHook
>= :: MenuHook -> MenuHook -> Bool
$c>= :: MenuHook -> MenuHook -> Bool
> :: MenuHook -> MenuHook -> Bool
$c> :: MenuHook -> MenuHook -> Bool
<= :: MenuHook -> MenuHook -> Bool
$c<= :: MenuHook -> MenuHook -> Bool
< :: MenuHook -> MenuHook -> Bool
$c< :: MenuHook -> MenuHook -> Bool
compare :: MenuHook -> MenuHook -> Ordering
$ccompare :: MenuHook -> MenuHook -> Ordering
$cp1Ord :: Eq MenuHook
Ord )

type Destructor = IO ()

type MenuTable = M.Map MenuHook Destructor

emptyMenuTable :: MenuTable
emptyMenuTable :: MenuTable
emptyMenuTable = MenuTable
forall k a. Map k a
M.empty

lookupInMenuTable :: MenuHook -> IO (Maybe Destructor)
lookupInMenuTable :: MenuHook -> IO (Maybe (IO ()))
lookupInMenuTable MenuHook
callbackID =
   (MenuTable -> Maybe (IO ())) -> IO MenuTable -> IO (Maybe (IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MenuHook -> MenuTable -> Maybe (IO ())
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MenuHook
callbackID) IO MenuTable
getMenuTable

deleteFromMenuTable :: MenuHook -> IO ()
deleteFromMenuTable :: MenuHook -> IO ()
deleteFromMenuTable MenuHook
callbackID =
   (MenuTable -> MenuTable) -> IO ()
modifyMenuTable (MenuHook -> MenuTable -> MenuTable
forall k a. Ord k => k -> Map k a -> Map k a
M.delete MenuHook
callbackID)

addToMenuTable :: MenuHook -> Destructor -> IO ()
addToMenuTable :: MenuHook -> IO () -> IO ()
addToMenuTable MenuHook
callbackID IO ()
funPtr =
   (MenuTable -> MenuTable) -> IO ()
modifyMenuTable (MenuHook -> IO () -> MenuTable -> MenuTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MenuHook
callbackID IO ()
funPtr)

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

type MenuID = CInt
type Value  = CInt

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

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

currentMenu :: StateVar MenuID
currentMenu :: StateVar MenuID
currentMenu = IO MenuID -> MenuFunc -> StateVar MenuID
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO MenuID
forall (m :: * -> *). MonadIO m => m MenuID
glutGetMenu MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutSetMenu

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

isRealMenu :: MenuID -> Bool
isRealMenu :: MenuID -> Bool
isRealMenu = (MenuID -> MenuID -> Bool
forall a. Eq a => a -> a -> Bool
/= MenuID
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 :: String -> MenuFunc
addMenuEntry String
name MenuID
value = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
n -> CString -> MenuFunc
forall (m :: * -> *). MonadIO m => CString -> MenuID -> m ()
glutAddMenuEntry CString
n MenuID
value

-- | 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 :: String -> MenuFunc
addSubMenu String
name MenuID
menuID = String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
n -> CString -> MenuFunc
forall (m :: * -> *). MonadIO m => CString -> MenuID -> m ()
glutAddSubMenu CString
n MenuID
menuID

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

{- 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 ()
-}

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

-- | 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_ :: MouseButton -> IO ()
attachMenu_ = MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutAttachMenu MenuFunc -> (MouseButton -> MenuID) -> MouseButton -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MouseButton -> MenuID
marshalMouseButton

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

detachMenu_ :: MouseButton -> IO ()
detachMenu_ :: MouseButton -> IO ()
detachMenu_ = MenuFunc
forall (m :: * -> *). MonadIO m => MenuID -> m ()
glutDetachMenu MenuFunc -> (MouseButton -> MenuID) -> MouseButton -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MouseButton -> MenuID
marshalMouseButton

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

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

numMenuItems :: GettableStateVar Int
numMenuItems :: GettableStateVar Int
numMenuItems = GettableStateVar Int -> GettableStateVar Int
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar Int -> GettableStateVar Int)
-> GettableStateVar Int -> GettableStateVar Int
forall a b. (a -> b) -> a -> b
$ Getter Int
forall a. Getter a
simpleGet MenuID -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_MENU_NUM_ITEMS

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

setMenuFont :: MenuID -> BitmapFont -> IO ()
setMenuFont :: MenuID -> BitmapFont -> IO ()
setMenuFont MenuID
menuID BitmapFont
font = MenuID -> Ptr () -> IO ()
forall (m :: * -> *) a. MonadIO m => MenuID -> Ptr a -> m ()
glutSetMenuFont MenuID
menuID (Ptr () -> IO ()) -> IO (Ptr ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< BitmapFont -> IO (Ptr ())
forall (m :: * -> *). MonadIO m => BitmapFont -> m (Ptr ())
marshalBitmapFont BitmapFont
font