Add the beginnings of a prompt system

Add the beginnings of a generic prompt system, with exclusive support
atm for string prompts, and test it out by asking the character for
their name at startup

2 files changed, 155 insertions, 30 deletions

diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 8deb20ff84cb..60ae7110a6bf 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -1,40 +1,47 @@
-{-# LANGUAGE ViewPatterns #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Game.Draw
   ( drawGame
   ) where
-
-import Xanthous.Prelude
-import Brick hiding (loc)
-import Brick.Widgets.Border
-import Brick.Widgets.Border.Style
-import Data.List.NonEmpty(NonEmpty((:|)))
-
-import Xanthous.Data (Position(Position), x, y, loc)
-import Xanthous.Data.EntityMap (EntityMap, atPosition)
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Brick hiding (loc)
+import           Brick.Widgets.Border
+import           Brick.Widgets.Border.Style
+import           Brick.Widgets.Edit
+import           Data.List.NonEmpty(NonEmpty((:|)))
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Position(Position), x, y, loc)
+import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
-import Xanthous.Entities
-import Xanthous.Game
-  ( GameState(..)
-  , entities
-  , revealedPositions
-  , characterPosition
-  , MessageHistory(..)
-  , messageHistory
-  )
-import Xanthous.Resource (Name(..))
-import Xanthous.Orphans ()
+import           Xanthous.Entities
+import           Xanthous.Game
+                 ( GameState(..)
+                 , entities
+                 , revealedPositions
+                 , characterPosition
+                 , MessageHistory(..)
+                 , messageHistory
+                 , GamePromptState(..)
+                 , promptState
+                 )
+import           Xanthous.Game.Prompt
+import           Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+import           Xanthous.Orphans ()
+--------------------------------------------------------------------------------
 
 drawMessages :: MessageHistory -> Widget Name
 drawMessages NoMessageHistory = emptyWidget
-drawMessages (MessageHistory _ False) = emptyWidget
+drawMessages (MessageHistory _ False) = str " "
 drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
 
--- an attempt to still take up a row even when no messages
--- drawMessages msgs = vLimit 1 . Widget Greedy Fixed . render $ case msgs of
---   NoMessageHistory -> padTop (Pad 2) $ str " "
---   (MessageHistory _ False) -> padTop (Pad 2) $ str " "
---   (MessageHistory (lastMessage :| _) True) -> txt lastMessage
+drawPromptState :: GamePromptState m -> Widget Name
+drawPromptState NoPrompt = emptyWidget
+drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      txt msg <+> renderEditor (txt . fold) True edit
+    _ -> undefined
 
 drawEntities
   :: Set Position
@@ -61,8 +68,8 @@ drawEntities visiblePositions allEnts
 
 drawMap :: GameState -> Widget Name
 drawMap game
-  = viewport MapViewport Both
-  . showCursor Character (game ^. characterPosition . loc)
+  = viewport Resource.MapViewport Both
+  . showCursor Resource.Character (game ^. characterPosition . loc)
   $ drawEntities
     (game ^. revealedPositions)
     (game ^. entities)
@@ -72,4 +79,5 @@ drawGame game
   = pure
   . withBorderStyle unicode
   $   drawMessages (game ^. messageHistory)
+  <=> drawPromptState (game ^. promptState)
   <=> border (drawMap game)
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
new file mode 100644
index 000000000000..928340f06480
--- /dev/null
+++ b/src/Xanthous/Game/Prompt.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE GADTs #-}
+--------------------------------------------------------------------------------
+module Xanthous.Game.Prompt
+  ( PromptType(..)
+  , SPromptType(..)
+  , SingPromptType(..)
+  , PromptCancellable(..)
+  , PromptResult(..)
+  , PromptState(..)
+  , Prompt(..)
+  , mkPrompt
+  , isCancellable
+  , submitPrompt
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Edit (Editor, editorText, getEditContents)
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import Xanthous.Data (Direction, Position)
+import Xanthous.Resource (Name)
+import qualified Xanthous.Resource as Resource
+--------------------------------------------------------------------------------
+
+data PromptType where
+  StringPrompt    :: PromptType
+  Confirm         :: PromptType
+  Menu            :: Type -> PromptType
+  DirectionPrompt :: PromptType
+  PointOnMap      :: PromptType
+  deriving stock (Generic)
+
+instance Show PromptType where
+  show StringPrompt = "StringPrompt"
+  show Confirm = "Confirm"
+  show (Menu _) = "Menu"
+  show DirectionPrompt = "DirectionPrompt"
+  show PointOnMap = "PointOnMap"
+
+data SPromptType :: PromptType -> Type where
+  SStringPrompt    ::      SPromptType 'StringPrompt
+  SConfirm         ::      SPromptType 'Confirm
+  SMenu            :: forall a. SPromptType ('Menu a)
+  SDirectionPrompt ::      SPromptType 'DirectionPrompt
+  SPointOnMap      ::      SPromptType 'PointOnMap
+
+class SingPromptType pt where singPromptType :: SPromptType pt
+instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+
+instance Show (SPromptType pt) where
+  show SStringPrompt    = "SStringPrompt"
+  show SConfirm         = "SConfirm"
+  show SMenu            = "SMenu"
+  show SDirectionPrompt = "SDirectionPrompt"
+  show SPointOnMap      = "SPointOnMap"
+
+data PromptCancellable
+  = Cancellable
+  | Uncancellable
+  deriving stock (Show, Eq, Ord, Enum, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance Arbitrary PromptCancellable where
+  arbitrary = genericArbitrary
+
+data PromptResult (pt :: PromptType) where
+  StringResult     :: Text      -> PromptResult 'StringPrompt
+  ConfirmResult    :: Bool      -> PromptResult 'Confirm
+  MenuResult       :: forall a. a    -> PromptResult ('Menu a)
+  DirectionResult  :: Direction -> PromptResult 'DirectionPrompt
+  PointOnMapResult :: Position  -> PromptResult 'PointOnMap
+
+data PromptState pt where
+  StringPromptState :: Editor Text Name -> PromptState 'StringPrompt
+
+deriving stock instance Show (PromptState pt)
+
+data Prompt (m :: Type -> Type) where
+  Prompt
+    :: forall (pt :: PromptType)
+        (m :: Type -> Type).
+      PromptCancellable
+    -> SPromptType pt
+    -> PromptState pt
+    -> (PromptResult pt -> m ())
+    -> Prompt m
+
+instance Show (Prompt m) where
+  show (Prompt c pt ps _)
+    = "(Prompt "
+    <> show c <> " "
+    <> show pt <> " "
+    <> show ps
+    <> " <function> )"
+
+mkPrompt :: PromptCancellable -> SPromptType pt -> (PromptResult pt -> m ()) -> Prompt m
+mkPrompt c pt@SStringPrompt cb =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c pt ps cb
+mkPrompt _ _ _ = undefined
+
+isCancellable :: Prompt m -> Bool
+isCancellable (Prompt Cancellable _ _ _)   = True
+isCancellable (Prompt Uncancellable _ _ _) = False
+
+submitPrompt :: Prompt m -> m ()
+submitPrompt (Prompt _ pt ps cb) =
+  case (pt, ps) of
+    (SStringPrompt, StringPromptState edit) ->
+      cb . StringResult . mconcat . getEditContents $ edit
+    _ -> undefined
+
+-- data PromptInput :: PromptType -> Type where
+--   StringInput :: PromptInput 'StringPrompt