Scenario launch configuration dialog

Towards #358

src/Swarm/Game/Scenario/Status.hs

@@ -22,14 +22,39 @@ import Swarm.Game.Scenario.Scoring.Best
 import Swarm.Game.Scenario.Scoring.CodeSize
 import Swarm.Game.Scenario.Scoring.ConcreteMetrics
 import Swarm.Game.Scenario.Scoring.GenericMetrics
+import Swarm.Game.WorldGen (Seed)
 import Swarm.Util.Lens (makeLensesNoSigs)
 
+-- | These launch parameters are used in a number of ways:
+-- * Serializing the seed/script path for saves
+-- * Holding parse status from form fields, including Error info
+-- * Carrying fully-validated launch parameters.
+--
+-- Type parameters are utilized to support all of these use cases.
+data ParameterizableLaunchParams b a = LaunchParms
+  { seedVal :: a (Maybe Seed)
+  , initialCode :: a (Maybe b)
+  }
+
+type SerializableLaunchParms = ParameterizableLaunchParams FilePath Identity
+deriving instance Eq SerializableLaunchParms
+deriving instance Ord SerializableLaunchParms
+deriving instance Show SerializableLaunchParms
+deriving instance Read SerializableLaunchParms
+deriving instance Generic SerializableLaunchParms
+deriving instance FromJSON SerializableLaunchParms
+deriving instance ToJSON SerializableLaunchParms
+
 -- | A "ScenarioStatus" stores the status of a scenario along with
 --   appropriate metadata: "NotStarted", or "Played".
 --   The "Played" status has two sub-states: "Attempted" or "Completed".
 data ScenarioStatus
   = NotStarted
-  | Played ProgressMetric BestRecords
+  | Played
+      SerializableLaunchParms
+      -- ^ initial seed and script to run
+      ProgressMetric
+      BestRecords
   deriving (Eq, Ord, Show, Read, Generic)
 
 instance FromJSON ScenarioStatus where
@@ -39,6 +64,11 @@ instance ToJSON ScenarioStatus where
   toEncoding = genericToEncoding scenarioOptions
   toJSON = genericToJSON scenarioOptions
 
+getLaunchParams :: ScenarioStatus -> SerializableLaunchParms
+getLaunchParams = \case
+  NotStarted -> LaunchParms (pure Nothing) (pure Nothing)
+  Played x _ _ -> x
+
 -- | A "ScenarioInfo" record stores metadata about a scenario: its
 -- canonical path and status.
 -- By way of the "ScenarioStatus" record, it stores the
@@ -84,9 +114,9 @@ updateScenarioInfoOnFinish
   ticks
   completed
   si@(ScenarioInfo p prevPlayState) = case prevPlayState of
-    Played (Metric _ (ProgressStats start _currentPlayMetrics)) prevBestRecords ->
+    Played initialScript (Metric _ (ProgressStats start _currentPlayMetrics)) prevBestRecords ->
       ScenarioInfo p $
-        Played newPlayMetric $
+        Played initialScript newPlayMetric $
           updateBest newPlayMetric prevBestRecords
      where
       el = (diffUTCTime `on` zonedTimeToUTC) z start

src/Swarm/Game/State.hs

