From 4ae117aa4832288a10461fdfbfe1ee7643b76352 Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 27 Nov 2017 23:30:11 +0100 Subject: [PATCH] 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