Confirm before quitting

Prompt to confirm before quitting the game with the Quit command

3 files changed, 28 insertions, 3 deletions

diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 353ab28e161a..2ffc11e8e6c7 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -129,7 +129,7 @@ handleNoPromptEvent (VtyEvent (EvKey k mods))
 handleNoPromptEvent _ = continue
 
 handleCommand :: Command -> AppM (Next GameState)
-handleCommand Quit = halt
+handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue
 handleCommand (Move dir) = do
   newPos <- uses characterPosition $ move dir
   collisionAt newPos >>= \case
@@ -282,6 +282,12 @@ handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
 handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
   = submitPrompt pr >> clearPrompt
 
+handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
+  = submitPrompt pr >> clearPrompt
+
+handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
+  = clearPrompt
+
 handlePromptEvent
   msg
   (Prompt c SStringPrompt (StringPromptState edit) pri cb)
@@ -297,8 +303,6 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
   = cb (DirectionResult dir) >> clearPrompt
 handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
 
-handlePromptEvent _ (Prompt _ SContinue _ _ _) _ = continue
-
 handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
   | Just (MenuOption _ res) <- items' ^. at chr
   = cb (MenuResult res) >> clearPrompt
@@ -315,6 +319,11 @@ handlePromptEvent
        >> continue
 handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
 
+handlePromptEvent
+  _
+  (Prompt Cancellable _ _ _ _)
+  (VtyEvent (EvKey (KChar 'q') []))
+  = clearPrompt
 handlePromptEvent _ _ _ = continue
 
 clearPrompt :: AppM (Next GameState)
@@ -361,6 +370,18 @@ prompt_
   -> AppM ()
 prompt_ msg = prompt msg $ object []
 
+confirm
+  :: ToJSON params
+  => [Text] -- ^ Message key
+  -> params
+  -> AppM ()
+  -> AppM ()
+confirm msgPath params
+  = prompt @'Confirm msgPath params Cancellable . const
+
+confirm_ :: [Text] -> AppM () -> AppM ()
+confirm_ msgPath = confirm msgPath $ object []
+
 menu :: forall (a :: Type) (params :: Type).
        (ToJSON params)
      => [Text]                            -- ^ Message key
diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs
index b83c3d246fa2..e89cf5bee3d0 100644
--- a/src/Xanthous/Game/Prompt.hs
+++ b/src/Xanthous/Game/Prompt.hs
@@ -69,6 +69,7 @@ instance NFData (SPromptType pt) where
 
 class SingPromptType pt where singPromptType :: SPromptType pt
 instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
+instance SingPromptType 'Confirm where singPromptType = SConfirm
 instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
 instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
 instance SingPromptType 'Continue where singPromptType = SContinue
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 9e59f4fb0fa8..408cb6a1a57b 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -12,6 +12,9 @@ save:
   location:
     "Enter filename to save to: "
 
+quit:
+  confirm: Really quit without saving?
+
 entities:
   description: You see here {{entityDescriptions}}