remove userstate reference from state monad

This commit is contained in:
nek0 2020-05-04 05:44:19 +02:00
parent 44ec3cc8e0
commit 8af8193a0a
9 changed files with 37 additions and 37 deletions

View File

@ -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

View File

@ -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 ()

View File

@ -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

View File

@ -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 []

View File

@ -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

View File

@ -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

View File

@ -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]

View File

@ -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

View File

@ -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