about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/Monad.hs
blob: db602de56f3aae41cf034c2baa8cdc3a55bfbf40 (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
70
71
72
73
74
75
76
--------------------------------------------------------------------------------
module Xanthous.Monad
  ( AppT(..)
  , AppM
  , runAppT
  , continue
  , halt

    -- * Messages
  , say
  , say_
  , message
  , message_
  , writeMessage

    -- * Autocommands
  , cancelAutocommand

    -- * Events
  , sendEvent
  ) where
--------------------------------------------------------------------------------
import           Xanthous.Prelude
import           Control.Monad.Random
import           Control.Monad.State
import qualified Brick
import           Brick (EventM, Next)
import           Brick.BChan (writeBChan)
import           Data.Aeson (ToJSON, object)
--------------------------------------------------------------------------------
import           Xanthous.Data.App (AppEvent)
import           Xanthous.Game.State
import           Xanthous.Game.Env
import           Xanthous.Messages (Message)
import qualified Xanthous.Messages as Messages
--------------------------------------------------------------------------------

halt :: AppT (EventM n) (Next GameState)
halt = lift . Brick.halt =<< get

continue :: AppT (EventM n) (Next GameState)
continue = lift . Brick.continue =<< get

--------------------------------------------------------------------------------

say :: (MonadRandom m, ToJSON params, MonadState GameState m)
    => [Text] -> params -> m ()
say msgPath = writeMessage <=< Messages.message msgPath

say_ :: (MonadRandom m, MonadState GameState m) => [Text] -> m ()
say_ msgPath = say msgPath $ object []

message :: (MonadRandom m, ToJSON params, MonadState GameState m)
        => Message -> params -> m ()
message msg = writeMessage <=< Messages.render msg

message_ :: (MonadRandom m, MonadState GameState m)
         => Message ->  m ()
message_ msg = message msg $ object []

writeMessage :: MonadState GameState m => Text -> m ()
writeMessage m = messageHistory %= pushMessage m

-- | Cancel the currently active autocommand, if any
cancelAutocommand :: (MonadState GameState m, MonadIO m) => m ()
cancelAutocommand = do
  traverse_ (liftIO . cancel . snd) =<< preuse (autocommand . _ActiveAutocommand)
  autocommand .= NoAutocommand

--------------------------------------------------------------------------------

-- | Send an event to the app in an environment where the game env is available
sendEvent :: (MonadReader GameEnv m, MonadIO m) => AppEvent -> m ()
sendEvent evt = do
  ec <- view eventChan
  liftIO $ writeBChan ec evt