--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Window
-- Copyright   :  (c) Sven Panne 2002-2018
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- GLUT supports two types of windows: top-level windows and subwindows. Both
-- types support OpenGL rendering and GLUT callbacks. There is a single
-- identifier space for both types of windows.
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.Window (
   -- * Window identifiers
   Window,

   -- * Creating and destroying (sub-)windows

   -- $CreatingAndDestroyingSubWindows
   createWindow, createSubWindow, destroyWindow,
   parentWindow, numSubWindows,

   -- * Manipulating the /current window/
   currentWindow,

   -- * Re-displaying and double buffer management
   postRedisplay, swapBuffers,

   -- * Changing the window geometry

   -- $ChangingTheWindowGeometry
   windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen,

   -- * Manipulating the stacking order

   -- $ManipulatingTheStackingOrder
   pushWindow, popWindow,

   -- * Managing a window\'s display status
   WindowStatus(..), windowStatus,

   -- * Changing the window\/icon title

   -- $ChangingTheWindowIconTitle
   windowTitle, iconTitle,

   -- * Cursor management
   Cursor(..), cursor, pointerPosition
) where

import Control.Monad.IO.Class ( MonadIO(..) )
import Data.StateVar ( GettableStateVar, makeGettableStateVar
                     , SettableStateVar, makeSettableStateVar
                     , StateVar, makeStateVar )
import Foreign.C.String ( withCString )
import Foreign.C.Types ( CInt )
import Graphics.Rendering.OpenGL ( Position(..), Size(..) )

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

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

-- $CreatingAndDestroyingSubWindows
-- Each created window has a unique associated OpenGL context. State changes to
-- a window\'s associated OpenGL context can be done immediately after the
-- window is created.
--
-- The /display state/ of a window is initially for the window to be shown. But
-- the window\'s /display state/ is not actually acted upon until
-- 'Graphics.UI.GLUT.Begin.mainLoop' is entered. This means until
-- 'Graphics.UI.GLUT.Begin.mainLoop' is called, rendering to a created window is
-- ineffective because the window can not yet be displayed.
--
-- The value returned by 'createWindow' and 'createSubWindow' is a unique
-- identifier for the window, which can be used with 'currentWindow'.

-- | Create a top-level window. The given name will be provided to the window
-- system as the window\'s name. The intent is that the window system will label
-- the window with the name.Implicitly, the /current window/ is set to the newly
-- created window.
--
-- /X Implementation Notes:/ The proper X Inter-Client Communication Conventions
-- Manual (ICCCM) top-level properties are established. The @WM_COMMAND@
-- property that lists the command line used to invoke the GLUT program is only
-- established for the first window created.

createWindow
   :: MonadIO m
   => String   -- ^ The window name
   -> m Window -- ^ The identifier for the newly created window
createWindow :: String -> m Window
createWindow String
name = IO Window -> m Window
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Window -> m Window) -> IO Window -> m Window
forall a b. (a -> b) -> a -> b
$ (CInt -> Window) -> IO CInt -> IO Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Window
Window (IO CInt -> IO Window) -> IO CInt -> IO Window
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
name CString -> IO CInt
forall (m :: * -> *). MonadIO m => CString -> m CInt
glutCreateWindow

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

-- | Create a subwindow of the identified window with the given relative
-- position and size. Implicitly, the /current window/ is set to the
-- newly created subwindow. Subwindows can be nested arbitrarily deep.

createSubWindow
   :: MonadIO m
   => Window   -- ^ Identifier of the subwindow\'s parent window.
   -> Position -- ^ Window position in pixels relative to parent window\'s
               --   origin.
   -> Size     -- ^ Window size in pixels
   -> m Window -- ^ The identifier for the newly created subwindow
createSubWindow :: Window -> Position -> Size -> m Window
createSubWindow (Window CInt
win) (Position GLint
x GLint
y) (Size GLint
w GLint
h) = do
   CInt
s <- CInt -> CInt -> CInt -> CInt -> CInt -> m CInt
forall (m :: * -> *).
MonadIO m =>
CInt -> CInt -> CInt -> CInt -> CInt -> m CInt
glutCreateSubWindow CInt
win
                            (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)
                            (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
w) (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
h)
   Window -> m Window
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> m Window) -> Window -> m Window
forall a b. (a -> b) -> a -> b
$ CInt -> Window
Window CInt
s

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

