Test.hs

-- 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, assertEqual)

-- 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
    c'glfwInitHint c'GLFW_COCOA_CHDIR_RESOURCES c'GLFW_FALSE
    _ <- 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
    wcscb <- mk'GLFWwindowcontentscalefun $ \win x y ->
        putStrLn $ "Got window content scale callback! " ++ show (win, x, y)
    _ <- c'glfwSetWindowContentScaleCallback p'win wcscb

    c'glfwGetError nullPtr
      >>= assertEqual "Got inititialization error!" c'GLFW_NO_ERROR

    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    = 3
versionRevision = 2

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,8192)
    , c'GLFWvidmode'height      vm `between` (0,8192)
    , 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,240)
    ]

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

glfwTest :: String -> IO () -> Test
glfwTest name test = testCase name $ do
  _ <- c'glfwGetError nullPtr  -- clear last error
  test
  alloca $ \p'errMsg -> do
    errResult <- c'glfwGetError p'errMsg
    errMsg <- if errResult == c'GLFW_NO_ERROR then return "" else do
      msg <- peek p'errMsg >>= peekCString
      return $ concat ["Test '", name, "' generated error: ", msg]
    assertEqual errMsg errResult c'GLFW_NO_ERROR

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
      , testCase "glfwGetError"         test_glfwGetError
      , testCase "glfwRawMouseMotionSupported" test_glfwRawMouseMotionSupported
      ]
    , testGroup "Monitor handling"
      [ glfwTest "glfwGetMonitors"              test_glfwGetMonitors
      , glfwTest "glfwGetPrimaryMonitor"        test_glfwGetPrimaryMonitor
      , glfwTest "glfwGetMonitorContentScale" $ test_glfwGetMonitorContentScale p'mon
      , glfwTest "glfwGetMonitorPos"          $ test_glfwGetMonitorPos p'mon
      , glfwTest "glfwGetMonitorPhysicalSize" $ test_glfwGetMonitorPhysicalSize p'mon
      , glfwTest "glfwGetMonitorName"         $ test_glfwGetMonitorName p'mon
      , glfwTest "glfwGetMonitorWorkarea"     $ test_glfwGetMonitorWorkarea p'mon
      , glfwTest "glfwGetVideoModes"          $ test_glfwGetVideoModes p'mon
      , glfwTest "glfwGetVideoMode"           $ test_glfwGetVideoMode p'mon
      , glfwTest "glfwGetGammaRamp"           $ test_glfwGetGammaRamp p'mon
      ]
    , testGroup "Window handling"
      [ glfwTest "glfwDefaultWindowHints"       test_glfwDefaultWindowHints
      , glfwTest "glfwGetWindowAttrib"        $ test_glfwGetWindowAttrib p'win
      , glfwTest "glfwSetWindowAttrib"        $ test_glfwSetWindowAttrib p'win
      , glfwTest "window close flag"          $ test_window_close_flag p'win
      , glfwTest "glfwSetWindowTitle"         $ test_glfwSetWindowTitle p'win
      , glfwTest "window pos"                 $ test_window_pos p'win
      , glfwTest "window size"                $ test_window_size p'win
      , glfwTest "glfwGetWindowContentSize"   $ test_glfwGetWindowContentScale p'win
      , glfwTest "glfwGetWindowFrameSize"     $ test_glfwGetWindowFrameSize p'win
      , glfwTest "glfwGetFramebufferSize"     $ test_glfwGetFramebufferSize p'win
      , glfwTest "iconification"              $ test_iconification p'win
      -- , glfwTest "show/hide"                  $ test_show_hide p'win
      , glfwTest "glfwGetWindowMonitor"       $ test_glfwGetWindowMonitor p'win p'mon
      , glfwTest "glfwSetWindowMonitor"       $ test_glfwSetWindowMonitor p'win p'mon
      , glfwTest "glfwSetWindowIcon"          $ test_glfwSetWindowIcon p'win
      , glfwTest "glfwSetWindowOpacity"       $ test_glfwSetWindowOpacity p'win
      , glfwTest "glfwMaximizeWindow"         $ test_glfwMaximizeWindow p'win
      , glfwTest "glfwSetWindowSizeLimits"    $ test_glfwSetWindowSizeLimits p'win
      , glfwTest "glfwSetWindowAspectRatio"   $ test_glfwSetWindowAspectRatio p'win
      , glfwTest "glfwFocusWindow"            $ test_glfwFocusWindow p'win
      , glfwTest "glfwRequestWindowAttention" $ test_glfwRequestWindowAttention p'win
      , glfwTest "cursor pos"                 $ test_cursor_pos p'win
      , glfwTest "glfwPollEvents"               test_glfwPollEvents
      , glfwTest "glfwWaitEvents"               test_glfwWaitEvents
      , glfwTest "glfwWaitEventsTimeout"        test_glfwWaitEventsTimeout
      ]
    , testGroup "Input handling"
      [ glfwTest "glfwJoystickPresent"    test_glfwJoystickPresent
      , glfwTest "glfwGetJoystickAxes"    test_glfwGetJoystickAxes
      , glfwTest "glfwGetJoystickButtons" test_glfwGetJoystickButtons
      , glfwTest "glfwGetJoystickHats"    test_glfwGetJoystickHats
      , glfwTest "glfwGetJoystickName"    test_glfwGetJoystickName
      , glfwTest "glfwGetJoystickGUID"    test_glfwGetJoystickGUID
      , glfwTest "glfwGetGamepadState"    test_glfwGetGamepadState
      , glfwTest "glfwGetKeyName"         test_glfwGetKeyName
      , glfwTest "glfwGetKeyScancode"     test_glfwGetKeyScancode
      ]
    , testGroup "Time"
      [ glfwTest "glfwGetTime"               test_glfwGetTime
      , glfwTest "glfwSetTime"               test_glfwSetTime
      , glfwTest "glfwGetTimerValue"         test_glfwGetTimerValue
      , glfwTest "glfwSetTimerFrequency"     test_glfwGetTimerFrequency
      ]
    , testGroup "Context"
      [ glfwTest "glfwGetCurrentContext"  $ test_glfwGetCurrentContext p'win
      , glfwTest "glfwSwapBuffers"        $ test_glfwSwapBuffers p'win
      , glfwTest "glfwSwapInterval"         test_glfwSwapInterval
      , glfwTest "glfwExtensionSupported"   test_glfwExtensionSupported
      ]
    , testGroup "Clipboard"
      [ glfwTest "clipboard" $ test_clipboard p'win
      ]
    , testGroup "Vulkan"
      [ glfwTest "glfwVulkanSupported"                          test_glfwVulkanSupported
      , glfwTest "glfwGetRequiredInstanceExtensions"            test_glfwGetRequiredInstanceExtensions
      , glfwTest "glfwGetInstanceProcAddress"                   test_glfwGetInstanceProcAddress
      , glfwTest "glfwGetPhysicalDevicePresentationSupport"     test_glfwGetPhysicalDevicePresentationSupport
      , glfwTest "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_glfwGetError :: IO ()
test_glfwGetError =
  alloca $ \p'err ->
  c'glfwGetError p'err >>= assertEqual "Discovered GLFW error!" c'GLFW_NO_ERROR

test_glfwRawMouseMotionSupported :: IO ()
test_glfwRawMouseMotionSupported = c'glfwRawMouseMotionSupported >> return ()

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

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_glfwGetMonitorContentScale :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetMonitorContentScale p'mon =
    alloca $ \p'x ->
    alloca $ \p'y -> do
        c'glfwGetMonitorContentScale p'mon p'x p'y
        x <- peek p'x
        y <- peek p'y
        assertBool "Monitor content scale x is defined" $ x > 0
        assertBool "Monitor content scale y is defined" $ y > 0

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_glfwGetMonitorWorkarea :: Ptr C'GLFWmonitor -> IO ()
test_glfwGetMonitorWorkarea p'mon =
    alloca $ \p'xpos ->
    alloca $ \p'ypos ->
    alloca $ \p'w ->
    alloca $ \p'h -> do
        c'glfwGetMonitorWorkarea p'mon p'xpos p'ypos p'w p'h
        xpos <- peek p'xpos
        ypos <- peek p'ypos
        w <- peek p'w
        h <- peek p'h
        assertBool "Workarea xpos not negative" $ xpos >= 0
        assertBool "Workarea ypos not negative" $ ypos >= 0
        assertBool "Workarea width is positive" $ w > 0
        assertBool "Workarea height is positive" $ h > 0

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_glfwGetWindowContentScale :: Ptr C'GLFWwindow -> IO ()
test_glfwGetWindowContentScale p'win =
    alloca $ \p'x ->
    alloca $ \p'y -> do
        c'glfwGetWindowContentScale p'win p'x p'y
        x <- peek p'x
        y <- peek p'y
        assertBool "Window content scale x is defined" $ x > 0
        assertBool "Window content scale y is defined" $ y > 0

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_glfwSetWindowOpacity :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowOpacity p'win = do
    let desiredOpacity = 0.27
    c'glfwSetWindowOpacity p'win desiredOpacity
    newOpacity <- c'glfwGetWindowOpacity p'win
    assertBool "Opacity is roughly the same." $
        abs (desiredOpacity - newOpacity) < 0.01
    c'glfwSetWindowOpacity p'win 1.0

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

test_glfwRequestWindowAttention :: Ptr C'GLFWwindow -> IO ()
test_glfwRequestWindowAttention = c'glfwRequestWindowAttention

-- 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_glfwSetWindowAttrib :: Ptr C'GLFWwindow -> IO ()
test_glfwSetWindowAttrib p'win = do
    c'glfwSetWindowAttrib p'win c'GLFW_RESIZABLE c'GLFW_FALSE
    norsz <- c'glfwGetWindowAttrib p'win c'GLFW_RESIZABLE
    norsz @?= c'GLFW_FALSE

    c'glfwSetWindowAttrib p'win c'GLFW_RESIZABLE c'GLFW_TRUE
    rsz <- c'glfwGetWindowAttrib p'win c'GLFW_RESIZABLE
    rsz @?= c'GLFW_TRUE

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_glfwGetJoystickHats :: IO ()
test_glfwGetJoystickHats =
    forM_ joysticks $ \js ->
        alloca $ \p'n -> do
            p'hats <- c'glfwGetJoystickHats js p'n
            when (p'hats /= nullPtr) $ do
                n <- fromIntegral `fmap` peek p'n
                if n <= 0
                  then assertFailure "No joystick hats??"
                  else do
                      hats <- peekArray n p'hats
                      length hats @?= n
                      forM_ hats $ assertEqual "Hat is centered" c'GLFW_HAT_CENTERED

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_glfwGetJoystickGUID :: IO ()
test_glfwGetJoystickGUID =
    forM_ joysticks $ \js -> do
        p'guid <- c'glfwGetJoystickGUID js
        when (p'guid /= nullPtr) $ do
            guid <- peekCString p'guid
            assertBool "" $ not $ null guid

test_glfwGetGamepadState :: IO ()
test_glfwGetGamepadState =
    forM_ joysticks $ \js ->
        alloca $ \p'gp -> do
            gotMapping <- c'glfwGetGamepadState js p'gp
            when (gotMapping == c'GLFW_TRUE) $ do
                assertBool "Gamepad state is valid" (p'gp /= nullPtr)

                c'glfwJoystickIsGamepad js
                  >>= assertEqual "Is gamepad" c'GLFW_TRUE

                c'glfwGetGamepadName js
                  >>= peekCString
                  >>= assertBool "Gamepad has name" . not . null

                gp <- peek p'gp
                forM_ (c'GLFWgamepadstate'buttons gp) $
                  assertEqual "Button not pressed" c'GLFW_RELEASE

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_glfwGetKeyScancode :: IO ()
test_glfwGetKeyScancode = do
    forM_ [c'GLFW_KEY_SLASH, c'GLFW_KEY_PERIOD] $ \k -> do
        sc <- c'glfwGetKeyScancode k
        assertBool (mconcat ["Key ", show k, " scancode not found."]) (sc > 0)

    -- According to the docs this should work but it returns 0. This is a GLFW
    -- bug (at least on OS X).
    -- c'glfwGetKeyScancode c'GLFW_KEY_UNKNOWN >>= assertEqual "" (-1)

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

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 $ c'glfwSetClipboardString p'win
        threadDelay 100000  -- Give it a little time
        p's' <- c'glfwGetClipboardString p'win

        -- See if we generated a known error for the clipboard, which would
        -- indicate that the format is not supported.
        errResult <- c'glfwGetError nullPtr
        if errResult == c'GLFW_FORMAT_UNAVAILABLE
          then return s
          else if errResult == c'GLFW_NO_ERROR then do
            if p's' == nullPtr
              then return ""
              else peekCString p's'
          else do
            assertFailure "Unexpected error from clipboard"

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

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
    when (support == c'GLFW_TRUE) $
        alloca $ \p'count -> do
            p'exts <- c'glfwGetRequiredInstanceExtensions p'count
            when (p'exts /= nullPtr) $ do
                count <- peek p'count
                assertBool "Got at least some extensions" $ count > 0

test_glfwGetInstanceProcAddress :: IO ()
test_glfwGetInstanceProcAddress = do
    support <- c'glfwVulkanSupported
    when (support == c'GLFW_TRUE) $ do
        shouldBeNull <- withCString "notafunction" $
                        \s -> c'glfwGetInstanceProcAddress nullPtr s
        shouldBeNull @?= nullFunPtr
        assertBool "Function pointer is defined!" $
          p'glfwGetInstanceProcAddress /= nullFunPtr

test_glfwGetPhysicalDevicePresentationSupport :: IO ()
test_glfwGetPhysicalDevicePresentationSupport = do
    -- We don't really have the proper types to test this function
    support <- c'glfwVulkanSupported
    when (support == c'GLFW_TRUE) $ do
        shouldBeFalse <-
            c'glfwGetPhysicalDevicePresentationSupport nullPtr nullPtr 0
        shouldBeFalse @?= c'GLFW_FALSE

        -- If we pass a nullptr for the instance here then we better get a
        -- GLFW_API_UNAVAILABLE error since we didn't create the instance with
        -- the proper extensions...
        alloca $ \p'errMsg ->
            c'glfwGetError p'errMsg >>=
                assertEqual "Got proper vulkan error" c'GLFW_API_UNAVAILABLE

        assertBool "Function pointer is defined!" $
          p'glfwGetPhysicalDevicePresentationSupport /= nullFunPtr

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
    when (support == c'GLFW_TRUE) $ 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

        -- The window that we pass here was not created with GLFW_NO_API, so
        -- the proper error received here seems to be GLFW_INVALID_VALUE
        alloca $ \p'errMsg ->
            c'glfwGetError p'errMsg >>=
                assertEqual "Got proper vulkan error" c'GLFW_INVALID_VALUE

        assertBool "Function pointer is defined!" $
          p'glfwCreateWindowSurface /= nullFunPtr

{-# ANN module "HLint: ignore Use camelCase" #-}