-- base
import Control.Concurrent (threadDelay)
import Control.Monad (forM, forM_, when)
import Data.Char (isAscii)
import Data.List (intercalate, isPrefixOf)
import Foreign.C.String (peekCString, withCString)
import Foreign.C.Types (CDouble(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (peekArray)
import Foreign.Ptr (Ptr, nullPtr, nullFunPtr)
import Foreign.Storable (Storable(..))
-- HUnit
import Test.HUnit ((@?=), (@?), assertBool, assertFailure)
-- test-framework
import Test.Framework (Test, defaultMain, testGroup)
-- test-framework-hunit
import Test.Framework.Providers.HUnit (testCase)
-- bindings-GLFW
import Bindings.GLFW
--------------------------------------------------------------------------------
main :: IO ()
main = do
cb <- mk'GLFWerrorfun $ \errnum p'desc -> do
desc <- if p'desc /= nullPtr
then peekCString p'desc
else return "unknown error"
putStrLn $ unwords ["###", "error:", show errnum, show desc]
_ <- c'glfwSetErrorCallback cb
-- uncomment next line to test error callback
-- _ <- c'glfwGetPrimaryMonitor
_ <- c'glfwInit
p'mon <- c'glfwGetPrimaryMonitor
c'glfwWindowHint c'GLFW_VISIBLE c'GLFW_FALSE
p'win <- withCString "bindings-GLFW test" $ \p'title ->
c'glfwCreateWindow 100 100 p'title nullPtr nullPtr
c'glfwMakeContextCurrent p'win
-- Mostly check for compiling
cmcb <- mk'GLFWcharmodsfun $ \win x y ->
putStrLn $ "Got char mods callback! " ++ show (win, x, y)
_ <- c'glfwSetCharModsCallback p'win cmcb
jcb <- mk'GLFWjoystickfun $ \x y ->
putStrLn $ "Got joystick callback! " ++ show (x, y)
_ <- c'glfwSetJoystickCallback jcb
defaultMain $ tests p'mon p'win
-- TODO because of how defaultMain works, this code is not reached
c'glfwDestroyWindow p'win
c'glfwTerminate
--------------------------------------------------------------------------------
versionMajor, versionMinor, versionRevision :: Int
versionMajor = 3
versionMinor = 2
versionRevision = 1
giveItTime :: IO ()
giveItTime = threadDelay 500000
joysticks :: Num a => [a]
joysticks =
[ c'GLFW_JOYSTICK_1
, c'GLFW_JOYSTICK_2
, c'GLFW_JOYSTICK_3
, c'GLFW_JOYSTICK_4
, c'GLFW_JOYSTICK_5
, c'GLFW_JOYSTICK_6
, c'GLFW_JOYSTICK_7
, c'GLFW_JOYSTICK_8
, c'GLFW_JOYSTICK_9
, c'GLFW_JOYSTICK_10
, c'GLFW_JOYSTICK_11
, c'GLFW_JOYSTICK_12
, c'GLFW_JOYSTICK_13
, c'GLFW_JOYSTICK_14
, c'GLFW_JOYSTICK_15
, c'GLFW_JOYSTICK_16
]
between :: Ord a => a -> (a,a) -> Bool
between n (l,h) = n >= l && n <= h
videoModeLooksValid :: C'GLFWvidmode -> Bool
videoModeLooksValid vm = and
[ c'GLFWvidmode'width vm `between` (0,4000)
, c'GLFWvidmode'height vm `between` (0,4000)
, c'GLFWvidmode'redBits vm `between` (0,32)
, c'GLFWvidmode'greenBits vm `between` (0,32)
, c'GLFWvidmode'blueBits vm `between` (0,32)
, c'GLFWvidmode'refreshRate vm `between` (0,120)
]
--------------------------------------------------------------------------------
tests :: Ptr C'GLFWmonitor -> Ptr C'GLFWwindow -> [Test]
tests p'mon p'win =
[ testGroup "Initialization and version information"
[ testCase "glfwGetVersion" test_glfwGetVersion
, testCase "glfwGetVersionString" test_glfwGetVersionString
]
, testGroup "Monitor handling"
[ testCase "glfwGetMonitors" test_glfwGetMonitors
, testCase "glfwGetPrimaryMonitor" test_glfwGetPrimaryMonitor
, testCase "glfwGetMonitorPos" $ test_glfwGetMonitorPos p'mon
, testCase "glfwGetMonitorPhysicalSize" $ test_glfwGetMonitorPhysicalSize p'mon
, testCase "glfwGetMonitorName" $ test_glfwGetMonitorName p'mon
, testCase "glfwGetVideoModes" $ test_glfwGetVideoModes p'mon
, testCase "glfwGetVideoMode" $ test_glfwGetVideoMode p'mon
, testCase "glfwGetGammaRamp" $ test_glfwGetGammaRamp p'mon
-- , testCase "setGamma" $ test_glfwSetGamma p'mon
-- , testCase "gamma ramp" $ test_glfwGamma_ramp p'mon
]
, testGroup "Window handling"
[ testCase "glfwDefaultWindowHints" test_glfwDefaultWindowHints
, testCase "glfwGetWindowAttrib" $ test_glfwGetWindowAttrib p'win
, testCase "window close flag" $ test_window_close_flag p'win
, testCase "glfwSetWindowTitle" $ test_glfwSetWindowTitle p'win
, testCase "window pos" $ test_window_pos p'win
, testCase "window size" $ test_window_size p'win
, testCase "glfwGetWindowFrameSize" $ test_glfwGetWindowFrameSize p'win
, testCase "glfwGetFramebufferSize" $ test_glfwGetFramebufferSize p'win
, testCase "iconification" $ test_iconification p'win
-- , testCase "show/hide" $ test_show_hide p'win
, testCase "glfwGetWindowMonitor" $ test_glfwGetWindowMonitor p'win p'mon
, testCase "glfwSetWindowMonitor" $ test_glfwSetWindowMonitor p'win p'mon
, testCase "glfwSetWindowIcon" $ test_glfwSetWindowIcon p'win
, testCase "glfwMaximizeWindow" $ test_glfwMaximizeWindow p'win
, testCase "glfwSetWindowSizeLimits" $ test_glfwSetWindowSizeLimits p'win
, testCase "glfwSetWindowAspectRatio" $ test_glfwSetWindowAspectRatio p'win
, testCase "glfwFocusWindow" $ test_glfwFocusWindow p'win
, testCase "cursor pos" $ test_cursor_pos p'win
, testCase "glfwPollEvents" test_glfwPollEvents
, testCase "glfwWaitEvents" test_glfwWaitEvents
, testCase "glfwWaitEventsTimeout" test_glfwWaitEventsTimeout
]
, testGroup "Input handling"
[ testCase "glfwJoystickPresent" test_glfwJoystickPresent
, testCase "glfwGetJoystickAxes" test_glfwGetJoystickAxes
, testCase "glfwGetJoystickButtons" test_glfwGetJoystickButtons
, testCase "glfwGetJoystickName" test_glfwGetJoystickName
, testCase "glfwGetKeyName" test_glfwGetKeyName
]
, testGroup "Time"
[ testCase "glfwGetTime" test_glfwGetTime
, testCase "glfwSetTime" test_glfwSetTime
]
, testGroup "Timers"
[ testCase "glfwGetTimerValue" test_glfwGetTimerValue
, testCase "glfwSetTimerFrequency" test_glfwGetTimerFrequency
]
, testGroup "Context"
[ testCase "glfwGetCurrentContext" $ test_glfwGetCurrentContext p'win
, testCase "glfwSwapBuffers" $ test_glfwSwapBuffers p'win
, testCase "glfwSwapInterval" test_glfwSwapInterval
, testCase "glfwExtensionSupported" test_glfwExtensionSupported
]
, testGroup "Clipboard"
[ testCase "clipboard" $ test_clipboard p'win
]
, testGroup "Vulkan"
[ testCase "glfwVulkanSupported" test_glfwVulkanSupported
, testCase "glfwGetRequiredInstanceExtensions" test_glfwGetRequiredInstanceExtensions
, testCase "glfwGetInstanceProcAddress" test_glfwGetInstanceProcAddress
, testCase "glfwGetPhysicalDevicePresentationSupport" test_glfwGetPhysicalDevicePresentationSupport
, testCase "glfwCreateWindowSurface" $ test_glfwCreateWindowSurface p'win
]
]
--------------------------------------------------------------------------------
test_glfwGetVersion :: IO ()
test_glfwGetVersion =
alloca $ \p'v0 ->
alloca $ \p'v1 ->
alloca $ \p'v2 -> do
c'glfwGetVersion p'v0 p'v1 p'v2
v0 <- peek p'v0
v1 <- peek p'v1
v2 <- peek p'v2
v0 @?= fromIntegral versionMajor
v1 @?= fromIntegral versionMinor
v2 @?= fromIntegral versionRevision
test_glfwGetVersionString :: IO ()
test_glfwGetVersionString = do
p'vs <- c'glfwGetVersionString
if p'vs == nullPtr
then assertFailure ""
else do
vs <- peekCString p'vs
assertBool "" $ v `isPrefixOf` vs
where
v = intercalate "." $ map show [versionMajor, versionMinor, versionRevision]
--------------------------------------------------------------------------------
test_glfwGetMonitors :: IO ()
test_glfwGetMonitors =
alloca $ \p'n -> do
p'mons <- c'glfwGetMonitors p'n
n <- peek p'n
if p'mons == nullPtr || n <= 0
then assertFailure ""
else do
mons <- peekArray (fromIntegral n) p'mons
assertBool "" $ not $ null mons
test_glfwGetPrimaryMonitor :: IO ()
test_glfwGetPrimaryMonitor = do
p'mon <- c'glfwGetPrimaryMonitor
assertBool "" $ p'mon /= nullPtr
test_glfwGetMonitorPos :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetMonitorPos p'mon =
alloca $ \p'x ->
alloca $ \p'y -> do
c'glfwGetMonitorPos p'mon p'x p'y
x <- peek p'x
y <- peek p'y
assertBool "" $ x >= 0
assertBool "" $ y >= 0
test_glfwGetMonitorPhysicalSize :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetMonitorPhysicalSize p'mon =
alloca $ \p'w ->
alloca $ \p'h -> do
c'glfwGetMonitorPhysicalSize p'mon p'w p'h
w <- peek p'w
h <- peek p'h
assertBool "" $ w `between` (0, 1000)
assertBool "" $ h `between` (0, 500)
test_glfwGetMonitorName :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetMonitorName p'mon = do
p'name <- c'glfwGetMonitorName p'mon
if p'name == nullPtr
then assertFailure ""
else do
name <- peekCString p'name
assertBool "" $ length name `between` (0, 20)
assertBool "" $ all isAscii name
test_glfwGetVideoModes :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetVideoModes p'mon =
alloca $ \p'n -> do
p'vms <- c'glfwGetVideoModes p'mon p'n
n <- fromIntegral `fmap` peek p'n
if p'vms == nullPtr || n <= 0
then assertFailure ""
else do
vms <- peekArray n p'vms
assertBool "" $ all videoModeLooksValid vms
test_glfwGetVideoMode :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetVideoMode p'mon = do
p'vm <- c'glfwGetVideoMode p'mon
if p'vm == nullPtr
then assertFailure ""
else do
vm <- peek p'vm
assertBool "" $ videoModeLooksValid vm
test_glfwGetGammaRamp :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetGammaRamp p'mon = do
p'gr <- c'glfwGetGammaRamp p'mon
if p'gr == nullPtr
then assertFailure ""
else do
gr <- peek p'gr
let p'rs = c'GLFWgammaramp'red gr
p'gs = c'GLFWgammaramp'green gr
p'bs = c'GLFWgammaramp'blue gr
cn = c'GLFWgammaramp'size gr
n = fromIntegral cn
if nullPtr `elem` [p'rs, p'gs, p'bs]
then assertFailure ""
else do
rs <- peekArray n p'rs
gs <- peekArray n p'gs
bs <- peekArray n p'bs
let rsl = length rs
gsl = length gs
bsl = length bs
assertBool "" $ rsl > 0 && rsl == gsl && gsl == bsl
--------------------------------------------------------------------------------
test_glfwDefaultWindowHints :: IO ()
test_glfwDefaultWindowHints =
c'glfwDefaultWindowHints
test_window_close_flag :: Ptr C'GLFWwindow -> IO ()
test_window_close_flag p'win = do
r0 <- c'glfwWindowShouldClose p'win
r0 @?= c'GLFW_FALSE
c'glfwSetWindowShouldClose p'win c'GLFW_TRUE
r1 <- c'glfwWindowShouldClose p'win
r1 @?= c'GLFW_TRUE
c'glfwSetWindowShouldClose p'win c'GLFW_FALSE
r2 <- c'glfwWindowShouldClose p'win
r2 @?= c'GLFW_FALSE
test_glfwSetWindowTitle :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowTitle p'win =
withCString "some new title" $
c'glfwSetWindowTitle p'win
-- 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 :: Ptr C'GLFWwindow -> IO ()
test_window_pos p'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 :: Int -> Int -> IO (Int, Int, Int, Int)
setGet x0 y0 = do
c'glfwSetWindowPos p'win (fromIntegral x0) (fromIntegral y0)
c'glfwSwapBuffers p'win
giveItTime
alloca $ \p'x1 ->
alloca $ \p'y1 -> do
c'glfwGetWindowPos p'win p'x1 p'y1
x1 <- fromIntegral `fmap` peek p'x1
y1 <- fromIntegral `fmap` peek p'y1
let (dx, dy) = (x0-x1, y0-y1)
return (x1, y1, dx, dy)
test_window_size :: Ptr C'GLFWwindow -> IO ()
test_window_size p'win = do
let w = 177
h = 372
c'glfwSetWindowSize p'win w h
giveItTime
alloca $ \p'w' ->
alloca $ \p'h' -> do
c'glfwGetWindowSize p'win p'w' p'h'
w' <- fromIntegral `fmap` peek p'w'
h' <- fromIntegral `fmap` peek p'h'
w' @?= w
h' @?= h
-- Really all we can say here is that we likely have a title bar, so just check
-- that the 'frame' around the top edge is > 0.
test_glfwGetWindowFrameSize :: Ptr C'GLFWwindow -> IO ()
test_glfwGetWindowFrameSize p'win =
alloca $ \p'win_frame_top -> do
c'glfwGetWindowFrameSize p'win nullPtr p'win_frame_top nullPtr nullPtr
top <- peek p'win_frame_top
assertBool "Window has no frame width up top!" $ top > 0
test_glfwGetFramebufferSize :: Ptr C'GLFWwindow -> IO ()
test_glfwGetFramebufferSize p'win =
alloca $ \p'w ->
alloca $ \p'h ->
alloca $ \p'fw ->
alloca $ \p'fh -> do
c'glfwGetWindowSize p'win p'w p'h
c'glfwGetFramebufferSize p'win p'fw p'fh
w <- peek p'w
h <- peek p'h
fw <- peek p'fw
fh <- peek p'fh
((fw `mod` w) == 0) @? "Framebuffer width multiple of window's"
((fh `mod` h) == 0) @? "Framebuffer height multiple of window's"
test_iconification :: Ptr C'GLFWwindow -> IO ()
test_iconification p'win = do
c'glfwShowWindow p'win
r0 <- c'glfwGetWindowAttrib p'win c'GLFW_ICONIFIED
r0 @?= c'GLFW_FALSE
c'glfwIconifyWindow p'win
giveItTime
r1 <- c'glfwGetWindowAttrib p'win c'GLFW_ICONIFIED
r1 @?= c'GLFW_TRUE
c'glfwRestoreWindow p'win
c'glfwHideWindow p'win
-- test_show_hide :: Ptr C'GLFWwindow -> IO ()
-- test_show_hide p'win = do
-- v0 <- c'glfwGetWindowAttrib p'win c'GLFW_VISIBLE
-- v0 @?= c'GLFW_FALSE
-- c'glfwShowWindow p'win
-- giveItTime
-- v1 <- c'glfwGetWindowAttrib p'win c'GLFW_VISIBLE
-- v1 @?= c'GLFW_TRUE
-- c'glfwHideWindow p'win
-- giveItTime
-- v2 <- c'glfwGetWindowAttrib p'win c'GLFW_VISIBLE
-- v2 @?= c'GLFW_FALSE
test_glfwGetWindowMonitor :: Ptr C'GLFWwindow -> Ptr C'GLFWmonitor -> IO ()
test_glfwGetWindowMonitor p'win _ = do
p'mon <- c'glfwGetWindowMonitor p'win
p'mon @?= nullPtr
test_glfwSetWindowMonitor :: Ptr C'GLFWwindow -> Ptr C'GLFWmonitor -> IO ()
test_glfwSetWindowMonitor p'win _ = do
c'glfwSetWindowMonitor p'win nullPtr 0 0 100 100 60
test_glfwSetWindowIcon :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowIcon p'win = do
c'glfwSetWindowIcon p'win 0 nullPtr
test_glfwSetWindowSizeLimits :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowSizeLimits p'win = do
c'glfwSetWindowSizeLimits p'win 640 480 1024 768
test_glfwSetWindowAspectRatio :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowAspectRatio p'win = do
c'glfwSetWindowAspectRatio p'win c'GLFW_DONT_CARE c'GLFW_DONT_CARE
test_glfwFocusWindow :: Ptr C'GLFWwindow -> IO ()
test_glfwFocusWindow = c'glfwFocusWindow
-- NOTE: This test seems to fail in X11. This might be due to the asynchronous
-- nature of focus events in X. We may be able to fix it by waiting for the focus
-- event before setting the cursor position.
test_cursor_pos :: Ptr C'GLFWwindow -> IO ()
test_cursor_pos p'win =
alloca $ \p'w ->
alloca $ \p'h ->
alloca $ \p'cx' ->
alloca $ \p'cy' -> do
c'glfwShowWindow p'win
c'glfwGetWindowSize p'win p'w p'h
w <- peek p'w
h <- peek p'h
-- Make sure we use integral coordinates here so that we don't run into
-- platform-dependent differences.
let cx :: CDouble
cy :: CDouble
(cx, cy) = (fromIntegral $ w `div` 2, fromIntegral $ h `div` 2)
-- !HACK! Poll events seems to be necessary on OS X,
-- before /and/ after glfwSetCursorPos, otherwise, the
-- windowing system likely never receives the cursor update. This is
-- reflected in the C version of GLFW as well, we just call it here in
-- order to have a more robust test.
c'glfwPollEvents
c'glfwSetCursorPos p'win cx cy
c'glfwPollEvents -- !HACK! see comment above
c'glfwGetCursorPos p'win p'cx' p'cy'
cx' <- peek p'cx'
cy' <- peek p'cy'
cx' @?= cx
cy' @?= cy
c'glfwHideWindow p'win
test_glfwGetWindowAttrib :: Ptr C'GLFWwindow -> IO ()
test_glfwGetWindowAttrib p'win = do
let pairs =
[ ( c'GLFW_FOCUSED, c'GLFW_FALSE )
, ( c'GLFW_ICONIFIED, c'GLFW_FALSE )
, ( c'GLFW_RESIZABLE, c'GLFW_TRUE )
, ( c'GLFW_DECORATED, c'GLFW_TRUE )
, ( c'GLFW_CLIENT_API, c'GLFW_OPENGL_API )
]
rs <- mapM (c'glfwGetWindowAttrib p'win . fst) pairs
rs @?= map snd pairs
test_glfwMaximizeWindow :: Ptr C'GLFWwindow -> IO ()
test_glfwMaximizeWindow p'win = do
c'glfwShowWindow p'win
startsMaximized <- c'glfwGetWindowAttrib p'win c'GLFW_MAXIMIZED
startsMaximized @?= c'GLFW_FALSE
c'glfwMaximizeWindow p'win
giveItTime
isMaximized <- c'glfwGetWindowAttrib p'win c'GLFW_MAXIMIZED
isMaximized @?= c'GLFW_TRUE
c'glfwHideWindow p'win
test_glfwPollEvents :: IO ()
test_glfwPollEvents =
c'glfwPollEvents
test_glfwWaitEvents :: IO ()
test_glfwWaitEvents = c'glfwPostEmptyEvent >> c'glfwWaitEvents
test_glfwWaitEventsTimeout :: IO ()
test_glfwWaitEventsTimeout =
-- to not slow down the test too much we set the timeout to 0.001 second :
c'glfwWaitEventsTimeout 0.001
--------------------------------------------------------------------------------
test_glfwJoystickPresent :: IO ()
test_glfwJoystickPresent = do
_ <- c'glfwJoystickPresent c'GLFW_JOYSTICK_1
r <- c'glfwJoystickPresent c'GLFW_JOYSTICK_16
r @?= c'GLFW_FALSE
test_glfwGetJoystickAxes :: IO ()
test_glfwGetJoystickAxes =
forM_ joysticks $ \js ->
alloca $ \p'n -> do
p'axes <- c'glfwGetJoystickAxes js p'n
when (p'axes /= nullPtr) $ do
n <- fromIntegral `fmap` peek p'n
if n <= 0
then assertFailure ""
else do
axes <- peekArray n p'axes
length axes @?= n
test_glfwGetJoystickButtons :: IO ()
test_glfwGetJoystickButtons =
forM_ joysticks $ \js ->
alloca $ \p'n -> do
p'buttons <- c'glfwGetJoystickButtons js p'n
when (p'buttons /= nullPtr) $ do
n <- fromIntegral `fmap` peek p'n
if n <= 0
then assertFailure ""
else do
buttons <- peekArray n p'buttons
length buttons @?= n
test_glfwGetJoystickName :: IO ()
test_glfwGetJoystickName =
forM_ joysticks $ \js -> do
p'name <- c'glfwGetJoystickName js
when (p'name /= nullPtr) $ do
name <- peekCString p'name
assertBool "" $ not $ null name
test_glfwGetKeyName :: IO ()
test_glfwGetKeyName =
forM_ [c'GLFW_KEY_SLASH, c'GLFW_KEY_PERIOD] $ \k -> do
p'name <- c'glfwGetKeyName k 0
when (p'name /= nullPtr) $ do
name <- peekCString p'name
assertBool "" $ not $ null name
--------------------------------------------------------------------------------
test_glfwGetTime :: IO ()
test_glfwGetTime = do
t <- c'glfwGetTime
assertBool "" $ t > 0
test_glfwSetTime :: IO ()
test_glfwSetTime = do
let t = 37 :: Double
c'glfwSetTime (realToFrac t)
t' <- realToFrac `fmap` c'glfwGetTime
assertBool "" $ t' `between` (t, t+10)
--------------------------------------------------------------------------------
test_glfwGetTimerValue :: IO ()
test_glfwGetTimerValue = do
val <- c'glfwGetTimerValue
assertBool "" $ val > 0
test_glfwGetTimerFrequency :: IO ()
test_glfwGetTimerFrequency = do
freq <- c'glfwGetTimerFrequency
assertBool "" $ freq > 0
--------------------------------------------------------------------------------
test_glfwGetCurrentContext :: Ptr C'GLFWwindow -> IO ()
test_glfwGetCurrentContext p'win = do
p'win' <- c'glfwGetCurrentContext
p'win' @?= p'win
test_glfwSwapBuffers :: Ptr C'GLFWwindow -> IO ()
test_glfwSwapBuffers =
c'glfwSwapBuffers
test_glfwSwapInterval :: IO ()
test_glfwSwapInterval =
c'glfwSwapInterval 1
test_glfwExtensionSupported :: IO ()
test_glfwExtensionSupported = do
let pairs =
[ ( "GL_ARB_multisample", c'GLFW_TRUE )
, ( "bogus", c'GLFW_FALSE )
]
rs <- forM (map fst pairs) $ \ext ->
withCString ext c'glfwExtensionSupported
rs @?= map snd pairs
--------------------------------------------------------------------------------
test_clipboard :: Ptr C'GLFWwindow -> IO ()
test_clipboard p'win = do
rs <- mapM setGet ss
rs @?= ss
where
ss =
[ "abc 123 ???"
, "xyz 456 !!!"
]
setGet s = do
withCString s $ \p's ->
c'glfwSetClipboardString p'win p's
threadDelay 100000 -- Give it a little time
p's' <- c'glfwGetClipboardString p'win
if p's' == nullPtr
then return ""
else peekCString p's'
--------------------------------------------------------------------------------
test_glfwVulkanSupported :: IO ()
test_glfwVulkanSupported =
-- Just test that it doesn't error. If it does, then we have a problem, but
-- some platforms (like OS X) don't actually support vulkan.
c'glfwVulkanSupported >> return ()
test_glfwGetRequiredInstanceExtensions :: IO ()
test_glfwGetRequiredInstanceExtensions = do
support <- c'glfwVulkanSupported
if (support == 1)
then alloca $ \p'count ->
c'glfwGetRequiredInstanceExtensions p'count >> return ()
else return ()
test_glfwGetInstanceProcAddress :: IO ()
test_glfwGetInstanceProcAddress = do
support <- c'glfwVulkanSupported
if support == 1
then do
shouldBeNull <- withCString "notafunction" $
\s -> c'glfwGetInstanceProcAddress nullPtr s
shouldBeNull @?= nullFunPtr
assertBool "Function pointer is defined!" $
p'glfwGetInstanceProcAddress /= nullFunPtr
else return ()
test_glfwGetPhysicalDevicePresentationSupport :: IO ()
test_glfwGetPhysicalDevicePresentationSupport = do
-- We don't really have the proper types to test this function
support <- c'glfwVulkanSupported
if support == 1
then do
shouldBeFalse <-
c'glfwGetPhysicalDevicePresentationSupport nullPtr nullPtr 0
shouldBeFalse @?= c'GLFW_FALSE
assertBool "Function pointer is defined!" $
p'glfwGetPhysicalDevicePresentationSupport /= nullFunPtr
else return ()
test_glfwCreateWindowSurface :: Ptr C'GLFWwindow -> IO ()
test_glfwCreateWindowSurface p'win = do
-- We don't really have the proper types to test this function
support <- c'glfwVulkanSupported
if support == 1
then do
alloca $ \p'surface -> do
let resPtr = p'surface :: Ptr ()
shouldNotBeSuccessful <-
c'glfwCreateWindowSurface nullPtr p'win nullPtr resPtr
assertBool "c'glfwCreateSurface was successful??" $
shouldNotBeSuccessful /= 0
assertBool "Function pointer is defined!" $
p'glfwCreateWindowSurface /= nullFunPtr
else return ()
{-# ANN module "HLint: ignore Use camelCase" #-}