Add a very basic, naive auto-move command

Add a very basic, naive auto-move command, which just steps the player
in a direction until they collide with something, regardless of any
surrounding beasties who might want to eat them.

There's a lot of other stuff going on here - in order to get this
working the way I wanted with a slight (I settled on 50ms) delay between
every step in these autocommands while still redrawing in between I had
to do all the extra machinery for custom Brick events with a channel,
and then at the same time adding the bits for actually executing
autocommands in a general fashion (because there will definitely be
more!) hit my threshold for size for App.hs which sent me on a big
journey to break it up into smaller files -- which seems actually like
it was quite successful. Hopefully this will help with compile times
too, though App.hs is still pretty slow (maybe more to do here).

6 files changed, 126 insertions, 31 deletions

diff --git a/src/Xanthous/Game/Arbitrary.hs b/src/Xanthous/Game/Arbitrary.hs
index 886a8c03d786..a1eb789a33c9 100644
--- a/src/Xanthous/Game/Arbitrary.hs
+++ b/src/Xanthous/Game/Arbitrary.hs
@@ -40,6 +40,7 @@ instance Arbitrary GameState where
     let _promptState = NoPrompt -- TODO
     _activePanel <- arbitrary
     _debugState <- arbitrary
+    let _autocommand = NoAutocommand
     pure $ GameState {..}
 
 
@@ -47,4 +48,3 @@ instance CoArbitrary GameLevel
 instance Function GameLevel
 instance CoArbitrary GameState
 instance Function GameState
-deriving newtype instance CoArbitrary (m (a, GameState)) => CoArbitrary (AppT m a)
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 659081e5731b..b855ce88e46b 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -10,6 +10,8 @@ import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Edit
 --------------------------------------------------------------------------------
 import           Xanthous.Data
+import           Xanthous.Data.App (ResourceName, Panel(..))
+import qualified Xanthous.Data.App as Resource
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Game.State
@@ -29,12 +31,10 @@ import           Xanthous.Game
                  , debugState, allRevealed
                  )
 import           Xanthous.Game.Prompt
-import           Xanthous.Resource (Name, Panel(..))
-import qualified Xanthous.Resource as Resource
 import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
-cursorPosition :: GameState -> Widget Name -> Widget Name
+cursorPosition :: GameState -> Widget ResourceName -> Widget ResourceName
 cursorPosition game
   | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
     <- game ^. promptState
@@ -42,10 +42,10 @@ cursorPosition game
   | otherwise
   = showCursor Resource.Character (game ^. characterPosition . loc)
 
-drawMessages :: MessageHistory -> Widget Name
+drawMessages :: MessageHistory -> Widget ResourceName
 drawMessages = txtWrap . (<> " ") . unwords . reverse . oextract
 
-drawPromptState :: GamePromptState m -> Widget Name
+drawPromptState :: GamePromptState m -> Widget ResourceName
 drawPromptState NoPrompt = emptyWidget
 drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
   case (pt, ps, pri) of
@@ -67,7 +67,7 @@ drawEntities
   -> (Position -> Bool)
     -- ^ Has a given position *ever* been seen by the character?
   -> EntityMap SomeEntity -- ^ all entities
-  -> Widget Name
+  -> Widget ResourceName
 drawEntities isVisible isRevealed allEnts
   = vBox rows
   where
@@ -90,7 +90,7 @@ drawEntities isVisible isRevealed allEnts
            $ maximumBy (compare `on` drawPriority)
            <$> fromNullable ents
 
-drawMap :: GameState -> Widget Name
+drawMap :: GameState -> Widget ResourceName
 drawMap game
   = viewport Resource.MapViewport Both
   . cursorPosition game
@@ -106,7 +106,7 @@ drawMap game
 bullet :: Char
 bullet = '•'
 
-drawInventoryPanel :: GameState -> Widget Name
+drawInventoryPanel :: GameState -> Widget ResourceName
 drawInventoryPanel game
   =   drawWielded  (game ^. character . inventory . wielded)
   <=> drawBackpack (game ^. character . inventory . backpack)
@@ -122,7 +122,7 @@ drawInventoryPanel game
               )
       <=> txt " "
 
-    drawBackpack :: Vector Item -> Widget Name
+    drawBackpack :: Vector Item -> Widget ResourceName
     drawBackpack Empty = txtWrap "Your backpack is empty right now."
     drawBackpack backpackItems
       = txtWrap ( "You are currently carrying the following items in your "
@@ -134,7 +134,7 @@ drawInventoryPanel game
               backpackItems)
 
 
-drawPanel :: GameState -> Panel -> Widget Name
+drawPanel :: GameState -> Panel -> Widget ResourceName
 drawPanel game panel
   = border
   . hLimit 35
