module Graphics.GPipe.Context.GLFW.Resource
( newContext
, newSharedContext
, WindowConf(..)
, GLFWWindow(..)
, defaultWindowConf
, Window
, ErrorCallback
) where
import qualified "GLFW-b" Graphics.UI.GLFW as GLFW
import qualified Control.Exception as Exc
import qualified Data.Maybe as M
import qualified Text.Printf as P
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
newtype GLFWWindow = GLFWWindow
{
getGLFWWindow :: GLFW.Window
}
type Window = GLFW.Window
type ErrorCallback = GLFW.ErrorCallback
defaultOnError :: ErrorCallback
defaultOnError err msg = fail $ P.printf "%s: %s" (show err) msg
data WindowConf = WindowConf
{ width :: Int
, height :: Int
, title :: String
}
defaultWindowConf :: WindowConf
defaultWindowConf = WindowConf 1024 768 "GLFW Window"
withErrorCallback :: Maybe ErrorCallback -> IO a -> IO a
withErrorCallback customOnError =
Exc.bracket_
(GLFW.setErrorCallback $ Just onError)
(GLFW.setErrorCallback Nothing)
where
onError :: ErrorCallback
onError = M.fromMaybe defaultOnError customOnError
withGLFW :: IO a -> IO a
withGLFW =
Exc.bracket_
GLFW.init
$ return ()
withHints :: [GLFW.WindowHint] -> IO a -> IO a
withHints hints =
Exc.bracket_
(GLFW.defaultWindowHints >> mapM_ GLFW.windowHint hints)
GLFW.defaultWindowHints
newWindow :: Maybe Window -> Maybe WindowConf -> IO Window
newWindow share customWindowConf =
M.fromMaybe noWindow <$> createWindowHuh
where
WindowConf {width=w, height=h, title=t} = M.fromMaybe defaultWindowConf customWindowConf
createWindowHuh :: IO (Maybe Window)
createWindowHuh = do
GLFW.makeContextCurrent Nothing
win <- GLFW.createWindow w h t Nothing share
GLFW.makeContextCurrent win
return win
noWindow :: Window
noWindow = error "Couldn't create a window"
newContext :: Maybe ErrorCallback -> [GLFW.WindowHint] -> Maybe WindowConf -> IO Window
newContext ec hints wc
= withErrorCallback ec
. withGLFW
. withHints hints
$ newWindow Nothing wc
newSharedContext :: Window -> [GLFW.WindowHint] -> Maybe WindowConf -> IO Window
newSharedContext ctx hints wc
= withHints hints
$ newWindow (Just ctx) wc