diff options
-rw-r--r-- | Spear/App/Application.hs | 16 |
1 files changed, 4 insertions, 12 deletions
diff --git a/Spear/App/Application.hs b/Spear/App/Application.hs index ce1d5cb..5886502 100644 --- a/Spear/App/Application.hs +++ b/Spear/App/Application.hs | |||
@@ -47,7 +47,7 @@ data SpearWindow = SpearWindow | |||
47 | withWindow :: MonadIO m | 47 | withWindow :: MonadIO m |
48 | => Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | 48 | => Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle |
49 | -> WindowSizeCallback -> (SpearWindow -> Game () a) -> m (Either String a) | 49 | -> WindowSizeCallback -> (SpearWindow -> Game () a) -> m (Either String a) |
50 | withWindow dim displayBits windowMode glVersion windowTitle onResize game = do | 50 | withWindow dim@(w,h) displayBits windowMode glVersion windowTitle onResize game = do |
51 | result <- liftIO . flip runGame () $ do | 51 | result <- liftIO . flip runGame () $ do |
52 | glfwInit | 52 | glfwInit |
53 | window <- setup dim displayBits windowMode glVersion windowTitle onResize | 53 | window <- setup dim displayBits windowMode glVersion windowTitle onResize |
@@ -62,25 +62,22 @@ withWindow dim displayBits windowMode glVersion windowTitle onResize game = do | |||
62 | -- Set up an application 'SpearWindow'. | 62 | -- Set up an application 'SpearWindow'. |
63 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle | 63 | setup :: Dimensions -> [DisplayBits] -> WindowMode -> Context -> Maybe WindowTitle |
64 | -> WindowSizeCallback -> Game s SpearWindow | 64 | -> WindowSizeCallback -> Game s SpearWindow |
65 | setup (w, h) displayBits windowMode (major, minor) wndTitle onResize' = do | 65 | setup (w, h) displayBits windowMode (major, minor) wndTitle onResize = do |
66 | closeRequest <- gameIO $ newEmptyMVar | 66 | closeRequest <- gameIO $ newEmptyMVar |
67 | gameIO $ do | 67 | gameIO $ do |
68 | openWindowHint OpenGLVersionMajor major | 68 | openWindowHint OpenGLVersionMajor major |
69 | openWindowHint OpenGLVersionMinor minor | 69 | openWindowHint OpenGLVersionMinor minor |
70 | openWindowHint OpenGLProfile OpenGLCompatProfile | 70 | openWindowHint OpenGLProfile OpenGLCompatProfile |
71 | disableSpecial AutoPollEvent | 71 | disableSpecial AutoPollEvent |
72 | |||
73 | let dimensions = GL.Size (fromIntegral w) (fromIntegral h) | 72 | let dimensions = GL.Size (fromIntegral w) (fromIntegral h) |
74 | result <- openWindow dimensions displayBits windowMode | 73 | result <- openWindow dimensions displayBits windowMode |
75 | windowTitle $= case wndTitle of | 74 | windowTitle $= case wndTitle of |
76 | Nothing -> "Spear Game Framework" | 75 | Nothing -> "Spear Game Framework" |
77 | Just title -> title | 76 | Just title -> title |
78 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | 77 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) |
79 | 78 | windowSizeCallback $= onResize | |
80 | windowSizeCallback $= (onResize onResize') | ||
81 | windowCloseCallback $= (onWindowClose closeRequest) | 79 | windowCloseCallback $= (onWindowClose closeRequest) |
82 | onResize' (Size (fromIntegral w) (fromIntegral h)) | 80 | onResize (Size (fromIntegral w) (fromIntegral h)) |
83 | |||
84 | return $ SpearWindow closeRequest | 81 | return $ SpearWindow closeRequest |
85 | 82 | ||
86 | glfwInit :: Game s () | 83 | glfwInit :: Game s () |
@@ -138,10 +135,5 @@ getRequest mvar = tryTakeMVar mvar >>= \x -> return $ case x of | |||
138 | Nothing -> False | 135 | Nothing -> False |
139 | Just x -> x | 136 | Just x -> x |
140 | 137 | ||
141 | onResize :: WindowSizeCallback -> Size -> IO () | ||
142 | onResize callback s@(Size w h) = do | ||
143 | GL.viewport $= (Position 0 0, Size (fromIntegral w) (fromIntegral h)) | ||
144 | callback s | ||
145 | |||
146 | onWindowClose :: MVar Bool -> WindowCloseCallback | 138 | onWindowClose :: MVar Bool -> WindowCloseCallback |
147 | onWindowClose closeRequest = putMVar closeRequest True >> return False | 139 | onWindowClose closeRequest = putMVar closeRequest True >> return False |