Confirm before quitting
Prompt to confirm before quitting the game with the Quit command
This commit is contained in:
		
							parent
							
								
									f701a0be40
								
							
						
					
					
						commit
						a58966d43f
					
				
					 3 changed files with 28 additions and 3 deletions
				
			
		|  | @ -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 | ||||||
|  |  | ||||||
|  | @ -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 | ||||||
|  |  | ||||||
|  | @ -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}} | ||||||
| 
 | 
 | ||||||
|  |  | ||||||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue