    {-# 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 _) = Maybe BitmapFont
    forall a. Maybe a
    Nothing
    menuFont (MenuWithFont font :: BitmapFont
    font _) = BitmapFont -> Maybe BitmapFont
    forall a. a -> Maybe a
    Just BitmapFont
    font

    menuItems :: Menu -> [MenuItem]
    menuItems :: Menu -> [MenuItem]
    menuItems (Menu items :: [MenuItem]
    items) = [MenuItem]
    items
    menuItems (MenuWithFont _ items :: [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
    mouseButton menu :: 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 "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
          (_, destructor :: 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 _ mouseButton :: MouseButton
    mouseButton) = do
       Maybe (IO ())
    maybeDestructor <- MenuHook -> IO (Maybe (IO ()))
    lookupInMenuTable MenuHook
    hook
       case Maybe (IO ())
    maybeDestructor of
          Nothing         -> () -> IO ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          Just destructor :: 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
    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 (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 (\i :: 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 [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 _ cb :: IO ()
    cb) = IO ()
    cb
    makeCallback _ = String -> IO ()
    forall a. HasCallStack => String -> a
    error "shouldn't receive a callback for submenus"

    addMenuItem :: MenuItem -> Value -> IO Destructor
    addMenuItem :: MenuItem -> MenuID -> IO (IO ())
    addMenuItem (MenuEntry s :: String
    s _) v :: 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 1
    addMenuItem (SubMenu s :: String
    s m :: Menu
    m) _ = do
       (menuID :: MenuID
    menuID, destructor :: 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 1
                   IO ()
    destructor

    -- Perform an action, saving/restoring the current menu around it
    saveExcursion :: IO a -> IO a
    saveExcursion :: IO a -> IO a
    saveExcursion act :: 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 callbackID :: 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 callbackID :: 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 callbackID :: MenuHook
    callbackID funPtr :: 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
    /= 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 name :: String
    name value :: 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
    $ \n :: 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 name :: String
    name menuID :: 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
    $ \n :: 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
    menuID font :: 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