GLFW-b-1.4.8.1: Test.hs
-- base
import Control.Concurrent (threadDelay)
import Data.Char (isAscii)
import Data.List (intercalate, isPrefixOf)
-- HUnit
import Test.HUnit ((@?=), assertBool, assertFailure)
-- test-framework
import Test.Framework (Test, defaultMain, testGroup)
-- test-framework-hunit
import Test.Framework.Providers.HUnit (testCase)
-- GLFW-b
import qualified Graphics.UI.GLFW as GLFW
--------------------------------------------------------------------------------
main :: IO ()
main = do
GLFW.setErrorCallback $ Just $ \e s ->
putStrLn $ unwords ["###", show e, show s]
True <- GLFW.init
Just mon <- GLFW.getPrimaryMonitor
GLFW.windowHint $ GLFW.WindowHint'Visible False
mwin@(Just win) <- GLFW.createWindow 100 100 "GLFW-b test" Nothing Nothing
GLFW.makeContextCurrent mwin
defaultMain $ tests mon win
-- TODO because of how defaultMain works, this code is not reached
GLFW.destroyWindow win
GLFW.terminate
--------------------------------------------------------------------------------
versionMajor, versionMinor :: Int
versionMajor = 3
versionMinor = 1
giveItTime :: IO ()
giveItTime = threadDelay 250000
joysticks :: [GLFW.Joystick]
joysticks =
[ GLFW.Joystick'1
, GLFW.Joystick'2
, GLFW.Joystick'3
, GLFW.Joystick'4
, GLFW.Joystick'5
, GLFW.Joystick'6
, GLFW.Joystick'7
, GLFW.Joystick'8
, GLFW.Joystick'9
, GLFW.Joystick'10
, GLFW.Joystick'11
, GLFW.Joystick'12
, GLFW.Joystick'13
, GLFW.Joystick'14
, GLFW.Joystick'15
, GLFW.Joystick'16
]
between :: Ord a => a -> (a,a) -> Bool
between n (l,h) = n >= l && n <= h
videoModeLooksValid :: GLFW.VideoMode -> Bool
videoModeLooksValid vm = and
[ GLFW.videoModeWidth vm `between` (0,4000)
, GLFW.videoModeHeight vm `between` (0,3000)
, GLFW.videoModeRedBits vm `between` (0, 32)
, GLFW.videoModeGreenBits vm `between` (0, 32)
, GLFW.videoModeBlueBits vm `between` (0, 32)
, GLFW.videoModeRefreshRate vm `between` (0, 120)
]
--------------------------------------------------------------------------------
tests :: GLFW.Monitor -> GLFW.Window -> [Test]
tests mon win =
[ testGroup "Initialization and version information"
[ testCase "getVersion" test_getVersion
, testCase "getVersionString" test_getVersionString
]
, testGroup "Monitor handling"
[ testCase "getMonitors" test_getMonitors
, testCase "getPrimaryMonitor" test_getPrimaryMonitor
, testCase "getMonitorPos" $ test_getMonitorPos mon
, testCase "getMonitorPhysicalSize" $ test_getMonitorPhysicalSize mon
, testCase "getMonitorName" $ test_getMonitorName mon
, testCase "getVideoModes" $ test_getVideoModes mon
, testCase "getVideoMode" $ test_getVideoMode mon
, testCase "getGamma" $ test_getGammaRamp mon
-- , testCase "setGamma" $ test_setGamma mon
-- , testCase "gamma ramp" $ test_gamma_ramp mon
]
, testGroup "Window handling"
[ testCase "defaultWindowHints" test_defaultWindowHints
, testCase "window close flag" $ test_window_close_flag win
, testCase "setWindowTitle" $ test_setWindowTitle win
, testCase "window pos" $ test_window_pos win
, testCase "window size" $ test_window_size win
, testCase "getFramebufferSize" $ test_getFramebufferSize win
, testCase "iconification" $ test_iconification win
-- , testCase "show/hide" $ test_show_hide win
, testCase "getWindowMonitor" $ test_getWindowMonitor win mon
, testCase "cursor pos" $ test_cursor_pos win
, testCase "getWindowFocused" $ test_getWindowFocused win
, testCase "getWindowResizable" $ test_getWindowResizable win
, testCase "getWindowDecorated" $ test_getWindowDecorated win
, testCase "getWindowClientAPI" $ test_getWindowClientAPI win
, testCase "window context version" $ test_window_context_version win
, testCase "getWindowContextRobustness" $ test_getWindowContextRobustness win
, testCase "getWindowOpenGLForwardCompat" $ test_getWindowOpenGLForwardCompat win
, testCase "getWindowOpenGLDebugContext" $ test_getWindowOpenGLDebugContext win
, testCase "getWindowOpenGLProfile" $ test_getWindowOpenGLProfile win
, testCase "pollEvents" test_pollEvents
, testCase "waitEvents" test_waitEvents
]
, testGroup "Input handling"
[ testCase "cursor input mode" $ test_cursor_input_mode win
, testCase "sticky keys input mode" $ test_sticky_keys_input_mode win
, testCase "sticky mouse buttons input mode" $ test_sticky_mouse_buttons_input_mode win
, testCase "joystickPresent" test_joystickPresent
, testCase "getJoystickAxes" test_getJoystickAxes
, testCase "getJoystickButtons" test_getJoystickButtons
, testCase "getJoystickName" test_getJoystickName
]
, testGroup "Time"
[ testCase "getTime" test_getTime
, testCase "setTime" test_setTime
]
, testGroup "Context"
[ testCase "getCurrentContext" $ test_getCurrentContext win
, testCase "swapBuffers" $ test_swapBuffers win
, testCase "swapInterval" test_swapInterval
, testCase "extensionSupported" test_extensionSupported
]
, testGroup "Clipboard"
[ testCase "clipboard" $ test_clipboard win
]
]
--------------------------------------------------------------------------------
test_getVersion :: IO ()
test_getVersion = do
v <- GLFW.getVersion
GLFW.versionMajor v @?= versionMajor
GLFW.versionMinor v @?= versionMinor
test_getVersionString :: IO ()
test_getVersionString = do
mvs <- GLFW.getVersionString
case mvs of
Just vs -> assertBool "" $ v `isPrefixOf` vs
Nothing -> assertFailure ""
where
v = intercalate "." $ map show [versionMajor, versionMinor]
test_getMonitors :: IO ()
test_getMonitors = do
r <- GLFW.getMonitors
case r of
Just ms -> assertBool "" $ (not . null) ms
Nothing -> assertFailure ""
test_getPrimaryMonitor :: IO ()
test_getPrimaryMonitor = do
r <- GLFW.getPrimaryMonitor
case r of
Just _ -> return ()
Nothing -> assertFailure ""
test_getMonitorPos :: GLFW.Monitor -> IO ()
test_getMonitorPos mon = do
(x, y) <- GLFW.getMonitorPos mon
assertBool "" $ x >= 0
assertBool "" $ y >= 0
test_getMonitorPhysicalSize :: GLFW.Monitor -> IO ()
test_getMonitorPhysicalSize mon = do
(w, h) <- GLFW.getMonitorPhysicalSize mon
assertBool "" $ w `between` (0, 1000)
assertBool "" $ h `between` (0, 500)
test_getMonitorName :: GLFW.Monitor -> IO ()
test_getMonitorName mon = do
mname <- GLFW.getMonitorName mon
case mname of
Nothing -> assertFailure ""
Just name -> do
assertBool "" $ length name `between` (0, 20)
assertBool "" $ all isAscii name
test_getVideoModes :: GLFW.Monitor -> IO ()
test_getVideoModes mon = do
mvms <- GLFW.getVideoModes mon
case mvms of
Nothing -> assertFailure ""
Just vms -> assertBool "" $ all videoModeLooksValid vms
test_getVideoMode :: GLFW.Monitor -> IO ()
test_getVideoMode mon = do
mvm <- GLFW.getVideoMode mon
case mvm of
Just vm -> assertBool "" $ videoModeLooksValid vm
Nothing -> assertFailure ""
test_getGammaRamp :: GLFW.Monitor -> IO ()
test_getGammaRamp mon = do
mgr <- GLFW.getGammaRamp mon
case mgr of
Nothing -> assertFailure ""
Just gr -> assertBool "" $
let rsl = length $ GLFW.gammaRampRed gr
gsl = length $ GLFW.gammaRampGreen gr
bsl = length $ GLFW.gammaRampBlue gr
in rsl > 0 && rsl == gsl && gsl == bsl
--------------------------------------------------------------------------------
test_defaultWindowHints :: IO ()
test_defaultWindowHints =
GLFW.defaultWindowHints
test_window_close_flag :: GLFW.Window -> IO ()
test_window_close_flag win = do
r0 <- GLFW.windowShouldClose win
r0 @?= False
GLFW.setWindowShouldClose win True
r1 <- GLFW.windowShouldClose win
r1 @?= True
GLFW.setWindowShouldClose win False
r2 <- GLFW.windowShouldClose win
r2 @?= False
test_setWindowTitle :: GLFW.Window -> IO ()
test_setWindowTitle win =
GLFW.setWindowTitle win "some new title"
-- This is a little strange. Depending on your window manager, etc, after
-- setting the window position to (x,y), the actual new window position might
-- be (x+5,y+5) due to borders. So we just check for consistency.
test_window_pos :: GLFW.Window -> IO ()
test_window_pos win = do
let x = 17
y = 37
xoff = 53
yoff = 149
(x0, y0, dx0, dy0) <- setGet x y
(x1, y1, dx1, dy1) <- setGet (x+xoff) (y+yoff)
dx0 @?= dx1
dy0 @?= dy1
x1 - x0 @?= xoff
y1 - y0 @?= yoff
where
setGet x0 y0 = do
GLFW.setWindowPos win x0 y0
giveItTime
(x1, y1) <- GLFW.getWindowPos win
let (dx, dy) = (x0-x1, y0-y1)
return (x1, y1, dx, dy)
test_window_size :: GLFW.Window -> IO ()
test_window_size win = do
let w = 17
h = 37
GLFW.setWindowSize win w h
giveItTime
(w', h') <- GLFW.getWindowSize win
w' @?= w
h' @?= h
test_getFramebufferSize :: GLFW.Window -> IO ()
test_getFramebufferSize win = do
(w, h) <- GLFW.getWindowSize win
(fw, fh) <- GLFW.getFramebufferSize win
-- Window size and framebuffer size are not always equal, an example are
-- retina screens. But maybe it's safe to assume they'll always be scaled
-- equally in both dimensions?
let ww = ( fromIntegral fw / fromIntegral w ) :: Double
hh = ( fromIntegral fh / fromIntegral h ) :: Double
ww @?= hh
assertBool "" $ fw /= 0
assertBool "" $ fh /= 0
test_iconification :: GLFW.Window -> IO ()
test_iconification win = do
is0 <- GLFW.getWindowIconified win
is0 @?= GLFW.IconifyState'NotIconified
GLFW.iconifyWindow win
giveItTime
is1 <- GLFW.getWindowIconified win
is1 @?= GLFW.IconifyState'Iconified
GLFW.restoreWindow win
-- test_show_hide :: GLFW.Window -> IO ()
-- test_show_hide win = do
-- v0 <- GLFW.getWindowVisible win
-- v0 @?= True
-- GLFW.hideWindow win
-- giveItTime
-- v1 <- GLFW.getWindowVisible win
-- v1 @?= False
-- GLFW.showWindow win
-- giveItTime
-- v2 <- GLFW.getWindowVisible win
-- v2 @?= True
test_getWindowMonitor :: GLFW.Window -> GLFW.Monitor -> IO ()
test_getWindowMonitor win _ = do
m <- GLFW.getWindowMonitor win
m @?= Nothing
test_cursor_pos :: GLFW.Window -> IO ()
test_cursor_pos win = do
(w, h) <- GLFW.getWindowSize win
let cx = fromIntegral w / 2
cy = fromIntegral h / 2
-- Can you set the cursor pos as of glfw 3.1? I don't see it in the
-- docs.
GLFW.setCursorPos win cx cy
--giveItTime
--(cx', cy') <- GLFW.getCursorPos win
--cx' @?= cx
--cy' @?= cy
test_getWindowFocused :: GLFW.Window -> IO ()
test_getWindowFocused win = do
fs <- GLFW.getWindowFocused win
fs @?= GLFW.FocusState'Defocused
test_getWindowResizable :: GLFW.Window -> IO ()
test_getWindowResizable win = do
b <- GLFW.getWindowResizable win
b @?= True
test_getWindowDecorated :: GLFW.Window -> IO ()
test_getWindowDecorated win = do
b <- GLFW.getWindowDecorated win
b @?= True
test_getWindowClientAPI :: GLFW.Window -> IO ()
test_getWindowClientAPI win = do
a <- GLFW.getWindowClientAPI win
a @?= GLFW.ClientAPI'OpenGL
test_window_context_version :: GLFW.Window -> IO ()
test_window_context_version win = do
v0 <- GLFW.getWindowContextVersionMajor win
v1 <- GLFW.getWindowContextVersionMinor win
v2 <- GLFW.getWindowContextVersionRevision win
assertBool "" $ all (`between` (0, 20)) [v0, v1, v2]
test_getWindowContextRobustness :: GLFW.Window -> IO ()
test_getWindowContextRobustness win = do
_ <- GLFW.getWindowContextRobustness win
return ()
test_getWindowOpenGLForwardCompat :: GLFW.Window -> IO ()
test_getWindowOpenGLForwardCompat win = do
_ <- GLFW.getWindowOpenGLForwardCompat win
return ()
test_getWindowOpenGLDebugContext :: GLFW.Window -> IO ()
test_getWindowOpenGLDebugContext win = do
_ <- GLFW.getWindowOpenGLDebugContext win
return ()
test_getWindowOpenGLProfile :: GLFW.Window -> IO ()
test_getWindowOpenGLProfile win = do
_ <- GLFW.getWindowOpenGLProfile win
return ()
test_pollEvents :: IO ()
test_pollEvents =
GLFW.pollEvents
test_waitEvents :: IO ()
test_waitEvents =
GLFW.waitEvents
--------------------------------------------------------------------------------
test_cursor_input_mode :: GLFW.Window -> IO ()
test_cursor_input_mode win = do
modes' <- mapM setGet modes
modes' @?= modes
where
modes =
[ GLFW.CursorInputMode'Disabled
, GLFW.CursorInputMode'Hidden
, GLFW.CursorInputMode'Normal
]
setGet m = do
GLFW.setCursorInputMode win m
GLFW.getCursorInputMode win
test_sticky_keys_input_mode :: GLFW.Window -> IO ()
test_sticky_keys_input_mode win = do
modes' <- mapM setGet modes
modes' @?= modes
where
modes =
[ GLFW.StickyKeysInputMode'Enabled
, GLFW.StickyKeysInputMode'Disabled
]
setGet m = do
GLFW.setStickyKeysInputMode win m
GLFW.getStickyKeysInputMode win
test_sticky_mouse_buttons_input_mode :: GLFW.Window -> IO ()
test_sticky_mouse_buttons_input_mode win = do
modes' <- mapM setGet modes
modes' @?= modes
where
modes =
[ GLFW.StickyMouseButtonsInputMode'Enabled
, GLFW.StickyMouseButtonsInputMode'Disabled
]
setGet m = do
GLFW.setStickyMouseButtonsInputMode win m
GLFW.getStickyMouseButtonsInputMode win
test_joystickPresent :: IO ()
test_joystickPresent = do
_ <- GLFW.joystickPresent GLFW.Joystick'1
r <- GLFW.joystickPresent GLFW.Joystick'16
assertBool "" $ not r
test_getJoystickAxes :: IO ()
test_getJoystickAxes =
mapM_ GLFW.getJoystickAxes joysticks
test_getJoystickButtons :: IO ()
test_getJoystickButtons =
mapM_ GLFW.getJoystickButtons joysticks
test_getJoystickName :: IO ()
test_getJoystickName =
mapM_ GLFW.getJoystickName joysticks
--------------------------------------------------------------------------------
test_getTime :: IO ()
test_getTime = do
mt <- GLFW.getTime
case mt of
Nothing -> assertFailure ""
Just t -> assertBool "" $ t `between` (0, 10)
test_setTime :: IO ()
test_setTime = do
let t = 37
GLFW.setTime t
mt <- GLFW.getTime
case mt of
Just t' -> assertBool "" $ t' `between` (t, t+10)
Nothing -> assertFailure ""
--------------------------------------------------------------------------------
test_getCurrentContext :: GLFW.Window -> IO ()
test_getCurrentContext win = do
mwin <- GLFW.getCurrentContext
case mwin of
Nothing -> assertFailure ""
Just win' -> win' @?= win
test_swapBuffers :: GLFW.Window -> IO ()
test_swapBuffers =
GLFW.swapBuffers
test_swapInterval :: IO ()
test_swapInterval =
GLFW.swapInterval 1
test_extensionSupported :: IO ()
test_extensionSupported = do
b0 <- GLFW.extensionSupported "GL_ARB_multisample"
b0 @?= True
b1 <- GLFW.extensionSupported "bogus"
b1 @?= False
--------------------------------------------------------------------------------
test_clipboard :: GLFW.Window -> IO ()
test_clipboard win = do
rs <- mapM setGet ss
rs @?= map Just ss
where
ss =
[ "abc 123 ???"
, "xyz 456 !!!"
]
setGet s = do
GLFW.setClipboardString win s
GLFW.getClipboardString win
--------------------------------------------------------------------------------
{-# ANN module "HLint: ignore Use camelCase" #-}