From ffc8e793d5ca8a73f8a6ec0f0a4f2efb2c98cf93 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Tue, 31 Dec 2019 11:09:18 -0500
Subject: Prompt before overwriting files when saving

When saving the game to a file that already exists, prompt for whether
or not to overwrite the file.

Since this was the first instance of a prompt triggered by another
prompt, this also had to do a minor fix to swap the order of completing
the prompt and clearing it, so that we don't submit the prompt and then
immediately clear it.
---
 package.yaml               |  1 +
 src/Xanthous/App.hs        | 29 ++++++++++++++++++-----------
 src/Xanthous/messages.yaml |  4 ++--
 xanthous.cabal             |  5 ++++-
 4 files changed, 25 insertions(+), 14 deletions(-)

diff --git a/package.yaml b/package.yaml
index 32a402f3fd..8d761b58e0 100644
--- a/package.yaml
+++ b/package.yaml
@@ -30,6 +30,7 @@ dependencies:
 - containers
 - data-default
 - deepseq
+- directory
 - fgl
 - fgl-arbitrary
 - file-embed
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 5fb70bd075..808654e1ab 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -16,6 +16,7 @@ import           Data.Aeson (object, ToJSON)
 import qualified Data.Aeson as A
 import qualified Data.Vector as V
 import           System.Exit
+import           System.Directory (doesFileExist)
 import           GHC.TypeLits (TypeError, ErrorMessage(..))
 --------------------------------------------------------------------------------
 import           Xanthous.Command
@@ -257,13 +258,19 @@ handleCommand Save = do
   -- TODO default save locations / config file?
   prompt_ @'StringPrompt ["save", "location"] Cancellable
     $ \(StringResult filename) -> do
+       exists <- liftIO . doesFileExist $ unpack filename
+       if exists
+       then confirm ["save", "overwrite"] (object ["filename" A..= filename])
+            $ doSave filename
+       else doSave filename
+  continue
+  where
+    doSave filename = do
       src <- gets saveGame
       lift . liftIO $ do
         writeFile (unpack filename) $ toStrict src
         exitSuccess
 
-  continue
-
 
 handleCommand ToggleRevealAll = do
   val <- debugState . allRevealed <%= not
@@ -279,15 +286,15 @@ handlePromptEvent
   -> AppM (Next GameState)
 
 handlePromptEvent _ (Prompt Cancellable _ _ _ _) (VtyEvent (EvKey KEsc []))
-  = clearPrompt
+  = clearPrompt >> continue
 handlePromptEvent _ pr (VtyEvent (EvKey KEnter []))
-  = submitPrompt pr >> clearPrompt
+  = clearPrompt >> submitPrompt pr >> continue
 
 handlePromptEvent _ pr@(Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'y') []))
-  = submitPrompt pr >> clearPrompt
+  = clearPrompt >> submitPrompt pr >> continue
 
 handlePromptEvent _ (Prompt _ SConfirm _ _ _) (VtyEvent (EvKey (KChar 'n') []))
-  = clearPrompt
+  = clearPrompt >> continue
 
 handlePromptEvent
   msg
@@ -301,12 +308,12 @@ handlePromptEvent
 
 handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ cb)
   (VtyEvent (EvKey (KChar (directionFromChar -> Just dir)) []))
-  = cb (DirectionResult dir) >> clearPrompt
+  = clearPrompt >> cb (DirectionResult dir) >> continue
 handlePromptEvent _ (Prompt _ SDirectionPrompt _ _ _) _ = continue
 
 handlePromptEvent _ (Prompt _ SMenu _ items' cb) (VtyEvent (EvKey (KChar chr) []))
   | Just (MenuOption _ res) <- items' ^. at chr
-  = cb (MenuResult res) >> clearPrompt
+  = clearPrompt >> cb (MenuResult res) >> continue
   | otherwise
   = continue
 
@@ -324,11 +331,11 @@ handlePromptEvent
   _
   (Prompt Cancellable _ _ _ _)
   (VtyEvent (EvKey (KChar 'q') []))
-  = clearPrompt
+  = clearPrompt >> continue
 handlePromptEvent _ _ _ = continue
 
-clearPrompt :: AppM (Next GameState)
-clearPrompt = promptState .= NoPrompt >> continue
+clearPrompt :: AppM ()
+clearPrompt = promptState .= NoPrompt
 
 class NotMenu (pt :: PromptType)
 instance NotMenu 'StringPrompt
diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml
index 408cb6a1a5..1a4159b0ac 100644
--- a/src/Xanthous/messages.yaml
+++ b/src/Xanthous/messages.yaml
@@ -9,8 +9,8 @@ generic:
   continue: Press enter to continue...
 
 save:
-  location:
-    "Enter filename to save to: "
+  location: "Enter filename to save to: "
+  overwrite: "A file named {{filename}} already exists. Would you like to overwrite it? "
 
 quit:
   confirm: Really quit without saving?
diff --git a/xanthous.cabal b/xanthous.cabal
index 23044d7fce..f173b1a114 100644
--- a/xanthous.cabal
+++ b/xanthous.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 497414a98a626a63a6c5022688b33d0021c1580c7c262fbc1152599289df7935
+-- hash: a4f6c2c91e3c94c81de5d6b27201cb22e7f9f9c5d8a4f14beec63c1540d01ca1
 
 name:           xanthous
 version:        0.1.0.0
@@ -92,6 +92,7 @@ library
     , containers
     , data-default
     , deepseq
+    , directory
     , fgl
     , fgl-arbitrary
     , file-embed
@@ -191,6 +192,7 @@ executable xanthous
     , containers
     , data-default
     , deepseq
+    , directory
     , fgl
     , fgl-arbitrary
     , file-embed
@@ -265,6 +267,7 @@ test-suite test
     , containers
     , data-default
     , deepseq
+    , directory
     , fgl
     , fgl-arbitrary
     , file-embed
-- 
cgit 1.4.1