-- | Contains the /current window\'s/ parent. If the /current window/ is a
-- top-level window, 'Nothing' is returned.

parentWindow :: GettableStateVar (Maybe Window)
parentWindow :: GettableStateVar (Maybe Window)
parentWindow =
   GettableStateVar (Maybe Window) -> GettableStateVar (Maybe Window)
forall a. IO a -> IO a
makeGettableStateVar (GettableStateVar (Maybe Window)
 -> GettableStateVar (Maybe Window))
-> GettableStateVar (Maybe Window)
-> GettableStateVar (Maybe Window)
forall a b. (a -> b) -> a -> b
$
      IO Window -> GettableStateVar (Maybe Window)
getWindow (Getter Window
forall a. Getter a
simpleGet CInt -> Window
Window GLenum
glut_WINDOW_PARENT)

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

-- | Contains the number of subwindows the /current window/ has, not counting
-- children of children.

numSubWindows :: GettableStateVar Int
numSubWindows :: GettableStateVar Int
numSubWindows =
   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 CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_NUM_CHILDREN

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

-- | Destroy the specified window and the window\'s associated OpenGL context,
-- logical colormap (if the window is color index), and overlay and related
-- state (if an overlay has been established). Any subwindows of the destroyed
-- window are also destroyed by 'destroyWindow'. If the specified window was the
-- /current window/, the /current window/ becomes invalid ('currentWindow' will
-- contain 'Nothing').

destroyWindow :: MonadIO m => Window -> m ()
destroyWindow :: Window -> m ()
destroyWindow (Window CInt
win) = CInt -> m ()
forall (m :: * -> *). MonadIO m => CInt -> m ()
glutDestroyWindow CInt
win

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

-- | Controls the /current window/. It does /not/ affect the /layer in use/ for
-- the window; this is done using 'Graphics.UI.GLUT.Overlay.layerInUse'.
-- Contains 'Nothing' if no windows exist or the previously /current window/ was
-- destroyed. Setting the /current window/ to 'Nothing' is a no-op.

currentWindow :: StateVar (Maybe Window)
currentWindow :: StateVar (Maybe Window)
currentWindow =
   GettableStateVar (Maybe Window)
-> (Maybe Window -> IO ()) -> StateVar (Maybe Window)
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
      (IO Window -> GettableStateVar (Maybe Window)
getWindow ((CInt -> Window) -> IO CInt -> IO Window
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Window
Window IO CInt
forall (m :: * -> *). MonadIO m => m CInt
glutGetWindow))
      (IO () -> (Window -> IO ()) -> Maybe Window -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\(Window CInt
win) -> CInt -> IO ()
forall (m :: * -> *). MonadIO m => CInt -> m ()
glutSetWindow CInt
win))

getWindow :: IO Window -> IO (Maybe Window)
getWindow :: IO Window -> GettableStateVar (Maybe Window)
getWindow IO Window
act = do
   Window
win <- IO Window
act
   Maybe Window -> GettableStateVar (Maybe Window)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Window -> GettableStateVar (Maybe Window))
-> Maybe Window -> GettableStateVar (Maybe Window)
forall a b. (a -> b) -> a -> b
$ if Window
win Window -> Window -> Bool
forall a. Eq a => a -> a -> Bool
== CInt -> Window
Window CInt
0 then Maybe Window
forall a. Maybe a
Nothing else Window -> Maybe Window
forall a. a -> Maybe a
Just Window
win

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

-- | Mark the normal plane of given window (or the /current window/, if none
-- is supplied) as needing to be redisplayed. The next iteration through
-- 'Graphics.UI.GLUT.Begin.mainLoop', the window\'s display callback will be
-- called to redisplay the window\'s normal plane. Multiple calls to
-- 'postRedisplay' before the next display callback opportunity generates only a
-- single redisplay callback. 'postRedisplay' may be called within a window\'s
-- display or overlay display callback to re-mark that window for redisplay.
--
-- Logically, normal plane damage notification for a window is treated as a
-- 'postRedisplay' on the damaged window. Unlike damage reported by the window
-- system, 'postRedisplay' will /not/ set to true the normal plane\'s damaged
-- status (see 'Graphics.UI.GLUT.State.damaged').
--
-- Also, see 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay'.

postRedisplay :: MonadIO m => Maybe Window -> m ()
postRedisplay :: Maybe Window -> m ()
postRedisplay = m () -> (Window -> m ()) -> Maybe Window -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ()
forall (m :: * -> *). MonadIO m => m ()
glutPostRedisplay (\(Window CInt
win) -> CInt -> m ()
forall (m :: * -> *). MonadIO m => CInt -> m ()
glutPostWindowRedisplay CInt
win)