@@ -143,7 +143,7 @@ drawPanel game panel
       InventoryPanel -> drawInventoryPanel
   $ game
 
-drawCharacterInfo :: Character -> Widget Name
+drawCharacterInfo :: Character -> Widget ResourceName
 drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
   where
     charName | Just n <- ch ^. characterName
@@ -154,7 +154,7 @@ drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints
         = txt "Hitpoints: "
       <+> txt (tshow $ let Hitpoints hp = characterHitpoints ch in hp)
 
-drawGame :: GameState -> [Widget Name]
+drawGame :: GameState -> [Widget ResourceName]
 drawGame game
   = pure
   . withBorderStyle unicode
diff --git a/src/Xanthous/Game/Env.hs b/src/Xanthous/Game/Env.hs
new file mode 100644
index 000000000000..6e10d0f73581
--- /dev/null
+++ b/src/Xanthous/Game/Env.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Env
+  ( GameEnv(..)
+  , eventChan
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.BChan (BChan)
+import Xanthous.Data.App (AppEvent)
+--------------------------------------------------------------------------------
+
+data GameEnv = GameEnv
+  { _eventChan :: BChan AppEvent
+  }
+  deriving stock (Generic)
+makeLenses ''GameEnv
+{-# ANN GameEnv ("HLint: ignore Use newtype instead of data" :: String) #-}
diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs
index 017d53652c4f..48b7235d2263 100644
--- a/src/Xanthous/Game/Lenses.hs
+++ b/src/Xanthous/Game/Lenses.hs
@@ -56,6 +56,7 @@ initialStateFromSeed seed =
       _debugState = DebugState
         { _allRevealed = False
         }
+      _autocommand = NoAutocommand
   in GameState {..}
 
 
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index e89cf5bee3d0..30b5fe7545e0 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -30,8 +30,8 @@ import           Test.QuickCheck.Arbitrary.Generic
 --------------------------------------------------------------------------------
 import           Xanthous.Util (smallestNotIn)
 import           Xanthous.Data (Direction, Position)
-import           Xanthous.Resource (Name)
-import qualified Xanthous.Resource as Resource
+import           Xanthous.Data.App (ResourceName)
+import qualified Xanthous.Data.App as Resource
 --------------------------------------------------------------------------------
 
 data PromptType where
@@ -120,12 +120,13 @@ instance Arbitrary (PromptResult 'Continue) where
 --------------------------------------------------------------------------------
 
 data PromptState pt where
-  StringPromptState     :: Editor Text Name -> PromptState 'StringPrompt
-  DirectionPromptState  ::                    PromptState 'DirectionPrompt
-  ContinuePromptState   ::                    PromptState 'Continue
-  ConfirmPromptState    ::                    PromptState 'Confirm
-  MenuPromptState       :: forall a.               PromptState ('Menu a)
-  PointOnMapPromptState :: Position         -> PromptState 'PointOnMap
+  StringPromptState
+    :: Editor Text ResourceName     -> PromptState 'StringPrompt
+  DirectionPromptState  ::            PromptState 'DirectionPrompt
+  ContinuePromptState   ::            PromptState 'Continue
+  ConfirmPromptState    ::            PromptState 'Confirm
+  MenuPromptState       :: forall a.       PromptState ('Menu a)
+  PointOnMapPromptState :: Position -> PromptState 'PointOnMap
 
 instance NFData (PromptState pt) where
   rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 80137df7a721..f614cad47339 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE TemplateHaskell      #-}
@@ -14,6 +15,7 @@ module Xanthous.Game.State
   , activePanel
   , promptState
   , characterEntityID
+  , autocommand
   , GamePromptState(..)
 
     -- * Game Level
@@ -31,9 +33,16 @@ module Xanthous.Game.State
   , previousMessage
   , nextTurn
 
+    -- * Autocommands
+  , Autocommand(..)
+  , AutocommandState(..)
+  , _NoAutocommand
+  , _ActiveAutocommand
+
     -- * App monad
   , AppT(..)
   , AppM
+  , runAppT
 
     -- * Entities
   , Draw(..)
@@ -73,9 +82,11 @@ import           Data.Coerce
 import           System.Random
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.Generic
-import           Control.Monad.State.Class
-import           Control.Monad.State
 import           Control.Monad.Random.Class
+import           Control.Monad.State
+import           Control.Monad.Trans.Control (MonadTransControl(..))
+import           Control.Monad.Trans.Compose
+import           Control.Monad.Morph (MFunctor(..))
 import           Brick (EventM, Widget, raw, str, emptyWidget)
 import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
 import qualified Data.Aeson as JSON
@@ -87,6 +98,7 @@ import qualified Graphics.Vty.Image as Vty
 import           Xanthous.Util (KnownBool(..))
 import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
 import           Xanthous.Data
+import           Xanthous.Data.App
 import           Xanthous.Data.Levels
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data.EntityChar
@@ -94,7 +106,7 @@ import           Xanthous.Data.VectorBag
 import           Xanthous.Data.Entities
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
-import           Xanthous.Resource
+import           Xanthous.Game.Env
 --------------------------------------------------------------------------------
 
 data MessageHistory
@@ -182,15 +194,21 @@ instance Function (GamePromptState m) where
 --------------------------------------------------------------------------------
 
 newtype AppT m a
-  = AppT { unAppT :: StateT GameState m a }
+  = AppT { unAppT :: ReaderT GameEnv (StateT GameState m) a }
   deriving ( Functor
            , Applicative
            , Monad
            , MonadState GameState
+           , MonadReader GameEnv
+           , MonadIO
+           )
+       via (ReaderT GameEnv (StateT GameState m))
+  deriving ( MonadTrans
+           , MFunctor
            )
-       via (StateT GameState m)
+       via (ReaderT GameEnv `ComposeT` StateT GameState)
 
-type AppM = AppT (EventM Name)
+type AppM = AppT (EventM ResourceName)
 
 --------------------------------------------------------------------------------
 
@@ -414,6 +432,50 @@ data GameLevel = GameLevel
 
 --------------------------------------------------------------------------------
 
+data Autocommand
+  = AutoMove Direction
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, Hashable, ToJSON, FromJSON, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Autocommand
+{-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
+
+data AutocommandState
+  = NoAutocommand
+  | ActiveAutocommand Autocommand (Async ())
+  deriving stock (Eq, Ord, Generic)
+  deriving anyclass (Hashable)
+
+instance Show AutocommandState where
+  show NoAutocommand = "NoAutocommand"
+  show (ActiveAutocommand ac _) =
+    "(ActiveAutocommand " <> show ac <> " <Async>)"
+
+instance ToJSON AutocommandState where
+  toJSON = const Null
+
+instance FromJSON AutocommandState where
+  parseJSON Null = pure NoAutocommand
+  parseJSON _ = fail "Invalid AutocommandState; expected null"
+
+instance NFData AutocommandState where
+  rnf NoAutocommand = ()
+  rnf (ActiveAutocommand ac t) = ac `deepseq` t `seq` ()
+
+instance CoArbitrary AutocommandState where
+  coarbitrary NoAutocommand = variant @Int 1
+  coarbitrary (ActiveAutocommand ac t)
+    = variant @Int 2
+    . coarbitrary ac
+    . coarbitrary (hash t)
+
+instance Function AutocommandState where
+  function = functionMap onlyNoAC (const NoAutocommand)
+    where
+      onlyNoAC NoAutocommand = ()
+      onlyNoAC _ = error "Can't handle autocommands in Function"
+
+--------------------------------------------------------------------------------
+
 
 data DebugState = DebugState
   { _allRevealed :: !Bool
@@ -439,6 +501,7 @@ data GameState = GameState
 
   , _promptState       :: !(GamePromptState AppM)
   , _debugState        :: !DebugState
+  , _autocommand       :: !AutocommandState
   }
   deriving stock (Show, Generic)
   deriving anyclass (NFData)
@@ -467,8 +530,12 @@ instance Eq GameState where
 
 --------------------------------------------------------------------------------
 
-instance MonadTrans AppT where
-  lift = AppT . lift
+runAppT :: Monad m => AppT m a -> GameEnv -> GameState -> m (a, GameState)
+runAppT appt env initialState
+  = flip runStateT initialState
+  . flip runReaderT env
+  . unAppT
+  $ appt
 
 instance (Monad m) => MonadRandom (AppT m) where
   getRandomR rng = randomGen %%= randomR rng
@@ -476,9 +543,16 @@ instance (Monad m) => MonadRandom (AppT m) where
   getRandomRs rng = uses randomGen $ randomRs rng
   getRandoms = uses randomGen randoms
 
-instance (MonadIO m) => MonadIO (AppT m) where
-  liftIO = lift . liftIO
+instance MonadTransControl AppT where
+  type StT AppT a = (a, GameState)
+  liftWith f
+    = AppT
+    . ReaderT $ \e
+    -> StateT $ \s
+    -> (,s) <$> f (\action -> runAppT action e s)
+  restoreT = AppT . ReaderT . const . StateT . const
 
 --------------------------------------------------------------------------------
 
 makeLenses ''DebugState
+makePrisms ''AutocommandState