gore-and-ash-sdl 1.1.0.1 → 2.0.0.0
raw patch · 4 files changed
+101/−22 lines, 4 files
Files
- gore-and-ash-sdl.cabal +1/−1
- src/Game/GoreAndAsh/SDL/API.hs +58/−15
- src/Game/GoreAndAsh/SDL/Module.hs +14/−5
- src/Game/GoreAndAsh/SDL/State.hs +28/−1
gore-and-ash-sdl.cabal view
@@ -1,5 +1,5 @@ name: gore-and-ash-sdl-version: 1.1.0.1+version: 2.0.0.0 synopsis: Gore&Ash core module for integration with SDL library description: Please see README.md homepage: git@github.com:Teaspot-Studio/gore-and-ash-sdl.git
src/Game/GoreAndAsh/SDL/API.hs view
@@ -36,7 +36,7 @@ import Control.Wire.Unsafe.Event import Data.Int import Data.Sequence (Seq)-import Data.Text (Text)+import Data.Text (Text, unpack) import Data.Word import Foreign import GHC.Generics @@ -64,11 +64,12 @@ -- | Low level API for module class (MonadIO m, MonadThrow m) => MonadSDL m where + -- | Creates window and stores in module context -- -- Throws @SDL'ConflictingWindows@ on name conflict sdlCreateWindowM :: - Text -- ^ Window name that is used to get the window (and renderer) from the module later+ WindowName -- ^ Window name that is used to get the window (and renderer) from the module later -> Text -- ^ Title of the window -> WindowConfig -- ^ Window configuration -> RendererConfig -- ^ Renderer configuration@@ -76,20 +77,34 @@ -- | Getting window and renderer by name sdlGetWindowM :: - Text -- ^ Window name that was used at @sdlCreateWindowM@ call+ WindowName -- ^ Window name that was used at @sdlCreateWindowM@ call -> m (Maybe (Window, Renderer)) -- | Destroying window and renderer by name sdlDestroyWindowM ::- Text -- ^ Window name that was used at @sdlCreateWindowM@ call+ WindowName -- ^ Window name that was used at @sdlCreateWindowM@ call -> m () -- | Setup background color for window sdlSetBackColor :: - Text -- ^ Window name that was used at @sdlCreateWindowM@ call- -> V4 Word8 -- ^ Color to set+ WindowName -- ^ Window name that was used at @sdlCreateWindowM@ call+ -> Maybe (V4 Word8) -- ^ Color to set, Nothing to do not clear color -> m () + -- | Creates context for given window+ --+ -- Note: destroys previous context if existed+ sdlCreateContext :: + WindowName -- ^ Window name that was used at @sdlCreateWindowM@ call+ -> m ()++ -- | Makes GL context of given window current+ --+ -- Does nothing if 'sdlCreateContext' wasn't called.+ sdlMakeCurrent :: + WindowName -- ^ Window name that was used at @sdlCreateWindowM@ call+ -> m ()+ -- | Getting window shown events that occurs scince last frame sdlWindowShownEventsM :: m (Seq WindowShownEventData) -- | Getting window hidden events that occurs scince last frame@@ -182,23 +197,28 @@ case H.lookup n . sdlWindows $! s of Just _ -> throwM . SDL'ConflictingWindows $! n Nothing -> do+ let winfo = WindowInfo {+ winfoWindow = w + , winfoRenderer = r + , winfoColor = Nothing + , winfoContext = Nothing+ } SDLT . put $! s {- sdlWindows = H.insert n (w, r, defColor) . sdlWindows $! s+ sdlWindows = H.insert n winfo . sdlWindows $! s } return (w, r)- where - defColor = V4 0 0 0 255 sdlGetWindowM n = do s <- SDLT get - return . fmap (\(w, r, _) -> (w, r)) . H.lookup n . sdlWindows $! s + return . fmap (\WindowInfo{..} -> (winfoWindow, winfoRenderer)) . H.lookup n . sdlWindows $! s sdlDestroyWindowM n = do s <- SDLT get case H.lookup n . sdlWindows $! s of - Just (w, r, _) -> do - destroyRenderer r - destroyWindow w+ Just WindowInfo{..} -> do + destroyRenderer winfoRenderer + destroyWindow winfoWindow+ whenJust winfoContext glDeleteContext SDLT . put $! s { sdlWindows = H.delete n . sdlWindows $! s }@@ -207,11 +227,32 @@ sdlSetBackColor n c = do s <- SDLT get case H.lookup n . sdlWindows $! s of - Just (w, r, _) -> SDLT . put $! s {- sdlWindows = H.insert n (w, r, c) . sdlWindows $! s + Just winfo -> SDLT . put $! s {+ sdlWindows = H.insert n winfo' . sdlWindows $! s }+ where + winfo' = winfo { winfoColor = c } Nothing -> return () + sdlCreateContext n = do + s <- SDLT get + case H.lookup n . sdlWindows $! s of + Just winfo -> do + whenJust (winfoContext winfo) glDeleteContext+ cntx <- glCreateContext $ winfoWindow winfo + let winfo' = winfo { winfoContext = Just cntx }+ SDLT . put $! s {+ sdlWindows = H.insert n winfo' . sdlWindows $! s+ }+ liftIO . putStrLn $! "Created context for " <> unpack n+ Nothing -> return ()++ sdlMakeCurrent n = do + s <- SDLT get + case H.lookup n . sdlWindows $! s of + Just WindowInfo{..} -> whenJust winfoContext $ glMakeCurrent winfoWindow+ Nothing -> return ()+ sdlWindowShownEventsM = sdlWindowShownEvents <$> get sdlWindowHiddenEventsM = sdlWindowHiddenEvents <$> get sdlWindowExposedEventsM = sdlWindowExposedEvents <$> get@@ -254,6 +295,8 @@ sdlGetWindowM = lift . sdlGetWindowM sdlDestroyWindowM = lift . sdlDestroyWindowM sdlSetBackColor a b = lift $ sdlSetBackColor a b + sdlCreateContext = lift . sdlCreateContext + sdlMakeCurrent = lift . sdlMakeCurrent sdlWindowShownEventsM = lift sdlWindowShownEventsM sdlWindowHiddenEventsM = lift sdlWindowHiddenEventsM
src/Game/GoreAndAsh/SDL/Module.hs view
@@ -19,6 +19,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.State.Strict+import Data.Proxy import qualified Data.Foldable as F import qualified Data.HashMap.Strict as H import qualified Data.Sequence as S @@ -61,22 +62,30 @@ }) newModuleState = emptySDLState <$> newModuleState- withModule _ io = initializeAll >> io+ withModule _ io = do+ initializeAll+ liftIO $ putStrLn "SDL initialized"+ withModule (Proxy :: Proxy m) io+ cleanupModule _ = quit -- | Takes all window and renderers and update them drawWindows :: MonadIO m => SDLState s -> m () drawWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows where - go (_, r, _) = present r + go WindowInfo{..} = do+ whenJust winfoContext . const . glSwapWindow $! winfoWindow+ present winfoRenderer -- | Clear surface of all windows clearWindows :: MonadIO m => SDLState s -> m () clearWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows where - go (_, r, c) = do - rendererDrawColor r $= c- clear r+ go WindowInfo{..} = case winfoColor of + Nothing -> return ()+ Just c -> do + rendererDrawColor winfoRenderer $= c+ clear winfoRenderer -- | Catch all SDL events processEvents :: MonadIO m => SDLState s -> m (SDLState s)
src/Game/GoreAndAsh/SDL/State.hs view
@@ -10,8 +10,12 @@ -} module Game.GoreAndAsh.SDL.State( SDLState(..)+ , WindowName+ , WindowInfo(..) , emptySDLState , flashSDLState+ -- | Helpers+ , whenJust ) where import Control.DeepSeq @@ -24,6 +28,7 @@ import SDL.Input.Keyboard import SDL.Input.Mouse import SDL.Internal.Types+import SDL.Video import Data.Sequence (Seq) import qualified Data.Sequence as S @@ -31,12 +36,25 @@ import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as H +-- | Windows are uniquely identified by names+type WindowName = Text ++-- | Context of window+data WindowInfo = WindowInfo {+ winfoWindow :: !Window +, winfoRenderer :: !Renderer +, winfoColor :: !(Maybe (V4 Word8))+, winfoContext :: !(Maybe GLContext)+} deriving (Generic)++instance NFData WindowInfo + -- | Inner state of SDL module. -- -- [@s@] - State of next module, the states are chained via nesting. data SDLState s = SDLState { sdlNextState :: !s-, sdlWindows :: !(HashMap Text (Window, Renderer, V4 Word8))+, sdlWindows :: !(HashMap WindowName WindowInfo) , sdlWindowShownEvents :: !(Seq WindowShownEventData) , sdlWindowHiddenEvents :: !(Seq WindowHiddenEventData)@@ -123,6 +141,9 @@ instance NFData Renderer where rnf = (`seq` ()) +instance NFData GLContext where+ rnf = (`seq` ())+ instance NFData SysWMEventData where rnf SysWMEventData{..} = sysWMEventMsg `seq` () @@ -220,3 +241,9 @@ , sdlDropEvents = S.empty , sdlClipboardUpdateEvents = S.empty }++-- | Helper to trigger action when value is 'Just'+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust ma f = case ma of + Nothing -> return ()+ Just a -> f a