-- | Mark the normal plane of the given window as needing to be redisplayed,
-- otherwise the same as 'postRedisplay'.
--
-- The advantage of this routine is that it saves the cost of using
-- 'currentWindow' (entailing an expensive OpenGL context switch), which is
-- particularly useful when multiple windows need redisplays posted at the same
-- time.

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

-- | Perform a buffer swap on the /layer in use/ for the /current window/.
-- Specifically, 'swapBuffers' promotes the contents of the back buffer of the
-- /layer in use/ of the /current window/ to become the contents of the front
-- buffer. The contents of the back buffer then become undefined. The update
-- typically takes place during the vertical retrace of the monitor, rather than
-- immediately after 'swapBuffers' is called.
--
-- An implicit 'Graphics.Rendering.OpenGL.GL.FlushFinish.flush' is done by
-- 'swapBuffers' before it returns. Subsequent OpenGL commands can be issued
-- immediately after calling 'swapBuffers', but are not executed until the
-- buffer exchange is completed.
--
-- If the /layer in use/ is not double buffered, 'swapBuffers' has no effect.

swapBuffers :: MonadIO m => m ()
swapBuffers :: m ()
swapBuffers = m ()
forall (m :: * -> *). MonadIO m => m ()
glutSwapBuffers

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

-- $ChangingTheWindowGeometry
-- Note that the requests by 'windowPosition', 'windowSize', and 'fullScreen'
-- are not processed immediately. A request is executed after returning to the
-- main event loop. This allows multiple requests to the same window to be
-- coalesced.
--
-- 'windowPosition' and 'windowSize' requests on a window will disable the full
-- screen status of the window.

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

-- | Controls the position of the /current window/. For top-level windows,
-- parameters of 'Position' are pixel offsets from the screen origin. For
-- subwindows, the parameters are pixel offsets from the window\'s parent window
-- origin.
--
-- In the case of top-level windows, setting 'windowPosition' is considered only
-- a request for positioning the window. The window system is free to apply its
-- own policies to top-level window placement. The intent is that top-level
-- windows should be repositioned according to the value of 'windowPosition'.

windowPosition :: StateVar Position
windowPosition :: StateVar Position
windowPosition = IO Position -> (Position -> IO ()) -> StateVar Position
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO Position
getWindowPosition Position -> IO ()
setWindowPosition

setWindowPosition :: Position -> IO ()
setWindowPosition :: Position -> IO ()
setWindowPosition (Position GLint
x GLint
y) =
   CInt -> CInt -> IO ()
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutPositionWindow (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)

getWindowPosition :: IO Position
getWindowPosition :: IO Position
getWindowPosition = do
   GLint
x <- Getter GLint
forall a. Getter a
simpleGet CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_X
   GLint
y <- Getter GLint
forall a. Getter a
simpleGet CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_Y
   Position -> IO Position
forall (m :: * -> *) a. Monad m => a -> m a
return (Position -> IO Position) -> Position -> IO Position
forall a b. (a -> b) -> a -> b
$ GLint -> GLint -> Position
Position GLint
x GLint
y

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

-- | Controls the size of the /current window/. The parameters of 'Size' are
-- size extents in pixels. The width and height must be positive values.
--
-- In the case of top-level windows, setting 'windowSize' is considered only a
-- request for sizing the window. The window system is free to apply its own
-- policies to top-level window sizing. The intent is that top-level windows
-- should be reshaped according to the value of 'windowSize'. Whether a reshape
-- actually takes effect and, if so, the reshaped dimensions are reported to the
-- program by a reshape callback.

windowSize :: StateVar Size
windowSize :: StateVar Size
windowSize = IO Size -> (Size -> IO ()) -> StateVar Size
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO Size
getWindowSize Size -> IO ()
setWindowSize

setWindowSize :: Size -> IO ()
setWindowSize :: Size -> IO ()
setWindowSize (Size GLint
w GLint
h) =
   CInt -> CInt -> IO ()
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutReshapeWindow (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
w) (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
h)

getWindowSize :: IO Size
getWindowSize :: IO Size
getWindowSize = do
   GLint
w <- Getter GLint
forall a. Getter a
simpleGet CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_WIDTH
   GLint
