Implement a "look" command

Implement the PointOnMap prompt type, which allows the player to move
the cursor around and select a position on the map, and use this prompt
type to implement a "look" command, describing all entities at the
selected position.

7 files changed, 111 insertions, 29 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 71bf40c427e8..13c4af1246d5 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE UndecidableInstances #-}
 --------------------------------------------------------------------------------
 module Xanthous.App (makeApp) where
 --------------------------------------------------------------------------------
@@ -14,8 +15,8 @@ import           Control.Monad.State.Class (modify)
 import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
 import qualified Data.Vector as V
-import qualified Data.Yaml as Yaml
 import           System.Exit
+import           GHC.TypeLits (TypeError, ErrorMessage(..))
 --------------------------------------------------------------------------------
 import           Xanthous.Command
 import           Xanthous.Data
@@ -167,6 +168,15 @@ handleCommand Open = do
   stepGame -- TODO
   continue
 
+handleCommand Look = do
+  prompt_ @'PointOnMap ["look", "prompt"] Cancellable
+    $ \(PointOnMapResult pos) ->
+      use (entities . EntityMap.atPosition pos)
+      >>= \case
+        Empty -> say_ ["look", "nothing"]
+        ents -> describeEntities ents
+  continue
+
 handleCommand Wait = stepGame >> continue
 
 handleCommand Eat = do
@@ -217,11 +227,10 @@ handlePromptEvent
   -> BrickEvent Name ()
   -> AppM (Next GameState)
 
-handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc [])) = do
-  promptState .= NoPrompt
-  continue
-handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) =
-  submitPrompt pr >> clearPrompt
+handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
+  = clearPrompt
+handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
+  = submitPrompt pr >> clearPrompt
 
 handlePromptEvent
   msg
