185 lines
5 KiB
Haskell
185 lines
5 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
import Affection
|
|
import qualified SDL
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Control.Monad (when)
|
|
|
|
import Data.Maybe (isJust, fromJust)
|
|
|
|
data StateData = StateData
|
|
{ sdSubs :: Subsystems
|
|
, sdJoys :: [SDL.Joystick]
|
|
}
|
|
|
|
data Subsystems = Subsystems
|
|
{ subWindow :: Window
|
|
, subMouse :: Mouse
|
|
, subKeyboard :: Keyboard
|
|
, subJoystick :: Joystick
|
|
}
|
|
|
|
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
|
|
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
|
|
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
|
|
newtype Joystick = Joystick (TVar [(UUID, JoystickMessage -> Affection StateData ())])
|
|
|
|
generalSubscribers
|
|
:: TVar [(UUID, msg -> Affection StateData ())]
|
|
-> Affection StateData [msg -> Affection StateData ()]
|
|
generalSubscribers t = do
|
|
subTups <- liftIO $ readTVarIO t
|
|
return $ map snd subTups
|
|
|
|
generalSubscribe
|
|
:: TVar [(UUID, msg -> Affection StateData ())]
|
|
-> (msg -> Affection StateData())
|
|
-> Affection StateData UUID
|
|
generalSubscribe t funct = do
|
|
uuid <- genUUID
|
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
|
return uuid
|
|
|
|
generalUnSubscribe
|
|
:: TVar [(UUID, msg -> Affection StateData ())]
|
|
-> UUID
|
|
-> Affection StateData ()
|
|
generalUnSubscribe t uuid =
|
|
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
|
|
|
|
instance Participant Window StateData where
|
|
type Mesg Window StateData = WindowMessage
|
|
|
|
partSubscribers (Window t) = generalSubscribers t
|
|
|
|
partSubscribe (Window t) = generalSubscribe t
|
|
|
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
|
|
|
instance SDLSubsystem Window StateData where
|
|
consumeSDLEvents = consumeSDLWindowEvents
|
|
|
|
instance Participant Mouse StateData where
|
|
type Mesg Mouse StateData = MouseMessage
|
|
|
|
partSubscribers (Mouse t) = generalSubscribers t
|
|
|
|
partSubscribe (Mouse t) = generalSubscribe t
|
|
|
|
partUnSubscribe (Mouse t) = generalUnSubscribe t
|
|
|
|
instance SDLSubsystem Mouse StateData where
|
|
consumeSDLEvents = consumeSDLMouseEvents
|
|
|
|
instance Participant Keyboard StateData where
|
|
type Mesg Keyboard StateData = KeyboardMessage
|
|
|
|
partSubscribers (Keyboard t) = generalSubscribers t
|
|
|
|
partSubscribe (Keyboard t) = generalSubscribe t
|
|
|
|
partUnSubscribe (Keyboard t) = generalUnSubscribe t
|
|
|
|
instance SDLSubsystem Keyboard StateData where
|
|
consumeSDLEvents = consumeSDLKeyboardEvents
|
|
|
|
instance Participant Joystick StateData where
|
|
type Mesg Joystick StateData = JoystickMessage
|
|
|
|
partSubscribers (Joystick t) = generalSubscribers t
|
|
|
|
partSubscribe (Joystick t) = generalSubscribe t
|
|
|
|
partUnSubscribe (Joystick t) = generalUnSubscribe t
|
|
|
|
instance SDLSubsystem Joystick StateData where
|
|
consumeSDLEvents = consumeSDLJoystickEvents
|
|
|
|
main :: IO ()
|
|
main = do
|
|
logIO Debug "Starting"
|
|
let conf = AffectionConfig
|
|
{ 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
|
|
, preLoop = pre
|
|
, eventLoop = handle
|
|
, updateLoop = update
|
|
, drawLoop = draw
|
|
, cleanUp = clean
|
|
}
|
|
withAffection conf
|
|
|
|
load :: IO StateData
|
|
load =
|
|
StateData <$> (Subsystems
|
|
<$> (Window <$> newTVarIO [])
|
|
<*> (Mouse <$> newTVarIO [])
|
|
<*> (Keyboard <$> newTVarIO [])
|
|
<*> (Joystick <$> newTVarIO [])
|
|
)
|
|
<*> return []
|
|
|
|
pre :: Affection StateData ()
|
|
pre = do
|
|
sd <- getAffection
|
|
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
|
|
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
|
|
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
|
|
return ()
|
|
|
|
exitOnQ :: KeyboardMessage -> Affection StateData ()
|
|
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
|
|
case SDL.keysymKeycode sym of
|
|
SDL.KeycodeQ -> do
|
|
liftIO $ logIO Debug "Yo dog I heard..."
|
|
quit
|
|
_ -> return ()
|
|
|
|
exitOnWindowClose :: WindowMessage -> Affection StateData ()
|
|
exitOnWindowClose wm =
|
|
case wm of
|
|
MsgWindowClose _ _ -> do
|
|
liftIO $ logIO Debug "I heard another one..."
|
|
quit
|
|
_ -> return ()
|
|
|
|
joyConnectDisconnect :: JoystickMessage -> Affection StateData ()
|
|
joyConnectDisconnect msg = do
|
|
mj <- joystickAutoConnect msg
|
|
when (isJust mj) $ do
|
|
sd <- getAffection
|
|
putAffection sd
|
|
{ sdJoys = fromJust mj : sdJoys sd
|
|
}
|
|
sd <- getAffection
|
|
njs <- joystickAutoDisconnect (sdJoys sd) msg
|
|
putAffection sd
|
|
{ sdJoys = njs
|
|
}
|
|
|
|
handle :: [SDL.EventPayload] -> Affection StateData ()
|
|
handle es = do
|
|
(Subsystems a b c d) <- sdSubs <$> getAffection
|
|
leftovers <- consumeSDLEvents a
|
|
=<< consumeSDLEvents b
|
|
=<< consumeSDLEvents c
|
|
=<< consumeSDLEvents d es
|
|
mapM_ (\e -> liftIO $ logIO Verbose $ "LEFTOVER: " ++ show e) leftovers
|
|
return ()
|
|
|
|
update _ = return ()
|
|
|
|
draw = return ()
|
|
|
|
clean _ = return ()
|