h <- Getter GLint
forall a. Getter a
simpleGet CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_HEIGHT
   Size -> IO Size
forall (m :: * -> *) a. Monad m => a -> m a
return (Size -> IO Size) -> Size -> IO Size
forall a b. (a -> b) -> a -> b
$ GLint -> GLint -> Size
Size GLint
w GLint
h

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

-- | Request that the /current window/ be made full screen. The exact semantics
-- of what full screen means may vary by window system. The intent is to make
-- the window as large as possible and disable any window decorations or borders
-- added the window system. The window width and height are not guaranteed to be
-- the same as the screen width and height, but that is the intent of making a
-- window full screen.
--
-- 'fullScreen' is defined to work only on top-level windows.
--
-- /X Implementation Notes:/ In the X implementation of GLUT, full screen is
-- implemented by sizing and positioning the window to cover the entire screen
-- and posting the @_MOTIF_WM_HINTS@ property on the window requesting
-- absolutely no decorations. Non-Motif window managers may not respond to
-- @_MOTIF_WM_HINTS@.

fullScreen :: MonadIO m => m ()
fullScreen :: m ()
fullScreen = m ()
forall (m :: * -> *). MonadIO m => m ()
glutFullScreen

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

-- | (/freeglut only/) Toggle between windowed and full screen mode.

fullScreenToggle :: MonadIO m => m ()
fullScreenToggle :: m ()
fullScreenToggle = m ()
forall (m :: * -> *). MonadIO m => m ()
glutFullScreenToggle

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

-- | (/freeglut only/) If we are in full screen mode, resize the current window
-- back to its original size.

leaveFullScreen :: MonadIO m => m ()
leaveFullScreen :: m ()
leaveFullScreen = m ()
forall (m :: * -> *). MonadIO m => m ()
glutLeaveFullScreen

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

-- $ManipulatingTheStackingOrder
-- 'pushWindow' and 'popWindow' work on both top-level windows and subwindows.
-- The effect of pushing and popping windows does not take place immediately.
-- Instead the push or pop is saved for execution upon return to the GLUT event
-- loop. Subsequent pop or push requests on a window replace the previously
-- saved request for that window. The effect of pushing and popping top-level
-- windows is subject to the window system\'s policy for restacking windows.

-- | Change the stacking order of the /current window/ relative to its siblings
-- (lowering it).

pushWindow :: MonadIO m => m ()
pushWindow :: m ()
pushWindow = m ()
forall (m :: * -> *). MonadIO m => m ()
glutPushWindow

-- | Change the stacking order of the /current window/ relative to its siblings,
-- bringing the /current window/ closer to the top.

popWindow :: MonadIO m => m ()
popWindow :: m ()
popWindow = m ()
forall (m :: * -> *). MonadIO m => m ()
glutPopWindow

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

-- | The display status of a window.

data WindowStatus
   = Shown
   | Hidden
   | Iconified
   deriving ( WindowStatus -> WindowStatus -> Bool
(WindowStatus -> WindowStatus -> Bool)
-> (WindowStatus -> WindowStatus -> Bool) -> Eq WindowStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WindowStatus -> WindowStatus -> Bool
$c/= :: WindowStatus -> WindowStatus -> Bool
== :: WindowStatus -> WindowStatus -> Bool
$c== :: WindowStatus -> WindowStatus -> Bool
Eq, Eq WindowStatus
Eq WindowStatus
-> (WindowStatus -> WindowStatus -> Ordering)
-> (WindowStatus -> WindowStatus -> Bool)
-> (WindowStatus -> WindowStatus -> Bool)
-> (WindowStatus -> WindowStatus -> Bool)
-> (WindowStatus -> WindowStatus -> Bool)
-> (WindowStatus -> WindowStatus -> WindowStatus)
-> (WindowStatus -> WindowStatus -> WindowStatus)
-> Ord WindowStatus
WindowStatus -> WindowStatus -> Bool
WindowStatus -> WindowStatus -> Ordering
WindowStatus -> WindowStatus -> WindowStatus
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 :: WindowStatus -> WindowStatus -> WindowStatus
$cmin :: WindowStatus -> WindowStatus -> WindowStatus
max :: WindowStatus -> WindowStatus -> WindowStatus
$cmax :: WindowStatus -> WindowStatus -> WindowStatus
>= :: WindowStatus -> WindowStatus -> Bool
$c>= :: WindowStatus -> WindowStatus -> Bool
> :: WindowStatus -> WindowStatus -> Bool
$c> :: WindowStatus -> WindowStatus -> Bool
<= :: WindowStatus -> WindowStatus -> Bool
$c<= :: WindowStatus -> WindowStatus -> Bool
< :: WindowStatus -> WindowStatus -> Bool
$c< :: WindowStatus -> WindowStatus -> Bool
compare :: WindowStatus -> WindowStatus -> Ordering
$ccompare :: WindowStatus -> WindowStatus -> Ordering
$cp1Ord :: Eq WindowStatus
Ord, Int -> WindowStatus -> ShowS
[WindowStatus] -> ShowS
WindowStatus -> String
(Int -> WindowStatus -> ShowS)
-> (WindowStatus -> String)
-> ([WindowStatus] -> ShowS)
-> Show WindowStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WindowStatus] -> ShowS
$cshowList :: [WindowStatus] -> ShowS
show :: WindowStatus -> String
$cshow :: WindowStatus -> String
showsPrec :: Int -> WindowStatus -> ShowS
$cshowsPrec :: Int -> WindowStatus -> ShowS
Show )

