blob: d48e06bf6b43b90de07a1b481ca7a9a93f485ca5 (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
module Chelleport.AppShell (setupAppShell, MonadAppShell (..)) where
import Chelleport.Config
import Chelleport.Control (MonadControl (releaseMouseButton))
import Chelleport.Types
import Control.Monad (foldM)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.RWS (MonadReader (ask), asks)
import qualified Graphics.X11 as X11
import SDL (($=))
import qualified SDL
import System.Exit (exitSuccess)
class (Monad m) => MonadAppShell m where
hideWindow :: m ()
showWindow :: m ()
shutdownApp :: m ()
instance (MonadIO m) => MonadAppShell (AppM m) where
hideWindow = asks ctxWindow >>= SDL.hideWindow
showWindow = asks ctxWindow >>= SDL.showWindow
shutdownApp = do
ctx <- ask
SDL.destroyRenderer $ ctxRenderer ctx
SDL.destroyWindow $ ctxWindow ctx
releaseMouseButton
SDL.quit
liftIO $ do
X11.closeDisplay $ ctxX11Display ctx
exitSuccess
type Update m state appAction = state -> appAction -> m (state, Maybe appAction)
type EventHandler state appAction = state -> SDL.Event -> Maybe appAction
type View m state = state -> m ()
type Initializer m state appAction = m (state, Maybe appAction)
setupAppShell ::
(MonadIO m) =>
DrawContext ->
Initializer m state appAction ->
Update m state appAction ->
EventHandler state appAction ->
View m state ->
m ()
setupAppShell (DrawContext {ctxRenderer = renderer}) getInitState update eventHandler draw = do
state <- getInitState >>= evalUpdateResult
appLoop state
where
appLoop currentState = do
SDL.rendererDrawColor renderer $= colorBackground
SDL.clear renderer
draw currentState
SDL.present renderer
newState <- SDL.pollEvents >>= foldM evaluateEvent currentState
appLoop newState
evaluateEvent state event =
maybe (pure state) (updateState state) (eventHandler state event)
updateState state action =
update state action >>= evalUpdateResult
evalUpdateResult (state, Nothing) = pure state
evalUpdateResult (state, Just action) = updateState state action
|
