nek0/affection
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

generalize

Browse source
This commit is contained in:
nek0 2017-12-12 13:12:47 +01:00
parent aa7be84883
commit 64537fe1c7
4 changed files with 64 additions and 66 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
src/Affection/MessageBus/Message.hs
View file

@ -4,3 +4,4 @@ module Affection.MessageBus.Message
import Affection.MessageBus.Message.Class as M import Affection.MessageBus.Message.Class as M
import Affection.MessageBus.Message.WindowMessage as M import Affection.MessageBus.Message.WindowMessage as M
import Affection.MessageBus.Message.KeyboardMessage as M

60
src/Affection/MessageBus/Message/WindowMessage.hs
View file

@ -11,79 +11,79 @@ import qualified SDL
import Linear (V2(..)) import Linear (V2(..))
data WindowMessage data WindowMessage
= MsgEngineReady Word32 -- = MsgEngineReady Word32
| MsgWindowShown = MsgWindowShow
{ msgWSWhen :: Word32 { msgWSWhen :: Word32
, msgWSWindow :: SDL.Window , msgWSWindow :: SDL.Window
} }
| MsgWindowHidden | MsgWindowHide
{ msgWHWhen :: Word32 { msgWHWhen :: Word32
, msgWHWindow :: SDL.Window , msgWHWindow :: SDL.Window
} }
| MsgWindowExposed | MsgWindowExpose
{ msgWEWhen :: Word32 { msgWEWhen :: Word32
, msgWEWindow :: SDL.Window , msgWEWindow :: SDL.Window
} }
| MsgWindowMoved | MsgWindowMove
{ msgWMWhen :: Word32 { msgWMWhen :: Word32
, msgWMWindow :: SDL.Window , msgWMWindow :: SDL.Window
, msgWMNewPos :: V2 Int32 , msgWMNewPos :: V2 Int32
} }
| MsgWindowResized | MsgWindowResize
{ msgWRWhen :: Word32 { msgWRWhen :: Word32
, msgWRWindow :: SDL.Window , msgWRWindow :: SDL.Window
, msgWRNewSize :: V2 Int32 , msgWRNewSize :: V2 Int32
} }
| MsgWindowSizeChanged | MsgWindowSizeChange
{ msgWSCWhen :: Word32 { msgWSCWhen :: Word32
, msgWSCWindow :: SDL.Window , msgWSCWindow :: SDL.Window
} }
| MsgWindowMinimized | MsgWindowMinimize
{ msgWMinWhen :: Word32 { msgWMinWhen :: Word32
, msgWMinWindow :: SDL.Window , msgWMinWindow :: SDL.Window
} }
| MsgWindowMaximized | MsgWindowMaximize
{ msgWMaxWhen :: Word32 { msgWMaxWhen :: Word32
, msgWMaxWindow :: SDL.Window , msgWMaxWindow :: SDL.Window
} }
| MsgWindowRestored | MsgWindowRestore
{ msgWRestWhen :: Word32 { msgWRestWhen :: Word32
, msgWRestWindow :: SDL.Window , msgWRestWindow :: SDL.Window
} }
| MsgWindowGainedMouseFocus | MsgWindowGainMouseFocus
{ msgWGMFWhen :: Word32 { msgWGMFWhen :: Word32
, msgWGMFWindow :: SDL.Window , msgWGMFWindow :: SDL.Window
} }
| MsgWindowLostMouseFocus | MsgWindowLoseMouseFocus
{ msgWLMFWhen :: Word32 { msgWLMFWhen :: Word32
, msgWLMFWindow :: SDL.Window , msgWLMFWindow :: SDL.Window
} }
| MsgWindowGainedKeyboardFocus | MsgWindowGainKeyboardFocus
{ msgWGKFWhen :: Word32 { msgWGKFWhen :: Word32
, msgWGKFWindow :: SDL.Window , msgWGKFWindow :: SDL.Window
} }
| MsgWindowLostKeyboardFocus | MsgWindowLoseKeyboardFocus
{ msgWLKFWhen :: Word32 { msgWLKFWhen :: Word32
, msgWLKFWindow :: SDL.Window , msgWLKFWindow :: SDL.Window
} }
| MsgWindowClosed | MsgWindowClose
{ msgWCWhen :: Word32 { msgWCWhen :: Word32
, msgWCWindow :: SDL.Window , msgWCWindow :: SDL.Window
} }
instance Message WindowMessage where instance Message WindowMessage where
msgTime (MsgEngineReady t) = t -- msgTime (MsgEngineReady t) = t
msgTime (MsgWindowShown t _) = t msgTime (MsgWindowShow t _) = t
msgTime (MsgWindowHidden t _) = t msgTime (MsgWindowHide t _) = t
msgTime (MsgWindowExposed t _) = t msgTime (MsgWindowExpose t _) = t
msgTime (MsgWindowMoved t _ _) = t msgTime (MsgWindowMove t _ _) = t
msgTime (MsgWindowResized t _ _) = t msgTime (MsgWindowResize t _ _) = t
msgTime (MsgWindowSizeChanged t _) = t msgTime (MsgWindowSizeChange t _) = t
msgTime (MsgWindowMinimized t _) = t msgTime (MsgWindowMinimize t _) = t
msgTime (MsgWindowMaximized t _) = t msgTime (MsgWindowMaximize t _) = t
msgTime (MsgWindowRestored t _) = t msgTime (MsgWindowRestore t _) = t
msgTime (MsgWindowGainedMouseFocus t _) = t msgTime (MsgWindowGainMouseFocus t _) = t
msgTime (MsgWindowLostMouseFocus t _) = t msgTime (MsgWindowLoseMouseFocus t _) = t
msgTime (MsgWindowGainedKeyboardFocus t _) = t msgTime (MsgWindowGainKeyboardFocus t _) = t
msgTime (MsgWindowLostKeyboardFocus t _) = t msgTime (MsgWindowLoseKeyboardFocus t _) = t
msgTime (MsgWindowClosed t _) = t msgTime (MsgWindowClose t _) = t