-- | Controls the display status of the /current window/.
--
-- Note that the effect of showing, hiding, and iconifying windows does not take
-- place immediately. Instead the requests are saved for execution upon return
-- to the GLUT event loop. Subsequent show, hide, or iconification requests on a
-- window replace the previously saved request for that window. The effect of
-- hiding, showing, or iconifying top-level windows is subject to the window
-- system\'s policy for displaying windows. Subwindows can\'t be iconified.

windowStatus :: SettableStateVar WindowStatus
windowStatus :: SettableStateVar WindowStatus
windowStatus = (WindowStatus -> IO ()) -> SettableStateVar WindowStatus
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar WindowStatus -> IO ()
forall (m :: * -> *). MonadIO m => WindowStatus -> m ()
setStatus
   where setStatus :: WindowStatus -> m ()
setStatus WindowStatus
Shown     = m ()
forall (m :: * -> *). MonadIO m => m ()
glutShowWindow
         setStatus WindowStatus
Hidden    = m ()
forall (m :: * -> *). MonadIO m => m ()
glutHideWindow
         setStatus WindowStatus
Iconified = m ()
forall (m :: * -> *). MonadIO m => m ()
glutIconifyWindow

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

-- $ChangingTheWindowIconTitle
-- 'windowTitle' and 'iconTitle' should be set only when the /current
-- window/ is a top-level window. Upon creation of a top-level window, the
-- window and icon names are determined by the name given to 'createWindow'.
-- Once created, setting 'windowTitle' and 'iconTitle' can change the window and
-- icon names respectively of top-level windows. Each call requests the window
-- system change the title appropriately. Requests are not buffered or
-- coalesced. The policy by which the window and icon name are displayed is
-- window system dependent.

-- | Controls the window title of the /current top-level window/.

windowTitle :: SettableStateVar String
windowTitle :: SettableStateVar String
windowTitle =
   (String -> IO ()) -> SettableStateVar String
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((String -> IO ()) -> SettableStateVar String)
-> (String -> IO ()) -> SettableStateVar String
forall a b. (a -> b) -> a -> b
$ \String
name ->
      String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name CString -> IO ()
forall (m :: * -> *). MonadIO m => CString -> m ()
glutSetWindowTitle

-- | Controls the icon title of the /current top-level window/.

iconTitle :: SettableStateVar String
iconTitle :: SettableStateVar String
iconTitle =
   (String -> IO ()) -> SettableStateVar String
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((String -> IO ()) -> SettableStateVar String)
-> (String -> IO ()) -> SettableStateVar String
forall a b. (a -> b) -> a -> b
$ \String
name ->
      String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
name CString -> IO ()
forall (m :: * -> *). MonadIO m => CString -> m ()
glutSetIconTitle

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

-- | The different cursor images GLUT supports.

