Confirm before quitting

Prompt to confirm before quitting the game with the Quit command
This commit is contained in:
Griffin Smith 2019-12-23 17:20:18 -05:00
parent f701a0be40
commit a58966d43f
3 changed files with 28 additions and 3 deletions

View file

@ -129,7 +129,7 @@ handleNoPromptEvent (VtyEvent (EvKey k mods))
handleNoPromptEvent _ = continue handleNoPromptEvent _ = continue
handleCommand :: Command -> AppM (Next GameState) handleCommand :: Command -> AppM (Next GameState)
handleCommand Quit = halt handleCommand Quit = confirm_ ["quit", "confirm"] (liftIO exitSuccess) >> continue
handleCommand (Move dir) = do handleCommand (Move dir) = do
newPos <- uses characterPosition $ move dir newPos <- uses characterPosition $ move dir
collisionAt newPos >>= \case collisionAt newPos >>= \case
@ -282,6 +282,12 @@ handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
handlePromptEvent _ pr (VtyEvent (EvKey KEnter [])) handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
= submitPrompt pr >> clearPrompt = submitPrompt pr >> clearPrompt
handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
= submitPrompt pr >> clearPrompt
handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
= clearPrompt
handlePromptEvent handlePromptEvent
msg msg
(Prompt c SStringPrompt (StringPromptState edit) pri cb) (Prompt c SStringPrompt (StringPromptState edit) pri cb)
@ -297,8 +303,6 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
= cb (DirectionResult dir) >> clearPrompt = cb (DirectionResult dir) >> clearPrompt
handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
handlePromptEvent _ (Prompt _ SContinue _ _ _) _ = continue
handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) [])) handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
| Just (MenuOption _ res) <- items' ^. at chr | Just (MenuOption _ res) <- items' ^. at chr
= cb (MenuResult res) >> clearPrompt = cb (MenuResult res) >> clearPrompt
@ -315,6 +319,11 @@ handlePromptEvent
>> continue >> continue
handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue handlePromptEvent _ (Prompt _ SPointOnMap _ _ _) _ = continue
handlePromptEvent
_
(Prompt Cancellable _ _ _ _)
(VtyEvent (EvKey (KChar 'q') []))
= clearPrompt
handlePromptEvent _ _ _ = continue handlePromptEvent _ _ _ = continue
clearPrompt :: AppM (Next GameState) clearPrompt :: AppM (Next GameState)
@ -361,6 +370,18 @@ prompt_
-> AppM () -> AppM ()
prompt_ msg = prompt msg $ object [] 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). menu :: forall (a :: Type) (params :: Type).
(ToJSON params) (ToJSON params)
=> [Text] -- ^ Message key => [Text] -- ^ Message key

View file

@ -69,6 +69,7 @@ instance NFData (SPromptType pt) where
class SingPromptType pt where singPromptType :: SPromptType pt class SingPromptType pt where singPromptType :: SPromptType pt
instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt
instance SingPromptType 'Confirm where singPromptType = SConfirm
instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt
instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap instance SingPromptType 'PointOnMap where singPromptType = SPointOnMap
instance SingPromptType 'Continue where singPromptType = SContinue instance SingPromptType 'Continue where singPromptType = SContinue

View file

@ -12,6 +12,9 @@ save:
location: location:
"Enter filename to save to: " "Enter filename to save to: "
quit:
confirm: Really quit without saving?
entities: entities:
description: You see here {{entityDescriptions}} description: You see here {{entityDescriptions}}