module Graphics.UI.GLUT.Window (
Window,
createWindow, createSubWindow, destroyWindow,
parentWindow, numSubWindows,
currentWindow,
postRedisplay, swapBuffers,
windowPosition, windowSize, fullScreen, fullScreenToggle, leaveFullScreen,
pushWindow, popWindow,
WindowStatus(..), windowStatus,
windowTitle, iconTitle,
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
createWindow
:: MonadIO m
=> String
-> m Window
createWindow :: forall (m :: * -> *). MonadIO m => String -> m Window
createWindow String
name = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Window
Window forall a b. (a -> b) -> a -> b
$ forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall (m :: * -> *). MonadIO m => CString -> m CInt
glutCreateWindow
createSubWindow
:: MonadIO m
=> Window
-> Position
-> Size
-> m Window
createSubWindow :: forall (m :: * -> *).
MonadIO m =>
Window -> Position -> Size -> m Window
createSubWindow (Window CInt
win) (Position GLint
x GLint
y) (Size GLint
w GLint
h) = do
CInt
s <- forall (m :: * -> *).
MonadIO m =>
CInt -> CInt -> CInt -> CInt -> CInt -> m CInt
glutCreateSubWindow CInt
win
(forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)
(forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
h)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CInt -> Window
Window CInt
s
parentWindow :: GettableStateVar (Maybe Window)
parentWindow :: GettableStateVar (Maybe Window)
parentWindow =
forall a. IO a -> IO a
makeGettableStateVar forall a b. (a -> b) -> a -> b
$
IO Window -> GettableStateVar (Maybe Window)
getWindow (forall a. Getter a
simpleGet CInt -> Window
Window GLenum
glut_WINDOW_PARENT)
numSubWindows :: GettableStateVar Int
numSubWindows :: GettableStateVar Int
numSubWindows =
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_WINDOW_NUM_CHILDREN
destroyWindow :: MonadIO m => Window -> m ()
destroyWindow :: forall (m :: * -> *). MonadIO m => Window -> m ()
destroyWindow (Window CInt
win) = forall (m :: * -> *). MonadIO m => CInt -> m ()
glutDestroyWindow CInt
win
currentWindow :: StateVar (Maybe Window)
currentWindow :: StateVar (Maybe Window)
currentWindow =
forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar
(IO Window -> GettableStateVar (Maybe Window)
getWindow (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Window
Window forall (m :: * -> *). MonadIO m => m CInt
glutGetWindow))
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\(Window CInt
win) -> 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Window
win forall a. Eq a => a -> a -> Bool
== CInt -> Window
Window CInt
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Window
win
postRedisplay :: MonadIO m => Maybe Window -> m ()
postRedisplay :: forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
postRedisplay = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *). MonadIO m => m ()
glutPostRedisplay (\(Window CInt
win) -> forall (m :: * -> *). MonadIO m => CInt -> m ()
glutPostWindowRedisplay CInt
win)
swapBuffers :: MonadIO m => m ()
swapBuffers :: forall (m :: * -> *). MonadIO m => m ()
swapBuffers = forall (m :: * -> *). MonadIO m => m ()
glutSwapBuffers
windowPosition :: StateVar Position
windowPosition :: StateVar Position
windowPosition = 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) =
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutPositionWindow (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)
getWindowPosition :: IO Position
getWindowPosition :: IO Position
getWindowPosition = do
GLint
x <- forall a. Getter a
simpleGet forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_X
GLint
y <- forall a. Getter a
simpleGet forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_Y
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GLint -> GLint -> Position
Position GLint
x GLint
y
windowSize :: StateVar Size
windowSize :: StateVar Size
windowSize = 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) =
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutReshapeWindow (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
w) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
h)
getWindowSize :: IO Size
getWindowSize :: IO Size
getWindowSize = do
GLint
w <- forall a. Getter a
simpleGet forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_WIDTH
GLint
h <- forall a. Getter a
simpleGet forall a b. (Integral a, Num b) => a -> b
fromIntegral GLenum
glut_WINDOW_HEIGHT
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GLint -> GLint -> Size
Size GLint
w GLint
h
fullScreen :: MonadIO m => m ()
fullScreen :: forall (m :: * -> *). MonadIO m => m ()
fullScreen = forall (m :: * -> *). MonadIO m => m ()
glutFullScreen
fullScreenToggle :: MonadIO m => m ()
fullScreenToggle :: forall (m :: * -> *). MonadIO m => m ()
fullScreenToggle = forall (m :: * -> *). MonadIO m => m ()
glutFullScreenToggle
leaveFullScreen :: MonadIO m => m ()
leaveFullScreen :: forall (m :: * -> *). MonadIO m => m ()
leaveFullScreen = forall (m :: * -> *). MonadIO m => m ()
glutLeaveFullScreen
pushWindow :: MonadIO m => m ()
pushWindow :: forall (m :: * -> *). MonadIO m => m ()
pushWindow = forall (m :: * -> *). MonadIO m => m ()
glutPushWindow
popWindow :: MonadIO m => m ()
popWindow :: forall (m :: * -> *). MonadIO m => m ()
popWindow = forall (m :: * -> *). MonadIO m => m ()
glutPopWindow
data WindowStatus
= Shown
| Hidden
| Iconified
deriving ( WindowStatus -> WindowStatus -> Bool
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
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
Ord, Int -> WindowStatus -> ShowS
[WindowStatus] -> ShowS
WindowStatus -> String
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 )
windowStatus :: SettableStateVar WindowStatus
windowStatus :: SettableStateVar WindowStatus
windowStatus = forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar forall {m :: * -> *}. MonadIO m => WindowStatus -> m ()
setStatus
where setStatus :: WindowStatus -> m ()
setStatus WindowStatus
Shown = forall (m :: * -> *). MonadIO m => m ()
glutShowWindow
setStatus WindowStatus
Hidden = forall (m :: * -> *). MonadIO m => m ()
glutHideWindow
setStatus WindowStatus
Iconified = forall (m :: * -> *). MonadIO m => m ()
glutIconifyWindow
windowTitle :: SettableStateVar String
windowTitle :: SettableStateVar String
windowTitle =
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar forall a b. (a -> b) -> a -> b
$ \String
name ->
forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall (m :: * -> *). MonadIO m => CString -> m ()
glutSetWindowTitle
iconTitle :: SettableStateVar String
iconTitle :: SettableStateVar String
iconTitle =
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar forall a b. (a -> b) -> a -> b
$ \String
name ->
forall a. String -> (CString -> IO a) -> IO a
withCString String
name forall (m :: * -> *). MonadIO m => CString -> m ()
glutSetIconTitle
data Cursor
= RightArrow
| LeftArrow
| Info
| Destroy
| Help
| Cycle
| Spray
| Wait
| Text
| Crosshair
| UpDown
| LeftRight
| TopSide
| BottomSide
| LeftSide
| RightSide
| TopLeftCorner
| TopRightCorner
| BottomRightCorner
| BottomLeftCorner
| Inherit
| None
| FullCrosshair
deriving ( Cursor -> Cursor -> Bool
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
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
Ord, Int -> Cursor -> ShowS
[Cursor] -> ShowS
Cursor -> String
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 forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_RIGHT_ARROW = Cursor
RightArrow
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_ARROW = Cursor
LeftArrow
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_INFO = Cursor
Info
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_DESTROY = Cursor
Destroy
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_HELP = Cursor
Help
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_CYCLE = Cursor
Cycle
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_SPRAY = Cursor
Spray
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_WAIT = Cursor
Wait
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TEXT = Cursor
Text
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_CROSSHAIR = Cursor
Crosshair
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_UP_DOWN = Cursor
UpDown
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_RIGHT = Cursor
LeftRight
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_SIDE = Cursor
TopSide
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_SIDE = Cursor
BottomSide
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_LEFT_SIDE = Cursor
LeftSide
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_RIGHT_SIDE = Cursor
RightSide
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_LEFT_CORNER = Cursor
TopLeftCorner
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_TOP_RIGHT_CORNER = Cursor
TopRightCorner
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_RIGHT_CORNER = Cursor
BottomRightCorner
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_BOTTOM_LEFT_CORNER = Cursor
BottomLeftCorner
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_INHERIT = Cursor
Inherit
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_NONE = Cursor
None
| CInt
x forall a. Eq a => a -> a -> Bool
== CInt
glut_CURSOR_FULL_CROSSHAIR = Cursor
FullCrosshair
| Bool
otherwise = forall a. HasCallStack => String -> a
error (String
"unmarshalCursor: illegal value " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
x)
cursor :: StateVar Cursor
cursor :: StateVar Cursor
cursor = forall a. IO a -> (a -> IO ()) -> StateVar a
makeStateVar IO Cursor
getCursor Cursor -> IO ()
setCursor
setCursor :: Cursor -> IO ()
setCursor :: Cursor -> IO ()
setCursor = forall (m :: * -> *). MonadIO m => CInt -> m ()
glutSetCursor forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cursor -> CInt
marshalCursor
getCursor :: IO Cursor
getCursor :: IO Cursor
getCursor = forall a. Getter a
simpleGet CInt -> Cursor
unmarshalCursor GLenum
glut_WINDOW_CURSOR
pointerPosition :: SettableStateVar Position
pointerPosition :: SettableStateVar Position
pointerPosition =
forall a. (a -> IO ()) -> SettableStateVar a
makeSettableStateVar forall a b. (a -> b) -> a -> b
$ \(Position GLint
x GLint
y) ->
forall (m :: * -> *). MonadIO m => CInt -> CInt -> m ()
glutWarpPointer (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
x) (forall a b. (Integral a, Num b) => a -> b
fromIntegral GLint
y)