From 6e11ff9b1ea0d159beb82b8faa3b27ee77e9b5b4 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 02:18:23 +0100 Subject: [PATCH 01/24] dusting off --- affection.cabal | 9 ----- src/Affection.hs | 60 +---------------------------- src/Affection/MessageBus.hs | 7 ++++ src/Affection/MessageBus/Class.hs | 2 +- src/Affection/MessageBus/Engine.hs | 3 -- src/Affection/MessageBus/Message.hs | 4 +- 6 files changed, 12 insertions(+), 73 deletions(-) create mode 100644 src/Affection/MessageBus.hs delete mode 100644 src/Affection/MessageBus/Engine.hs diff --git a/affection.cabal b/affection.cabal index cf45d46..5f4a95e 100644 --- a/affection.cabal +++ b/affection.cabal @@ -36,18 +36,12 @@ flag examples library exposed-modules: Affection - -- , Affection.Draw - -- , Affection.Particle , Affection.Types , Affection.StateMachine , Affection.MouseInteractable - -- , Affection.Property - -- , Affection.Actor - -- , Affection.Animation , Affection.Util , Affection.MessageBus.Util , Affection.MessageBus.Class - , Affection.MessageBus.Engine , Affection.MessageBus.Message default-extensions: OverloadedStrings @@ -69,8 +63,6 @@ library , text , mtl , time - -- , gegl - -- , babl , monad-loops , monad-parallel , containers @@ -79,7 +71,6 @@ library , bytestring , OpenGL , stm - -- , sdl2-image -- executable example00 -- hs-source-dirs: examples diff --git a/src/Affection.hs b/src/Affection.hs index 3dbb127..fd564ad 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -5,8 +5,6 @@ module Affection , get , getAffection , putAffection - -- , withWindow - -- , withDefaultWindow , delaySec , get , put @@ -17,7 +15,6 @@ import SDL (($=)) import qualified SDL import qualified SDL.Internal.Numbered as SDL (toNumber) import qualified SDL.Raw as Raw --- import qualified GEGL as G import Data.Maybe import Data.IORef @@ -33,22 +30,13 @@ import Foreign.Storable (peek) import Debug.Trace import Affection.Types as A --- import Affection.Draw as A --- import Affection.Particle as A import Affection.StateMachine as A import Affection.MouseInteractable as A --- import Affection.Property as A --- import Affection.Actor as A --- import Affection.Animation as A import Affection.Util as A -import Affection.MessageBus.Class as A -import Affection.MessageBus.Message as A -import Affection.MessageBus.Engine as A -import Affection.MessageBus.Util as A +import Affection.MessageBus as A import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) --- import qualified BABL as B -- | Main function which bootstraps everything else. withAffection @@ -61,7 +49,6 @@ withAffection AffectionConfig{..} = do SDL.initializeAll Only is -> SDL.initialize is - -- G.gegl_init -- give SDL render quality SDL.HintRenderScaleQuality SDL.$= SDL.ScaleLinear -- just checking… @@ -73,54 +60,23 @@ withAffection AffectionConfig{..} = do window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window context <- SDL.glCreateContext(window) - -- -- create renderer - -- renderer <- SDL.createRenderer - -- window - -- (-1) - -- SDL.defaultRenderer - -- -- make draw texture - -- texture <- SDL.createTexture - -- renderer - -- SDL.ABGR8888 - -- SDL.TextureAccessStreaming - -- (case canvasSize of - -- Just (cw, ch) -> (SDL.V2 - -- (CInt $ fromIntegral cw) - -- (CInt $ fromIntegral ch) - -- ) - -- Nothing -> - -- SDL.windowInitialSize windowConfig - -- ) - -- -- make draw surface - -- -- pixelFormat <- liftIO $ peek . Raw.surfaceFormat =<< peek ptr let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig (w, h) = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (fromIntegral rw, fromIntegral rh) - -- -- stride = fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w - -- bablFormat = B.PixelFormat B.RGBA B.CFu8 - -- cpp = B.babl_components_per_pixel bablFormat - -- !stride = cpp * w - -- format <- B.babl_format bablFormat - -- get current time SDL.setWindowMode window initScreenMode SDL.swapInterval $= SDL.SynchronizedUpdates + -- get current time execTime <- getTime Monotonic initContainer <- (\x -> AffectionData { quitEvent = False , userState = x , drawWindow = window , glContext = context - -- , windowRenderer = renderer - -- , drawTexture = texture - -- , drawFormat = format , drawDimensions = case canvasSize of Just (cw, ch) -> (cw, ch) Nothing -> (w, h) , screenMode = initScreenMode - -- , drawStride = stride - -- , drawCPP = cpp - -- , drawStack = [] , elapsedTime = 0 , deltaTime = 0 , sysTime = execTime @@ -138,15 +94,10 @@ withAffection AffectionConfig{..} = do -- Measure time difference form last run now <- liftIO $ getTime Monotonic let lastTime = sysTime ad - -- -- clean draw requests from last run - -- MP.mapM_ (invalidateDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad) - -- clean the renderer form last time - -- SDL.clear renderer -- compute dt and update elapsedTime let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) !ne = elapsedTime ad + dt put $ ad - -- { drawStack = [] { elapsedTime = ne , deltaTime = dt } @@ -161,14 +112,8 @@ withAffection AffectionConfig{..} = do liftIO $ flush -- handle all new draw requests ad2 <- get - -- clear <- catMaybes <$> - -- mapM (handleDrawRequest (drawStride ad) (drawCPP ad)) (drawStack ad2) - -- -- save all draw requests to clear in next run - -- put $ ad2 - -- { drawStack = clear } -- actual drawing SDL.glSwapWindow window - -- SDL.present (windowRenderer ad2) -- save new time ad3 <- get when (sysTime ad == sysTime ad3) ( @@ -178,7 +123,6 @@ withAffection AffectionConfig{..} = do ) ) ) initContainer - -- G.gegl_exit cleanUp $ userState nState SDL.destroyWindow window SDL.quit diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs new file mode 100644 index 0000000..ea372ec --- /dev/null +++ b/src/Affection/MessageBus.hs @@ -0,0 +1,7 @@ +module Affection.Messagebus + ( module M + ) where + +import Affection.MessageBus.Class as M +import Affection.MessageBus.Message as M +import Affection.MessageBus.Util as M diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index c02687e..880abac 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -16,4 +16,4 @@ class (Message msg) => Participant prt msg where partListen :: prt -> IO msg - partBroadcast :: prt -> msg -> IO () + partEmit :: prt -> msg -> IO () diff --git a/src/Affection/MessageBus/Engine.hs b/src/Affection/MessageBus/Engine.hs deleted file mode 100644 index 9990a94..0000000 --- a/src/Affection/MessageBus/Engine.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Affection.MessageBus.Engine where - -import Affection.MessageBus.Class diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 8fe92fe..8b108ee 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -6,13 +6,13 @@ import Data.Time.Clock (UTCTime(..)) class Message msg where msgTime :: msg -> UTCTime -data EngineMessage m +data SystemMessage m = MsgUserMessage { msgPayload :: m , msgWhen :: UTCTime } -- ^ Generic user defined message with custom payload | MsgEngineReady UTCTime -instance Message (EngineMessage m) where +instance Message (SystemMessage m) where msgTime (MsgUserMessage _ t) = t msgTime (MsgEngineReady t) = t From d8d29ec7df4e8e1836677daaa2791d374c6e122e Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 05:27:34 +0100 Subject: [PATCH 02/24] new subsystem --- src/Affection/Subsystems/AffectionWindow.hs | 70 +++++++++++++++++++++ src/Affection/Subsystems/Class.hs | 8 +++ 2 files changed, 78 insertions(+) create mode 100644 src/Affection/Subsystems/AffectionWindow.hs create mode 100644 src/Affection/Subsystems/Class.hs diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs new file mode 100644 index 0000000..fd0882f --- /dev/null +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -0,0 +1,70 @@ +module Affection.Subsystem.AffectionWindow where + +import Affection.MessageBus +import Affection.Subsystems.Class + +import qualified SDL + +data AffectionWindow = AffectionWindow + { windowChannel :: Channel msg + } + +instance Participant AffectionWindow where + partChannel = windowChannel + + partListen p = do + let chan = partChannel p + mmsg <- tryPeekChannel chan + return mmsg + + partEmit p m = do + let chan = partChannel p + writeChannel chan m + +instance Subsystem AffectionWindow where + consumeEvents aw evs = doConsume evs + where + doConsume (e:es) = case SDL.eventPayload e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) = do + partEmit aw (MsgWindowShown (SDL.eventTiemstamp e) window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) = do + partEmit aw (MsgWindowHidden (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) = do + partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) = do + partEmit aw (MsgWindowMoved (SDL.EventTimestamp e) window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) = do + partEmit aw (MsgWindowResized (SDL.EventTimestamp e) window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) = do + partEmit aw (MsgWindowSizeChanged (SDL.EventTimestamp e) window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) = do + partEmit aw (MsgWindowMinimized (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) = do + partEmit aw (MsgWindowMaximized (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) = do + partEmit aw (MsgWindowRestored (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) = do + partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) = do + partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) = do + partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) = do + partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestemp e) window) + doConsume es + SDL.WindowClosed (SDL.WindowClosedEventData window) = do + partEmit aw (MsgWindowClosed (SDL.eventTimestemp e) window) + doConsume es + _ = fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs new file mode 100644 index 0000000..7caea9f --- /dev/null +++ b/src/Affection/Subsystems/Class.hs @@ -0,0 +1,8 @@ +module Affection.Subsystems.Class where + +import Affection.MessageBus.Class + +import qualified SDL + +class (Participant s) => Subsystem s where + consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event] From a5ca89f93c493eed5801bc8ef8e357d77038af72 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 05:27:52 +0100 Subject: [PATCH 03/24] more message foo --- affection.cabal | 3 +- src/Affection/MessageBus.hs | 2 +- src/Affection/MessageBus/Class.hs | 8 +-- src/Affection/MessageBus/Message.hs | 89 +++++++++++++++++++++++++++-- src/Affection/MessageBus/Util.hs | 22 +++++++ 5 files changed, 111 insertions(+), 13 deletions(-) diff --git a/affection.cabal b/affection.cabal index 5f4a95e..74f1fb7 100644 --- a/affection.cabal +++ b/affection.cabal @@ -40,6 +40,7 @@ library , Affection.StateMachine , Affection.MouseInteractable , Affection.Util + , Affection.MessageBus , Affection.MessageBus.Util , Affection.MessageBus.Class , Affection.MessageBus.Message @@ -60,9 +61,9 @@ library -- Other library packages from which modules are imported. build-depends: base >=4.9 , sdl2 + , linear , text , mtl - , time , monad-loops , monad-parallel , containers diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index ea372ec..28d1bfa 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -1,4 +1,4 @@ -module Affection.Messagebus +module Affection.MessageBus ( module M ) where diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 880abac..1c0a526 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -3,17 +3,15 @@ module Affection.MessageBus.Class where import Control.Concurrent.STM as STM -import Data.IORef - import Affection.MessageBus.Message newtype (Message msg) => Channel msg = Channel (TChan msg) class (Message msg) => Participant prt msg where - partChannel :: prt -> IORef (Channel msg) + partChannel :: prt -> Channel msg - partConnectChannel :: prt -> Channel msg -> IO () + -- partConnectChannel :: prt -> Channel msg -> IO () - partListen :: prt -> IO msg + partListen :: prt -> IO (Maybe msg) partEmit :: prt -> msg -> IO () diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 8b108ee..bedf10c 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -1,18 +1,95 @@ {-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Message where -import Data.Time.Clock (UTCTime(..)) +import Data.Word (Word32(..)) +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) class Message msg where - msgTime :: msg -> UTCTime + msgTime :: msg -> Word32 data SystemMessage m = MsgUserMessage - { msgPayload :: m - , msgWhen :: UTCTime + { msgUMWhen :: Word32 + , msgUMPayload :: m } -- ^ Generic user defined message with custom payload - | MsgEngineReady UTCTime + | MsgEngineReady Word32 + | MsgWindowShown + { msgWSWhen :: Word32 + , msgWSWindow :: SDL.Window + } + | MsgWindowHidden + { msgWHWhen :: Word32 + , msgWHWindow :: SDL.Window + } + | MsgWindowExposed + { msgWEWhen :: Word32 + , msgWEWindow :: SDL.Window + } + | MsgWindowMoved + { msgWMWhen :: Word32 + , msgWMWindow :: SDL.Window + , msgWMNewPos :: V2 Int32 + } + | MsgWindowResized + { msgWRWhen :: Word32 + , msgWRWindow :: SDL.Window + , msgWRNewSize :: V2 Int32 + } + | MsgWindowSizeChanged + { msgWSCWhen :: Word32 + , msgWSCWindow :: SDL.Window + } + | MsgWindowMinimized + { msgWMinWhen :: Word32 + , msgWMinWindow :: SDL.Window + } + | MsgWindowMaximized + { msgWMaxWhen :: Word32 + , msgWMaxWindow :: SDL.Window + } + | MsgWindowRestored + { msgWRestWhen :: Word32 + , msgWRestWindow :: SDL.Window + } + | MsgWindowGainedMouseFocus + { msgWGMFWhen :: Word32 + , msgWGMFWindow :: SDL.Window + } + | MsgWindowLostMouseFocus + { msgWLMFWhen :: Word32 + , msgWLMFWindow :: SDL.Window + } + | MsgWindowGainedKeyboardFocus + { msgWGKFWhen :: Word32 + , msgWGKFWindow :: SDL.Window + } + | MsgWindowLostKeyboardFocus + { msgWLKFWhen :: Word32 + , msgWLKFWindow :: SDL.Window + } + | MsgWindowClosed + { msgWCWhen :: Word32 + , msgWCWindow :: SDL.Window + } instance Message (SystemMessage m) where - msgTime (MsgUserMessage _ t) = t + msgTime (MsgUserMessage t _) = t msgTime (MsgEngineReady t) = t + msgTime (MsgWindowShown t _) = t + msgTime (MsgWindowHidden t _) = t + msgTime (MsgWindowExposed t _) = t + msgTime (MsgWindowMoved t _ _) = t + msgTime (MsgWindowResized t _ _) = t + msgTime (MsgWindowSizeChanged t _) = t + msgTime (MsgWindowMinimized t _) = t + msgTime (MsgWindowMaximized t _) = t + msgTime (MsgWindowRestored t _) = t + msgTime (MsgWindowGainedMouseFocus t _) = t + msgTime (MsgWindowLostMouseFocus t _) = t + msgTime (MsgWindowGainedKeyboardFocus t _) = t + msgTime (MsgWindowLostKeyboardFocus t _) = t + msgTime (MsgWindowClosed t _) = t diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index ed7c551..501e9ab 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/src/Affection/MessageBus/Util.hs @@ -4,5 +4,27 @@ import Affection.MessageBus.Class import Affection.MessageBus.Message import Control.Concurrent.STM as STM +-- | Build a new broadcast channel newBroadcastChannel :: (Message msg) => IO (Channel msg) newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan + +-- | Duplicate a broadcast channel, so it can be accessed by subsystems +dupChannel :: (Message msg) + => Channel msg -- ^ Original 'Channel' + -> IO (Channel msg) -- ^ 'Channel' duplicate +dupChannel (Channel c) = atomically $ Channel <$> dupTChan c + +-- | Try to read a 'Channel' wihtout deleting the message. Returns 'Nothing' on +-- an empty 'Channel' +tryPeekChannel :: (Message msg) + => Channel msg -- ^ Channel to read from + -> IO (Maybe msg) -- ^ Resulting message (or not) +tryPeekChannel (Channel c) = atomically $ tryPeekTChan c + +-- | Write a message to a 'Channel' and thus broadcast it to all connected +-- subsystems +writeChannel :: (Message msg) + => Channel msg -- ^ 'Channel' to write to + -> msg -- ^ The Message to emit + -> IO () +writeChannel (Channel c) m = atomically $ writeTChan c m From c4e3528885afa235a5fb5d5483032e198733ae5f Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 05:28:34 +0100 Subject: [PATCH 04/24] ignore vim swap files --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index ced8b76..df67c56 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ dist/ *.aux *.hp *.ps +*.swp From 4ae117aa4832288a10461fdfbfe1ee7643b76352 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 23:30:11 +0100 Subject: [PATCH 05/24] classy messup --- affection.cabal | 2 + src/Affection.hs | 2 +- src/Affection/MessageBus/Class.hs | 8 +-- src/Affection/MessageBus/Util.hs | 1 + src/Affection/MouseInteractable.hs | 4 +- src/Affection/StateMachine.hs | 10 +-- src/Affection/Subsystems/AffectionWindow.hs | 78 ++++++++++++--------- src/Affection/Subsystems/Class.hs | 6 +- src/Affection/Types.hs | 20 ++++-- src/Affection/Util.hs | 14 ++-- 10 files changed, 84 insertions(+), 61 deletions(-) diff --git a/affection.cabal b/affection.cabal index 74f1fb7..5315c9d 100644 --- a/affection.cabal +++ b/affection.cabal @@ -44,6 +44,8 @@ library , Affection.MessageBus.Util , Affection.MessageBus.Class , Affection.MessageBus.Message + , Affection.Subsystems.Class + , Affection.Subsystems.AffectionWindow default-extensions: OverloadedStrings -- Modules included in this library but not exported. diff --git a/src/Affection.hs b/src/Affection.hs index fd564ad..5022675 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -40,7 +40,7 @@ import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) -- | Main function which bootstraps everything else. withAffection - :: AffectionConfig us -- ^ Configuration of the Game and its engine. + :: AffectionConfig us msg -- ^ Configuration of the Game and its engine. -> IO () withAffection AffectionConfig{..} = do -- intialiaze SDL diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 1c0a526..4f888cc 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,16 +1,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Affection.MessageBus.Class where -import Control.Concurrent.STM as STM - import Affection.MessageBus.Message - -newtype (Message msg) => Channel msg = Channel (TChan msg) +import Affection.Types class (Message msg) => Participant prt msg where partChannel :: prt -> Channel msg - -- partConnectChannel :: prt -> Channel msg -> IO () + partInit :: Affection sd msg prt partListen :: prt -> IO (Maybe msg) diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index 501e9ab..341f21b 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/src/Affection/MessageBus/Util.hs @@ -2,6 +2,7 @@ module Affection.MessageBus.Util where import Affection.MessageBus.Class import Affection.MessageBus.Message +import Affection.Types import Control.Concurrent.STM as STM -- | Build a new broadcast channel diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs index e3a6436..5e0c1f5 100644 --- a/src/Affection/MouseInteractable.hs +++ b/src/Affection/MouseInteractable.hs @@ -17,7 +17,7 @@ class MouseClickable a us where -> (Int, Int) -- The coordinates of the click -> SDL.InputMotion -- The 'SDL.InputMotion' of the click -> Int -- The number of clicks - -> Affection us () + -> Affection us msg () -- | A helper function that checks wether provided clickables have been clicked. -- This function does not consume provided events, but passes them on. @@ -25,7 +25,7 @@ handleMouseClicks :: (Foldable t, MouseClickable clickable us) => SDL.EventPayload -- ^ Piped event in -> t clickable -- ^ 'MouseClickable' elemt to be checked - -> Affection us SDL.EventPayload -- ^ Unaltered event + -> Affection us msg SDL.EventPayload -- ^ Unaltered event handleMouseClicks e clickables = case e of SDL.MouseButtonEvent dat -> do diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs index 067ae78..c2f9f3d 100644 --- a/src/Affection/StateMachine.hs +++ b/src/Affection/StateMachine.hs @@ -7,8 +7,8 @@ import Affection.Types import qualified SDL class StateMachine a us where - smLoad :: a -> Affection us () - smUpdate :: a -> Double -> Affection us () - smEvent :: a -> SDL.EventPayload -> Affection us () - smDraw :: a -> Affection us () - smClean :: a -> Affection us () + smLoad :: a -> Affection us msg () + smUpdate :: a -> Double -> Affection us msg () + smEvent :: a -> SDL.EventPayload -> Affection us msg () + smDraw :: a -> Affection us msg () + smClean :: a -> Affection us msg () diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index fd0882f..805047e 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,17 +1,31 @@ -module Affection.Subsystem.AffectionWindow where +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.Subsystems.AffectionWindow where import Affection.MessageBus import Affection.Subsystems.Class +import Affection.Types + +import Control.Monad.State.Class (get) +import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow = AffectionWindow +data AffectionWindow msg = AffectionWindow { windowChannel :: Channel msg } -instance Participant AffectionWindow where +instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where partChannel = windowChannel + partInit = do + ad <- get + nchan <- liftIO $ dupChannel $ messageChannel ad + return $ AffectionWindow + { windowChannel = nchan + } + partListen p = do let chan = partChannel p mmsg <- tryPeekChannel chan @@ -21,50 +35,50 @@ instance Participant AffectionWindow where let chan = partChannel p writeChannel chan m -instance Subsystem AffectionWindow where +instance Subsystem (AffectionWindow (SystemMessage m)) (SystemMessage m) where consumeEvents aw evs = doConsume evs where doConsume (e:es) = case SDL.eventPayload e of - SDL.WindowShownEvent (SDL.WindowShownEventData window) = do - partEmit aw (MsgWindowShown (SDL.eventTiemstamp e) window) + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShown (SDL.eventTimestamp e) window) doConsume es - SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) = do - partEmit aw (MsgWindowHidden (SDL.eventTimestemp e) window) + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHidden (SDL.eventTimestamp e) window) doConsume es - SDL.WindowExposedEvent (SDL.WindowExposedEventData window) = do + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window) doConsume es - SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) = do - partEmit aw (MsgWindowMoved (SDL.EventTimestamp e) window newPos) + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMoved (SDL.eventTimestamp e) window newPos) doConsume es - SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) = do - partEmit aw (MsgWindowResized (SDL.EventTimestamp e) window newSize) + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResized (SDL.eventTimestamp e) window newSize) doConsume es - SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) = do - partEmit aw (MsgWindowSizeChanged (SDL.EventTimestamp e) window) + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChanged (SDL.eventTimestamp e) window) doConsume es - SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) = do - partEmit aw (MsgWindowMinimized (SDL.eventTimestemp e) window) + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimized (SDL.eventTimestamp e) window) doConsume es - SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) = do - partEmit aw (MsgWindowMaximized (SDL.eventTimestemp e) window) + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximized (SDL.eventTimestamp e) window) doConsume es - SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) = do - partEmit aw (MsgWindowRestored (SDL.eventTimestemp e) window) + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestored (SDL.eventTimestamp e) window) doConsume es - SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) = do - partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestemp e) window) + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestamp e) window) doConsume es - SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) = do - partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestemp e) window) + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestamp e) window) doConsume es - SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) = do - partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestemp e) window) + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestamp e) window) doConsume es - SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) = do - partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestemp e) window) + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestamp e) window) doConsume es - SDL.WindowClosed (SDL.WindowClosedEventData window) = do - partEmit aw (MsgWindowClosed (SDL.eventTimestemp e) window) + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClosed (SDL.eventTimestamp e) window) doConsume es - _ = fmap (e :) (doConsume es) + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index 7caea9f..e104640 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} module Affection.Subsystems.Class where -import Affection.MessageBus.Class +import Affection.MessageBus import qualified SDL -class (Participant s) => Subsystem s where +class (Message m, Participant s m) => Subsystem s m where consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event] diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index df107dc..bb0b1e9 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -42,6 +42,7 @@ import Data.Map.Strict as M import Control.Monad.IO.Class import Control.Monad.State import qualified Control.Monad.Parallel as MP +import Control.Concurrent.STM as STM import System.Clock (TimeSpec) -- import Control.Monad.Reader @@ -50,8 +51,10 @@ import System.Clock (TimeSpec) import Foreign.Ptr (Ptr) +import Affection.MessageBus.Message + -- | Configuration for the aplication. needed at startup. -data AffectionConfig us = AffectionConfig +data AffectionConfig us msg = AffectionConfig { initComponents :: InitComponents -- ^ SDL components to initialize at startup , windowTitle :: T.Text @@ -62,13 +65,13 @@ data AffectionConfig us = AffectionConfig -- ^ size of the texture canvas , initScreenMode :: SDL.WindowMode -- ^ Window mode to start in - , preLoop :: Affection us () + , preLoop :: Affection us msg () -- ^ Actions to be performed, before loop starts - , eventLoop :: SDL.EventPayload -> Affection us () + , eventLoop :: SDL.EventPayload -> Affection us msg () -- ^ Main update function. Takes fractions of a second as input. - , updateLoop :: Double -> Affection us () + , updateLoop :: Double -> Affection us msg () -- ^ Main update function. Takes fractions of a second as input. - , drawLoop :: Affection us () + , drawLoop :: Affection us msg () -- ^ Function for updating graphics. , loadState :: IO us -- ^ Provide your own load function to create this data. @@ -82,7 +85,7 @@ data InitComponents | Only [SDL.InitFlag] -- | Main type for defining the look, feel and action of the whole application. -data AffectionData us = AffectionData +data AffectionData us msg = AffectionData -- { affectionConfig :: AffectionConfig us -- ^ Application configuration. { quitEvent :: Bool -- ^ Loop breaker. , userState :: us -- ^ State data provided by user @@ -100,6 +103,7 @@ data AffectionData us = AffectionData , deltaTime :: Double -- ^ Elapsed time in seconds since last tick , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) , pausedTime :: Bool -- ^ Should the update loop be executed? + , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from } -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated @@ -127,7 +131,7 @@ newtype AffectionState us m a = AffectionState instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m) -type Affection us a = AffectionState (AffectionData us) IO a +type Affection us msg a = AffectionState (AffectionData us msg) IO a -- -- | Inner 'StateT' monad of Affection -- type AffectionInner us od a = StateT (AffectionState us od) IO a @@ -228,3 +232,5 @@ type Angle = Double -- { partStorLatest :: Maybe Particle -- ^ The particle stored last -- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime -- } + +newtype (Message msg) => Channel msg = Channel (TChan msg) diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index 9cf794a..84d0dd2 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -10,12 +10,12 @@ import System.Clock import Control.Monad.State -- Prehandle SDL events in case any window events occur -preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] +preHandleEvents :: [SDL.Event] -> Affection us msg [SDL.EventPayload] preHandleEvents evs = return $ map SDL.eventPayload evs -- | Return the userstate to the user -getAffection :: Affection us us +getAffection :: Affection us msg us getAffection = do ad <- get return $ userState ad @@ -23,7 +23,7 @@ getAffection = do -- | Put altered user state back putAffection :: us -- User state - -> Affection us () + -> Affection us msg () putAffection us = do ad <- get put $ ad @@ -36,20 +36,20 @@ delaySec delaySec dur = SDL.delay (fromIntegral $ dur * 1000) -- | Get time since start but always the same in the current tick. -getElapsedTime :: Affection us Double +getElapsedTime :: Affection us msg Double getElapsedTime = elapsedTime <$> get -getDelta :: Affection us Double +getDelta :: Affection us msg Double getDelta = deltaTime <$> get -quit :: Affection us () +quit :: Affection us msg () quit = do ad <- get put $ ad { quitEvent = True } -toggleScreen :: Affection us () +toggleScreen :: Affection us msg () toggleScreen = do ad <- get newMode <- case screenMode ad of From c40cd04d999b5742ada5df84b0cf44ac2e5ba97a Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 29 Nov 2017 08:29:44 +0100 Subject: [PATCH 06/24] it compiles now. messagebus will have multiple channels --- src/Affection/MessageBus/Class.hs | 10 +++++----- src/Affection/MessageBus/Message.hs | 16 ++++++++-------- src/Affection/Subsystems/AffectionWindow.hs | 18 +++++++++--------- 3 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 4f888cc..80a1c51 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -5,11 +5,11 @@ module Affection.MessageBus.Class where import Affection.MessageBus.Message import Affection.Types -class (Message msg) => Participant prt msg where - partChannel :: prt -> Channel msg +class Participant prt m where + partChannel :: prt -> Channel m - partInit :: Affection sd msg prt + partInit :: Affection sd m prt - partListen :: prt -> IO (Maybe msg) + partListen :: prt -> IO (Maybe m) - partEmit :: prt -> msg -> IO () + partEmit :: prt -> m -> IO () diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index bedf10c..b96419d 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -11,12 +11,12 @@ import Linear (V2(..)) class Message msg where msgTime :: msg -> Word32 -data SystemMessage m - = MsgUserMessage - { msgUMWhen :: Word32 - , msgUMPayload :: m - } -- ^ Generic user defined message with custom payload - | MsgEngineReady Word32 +data SystemMessage + -- = MsgUserMessage + -- { msgUMWhen :: Word32 + -- , msgUMPayload :: m + -- } -- ^ Generic user defined message with custom payload + = MsgEngineReady Word32 | MsgWindowShown { msgWSWhen :: Word32 , msgWSWindow :: SDL.Window @@ -76,8 +76,8 @@ data SystemMessage m , msgWCWindow :: SDL.Window } -instance Message (SystemMessage m) where - msgTime (MsgUserMessage t _) = t +instance Message SystemMessage where + -- msgTime (MsgUserMessage t _) = t msgTime (MsgEngineReady t) = t msgTime (MsgWindowShown t _) = t msgTime (MsgWindowHidden t _) = t diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 805047e..2954ee5 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -7,21 +7,21 @@ import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types -import Control.Monad.State.Class (get) +import Control.Monad.State.Class (gets) import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow msg = AffectionWindow - { windowChannel :: Channel msg +data AffectionWindow m = AffectionWindow + { windowChannel :: Channel m } -instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where +instance (Message m) => Participant (AffectionWindow m) m where partChannel = windowChannel partInit = do - ad <- get - nchan <- liftIO $ dupChannel $ messageChannel ad + chan <- gets messageChannel :: Affection sd m (Channel m) + nchan <- liftIO $ dupChannel $ chan return $ AffectionWindow { windowChannel = nchan } @@ -31,11 +31,11 @@ instance Participant (AffectionWindow (SystemMessage m)) (SystemMessage m) where mmsg <- tryPeekChannel chan return mmsg - partEmit p m = do + partEmit p message = do let chan = partChannel p - writeChannel chan m + writeChannel chan message -instance Subsystem (AffectionWindow (SystemMessage m)) (SystemMessage m) where +instance Subsystem (AffectionWindow SystemMessage) SystemMessage where consumeEvents aw evs = doConsume evs where doConsume (e:es) = case SDL.eventPayload e of From df2f59c6b91eef26899a8055df0bad53914d925c Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 29 Nov 2017 17:49:56 +0100 Subject: [PATCH 07/24] splitting the messages up --- affection.cabal | 2 + src/Affection.hs | 13 +-- src/Affection/MessageBus/Message.hs | 99 +------------------ src/Affection/MessageBus/Message/Class.hs | 7 ++ .../MessageBus/Message/WindowMessage.hs | 89 +++++++++++++++++ 5 files changed, 105 insertions(+), 105 deletions(-) create mode 100644 src/Affection/MessageBus/Message/Class.hs create mode 100644 src/Affection/MessageBus/Message/WindowMessage.hs diff --git a/affection.cabal b/affection.cabal index 5315c9d..018d1ff 100644 --- a/affection.cabal +++ b/affection.cabal @@ -44,6 +44,8 @@ library , Affection.MessageBus.Util , Affection.MessageBus.Class , Affection.MessageBus.Message + , Affection.MessageBus.Message.Class + , Affection.MessageBus.Message.WindowMessage , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow default-extensions: OverloadedStrings diff --git a/src/Affection.hs b/src/Affection.hs index 5022675..59448a2 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -3,21 +3,12 @@ module Affection ( withAffection , get - , getAffection - , putAffection - , delaySec - , get , put , module A ) where import SDL (($=)) import qualified SDL -import qualified SDL.Internal.Numbered as SDL (toNumber) -import qualified SDL.Raw as Raw - -import Data.Maybe -import Data.IORef import System.Clock @@ -25,7 +16,6 @@ import Control.Monad.Loops import Control.Monad.State import Foreign.C.Types (CInt(..)) -import Foreign.Storable (peek) import Debug.Trace @@ -95,7 +85,8 @@ withAffection AffectionConfig{..} = do now <- liftIO $ getTime Monotonic let lastTime = sysTime ad -- compute dt and update elapsedTime - let !dt = fromIntegral (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ 9) + let !dt = fromIntegral + (toNanoSecs $ diffTimeSpec lastTime now) / (10 ^ (9 :: Int)) !ne = elapsedTime ad + dt put $ ad { elapsedTime = ne diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index b96419d..b1d0d46 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -1,95 +1,6 @@ -{-# LANGUAGE RankNTypes #-} -module Affection.MessageBus.Message where +module Affection.MessageBus.Message + ( module M + ) where -import Data.Word (Word32(..)) -import Data.Int (Int32(..)) - -import qualified SDL - -import Linear (V2(..)) - -class Message msg where - msgTime :: msg -> Word32 - -data SystemMessage - -- = MsgUserMessage - -- { msgUMWhen :: Word32 - -- , msgUMPayload :: m - -- } -- ^ Generic user defined message with custom payload - = MsgEngineReady Word32 - | MsgWindowShown - { msgWSWhen :: Word32 - , msgWSWindow :: SDL.Window - } - | MsgWindowHidden - { msgWHWhen :: Word32 - , msgWHWindow :: SDL.Window - } - | MsgWindowExposed - { msgWEWhen :: Word32 - , msgWEWindow :: SDL.Window - } - | MsgWindowMoved - { msgWMWhen :: Word32 - , msgWMWindow :: SDL.Window - , msgWMNewPos :: V2 Int32 - } - | MsgWindowResized - { msgWRWhen :: Word32 - , msgWRWindow :: SDL.Window - , msgWRNewSize :: V2 Int32 - } - | MsgWindowSizeChanged - { msgWSCWhen :: Word32 - , msgWSCWindow :: SDL.Window - } - | MsgWindowMinimized - { msgWMinWhen :: Word32 - , msgWMinWindow :: SDL.Window - } - | MsgWindowMaximized - { msgWMaxWhen :: Word32 - , msgWMaxWindow :: SDL.Window - } - | MsgWindowRestored - { msgWRestWhen :: Word32 - , msgWRestWindow :: SDL.Window - } - | MsgWindowGainedMouseFocus - { msgWGMFWhen :: Word32 - , msgWGMFWindow :: SDL.Window - } - | MsgWindowLostMouseFocus - { msgWLMFWhen :: Word32 - , msgWLMFWindow :: SDL.Window - } - | MsgWindowGainedKeyboardFocus - { msgWGKFWhen :: Word32 - , msgWGKFWindow :: SDL.Window - } - | MsgWindowLostKeyboardFocus - { msgWLKFWhen :: Word32 - , msgWLKFWindow :: SDL.Window - } - | MsgWindowClosed - { msgWCWhen :: Word32 - , msgWCWindow :: SDL.Window - } - -instance Message SystemMessage where - -- msgTime (MsgUserMessage t _) = t - msgTime (MsgEngineReady t) = t - msgTime (MsgWindowShown t _) = t - msgTime (MsgWindowHidden t _) = t - msgTime (MsgWindowExposed t _) = t - msgTime (MsgWindowMoved t _ _) = t - msgTime (MsgWindowResized t _ _) = t - msgTime (MsgWindowSizeChanged t _) = t - msgTime (MsgWindowMinimized t _) = t - msgTime (MsgWindowMaximized t _) = t - msgTime (MsgWindowRestored t _) = t - msgTime (MsgWindowGainedMouseFocus t _) = t - msgTime (MsgWindowLostMouseFocus t _) = t - msgTime (MsgWindowGainedKeyboardFocus t _) = t - msgTime (MsgWindowLostKeyboardFocus t _) = t - msgTime (MsgWindowClosed t _) = t +import Affection.MessageBus.Message.Class as M +import Affection.MessageBus.Message.WindowMessage as M diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs new file mode 100644 index 0000000..bd18c4b --- /dev/null +++ b/src/Affection/MessageBus/Message/Class.hs @@ -0,0 +1,7 @@ +module Affection.MessageBus.Message.Class where + +import Data.Word (Word32(..)) + + +class Message msg where + msgTime :: msg -> Word32 diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs new file mode 100644 index 0000000..95b9795 --- /dev/null +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE RankNTypes #-} +module Affection.MessageBus.Message.WindowMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word32(..)) +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data SystemMessage + = MsgEngineReady Word32 + | MsgWindowShown + { msgWSWhen :: Word32 + , msgWSWindow :: SDL.Window + } + | MsgWindowHidden + { msgWHWhen :: Word32 + , msgWHWindow :: SDL.Window + } + | MsgWindowExposed + { msgWEWhen :: Word32 + , msgWEWindow :: SDL.Window + } + | MsgWindowMoved + { msgWMWhen :: Word32 + , msgWMWindow :: SDL.Window + , msgWMNewPos :: V2 Int32 + } + | MsgWindowResized + { msgWRWhen :: Word32 + , msgWRWindow :: SDL.Window + , msgWRNewSize :: V2 Int32 + } + | MsgWindowSizeChanged + { msgWSCWhen :: Word32 + , msgWSCWindow :: SDL.Window + } + | MsgWindowMinimized + { msgWMinWhen :: Word32 + , msgWMinWindow :: SDL.Window + } + | MsgWindowMaximized + { msgWMaxWhen :: Word32 + , msgWMaxWindow :: SDL.Window + } + | MsgWindowRestored + { msgWRestWhen :: Word32 + , msgWRestWindow :: SDL.Window + } + | MsgWindowGainedMouseFocus + { msgWGMFWhen :: Word32 + , msgWGMFWindow :: SDL.Window + } + | MsgWindowLostMouseFocus + { msgWLMFWhen :: Word32 + , msgWLMFWindow :: SDL.Window + } + | MsgWindowGainedKeyboardFocus + { msgWGKFWhen :: Word32 + , msgWGKFWindow :: SDL.Window + } + | MsgWindowLostKeyboardFocus + { msgWLKFWhen :: Word32 + , msgWLKFWindow :: SDL.Window + } + | MsgWindowClosed + { msgWCWhen :: Word32 + , msgWCWindow :: SDL.Window + } + +instance Message SystemMessage where + msgTime (MsgEngineReady t) = t + msgTime (MsgWindowShown t _) = t + msgTime (MsgWindowHidden t _) = t + msgTime (MsgWindowExposed t _) = t + msgTime (MsgWindowMoved t _ _) = t + msgTime (MsgWindowResized t _ _) = t + msgTime (MsgWindowSizeChanged t _) = t + msgTime (MsgWindowMinimized t _) = t + msgTime (MsgWindowMaximized t _) = t + msgTime (MsgWindowRestored t _) = t + msgTime (MsgWindowGainedMouseFocus t _) = t + msgTime (MsgWindowLostMouseFocus t _) = t + msgTime (MsgWindowGainedKeyboardFocus t _) = t + msgTime (MsgWindowLostKeyboardFocus t _) = t + msgTime (MsgWindowClosed t _) = t From d6f80ed1f01d32b70647669681f7d6c17879b65c Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 6 Dec 2017 06:36:25 +0100 Subject: [PATCH 08/24] rename message type --- src/Affection/MessageBus/Message/WindowMessage.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 95b9795..b9e3727 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -10,7 +10,7 @@ import qualified SDL import Linear (V2(..)) -data SystemMessage +data WindowMessage = MsgEngineReady Word32 | MsgWindowShown { msgWSWhen :: Word32 @@ -71,7 +71,7 @@ data SystemMessage , msgWCWindow :: SDL.Window } -instance Message SystemMessage where +instance Message WindowMessage where msgTime (MsgEngineReady t) = t msgTime (MsgWindowShown t _) = t msgTime (MsgWindowHidden t _) = t From c33aa67c3e8e2f9ba89c066afb8fe2d00dbbdef8 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 10 Dec 2017 16:10:09 +0100 Subject: [PATCH 09/24] remove message type variable --- src/Affection/Types.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index bb0b1e9..d5bff6b 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -54,7 +54,7 @@ import Foreign.Ptr (Ptr) import Affection.MessageBus.Message -- | Configuration for the aplication. needed at startup. -data AffectionConfig us msg = AffectionConfig +data AffectionConfig us = AffectionConfig { initComponents :: InitComponents -- ^ SDL components to initialize at startup , windowTitle :: T.Text @@ -65,13 +65,13 @@ data AffectionConfig us msg = AffectionConfig -- ^ size of the texture canvas , initScreenMode :: SDL.WindowMode -- ^ Window mode to start in - , preLoop :: Affection us msg () + , preLoop :: Affection us () -- ^ Actions to be performed, before loop starts - , eventLoop :: SDL.EventPayload -> Affection us msg () + , eventLoop :: SDL.EventPayload -> Affection us () -- ^ Main update function. Takes fractions of a second as input. - , updateLoop :: Double -> Affection us msg () + , updateLoop :: Double -> Affection us () -- ^ Main update function. Takes fractions of a second as input. - , drawLoop :: Affection us msg () + , drawLoop :: Affection us () -- ^ Function for updating graphics. , loadState :: IO us -- ^ Provide your own load function to create this data. @@ -103,7 +103,7 @@ data AffectionData us msg = AffectionData , deltaTime :: Double -- ^ Elapsed time in seconds since last tick , sysTime :: TimeSpec -- ^ System time (NOT the time on the clock) , pausedTime :: Bool -- ^ Should the update loop be executed? - , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from + -- , messageChannel :: Channel msg -- ^ The main broadcast channel to duplicate all others from } -- -- | This datatype stores information about areas of a 'G.GeglBuffer' to be updated @@ -122,16 +122,16 @@ data AffectionData us msg = AffectionData -- | Inner 'StateT' monad for the update state -- type AffectionStateInner us m a = StateT (AffectionData us) m a -type AffectionStateInner us m a = StateT us m a +type AffectionStateInner us a = StateT us a -- | Affection's state monad -newtype AffectionState us m a = AffectionState - { runState :: AffectionStateInner us m a } +newtype AffectionState us a = AffectionState + { runState :: AffectionStateInner us a } deriving (Functor, Applicative, Monad, MonadIO, MonadState us) -instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m) +instance MP.MonadParallel m => MP.MonadParallel (AffectionState us) -type Affection us msg a = AffectionState (AffectionData us msg) IO a +type Affection us a = AffectionState (AffectionData us) IO a -- -- | Inner 'StateT' monad of Affection -- type AffectionInner us od a = StateT (AffectionState us od) IO a From c82325a1bd35d2ba65784d233d7c5cbca21bf050 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Dec 2017 13:10:00 +0100 Subject: [PATCH 10/24] logging module --- affection.cabal | 22 ++++++++++++++++++++++ src/Affection/Logging.hs | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+) create mode 100644 src/Affection/Logging.hs diff --git a/affection.cabal b/affection.cabal index 018d1ff..97fc92d 100644 --- a/affection.cabal +++ b/affection.cabal @@ -30,12 +30,34 @@ source-repository head type: git location: https://github.com/nek0/affection +flag debug + description: Enable debug messages + default: False + manual: True + +flag warn + description: Enable warning messages + default: False + manual: True + +flag error + description: Enable error messages + default: False + manual: True + flag examples description: Build example programs default: False library + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR exposed-modules: Affection + , Affection.Logging , Affection.Types , Affection.StateMachine , Affection.MouseInteractable diff --git a/src/Affection/Logging.hs b/src/Affection/Logging.hs new file mode 100644 index 0000000..0cf3032 --- /dev/null +++ b/src/Affection/Logging.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} +module Affection.Logging where + +import Debug.Trace + +data LogLevel + = Debug + | Warn + | Error + +log :: LogLevel -> String -> a -> a +#if defined(DEBUG) +log Debug s = trace ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) +log Warn s = trace ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) +log Error s = trace ("ERROR: " ++ s) +#endif +log _ _ = id + +logIO :: LogLevel -> String -> IO () +#if defined(DEBUG) +logIO Debug s = traceIO ("DEBUG: " ++ s) +#endif +#if defined(WARN) || defined(DEBUG) +logIO Warn s = traceIO ("WARN: " ++ s) +#endif +#if defined(ERROR) || defined(WARN) || defined(DEBUG) +logIO Error s = traceIO ("ERROR: " ++ s) +#endif +logIO _ _ = return () From 853951df5bab95315d3662e80fc725fa1dce9f50 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Dec 2017 13:10:55 +0100 Subject: [PATCH 11/24] keyboard subsystem added --- affection.cabal | 2 + .../MessageBus/Message/KeyboardMessage.hs | 18 ++++++++ src/Affection/Subsystems/AffectionKeyboard.hs | 44 +++++++++++++++++++ 3 files changed, 64 insertions(+) create mode 100644 src/Affection/MessageBus/Message/KeyboardMessage.hs create mode 100644 src/Affection/Subsystems/AffectionKeyboard.hs diff --git a/affection.cabal b/affection.cabal index 97fc92d..0f144f5 100644 --- a/affection.cabal +++ b/affection.cabal @@ -68,8 +68,10 @@ library , Affection.MessageBus.Message , Affection.MessageBus.Message.Class , Affection.MessageBus.Message.WindowMessage + , Affection.MessageBus.Message.KeyboardMessage , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow + , Affection.Subsystems.AffectionKeyboard default-extensions: OverloadedStrings -- Modules included in this library but not exported. diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs new file mode 100644 index 0000000..e783592 --- /dev/null +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -0,0 +1,18 @@ +module Affection.MessageBus.Message.KeyboardMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word32(..)) + +import qualified SDL + +data KeyboardMessage = MsgKeyboardEvent + { msgKbdWhen :: Word32 + , msgKbdWindow :: Maybe SDL.Window + , msgKbdKeyMotion :: SDL.InputMotion + , msgKbdLeyRepeat :: Bool + , msgKbdKeysym :: SDL.Keysym + } + +instance Message KeyboardMessage where + msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs new file mode 100644 index 0000000..de5ad62 --- /dev/null +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +module Affection.Subsystems.AffectionKeyboard where + +import Affection.MessageBus +import Affection.Subsystems.Class +import Affection.Types + +import Control.Monad.IO.Class (liftIO) + +import qualified SDL + +data AffectionKeyboard = AffectionKeyboard + { keyboardInChannel :: Channel KeyboardMessage + , keyboardOutChannel :: Channel KeyboardMessage + } + +instance Participant AffectionKeyboard KeyboardMessage where + partChannel = keyboardOutChannel + + partInit ichan = do + ochan <- liftIO $ newBroadcastChannel + return $ AffectionKeyboard ichan ochan + + partListen p = + liftIO $ tryPeekChannel (keyboardInChannel p) + + partEmit p m = + liftIO $ writeChannel (keyboardOutChannel p) m + +instance SDLSubsystem AffectionKeyboard KeyboardMessage where + consumeSDLEvents ak evs = doConsume evs + where + doConsume [] = return [] + doConsume (e:es) = case SDL.eventPayload e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + (SDL.eventTimestamp e) + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) From f44021f03483b415cd0f6d733388491a1b1a96fe Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Dec 2017 13:12:06 +0100 Subject: [PATCH 12/24] eliminate msg --- src/Affection.hs | 2 +- src/Affection/MessageBus/Message/Class.hs | 1 - src/Affection/MouseInteractable.hs | 4 ++-- src/Affection/StateMachine.hs | 10 +++++----- src/Affection/Types.hs | 8 ++++---- src/Affection/Util.hs | 14 +++++++------- 6 files changed, 19 insertions(+), 20 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index 59448a2..2917ec7 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -30,7 +30,7 @@ import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) -- | Main function which bootstraps everything else. withAffection - :: AffectionConfig us msg -- ^ Configuration of the Game and its engine. + :: AffectionConfig us -- ^ Configuration of the Game and its engine. -> IO () withAffection AffectionConfig{..} = do -- intialiaze SDL diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs index bd18c4b..b97de31 100644 --- a/src/Affection/MessageBus/Message/Class.hs +++ b/src/Affection/MessageBus/Message/Class.hs @@ -2,6 +2,5 @@ module Affection.MessageBus.Message.Class where import Data.Word (Word32(..)) - class Message msg where msgTime :: msg -> Word32 diff --git a/src/Affection/MouseInteractable.hs b/src/Affection/MouseInteractable.hs index 5e0c1f5..e3a6436 100644 --- a/src/Affection/MouseInteractable.hs +++ b/src/Affection/MouseInteractable.hs @@ -17,7 +17,7 @@ class MouseClickable a us where -> (Int, Int) -- The coordinates of the click -> SDL.InputMotion -- The 'SDL.InputMotion' of the click -> Int -- The number of clicks - -> Affection us msg () + -> Affection us () -- | A helper function that checks wether provided clickables have been clicked. -- This function does not consume provided events, but passes them on. @@ -25,7 +25,7 @@ handleMouseClicks :: (Foldable t, MouseClickable clickable us) => SDL.EventPayload -- ^ Piped event in -> t clickable -- ^ 'MouseClickable' elemt to be checked - -> Affection us msg SDL.EventPayload -- ^ Unaltered event + -> Affection us SDL.EventPayload -- ^ Unaltered event handleMouseClicks e clickables = case e of SDL.MouseButtonEvent dat -> do diff --git a/src/Affection/StateMachine.hs b/src/Affection/StateMachine.hs index c2f9f3d..067ae78 100644 --- a/src/Affection/StateMachine.hs +++ b/src/Affection/StateMachine.hs @@ -7,8 +7,8 @@ import Affection.Types import qualified SDL class StateMachine a us where - smLoad :: a -> Affection us msg () - smUpdate :: a -> Double -> Affection us msg () - smEvent :: a -> SDL.EventPayload -> Affection us msg () - smDraw :: a -> Affection us msg () - smClean :: a -> Affection us msg () + smLoad :: a -> Affection us () + smUpdate :: a -> Double -> Affection us () + smEvent :: a -> SDL.EventPayload -> Affection us () + smDraw :: a -> Affection us () + smClean :: a -> Affection us () diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index d5bff6b..8810fe1 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -85,7 +85,7 @@ data InitComponents | Only [SDL.InitFlag] -- | Main type for defining the look, feel and action of the whole application. -data AffectionData us msg = AffectionData +data AffectionData us = AffectionData -- { affectionConfig :: AffectionConfig us -- ^ Application configuration. { quitEvent :: Bool -- ^ Loop breaker. , userState :: us -- ^ State data provided by user @@ -125,11 +125,11 @@ data AffectionData us msg = AffectionData type AffectionStateInner us a = StateT us a -- | Affection's state monad -newtype AffectionState us a = AffectionState - { runState :: AffectionStateInner us a } +newtype AffectionState us m a = AffectionState + { runState :: AffectionStateInner us m a } deriving (Functor, Applicative, Monad, MonadIO, MonadState us) -instance MP.MonadParallel m => MP.MonadParallel (AffectionState us) +instance MP.MonadParallel m => MP.MonadParallel (AffectionState us m) type Affection us a = AffectionState (AffectionData us) IO a diff --git a/src/Affection/Util.hs b/src/Affection/Util.hs index 84d0dd2..9cf794a 100644 --- a/src/Affection/Util.hs +++ b/src/Affection/Util.hs @@ -10,12 +10,12 @@ import System.Clock import Control.Monad.State -- Prehandle SDL events in case any window events occur -preHandleEvents :: [SDL.Event] -> Affection us msg [SDL.EventPayload] +preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload] preHandleEvents evs = return $ map SDL.eventPayload evs -- | Return the userstate to the user -getAffection :: Affection us msg us +getAffection :: Affection us us getAffection = do ad <- get return $ userState ad @@ -23,7 +23,7 @@ getAffection = do -- | Put altered user state back putAffection :: us -- User state - -> Affection us msg () + -> Affection us () putAffection us = do ad <- get put $ ad @@ -36,20 +36,20 @@ delaySec delaySec dur = SDL.delay (fromIntegral $ dur * 1000) -- | Get time since start but always the same in the current tick. -getElapsedTime :: Affection us msg Double +getElapsedTime :: Affection us Double getElapsedTime = elapsedTime <$> get -getDelta :: Affection us msg Double +getDelta :: Affection us Double getDelta = deltaTime <$> get -quit :: Affection us msg () +quit :: Affection us () quit = do ad <- get put $ ad { quitEvent = True } -toggleScreen :: Affection us msg () +toggleScreen :: Affection us () toggleScreen = do ad <- get newMode <- case screenMode ad of From aa7be8488399197ba2a70ab546dc4ba9c7721520 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Dec 2017 13:12:27 +0100 Subject: [PATCH 13/24] moar documentation --- src/Affection/MessageBus/Class.hs | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 80a1c51..b83e99b 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,15 +1,33 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} module Affection.MessageBus.Class where import Affection.MessageBus.Message import Affection.Types -class Participant prt m where - partChannel :: prt -> Channel m +class (Message m) => Participant prt m where + -- | get the outbound 'Channel' of the 'Participant' + partChannel + :: prt -- ^ The 'Participant' + -> Channel m -- ^ Outbound 'Channel' - partInit :: Affection sd m prt + -- | Initialize the 'Participant' with an inbound 'Channel' + partInit + :: Channel m -- ^ Inbound 'Channel' the 'Participant' will listen to + -> Affection sd prt -- ^ The constructed and initialized 'Participant' - partListen :: prt -> IO (Maybe m) + -- Get the 'Participant' to listen to its inbound 'Channel' + partListen + :: prt -- ^ The 'Participant' + -> Affection sd (Maybe m) -- ^ The optional 'Message' peeked from the 'Channel' - partEmit :: prt -> m -> IO () + -- Get the 'Participant' to emit a Message on its outbound 'Channel' + partEmit + :: prt -- ^ The 'Participant' + -> m -- ^ The 'Message' to emit + -> Affection sd () + +-- data Envelope = Envelope +-- { envFrom :: (Participant a _) => a +-- , envTo :: (Participant b _) => b +-- , envMessage :: (Message msg) => msg +-- } From 64537fe1c7ad108df0a2805bae2cbd859b040fbb Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Dec 2017 13:12:47 +0100 Subject: [PATCH 14/24] generalize --- src/Affection/MessageBus/Message.hs | 1 + .../MessageBus/Message/WindowMessage.hs | 60 ++++++++--------- src/Affection/Subsystems/AffectionWindow.hs | 64 +++++++++---------- src/Affection/Subsystems/Class.hs | 5 +- 4 files changed, 64 insertions(+), 66 deletions(-) diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index b1d0d46..6712571 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -4,3 +4,4 @@ module Affection.MessageBus.Message import Affection.MessageBus.Message.Class as M import Affection.MessageBus.Message.WindowMessage as M +import Affection.MessageBus.Message.KeyboardMessage as M diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index b9e3727..d410b2e 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -11,79 +11,79 @@ import qualified SDL import Linear (V2(..)) data WindowMessage - = MsgEngineReady Word32 - | MsgWindowShown + -- = MsgEngineReady Word32 + = MsgWindowShow { msgWSWhen :: Word32 , msgWSWindow :: SDL.Window } - | MsgWindowHidden + | MsgWindowHide { msgWHWhen :: Word32 , msgWHWindow :: SDL.Window } - | MsgWindowExposed + | MsgWindowExpose { msgWEWhen :: Word32 , msgWEWindow :: SDL.Window } - | MsgWindowMoved + | MsgWindowMove { msgWMWhen :: Word32 , msgWMWindow :: SDL.Window , msgWMNewPos :: V2 Int32 } - | MsgWindowResized + | MsgWindowResize { msgWRWhen :: Word32 , msgWRWindow :: SDL.Window , msgWRNewSize :: V2 Int32 } - | MsgWindowSizeChanged + | MsgWindowSizeChange { msgWSCWhen :: Word32 , msgWSCWindow :: SDL.Window } - | MsgWindowMinimized + | MsgWindowMinimize { msgWMinWhen :: Word32 , msgWMinWindow :: SDL.Window } - | MsgWindowMaximized + | MsgWindowMaximize { msgWMaxWhen :: Word32 , msgWMaxWindow :: SDL.Window } - | MsgWindowRestored + | MsgWindowRestore { msgWRestWhen :: Word32 , msgWRestWindow :: SDL.Window } - | MsgWindowGainedMouseFocus + | MsgWindowGainMouseFocus { msgWGMFWhen :: Word32 , msgWGMFWindow :: SDL.Window } - | MsgWindowLostMouseFocus + | MsgWindowLoseMouseFocus { msgWLMFWhen :: Word32 , msgWLMFWindow :: SDL.Window } - | MsgWindowGainedKeyboardFocus + | MsgWindowGainKeyboardFocus { msgWGKFWhen :: Word32 , msgWGKFWindow :: SDL.Window } - | MsgWindowLostKeyboardFocus + | MsgWindowLoseKeyboardFocus { msgWLKFWhen :: Word32 , msgWLKFWindow :: SDL.Window } - | MsgWindowClosed + | MsgWindowClose { msgWCWhen :: Word32 , msgWCWindow :: SDL.Window } instance Message WindowMessage where - msgTime (MsgEngineReady t) = t - msgTime (MsgWindowShown t _) = t - msgTime (MsgWindowHidden t _) = t - msgTime (MsgWindowExposed t _) = t - msgTime (MsgWindowMoved t _ _) = t - msgTime (MsgWindowResized t _ _) = t - msgTime (MsgWindowSizeChanged t _) = t - msgTime (MsgWindowMinimized t _) = t - msgTime (MsgWindowMaximized t _) = t - msgTime (MsgWindowRestored t _) = t - msgTime (MsgWindowGainedMouseFocus t _) = t - msgTime (MsgWindowLostMouseFocus t _) = t - msgTime (MsgWindowGainedKeyboardFocus t _) = t - msgTime (MsgWindowLostKeyboardFocus t _) = t - msgTime (MsgWindowClosed t _) = t + -- msgTime (MsgEngineReady t) = t + msgTime (MsgWindowShow t _) = t + msgTime (MsgWindowHide t _) = t + msgTime (MsgWindowExpose t _) = t + msgTime (MsgWindowMove t _ _) = t + msgTime (MsgWindowResize t _ _) = t + msgTime (MsgWindowSizeChange t _) = t + msgTime (MsgWindowMinimize t _) = t + msgTime (MsgWindowMaximize t _) = t + msgTime (MsgWindowRestore t _) = t + msgTime (MsgWindowGainMouseFocus t _) = t + msgTime (MsgWindowLoseMouseFocus t _) = t + msgTime (MsgWindowGainKeyboardFocus t _) = t + msgTime (MsgWindowLoseKeyboardFocus t _) = t + msgTime (MsgWindowClose t _) = t diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 2954ee5..26eb841 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,84 +1,80 @@ -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE AllowAmbiguousTypes #-} module Affection.Subsystems.AffectionWindow where import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types -import Control.Monad.State.Class (gets) import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow m = AffectionWindow - { windowChannel :: Channel m +data AffectionWindow = AffectionWindow + { windowInChannel :: Channel WindowMessage + , windowOutChannel :: Channel WindowMessage } -instance (Message m) => Participant (AffectionWindow m) m where - partChannel = windowChannel +instance Participant AffectionWindow WindowMessage where + partChannel = windowOutChannel - partInit = do - chan <- gets messageChannel :: Affection sd m (Channel m) - nchan <- liftIO $ dupChannel $ chan + partInit ichan = do + ochan <- liftIO $ newBroadcastChannel return $ AffectionWindow - { windowChannel = nchan + { windowOutChannel = ochan + , windowInChannel = ichan } - partListen p = do - let chan = partChannel p - mmsg <- tryPeekChannel chan - return mmsg + partListen p = + liftIO $ tryPeekChannel (windowInChannel p) - partEmit p message = do - let chan = partChannel p - writeChannel chan message + partEmit p message = + liftIO $ writeChannel (windowOutChannel p) message -instance Subsystem (AffectionWindow SystemMessage) SystemMessage where - consumeEvents aw evs = doConsume evs +instance SDLSubsystem AffectionWindow WindowMessage where + consumeSDLEvents aw evs = doConsume evs where + doConsume [] = return [] doConsume (e:es) = case SDL.eventPayload e of SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do - partEmit aw (MsgWindowShown (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window) doConsume es SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do - partEmit aw (MsgWindowHidden (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window) doConsume es SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do - partEmit aw (MsgWindowExposed (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window) doConsume es 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 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 SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do - partEmit aw (MsgWindowSizeChanged (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window) doConsume es SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do - partEmit aw (MsgWindowMinimized (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window) doConsume es SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do - partEmit aw (MsgWindowMaximized (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window) doConsume es SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do - partEmit aw (MsgWindowRestored (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window) doConsume es SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do - partEmit aw (MsgWindowGainedMouseFocus (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window) doConsume es SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do - partEmit aw (MsgWindowLostMouseFocus (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window) doConsume es SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowGainedKeyboardFocus (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window) doConsume es SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowLostKeyboardFocus (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window) doConsume es SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do - partEmit aw (MsgWindowClosed (SDL.eventTimestamp e) window) + partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window) doConsume es _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index e104640..6dc42f4 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -2,9 +2,10 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Affection.Subsystems.Class where +import Affection.Types import Affection.MessageBus import qualified SDL -class (Message m, Participant s m) => Subsystem s m where - consumeEvents :: s -> [SDL.Event] -> IO [SDL.Event] +class (Message m, Participant s m) => SDLSubsystem s m where + consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event] From 55d863e4cc7620a6c62355306e544ddb815c97a7 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Dec 2017 04:37:16 +0100 Subject: [PATCH 15/24] it builds! --- affection.cabal | 3 + src/Affection/MessageBus/Class.hs | 56 ++++++++++------ src/Affection/MessageBus/Message.hs | 1 + .../MessageBus/Message/KeyboardMessage.hs | 2 +- .../MessageBus/Message/MouseMessage.hs | 40 ++++++++++++ .../MessageBus/Message/WindowMessage.hs | 2 +- src/Affection/MessageBus/Util.hs | 30 +-------- src/Affection/Subsystems/AffectionKeyboard.hs | 23 +++---- src/Affection/Subsystems/AffectionMouse.hs | 64 +++++++++++++++++++ src/Affection/Subsystems/AffectionWindow.hs | 30 ++++----- src/Affection/Types.hs | 3 - 11 files changed, 173 insertions(+), 81 deletions(-) create mode 100644 src/Affection/MessageBus/Message/MouseMessage.hs create mode 100644 src/Affection/Subsystems/AffectionMouse.hs diff --git a/affection.cabal b/affection.cabal index 0f144f5..9055740 100644 --- a/affection.cabal +++ b/affection.cabal @@ -69,9 +69,11 @@ library , Affection.MessageBus.Message.Class , Affection.MessageBus.Message.WindowMessage , Affection.MessageBus.Message.KeyboardMessage + , Affection.MessageBus.Message.MouseMessage , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow , Affection.Subsystems.AffectionKeyboard + , Affection.Subsystems.AffectionMouse default-extensions: OverloadedStrings -- Modules included in this library but not exported. @@ -100,6 +102,7 @@ library , bytestring , OpenGL , stm + , uuid -- executable example00 -- hs-source-dirs: examples diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index b83e99b..3aa1fea 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,33 +1,49 @@ {-# LANGUAGE MultiParamTypeClasses #-} -module Affection.MessageBus.Class where +{-# LANGUAGE AllowAmbiguousTypes #-} +module Affection.MessageBus.Class + ( Participant(..) + , genUUID + , UUID + ) where import Affection.MessageBus.Message import Affection.Types -class (Message m) => Participant prt m where - -- | get the outbound 'Channel' of the 'Participant' - partChannel - :: prt -- ^ The 'Participant' - -> Channel m -- ^ Outbound 'Channel' +import Control.Monad.IO.Class (liftIO) - -- | Initialize the 'Participant' with an inbound 'Channel' - partInit - :: Channel m -- ^ Inbound 'Channel' the 'Participant' will listen to - -> Affection sd prt -- ^ The constructed and initialized 'Participant' +import Data.UUID +import Data.UUID.V4 - -- Get the 'Participant' to listen to its inbound 'Channel' - partListen - :: prt -- ^ The 'Participant' - -> Affection sd (Maybe m) -- ^ The optional 'Message' peeked from the 'Channel' +import Affection.Logging - -- Get the 'Participant' to emit a Message on its outbound 'Channel' +class (Show m, Message m) => Participant prt m where + -- | Function to get the lsit of subscribers from the participant + partSubscribers + :: prt -- ^ the participant + -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions + + -- | Subscribe to the 'Participant''s events + partSubscribe + :: prt -- ^ The 'Participant' to subscribe to + -> (m -> IO ()) -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function + + -- | Unsubscribe a Subscriber function from Participant + partUnSubscribe + :: prt -- ^ The 'Participant' to unsubscribe from + -> UUID -- ^ The subscriber function's 'UUID' + -> Affection sd () + + -- | Get the 'Participant' to emit a 'Message' on all of its subscribers partEmit :: prt -- ^ The 'Participant' -> m -- ^ The 'Message' to emit -> Affection sd () + partEmit p m = do + liftIO $ logIO Debug $ "Emitting message: " ++ show m + l <- partSubscribers p + mapM_ ($ m) l --- data Envelope = Envelope --- { envFrom :: (Participant a _) => a --- , envTo :: (Participant b _) => b --- , envMessage :: (Message msg) => msg --- } +genUUID :: Affection sd UUID +genUUID = liftIO $ nextRandom diff --git a/src/Affection/MessageBus/Message.hs b/src/Affection/MessageBus/Message.hs index 6712571..0af45ec 100644 --- a/src/Affection/MessageBus/Message.hs +++ b/src/Affection/MessageBus/Message.hs @@ -5,3 +5,4 @@ module Affection.MessageBus.Message import Affection.MessageBus.Message.Class as M import Affection.MessageBus.Message.WindowMessage as M import Affection.MessageBus.Message.KeyboardMessage as M +import Affection.MessageBus.Message.MouseMessage as M diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index e783592..e51b712 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -12,7 +12,7 @@ data KeyboardMessage = MsgKeyboardEvent , msgKbdKeyMotion :: SDL.InputMotion , msgKbdLeyRepeat :: Bool , msgKbdKeysym :: SDL.Keysym - } + } deriving (Show) instance Message KeyboardMessage where msgTime (MsgKeyboardEvent t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs new file mode 100644 index 0000000..a3c60d8 --- /dev/null +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -0,0 +1,40 @@ +module Affection.MessageBus.Message.MouseMessage where + +import Affection.MessageBus.Message.Class + +import Data.Word (Word32(..), Word8(..)) +import Data.Int (Int32(..)) + +import qualified SDL + +import Linear (V2(..)) + +data MouseMessage + = MsgMouseMotion + { msgMMWhen :: Word32 + , msgMMWindow :: Maybe SDL.Window + , msgMMWhich :: SDL.MouseDevice + , msgMMState :: [SDL.MouseButton] + , msgMMPos :: V2 Int32 + , msgMMRelMotion :: V2 Int32 + } + | MsgMouseButton + { msgMBWhen :: Word32 + , msgMBWindow :: Maybe SDL.Window + , msgMBWhich :: SDL.MouseDevice + , msgMBButton :: SDL.MouseButton + , msgMBClicks :: Word8 + , msgMBPos :: V2 Int32 + } + | MsgMouseWheel + { msgMWWhen :: Word32 + , msgMWWhindow :: Maybe SDL.Window + , msgMWWhich :: SDL.MouseDevice + , msgMWPos :: V2 Int32 + , msgMWDIrection :: SDL.MouseScrollDirection + } + +instance Message MouseMessage where + msgTime (MsgMouseMotion t _ _ _ _ _) = t + msgTime (MsgMouseButton t _ _ _ _ _) = t + msgTime (MsgMouseWheel t _ _ _ _) = t diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index d410b2e..43c4c46 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Message.WindowMessage where import Affection.MessageBus.Message.Class @@ -70,6 +69,7 @@ data WindowMessage { msgWCWhen :: Word32 , msgWCWindow :: SDL.Window } + deriving (Show) instance Message WindowMessage where -- msgTime (MsgEngineReady t) = t diff --git a/src/Affection/MessageBus/Util.hs b/src/Affection/MessageBus/Util.hs index 341f21b..b2cae3e 100644 --- a/src/Affection/MessageBus/Util.hs +++ b/src/Affection/MessageBus/Util.hs @@ -1,31 +1,3 @@ module Affection.MessageBus.Util where -import Affection.MessageBus.Class -import Affection.MessageBus.Message -import Affection.Types -import Control.Concurrent.STM as STM - --- | Build a new broadcast channel -newBroadcastChannel :: (Message msg) => IO (Channel msg) -newBroadcastChannel = atomically $ Channel <$> newBroadcastTChan - --- | Duplicate a broadcast channel, so it can be accessed by subsystems -dupChannel :: (Message msg) - => Channel msg -- ^ Original 'Channel' - -> IO (Channel msg) -- ^ 'Channel' duplicate -dupChannel (Channel c) = atomically $ Channel <$> dupTChan c - --- | Try to read a 'Channel' wihtout deleting the message. Returns 'Nothing' on --- an empty 'Channel' -tryPeekChannel :: (Message msg) - => Channel msg -- ^ Channel to read from - -> IO (Maybe msg) -- ^ Resulting message (or not) -tryPeekChannel (Channel c) = atomically $ tryPeekTChan c - --- | Write a message to a 'Channel' and thus broadcast it to all connected --- subsystems -writeChannel :: (Message msg) - => Channel msg -- ^ 'Channel' to write to - -> msg -- ^ The Message to emit - -> IO () -writeChannel (Channel c) m = atomically $ writeTChan c m +-- zuru zuru diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index de5ad62..094b559 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -6,26 +6,27 @@ import Affection.Subsystems.Class import Affection.Types import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM as STM import qualified SDL data AffectionKeyboard = AffectionKeyboard - { keyboardInChannel :: Channel KeyboardMessage - , keyboardOutChannel :: Channel KeyboardMessage + { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())] } instance Participant AffectionKeyboard KeyboardMessage where - partChannel = keyboardOutChannel + partSubscribe p funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) + return uuid - partInit ichan = do - ochan <- liftIO $ newBroadcastChannel - return $ AffectionKeyboard ichan ochan + partUnSubscribe p uuid = + liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) + (filter (\(u, _) -> u /= uuid)) - partListen p = - liftIO $ tryPeekChannel (keyboardInChannel p) - - partEmit p m = - liftIO $ writeChannel (keyboardOutChannel p) m + partSubscribers p = do + subTups <- liftIO $ readTVarIO $ keyboardSubscribers p + return $ map snd subTups instance SDLSubsystem AffectionKeyboard KeyboardMessage where consumeSDLEvents ak evs = doConsume evs diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs new file mode 100644 index 0000000..8c9f144 --- /dev/null +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -0,0 +1,64 @@ +module Affection.Subsystems.AffectionMouse where + +import Affection.MessageBus +import Affection.Subsystem.Class +import Affection.Types + +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM + +import qualified SDL + +data AffectionMouse = AffectionMouse + { mouseSubscribers :: TVar (UUID, MouseMessage -> IO ()) + } + +instance Participant AffectionMouse MouseMessage where + partSubscribe p funct = do + uuid <- genUUID + liftIO $ atmoically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) + return uuid + + partUnSubscribe p uuid = + liftIO $ atomically $ modifyTVar' (mouseSubscribers p) + (filter (\(u, _) -> u /= uuid)) + + partSubscribers p = + subTups <- liftIO $ readTVarIO $ mouseSubscribers p + return $ map snd subTups + +instance SDLSubsystem AffectionMouse where + consumeSDLEvents am evs = doComsume evs + where + doConsume [] = return [] + doConsume (e:es) = case SDL.EventPayload e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + (SDL.eventTimestamp dat) + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doComsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + (SDL.eventTimestamp e) + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + (SDL.eventTimestamp e) + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEvntWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doComsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 26eb841..90b560a 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,34 +1,32 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Affection.Subsystems.AffectionWindow where +import Affection.Types import Affection.MessageBus import Affection.Subsystems.Class -import Affection.Types +import Control.Concurrent.STM as STM import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow = AffectionWindow - { windowInChannel :: Channel WindowMessage - , windowOutChannel :: Channel WindowMessage +data AffectionWindow sd = AffectionWindow + { windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())] } instance Participant AffectionWindow WindowMessage where - partChannel = windowOutChannel + partSubscribe p funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) + return uuid - partInit ichan = do - ochan <- liftIO $ newBroadcastChannel - return $ AffectionWindow - { windowOutChannel = ochan - , windowInChannel = ichan - } + partUnSubscribe p uuid = + liftIO $ atomically $ modifyTVar' (windowSubscribers p) + (filter (\(u, _) -> u /= uuid)) - partListen p = - liftIO $ tryPeekChannel (windowInChannel p) - - partEmit p message = - liftIO $ writeChannel (windowOutChannel p) message + partSubscribers p = do + subTups <- liftIO $ readTVarIO $ windowSubscribers p + return $ map snd subTups instance SDLSubsystem AffectionWindow WindowMessage where consumeSDLEvents aw evs = doConsume evs diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 8810fe1..6e89dd7 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -42,7 +42,6 @@ import Data.Map.Strict as M import Control.Monad.IO.Class import Control.Monad.State import qualified Control.Monad.Parallel as MP -import Control.Concurrent.STM as STM import System.Clock (TimeSpec) -- import Control.Monad.Reader @@ -232,5 +231,3 @@ type Angle = Double -- { partStorLatest :: Maybe Particle -- ^ The particle stored last -- , partStorList :: [Particle] -- ^ List of particles in ascending order of remaining lifetime -- } - -newtype (Message msg) => Channel msg = Channel (TChan msg) From 1cbda31499a7c15c71424165395882e3404dfd10 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Dec 2017 05:05:18 +0100 Subject: [PATCH 16/24] fixing things up --- src/Affection/MessageBus/Class.hs | 3 +- .../MessageBus/Message/MouseMessage.hs | 1 + src/Affection/Subsystems/AffectionKeyboard.hs | 9 ++--- src/Affection/Subsystems/AffectionMouse.hs | 34 +++++++++++-------- src/Affection/Subsystems/AffectionWindow.hs | 7 ++-- 5 files changed, 31 insertions(+), 23 deletions(-) diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 3aa1fea..4ec6b7d 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -25,7 +26,7 @@ class (Show m, Message m) => Participant prt m where -- | Subscribe to the 'Participant''s events partSubscribe :: prt -- ^ The 'Participant' to subscribe to - -> (m -> IO ()) -- ^ What to do in case of a 'Message' + -> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index a3c60d8..4ff12b6 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -33,6 +33,7 @@ data MouseMessage , msgMWPos :: V2 Int32 , msgMWDIrection :: SDL.MouseScrollDirection } + deriving (Show) instance Message MouseMessage where msgTime (MsgMouseMotion t _ _ _ _ _) = t diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 094b559..188099a 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionKeyboard where import Affection.MessageBus @@ -10,11 +11,11 @@ import Control.Concurrent.STM as STM import qualified SDL -data AffectionKeyboard = AffectionKeyboard - { keyboardSubscribers :: TVar [(UUID, KeyboardMessage -> IO ())] +data AffectionKeyboard sd = AffectionKeyboard + { keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())] } -instance Participant AffectionKeyboard KeyboardMessage where +instance Participant (AffectionKeyboard sd) KeyboardMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) @@ -28,7 +29,7 @@ instance Participant AffectionKeyboard KeyboardMessage where subTups <- liftIO $ readTVarIO $ keyboardSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionKeyboard KeyboardMessage where +instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where consumeSDLEvents ak evs = doConsume evs where doConsume [] = return [] diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index 8c9f144..ff47e06 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -1,47 +1,51 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionMouse where import Affection.MessageBus -import Affection.Subsystem.Class +import Affection.Subsystems.Class import Affection.Types import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM +import Linear.Affine (unP) + import qualified SDL -data AffectionMouse = AffectionMouse - { mouseSubscribers :: TVar (UUID, MouseMessage -> IO ()) +data AffectionMouse sd = AffectionMouse + { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())] } -instance Participant AffectionMouse MouseMessage where +instance Participant (AffectionMouse sd) MouseMessage where partSubscribe p funct = do uuid <- genUUID - liftIO $ atmoically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) + liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) return uuid partUnSubscribe p uuid = liftIO $ atomically $ modifyTVar' (mouseSubscribers p) (filter (\(u, _) -> u /= uuid)) - partSubscribers p = + partSubscribers p = do subTups <- liftIO $ readTVarIO $ mouseSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionMouse where - consumeSDLEvents am evs = doComsume evs +instance SDLSubsystem (AffectionMouse sd) MouseMessage where + consumeSDLEvents am evs = doConsume evs where doConsume [] = return [] - doConsume (e:es) = case SDL.EventPayload e of + doConsume (e:es) = case SDL.eventPayload e of SDL.MouseMotionEvent dat -> do partEmit am (MsgMouseMotion - (SDL.eventTimestamp dat) + (SDL.eventTimestamp e) (SDL.mouseMotionEventWindow dat) (SDL.mouseMotionEventWhich dat) (SDL.mouseMotionEventState dat) - (SDL.mouseMotionEventPos dat) + (unP $ SDL.mouseMotionEventPos dat) (SDL.mouseMotionEventRelMotion dat) ) - doComsume es + doConsume es SDL.MouseButtonEvent dat -> do partEmit am (MsgMouseButton (SDL.eventTimestamp e) @@ -49,16 +53,16 @@ instance SDLSubsystem AffectionMouse where (SDL.mouseButtonEventWhich dat) (SDL.mouseButtonEventButton dat) (SDL.mouseButtonEventClicks dat) - (SDL.mouseButtonEventPos dat) + (unP $ SDL.mouseButtonEventPos dat) ) doConsume es SDL.MouseWheelEvent dat -> do partEmit am (MsgMouseWheel (SDL.eventTimestamp e) (SDL.mouseWheelEventWindow dat) - (SDL.mouseWheelEvntWhich dat) + (SDL.mouseWheelEventWhich dat) (SDL.mouseWheelEventPos dat) (SDL.mouseWheelEventDirection dat) ) doConsume es - _ -> fmap (e :) (doComsume es) + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 90b560a..aebe2ee 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -11,10 +12,10 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL data AffectionWindow sd = AffectionWindow - { windowSubscribers :: TVar [(UUID, WindowMessage -> Affection sd ())] + { windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())] } -instance Participant AffectionWindow WindowMessage where +instance Participant (AffectionWindow sd) WindowMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) @@ -28,7 +29,7 @@ instance Participant AffectionWindow WindowMessage where subTups <- liftIO $ readTVarIO $ windowSubscribers p return $ map snd subTups -instance SDLSubsystem AffectionWindow WindowMessage where +instance SDLSubsystem (AffectionWindow sd) WindowMessage where consumeSDLEvents aw evs = doConsume evs where doConsume [] = return [] From 78f058db6b46f2e9e9b8b1cef79fdceca1cfbc66 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Dec 2017 15:19:53 +0100 Subject: [PATCH 17/24] still won't work --- affection.cabal | 84 +++++----- examples/example00.hs | 150 ++++++------------ src/Affection.hs | 8 +- src/Affection/MessageBus.hs | 3 + src/Affection/MessageBus/Class.hs | 6 +- src/Affection/MessageBus/Message/Class.hs | 2 +- .../MessageBus/Message/KeyboardMessage.hs | 4 +- .../MessageBus/Message/MouseMessage.hs | 8 +- .../MessageBus/Message/WindowMessage.hs | 31 ++-- src/Affection/Subsystems.hs | 8 + src/Affection/Subsystems/AffectionKeyboard.hs | 28 ++-- src/Affection/Subsystems/AffectionMouse.hs | 68 ++++---- src/Affection/Subsystems/AffectionWindow.hs | 94 +++++------ src/Affection/Subsystems/Class.hs | 2 +- src/Affection/Types.hs | 6 +- 15 files changed, 239 insertions(+), 263 deletions(-) create mode 100644 src/Affection/Subsystems.hs diff --git a/affection.cabal b/affection.cabal index 9055740..00b97da 100644 --- a/affection.cabal +++ b/affection.cabal @@ -70,6 +70,7 @@ library , Affection.MessageBus.Message.WindowMessage , Affection.MessageBus.Message.KeyboardMessage , Affection.MessageBus.Message.MouseMessage + , Affection.Subsystems , Affection.Subsystems.Class , Affection.Subsystems.AffectionWindow , Affection.Subsystems.AffectionKeyboard @@ -104,23 +105,26 @@ library , stm , uuid --- executable example00 --- hs-source-dirs: examples --- main-is: example00.hs --- ghc-options: -threaded -Wall --- default-language: Haskell2010 --- default-extensions: OverloadedStrings --- if flag(examples) --- build-depends: base --- , affection --- , sdl2 --- , gegl --- , babl --- , containers --- , mtl --- else --- buildable: False --- +executable example00 + if flag(debug) + cpp-options: -DDEBUG + if flag(warn) + cpp-options: -DWARN + if flag(error) + cpp-options: -DERROR + hs-source-dirs: examples + main-is: example00.hs + ghc-options: -threaded -Wall + default-language: Haskell2010 + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base + , affection + , sdl2 + , stm + else + buildable: False + -- executable example01 -- hs-source-dirs: examples -- main-is: example01.hs @@ -209,26 +213,26 @@ library -- , monad-parallel -- else -- buildable: False - -executable example05 - hs-source-dirs: examples - main-is: example05.hs - ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts - default-language: Haskell2010 - default-extensions: OverloadedStrings - if flag(examples) - build-depends: base - , affection - , sdl2 - , gegl - , babl - , containers - , unordered-containers - , mtl - , random - , matrix - , random - , monad-parallel - , parallel - else - buildable: False +-- +-- executable example05 +-- hs-source-dirs: examples +-- main-is: example05.hs +-- ghc-options: -threaded -Wall -auto-all -caf-all -rtsopts +-- default-language: Haskell2010 +-- default-extensions: OverloadedStrings +-- if flag(examples) +-- build-depends: base +-- , affection +-- , sdl2 +-- , gegl +-- , babl +-- , containers +-- , unordered-containers +-- , mtl +-- , random +-- , matrix +-- , random +-- , monad-parallel +-- , parallel +-- else +-- buildable: False diff --git a/examples/example00.hs b/examples/example00.hs index def9f9e..9be083c 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,117 +1,71 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RankNTypes #-} import Affection import qualified SDL -import qualified SDL.Raw as Raw -import qualified GEGL as G -import qualified BABL as B -import qualified Data.Map.Strict as M -import Control.Monad (when) +import Control.Concurrent.STM -import Foreign.Storable (peek) -import Foreign.C.Types (CInt(..)) +data StateData = StateData + { sdSubs :: Subsystems + } -import Debug.Trace - --- main :: IO () --- main = withAllAffection $ --- withDefaultWindow "test" $ do --- changeColor $ RGBA 255 255 255 255 --- clear --- present --- liftIO $ delaySec 2 +data Subsystems = Subsystems + { subWindow :: AffectionWindow StateData + , subMouse :: AffectionMouse StateData + , subKeyboard :: AffectionKeyboard StateData + } main :: IO () main = do - conf <- return $ AffectionConfig - { initComponents = All - , windowTitle = "Affection: example00" - , windowConfig = SDL.defaultWindow - , preLoop = return () - , eventLoop = handle - , updateLoop = update - , drawLoop = draw - , loadState = load - , cleanUp = clean - } + logIO Debug "Starting" + let conf = AffectionConfig + { initComponents = All + , windowTitle = "affection: example00" + , windowConfig = SDL.defaultWindow + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = clean + } withAffection conf -data UserData = UserData - { nodeGraph :: M.Map String G.GeglNode - } - -load :: IO UserData +load :: IO StateData load = do - traceM "loading" - root <- G.gegl_node_new - traceM "new root node" - checkerboard <- G.gegl_node_new_child root $ G.checkerboardOperation $ - props $ do - prop "color1" $ G.RGBA 0.4 0.4 0.4 1 - prop "color2" $ G.RGBA 0.6 0.6 0.6 1 - traceM "checkerboard" - over <- G.gegl_node_new_child root G.defaultOverOperation - traceM "over" - text <- G.gegl_node_new_child root $ G.textOperation $ - props $ do - prop "string" ("Hello world!"::String) - prop "color" $ G.RGBA 0 0 1 0.5 - prop "size" (40::Int) - traceM "text" - G.gegl_node_link checkerboard over - G.gegl_node_connect_to text "output" over "aux" - traceM "connections made" - myMap <- return $ M.fromList - [ ("root" , root) - , ("over" , over) - , ("checkerboard", checkerboard) - , ("text" , text) - ] - traceM "loading complete" - return $ UserData - { nodeGraph = myMap - } + empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())]) + empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) + empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) + return $ StateData $ Subsystems + (AffectionWindow empty1) + (AffectionMouse empty2) + (AffectionKeyboard empty3) -draw :: Affection UserData () -draw = do - traceM "drawing" - AffectionData{..} <- get - let UserData{..} = userState - liftIO $ SDL.lockSurface drawSurface - pixels <- liftIO $ SDL.surfacePixels drawSurface - let SDL.Surface rawSurfacePtr _ = drawSurface - rawSurface <- liftIO $ peek rawSurfacePtr - pixelFormat <- liftIO $ peek $ Raw.surfaceFormat rawSurface - format <- liftIO $ (B.babl_format $ B.PixelFormat B.RGBA B.CFu8) - SDL.V2 (CInt rw) (CInt rh) <- SDL.surfaceDimensions drawSurface - let (w, h) = (fromIntegral rw, fromIntegral rh) - liftIO $ G.gegl_node_blit - (nodeGraph M.! "over" :: G.GeglNode) - 1 - (G.GeglRectangle 0 0 w h) - format - pixels - (fromIntegral (Raw.pixelFormatBytesPerPixel pixelFormat) * w) - [G.GeglBlitDefault] - liftIO $ SDL.unlockSurface drawSurface - liftIO $ SDL.updateWindowSurface drawWindow +pre :: Affection StateData () +pre = do + sd <- getAffection + _ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ + return () -handle :: SDL.EventPayload -> Affection UserData () -handle = const $ return () +exitOnQ :: KeyboardMessage -> Affection StateData () +exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = + case SDL.keysymKeycode sym of + SDL.KeycodeQ -> quit + otherwise -> return () -update :: Double -> Affection UserData () -update sec = do - traceM "updating" - ad <- get - ud@UserData{..} <- getAffection +handle :: [SDL.EventPayload] -> Affection StateData () +handle es = do + (Subsystems a b c) <- sdSubs <$> getAffection + _ <- consumeSDLEvents a es + _ <- consumeSDLEvents b es + _ <- consumeSDLEvents c es + return () - -- sec <- getDelta - traceM $ (show $ 1 / sec) ++ " FPS" - when (elapsedTime ad > 5) $ - put $ ad - { quitEvent = True - } +update _ = return () + +draw = return () -clean :: UserData -> IO () clean _ = return () diff --git a/src/Affection.hs b/src/Affection.hs index 2917ec7..11dec7b 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -24,6 +24,9 @@ import Affection.StateMachine as A import Affection.MouseInteractable as A import Affection.Util as A import Affection.MessageBus as A +import Affection.Subsystems as A + +import Affection.Logging as A import Graphics.Rendering.OpenGL as GL (clear, flush, ClearBuffer(..)) @@ -45,7 +48,7 @@ withAffection AffectionConfig{..} = do do renderQuality <- SDL.get SDL.HintRenderScaleQuality when (renderQuality /= SDL.ScaleLinear) $ - putStrLn "Warning: Linear texture filtering not enabled!" + logIO Warn "Linear texture filtering not enabled!" -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window @@ -94,7 +97,8 @@ withAffection AffectionConfig{..} = do } -- poll events evs <- preHandleEvents =<< liftIO SDL.pollEvents - mapM_ eventLoop evs + -- mapM_ eventLoop evs + eventLoop evs -- execute user defined update loop unless (pausedTime ad) (updateLoop dt) -- execute user defined draw loop diff --git a/src/Affection/MessageBus.hs b/src/Affection/MessageBus.hs index 28d1bfa..d22edbb 100644 --- a/src/Affection/MessageBus.hs +++ b/src/Affection/MessageBus.hs @@ -1,7 +1,10 @@ module Affection.MessageBus ( module M + , module Msg ) where import Affection.MessageBus.Class as M import Affection.MessageBus.Message as M import Affection.MessageBus.Util as M + +import Affection.MessageBus.Message as Msg diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 4ec6b7d..a27bca3 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Rank2Types #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -20,13 +20,13 @@ import Affection.Logging class (Show m, Message m) => Participant prt m where -- | Function to get the lsit of subscribers from the participant partSubscribers - :: prt -- ^ the participant + :: prt -- ^ the participant -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events partSubscribe :: prt -- ^ The 'Participant' to subscribe to - -> (forall sd. m -> Affection sd ()) -- ^ What to do in case of a 'Message' + -> (m -> Affection sd ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function diff --git a/src/Affection/MessageBus/Message/Class.hs b/src/Affection/MessageBus/Message/Class.hs index b97de31..bcb2651 100644 --- a/src/Affection/MessageBus/Message/Class.hs +++ b/src/Affection/MessageBus/Message/Class.hs @@ -3,4 +3,4 @@ module Affection.MessageBus.Message.Class where import Data.Word (Word32(..)) class Message msg where - msgTime :: msg -> Word32 + msgTime :: msg -> Double diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index e51b712..5ef859a 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -2,12 +2,10 @@ module Affection.MessageBus.Message.KeyboardMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..)) - import qualified SDL data KeyboardMessage = MsgKeyboardEvent - { msgKbdWhen :: Word32 + { msgKbdWhen :: Double , msgKbdWindow :: Maybe SDL.Window , msgKbdKeyMotion :: SDL.InputMotion , msgKbdLeyRepeat :: Bool diff --git a/src/Affection/MessageBus/Message/MouseMessage.hs b/src/Affection/MessageBus/Message/MouseMessage.hs index 4ff12b6..5833ae1 100644 --- a/src/Affection/MessageBus/Message/MouseMessage.hs +++ b/src/Affection/MessageBus/Message/MouseMessage.hs @@ -2,7 +2,7 @@ module Affection.MessageBus.Message.MouseMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..), Word8(..)) +import Data.Word (Word8(..)) import Data.Int (Int32(..)) import qualified SDL @@ -11,7 +11,7 @@ import Linear (V2(..)) data MouseMessage = MsgMouseMotion - { msgMMWhen :: Word32 + { msgMMWhen :: Double , msgMMWindow :: Maybe SDL.Window , msgMMWhich :: SDL.MouseDevice , msgMMState :: [SDL.MouseButton] @@ -19,7 +19,7 @@ data MouseMessage , msgMMRelMotion :: V2 Int32 } | MsgMouseButton - { msgMBWhen :: Word32 + { msgMBWhen :: Double , msgMBWindow :: Maybe SDL.Window , msgMBWhich :: SDL.MouseDevice , msgMBButton :: SDL.MouseButton @@ -27,7 +27,7 @@ data MouseMessage , msgMBPos :: V2 Int32 } | MsgMouseWheel - { msgMWWhen :: Word32 + { msgMWWhen :: Double , msgMWWhindow :: Maybe SDL.Window , msgMWWhich :: SDL.MouseDevice , msgMWPos :: V2 Int32 diff --git a/src/Affection/MessageBus/Message/WindowMessage.hs b/src/Affection/MessageBus/Message/WindowMessage.hs index 43c4c46..d857ed2 100644 --- a/src/Affection/MessageBus/Message/WindowMessage.hs +++ b/src/Affection/MessageBus/Message/WindowMessage.hs @@ -2,7 +2,6 @@ module Affection.MessageBus.Message.WindowMessage where import Affection.MessageBus.Message.Class -import Data.Word (Word32(..)) import Data.Int (Int32(..)) import qualified SDL @@ -10,63 +9,63 @@ import qualified SDL import Linear (V2(..)) data WindowMessage - -- = MsgEngineReady Word32 + -- = MsgEngineReady Double = MsgWindowShow - { msgWSWhen :: Word32 + { msgWSWhen :: Double , msgWSWindow :: SDL.Window } | MsgWindowHide - { msgWHWhen :: Word32 + { msgWHWhen :: Double , msgWHWindow :: SDL.Window } | MsgWindowExpose - { msgWEWhen :: Word32 + { msgWEWhen :: Double , msgWEWindow :: SDL.Window } | MsgWindowMove - { msgWMWhen :: Word32 + { msgWMWhen :: Double , msgWMWindow :: SDL.Window , msgWMNewPos :: V2 Int32 } | MsgWindowResize - { msgWRWhen :: Word32 + { msgWRWhen :: Double , msgWRWindow :: SDL.Window , msgWRNewSize :: V2 Int32 } | MsgWindowSizeChange - { msgWSCWhen :: Word32 + { msgWSCWhen :: Double , msgWSCWindow :: SDL.Window } | MsgWindowMinimize - { msgWMinWhen :: Word32 + { msgWMinWhen :: Double , msgWMinWindow :: SDL.Window } | MsgWindowMaximize - { msgWMaxWhen :: Word32 + { msgWMaxWhen :: Double , msgWMaxWindow :: SDL.Window } | MsgWindowRestore - { msgWRestWhen :: Word32 + { msgWRestWhen :: Double , msgWRestWindow :: SDL.Window } | MsgWindowGainMouseFocus - { msgWGMFWhen :: Word32 + { msgWGMFWhen :: Double , msgWGMFWindow :: SDL.Window } | MsgWindowLoseMouseFocus - { msgWLMFWhen :: Word32 + { msgWLMFWhen :: Double , msgWLMFWindow :: SDL.Window } | MsgWindowGainKeyboardFocus - { msgWGKFWhen :: Word32 + { msgWGKFWhen :: Double , msgWGKFWindow :: SDL.Window } | MsgWindowLoseKeyboardFocus - { msgWLKFWhen :: Word32 + { msgWLKFWhen :: Double , msgWLKFWindow :: SDL.Window } | MsgWindowClose - { msgWCWhen :: Word32 + { msgWCWhen :: Double , msgWCWindow :: SDL.Window } deriving (Show) diff --git a/src/Affection/Subsystems.hs b/src/Affection/Subsystems.hs new file mode 100644 index 0000000..ce9929f --- /dev/null +++ b/src/Affection/Subsystems.hs @@ -0,0 +1,8 @@ +module Affection.Subsystems + ( module S + ) where + +import Affection.Subsystems.Class as S +import Affection.Subsystems.AffectionKeyboard as S +import Affection.Subsystems.AffectionWindow as S +import Affection.Subsystems.AffectionMouse as S diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 188099a..dc62706 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionKeyboard where import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types +import Affection.Util import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM as STM @@ -30,17 +31,18 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where return $ map snd subTups instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where - consumeSDLEvents ak evs = doConsume evs + consumeSDLEvents ak eps = doConsume eps where - doConsume [] = return [] - doConsume (e:es) = case SDL.eventPayload e of - SDL.KeyboardEvent dat -> do - partEmit ak (MsgKeyboardEvent - (SDL.eventTimestamp e) - (SDL.keyboardEventWindow dat) - (SDL.keyboardEventKeyMotion dat) - (SDL.keyboardEventRepeat dat) - (SDL.keyboardEventKeysym dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index ff47e06..35689c1 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -5,6 +5,7 @@ module Affection.Subsystems.AffectionMouse where import Affection.MessageBus import Affection.Subsystems.Class import Affection.Types +import Affection.Util import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM @@ -32,37 +33,38 @@ instance Participant (AffectionMouse sd) MouseMessage where return $ map snd subTups instance SDLSubsystem (AffectionMouse sd) MouseMessage where - consumeSDLEvents am evs = doConsume evs + consumeSDLEvents am eps = doConsume eps where - doConsume [] = return [] - doConsume (e:es) = case SDL.eventPayload e of - SDL.MouseMotionEvent dat -> do - partEmit am (MsgMouseMotion - (SDL.eventTimestamp e) - (SDL.mouseMotionEventWindow dat) - (SDL.mouseMotionEventWhich dat) - (SDL.mouseMotionEventState dat) - (unP $ SDL.mouseMotionEventPos dat) - (SDL.mouseMotionEventRelMotion dat) - ) - doConsume es - SDL.MouseButtonEvent dat -> do - partEmit am (MsgMouseButton - (SDL.eventTimestamp e) - (SDL.mouseButtonEventWindow dat) - (SDL.mouseButtonEventWhich dat) - (SDL.mouseButtonEventButton dat) - (SDL.mouseButtonEventClicks dat) - (unP $ SDL.mouseButtonEventPos dat) - ) - doConsume es - SDL.MouseWheelEvent dat -> do - partEmit am (MsgMouseWheel - (SDL.eventTimestamp e) - (SDL.mouseWheelEventWindow dat) - (SDL.mouseWheelEventWhich dat) - (SDL.mouseWheelEventPos dat) - (SDL.mouseWheelEventDirection dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (unP $ SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doConsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + ts + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (unP $ SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index aebe2ee..9b432c8 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -3,6 +3,7 @@ module Affection.Subsystems.AffectionWindow where import Affection.Types +import Affection.Util import Affection.MessageBus import Affection.Subsystems.Class @@ -30,50 +31,51 @@ instance Participant (AffectionWindow sd) WindowMessage where return $ map snd subTups instance SDLSubsystem (AffectionWindow sd) WindowMessage where - consumeSDLEvents aw evs = doConsume evs + consumeSDLEvents aw eps = doConsume eps where - doConsume [] = return [] - doConsume (e:es) = case SDL.eventPayload e of - SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do - partEmit aw (MsgWindowShow (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do - partEmit aw (MsgWindowHide (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do - partEmit aw (MsgWindowExpose (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do - partEmit aw (MsgWindowMove (SDL.eventTimestamp e) window newPos) - doConsume es - SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do - partEmit aw (MsgWindowResize (SDL.eventTimestamp e) window newSize) - doConsume es - SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do - partEmit aw (MsgWindowSizeChange (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do - partEmit aw (MsgWindowMinimize (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do - partEmit aw (MsgWindowMaximize (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do - partEmit aw (MsgWindowRestore (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do - partEmit aw (MsgWindowGainMouseFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do - partEmit aw (MsgWindowLoseMouseFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowGainKeyboardFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowLoseKeyboardFocus (SDL.eventTimestamp e) window) - doConsume es - SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do - partEmit aw (MsgWindowClose (SDL.eventTimestamp e) window) - doConsume es - _ -> fmap (e :) (doConsume es) + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChange ts window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index 6dc42f4..f9f3d27 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -8,4 +8,4 @@ import Affection.MessageBus import qualified SDL class (Message m, Participant s m) => SDLSubsystem s m where - consumeSDLEvents :: s -> [SDL.Event] -> Affection sd [SDL.Event] + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload] diff --git a/src/Affection/Types.hs b/src/Affection/Types.hs index 6e89dd7..350c285 100644 --- a/src/Affection/Types.hs +++ b/src/Affection/Types.hs @@ -64,16 +64,16 @@ data AffectionConfig us = AffectionConfig -- ^ size of the texture canvas , initScreenMode :: SDL.WindowMode -- ^ Window mode to start in + , loadState :: IO us + -- ^ Provide your own load function to create this data. , preLoop :: Affection us () -- ^ Actions to be performed, before loop starts - , eventLoop :: SDL.EventPayload -> Affection us () + , eventLoop :: [SDL.EventPayload] -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , updateLoop :: Double -> Affection us () -- ^ Main update function. Takes fractions of a second as input. , drawLoop :: Affection us () -- ^ Function for updating graphics. - , loadState :: IO us - -- ^ Provide your own load function to create this data. , cleanUp :: us -> IO () -- ^ Provide your own finisher function to clean your data. } From 3199d034016811df3e1093f45079f9eb58947a39 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 13 Dec 2017 15:53:51 +0100 Subject: [PATCH 18/24] blabla --- src/Affection/MessageBus/Class.hs | 16 ++++++++-------- src/Affection/Subsystems/AffectionKeyboard.hs | 14 +++++++------- src/Affection/Subsystems/AffectionWindow.hs | 9 +++++---- 3 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index a27bca3..aaac555 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -20,31 +20,31 @@ import Affection.Logging class (Show m, Message m) => Participant prt m where -- | Function to get the lsit of subscribers from the participant partSubscribers - :: prt -- ^ the participant - -> Affection sd [(m -> Affection sd ())] -- ^ List of Subscriber functions + :: prt -- ^ the participant + -> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events partSubscribe :: prt -- ^ The 'Participant' to subscribe to - -> (m -> Affection sd ()) -- ^ What to do in case of a 'Message' + -> (forall us. m -> Affection us ()) -- ^ What to do in case of a 'Message' -- (Subscriber function) - -> Affection sd UUID -- ^ 'UUID' of the registered subscriber Function + -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function -- | Unsubscribe a Subscriber function from Participant partUnSubscribe :: prt -- ^ The 'Participant' to unsubscribe from -> UUID -- ^ The subscriber function's 'UUID' - -> Affection sd () + -> Affection us () -- | Get the 'Participant' to emit a 'Message' on all of its subscribers partEmit :: prt -- ^ The 'Participant' -> m -- ^ The 'Message' to emit - -> Affection sd () + -> Affection us () partEmit p m = do liftIO $ logIO Debug $ "Emitting message: " ++ show m l <- partSubscribers p mapM_ ($ m) l -genUUID :: Affection sd UUID +genUUID :: Affection us UUID genUUID = liftIO $ nextRandom diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index dc62706..6f822d2 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -2,21 +2,21 @@ {-# LANGUAGE RankNTypes #-} module Affection.Subsystems.AffectionKeyboard where -import Affection.MessageBus -import Affection.Subsystems.Class import Affection.Types import Affection.Util +import Affection.MessageBus +import Affection.Subsystems.Class -import Control.Monad.IO.Class (liftIO) import Control.Concurrent.STM as STM +import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionKeyboard sd = AffectionKeyboard - { keyboardSubscribers :: forall sd. TVar [(UUID, KeyboardMessage -> Affection sd ())] +data AffectionKeyboard us = AffectionKeyboard + { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())] } -instance Participant (AffectionKeyboard sd) KeyboardMessage where +instance Participant (AffectionKeyboard us) KeyboardMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) @@ -30,7 +30,7 @@ instance Participant (AffectionKeyboard sd) KeyboardMessage where subTups <- liftIO $ readTVarIO $ keyboardSubscribers p return $ map snd subTups -instance SDLSubsystem (AffectionKeyboard sd) KeyboardMessage where +instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where consumeSDLEvents ak eps = doConsume eps where doConsume (e:es) = do diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 9b432c8..1fe4775 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleInstances #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -12,11 +13,11 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow sd = AffectionWindow - { windowSubscribers :: forall sd. TVar [(UUID, WindowMessage -> Affection sd ())] +data AffectionWindow us = AffectionWindow + { windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())] } -instance Participant (AffectionWindow sd) WindowMessage where +instance Participant (AffectionWindow us) WindowMessage where partSubscribe p funct = do uuid <- genUUID liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) @@ -30,7 +31,7 @@ instance Participant (AffectionWindow sd) WindowMessage where subTups <- liftIO $ readTVarIO $ windowSubscribers p return $ map snd subTups -instance SDLSubsystem (AffectionWindow sd) WindowMessage where +instance SDLSubsystem (AffectionWindow us) WindowMessage where consumeSDLEvents aw eps = doConsume eps where doConsume (e:es) = do From f12e62d938f0e63d152634543e02780070448321 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 17:48:12 +0100 Subject: [PATCH 19/24] event system works! --- examples/example00.hs | 71 +++++++++- src/Affection/MessageBus/Class.hs | 37 ++++-- src/Affection/Subsystems/AffectionKeyboard.hs | 57 ++++---- src/Affection/Subsystems/AffectionMouse.hs | 97 ++++++-------- src/Affection/Subsystems/AffectionWindow.hs | 123 ++++++++---------- src/Affection/Subsystems/Class.hs | 4 +- 6 files changed, 209 insertions(+), 180 deletions(-) diff --git a/examples/example00.hs b/examples/example00.hs index 9be083c..00d5c69 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,21 +1,74 @@ {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} import Affection import qualified SDL import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) data StateData = StateData { sdSubs :: Subsystems } data Subsystems = Subsystems - { subWindow :: AffectionWindow StateData - , subMouse :: AffectionMouse StateData - , subKeyboard :: AffectionKeyboard StateData + { subWindow :: Window + , subMouse :: Mouse + , subKeyboard :: Keyboard } +data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) + +instance Participant Window WindowMessage StateData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Window t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Window t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window StateData where + consumeSDLEvents = consumeSDLWindowEvents + +instance Participant Mouse MouseMessage StateData where + partSubscribers (Mouse t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Mouse t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Mouse t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Mouse StateData where + consumeSDLEvents = consumeSDLMouseEvents + +instance Participant Keyboard KeyboardMessage StateData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO $ t + return $ map snd subTups + + partSubscribe (Keyboard t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + + partUnSubscribe (Keyboard t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard StateData where + consumeSDLEvents = consumeSDLKeyboardEvents + main :: IO () main = do logIO Debug "Starting" @@ -23,6 +76,10 @@ main = do { initComponents = All , windowTitle = "affection: example00" , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 3 + } + } , initScreenMode = SDL.Windowed , canvasSize = Nothing , loadState = load @@ -40,9 +97,9 @@ load = do empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())]) empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())]) return $ StateData $ Subsystems - (AffectionWindow empty1) - (AffectionMouse empty2) - (AffectionKeyboard empty3) + (Window empty1) + (Mouse empty2) + (Keyboard empty3) pre :: Affection StateData () pre = do diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index aaac555..4530278 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} module Affection.MessageBus.Class ( Participant(..) , genUUID @@ -17,34 +17,45 @@ import Data.UUID.V4 import Affection.Logging -class (Show m, Message m) => Participant prt m where - -- | Function to get the lsit of subscribers from the participant +class (Show m, Message m) => Participant prt m us where + + -- | Function to get the list of subscribers from the participant partSubscribers - :: prt -- ^ the participant - -> forall us. Affection us [(m -> Affection us ())] -- ^ List of Subscriber functions + :: prt + -- ^ the 'Participant''s subscriber storage + -> Affection us [(m -> Affection us ())] + -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events partSubscribe - :: prt -- ^ The 'Participant' to subscribe to - -> (forall us. m -> Affection us ()) -- ^ What to do in case of a 'Message' - -- (Subscriber function) - -> Affection us UUID -- ^ 'UUID' of the registered subscriber Function + :: prt + -- ^ The 'Participant''s subscriber storage + -> (m -> Affection us ()) + -- ^ What to do in case of a 'Message' + -- (Subscriber function) + -> Affection us UUID + -- ^ 'UUID' of the registered subscriber Function -- | Unsubscribe a Subscriber function from Participant partUnSubscribe - :: prt -- ^ The 'Participant' to unsubscribe from - -> UUID -- ^ The subscriber function's 'UUID' + :: prt + -- ^ The 'Participant''s subscriber storage to unsubscribe from + -> UUID + -- ^ The subscriber function's 'UUID' -> Affection us () -- | Get the 'Participant' to emit a 'Message' on all of its subscribers partEmit - :: prt -- ^ The 'Participant' - -> m -- ^ The 'Message' to emit + :: prt + -- ^ The 'Participant''s subscriber storage + -> m + -- ^ The 'Message' to emit -> Affection us () partEmit p m = do liftIO $ logIO Debug $ "Emitting message: " ++ show m l <- partSubscribers p mapM_ ($ m) l +-- | Helper function to generate new 'UUID's genUUID :: Affection us UUID genUUID = liftIO $ nextRandom diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 6f822d2..4d19ea4 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionKeyboard where import Affection.Types @@ -12,37 +12,24 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionKeyboard us = AffectionKeyboard - { keyboardSubscribers :: forall us. TVar [(UUID, KeyboardMessage -> Affection us ())] - } - -instance Participant (AffectionKeyboard us) KeyboardMessage where - partSubscribe p funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) ((uuid, funct) :) - return uuid - - partUnSubscribe p uuid = - liftIO $ atomically $ modifyTVar' (keyboardSubscribers p) - (filter (\(u, _) -> u /= uuid)) - - partSubscribers p = do - subTups <- liftIO $ readTVarIO $ keyboardSubscribers p - return $ map snd subTups - -instance SDLSubsystem (AffectionKeyboard us) KeyboardMessage where - consumeSDLEvents ak eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.KeyboardEvent dat -> do - partEmit ak (MsgKeyboardEvent - ts - (SDL.keyboardEventWindow dat) - (SDL.keyboardEventKeyMotion dat) - (SDL.keyboardEventRepeat dat) - (SDL.keyboardEventKeysym dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLKeyboardEvents + :: (Participant ak KeyboardMessage us) + => ak + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLKeyboardEvents ak eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.KeyboardEvent dat -> do + partEmit ak (MsgKeyboardEvent + ts + (SDL.keyboardEventWindow dat) + (SDL.keyboardEventKeyMotion dat) + (SDL.keyboardEventRepeat dat) + (SDL.keyboardEventKeysym dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index 35689c1..a4e83f9 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionMouse where import Affection.MessageBus @@ -14,57 +14,44 @@ import Linear.Affine (unP) import qualified SDL -data AffectionMouse sd = AffectionMouse - { mouseSubscribers :: forall sd. TVar [(UUID, MouseMessage -> Affection sd ())] - } - -instance Participant (AffectionMouse sd) MouseMessage where - partSubscribe p funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' (mouseSubscribers p) ((uuid, funct) :) - return uuid - - partUnSubscribe p uuid = - liftIO $ atomically $ modifyTVar' (mouseSubscribers p) - (filter (\(u, _) -> u /= uuid)) - - partSubscribers p = do - subTups <- liftIO $ readTVarIO $ mouseSubscribers p - return $ map snd subTups - -instance SDLSubsystem (AffectionMouse sd) MouseMessage where - consumeSDLEvents am eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.MouseMotionEvent dat -> do - partEmit am (MsgMouseMotion - ts - (SDL.mouseMotionEventWindow dat) - (SDL.mouseMotionEventWhich dat) - (SDL.mouseMotionEventState dat) - (unP $ SDL.mouseMotionEventPos dat) - (SDL.mouseMotionEventRelMotion dat) - ) - doConsume es - SDL.MouseButtonEvent dat -> do - partEmit am (MsgMouseButton - ts - (SDL.mouseButtonEventWindow dat) - (SDL.mouseButtonEventWhich dat) - (SDL.mouseButtonEventButton dat) - (SDL.mouseButtonEventClicks dat) - (unP $ SDL.mouseButtonEventPos dat) - ) - doConsume es - SDL.MouseWheelEvent dat -> do - partEmit am (MsgMouseWheel - ts - (SDL.mouseWheelEventWindow dat) - (SDL.mouseWheelEventWhich dat) - (SDL.mouseWheelEventPos dat) - (SDL.mouseWheelEventDirection dat) - ) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLMouseEvents + :: (Participant am MouseMessage us) + => am + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLMouseEvents am eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.MouseMotionEvent dat -> do + partEmit am (MsgMouseMotion + ts + (SDL.mouseMotionEventWindow dat) + (SDL.mouseMotionEventWhich dat) + (SDL.mouseMotionEventState dat) + (unP $ SDL.mouseMotionEventPos dat) + (SDL.mouseMotionEventRelMotion dat) + ) + doConsume es + SDL.MouseButtonEvent dat -> do + partEmit am (MsgMouseButton + ts + (SDL.mouseButtonEventWindow dat) + (SDL.mouseButtonEventWhich dat) + (SDL.mouseButtonEventButton dat) + (SDL.mouseButtonEventClicks dat) + (unP $ SDL.mouseButtonEventPos dat) + ) + doConsume es + SDL.MouseWheelEvent dat -> do + partEmit am (MsgMouseWheel + ts + (SDL.mouseWheelEventWindow dat) + (SDL.mouseWheelEventWhich dat) + (SDL.mouseWheelEventPos dat) + (SDL.mouseWheelEventDirection dat) + ) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 1fe4775..0dea121 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -1,6 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Affection.Subsystems.AffectionWindow where import Affection.Types @@ -13,70 +13,57 @@ import Control.Monad.IO.Class (liftIO) import qualified SDL -data AffectionWindow us = AffectionWindow - { windowSubscribers :: forall us. TVar [(UUID, WindowMessage -> Affection us ())] - } - -instance Participant (AffectionWindow us) WindowMessage where - partSubscribe p funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' (windowSubscribers p) ((uuid, funct) :) - return uuid - - partUnSubscribe p uuid = - liftIO $ atomically $ modifyTVar' (windowSubscribers p) - (filter (\(u, _) -> u /= uuid)) - - partSubscribers p = do - subTups <- liftIO $ readTVarIO $ windowSubscribers p - return $ map snd subTups - -instance SDLSubsystem (AffectionWindow us) WindowMessage where - consumeSDLEvents aw eps = doConsume eps - where - doConsume (e:es) = do - ts <- getElapsedTime - case e of - SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do - partEmit aw (MsgWindowShow ts window) - doConsume es - SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do - partEmit aw (MsgWindowHide ts window) - doConsume es - SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do - partEmit aw (MsgWindowExpose ts window) - doConsume es - SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do - partEmit aw (MsgWindowMove ts window newPos) - doConsume es - SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do - partEmit aw (MsgWindowResize ts window newSize) - doConsume es - SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do - partEmit aw (MsgWindowSizeChange ts window) - doConsume es - SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do - partEmit aw (MsgWindowMinimize ts window) - doConsume es - SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do - partEmit aw (MsgWindowMaximize ts window) - doConsume es - SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do - partEmit aw (MsgWindowRestore ts window) - doConsume es - SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do - partEmit aw (MsgWindowGainMouseFocus ts window) - doConsume es - SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do - partEmit aw (MsgWindowLoseMouseFocus ts window) - doConsume es - SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowGainKeyboardFocus ts window) - doConsume es - SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do - partEmit aw (MsgWindowLoseKeyboardFocus ts window) - doConsume es - SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do - partEmit aw (MsgWindowClose ts window) - doConsume es - _ -> fmap (e :) (doConsume es) +consumeSDLWindowEvents + :: (Participant aw WindowMessage us) + => aw + -> [SDL.EventPayload] + -> Affection us [SDL.EventPayload] +consumeSDLWindowEvents aw eps = doConsume eps + where + doConsume [] = return [] + doConsume (e:es) = do + ts <- getElapsedTime + case e of + SDL.WindowShownEvent (SDL.WindowShownEventData window) -> do + partEmit aw (MsgWindowShow ts window) + doConsume es + SDL.WindowHiddenEvent (SDL.WindowHiddenEventData window) -> do + partEmit aw (MsgWindowHide ts window) + doConsume es + SDL.WindowExposedEvent (SDL.WindowExposedEventData window) -> do + partEmit aw (MsgWindowExpose ts window) + doConsume es + SDL.WindowMovedEvent (SDL.WindowMovedEventData window (SDL.P newPos)) -> do + partEmit aw (MsgWindowMove ts window newPos) + doConsume es + SDL.WindowResizedEvent (SDL.WindowResizedEventData window newSize) -> do + partEmit aw (MsgWindowResize ts window newSize) + doConsume es + SDL.WindowSizeChangedEvent (SDL.WindowSizeChangedEventData window) -> do + partEmit aw (MsgWindowSizeChange ts window) + doConsume es + SDL.WindowMinimizedEvent (SDL.WindowMinimizedEventData window) -> do + partEmit aw (MsgWindowMinimize ts window) + doConsume es + SDL.WindowMaximizedEvent (SDL.WindowMaximizedEventData window) -> do + partEmit aw (MsgWindowMaximize ts window) + doConsume es + SDL.WindowRestoredEvent (SDL.WindowRestoredEventData window) -> do + partEmit aw (MsgWindowRestore ts window) + doConsume es + SDL.WindowGainedMouseFocusEvent (SDL.WindowGainedMouseFocusEventData window) -> do + partEmit aw (MsgWindowGainMouseFocus ts window) + doConsume es + SDL.WindowLostMouseFocusEvent (SDL.WindowLostMouseFocusEventData window) -> do + partEmit aw (MsgWindowLoseMouseFocus ts window) + doConsume es + SDL.WindowGainedKeyboardFocusEvent (SDL.WindowGainedKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowGainKeyboardFocus ts window) + doConsume es + SDL.WindowLostKeyboardFocusEvent (SDL.WindowLostKeyboardFocusEventData window) -> do + partEmit aw (MsgWindowLoseKeyboardFocus ts window) + doConsume es + SDL.WindowClosedEvent (SDL.WindowClosedEventData window) -> do + partEmit aw (MsgWindowClose ts window) + doConsume es + _ -> fmap (e :) (doConsume es) diff --git a/src/Affection/Subsystems/Class.hs b/src/Affection/Subsystems/Class.hs index f9f3d27..7c52f8e 100644 --- a/src/Affection/Subsystems/Class.hs +++ b/src/Affection/Subsystems/Class.hs @@ -7,5 +7,5 @@ import Affection.MessageBus import qualified SDL -class (Message m, Participant s m) => SDLSubsystem s m where - consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection sd [SDL.EventPayload] +class SDLSubsystem s us where + consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] From 295c4b333c76877e191970d90aec05e32eb95724 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 17:58:55 +0100 Subject: [PATCH 20/24] eta reductions --- examples/example00.hs | 6 ++++-- src/Affection/Subsystems/AffectionKeyboard.hs | 2 +- src/Affection/Subsystems/AffectionMouse.hs | 2 +- src/Affection/Subsystems/AffectionWindow.hs | 2 +- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/examples/example00.hs b/examples/example00.hs index 00d5c69..7cdcf83 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -110,8 +110,10 @@ pre = do exitOnQ :: KeyboardMessage -> Affection StateData () exitOnQ (MsgKeyboardEvent _ _ _ _ sym) = case SDL.keysymKeycode sym of - SDL.KeycodeQ -> quit - otherwise -> return () + SDL.KeycodeQ -> do + liftIO $ logIO Debug "Yo dog I heard..." + quit + _ -> return () handle :: [SDL.EventPayload] -> Affection StateData () handle es = do diff --git a/src/Affection/Subsystems/AffectionKeyboard.hs b/src/Affection/Subsystems/AffectionKeyboard.hs index 4d19ea4..3df62fd 100644 --- a/src/Affection/Subsystems/AffectionKeyboard.hs +++ b/src/Affection/Subsystems/AffectionKeyboard.hs @@ -17,7 +17,7 @@ consumeSDLKeyboardEvents => ak -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] -consumeSDLKeyboardEvents ak eps = doConsume eps +consumeSDLKeyboardEvents ak = doConsume where doConsume [] = return [] doConsume (e:es) = do diff --git a/src/Affection/Subsystems/AffectionMouse.hs b/src/Affection/Subsystems/AffectionMouse.hs index a4e83f9..dcbcf3a 100644 --- a/src/Affection/Subsystems/AffectionMouse.hs +++ b/src/Affection/Subsystems/AffectionMouse.hs @@ -19,7 +19,7 @@ consumeSDLMouseEvents => am -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] -consumeSDLMouseEvents am eps = doConsume eps +consumeSDLMouseEvents am = doConsume where doConsume [] = return [] doConsume (e:es) = do diff --git a/src/Affection/Subsystems/AffectionWindow.hs b/src/Affection/Subsystems/AffectionWindow.hs index 0dea121..6aadf0d 100644 --- a/src/Affection/Subsystems/AffectionWindow.hs +++ b/src/Affection/Subsystems/AffectionWindow.hs @@ -18,7 +18,7 @@ consumeSDLWindowEvents => aw -> [SDL.EventPayload] -> Affection us [SDL.EventPayload] -consumeSDLWindowEvents aw eps = doConsume eps +consumeSDLWindowEvents aw = doConsume where doConsume [] = return [] doConsume (e:es) = do From 22e08e3f9b2a6da7d0ce277b3ffeebc2b7b48f6e Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 18:01:05 +0100 Subject: [PATCH 21/24] brackets --- src/Affection.hs | 2 +- src/Affection/Actor.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Affection.hs b/src/Affection.hs index 11dec7b..6852a4d 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -52,7 +52,7 @@ withAffection AffectionConfig{..} = do -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window - context <- SDL.glCreateContext(window) + context <- SDL.glCreateContext windw let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig (w, h) = case canvasSize of Just (cw, ch) -> (cw, ch) diff --git a/src/Affection/Actor.hs b/src/Affection/Actor.hs index cff094f..0f98598 100644 --- a/src/Affection/Actor.hs +++ b/src/Affection/Actor.hs @@ -48,7 +48,7 @@ updateProperties ps act@Actor{..} = applyProperties :: (Show a, Ord a) => Actor a -> Affection us () applyProperties Actor{..} = - MP.mapM_ (\(ActorProperty{..}) -> + MP.mapM_ (\ActorProperty{..} -> maybe (return ()) (\m -> liftIO $ G.gegl_node_set (actorNodes M.! fst m) $ G.Operation "" $ (G.Property (snd m) apValue) : [] From 004579eeddee5c6c9a03b7f4a12cebcdb822cc7c Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 18:02:14 +0100 Subject: [PATCH 22/24] unused pragma --- examples/example00.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/examples/example00.hs b/examples/example00.hs index 7cdcf83..a53b441 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiParamTypeClasses #-} import Affection From ca817955853e15558b4a8af931b75d7baf0a4bea Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 18:12:16 +0100 Subject: [PATCH 23/24] linted --- examples/example00.hs | 34 ++++++++++++++----------------- src/Affection.hs | 4 ++-- src/Affection/MessageBus/Class.hs | 4 ++-- 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/examples/example00.hs b/examples/example00.hs index a53b441..d49eb94 100644 --- a/examples/example00.hs +++ b/examples/example00.hs @@ -6,7 +6,7 @@ import qualified SDL import Control.Concurrent.STM import Control.Monad.IO.Class (liftIO) -data StateData = StateData +newtype StateData = StateData { sdSubs :: Subsystems } @@ -16,19 +16,16 @@ data Subsystems = Subsystems , subKeyboard :: Keyboard } -data Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) -data Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) -data Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())]) +newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())]) +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())]) instance Participant Window WindowMessage StateData where partSubscribers (Window t) = do - subTups <- liftIO $ readTVarIO $ t + subTups <- liftIO $ readTVarIO t return $ map snd subTups - partSubscribe (Window t) funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid + partSubscribe (Window t) = generalSubscribe t partUnSubscribe (Window t) uuid = liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) @@ -38,13 +35,10 @@ instance SDLSubsystem Window StateData where instance Participant Mouse MouseMessage StateData where partSubscribers (Mouse t) = do - subTups <- liftIO $ readTVarIO $ t + subTups <- liftIO $ readTVarIO t return $ map snd subTups - partSubscribe (Mouse t) funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid + partSubscribe (Mouse t) = generalSubscribe t partUnSubscribe (Mouse t) uuid = liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) @@ -54,13 +48,10 @@ instance SDLSubsystem Mouse StateData where instance Participant Keyboard KeyboardMessage StateData where partSubscribers (Keyboard t) = do - subTups <- liftIO $ readTVarIO $ t + subTups <- liftIO $ readTVarIO t return $ map snd subTups - partSubscribe (Keyboard t) funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid + partSubscribe (Keyboard t) = generalSubscribe t partUnSubscribe (Keyboard t) uuid = liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) @@ -68,6 +59,11 @@ instance Participant Keyboard KeyboardMessage StateData where instance SDLSubsystem Keyboard StateData where consumeSDLEvents = consumeSDLKeyboardEvents +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid + main :: IO () main = do logIO Debug "Starting" diff --git a/src/Affection.hs b/src/Affection.hs index 6852a4d..4988362 100644 --- a/src/Affection.hs +++ b/src/Affection.hs @@ -52,7 +52,7 @@ withAffection AffectionConfig{..} = do -- construct window window <- SDL.createWindow windowTitle windowConfig SDL.showWindow window - context <- SDL.glCreateContext windw + context <- SDL.glCreateContext window let SDL.V2 (CInt rw) (CInt rh) = SDL.windowInitialSize windowConfig (w, h) = case canvasSize of Just (cw, ch) -> (cw, ch) @@ -104,7 +104,7 @@ withAffection AffectionConfig{..} = do -- execute user defined draw loop liftIO $ GL.clear [ColorBuffer, DepthBuffer] drawLoop - liftIO $ flush + liftIO flush -- handle all new draw requests ad2 <- get -- actual drawing diff --git a/src/Affection/MessageBus/Class.hs b/src/Affection/MessageBus/Class.hs index 4530278..a715970 100644 --- a/src/Affection/MessageBus/Class.hs +++ b/src/Affection/MessageBus/Class.hs @@ -23,7 +23,7 @@ class (Show m, Message m) => Participant prt m us where partSubscribers :: prt -- ^ the 'Participant''s subscriber storage - -> Affection us [(m -> Affection us ())] + -> Affection us [m -> Affection us ()] -- ^ List of Subscriber functions -- | Subscribe to the 'Participant''s events @@ -58,4 +58,4 @@ class (Show m, Message m) => Participant prt m us where -- | Helper function to generate new 'UUID's genUUID :: Affection us UUID -genUUID = liftIO $ nextRandom +genUUID = liftIO nextRandom From 39632ce05cbc7a7d4a8f9efa5a4db07dc8baf952 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 15 Dec 2017 18:20:04 +0100 Subject: [PATCH 24/24] typo --- src/Affection/MessageBus/Message/KeyboardMessage.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Affection/MessageBus/Message/KeyboardMessage.hs b/src/Affection/MessageBus/Message/KeyboardMessage.hs index 5ef859a..6b90b0f 100644 --- a/src/Affection/MessageBus/Message/KeyboardMessage.hs +++ b/src/Affection/MessageBus/Message/KeyboardMessage.hs @@ -8,7 +8,7 @@ data KeyboardMessage = MsgKeyboardEvent { msgKbdWhen :: Double , msgKbdWindow :: Maybe SDL.Window , msgKbdKeyMotion :: SDL.InputMotion - , msgKbdLeyRepeat :: Bool + , msgKbdKeyRepeat :: Bool , msgKbdKeysym :: SDL.Keysym } deriving (Show)