remove userstate reference from state monad
This commit is contained in:
parent
44ec3cc8e0
commit
8af8193a0a
9 changed files with 37 additions and 37 deletions
|
@ -22,25 +22,25 @@ import Data.String as S (fromString)
|
|||
import Affection.Logging
|
||||
|
||||
-- | This typeclass defines the behaviour of a participant in the message system
|
||||
class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
|
||||
class (Message (Mesg prt), Show (Mesg prt)) => Participant prt where
|
||||
-- | Message datatype
|
||||
type Mesg prt us :: *
|
||||
type Mesg prt :: *
|
||||
|
||||
-- | Function to get the list of subscribers from the participant
|
||||
partSubscribers
|
||||
:: prt
|
||||
-- ^ the 'Participant''s subscriber storage
|
||||
-> Affection us [Mesg prt us -> Affection us ()]
|
||||
-> Affection [Mesg prt -> Affection ()]
|
||||
-- ^ List of Subscriber functions
|
||||
|
||||
-- | Subscribe to the 'Participant''s events
|
||||
partSubscribe
|
||||
:: prt
|
||||
-- ^ The 'Participant''s subscriber storage
|
||||
-> (Mesg prt us -> Affection us ())
|
||||
-> (Mesg prt -> Affection ())
|
||||
-- ^ What to do in case of a 'Message'
|
||||
-- (Subscriber function)
|
||||
-> Affection us UUID
|
||||
-> Affection UUID
|
||||
-- ^ 'UUID' of the registered subscriber Function
|
||||
|
||||
-- | Unsubscribe a Subscriber function from Participant
|
||||
|
@ -49,20 +49,20 @@ class (Message (Mesg prt us), Show (Mesg prt us)) => Participant prt us where
|
|||
-- ^ The 'Participant''s subscriber storage to unsubscribe from
|
||||
-> UUID
|
||||
-- ^ The subscriber function's 'UUID'
|
||||
-> Affection us ()
|
||||
-> Affection ()
|
||||
|
||||
-- | Get the 'Participant' to emit a 'Message' on all of its subscribers
|
||||
partEmit
|
||||
:: prt
|
||||
-- ^ The 'Participant''s subscriber storage
|
||||
-> Mesg prt us
|
||||
-> Mesg prt
|
||||
-- ^ The 'Message' to emit
|
||||
-> Affection us ()
|
||||
-> Affection ()
|
||||
partEmit p m = do
|
||||
liftIO $ logIO Verbose $ "Emitting message: " <> S.fromString (show m)
|
||||
l <- partSubscribers p
|
||||
mapM_ ($ m) l
|
||||
|
||||
-- | Helper function to generate new 'UUID's
|
||||
genUUID :: Affection us UUID
|
||||
genUUID :: Affection UUID
|
||||
genUUID = liftIO nextRandom
|
||||
|
|
|
@ -7,14 +7,14 @@ import Affection.Types
|
|||
import qualified SDL
|
||||
|
||||
-- | Typeclass for simple scaffolding of a state machine
|
||||
class StateMachine a us where
|
||||
class StateMachine a where
|
||||
-- | State load routine
|
||||
smLoad :: a -> Affection us ()
|
||||
smLoad :: a -> Affection ()
|
||||
-- | state update routine
|
||||
smUpdate :: a -> Double -> Affection us ()
|
||||
smUpdate :: a -> Double -> Affection ()
|
||||
-- | State event handler routine
|
||||
smEvent :: a -> [SDL.EventPayload] -> Affection us ()
|
||||
smEvent :: a -> [SDL.EventPayload] -> Affection ()
|
||||
-- | State draw routine
|
||||
smDraw :: a -> Affection us ()
|
||||
smDraw :: a -> Affection ()
|
||||
-- | State clean routine
|
||||
smClean :: a -> Affection us ()
|
||||
smClean :: a -> Affection ()
|
||||
|
|
|
@ -22,15 +22,15 @@ import qualified SDL
|
|||
-- | Helper function that consumes all Joystick-related 'SDL.EventPayload's
|
||||
-- and emits appropriate 'JoystickMessage's
|
||||
consumeSDLJoystickEvents
|
||||
:: forall am us. (Participant am us, Mesg am us ~ JoystickMessage)
|
||||
:: forall am. (Participant am, Mesg am ~ JoystickMessage)
|
||||
=> am -- ^ The message system participant
|
||||
-> [SDL.EventPayload] -- ^ Incoming events
|
||||
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
consumeSDLJoystickEvents am = doConsume
|
||||
where
|
||||
doConsume
|
||||
:: [SDL.EventPayload]
|
||||
-> Affection us [SDL.EventPayload]
|
||||
-> Affection [SDL.EventPayload]
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
|
@ -81,7 +81,7 @@ consumeSDLJoystickEvents am = doConsume
|
|||
joystickAutoConnect
|
||||
:: JoystickMessage -- ^ Any 'JoystickMessage' will do,
|
||||
-- but listens only on 'MsgJoystickDevice' messages
|
||||
-> Affection us (Maybe SDL.Joystick)
|
||||
-> Affection (Maybe SDL.Joystick)
|
||||
-- ^ Returns a joystick descriptor, if successful
|
||||
joystickAutoConnect (MsgJoystickDevice _ which SDL.JoyDeviceAdded) = liftIO $ do
|
||||
[descr] <- V.toList <$>
|
||||
|
@ -98,7 +98,7 @@ joystickAutoDisconnect
|
|||
:: [SDL.Joystick] -- ^ List of Joystick descriptors
|
||||
-> JoystickMessage -- ^ Any 'JoystickMessage' will do, but listens
|
||||
-- specifically to 'MsgJoystickDevice' messages
|
||||
-> Affection us [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
|
||||
-> Affection [SDL.Joystick] -- ^ Returns altered list of Joystick descriptors
|
||||
joystickAutoDisconnect js (MsgJoystickDevice _ which SDL.JoyDeviceRemoved) =
|
||||
liftIO $ do
|
||||
joyIds <- mapM SDL.getJoystickID js
|
||||
|
|
|
@ -13,10 +13,10 @@ import qualified SDL
|
|||
-- | Helper function that consumes all Keyboard-related 'SDL.EventPayload's
|
||||
-- and emits appropriate 'KeyboardMessage's
|
||||
consumeSDLKeyboardEvents
|
||||
:: forall ak us. (Participant ak us, Mesg ak us ~ KeyboardMessage)
|
||||
:: forall ak. (Participant ak, Mesg ak ~ KeyboardMessage)
|
||||
=> ak -- ^ The message system participant
|
||||
-> [SDL.EventPayload] -- ^ Incoming events
|
||||
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL Events
|
||||
-> Affection [SDL.EventPayload] -- ^ Leftover SDL Events
|
||||
consumeSDLKeyboardEvents ak = doConsume
|
||||
where
|
||||
doConsume [] = return []
|
||||
|
|
|
@ -15,15 +15,15 @@ import qualified SDL
|
|||
-- | Helper funtion that consumes all Mouse-related 'SDL.Eventpayload's
|
||||
-- and emits appropriate 'MouseMessage's
|
||||
consumeSDLMouseEvents
|
||||
:: forall am us. (Participant am us, Mesg am us ~ MouseMessage)
|
||||
:: forall am. (Participant am, Mesg am ~ MouseMessage)
|
||||
=> am -- ^ The message system participant
|
||||
-> [SDL.EventPayload] -- ^ Incoming events
|
||||
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
consumeSDLMouseEvents am = doConsume
|
||||
where
|
||||
doConsume
|
||||
:: [SDL.EventPayload]
|
||||
-> Affection us [SDL.EventPayload]
|
||||
-> Affection [SDL.EventPayload]
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
|
|
|
@ -15,16 +15,16 @@ import qualified SDL
|
|||
-- | Helper function that consumes all Window-related 'SDL.EventPayload's
|
||||
-- and emits appropriate 'WindowMessage's.
|
||||
consumeSDLWindowEvents
|
||||
:: forall aw us. (Participant aw us, Mesg aw us ~ WindowMessage)
|
||||
:: forall aw. (Participant aw, Mesg aw ~ WindowMessage)
|
||||
=> aw -- ^ The message system participant
|
||||
-> [SDL.EventPayload] -- ^ Incoming events
|
||||
-> Affection us [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
-> Affection [SDL.EventPayload] -- ^ Leftover SDL events
|
||||
consumeSDLWindowEvents aw = doConsume
|
||||
where
|
||||
doConsume
|
||||
:: (Mesg aw us ~ WindowMessage)
|
||||
:: (Mesg aw ~ WindowMessage)
|
||||
=> [SDL.EventPayload]
|
||||
-> Affection us [SDL.EventPayload]
|
||||
-> Affection [SDL.EventPayload]
|
||||
doConsume [] = return []
|
||||
doConsume (e:es) = do
|
||||
ts <- getElapsedTime
|
||||
|
|
|
@ -10,4 +10,4 @@ import qualified SDL
|
|||
class SDLSubsystem s us where
|
||||
-- | Consume the given 'SDL.EventPayload's and return only those not
|
||||
-- recognised
|
||||
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection us [SDL.EventPayload]
|
||||
consumeSDLEvents :: s -> [SDL.EventPayload] -> Affection [SDL.EventPayload]
|
||||
|
|
|
@ -49,7 +49,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 = AffectionData
|
||||
{ drawWindows ::
|
||||
[
|
||||
( Word -- --^ Window identifier
|
||||
|
@ -80,6 +80,6 @@ newtype AffectionState sd m a = AffectionState
|
|||
|
||||
instance MP.MonadParallel m => MP.MonadParallel (AffectionState sd m)
|
||||
|
||||
type Affection us a = AffectionState (AffectionData us) IO a
|
||||
type Affection a = AffectionState AffectionData IO a
|
||||
|
||||
type Angle = Double
|
||||
|
|
|
@ -15,7 +15,7 @@ import Data.String (fromString)
|
|||
import Control.Monad.State
|
||||
|
||||
-- | Prehandle SDL events
|
||||
preHandleEvents :: [SDL.Event] -> Affection us [SDL.EventPayload]
|
||||
preHandleEvents :: [SDL.Event] -> Affection [SDL.EventPayload]
|
||||
preHandleEvents evs =
|
||||
return $ map SDL.eventPayload evs
|
||||
|
||||
|
@ -26,16 +26,16 @@ 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 Double
|
||||
getElapsedTime = gets elapsedTime
|
||||
|
||||
-- | Get delta time (time elapsed from last frame)
|
||||
getDelta :: Affection us Double
|
||||
getDelta :: Affection Double
|
||||
getDelta = gets deltaTime
|
||||
|
||||
-- | Toggle the Screen mode between 'SDL.Windowed' and 'SDL.FullscreenDesktop'.
|
||||
-- Pauses the Engine in the process.
|
||||
toggleScreen :: Affection us ()
|
||||
toggleScreen :: Affection ()
|
||||
toggleScreen = do
|
||||
ad <- get
|
||||
newMode <- case screenMode ad of
|
||||
|
@ -59,7 +59,7 @@ fitViewport
|
|||
:: Double -- ^ Image Ratio (width / height)
|
||||
-> WindowMessage -- ^ Incoming Message. Listens only on
|
||||
-- 'MsgWindowResize' and ignores all others.
|
||||
-> Affection us ()
|
||||
-> Affection ()
|
||||
fitViewport ratio (MsgWindowResize _ _ (SDL.V2 w h)) = do
|
||||
liftIO $ logIO Verbose "Fitting Viewport to size"
|
||||
if (fromIntegral w / fromIntegral h) > ratio
|
||||
|
|
Loading…
Reference in a new issue