{-# OPTIONS_GHC -fno-cse #-}
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
data
= [MenuItem]
| BitmapFont [MenuItem]
menuFont :: Menu -> Maybe BitmapFont
(Menu [MenuItem]
_) = forall a. Maybe a
Nothing
menuFont (MenuWithFont BitmapFont
font [MenuItem]
_) = forall a. a -> Maybe a
Just BitmapFont
font
menuItems :: Menu -> [MenuItem]
(Menu [MenuItem]
items) = [MenuItem]
items
menuItems (MenuWithFont BitmapFont
_ [MenuItem]
items) = [MenuItem]
items
data
= String MenuCallback
| String Menu
type = IO ()
attachMenu :: MonadIO m => MouseButton -> Menu -> m ()
MouseButton
mouseButton Menu
menu = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Menu -> [MenuItem]
menuItems Menu
menu)) forall a b. (a -> b) -> a -> b
$ do
(CInt
_, IO ()
destructor) <- Menu -> IO (CInt, IO ())
traverseMenu Menu
menu
MenuHook -> IO () -> IO ()
addToMenuTable MenuHook
hook IO ()
destructor
MouseButton -> IO ()
attachMenu_ MouseButton
mouseButton
detachMenu :: MenuHook -> IO ()
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 -> 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)
Menu
menu = do
let items :: [MenuItem]
items = Menu -> [MenuItem]
menuItems Menu
menu
callbackArray :: Array Int (IO ())
callbackArray = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
1, forall (t :: * -> *) a. Foldable t => t a -> Int
length [MenuItem]
items) (forall a b. (a -> b) -> [a] -> [b]
map MenuItem -> IO ()
makeCallback [MenuItem]
items)
FunPtr MenuFunc
cb <- MenuFunc -> IO (FunPtr MenuFunc)
makeMenuFunc (\CInt
i -> Array Int (IO ())
callbackArray forall i e. Ix i => Array i e -> i -> e
! (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
i))
CInt
menuID <- forall (m :: * -> *). MonadIO m => FunPtr MenuFunc -> m CInt
glutCreateMenu FunPtr MenuFunc
cb
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (CInt -> BitmapFont -> IO ()
setMenuFont CInt
menuID) (Menu -> Maybe BitmapFont
menuFont Menu
menu)
[IO ()]
destructors <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM MenuItem -> CInt -> IO (IO ())
addMenuItem [MenuItem]
items [CInt
1..]
let destructor :: IO ()
destructor = do forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
destructors
forall (m :: * -> *). MonadIO m => CInt -> m ()
glutDestroyMenu CInt
menuID
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr MenuFunc
cb
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt
menuID, IO ()
destructor)
makeCallback :: MenuItem -> MenuCallback
makeCallback :: MenuItem -> IO ()
makeCallback (MenuEntry String
_ IO ()
cb) = IO ()
cb
makeCallback MenuItem
_ = forall a. HasCallStack => String -> a
error String
"shouldn't receive a callback for submenus"
addMenuItem :: MenuItem -> Value -> IO Destructor
(MenuEntry String
s IO ()
_) CInt
v = do
String -> MenuFunc
addMenuEntry String
s CInt
v
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => CInt -> m ()
glutRemoveMenuItem CInt
1
addMenuItem (SubMenu String
s Menu
m) CInt
_ = do
(CInt
menuID, IO ()
destructor) <- forall a. IO a -> IO a
saveExcursion (Menu -> IO (CInt, IO ())
traverseMenu Menu
m)
String -> MenuFunc
addSubMenu String
s CInt
menuID
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ do forall (m :: * -> *). MonadIO m => CInt -> m ()
glutRemoveMenuItem CInt
1
IO ()
destructor
saveExcursion :: IO a -> IO a
saveExcursion :: forall a. IO a -> IO a
saveExcursion IO a
act = do
CInt
menuID <- forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
get StateVar CInt
currentMenu
a
returnValue <- IO a
act
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CInt -> Bool
isRealMenu CInt
menuID) forall a b. (a -> b) -> a -> b
$
StateVar CInt
currentMenu forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
$= CInt
menuID
forall (m :: * -> *) a. Monad m => a -> m a
return a
returnValue
{-# NOINLINE theMenuTable #-}
theMenuTable :: IORef MenuTable
= forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef MenuTable
emptyMenuTable)
getMenuTable :: IO MenuTable
= forall a. IORef a -> IO a
readIORef IORef MenuTable
theMenuTable
modifyMenuTable :: (MenuTable -> MenuTable) -> IO ()
= forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef MenuTable
theMenuTable
data = Window MouseButton
deriving ( MenuHook -> MenuHook -> Bool
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
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
Ord )
type Destructor = IO ()
type = M.Map MenuHook Destructor
emptyMenuTable :: MenuTable
= forall k a. Map k a
M.empty
lookupInMenuTable :: MenuHook -> IO (Maybe Destructor)
MenuHook
callbackID =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MenuHook
callbackID) IO MenuTable
getMenuTable
deleteFromMenuTable :: MenuHook -> IO ()
MenuHook
callbackID =
(MenuTable -> MenuTable) -> IO ()
modifyMenuTable (forall k a. Ord k => k -> Map k a -> Map k a
M.delete MenuHook
callbackID)
addToMenuTable :: MenuHook -> Destructor -> IO ()
MenuHook
callbackID IO ()
funPtr =
(MenuTable -> MenuTable) -> IO ()
modifyMenuTable (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert MenuHook
callbackID IO ()
funPtr)
type = CInt
type Value = CInt
currentMenu :: StateVar MenuID
= forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar forall (m :: * -> *). MonadIO m => m CInt
glutGetMenu forall (m :: * -> *). MonadIO m => CInt -> m ()
glutSetMenu
isRealMenu :: MenuID -> Bool
= (forall a. Eq a => a -> a -> Bool
/= CInt
0)
addMenuEntry :: String -> Value -> IO ()
String
name CInt
value = forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall a b. (a -> b) -> a -> b
$ \CString
n -> forall (m :: * -> *). MonadIO m => CString -> CInt -> m ()
glutAddMenuEntry CString
n CInt
value
addSubMenu :: String -> MenuID -> IO ()
String
name CInt
menuID = forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall a b. (a -> b) -> a -> b
$ \CString
n -> forall (m :: * -> *). MonadIO m => CString -> CInt -> m ()
glutAddSubMenu CString
n CInt
menuID
attachMenu_ :: MouseButton -> IO ()
= forall (m :: * -> *). MonadIO m => CInt -> m ()
glutAttachMenu forall b c a. (b -> c) -> (a -> b) -> a -> c
. MouseButton -> CInt
marshalMouseButton
detachMenu_ :: MouseButton -> IO ()
= forall (m :: * -> *). MonadIO m => CInt -> m ()
glutDetachMenu forall b c a. (b -> c) -> (a -> b) -> a -> c
. MouseButton -> CInt
marshalMouseButton
numMenuItems :: GettableStateVar Int
= forall a. IO a -> IO a
makeGettableStateVar forall a b. (a -> b) -> a -> b
$ forall a. Getter a
simpleGet forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_MENU_NUM_ITEMS
setMenuFont :: MenuID -> BitmapFont -> IO ()
CInt
menuID BitmapFont
font = forall (m :: * -> *) a. MonadIO m => CInt -> Ptr a -> m ()
glutSetMenuFont CInt
menuID forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => BitmapFont -> m GLUTbitmapFont
marshalBitmapFont BitmapFont
font