@@ -88,6 +88,7 @@ module Swarm.Game.State (
   CodeToRun (..),
   Sha1 (..),
   SolutionSource (..),
+  parseCodeFile,
   getParsedInitialCode,
 
   -- * Utilities
@@ -112,6 +113,7 @@ module Swarm.Game.State (
   toggleRunStatus,
   messageIsRecent,
   messageIsFromNearby,
+  getRunCodePath,
 ) where
 
 import Control.Algebra (Has)
@@ -277,29 +279,33 @@ data SolutionSource
   | -- | Includes the SHA1 of the program text
     -- for the purpose of corroborating solutions
     -- on a leaderboard.
-    PlayerAuthored Sha1
+    PlayerAuthored FilePath Sha1
 
 data CodeToRun = CodeToRun SolutionSource ProcessedTerm
 
-getParsedInitialCode :: Maybe FilePath -> ExceptT Text IO (Maybe CodeToRun)
-getParsedInitialCode toRun = case toRun of
-  Nothing -> return Nothing
-  Just filepath -> do
-    contents <- liftIO $ TIO.readFile filepath
+getRunCodePath :: CodeToRun -> Maybe FilePath
+getRunCodePath (CodeToRun solutionSource _) = case solutionSource of
+  ScenarioSuggested -> Nothing
+  PlayerAuthored fp _ -> Just fp
+
+parseCodeFile :: FilePath -> IO (Either Text CodeToRun)
+parseCodeFile filepath = do
+  contents <- TIO.readFile filepath
+  return $ do
     pt@(ProcessedTerm (Module (Syntax' srcLoc _ _) _) _ _) <-
-      ExceptT
-        . return
-        . left T.pack
-        $ processTermEither contents
+      left T.pack $ processTermEither contents
     let strippedText = stripSrc srcLoc contents
         programBytestring = TL.encodeUtf8 $ TL.fromStrict strippedText
         sha1Hash = showDigest $ sha1 programBytestring
-    return $ Just $ CodeToRun (PlayerAuthored $ Sha1 sha1Hash) pt
+    return $ CodeToRun (PlayerAuthored filepath $ Sha1 sha1Hash) pt
  where
   stripSrc :: SrcLoc -> Text -> Text
   stripSrc (SrcLoc start end) txt = T.drop start $ T.take end txt
   stripSrc NoLoc txt = txt
 
+getParsedInitialCode :: Maybe FilePath -> ExceptT Text IO (Maybe CodeToRun)
+getParsedInitialCode = traverse $ ExceptT . parseCodeFile
+
 ------------------------------------------------------------
 -- The main GameState record type
 ------------------------------------------------------------

src/Swarm/TUI/Attr.hs

@@ -44,11 +44,13 @@ module Swarm.TUI.Attr (
   greenAttr,
   redAttr,
   defAttr,
+  customEditFocusedAttr,
 ) where
 
 import Brick
 import Brick.Forms
 import Brick.Widgets.Dialog
+import Brick.Widgets.Edit qualified as E
 import Brick.Widgets.List
 import Data.Bifunctor (bimap)
 import Data.Text (unpack)
@@ -77,6 +79,7 @@ swarmAttrMap =
            (highlightAttr, fg V.cyan)
          , (invalidFormInputAttr, fg V.red)
          , (focusedFormInputAttr, V.defAttr)
+         , (customEditFocusedAttr, V.black `on` V.yellow)
          , (listSelectedFocusedAttr, bg V.blue)
          , (infoAttr, fg (V.rgbColor @Int 50 50 50))
          , (buttonSelectedAttr, bg V.blue)
@@ -168,6 +171,9 @@ boldAttr = attrName "bold"
 dimAttr = attrName "dim"
 defAttr = attrName "def"
 
+customEditFocusedAttr :: AttrName
+customEditFocusedAttr = attrName "custom" <> E.editFocusedAttr
+
 -- | Some basic colors used in TUI.
 redAttr, greenAttr, blueAttr, yellowAttr, cyanAttr, lightCyanAttr, magentaAttr :: AttrName
 redAttr = attrName "red"

src/Swarm/TUI/Controller.hs

@@ -93,6 +93,9 @@ import Swarm.Language.Types
 import Swarm.Language.Value (Value (VKey, VUnit), prettyValue, stripVResult)
 import Swarm.TUI.Controller.Util
 import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)
+import Swarm.TUI.Launch.Controller
+import Swarm.TUI.Launch.Model
+import Swarm.TUI.Launch.Prep (prepareLaunchDialog)
 import Swarm.TUI.List
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal
@@ -133,7 +136,12 @@ handleEvent = \case
           -- quitGame function would have already halted the app).
           NoMenu -> const halt
           MainMenu l -> handleMainMenuEvent l
-          NewGameMenu l -> handleNewGameMenuEvent l
+          NewGameMenu l ->
+            if s ^. uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed
+              then handleFBEvent
+              else case s ^. uiState . uiLaunchConfig . controls . isDisplayedFor of
+                Nothing -> handleNewGameMenuEvent l
+                Just siPair -> handleLaunchOptionsEvent siPair
           MessagesMenu -> handleMainMessagesEvent
           AchievementsMenu l -> handleMainAchievementsEvent l
           AboutMenu -> pressAnyKey (MainMenu (mainMenu About))
@@ -222,7 +230,10 @@ handleMainMessagesEvent = \case
  where
   returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages)
 
-handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> EventM Name AppState ()
+handleNewGameMenuEvent ::
+  NonEmpty (BL.List Name ScenarioItem) ->
+  BrickEvent Name AppEvent ->
+  EventM Name AppState ()
 handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case
   Key V.KEnter ->
     case snd <$> BL.listSelectedElement curMenu of
@@ -231,13 +242,19 @@ handleNewGameMenuEvent scenarioStack@(curMenu :| rest) = \case
       Just (SICollection _ c) -> do
         cheat <- use $ uiState . uiCheatMode
         uiState . uiMenu .= NewGameMenu (NE.cons (mkScenarioList cheat c) scenarioStack)
+  CharKey 'o' -> showLaunchDialog
+  CharKey 'O' -> showLaunchDialog
   Key V.KEsc -> exitNewGameMenu scenarioStack
   CharKey 'q' -> exitNewGameMenu scenarioStack
   ControlChar 'q' -> halt
   VtyEvent ev -> do
     menu' <- nestEventM' curMenu (handleListEvent ev)
     uiState . uiMenu .= NewGameMenu (menu' :| rest)
   _ -> continueWithoutRedraw
+ where
+  showLaunchDialog = case snd <$> BL.listSelectedElement curMenu of
+    Just (SISingle siPair) -> Brick.zoom (uiState . uiLaunchConfig) $ prepareLaunchDialog siPair
+    _ -> continueWithoutRedraw
 
 exitNewGameMenu :: NonEmpty (BL.List Name ScenarioItem) -> EventM Name AppState ()
 exitNewGameMenu stk = do
@@ -460,7 +477,7 @@ getNormalizedCurrentScenarioPath =
 
 saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo)
 saveScenarioInfoOnFinish p = do
-  initialCode <- use $ gameState . initiallyRunCode
+  initialRunCode <- use $ gameState . initiallyRunCode
   t <- liftIO getZonedTime
   wc <- use $ gameState . winCondition
   let won = case wc of
@@ -475,7 +492,7 @@ saveScenarioInfoOnFinish p = do
       currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2
 
   replHist <- use $ uiState . uiREPL . replHistory
-  let determinator = CodeSizeDeterminators initialCode $ replHist ^. replHasExecutedManualInput
+  let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput
   currentScenarioInfo
     %= updateScenarioInfoOnFinish determinator t ts won
   status <- preuse currentScenarioInfo

src/Swarm/TUI/Launch/Controller.hs

@@ -0,0 +1,155 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Event handling for the scenario launch configuration dialog.
+module Swarm.TUI.Launch.Controller where
+
+import Brick hiding (Direction, Location)
+import Brick.Focus
+import Brick.Widgets.Edit (handleEditorEvent)
+import Brick.Widgets.FileBrowser
+import Brick.Widgets.FileBrowser qualified as FB
+import Control.Lens
+import Control.Monad.Except (forM_, liftIO, when)
+import Data.Maybe (listToMaybe)
+import Graphics.Vty qualified as V
+import Swarm.Game.ScenarioInfo
+import Swarm.TUI.Controller.Util
+import Swarm.TUI.Launch.Model
+import Swarm.TUI.Launch.Prep (initFileBrowserWidget, makeFocusRingWith, parseWidgetParms, toValidatedParms)
+import Swarm.TUI.Model
+import Swarm.TUI.Model.Name
+import Swarm.TUI.Model.StateUpdate
+import Swarm.TUI.Model.UI
+import Swarm.Util (listEnums)
+
+cacheValidatedInputs :: EventM Name AppState ()
+cacheValidatedInputs = do
+  launchControls <- use $ uiState . uiLaunchConfig . controls
+  parsedParams <- liftIO $ parseWidgetParms launchControls
+  uiState . uiLaunchConfig . editingParams .= parsedParams
+
+  currentRing <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing
+
+  let eitherLaunchParams = toValidatedParms parsedParams
+      modifyRingMembers = case eitherLaunchParams of
+        Left _ -> filter (/= StartGameButton)
+        Right _ -> id
+      maybeCurrentFocus = focusGetCurrent currentRing
+      refocusRing = maybe id focusSetCurrent maybeCurrentFocus
+
+  uiState . uiLaunchConfig . controls . scenarioConfigFocusRing .= refocusRing (makeFocusRingWith $ modifyRingMembers listEnums)
+
+-- | If the FileBrowser is in "search mode", then we allow
+-- more of the key events to pass through. Otherwise,
+-- we intercept things like "q" (for quit) and Space (so that
+-- we can restrict file selection to at most one).
+handleFBEvent ::
+  BrickEvent Name AppEvent ->
+  EventM Name AppState ()
+handleFBEvent ev = do
+  fb <- use $ uiState . uiLaunchConfig . controls . fileBrowser . fbWidget
+  let isSearching = fileBrowserIsSearching fb
+  case (isSearching, ev) of
+    (False, Key V.KEsc) -> closeModal
+    (False, CharKey 'q') -> closeModal
+    (False, ControlChar 'q') -> closeModal
+    -- Intercept the "space" key so that it cannot be used to select files
+    -- (see note below).
+    (False, CharKey ' ') -> return ()
+    (_, VtyEvent e) -> do
+      (shouldClose, maybeSingleFile) <- Brick.zoom (uiState . uiLaunchConfig . controls . fileBrowser . fbWidget) $ do
+        handleFileBrowserEvent e
+        -- If the browser has a selected file after handling the
+        -- event (because the user pressed Enter), close the dialog.
+        case e of
+          V.EvKey V.KEnter [] -> do
+            b' <- get
+            case FB.fileBrowserSelection b' of
+              [] -> return (False, Nothing)
+              -- We only allow one file to be selected
+              -- by closing immediately.
+              -- This is a hack illustrated in the Brick FileBrowser demo:
+              -- https://github.com/jtdaugherty/brick/blob/4b40476d5d58c40720170d21503c11596bc9ee39/programs/FileBrowserDemo.hs#L68-L69
+              -- It is not foolproof on its own, so we also intercept
+              -- the "Space" key above.
+              xs -> return (True, FB.fileInfoFilePath <$> listToMaybe xs)
+          -- NOTE: The "Space" key also selects a file.
+          -- Apparently, even when directories are specified as
+          -- non-selectable via "FB.selectNonDirectories", the internal state
+          -- of the FileBrowser dialog
+          -- briefly adds a directory to its "fileBrowserSelection" list
+          -- when the "space" key is pressed.
+          -- So it is not enough to simply check whether the selection list
+          -- is nonempty after *any* keypress; we specifically have to listen for "Enter".
+          --
+          -- WARNING: There is still a bug when one presses the "space" key to mark
+          -- a directory, then presses "Enter" right afterward.
+          -- The directory will get selected, and then swarm will crash.
+          -- This is why we prevent the Space key from being handled by the FileBrowser
+          -- unless we are in file searching mode.
+          _ -> return (False, Nothing)
+
+      when shouldClose $ do
+        uiState . uiLaunchConfig . controls . fileBrowser . maybeSelectedFile .= maybeSingleFile
+        closeModal
+    _ -> return ()
+ where
+  closeModal = do
+    uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed .= False
+    cacheValidatedInputs
+
+handleLaunchOptionsEvent ::
+  ScenarioInfoPair ->
+  BrickEvent Name AppEvent ->
+  EventM Name AppState ()
+handleLaunchOptionsEvent siPair = \case
+  Key V.KBackTab ->
+    uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev
+  Key V.KUp ->
+    uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusPrev
+  CharKey '\t' ->
+    uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext
+  Key V.KDown ->
+    uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusNext
+  MouseDown n _ _ _ ->
+    case n of
+      ScenarioConfigControl (ScenarioConfigPanelControl x) -> do
+        uiState . uiLaunchConfig . controls . scenarioConfigFocusRing %= focusSetCurrent n
+        activateFocusedControl x
+      _ -> return ()
+  CharKey ' ' -> activateControl
+  Key V.KEnter -> activateControl
+  Key V.KEsc -> closeModal
+  CharKey 'q' -> closeModal
+  ControlChar 'q' -> closeModal
+  ev -> do
+    fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing
+    case focusGetCurrent fr of
+      Just (ScenarioConfigControl (ScenarioConfigPanelControl SeedSelector)) -> do
+        Brick.zoom (uiState . uiLaunchConfig . controls . seedValueEditor) (handleEditorEvent ev)
+        cacheValidatedInputs
+      _ -> return ()
+ where
+  activateControl = do
+    fr <- use $ uiState . uiLaunchConfig . controls . scenarioConfigFocusRing
+    case focusGetCurrent fr of
+      Just (ScenarioConfigControl (ScenarioConfigPanelControl item)) ->
+        activateFocusedControl item
+      _ -> return ()
+
+  activateFocusedControl item = case item of
+    SeedSelector -> return ()
+    ScriptSelector -> do
+      maybeSingleFile <- use $ uiState . uiLaunchConfig . controls . fileBrowser . maybeSelectedFile
+      configuredFB <- initFileBrowserWidget maybeSingleFile
+      uiState . uiLaunchConfig . controls . fileBrowser . fbWidget .= configuredFB
+      uiState . uiLaunchConfig . controls . fileBrowser . fbIsDisplayed .= True
+    StartGameButton -> do
+      params <- use $ uiState . uiLaunchConfig . editingParams
+      let eitherLaunchParams = toValidatedParms params
+      forM_ eitherLaunchParams $ \launchParams -> do
+        closeModal
+        startGameWithSeed siPair launchParams
+
+  closeModal = uiState . uiLaunchConfig . controls . isDisplayedFor .= Nothing