affection/examples/example00/Main.hs

186 lines
5 KiB
Haskell
Raw Normal View History

2017-12-28 15:56:49 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
import Affection
import qualified SDL
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
2018-01-09 17:40:54 +00:00
import Control.Monad (when)
2017-12-28 15:56:49 +00:00
2018-01-09 17:40:54 +00:00
import Data.Maybe (isJust, fromJust)
data StateData = StateData
2017-12-28 15:56:49 +00:00
{ sdSubs :: Subsystems
2018-01-09 17:40:54 +00:00
, sdJoys :: [SDL.Joystick]
2017-12-28 15:56:49 +00:00
}
data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
, subKeyboard :: Keyboard
2018-01-09 17:40:54 +00:00
, subJoystick :: Joystick
2017-12-28 15:56:49 +00:00
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection StateData ())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection StateData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection StateData ())])
2018-01-09 17:40:54 +00:00
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
2017-12-28 15:56:49 +00:00
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
2018-01-09 17:40:54 +00:00
generalUnSubscribe
:: TVar [(UUID, msg -> Affection StateData ())]
-> UUID
-> Affection StateData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
2017-12-28 15:56:49 +00:00
instance Participant Window StateData where
type Mesg Window StateData = WindowMessage
2018-01-09 17:40:54 +00:00
partSubscribers (Window t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Window t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Window t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Window StateData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse StateData where
type Mesg Mouse StateData = MouseMessage
2018-01-09 17:40:54 +00:00
partSubscribers (Mouse t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Mouse t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Mouse t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Mouse StateData where
consumeSDLEvents = consumeSDLMouseEvents
instance Participant Keyboard StateData where
type Mesg Keyboard StateData = KeyboardMessage
2018-01-09 17:40:54 +00:00
partSubscribers (Keyboard t) = generalSubscribers t
2017-12-28 15:56:49 +00:00
partSubscribe (Keyboard t) = generalSubscribe t
2018-01-09 17:40:54 +00:00
partUnSubscribe (Keyboard t) = generalUnSubscribe t
2017-12-28 15:56:49 +00:00
instance SDLSubsystem Keyboard StateData where
consumeSDLEvents = consumeSDLKeyboardEvents
2018-01-09 17:40:54 +00:00
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
2017-12-28 15:56:49 +00:00
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
2018-01-09 17:40:54 +00:00
load =
StateData <$> (Subsystems
<$> (Window <$> newTVarIO [])
<*> (Mouse <$> newTVarIO [])
<*> (Keyboard <$> newTVarIO [])
<*> (Joystick <$> newTVarIO [])
)
<*> return []
2017-12-28 15:56:49 +00:00
pre :: Affection StateData ()
pre = do
sd <- getAffection
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
_ <- partSubscribe (subWindow $ sdSubs sd) exitOnWindowClose
2018-01-09 17:40:54 +00:00
_ <- partSubscribe (subJoystick $ sdSubs sd) joyConnectDisconnect
2017-12-28 15:56:49 +00:00
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 ()
2018-01-09 17:40:54 +00:00
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
}
2017-12-28 15:56:49 +00:00
handle :: [SDL.EventPayload] -> Affection StateData ()
handle es = do
2018-01-09 17:40:54 +00:00
(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
2017-12-28 15:56:49 +00:00
return ()
update _ = return ()
draw = return ()
clean _ = return ()