feat(gs/xanthous): Default to the current save file r/3008

When saving, default to the save file that was loaded for the game if
any. To support this, this also makes text prompts support a default,
which will be used if no value is input.

Change-Id: I72a826499d6e987b939e3465a2d29167e53416be
Reviewed-on: https://cl.tvl.fyi/c/depot/+/3801
Reviewed-by: grfn <grfn@gws.fyi>
Tested-by: BuildkiteCI

8 files changed, 93 insertions, 31 deletions

diff --git a/users/grfn/xanthous/app/Main.hs b/users/grfn/xanthous/app/Main.hs
index 6d88405fd9..e67ad4ac99 100644
--- a/users/grfn/xanthous/app/Main.hs
+++ b/users/grfn/xanthous/app/Main.hs
@@ -113,9 +113,9 @@ newGame rparams = do
 
 loadGame :: FilePath -> IO ()
 loadGame saveFile = do
-  gameState <- maybe (die "Invalid save file!") pure
-              =<< Game.loadGame . fromStrict <$> readFile @IO saveFile
-  gameState `deepseq` runGame LoadGame gameState
+  gameState <- maybe (die "Invalid save file!") pure . Game.loadGame  . fromStrict
+              =<< readFile @IO saveFile
+  gameState `deepseq` runGame (LoadGame saveFile) gameState
 
 runGame :: RunType -> Game.GameState -> IO ()
 runGame rt gameState = do
diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs
index bb6d6cf4dd..369f6ae2ff 100644
--- a/users/grfn/xanthous/src/Xanthous/App.hs
+++ b/users/grfn/xanthous/src/Xanthous/App.hs
@@ -73,7 +73,7 @@ import qualified Xanthous.Generators.Level.Dungeon as Dungeon
 
 type App = Brick.App GameState AppEvent ResourceName
 
-data RunType = NewGame | LoadGame
+data RunType = NewGame | LoadGame FilePath
   deriving stock (Eq)
 
 makeApp :: GameEnv -> RunType -> IO App
@@ -83,7 +83,7 @@ makeApp env rt = pure $ Brick.App
   , appHandleEvent = \game event -> runAppM (handleEvent event) env game
   , appStartEvent = case rt of
       NewGame -> runAppM (startEvent >> get) env
-      LoadGame -> pure
+      LoadGame save -> pure . (savefile ?~ save)
   , appAttrMap = const $ attrMap defAttr []
   }
 
@@ -334,15 +334,24 @@ handleCommand Fire = do
 
 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
+  use savefile >>= \case
+    Just filepath ->
+      stringPromptWithDefault_
+        ["save", "location"]
+        Cancellable
+        (pack filepath)
+        promptCallback
+    Nothing -> prompt_ @'StringPrompt ["save", "location"] Cancellable promptCallback
   continue
   where
+    promptCallback :: PromptResult 'StringPrompt -> AppM ()
+    promptCallback (StringResult filename) = do
+      sf <- use savefile
+      exists <- liftIO . doesFileExist $ unpack filename
+      if exists && sf /= Just (unpack filename)
+      then confirm ["save", "overwrite"] (object ["filename" A..= filename])
+          $ doSave filename
+      else doSave filename
     doSave filename = do
       src <- gets saveGame
       lift . liftIO $ do
diff --git a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
index 911f869612..0397e590e7 100644
--- a/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
+++ b/users/grfn/xanthous/src/Xanthous/App/Prompt.hs
@@ -5,6 +5,8 @@ module Xanthous.App.Prompt
   , clearPrompt
   , prompt
   , prompt_
+  , stringPromptWithDefault
+  , stringPromptWithDefault_
   , confirm_
   , confirm
   , menu
@@ -123,7 +125,7 @@ prompt msgPath params cancellable cb = do
     SPointOnMap -> do
       charPos <- use characterPosition
       pure . Just $ mkPointOnMapPrompt cancellable charPos cb