64
src/Affection/Subsystems/AffectionWindow.hs
View file

@ -1,84 +1,80 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.Subsystems.AffectionWindow where module Affection.Subsystems.AffectionWindow where
import Affection.MessageBus import Affection.MessageBus
import Affection.Subsystems.Class import Affection.Subsystems.Class
import Affection.Types import Affection.Types
import Control.Monad.State.Class (gets)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import qualified SDL import qualified SDL
data AffectionWindow m = AffectionWindow data AffectionWindow = AffectionWindow
{ windowChannel :: Channel m { windowInChannel :: Channel WindowMessage
, windowOutChannel :: Channel WindowMessage
} }
instance (Message m) => Participant (AffectionWindow m) m where instance Participant AffectionWindow WindowMessage where
partChannel = windowChannel partChannel = windowOutChannel
partInit = do partInit ichan = do
chan <- gets messageChannel :: Affection sd m (Channel m) ochan <- liftIO $ newBroadcastChannel
nchan <- liftIO $ dupChannel $ chan
return $ AffectionWindow return $ AffectionWindow
{ windowChannel = nchan { windowOutChannel = ochan
, windowInChannel = ichan
} }
partListen p = do partListen p =
let chan = partChannel p liftIO $ tryPeekChannel (windowInChannel p)
mmsg <- tryPeekChannel chan
return mmsg
partEmit p message = do partEmit p message =
let chan = partChannel p liftIO $ writeChannel (windowOutChannel p) message
writeChannel chan message
instance Subsystem (AffectionWindow SystemMessage) SystemMessage where instance SDLSubsystem AffectionWindow WindowMessage where
consumeEvents aw evs = doConsume evs consumeSDLEvents aw evs = doConsume evs
where where
doConsume [] = return []
doConsume (e:es) = case SDL.eventPayload e of doConsume (e:es) = case SDL.eventPayload e of
SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do
partEmit aw (MsgWindowShown (SDL.eventTimestamp e) window) partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do
partEmit aw (MsgWindowHidden (SDL.eventTimestamp e) window) partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do
partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window) partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do
partEmit aw (MsgWindowMoved (SDL.eventTimestamp e) window newPos) partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos)
doConsume es doConsume es
SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do
partEmit aw (MsgWindowResized (SDL.eventTimestamp e) window newSize) partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize)
doConsume es doConsume es
SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do
partEmit aw (MsgWindowSizeChanged (SDL.eventTimestamp e) window) partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do
partEmit aw (MsgWindowMinimized (SDL.eventTimestamp e) window) partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do
partEmit aw (MsgWindowMaximized (SDL.eventTimestamp e) window) partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do
partEmit aw (MsgWindowRestored (SDL.eventTimestamp e) window) partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do
partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do
partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do
partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestamp e) window) partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window)
doConsume es doConsume es
SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do
partEmit aw (MsgWindowClosed (SDL.eventTimestamp e) window) partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window)
doConsume es doConsume es
_ -> fmap (e :) (doConsume es) _ -> fmap (e :) (doConsume es)

5
src/Affection/Subsystems/Class.hs
View file

@ -2,9 +2,10 @@
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
module Affection.Subsystems.Class where module Affection.Subsystems.Class where
import Affection.Types
import Affection.MessageBus import Affection.MessageBus
import qualified SDL import qualified SDL
class (Message m, Participant s m) => Subsystem s m where class (Message m, Participant s m) => SDLSubsystem s m where
consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event] consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event]