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 <grfn@gws.fyi> Tested-by: BuildkiteCI
This commit is contained in:
parent
099f36e5ee
commit
ff6c008d78
8 changed files with 93 additions and 31 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -43,6 +43,7 @@ instance Arbitrary GameState where
|
|||
_debugState <- arbitrary
|
||||
let _autocommand = NoAutocommand
|
||||
_memo <- arbitrary
|
||||
_savefile <- arbitrary
|
||||
pure $ GameState {..}
|
||||
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -65,6 +65,7 @@ initialStateFromSeed seed =
|
|||
_debugState = DebugState
|
||||
{ _allRevealed = False
|
||||
}
|
||||
_savefile = Nothing
|
||||
_autocommand = NoAutocommand
|
||||
_memo = emptyMemoState
|
||||
in GameState {..}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue