From ff6c008d7884975f3dc0295a75b9383fd2c3a2ed Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 6 Nov 2021 11:44:14 -0400 Subject: feat(gs/xanthous): Default to the current save file 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 Tested-by: BuildkiteCI --- users/grfn/xanthous/src/Xanthous/App.hs | 27 +++++++---- users/grfn/xanthous/src/Xanthous/App/Prompt.hs | 25 ++++++++++- users/grfn/xanthous/src/Xanthous/Game/Arbitrary.hs | 1 + users/grfn/xanthous/src/Xanthous/Game/Draw.hs | 8 +++- users/grfn/xanthous/src/Xanthous/Game/Lenses.hs | 1 + users/grfn/xanthous/src/Xanthous/Game/Prompt.hs | 52 +++++++++++++++------- users/grfn/xanthous/src/Xanthous/Game/State.hs | 4 ++ 7 files changed, 90 insertions(+), 28 deletions(-) (limited to 'users/grfn/xanthous/src') diff --git a/users/grfn/xanthous/src/Xanthous/App.hs b/users/grfn/xanthous/src/Xanthous/App.hs index bb6d6cf4ddda..369f6ae2ff9e 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 911f8696123a..0397e590e760 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 bb9b64b0b303..679bfe54597f 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 25b1b92e215c..b9590ba40438 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 fd60e3637cc9..c692a3b47944 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 0674d853beb7..2d6c0a280f41 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 10883ce06e40..3025eb15be5a 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) -- cgit 1.4.1