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