about summary refs log tree commit diff
path: root/src/Xanthous/Monad.hs
diff options
context:
space:
mode:
authorGriffin Smith <root@gws.fyi>2019-09-01T20·21-0400
committerGriffin Smith <root@gws.fyi>2019-09-02T14·52-0400
commitadb3b74c0c3a3bffa0d47f52036fde3623f859f7 (patch)
tree3a2e416ea31f92562ba6eabf0fc4ddf2974b24b7 /src/Xanthous/Monad.hs
parent2fd3e4c9ad28b77a0d167ceefe879ca80ee1ee04 (diff)
Link up messages to the overall game
Add a "say" function for saying messages within an app monad to the
user, and link everything up to display them and track their history
Diffstat (limited to 'src/Xanthous/Monad.hs')
-rw-r--r--src/Xanthous/Monad.hs58
1 files changed, 58 insertions, 0 deletions
diff --git a/src/Xanthous/Monad.hs b/src/Xanthous/Monad.hs
new file mode 100644
index 000000000000..fb790d5f9cb2
--- /dev/null
+++ b/src/Xanthous/Monad.hs
@@ -0,0 +1,58 @@
+module Xanthous.Monad
+  ( AppT(..)
+  , runAppT
+  , continue
+  , halt
+  , say
+  ) where
+
+import Xanthous.Prelude
+import Control.Monad.Random
+import Control.Monad.State
+import qualified Brick
+import Brick (EventM, Next)
+import Data.Aeson
+
+import Xanthous.Game
+import Xanthous.Messages (message)
+
+newtype AppT m a
+  = AppT { unAppT :: StateT GameState m a }
+  deriving ( Functor
+           , Applicative
+           , Monad
+           , MonadState GameState
+           )
+       via (StateT GameState m)
+
+instance MonadTrans AppT where
+  lift = AppT . lift
+
+instance (Monad m) => MonadRandom (AppT m) where
+  getRandomR rng = randomGen %%= randomR rng
+  getRandom = randomGen %%= random
+  getRandomRs rng = uses randomGen $ randomRs rng
+  getRandoms = uses randomGen randoms
+
+runAppT :: Monad m => AppT m a -> GameState -> m (a, GameState)
+runAppT appt initialState = flip runStateT initialState . unAppT $ appt
+
+halt :: AppT (EventM n) (Next GameState)
+halt = lift . Brick.halt =<< get
+
+continue :: AppT (EventM n) (Next GameState)
+continue = lift . Brick.continue =<< get
+
+-- say :: [Text] -> AppT m ()
+-- say :: [Text] -> params -> AppT m ()
+
+class SayR a where
+  say :: [Text] -> a
+
+instance Monad m => SayR (AppT m ()) where
+  say msgPath = say msgPath $ object []
+
+instance (Monad m, ToJSON params) => SayR (params -> AppT m ()) where
+  say msgPath params = do
+    msg <- message msgPath params
+    messageHistory %= pushMessage msg