{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
module Graphics.NanoVG.Window
( Window (..)
, simpleWindow
, MiddleWare
, run
) where
import Control.Concurrent
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Loops
import Foreign.C.Types
import System.IO (hPutStrLn, stderr)
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLFW as GLFW
import qualified NanoVG as NVG
import qualified Graphics.NanoVG.FrameSize as FS
foreign import ccall unsafe "initGlew"
glewInit :: IO CInt
data Window st = Window
{ winInit :: !(NVG.Context -> IO st)
, winRender :: !(st -> NVG.Context -> IO ())
, winAfterRender :: !(st -> NVG.Context -> IO ())
}
simpleWindow :: (NVG.Context -> IO ()) -> Window ()
simpleWindow render = Window
{ winInit = const $ pure ()
, winRender = const render
, winAfterRender = \_ _ -> pure ()
}
type MiddleWare st0 st = Window st0 -> Window st
run
:: Int
-> Int
-> String
-> Window st
-> IO ()
run initWidth initHeight title Window {..} = withGLFW $
createWindow initWidth initHeight title >>= go
where
go win = do
GLFW.makeContextCurrent $ Just win
void glewInit
ctx <- NVG.createGL3 [NVG.Antialias, NVG.StencilStrokes, NVG.Debug]
frameSize <- FS.init win
st <- winInit ctx
whileM_ (not <$> GLFW.windowShouldClose win) $ do
throwError
(width, height) <- FS.size frameSize
GL.clear [GL.ColorBuffer, GL.StencilBuffer]
runFrame ctx width height $ winRender st ctx
GLFW.swapBuffers win
GL.flush
GLFW.pollEvents
winAfterRender st ctx
runFrame :: NVG.Context -> Int -> Int -> IO a -> IO a
runFrame c w h act = NVG.beginFrame c (fromIntegral w) (fromIntegral h) 1 *> act <* NVG.endFrame c
throwError :: IO ()
throwError = do
errs <- GL.errors
case errs of
err:_ ->
throwString $ "OpenGL error: " <> show err
_ ->
pure ()
createWindow :: Int -> Int -> String -> IO GLFW.Window
createWindow w h title = do
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMajor 3
GLFW.windowHint $ GLFW.WindowHint'ContextVersionMinor 3
GLFW.windowHint $ GLFW.WindowHint'OpenGLProfile GLFW.OpenGLProfile'Core
GLFW.windowHint $ GLFW.WindowHint'OpenGLDebugContext True
Just win <- GLFW.createWindow w h title Nothing Nothing
pure win
withGLFW :: IO a -> IO a
withGLFW act = runInBoundThread $ do
GLFW.setErrorCallback $ Just $ \err msg ->
hPutStrLn stderr $ "GLFW error: " <> show err <> "\n" <> msg
bracket_ (assertTrueM GLFW.init) GLFW.terminate act
where
assertTrueM predM = do
True <- predM
pure ()