data Cursor
   = RightArrow        -- ^ Arrow pointing up and to the right.
   | LeftArrow         -- ^ Arrow pointing up and to the left.
   | Info              -- ^ Pointing hand.
   | Destroy           -- ^ Skull & cross bones.
   | Help              -- ^ Question mark.
   | Cycle             -- ^ Arrows rotating in a circle.
   | Spray             -- ^ Spray can.
   | Wait              -- ^ Wrist watch.
   | Text              -- ^ Insertion point cursor for text.
   | Crosshair         -- ^ Simple cross-hair.
   | UpDown            -- ^ Bi-directional pointing up & down.
   | LeftRight         -- ^ Bi-directional pointing left & right.
   | TopSide           -- ^ Arrow pointing to top side.
   | BottomSide        -- ^ Arrow pointing to bottom side.
   | LeftSide          -- ^ Arrow pointing to left side.
   | RightSide         -- ^ Arrow pointing to right side.
   | TopLeftCorner     -- ^ Arrow pointing to top-left corner.
   | TopRightCorner    -- ^ Arrow pointing to top-right corner.
   | BottomRightCorner -- ^ Arrow pointing to bottom-left corner.
   | BottomLeftCorner  -- ^ Arrow pointing to bottom-right corner.
   | Inherit           -- ^ Use parent\'s cursor.
   | None              -- ^ Invisible cursor.
   | FullCrosshair     -- ^ Full-screen cross-hair cursor (if possible, otherwise 'Crosshair').
   deriving ( Cursor -> Cursor -> Bool
(Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool) -> Eq Cursor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cursor -> Cursor -> Bool
$c/= :: Cursor -> Cursor -> Bool
== :: Cursor -> Cursor -> Bool
$c== :: Cursor -> Cursor -> Bool
Eq, Eq Cursor
Eq Cursor
-> (Cursor -> Cursor -> Ordering)
-> (Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Bool)
-> (Cursor -> Cursor -> Cursor)
-> (Cursor -> Cursor -> Cursor)
-> Ord Cursor
Cursor -> Cursor -> Bool
Cursor -> Cursor -> Ordering
Cursor -> Cursor -> Cursor
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 :: Cursor -> Cursor -> Cursor
$cmin :: Cursor -> Cursor -> Cursor
max :: Cursor -> Cursor -> Cursor
$cmax :: Cursor -> Cursor -> Cursor
>= :: Cursor -> Cursor -> Bool
$c>= :: Cursor -> Cursor -> Bool
> :: Cursor -> Cursor -> Bool
$c> :: Cursor -> Cursor -> Bool
<= :: Cursor -> Cursor -> Bool
$c<= :: Cursor -> Cursor -> Bool
< :: Cursor -> Cursor -> Bool
$c< :: Cursor -> Cursor -> Bool
compare :: Cursor -> Cursor -> Ordering
$ccompare :: Cursor -> Cursor -> Ordering
$cp1Ord :: Eq Cursor
Ord, Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
(Int -> Cursor -> ShowS)
-> (Cursor -> String) -> ([Cursor] -> ShowS) -> Show Cursor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cursor] -> ShowS
$cshowList :: [Cursor] -> ShowS
show :: Cursor -> String
$cshow :: Cursor -> String
showsPrec :: Int -> Cursor -> ShowS
$cshowsPrec :: Int -> Cursor -> ShowS
Show )

marshalCursor :: Cursor -> CInt
marshalCursor :: Cursor -> CInt
marshalCursor Cursor
x = case Cursor
x of
   Cursor
RightArrow -> CInt
glut_CURSOR_RIGHT_ARROW
   Cursor
LeftArrow -> CInt
glut_CURSOR_LEFT_ARROW
   Cursor
Info -> CInt
glut_CURSOR_INFO
   Cursor
Destroy -> CInt
glut_CURSOR_DESTROY
   Cursor
Help -> CInt
glut_CURSOR_HELP
   Cursor
Cycle -> CInt
glut_CURSOR_CYCLE
   Cursor
Spray -> CInt
glut_CURSOR_SPRAY
   Cursor
Wait -> CInt
glut_CURSOR_WAIT
   Cursor
Text -> CInt
glut_CURSOR_TEXT
   Cursor
Crosshair -> CInt
glut_CURSOR_CROSSHAIR
   Cursor
UpDown -> CInt
glut_CURSOR_UP_DOWN
   Cursor
LeftRight -> CInt
glut_CURSOR_LEFT_RIGHT
   Cursor
TopSide -> CInt
glut_CURSOR_TOP_SIDE
   Cursor
BottomSide -> CInt
glut_CURSOR_BOTTOM_SIDE
   Cursor
LeftSide -> CInt
glut_CURSOR_LEFT_SIDE
   Cursor
RightSide -> CInt
glut_CURSOR_RIGHT_SIDE
   Cursor
TopLeftCorner -> CInt
glut_CURSOR_TOP_LEFT_CORNER
   Cursor
