2016-11-04 15:06:16 +00:00
|
|
|
{-# LANGUAGE RecordWildCards #-}
|
2017-12-13 14:19:53 +00:00
|
|
|
{-# LANGUAGE RankNTypes #-}
|
2016-11-04 15:06:16 +00:00
|
|
|
|
2016-05-29 16:01:23 +00:00
|
|
|
import Affection
|
2016-11-04 15:06:16 +00:00
|
|
|
import qualified SDL
|
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
import Control.Concurrent.STM
|
2016-12-26 13:06:51 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
data StateData = StateData
|
|
|
|
{ sdSubs :: Subsystems
|
|
|
|
}
|
2016-11-04 15:06:16 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
data Subsystems = Subsystems
|
|
|
|
{ subWindow :: AffectionWindow StateData
|
|
|
|
, subMouse :: AffectionMouse StateData
|
|
|
|
, subKeyboard :: AffectionKeyboard StateData
|
|
|
|
}
|
2016-05-29 16:01:23 +00:00
|
|
|
|
|
|
|
main :: IO ()
|
2016-11-04 15:06:16 +00:00
|
|
|
main = do
|
2017-12-13 14:19:53 +00:00
|
|
|
logIO Debug "Starting"
|
|
|
|
let conf = AffectionConfig
|
|
|
|
{ initComponents = All
|
|
|
|
, windowTitle = "affection: example00"
|
|
|
|
, windowConfig = SDL.defaultWindow
|
|
|
|
, initScreenMode = SDL.Windowed
|
|
|
|
, canvasSize = Nothing
|
|
|
|
, loadState = load
|
|
|
|
, preLoop = pre
|
|
|
|
, eventLoop = handle
|
|
|
|
, updateLoop = update
|
|
|
|
, drawLoop = draw
|
|
|
|
, cleanUp = clean
|
|
|
|
}
|
2016-11-04 15:06:16 +00:00
|
|
|
withAffection conf
|
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
load :: IO StateData
|
2017-03-23 03:27:57 +00:00
|
|
|
load = do
|
2017-12-13 14:19:53 +00:00
|
|
|
empty1 <- newTVarIO [] -- ([] :: [(UUID, WindowMessage -> Affection StateData ())])
|
|
|
|
empty2 <- newTVarIO [] -- ([] :: [(UUID, MouseMessage -> Affection StateData ())])
|
|
|
|
empty3 <- newTVarIO [] -- ([] :: [(UUID, KeyboardMessage -> Affection StateData ())])
|
|
|
|
return $ StateData $ Subsystems
|
|
|
|
(AffectionWindow empty1)
|
|
|
|
(AffectionMouse empty2)
|
|
|
|
(AffectionKeyboard empty3)
|
|
|
|
|
|
|
|
pre :: Affection StateData ()
|
|
|
|
pre = do
|
|
|
|
sd <- getAffection
|
|
|
|
_ <- partSubscribe (subKeyboard $ sdSubs sd) exitOnQ
|
|
|
|
return ()
|
2016-11-04 15:06:16 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
exitOnQ :: KeyboardMessage -> Affection StateData ()
|
|
|
|
exitOnQ (MsgKeyboardEvent _ _ _ _ sym) =
|
|
|
|
case SDL.keysymKeycode sym of
|
|
|
|
SDL.KeycodeQ -> quit
|
|
|
|
otherwise -> return ()
|
2016-11-04 15:06:16 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
handle :: [SDL.EventPayload] -> Affection StateData ()
|
|
|
|
handle es = do
|
|
|
|
(Subsystems a b c) <- sdSubs <$> getAffection
|
|
|
|
_ <- consumeSDLEvents a es
|
|
|
|
_ <- consumeSDLEvents b es
|
|
|
|
_ <- consumeSDLEvents c es
|
|
|
|
return ()
|
2017-03-16 19:12:41 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
update _ = return ()
|
2017-03-16 19:12:41 +00:00
|
|
|
|
2017-12-13 14:19:53 +00:00
|
|
|
draw = return ()
|
2016-11-13 12:46:23 +00:00
|
|
|
|
|
|
|
clean _ = return ()
|