-    SStringPrompt -> pure . Just $ mkPrompt cancellable pt cb
+    SStringPrompt -> pure . Just $ mkStringPrompt cancellable cb
     SConfirm -> pure . Just $ mkPrompt cancellable pt cb
     SDirectionPrompt -> pure . Just $ mkPrompt cancellable pt cb
     SContinue -> pure . Just $ mkPrompt cancellable pt cb
@@ -138,6 +140,27 @@ prompt_
   -> AppM ()
 prompt_ msg = prompt msg $ object []
 
+stringPromptWithDefault
+  :: forall (params :: Type). (ToJSON params)
+  => [Text]                                -- ^ Message key
+  -> params                                -- ^ Message params
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault msgPath params cancellable def cb = do
+  msg <- Messages.message msgPath params
+  let p = mkStringPromptWithDefault cancellable def cb
+  promptState .= WaitingPrompt msg p
+
+stringPromptWithDefault_
+  :: [Text]                                -- ^ Message key
+  -> PromptCancellable
+  -> Text                                  -- ^ Prompt default
+  -> (PromptResult 'StringPrompt -> AppM ()) -- ^ Prompt promise handler
+  -> AppM ()
+stringPromptWithDefault_ msg = stringPromptWithDefault msg $ object []
+
 confirm
   :: ToJSON params
   => [Text] -- ^ Message key
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
index bb9b64b0b3..679bfe5459 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs
@@ -43,6 +43,7 @@ instance Arbitrary GameState where
     _debugState <- arbitrary
     let _autocommand = NoAutocommand
     _memo <- arbitrary
+    _savefile <- arbitrary
     pure $ GameState {..}
 
 
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
index 25b1b92e21..b9590ba404 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/Draw.hs
@@ -43,8 +43,12 @@ drawPromptState :: GamePromptState m -> Widget ResourceName
 drawPromptState NoPrompt = emptyWidget
 drawPromptState (WaitingPrompt msg (Prompt _ pt ps pri _)) =
   case (pt, ps, pri) of
-    (SStringPrompt, StringPromptState edit, _) ->
-      txtWrap msg <+> txt " " <+> renderEditor (txt . fold) True edit
+    (SStringPrompt, StringPromptState edit, mDef) ->
+      txtWrap msg
+      <+> txt " "
+      <+> txt (maybe "" (\def -> "(default: " <> def <> ")") mDef)
+      <+> txt " "
+      <+> renderEditor (txt . fold) True edit
     (SDirectionPrompt, DirectionPromptState, _) -> txtWrap msg
     (SMenu, _, menuItems) ->
       txtWrap msg
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
index fd60e3637c..c692a3b479 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/Lenses.hs
@@ -65,6 +65,7 @@ initialStateFromSeed seed =
       _debugState = DebugState
         { _allRevealed = False
         }
+      _savefile = Nothing
       _autocommand = NoAutocommand
       _memo = emptyMemoState
   in GameState {..}
diff --git a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
index 0674d853be..2d6c0a280f 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/Prompt.hs
@@ -16,6 +16,8 @@ module Xanthous.Game.Prompt
   , PromptInput
   , Prompt(..)
   , mkPrompt
+  , mkStringPrompt
+  , mkStringPromptWithDefault
   , mkMenu
   , mkPointOnMapPrompt
   , mkFirePrompt
@@ -215,9 +217,10 @@ instance Show (MenuOption a) where
   show (MenuOption m _) = show m
 
 type family PromptInput (pt :: PromptType) :: Type where
-  PromptInput ('Menu a)   = Map Char (MenuOption a)
-  PromptInput 'PointOnMap = Position -- Character pos
-  PromptInput 'Fire       = (Position, Tiles) -- Nearest enemy, range
+  PromptInput ('Menu a)     = Map Char (MenuOption a)
+  PromptInput 'PointOnMap   = Position -- Character pos
+  PromptInput 'Fire         = (Position, Tiles) -- Nearest enemy, range
+  PromptInput 'StringPrompt = Maybe Text -- Default value
   PromptInput _ = ()
 
 data Prompt (m :: Type -> Type) where
@@ -286,13 +289,27 @@ mkPrompt
   -> SPromptType pt          -- ^ The type of the prompt
   -> (PromptResult pt -> m ()) -- ^ Function to call when the prompt is complete
   -> Prompt m
-mkPrompt c pt@SStringPrompt cb =
-  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
-  in Prompt c pt ps () cb
 mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState () cb
 mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState () cb
 mkPrompt c pt@SConfirm cb = Prompt c pt ConfirmPromptState () cb
 
+mkStringPrompt
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPrompt c =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps Nothing
+
+mkStringPromptWithDefault
+  :: PromptCancellable                  -- ^ Is the prompt cancellable or not?
+  -> Text                               -- ^ Default value for the prompt
+  -> (PromptResult 'StringPrompt -> m ()) -- ^ Function to call when the prompt is complete
+  -> Prompt m
+mkStringPromptWithDefault c def =
+  let ps = StringPromptState $ editorText Resource.Prompt (Just 1) ""
+  in Prompt c SStringPrompt ps (Just def)
+
 mkMenu
   :: forall a m.
     PromptCancellable
@@ -321,19 +338,22 @@ isCancellable (Prompt Cancellable _ _ _ _)   = True
 isCancellable (Prompt Uncancellable _ _ _ _) = False
 
 submitPrompt :: Applicative m => Prompt m -> m ()
-submitPrompt (Prompt _ pt ps _ cb) =
-  case (pt, ps) of
-    (SStringPrompt, StringPromptState edit) ->
-      cb . StringResult . mconcat . getEditContents $ edit
-    (SDirectionPrompt, DirectionPromptState) ->
+submitPrompt (Prompt _ pt ps pri cb) =
+  case (pt, ps, pri) of
+    (SStringPrompt, StringPromptState edit, mDef) ->
+      let inputVal = mconcat . getEditContents $ edit
+          val | null inputVal, Just def <- mDef = def
+              | otherwise = inputVal
+      in cb $ StringResult val
+    (SDirectionPrompt, DirectionPromptState, _) ->
       pure () -- Don't use submit with a direction prompt
-    (SContinue, ContinuePromptState) ->
+    (SContinue, ContinuePromptState, _) ->
       cb ContinueResult
-    (SMenu, MenuPromptState) ->
+    (SMenu, MenuPromptState, _) ->
       pure () -- Don't use submit with a menu prompt
-    (SPointOnMap, PointOnMapPromptState pos) ->
+    (SPointOnMap, PointOnMapPromptState pos, _) ->
       cb $ PointOnMapResult pos
-    (SConfirm, ConfirmPromptState) ->
+    (SConfirm, ConfirmPromptState, _) ->
       cb $ ConfirmResult True
-    (SFire, FirePromptState pos) ->
+    (SFire, FirePromptState pos, _) ->
       cb $ FireResult pos
diff --git a/users/grfn/xanthous/src/Xanthous/Game/State.hs b/users/grfn/xanthous/src/Xanthous/Game/State.hs
index 10883ce06e..3025eb15be 100644
--- a/users/grfn/xanthous/src/Xanthous/Game/State.hs
+++ b/users/grfn/xanthous/src/Xanthous/Game/State.hs
@@ -16,6 +16,7 @@ module Xanthous.Game.State
   , promptState
   , characterEntityID
   , autocommand
+  , savefile
   , memo
   , GamePromptState(..)
 
@@ -512,6 +513,9 @@ data GameState = GameState
   , _debugState        :: !DebugState
   , _autocommand       :: !AutocommandState
 
+  -- | The path to the savefile that was loaded for this game, if any
+  , _savefile          :: !(Maybe FilePath)
+
   , _memo              :: MemoState
   }
   deriving stock (Show, Generic)