TopRightCorner -> CInt
glut_CURSOR_TOP_RIGHT_CORNER
   Cursor
BottomRightCorner -> CInt
glut_CURSOR_BOTTOM_RIGHT_CORNER
   Cursor
BottomLeftCorner -> CInt
glut_CURSOR_BOTTOM_LEFT_CORNER
   Cursor
Inherit -> CInt
glut_CURSOR_INHERIT
   Cursor
None -> CInt
glut_CURSOR_NONE
   Cursor
FullCrosshair -> CInt
glut_CURSOR_FULL_CROSSHAIR

unmarshalCursor :: CInt -> Cursor
unmarshalCursor :: CInt -> Cursor
unmarshalCursor CInt
x
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_RIGHT_ARROW = Cursor
RightArrow
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_ARROW = Cursor
LeftArrow
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_INFO = Cursor
Info
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_DESTROY = Cursor
Destroy
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_HELP = Cursor
Help
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_CYCLE = Cursor
Cycle
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_SPRAY = Cursor
Spray
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_WAIT = Cursor
Wait
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TEXT = Cursor
Text
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_CROSSHAIR = Cursor
Crosshair
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_UP_DOWN = Cursor
UpDown
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_RIGHT = Cursor
LeftRight
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_SIDE = Cursor
TopSide
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_SIDE = Cursor
BottomSide
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_SIDE = Cursor
LeftSide
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_RIGHT_SIDE = Cursor
RightSide
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_LEFT_CORNER = Cursor
TopLeftCorner
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_RIGHT_CORNER = Cursor
TopRightCorner
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_RIGHT_CORNER = Cursor
BottomRightCorner
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_LEFT_CORNER = Cursor
BottomLeftCorner
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_INHERIT = Cursor
Inherit
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_NONE = Cursor
None
   | CInt
x CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_FULL_CROSSHAIR = Cursor
FullCrosshair
   | Bool
otherwise = String -> Cursor
forall a. HasCallStack => String -> a
error (String
"unmarshalCursor: illegal value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
x)

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

-- | Change the cursor image of the /current window/. Each call requests the
-- window system change the cursor appropriately. The cursor image when a window
-- is created is 'Inherit'. The exact cursor images used are implementation
-- dependent. The intent is for the image to convey the meaning of the cursor
-- name. For a top-level window, 'Inherit' uses the default window system
-- cursor.
--
-- /X Implementation Notes:/ GLUT for X uses SGI\'s @_SGI_CROSSHAIR_CURSOR@
-- convention to access a full-screen cross-hair cursor if possible.

cursor :: StateVar Cursor
cursor :: StateVar Cursor
cursor = IO Cursor -> (Cursor -> IO ()) -> StateVar Cursor
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO Cursor
getCursor Cursor -> IO ()
setCursor

setCursor :: Cursor -> IO ()
setCursor :: Cursor -> IO ()
setCursor = CInt -> IO ()
forall (m :: * -> *). MonadIO m => CInt -> m ()
glutSetCursor (CInt -> IO ()) -> (Cursor -> CInt) -> Cursor -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> CInt
marshalCursor

getCursor :: IO Cursor
getCursor :: IO Cursor
getCursor = Getter Cursor
forall a. Getter a
simpleGet CInt -> Cursor
unmarshalCursor GLenum
glut_WINDOW_CURSOR

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

-- | Setting 'pointerPosition' warps the window system\'s pointer to a new
-- location relative to the origin of the /current window/ by the specified
-- pixel offset, which may be negative. The warp is done immediately.
--
-- If the pointer would be warped outside the screen\'s frame buffer region, the
-- location will be clamped to the nearest screen edge. The window system is
-- allowed to further constrain the pointer\'s location in window system
-- dependent ways.
--
-- Good advice from Xlib\'s @XWarpPointer@ man page: \"There is seldom any
-- reason for calling this function. The pointer should normally be left to the
-- user.\"

pointerPosition :: SettableStateVar Position
pointerPosition :: SettableStateVar Position
pointerPosition =
   (Position -> IO ()) -> SettableStateVar Position
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar ((Position -> IO ()) -> SettableStateVar Position)
-> (Position -> IO ()) -> SettableStateVar Position
forall a b. (a -> b) -> a -> b
$ \(Position GLint
x GLint
y) ->
      CInt -> CInt -> IO ()
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutWarpPointer (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (GLint -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)