@@ -246,14 +255,32 @@ handlePromptEvent _ (Prompt _ SMenu _ items cb) (VtyEvent (EvKey (KChar chr) [])
   | otherwise
   = continue
 
-handlePromptEvent _ _ _ = undefined
+handlePromptEvent
+  msg
+  (Prompt c SPointOnMap (PointOnMapPromptState pos) pri cb)
+  (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
+  = let pos' = move dir pos
+        prompt' = Prompt c SPointOnMap (PointOnMapPromptState pos') pri cb
+    in promptState .= WaitingPrompt msg prompt'
+       >> continue
+handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
 
 clearPrompt :: AppM (Next GameState)
 clearPrompt = promptState .= NoPrompt >> continue
 
+class NotMenu (pt :: PromptType)
+instance NotMenu 'StringPrompt
+instance NotMenu 'Confirm
+instance NotMenu 'DirectionPrompt
+instance NotMenu 'PointOnMap
+instance NotMenu 'Continue
+instance TypeError ('Text "Cannot use `prompt` or `prompt_` for menu prompts"
+                    ':$$: 'Text "Use `menu` or `menu_` instead")
+         => NotMenu ('Menu a)
+
 prompt
   :: forall (pt :: PromptType) (params :: Type).
-    (ToJSON params, SingPromptType pt, PromptInput pt ~ ())
+    (ToJSON params, SingPromptType pt, NotMenu pt)
   => [Text]                     -- ^ Message key
   -> params                     -- ^ Message params
   -> PromptCancellable
@@ -262,12 +289,20 @@ prompt
 prompt msgPath params cancellable cb = do
   let pt = singPromptType @pt
   msg <- Messages.message msgPath params
-  let p = mkPrompt cancellable pt cb
+  p <- case pt of
+    SPointOnMap -> do
+      charPos <- use characterPosition
+      pure $ mkPointOnMapPrompt cancellable charPos cb
+    SStringPrompt -> pure $ mkPrompt cancellable pt cb
+    SConfirm -> pure $ mkPrompt cancellable pt cb
+    SDirectionPrompt -> pure $ mkPrompt cancellable pt cb
+    SContinue -> pure $ mkPrompt cancellable pt cb
+    SMenu -> error "unreachable"
   promptState .= WaitingPrompt msg p
 
 prompt_
-  :: forall (pt :: PromptType) .
-    (SingPromptType pt, PromptInput pt ~ ())
+  :: forall (pt :: PromptType).
+    (SingPromptType pt, NotMenu pt)
   => [Text] -- ^ Message key
   -> PromptCancellable
   -> (PromptResult pt -> AppM ()) -- ^ Prompt promise handler
@@ -295,6 +330,7 @@ menu_ :: forall (a :: Type).
       -> AppM ()
 menu_ msgPath = menu msgPath $ object []
 
+
 --------------------------------------------------------------------------------
 
 entitiesAtPositionWithType
@@ -316,10 +352,22 @@ describeEntitiesAt pos =
       . to (filter (not . entityIs @Character))
       ) >>= \case
         Empty -> pure ()
-        ents  ->
-          let descriptions = description <$> ents
-          in say ["entities", "description"] $ object
-                 ["entityDescriptions" A..= toSentence descriptions]
+        ents  -> describeEntities ents
+
+describeEntities
+  :: ( Entity entity
+    , MonadRandom m
+    , MonadState GameState m
+    , MonoFoldable (f Text)
+    , Functor f
+    , Element (f Text) ~ Text
+    )
+  => f entity
+  -> m ()
+describeEntities ents =
+  let descriptions = description <$> ents
+  in say ["entities", "description"]
+     $ object ["entityDescriptions" A..= toSentence descriptions]
 
 attackAt :: Position -> AppM ()
 attackAt pos =
diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs
index 74808443d34c..35a8ce367269 100644
--- a/src/Xanthous/Command.hs
+++ b/src/Xanthous/Command.hs
@@ -17,6 +17,7 @@ data Command
   | Open
   | Wait
   | Eat
+  | Look
   | Save
 
     -- | TODO replace with `:` commands
@@ -29,9 +30,12 @@ commandFromKey (KChar (directionFromChar -> Just dir)) [] = Just $ Move dir
 commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
 commandFromKey (KChar ',') [] = Just PickUp
 commandFromKey (KChar 'o') [] = Just Open
+commandFromKey (KChar ';') [] = Just Look
 commandFromKey (KChar 'e') [] = Just Eat
-commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
 commandFromKey (KChar 'S') [] = Just Save
+
+commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
+
 commandFromKey _ _ = Nothing
 
 --------------------------------------------------------------------------------
diff --git a/src/Xanthous/Entities/Raws/gormlak.yaml b/src/Xanthous/Entities/Raws/gormlak.yaml
index 9a9281c9a91a..2eac895190b3 100644
--- a/src/Xanthous/Entities/Raws/gormlak.yaml
+++ b/src/Xanthous/Entities/Raws/gormlak.yaml
@@ -1,6 +1,7 @@
 Creature:
   name: gormlak
-  description: |
+  description: a gormlak
+  longDescription: |
     A chittering imp-like creature with bright yellow horns. It adores shiny objects
     and gathers in swarms.
   char:
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index ffbf30cca864..2f7ccf29f795 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -32,6 +32,14 @@ import qualified Xanthous.Resource as Resource
 import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
+cursorPosition :: GameState -> Widget Name -> Widget Name
+cursorPosition game
+  | WaitingPrompt _ (Prompt _ SPointOnMap (PointOnMapPromptState pos) _ _)
+    <- game ^. promptState
+  = showCursor Resource.Prompt (pos ^. loc)
+  | otherwise
+  = showCursor Resource.Character (game ^. characterPosition . loc)
+
 drawMessages :: MessageHistory -> Widget Name
 drawMessages = txt . (<> " ") . unwords . oextract
 
@@ -46,7 +54,7 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
     (SMenu, _, menuItems) ->
       txt msg
       <=> foldl' (<=>) emptyWidget (map drawMenuItem $ itoList menuItems)
-    _ -> undefined
+    _ -> txt msg
   where
     drawMenuItem (chr, MenuOption m _) =
       str ("[" <> pure chr <> "] ") <+> txt m
@@ -77,7 +85,7 @@ drawEntities canRenderPos allEnts
 drawMap :: GameState -> Widget Name
 drawMap game
   = viewport Resource.MapViewport Both
-  . showCursor Resource.Character (game ^. characterPosition . loc)
+  . cursorPosition game
   $ drawEntities
     (\pos ->
          (game ^. debugState . allRevealed)
@@ -102,7 +110,9 @@ drawGame :: GameState -> [Widget Name]
 drawGame game
   = pure
   . withBorderStyle unicode
-  $   drawMessages (game ^. messageHistory)
+  $ case game ^. promptState of
+       NoPrompt -> drawMessages (game ^. messageHistory)
+       _ -> emptyWidget
   <=> drawPromptState (game ^. promptState)
   <=> border (drawMap game)
   <=> drawCharacterInfo (game ^. character)
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index 1154d6db5a4c..6c3629f31055 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -15,6 +15,7 @@ module Xanthous.Game.Prompt
   , Prompt(..)
   , mkPrompt
   , mkMenu
+  , mkPointOnMapPrompt
   , isCancellable
   , submitPrompt
   ) where
@@ -67,6 +68,7 @@ instance NFData (SPromptType pt) where
 class SingPromptType pt where singPromptType :: SPromptType pt
 instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
 instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
+instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
 instance SingPromptType 'Continue where singPromptType = SContinue
 
 instance Show (SPromptType pt) where
@@ -115,16 +117,20 @@ instance Arbitrary (PromptResult 'Continue) where
 --------------------------------------------------------------------------------
 
 data PromptState pt where
-  StringPromptState    :: Editor Text Name -> PromptState 'StringPrompt
-  DirectionPromptState ::                    PromptState 'DirectionPrompt
-  ContinuePromptState  ::                    PromptState 'Continue
-  MenuPromptState      :: forall a.               PromptState ('Menu a)
+  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
 
 instance NFData (PromptState pt) where
   rnf sps@(StringPromptState ed) = sps `deepseq` ed `deepseq` ()
   rnf DirectionPromptState = ()
   rnf ContinuePromptState = ()
+  rnf ConfirmPromptState = ()
   rnf MenuPromptState = ()
+  rnf pomps@(PointOnMapPromptState pos) = pomps `deepseq` pos `deepseq` ()
 
 instance Arbitrary (PromptState 'StringPrompt) where
   arbitrary = StringPromptState <$> arbitrary
@@ -170,6 +176,7 @@ instance Show (MenuOption a) where
 
 type family PromptInput (pt :: PromptType) :: Type where
   PromptInput ('Menu a) = Map Char (MenuOption a)
+  PromptInput 'PointOnMap = Position -- Character pos
   PromptInput _ = ()
 
 data Prompt (m :: Type -> Type) where
@@ -236,7 +243,7 @@ mkPrompt c pt@SStringPrompt cb =
   in Prompt c pt ps () cb
 mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
 mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
-mkPrompt _ _ _ = undefined
+mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
 
 mkMenu
   :: forall a m.
@@ -246,6 +253,13 @@ mkMenu
   -> Prompt m
 mkMenu c = Prompt c SMenu MenuPromptState
 
+mkPointOnMapPrompt
+  :: PromptCancellable
+  -> Position
+  -> (PromptResult 'PointOnMap -> m ())
+  -> Prompt m
+mkPointOnMapPrompt c pos = Prompt c SPointOnMap (PointOnMapPromptState pos) pos
+
 isCancellable :: Prompt m -> Bool
 isCancellable (Prompt Cancellable _ _ _ _)   = True
 isCancellable (Prompt Uncancellable _ _ _ _) = False
@@ -261,7 +275,7 @@ submitPrompt (Prompt _ pt ps _ cb) =
       cb ContinueResult
     (SMenu, MenuPromptState) ->
       pure () -- Don't use submit with a menu prompt
-    _ -> undefined
-
--- data PromptInput :: PromptType -> Type where
---   StringInput :: PromptInput 'StringPrompt
+    (SPointOnMap, PointOnMapPromptState pos) ->
+      cb $ PointOnMapResult pos
+    (SConfirm, ConfirmPromptState) ->
+      cb $ ConfirmResult True
diff --git a/src/Xanthous/Resource.hs b/src/Xanthous/Resource.hs
index 13f7e539679b..5350e7646e38 100644
--- a/src/Xanthous/Resource.hs
+++ b/src/Xanthous/Resource.hs
@@ -16,6 +16,7 @@ data Name = MapViewport
           | MessageBox
             -- ^ The box where we display messages to the user
           | Prompt
+            -- ^ The game's prompt
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function)
 
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 69664f8a7940..71f08f263185 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -22,6 +22,10 @@ open:
   locked: "That door is locked"
   nothingToOpen: "There's nothing to open there"
 
+look:
+  prompt: Select a position on the map to describe (use Enter to confirm)
+  nothing: There's nothing there
+
 character:
   namePrompt: "What's your name? "