about summary refs log tree commit diff
path: root/users/aspen/xanthous/src/Xanthous/Monad.hs
diff options
context:
space:
mode:
authorAspen Smith <grfn@gws.fyi>2024-02-12T03·00-0500
committerclbot <clbot@tvl.fyi>2024-02-14T19·37+0000
commit82ecd61f5c699cf3af6c4eadf47a1c52b1d696c6 (patch)
tree429c5e078528000591742ec3211bc768ae913a78 /users/aspen/xanthous/src/Xanthous/Monad.hs
parent0ba476a4266015f278f18d74094299de74a5a111 (diff)
chore(users): grfn -> aspen r/7511
Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>
Diffstat (limited to 'users/aspen/xanthous/src/Xanthous/Monad.hs')
-rw-r--r--users/aspen/xanthous/src/Xanthous/Monad.hs76
1 files changed, 76 insertions, 0 deletions
diff --git a/users/aspen/xanthous/src/Xanthous/Monad.hs b/users/aspen/xanthous/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..db602de56f3a
--- /dev/null
+++ b/users/aspen/xanthous/src/Xanthous/Monad.hs
@@ -0,0 +1,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