From dc5b8dc7e9d82637b778cfc9e2c5d937fdc150db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 23 Jun 2024 21:52:04 +0200 Subject: [PATCH 01/55] Refactor out a few abstract event handlers --- src/swarm-tui/Swarm/TUI/Controller.hs | 129 ++---------------- .../Swarm/TUI/Controller/MainEventHandler.hs | 72 ++++++++++ .../Swarm/TUI/Controller/REPLEventHandler.hs | 56 ++++++++ src/swarm-tui/Swarm/TUI/Controller/Util.hs | 56 +++++++- src/swarm-tui/Swarm/TUI/Model.hs | 35 ++++- src/swarm-tui/Swarm/TUI/Model/Event.hs | 90 ++++++++++++ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 47 ++++++- src/swarm-web/Swarm/Web.hs | 6 +- swarm.cabal | 3 + 9 files changed, 368 insertions(+), 126 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs create mode 100644 src/swarm-tui/Swarm/TUI/Model/Event.hs diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 462e7b1d2..d776ddbdc 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -137,6 +137,8 @@ import System.Clock import System.FilePath (splitDirectories) import Witch (into) import Prelude hiding (Applicative (..)) -- See Note [liftA2 re-export from Prelude] +import Brick.Keybindings qualified as B +import Swarm.TUI.Model.Event (SwarmEvent (..), MainEvent (..), REPLEvent (..)) -- ~~~~ Note [liftA2 re-export from Prelude] -- @@ -311,6 +313,7 @@ handleMainEvent ev = do let isPaused = s ^. gameState . temporal . paused let isCreative = s ^. gameState . creativeMode let hasDebug = hasDebugCapability isCreative s + let keyHandler = s ^. keyEventHandling . keyHandlers . to mainHandler case ev of AppEvent ae -> case ae of Frame @@ -318,12 +321,10 @@ handleMainEvent ev = do | otherwise -> runFrameUI Web (RunWebCode c) -> runBaseWebCode c _ -> continueWithoutRedraw - -- ctrl-q works everywhere - ControlChar 'q' -> - case s ^. gameState . winCondition of - WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal + -- pass to key handler (allows users to configure bindings) + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> do + void $ B.handleKey keyHandler k m VtyEvent (V.EvResize _ _) -> invalidateCache Key V.KEsc | Just m <- s ^. uiState . uiGameplay . uiModal -> do @@ -334,40 +335,6 @@ handleMainEvent ev = do MessagesModal -> do gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks _ -> return () - FKey 1 -> toggleModal HelpModal - FKey 2 -> toggleModal RobotsModal - FKey 3 | not (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) -> do - toggleModal RecipesModal - gameState . discovery . availableRecipes . notificationsCount .= 0 - FKey 4 | not (null (s ^. gameState . discovery . availableCommands . notificationsContent)) -> do - toggleModal CommandsModal - gameState . discovery . availableCommands . notificationsCount .= 0 - FKey 5 | not (null (s ^. gameState . messageNotifications . notificationsContent)) -> do - toggleModal MessagesModal - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - FKey 6 | not (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) -> toggleModal StructuresModal - -- show goal - ControlChar 'g' -> - if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent - then toggleModal GoalModal - else continueWithoutRedraw - -- hide robots - MetaChar 'h' -> do - t <- liftIO $ getTime Monotonic - h <- use $ uiState . uiGameplay . uiHideRobotsUntil - case h >= t of - -- ignore repeated keypresses - True -> continueWithoutRedraw - -- hide for two seconds - False -> do - uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 - invalidateCacheEntry WorldCache - -- debug focused robot - MetaChar 'd' | isPaused && hasDebug -> do - debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not - if debug - then gameState . temporal . gameStep .= RobotStep SBefore - else zoomGameState finishGameTick >> void updateUI -- pausing and stepping ControlChar 'p' | isRunning -> safeTogglePause ControlChar 'o' | isRunning -> do @@ -384,12 +351,11 @@ handleMainEvent ev = do -- pass keys on to modal event handler if a modal is open VtyEvent vev | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev - -- toggle creative mode if in "cheat mode" - MouseDown (TerrainListItem pos) V.BLeft _ _ -> uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos + -- toggle creative mode if in "cheat mode" ControlChar 'v' | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not -- toggle world editor mode if in "cheat mode" @@ -454,36 +420,6 @@ handleMainEvent ev = do InfoPanel -> handleInfoPanelEvent infoScroll ev _ -> continueWithoutRedraw --- | Set the game to Running if it was (auto) paused otherwise to paused. --- --- Also resets the last frame time to now. If we are pausing, it --- doesn't matter; if we are unpausing, this is critical to --- ensure the next frame doesn't think it has to catch up from --- whenever the game was paused! -safeTogglePause :: EventM Name AppState () -safeTogglePause = do - curTime <- liftIO $ getTime Monotonic - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime - uiState . uiGameplay . uiShowDebug .= False - p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus - when (p == Running) $ zoomGameState finishGameTick - --- | Only unpause the game if leaving autopaused modal. --- --- Note that the game could have been paused before opening --- the modal, in that case, leave the game paused. -safeAutoUnpause :: EventM Name AppState () -safeAutoUnpause = do - runs <- use $ gameState . temporal . runStatus - when (runs == AutoPause) safeTogglePause - -toggleModal :: ModalType -> EventM Name AppState () -toggleModal mt = do - modal <- use $ uiState . uiGameplay . uiModal - case modal of - Nothing -> openModal mt - Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause - handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case V.EvKey V.KEnter [] -> do @@ -762,14 +698,6 @@ runFrameTicks dt = do runGameTickUI :: EventM Name AppState () runGameTickUI = runGameTick >> void updateUI --- | Modifies the game state using a fused-effect state action. -zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a -zoomGameState f = do - gs <- use gameState - (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) - gameState .= gs' - return a - updateAchievements :: EventM Name AppState () updateAchievements = do -- Merge the in-game achievements with the master list in UIState @@ -1017,37 +945,13 @@ resetREPL t r replState = handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEvent x = do s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL - controlMode = theRepl ^. replControlMode - uinput = theRepl ^. replPromptText + let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode + let keyHandler = s ^. keyEventHandling . keyHandlers . to replHandler case x of - -- Handle Ctrl-c here so we can always cancel the currently running - -- base program no matter what REPL control mode we are in. - ControlChar 'c' -> do - working <- use $ gameState . gameControls . replWorking - when working $ gameState . baseRobot . machine %= cancel - Brick.zoom (uiState . uiGameplay . uiREPL) $ do - replPromptType .= CmdPrompt [] - replPromptText .= "" - - -- Handle M-p and M-k, shortcuts for toggling pilot + key handler modes. - MetaChar 'p' -> - onlyCreative $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - case curMode of - Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing - _ -> - if T.null uinput - then uiState . uiGameplay . uiREPL . replControlMode .= Piloting - else do - let err = REPLError "Please clear the REPL before engaging pilot mode." - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err - invalidateCacheEntry REPLHistoryCache - MetaChar 'k' -> do - when (isJust (s ^. gameState . gameControls . inputHandler)) $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling - + -- pass to key handler (allows users to configure bindings) + VtyEvent (V.EvKey k m) + | isJust (B.lookupVtyEvent k m keyHandler) -> do + void $ B.handleKey keyHandler k m -- Handle other events in a way appropriate to the current REPL -- control mode. _ -> case controlMode of @@ -1359,11 +1263,6 @@ adjReplHistIndex d s = worldScrollDist :: Int32 worldScrollDist = 8 -onlyCreative :: (MonadState AppState m) => m () -> m () -onlyCreative a = do - c <- use $ gameState . creativeMode - when c a - -- | Handle a user input event in the world view panel. handleWorldEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleWorldEvent = \case diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs new file mode 100644 index 000000000..f1499c1e1 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -0,0 +1,72 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +{-# LANGUAGE OverloadedStrings #-} +module Swarm.TUI.Controller.MainEventHandler ( + mainEventHandlers +) where +import Brick.Keybindings qualified as B +import Swarm.TUI.Model.Event (SwarmEvent (..), MainEvent (..)) +import Brick +import Swarm.TUI.Model +import Control.Lens as Lens +import Control.Monad (unless) +import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) +import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.UI + + +mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] +mainEventHandlers = + [ B.onEvent (Main QuitEvent) "Open quit game dialog" $ do + s <- get + case s ^. gameState . winCondition of + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal + _ -> toggleModal QuitModal + , B.onEvent (Main ViewHelpEvent) "View Help screen" $ toggleModal HelpModal + , B.onEvent (Main ViewRobotsEvent) "View Robots screen" $ toggleModal RobotsModal + , B.onEvent (Main ViewRecipesEvent) "View Recipes screen" $ do + s <- get + unless (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) $ do + toggleModal RecipesModal + gameState . discovery . availableRecipes . notificationsCount .= 0 + , B.onEvent (Main ViewCommandsEvent) "View Commands screen" $ do + s <- get + unless (null (s ^. gameState . discovery . availableCommands . notificationsContent)) $ do + toggleModal CommandsModal + gameState . discovery . availableCommands . notificationsCount .= 0 + , B.onEvent (Main ViewStructuresEvent) "View Structures screen" $ do + s <- get + unless (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) $ do + toggleModal StructuresModal + , B.onEvent (Main ViewGoalEvent) "View scenario goal description" $ do + s <- get + if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent + then toggleModal GoalModal + else continueWithoutRedraw + , B.onEvent (Main HideRobotsEvent) "Hide robots for a few ticks" $ do + t <- liftIO $ getTime Monotonic + h <- use $ uiState . uiGameplay . uiHideRobotsUntil + case h >= t of + -- ignore repeated keypresses + True -> continueWithoutRedraw + -- hide for two seconds + False -> do + uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 + invalidateCacheEntry WorldCache + , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do + s <- get + let isPaused = s ^. gameState . temporal . paused + let hasDebug = hasDebugCapability isCreative s + when (isPaused && hasDebug) $ do + debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not + if debug + then gameState . temporal . gameStep .= RobotStep SBefore + else zoomGameState finishGameTick >> void updateUI + ] \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs new file mode 100644 index 000000000..fa1ebead3 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs @@ -0,0 +1,56 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +{-# LANGUAGE OverloadedStrings #-} +module Swarm.TUI.Controller.REPLEventHandler ( + replEventHandlers +) where + +import Brick.Keybindings qualified as B +import Swarm.TUI.Model.Event +import Brick +import Swarm.TUI.Model +import Control.Lens as Lens +import Control.Monad (when) +import Data.Maybe (isJust) +import Data.Text qualified as T +import Swarm.Game.CESK (cancel) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI + + +replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] +replEventHandlers = + [ B.onEvent (REPL CancelRunningProgramEvent) "Cancel running base robot program" $ do + -- Handled here so we can always cancel the currently running + -- base program no matter what REPL control mode we are in. + working <- use $ gameState . gameControls . replWorking + when working $ gameState . baseRobot . machine %= cancel + Brick.zoom (uiState . uiGameplay . uiREPL) $ do + replPromptType .= CmdPrompt [] + replPromptText .= "" + , B.onEvent (REPL TogglePilotingModeEvent) "Toggle piloting mode" . onlyCreative $ do + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + case curMode of + Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + _ -> + if T.null uinput + then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + else do + let err = REPLError "Please clear the REPL before engaging pilot mode." + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err + invalidateCacheEntry REPLHistoryCache + , B.onEvent (REPL ToggleCustomKeyHandlingEvent) "Toggle custom key handling mode" $ do + s <- get + when (isJust (s ^. gameState . gameControls . inputHandler)) $ do + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling + ] \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 31961b661..23aed3881 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -7,7 +7,7 @@ module Swarm.TUI.Controller.Util where import Brick hiding (Direction) import Brick.Focus import Control.Lens -import Control.Monad (forM_, unless) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (liftIO) import Data.Map qualified as M import Data.Set qualified as S @@ -25,6 +25,17 @@ import Swarm.Language.Capability (Capability (CDebug)) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) +import Swarm.Effect (TimeIOC) +import Control.Monad (forM_, unless, void, when) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState, execState) +import Control.Carrier.Lift qualified as Fused +import Control.Carrier.State.Lazy qualified as Fused +import System.Clock (getTime, Clock (..)) +import Control.Lens qualified as Lens +import Swarm.Game.Step (finishGameTick) +import Swarm.Effect (runTimeIO) -- | Pattern synonyms to simplify brick event handler pattern Key :: V.Key -> BrickEvent n e @@ -76,6 +87,36 @@ isRunningModal = \case MessagesModal -> True _ -> False +-- | Set the game to Running if it was (auto) paused otherwise to paused. +-- +-- Also resets the last frame time to now. If we are pausing, it +-- doesn't matter; if we are unpausing, this is critical to +-- ensure the next frame doesn't think it has to catch up from +-- whenever the game was paused! +safeTogglePause :: EventM Name AppState () +safeTogglePause = do + curTime <- liftIO $ getTime Monotonic + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + uiState . uiGameplay . uiShowDebug .= False + p <- gameState . temporal . runStatus Lens.<%= toggleRunStatus + when (p == Running) $ zoomGameState finishGameTick + +-- | Only unpause the game if leaving autopaused modal. +-- +-- Note that the game could have been paused before opening +-- the modal, in that case, leave the game paused. +safeAutoUnpause :: EventM Name AppState () +safeAutoUnpause = do + runs <- use $ gameState . temporal . runStatus + when (runs == AutoPause) safeTogglePause + +toggleModal :: ModalType -> EventM Name AppState () +toggleModal mt = do + modal <- use $ uiState . uiGameplay . uiModal + case modal of + Nothing -> openModal mt + Just _ -> uiState . uiGameplay . uiModal .= Nothing >> safeAutoUnpause + setFocus :: FocusablePanel -> EventM Name AppState () setFocus name = uiState . uiGameplay . uiFocusRing %= focusSetCurrent (FocusablePanel name) @@ -117,3 +158,16 @@ resetViewport :: ViewportScroll Name -> EventM Name AppState () resetViewport n = do vScrollToBeginning n hScrollToBeginning n + +-- | Modifies the game state using a fused-effect state action. +zoomGameState :: (MonadState AppState m, MonadIO m) => Fused.StateC GameState (TimeIOC (Fused.LiftC IO)) a -> m a +zoomGameState f = do + gs <- use gameState + (gs', a) <- liftIO (Fused.runM (runTimeIO (Fused.runState gs f))) + gameState .= gs' + return a + +onlyCreative :: (MonadState AppState m) => m () -> m () +onlyCreative a = do + c <- use $ gameState . creativeMode + when c a diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 846632864..fd5efdb53 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -48,10 +48,16 @@ module Swarm.TUI.Model ( -- ** Utility logEvent, + KeyEventHandlingState(..), + EventHandlers(..), + keyConfig, + keyHandlers, + -- * App state AppState (AppState), gameState, uiState, + keyEventHandling, runtimeState, -- ** Initialization @@ -67,10 +73,10 @@ module Swarm.TUI.Model ( nextScenario, ) where -import Brick +import Brick ( EventM, viewportScroll, ViewportScroll ) import Brick.Widgets.List qualified as BL import Control.Lens hiding (from, (<.>)) -import Control.Monad ((>=>)) +import Control.Monad ((>=>), forM_) import Control.Monad.State (MonadState) import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..)) @@ -98,6 +104,8 @@ import Swarm.TUI.Model.UI import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Version (NewReleaseFailure) import Text.Fuzzy qualified as Fuzzy +import Brick.Keybindings as BK +import Swarm.TUI.Model.Event (SwarmEvent) ------------------------------------------------------------ -- Custom UI label types @@ -139,6 +147,25 @@ logEvent src sev who msg el = where l = LogEntry (TickNumber 0) src sev who msg + +data KeyEventHandlingState = KeyEventHandlingState + { _keyConfig :: KeyConfig SwarmEvent + , _keyHandlers :: EventHandlers + } + +keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) +keyConfig = lens _keyConfig (\s k -> s {_keyConfig = k}) + +keyHandlers :: Lens' KeyEventHandlingState EventHandlers +keyHandlers = lens _keyHandlers (\s k -> s {_keyHandlers = k}) + +type SwarmEventHandler = KeyDispatcher SwarmEvent (EventM Name AppState) + +data EventHandlers = EventHandlers + { mainHandler :: SwarmEventHandler + , replHandler :: SwarmEventHandler + } + -- ---------------------------------------------------------------------------- -- APPSTATE -- -- ---------------------------------------------------------------------------- @@ -151,6 +178,7 @@ logEvent src sev who msg el = data AppState = AppState { _gameState :: GameState , _uiState :: UIState + , _keyEventHandling :: KeyEventHandlingState , _runtimeState :: RuntimeState } @@ -165,6 +193,9 @@ gameState :: Lens' AppState GameState -- | The 'UIState' record. uiState :: Lens' AppState UIState +-- | The key event handling configuration. +keyEventHandling :: Lens' AppState KeyEventHandlingState + -- | The 'RuntimeState' record runtimeState :: Lens' AppState RuntimeState diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs new file mode 100644 index 000000000..91a3ee54a --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -0,0 +1,90 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types representing the Swarm events +-- abstracted away from keybindings. +{-# LANGUAGE OverloadedStrings #-} +module Swarm.TUI.Model.Event ( + SwarmEvent(..), + MainEvent(..), + REPLEvent(..), + swarmEvents, + defaultSwarmBindings, +) where + +import Brick.Keybindings +import Data.Text (Text) +import Graphics.Vty qualified as V +import Data.Bifunctor (first) + +data SwarmEvent + = Main MainEvent + | REPL REPLEvent + deriving (Eq, Ord, Show) + +swarmEvents :: KeyEvents SwarmEvent +swarmEvents = keyEvents (embed Main mainEvents ++ embed REPL replEvents) + +defaultSwarmBindings :: [(SwarmEvent, [Binding])] +defaultSwarmBindings = embedB Main defaultMainBindings ++ embedB REPL defaultReplBindings + where + embedB f = map (first f) + +data MainEvent + = QuitEvent + | ViewHelpEvent + | ViewRobotsEvent + | ViewRecipesEvent + | ViewCommandsEvent + | ViewMessagesEvent + | ViewStructuresEvent + | ViewGoalEvent + | HideRobotsEvent + | ShowCESKDebugEvent + deriving (Eq, Ord, Show, Enum) + +mainEvents :: KeyEvents MainEvent +mainEvents = keyEvents + [ ("quit", QuitEvent) + , ("view goal", ViewGoalEvent) + ] + +defaultMainBindings :: [(MainEvent, [Binding])] +defaultMainBindings = + [ (QuitEvent, [ctrl 'q']) + , (ViewHelpEvent, [fn 1]) + , (ViewRobotsEvent, [fn 2]) + , (ViewRecipesEvent, [fn 3]) + , (ViewCommandsEvent, [fn 4]) + , (ViewMessagesEvent, [fn 5]) + , (ViewStructuresEvent, [fn 6]) + , (ViewGoalEvent, [ctrl 'g']) + , (HideRobotsEvent, [meta 'h']) + , (ShowCESKDebugEvent, [meta 'd']) + ] + +data REPLEvent + = CancelRunningProgramEvent + | TogglePilotingModeEvent + | ToggleCustomKeyHandlingEvent + deriving (Eq, Ord, Show, Enum) + +replEvents :: KeyEvents REPLEvent +replEvents = keyEvents + [ ("cancel running program", CancelRunningProgramEvent) + , ("toggle custom key handling", ToggleCustomKeyHandlingEvent) + , ("toggle piloting mode", TogglePilotingModeEvent) + ] + +defaultReplBindings :: [(REPLEvent, [Binding])] +defaultReplBindings = + [ (CancelRunningProgramEvent, [ctrl 'c', bind V.KEsc]) + , (TogglePilotingModeEvent, [meta 'p']) + , (ToggleCustomKeyHandlingEvent, [meta 'k']) + ] + +-- ---------------- +-- * Helper methods + +embed :: Ord b => (a -> b) -> KeyEvents a -> [(Text, b)] +embed f = map (fmap f) . keyEventsList \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 16811ea3c..2ae1bc011 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -28,7 +28,7 @@ import Control.Effect.Accum import Control.Effect.Lift import Control.Effect.Throw import Control.Lens hiding (from, (<.>)) -import Control.Monad (guard, void) +import Control.Monad (guard, void, forM_) import Control.Monad.Except (ExceptT (..)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) @@ -91,6 +91,41 @@ import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock +import System.Exit (exitFailure) +import Data.Text.IO qualified as T +import Brick.Keybindings as BK +import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents, defaultSwarmBindings) +import Swarm.TUI.Controller.MainEventHandler (mainEventHandlers) +import Swarm.TUI.Controller.REPLEventHandler (replEventHandlers) + +createEventHandlers :: KeyConfig SwarmEvent -> IO EventHandlers +createEventHandlers config = do + mainHandler <- buildDispatcher mainEventHandlers + replHandler <- buildDispatcher replEventHandlers + return EventHandlers {..} + where + -- this error handling code is taken from the brick demo app: + -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 + buildDispatcher handlers = case keyDispatcher config handlers of + Right d -> return d + Left collisions -> do + putStrLn "Error: some key events have the same keys bound to them." + forM_ collisions $ \(b, hs) -> do + T.putStrLn $ "Handlers with the '" <> BK.ppBinding b <> "' binding:" + forM_ hs $ \h -> do + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" + ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + T.putStrLn $ " " <> desc <> " (" <> trigger <> ")" + exitFailure + +initKeyHandlingState :: IO KeyEventHandlingState +initKeyHandlingState = do + let cfg = newKeyConfig swarmEvents defaultSwarmBindings [] + handlers <- sendIO $ createEventHandlers cfg + return $ KeyEventHandlingState cfg handlers + -- | Initialize the 'AppState' from scratch. initAppState :: @@ -99,7 +134,8 @@ initAppState :: m AppState initAppState opts = do (rs, ui) <- initPersistentState opts - constructAppState rs ui opts + keyHandling <- sendIO initKeyHandlingState + constructAppState rs ui keyHandling opts -- | Add some system failures to the list of messages in the -- 'RuntimeState'. @@ -137,12 +173,13 @@ constructAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => RuntimeState -> UIState -> + KeyEventHandlingState -> AppOpts -> m AppState -constructAppState rs ui opts@(AppOpts {..}) = do +constructAppState rs ui key opts@(AppOpts {..}) = do let gs = initGameState $ rs ^. stdGameConfigInputs case skipMenu opts of - False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) rs + False -> return $ AppState gs (ui & uiGameplay . uiTiming . lgTicksPerSecond .~ defaultInitLgTicksPerSecond) key rs True -> do let tem = gs ^. landscape . terrainAndEntities (scenario, path) <- @@ -164,7 +201,7 @@ constructAppState rs ui opts@(AppOpts {..}) = do sendIO $ execStateT (startGameWithSeed (scenario, si) $ LaunchParams (pure userSeed) (pure codeToRun)) - (AppState gs ui newRs) + (AppState gs ui key newRs) -- | Load a 'Scenario' and start playing the game. startGame :: (MonadIO m, MonadState AppState m) => ScenarioInfoPair -> Maybe CodeToRun -> m () diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 5d968d375..1a3be5931 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -167,7 +167,7 @@ mkApp state events = :<|> codeRunHandler events :<|> pathsLogHandler state :<|> cmdMatrixHandler state - :<|> replHandler state + :<|> replHistHandler state :<|> mapViewHandler state robotsHandler :: ReadableIORef AppState -> Handler [Robot] @@ -247,8 +247,8 @@ pathsLogHandler appStateRef = do cmdMatrixHandler :: ReadableIORef AppState -> Handler CommandCatalog cmdMatrixHandler _ = pure getCatalog -replHandler :: ReadableIORef AppState -> Handler [REPLHistItem] -replHandler appStateRef = do +replHistHandler :: ReadableIORef AppState -> Handler [REPLHistItem] +replHistHandler appStateRef = do appState <- liftIO (readIORef appStateRef) let replHistorySeq = appState ^. uiState . uiGameplay . uiREPL . replHistory . replSeq items = toList replHistorySeq diff --git a/swarm.cabal b/swarm.cabal index 296180398..d3acdc734 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -664,6 +664,8 @@ library swarm-tui exposed-modules: Swarm.TUI.Border Swarm.TUI.Controller + Swarm.TUI.Controller.MainEventHandler + Swarm.TUI.Controller.REPLEventHandler Swarm.TUI.Controller.Util Swarm.TUI.Editor.Controller Swarm.TUI.Editor.Json @@ -679,6 +681,7 @@ library swarm-tui Swarm.TUI.Launch.View Swarm.TUI.List Swarm.TUI.Model + Swarm.TUI.Model.Event Swarm.TUI.Model.Goal Swarm.TUI.Model.Menu Swarm.TUI.Model.Name From 829b4e334bad2b6a157eafdf5b1f25406e317cd9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 23 Jun 2024 22:03:50 +0200 Subject: [PATCH 02/55] Reformat --- src/swarm-tui/Swarm/TUI/Controller.hs | 11 ++- .../Swarm/TUI/Controller/MainEventHandler.hs | 65 ++++++------- .../Swarm/TUI/Controller/REPLEventHandler.hs | 46 ++++----- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 23 ++--- src/swarm-tui/Swarm/TUI/Model.hs | 20 ++-- src/swarm-tui/Swarm/TUI/Model/Event.hs | 94 ++++++++++--------- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 33 ++++--- 7 files changed, 146 insertions(+), 146 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index d776ddbdc..f8e4abc10 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -39,6 +39,8 @@ module Swarm.TUI.Controller ( import Brick hiding (Direction, Location) import Brick.Focus +-- See Note [liftA2 re-export from Prelude] +import Brick.Keybindings qualified as B import Brick.Widgets.Dialog import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) import Brick.Widgets.List (handleListEvent) @@ -123,6 +125,7 @@ import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep (prepareLaunchDialog) import Swarm.TUI.List import Swarm.TUI.Model +import Swarm.TUI.Model.Event (MainEvent (..), REPLEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl @@ -136,9 +139,7 @@ import Swarm.Version (NewReleaseFailure (..)) import System.Clock import System.FilePath (splitDirectories) import Witch (into) -import Prelude hiding (Applicative (..)) -- See Note [liftA2 re-export from Prelude] -import Brick.Keybindings qualified as B -import Swarm.TUI.Model.Event (SwarmEvent (..), MainEvent (..), REPLEvent (..)) +import Prelude hiding (Applicative (..)) -- ~~~~ Note [liftA2 re-export from Prelude] -- @@ -324,7 +325,7 @@ handleMainEvent ev = do -- pass to key handler (allows users to configure bindings) VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> do - void $ B.handleKey keyHandler k m + void $ B.handleKey keyHandler k m VtyEvent (V.EvResize _ _) -> invalidateCache Key V.KEsc | Just m <- s ^. uiState . uiGameplay . uiModal -> do @@ -951,7 +952,7 @@ handleREPLEvent x = do -- pass to key handler (allows users to configure bindings) VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> do - void $ B.handleKey keyHandler k m + void $ B.handleKey keyHandler k m -- Handle other events in a way appropriate to the current REPL -- control mode. _ -> case controlMode of diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index f1499c1e1..ca6b00110 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -1,15 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- TODO: describe -{-# LANGUAGE OverloadedStrings #-} module Swarm.TUI.Controller.MainEventHandler ( - mainEventHandlers + mainEventHandlers, ) where -import Brick.Keybindings qualified as B -import Swarm.TUI.Model.Event (SwarmEvent (..), MainEvent (..)) + import Brick -import Swarm.TUI.Model +import Brick.Keybindings qualified as B import Control.Lens as Lens import Control.Monad (unless) import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) @@ -17,40 +17,41 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStruct import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI - mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = - [ B.onEvent (Main QuitEvent) "Open quit game dialog" $ do - s <- get - case s ^. gameState . winCondition of - WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal - , B.onEvent (Main ViewHelpEvent) "View Help screen" $ toggleModal HelpModal - , B.onEvent (Main ViewRobotsEvent) "View Robots screen" $ toggleModal RobotsModal - , B.onEvent (Main ViewRecipesEvent) "View Recipes screen" $ do - s <- get - unless (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) $ do - toggleModal RecipesModal - gameState . discovery . availableRecipes . notificationsCount .= 0 - , B.onEvent (Main ViewCommandsEvent) "View Commands screen" $ do - s <- get - unless (null (s ^. gameState . discovery . availableCommands . notificationsContent)) $ do - toggleModal CommandsModal - gameState . discovery . availableCommands . notificationsCount .= 0 - , B.onEvent (Main ViewStructuresEvent) "View Structures screen" $ do - s <- get - unless (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) $ do - toggleModal StructuresModal - , B.onEvent (Main ViewGoalEvent) "View scenario goal description" $ do + [ B.onEvent (Main QuitEvent) "Open quit game dialog" $ do + s <- get + case s ^. gameState . winCondition of + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal + _ -> toggleModal QuitModal + , B.onEvent (Main ViewHelpEvent) "View Help screen" $ toggleModal HelpModal + , B.onEvent (Main ViewRobotsEvent) "View Robots screen" $ toggleModal RobotsModal + , B.onEvent (Main ViewRecipesEvent) "View Recipes screen" $ do + s <- get + unless (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) $ do + toggleModal RecipesModal + gameState . discovery . availableRecipes . notificationsCount .= 0 + , B.onEvent (Main ViewCommandsEvent) "View Commands screen" $ do + s <- get + unless (null (s ^. gameState . discovery . availableCommands . notificationsContent)) $ do + toggleModal CommandsModal + gameState . discovery . availableCommands . notificationsCount .= 0 + , B.onEvent (Main ViewStructuresEvent) "View Structures screen" $ do + s <- get + unless (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) $ do + toggleModal StructuresModal + , B.onEvent (Main ViewGoalEvent) "View scenario goal description" $ do s <- get if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent then toggleModal GoalModal else continueWithoutRedraw - , B.onEvent (Main HideRobotsEvent) "Hide robots for a few ticks" $ do + , B.onEvent (Main HideRobotsEvent) "Hide robots for a few ticks" $ do t <- liftIO $ getTime Monotonic h <- use $ uiState . uiGameplay . uiHideRobotsUntil case h >= t of @@ -60,7 +61,7 @@ mainEventHandlers = False -> do uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 invalidateCacheEntry WorldCache - , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do + , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do s <- get let isPaused = s ^. gameState . temporal . paused let hasDebug = hasDebugCapability isCreative s @@ -69,4 +70,4 @@ mainEventHandlers = if debug then gameState . temporal . gameStep .= RobotStep SBefore else zoomGameState finishGameTick >> void updateUI - ] \ No newline at end of file + ] diff --git a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs index fa1ebead3..5908d89a6 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs @@ -1,16 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- TODO: describe -{-# LANGUAGE OverloadedStrings #-} module Swarm.TUI.Controller.REPLEventHandler ( - replEventHandlers + replEventHandlers, ) where -import Brick.Keybindings qualified as B -import Swarm.TUI.Model.Event import Brick -import Swarm.TUI.Model +import Brick.Keybindings qualified as B import Control.Lens as Lens import Control.Monad (when) import Data.Maybe (isJust) @@ -20,13 +19,14 @@ import Swarm.Game.Robot.Concrete import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI - replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] replEventHandlers = - [ B.onEvent (REPL CancelRunningProgramEvent) "Cancel running base robot program" $ do + [ B.onEvent (REPL CancelRunningProgramEvent) "Cancel running base robot program" $ do -- Handled here so we can always cancel the currently running -- base program no matter what REPL control mode we are in. working <- use $ gameState . gameControls . replWorking @@ -34,23 +34,23 @@ replEventHandlers = Brick.zoom (uiState . uiGameplay . uiREPL) $ do replPromptType .= CmdPrompt [] replPromptText .= "" - , B.onEvent (REPL TogglePilotingModeEvent) "Toggle piloting mode" . onlyCreative $ do - s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL - uinput = theRepl ^. replPromptText - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - case curMode of - Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing - _ -> - if T.null uinput - then uiState . uiGameplay . uiREPL . replControlMode .= Piloting - else do - let err = REPLError "Please clear the REPL before engaging pilot mode." - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err - invalidateCacheEntry REPLHistoryCache - , B.onEvent (REPL ToggleCustomKeyHandlingEvent) "Toggle custom key handling mode" $ do + , B.onEvent (REPL TogglePilotingModeEvent) "Toggle piloting mode" . onlyCreative $ do + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + case curMode of + Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + _ -> + if T.null uinput + then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + else do + let err = REPLError "Please clear the REPL before engaging pilot mode." + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err + invalidateCacheEntry REPLHistoryCache + , B.onEvent (REPL ToggleCustomKeyHandlingEvent) "Toggle custom key handling mode" $ do s <- get when (isJust (s ^. gameState . gameControls . inputHandler)) $ do curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling - ] \ No newline at end of file + ] diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 23aed3881..a65dbe19c 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -6,18 +6,25 @@ module Swarm.TUI.Controller.Util where import Brick hiding (Direction) import Brick.Focus +import Control.Carrier.Lift qualified as Fused +import Control.Carrier.State.Lazy qualified as Fused import Control.Lens -import Control.Monad (forM_, unless, when) -import Control.Monad.IO.Class (liftIO) +import Control.Lens qualified as Lens +import Control.Monad (forM_, unless, void, when) +import Control.Monad.Extra (whenJust) +import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) +import Control.Monad.State (MonadState, execState) import Data.Map qualified as M import Data.Set qualified as S import Graphics.Vty qualified as V +import Swarm.Effect (TimeIOC, runTimeIO) import Swarm.Game.Device import Swarm.Game.Robot (robotCapabilities) import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Game.World.Coords @@ -25,17 +32,7 @@ import Swarm.Language.Capability (Capability (CDebug)) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) -import Swarm.Effect (TimeIOC) -import Control.Monad (forM_, unless, void, when) -import Control.Monad.Extra (whenJust) -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.State (MonadState, execState) -import Control.Carrier.Lift qualified as Fused -import Control.Carrier.State.Lazy qualified as Fused -import System.Clock (getTime, Clock (..)) -import Control.Lens qualified as Lens -import Swarm.Game.Step (finishGameTick) -import Swarm.Effect (runTimeIO) +import System.Clock (Clock (..), getTime) -- | Pattern synonyms to simplify brick event handler pattern Key :: V.Key -> BrickEvent n e diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index fd5efdb53..176135168 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -47,9 +47,8 @@ module Swarm.TUI.Model ( -- ** Utility logEvent, - - KeyEventHandlingState(..), - EventHandlers(..), + KeyEventHandlingState (..), + EventHandlers (..), keyConfig, keyHandlers, @@ -73,10 +72,11 @@ module Swarm.TUI.Model ( nextScenario, ) where -import Brick ( EventM, viewportScroll, ViewportScroll ) +import Brick (EventM, ViewportScroll, viewportScroll) +import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Lens hiding (from, (<.>)) -import Control.Monad ((>=>), forM_) +import Control.Monad (forM_, (>=>)) import Control.Monad.State (MonadState) import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..)) @@ -98,14 +98,13 @@ import Swarm.Game.Tick (TickNumber (..)) import Swarm.Game.World.Gen (Seed) import Swarm.Log import Swarm.TUI.Inventory.Sorting +import Swarm.TUI.Model.Event (SwarmEvent) import Swarm.TUI.Model.Menu import Swarm.TUI.Model.Name import Swarm.TUI.Model.UI import Swarm.Util.Lens (makeLensesNoSigs) import Swarm.Version (NewReleaseFailure) import Text.Fuzzy qualified as Fuzzy -import Brick.Keybindings as BK -import Swarm.TUI.Model.Event (SwarmEvent) ------------------------------------------------------------ -- Custom UI label types @@ -147,11 +146,10 @@ logEvent src sev who msg el = where l = LogEntry (TickNumber 0) src sev who msg - data KeyEventHandlingState = KeyEventHandlingState - { _keyConfig :: KeyConfig SwarmEvent - , _keyHandlers :: EventHandlers - } + { _keyConfig :: KeyConfig SwarmEvent + , _keyHandlers :: EventHandlers + } keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) keyConfig = lens _keyConfig (\s k -> s {_keyConfig = k}) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 91a3ee54a..cef07f0a4 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -1,76 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- -- Sum types representing the Swarm events -- abstracted away from keybindings. -{-# LANGUAGE OverloadedStrings #-} module Swarm.TUI.Model.Event ( - SwarmEvent(..), - MainEvent(..), - REPLEvent(..), - swarmEvents, - defaultSwarmBindings, + SwarmEvent (..), + MainEvent (..), + REPLEvent (..), + swarmEvents, + defaultSwarmBindings, ) where import Brick.Keybindings +import Data.Bifunctor (first) import Data.Text (Text) import Graphics.Vty qualified as V -import Data.Bifunctor (first) data SwarmEvent - = Main MainEvent - | REPL REPLEvent - deriving (Eq, Ord, Show) + = Main MainEvent + | REPL REPLEvent + deriving (Eq, Ord, Show) swarmEvents :: KeyEvents SwarmEvent swarmEvents = keyEvents (embed Main mainEvents ++ embed REPL replEvents) defaultSwarmBindings :: [(SwarmEvent, [Binding])] defaultSwarmBindings = embedB Main defaultMainBindings ++ embedB REPL defaultReplBindings - where - embedB f = map (first f) + where + embedB f = map (first f) data MainEvent - = QuitEvent - | ViewHelpEvent - | ViewRobotsEvent - | ViewRecipesEvent - | ViewCommandsEvent - | ViewMessagesEvent - | ViewStructuresEvent - | ViewGoalEvent - | HideRobotsEvent - | ShowCESKDebugEvent - deriving (Eq, Ord, Show, Enum) + = QuitEvent + | ViewHelpEvent + | ViewRobotsEvent + | ViewRecipesEvent + | ViewCommandsEvent + | ViewMessagesEvent + | ViewStructuresEvent + | ViewGoalEvent + | HideRobotsEvent + | ShowCESKDebugEvent + deriving (Eq, Ord, Show, Enum) mainEvents :: KeyEvents MainEvent -mainEvents = keyEvents +mainEvents = + keyEvents [ ("quit", QuitEvent) , ("view goal", ViewGoalEvent) ] defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = - [ (QuitEvent, [ctrl 'q']) - , (ViewHelpEvent, [fn 1]) - , (ViewRobotsEvent, [fn 2]) - , (ViewRecipesEvent, [fn 3]) - , (ViewCommandsEvent, [fn 4]) - , (ViewMessagesEvent, [fn 5]) - , (ViewStructuresEvent, [fn 6]) - , (ViewGoalEvent, [ctrl 'g']) - , (HideRobotsEvent, [meta 'h']) - , (ShowCESKDebugEvent, [meta 'd']) - ] + [ (QuitEvent, [ctrl 'q']) + , (ViewHelpEvent, [fn 1]) + , (ViewRobotsEvent, [fn 2]) + , (ViewRecipesEvent, [fn 3]) + , (ViewCommandsEvent, [fn 4]) + , (ViewMessagesEvent, [fn 5]) + , (ViewStructuresEvent, [fn 6]) + , (ViewGoalEvent, [ctrl 'g']) + , (HideRobotsEvent, [meta 'h']) + , (ShowCESKDebugEvent, [meta 'd']) + ] data REPLEvent - = CancelRunningProgramEvent - | TogglePilotingModeEvent - | ToggleCustomKeyHandlingEvent - deriving (Eq, Ord, Show, Enum) + = CancelRunningProgramEvent + | TogglePilotingModeEvent + | ToggleCustomKeyHandlingEvent + deriving (Eq, Ord, Show, Enum) replEvents :: KeyEvents REPLEvent -replEvents = keyEvents +replEvents = + keyEvents [ ("cancel running program", CancelRunningProgramEvent) , ("toggle custom key handling", ToggleCustomKeyHandlingEvent) , ("toggle piloting mode", TogglePilotingModeEvent) @@ -78,13 +81,14 @@ replEvents = keyEvents defaultReplBindings :: [(REPLEvent, [Binding])] defaultReplBindings = - [ (CancelRunningProgramEvent, [ctrl 'c', bind V.KEsc]) - , (TogglePilotingModeEvent, [meta 'p']) - , (ToggleCustomKeyHandlingEvent, [meta 'k']) - ] + [ (CancelRunningProgramEvent, [ctrl 'c', bind V.KEsc]) + , (TogglePilotingModeEvent, [meta 'p']) + , (ToggleCustomKeyHandlingEvent, [meta 'k']) + ] -- ---------------- + -- * Helper methods embed :: Ord b => (a -> b) -> KeyEvents a -> [(Text, b)] -embed f = map (fmap f) . keyEventsList \ No newline at end of file +embed f = map (fmap f) . keyEventsList diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 2ae1bc011..6d8c2a770 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -19,6 +19,7 @@ module Swarm.TUI.Model.StateUpdate ( import Brick.AttrMap (applyAttrMappings) import Brick.Focus +import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Applicative ((<|>)) import Control.Carrier.Accum.FixedStrict (runAccum) @@ -28,7 +29,7 @@ import Control.Effect.Accum import Control.Effect.Lift import Control.Effect.Throw import Control.Lens hiding (from, (<.>)) -import Control.Monad (guard, void, forM_) +import Control.Monad (forM_, guard, void) import Control.Monad.Except (ExceptT (..)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) @@ -41,6 +42,7 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) +import Data.Text.IO qualified as T import Data.Time (ZonedTime, getZonedTime) import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions @@ -76,11 +78,14 @@ import Swarm.Game.State.Substate import Swarm.Game.World.Gen (Seed) import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) +import Swarm.TUI.Controller.MainEventHandler (mainEventHandlers) +import Swarm.TUI.Controller.REPLEventHandler (replEventHandlers) import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) import Swarm.TUI.Model.Goal (emptyGoalDisplay) import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl @@ -92,11 +97,6 @@ import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock import System.Exit (exitFailure) -import Data.Text.IO qualified as T -import Brick.Keybindings as BK -import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents, defaultSwarmBindings) -import Swarm.TUI.Controller.MainEventHandler (mainEventHandlers) -import Swarm.TUI.Controller.REPLEventHandler (replEventHandlers) createEventHandlers :: KeyConfig SwarmEvent -> IO EventHandlers createEventHandlers config = do @@ -109,16 +109,16 @@ createEventHandlers config = do buildDispatcher handlers = case keyDispatcher config handlers of Right d -> return d Left collisions -> do - putStrLn "Error: some key events have the same keys bound to them." - forM_ collisions $ \(b, hs) -> do - T.putStrLn $ "Handlers with the '" <> BK.ppBinding b <> "' binding:" - forM_ hs $ \h -> do - let trigger = case BK.kehEventTrigger $ BK.khHandler h of - ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" - ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" - desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h - T.putStrLn $ " " <> desc <> " (" <> trigger <> ")" - exitFailure + putStrLn "Error: some key events have the same keys bound to them." + forM_ collisions $ \(b, hs) -> do + T.putStrLn $ "Handlers with the '" <> BK.ppBinding b <> "' binding:" + forM_ hs $ \h -> do + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" + ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + T.putStrLn $ " " <> desc <> " (" <> trigger <> ")" + exitFailure initKeyHandlingState :: IO KeyEventHandlingState initKeyHandlingState = do @@ -126,7 +126,6 @@ initKeyHandlingState = do handlers <- sendIO $ createEventHandlers cfg return $ KeyEventHandlingState cfg handlers - -- | Initialize the 'AppState' from scratch. initAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => From f6b8b76a2a200bc67872f81b73bb2970ab7e9c4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 23 Jun 2024 22:34:51 +0200 Subject: [PATCH 03/55] Lot of shuffling just for updateUI --- src/swarm-tui/Swarm/TUI/Controller.hs | 329 +----------------- .../Swarm/TUI/Controller/MainEventHandler.hs | 7 +- .../Swarm/TUI/Controller/SaveScenario.hs | 120 +++++++ .../Swarm/TUI/Controller/UpdateUI.hs | 251 +++++++++++++ src/swarm-tui/Swarm/TUI/Controller/Util.hs | 5 +- src/swarm-tui/Swarm/TUI/Model.hs | 2 +- src/swarm-tui/Swarm/TUI/Model/Achievements.hs | 39 +++ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 26 +- swarm.cabal | 3 + 9 files changed, 432 insertions(+), 350 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs create mode 100644 src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs create mode 100644 src/swarm-tui/Swarm/TUI/Model/Achievements.hs diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index f8e4abc10..68492290d 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -45,56 +45,46 @@ import Brick.Widgets.Dialog import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) import Brick.Widgets.List (handleListEvent) import Brick.Widgets.List qualified as BL -import Control.Applicative (liftA2, pure) -import Control.Carrier.Lift qualified as Fused -import Control.Carrier.State.Lazy qualified as Fused +import Control.Applicative (pure) import Control.Category ((>>>)) import Control.Lens as Lens import Control.Lens.Extras as Lens (is) -import Control.Monad (forM_, unless, void, when) +import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execState) import Data.Bits -import Data.Foldable (toList) import Data.Int (Int32) import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M -import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Set (Set) import Data.Set qualified as S -import Data.String (fromString) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Text.Zipper qualified as TZ import Data.Text.Zipper.Generic.Words qualified as TZ -import Data.Time (getZonedTime) import Data.Vector qualified as V import Graphics.Vty qualified as V import Linear -import Swarm.Effect (TimeIOC (..)) import Swarm.Game.Achievement.Definitions import Swarm.Game.Achievement.Persistence -import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), cancel, continue) +import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), continue) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land import Swarm.Game.Location import Swarm.Game.ResourceLoading (getSwarmHistoryPath) -import Swarm.Game.Robot import Swarm.Game.Robot.Concrete -import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) -import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) -import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.ScenarioInfo import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Runtime import Swarm.Game.State.Substate -import Swarm.Game.Step (finishGameTick, gameTick) +import Swarm.Game.Step (gameTick) import Swarm.Language.Capability ( Capability (CGod), constCaps, @@ -107,16 +97,14 @@ import Swarm.Language.Parser.Lex (reservedWords) import Swarm.Language.Parser.Util (showErrorPos) import Swarm.Language.Pipeline (processParsedTerm', processTerm') import Swarm.Language.Pipeline.QQ (tmQ) -import Swarm.Language.Pretty import Swarm.Language.Syntax hiding (Key) import Swarm.Language.Typecheck ( ContextualTypeErr (..), ) -import Swarm.Language.Typed (Typed (..)) -import Swarm.Language.Types -import Swarm.Language.Value (Value (VExc, VKey, VUnit), envTydefs, envTypes, prettyValue) +import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log import Swarm.TUI.Controller.Util +import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) @@ -125,21 +113,18 @@ import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep (prepareLaunchDialog) import Swarm.TUI.List import Swarm.TUI.Model -import Swarm.TUI.Model.Event (MainEvent (..), REPLEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI -import Swarm.TUI.View.Objective qualified as GR import Swarm.TUI.View.Util (generateModal) import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) import System.Clock -import System.FilePath (splitDirectories) -import Witch (into) import Prelude hiding (Applicative (..)) +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) -- ~~~~ Note [liftA2 re-export from Prelude] -- @@ -311,9 +296,6 @@ handleMainEvent ev = do s <- get mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType let isRunning = maybe True isRunningModal mt - let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode - let hasDebug = hasDebugCapability isCreative s let keyHandler = s ^. keyEventHandling . keyHandlers . to mainHandler case ev of AppEvent ae -> case ae of @@ -472,94 +454,6 @@ handleModalEvent = \case refreshGoalList lw = nestEventM' lw $ handleListEventWithSeparators ev shouldSkipSelection refreshList z = Brick.zoom z $ BL.handleListEvent ev -getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) -getNormalizedCurrentScenarioPath = - -- the path should be normalized and good to search in scenario collection - use (gameState . currentScenarioPath) >>= \case - Nothing -> return Nothing - Just p' -> do - gs <- use $ runtimeState . scenarios - Just <$> liftIO (normalizeScenarioPath gs p') - -saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) -saveScenarioInfoOnFinish p = do - initialRunCode <- use $ gameState . gameControls . initiallyRunCode - t <- liftIO getZonedTime - wc <- use $ gameState . winCondition - let won = case wc of - WinConditions (Won _ _) _ -> True - _ -> False - ts <- use $ gameState . temporal . ticks - - -- NOTE: This traversal is apparently not the same one as used by - -- the scenario selection menu, so the menu needs to be updated separately. - -- See Note [scenario menu update] - let currentScenarioInfo :: Traversal' AppState ScenarioInfo - currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 - - replHist <- use $ uiState . uiGameplay . uiREPL . replHistory - let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput - currentScenarioInfo - %= updateScenarioInfoOnFinish determinator t ts won - status <- preuse currentScenarioInfo - case status of - Nothing -> return () - Just si -> do - let segments = splitDirectories p - case segments of - firstDir : _ -> do - when (won && firstDir == tutorialsDirname) $ - attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) - _ -> return () - liftIO $ saveScenarioInfo p si - return status - --- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). -saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnFinishNocheat = do - -- Don't save progress if we are in cheat mode - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - -- the path should be normalized and good to search in scenario collection - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> void $ saveScenarioInfoOnFinish p - --- | Write the @ScenarioInfo@ out to disk when exiting a game. -saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () -saveScenarioInfoOnQuit = do - -- Don't save progress if we are in cheat mode - -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" - cheat <- use $ uiState . uiCheatMode - unless cheat $ do - getNormalizedCurrentScenarioPath >>= \case - Nothing -> return () - Just p -> do - maybeSi <- saveScenarioInfoOnFinish p - -- Note [scenario menu update] - -- Ensures that the scenario selection menu gets updated - -- with the high score/completion status - forM_ - maybeSi - ( uiState - . uiMenu - . _NewGameMenu - . ix 0 - . BL.listSelectedElementL - . _SISingle - . _2 - .= - ) - - -- See what scenario is currently focused in the menu. Depending on how the - -- previous scenario ended (via quit vs. via win), it might be the same as - -- currentScenarioPath or it might be different. - curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath - -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, - -- being sure to preserve the same focused scenario. - sc <- use $ runtimeState . scenarios - forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) - -- | Quit a game. -- -- * writes out the updated REPL history to a @.swarm_history@ file @@ -724,213 +618,6 @@ runGameTick = do ticked <- zoomGameState gameTick when ticked updateAchievements --- | Update the UI. This function is used after running the --- game for some number of ticks. -updateUI :: EventM Name AppState Bool -updateUI = do - loadVisibleRegion - - -- If the game state indicates a redraw is needed, invalidate the - -- world cache so it will be redrawn. - g <- use gameState - when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache - - -- The hash of the robot whose inventory is currently displayed (if any) - listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) - - -- The hash of the focused robot (if any) - fr <- use (gameState . to focusedRobot) - let focusedRobotHash = view inventoryHash <$> fr - - -- Check if the inventory list needs to be updated. - shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) - - -- Whether the focused robot is too far away to sense, & whether - -- that has recently changed - dist <- use (gameState . to focusedRange) - farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) - let tooFar = not farOK && dist == Just Far - farChanged = tooFar /= isNothing listRobotHash - - -- If the robot moved in or out of range, or hashes don't match - -- (either because which robot (or whether any robot) is focused - -- changed, or the focused robot's inventory changed), or the - -- inventory was flagged to be updated, regenerate the inventory list. - inventoryUpdated <- - if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate - then do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - populateInventoryList $ if tooFar then Nothing else fr - uiInventoryShouldUpdate .= False - pure True - else pure False - - -- Now check if the base finished running a program entered at the REPL. - replUpdated <- case g ^. gameControls . replStatus of - REPLWorking pty (Just v) - -- It did, and the result was the unit value or an exception. Just reset replStatus. - | v `elem` [VUnit, VExc] -> do - gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) - pure True - - -- It did, and returned some other value. Create new 'it' - -- variables, pretty-print the result as a REPL output, with its - -- type, and reset the replStatus. - | otherwise -> do - itIx <- use (gameState . gameControls . replNextValueIndex) - env <- use (gameState . baseEnv) - let finalType = stripCmd (env ^. envTydefs) pty - itName = fromString $ "it" ++ show itIx - out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out) - invalidateCacheEntry REPLHistoryCache - vScrollToEnd replScroll - gameState . gameControls . replStatus .= REPLDone (Just (finalType, v)) - gameState . baseEnv . at itName .= Just (Typed v finalType mempty) - gameState . baseEnv . at "it" .= Just (Typed v finalType mempty) - gameState . gameControls . replNextValueIndex %= (+ 1) - pure True - - -- Otherwise, do nothing. - _ -> pure False - - -- If the focused robot's log has been updated and the UI focus - -- isn't currently on the inventory or info panels, attempt to - -- automatically switch to the logger and scroll all the way down so - -- the new message can be seen. - uiState . uiGameplay . uiScrollToEnd .= False - logUpdated <- do - -- If the inventory or info panels are currently focused, it would - -- be rude to update them right under the user's nose, so consider - -- them "sticky". They will be updated as soon as the player moves - -- the focus away. - fring <- use $ uiState . uiGameplay . uiFocusRing - let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] - - -- Check if the robot log was updated and we are allowed to change - -- the inventory+info panels. - case maybe False (view robotLogUpdated) fr && not sticky of - False -> pure False - True -> do - -- Reset the log updated flag - zoomGameState $ zoomRobots clearFocusedRobotLogUpdated - - -- Find and focus an equipped "logger" device in the inventory list. - let isLogger (EquippedEntry e) = e ^. entityName == "logger" - isLogger _ = False - focusLogger = BL.listFindBy isLogger - - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger - - -- Now inform the UI that it should scroll the info panel to - -- the very end. - uiState . uiGameplay . uiScrollToEnd .= True - pure True - - goalOrWinUpdated <- doGoalUpdates - - let redraw = - g ^. needsRedraw - || inventoryUpdated - || replUpdated - || logUpdated - || goalOrWinUpdated - pure redraw - --- | Either pops up the updated Goals modal --- or pops up the Congratulations (Win) modal, or pops --- up the Condolences (Lose) modal. --- The Win modal will take precedence if the player --- has met the necessary conditions to win the game. --- --- If the player chooses to "Keep Playing" from the Win modal, the --- updated Goals will then immediately appear. --- This is desirable for: --- * feedback as to the final goal the player accomplished, --- * as a summary of all of the goals of the game --- * shows the player more "optional" goals they can continue to pursue -doGoalUpdates :: EventM Name AppState Bool -doGoalUpdates = do - curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) - isCheating <- use (uiState . uiCheatMode) - curWinCondition <- use (gameState . winCondition) - announcementsSeq <- use (gameState . messageInfo . announcementQueue) - let announcementsList = toList announcementsSeq - - -- Decide whether we need to update the current goal text and pop - -- up a modal dialog. - case curWinCondition of - NoWinCondition -> return False - WinConditions (Unwinnable False) x -> do - -- This clears the "flag" that the Lose dialog needs to pop up - gameState . winCondition .= WinConditions (Unwinnable True) x - openModal $ ScenarioEndModal LoseModal - saveScenarioInfoOnFinishNocheat - return True - WinConditions (Won False ts) x -> do - -- This clears the "flag" that the Win dialog needs to pop up - gameState . winCondition .= WinConditions (Won True ts) x - openModal $ ScenarioEndModal WinModal - saveScenarioInfoOnFinishNocheat - -- We do NOT advance the New Game menu to the next item here (we - -- used to!), because we do not know if the user is going to - -- select 'keep playing' or 'next challenge'. We maintain the - -- invariant that the current menu item is always the same as - -- the scenario currently being played. If the user either (1) - -- quits to the menu or (2) selects 'next challenge' we will - -- advance the menu at that point. - return True - WinConditions _ oc -> do - let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc - -- The "uiGoal" field is initialized with empty members, so we know that - -- this will be the first time showing it if it will be nonempty after previously - -- being empty. - isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) - goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) - - -- Decide whether to show a pop-up modal congratulating the user on - -- successfully completing the current challenge. - when goalWasUpdated $ do - let hasMultiple = hasMultipleGoals newGoalTracking - defaultFocus = - if hasMultiple - then ObjectivesList - else GoalSummary - - ring = - focusRing $ - map GoalWidgets $ - if hasMultiple - then enumerate - else [GoalSummary] - - -- The "uiGoal" field is necessary at least to "persist" the data that is needed - -- if the player chooses to later "recall" the goals dialog with CTRL+g. - uiState - . uiGameplay - . uiGoal - .= GoalDisplay - newGoalTracking - (GR.makeListWidget newGoalTracking) - (focusSetCurrent (GoalWidgets defaultFocus) ring) - - -- This clears the "flag" that indicate that the goals dialog needs to be - -- automatically popped up. - gameState . messageInfo . announcementQueue .= mempty - - hideGoals <- use $ uiState . uiGameplay . uiHideGoals - unless hideGoals $ - openModal GoalModal - - return goalWasUpdated - --- | Strips the top-level @Cmd@ from a type, if any (to compute the --- result type of a REPL command evaluation). -stripCmd :: TDCtx -> Polytype -> Polytype -stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of - TyCmd resTy -> Forall xs resTy - _ -> Forall xs ty - ------------------------------------------------------------ -- REPL events ------------------------------------------------------------ diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index ca6b00110..f97d1a68b 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -11,7 +11,7 @@ module Swarm.TUI.Controller.MainEventHandler ( import Brick import Brick.Keybindings qualified as B import Control.Lens as Lens -import Control.Monad (unless) +import Control.Monad (unless, when, void) import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.State @@ -21,6 +21,10 @@ import Swarm.TUI.Model import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI +import System.Clock (getTime, Clock (..), TimeSpec (..)) +import Control.Monad.IO.Class (liftIO) +import Swarm.Game.Step (finishGameTick) +import Swarm.TUI.Controller.UpdateUI (updateUI) mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = @@ -64,6 +68,7 @@ mainEventHandlers = , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do s <- get let isPaused = s ^. gameState . temporal . paused + let isCreative = s ^. gameState . creativeMode let hasDebug = hasDebugCapability isCreative s when (isPaused && hasDebug) $ do debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs new file mode 100644 index 000000000..df738341c --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -0,0 +1,120 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +module Swarm.TUI.Controller.SaveScenario ( + saveScenarioInfoOnFinish, + saveScenarioInfoOnFinishNocheat, + saveScenarioInfoOnQuit, + getNormalizedCurrentScenarioPath, +) where + + +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Lens as Lens +import Control.Monad (forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Maybe (fromMaybe) +import Data.Time (getZonedTime) +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Scenario.Status (updateScenarioInfoOnFinish) +import Swarm.Game.ScenarioInfo +import Swarm.Game.State +import Swarm.Game.State.Runtime +import Swarm.Game.State.Substate +import Swarm.TUI.Model +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import System.FilePath (splitDirectories) +import Prelude hiding (Applicative (..)) +import Swarm.TUI.Model.Achievements (attainAchievement') + +getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) +getNormalizedCurrentScenarioPath = + -- the path should be normalized and good to search in scenario collection + use (gameState . currentScenarioPath) >>= \case + Nothing -> return Nothing + Just p' -> do + gs <- use $ runtimeState . scenarios + Just <$> liftIO (normalizeScenarioPath gs p') + +saveScenarioInfoOnFinish :: (MonadIO m, MonadState AppState m) => FilePath -> m (Maybe ScenarioInfo) +saveScenarioInfoOnFinish p = do + initialRunCode <- use $ gameState . gameControls . initiallyRunCode + t <- liftIO getZonedTime + wc <- use $ gameState . winCondition + let won = case wc of + WinConditions (Won _ _) _ -> True + _ -> False + ts <- use $ gameState . temporal . ticks + + -- NOTE: This traversal is apparently not the same one as used by + -- the scenario selection menu, so the menu needs to be updated separately. + -- See Note [scenario menu update] + let currentScenarioInfo :: Traversal' AppState ScenarioInfo + currentScenarioInfo = runtimeState . scenarios . scenarioItemByPath p . _SISingle . _2 + + replHist <- use $ uiState . uiGameplay . uiREPL . replHistory + let determinator = CodeSizeDeterminators initialRunCode $ replHist ^. replHasExecutedManualInput + currentScenarioInfo + %= updateScenarioInfoOnFinish determinator t ts won + status <- preuse currentScenarioInfo + case status of + Nothing -> return () + Just si -> do + let segments = splitDirectories p + case segments of + firstDir : _ -> do + when (won && firstDir == tutorialsDirname) $ + attainAchievement' t (Just p) (GlobalAchievement CompletedSingleTutorial) + _ -> return () + liftIO $ saveScenarioInfo p si + return status + +-- | Write the @ScenarioInfo@ out to disk when finishing a game (i.e. on winning or exit). +saveScenarioInfoOnFinishNocheat :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnFinishNocheat = do + -- Don't save progress if we are in cheat mode + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + -- the path should be normalized and good to search in scenario collection + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> void $ saveScenarioInfoOnFinish p + +-- | Write the @ScenarioInfo@ out to disk when exiting a game. +saveScenarioInfoOnQuit :: (MonadIO m, MonadState AppState m) => m () +saveScenarioInfoOnQuit = do + -- Don't save progress if we are in cheat mode + -- NOTE This check is duplicated in "saveScenarioInfoOnFinishNocheat" + cheat <- use $ uiState . uiCheatMode + unless cheat $ do + getNormalizedCurrentScenarioPath >>= \case + Nothing -> return () + Just p -> do + maybeSi <- saveScenarioInfoOnFinish p + -- Note [scenario menu update] + -- Ensures that the scenario selection menu gets updated + -- with the high score/completion status + forM_ + maybeSi + ( uiState + . uiMenu + . _NewGameMenu + . ix 0 + . BL.listSelectedElementL + . _SISingle + . _2 + .= + ) + + -- See what scenario is currently focused in the menu. Depending on how the + -- previous scenario ended (via quit vs. via win), it might be the same as + -- currentScenarioPath or it might be different. + curPath <- preuse $ uiState . uiMenu . _NewGameMenu . ix 0 . BL.listSelectedElementL . _SISingle . _2 . scenarioPath + -- Now rebuild the NewGameMenu so it gets the updated ScenarioInfo, + -- being sure to preserve the same focused scenario. + sc <- use $ runtimeState . scenarios + forM_ (mkNewGameMenu cheat sc (fromMaybe p curPath)) (uiState . uiMenu .=) diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs new file mode 100644 index 000000000..75dbece68 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +module Swarm.TUI.Controller.UpdateUI ( + updateUI, + doGoalUpdates, +) where + + +import Brick hiding (Direction, Location) +import Brick.Focus +-- See Note [liftA2 re-export from Prelude] +import Brick.Widgets.List qualified as BL +import Control.Applicative (liftA2, pure) +import Control.Lens as Lens +import Control.Monad (unless, when) +import Data.Foldable (toList) +import Data.Maybe (isNothing) +import Data.String (fromString) +import Data.Text qualified as T +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Substate +import Swarm.Language.Pretty +import Swarm.Language.Typed (Typed (..)) +import Swarm.Language.Types +import Swarm.Language.Value (Value (VExc, VUnit), envTydefs, prettyValue) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Goal +import Swarm.TUI.Model.Name +import Swarm.TUI.Model.Repl +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Objective qualified as GR +import Witch (into) +import Prelude hiding (Applicative (..)) +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) +import Data.List.Extra (enumerate) + +-- | Update the UI. This function is used after running the +-- game for some number of ticks. +updateUI :: EventM Name AppState Bool +updateUI = do + loadVisibleRegion + + -- If the game state indicates a redraw is needed, invalidate the + -- world cache so it will be redrawn. + g <- use gameState + when (g ^. needsRedraw) $ invalidateCacheEntry WorldCache + + -- The hash of the robot whose inventory is currently displayed (if any) + listRobotHash <- fmap fst <$> use (uiState . uiGameplay . uiInventory . uiInventoryList) + + -- The hash of the focused robot (if any) + fr <- use (gameState . to focusedRobot) + let focusedRobotHash = view inventoryHash <$> fr + + -- Check if the inventory list needs to be updated. + shouldUpdate <- use (uiState . uiGameplay . uiInventory . uiInventoryShouldUpdate) + + -- Whether the focused robot is too far away to sense, & whether + -- that has recently changed + dist <- use (gameState . to focusedRange) + farOK <- liftA2 (||) (use (gameState . creativeMode)) (use (gameState . landscape . worldScrollable)) + let tooFar = not farOK && dist == Just Far + farChanged = tooFar /= isNothing listRobotHash + + -- If the robot moved in or out of range, or hashes don't match + -- (either because which robot (or whether any robot) is focused + -- changed, or the focused robot's inventory changed), or the + -- inventory was flagged to be updated, regenerate the inventory list. + inventoryUpdated <- + if farChanged || (not farChanged && listRobotHash /= focusedRobotHash) || shouldUpdate + then do + Brick.zoom (uiState . uiGameplay . uiInventory) $ do + populateInventoryList $ if tooFar then Nothing else fr + uiInventoryShouldUpdate .= False + pure True + else pure False + + -- Now check if the base finished running a program entered at the REPL. + replUpdated <- case g ^. gameControls . replStatus of + REPLWorking pty (Just v) + -- It did, and the result was the unit value or an exception. Just reset replStatus. + | v `elem` [VUnit, VExc] -> do + gameState . gameControls . replStatus .= REPLDone (Just (pty, v)) + pure True + + -- It did, and returned some other value. Create new 'it' + -- variables, pretty-print the result as a REPL output, with its + -- type, and reset the replStatus. + | otherwise -> do + itIx <- use (gameState . gameControls . replNextValueIndex) + env <- use (gameState . baseEnv) + let finalType = stripCmd (env ^. envTydefs) pty + itName = fromString $ "it" ++ show itIx + out = T.intercalate " " [itName, ":", prettyText finalType, "=", into (prettyValue v)] + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLOutput out) + invalidateCacheEntry REPLHistoryCache + vScrollToEnd replScroll + gameState . gameControls . replStatus .= REPLDone (Just (finalType, v)) + gameState . baseEnv . at itName .= Just (Typed v finalType mempty) + gameState . baseEnv . at "it" .= Just (Typed v finalType mempty) + gameState . gameControls . replNextValueIndex %= (+ 1) + pure True + + -- Otherwise, do nothing. + _ -> pure False + + -- If the focused robot's log has been updated and the UI focus + -- isn't currently on the inventory or info panels, attempt to + -- automatically switch to the logger and scroll all the way down so + -- the new message can be seen. + uiState . uiGameplay . uiScrollToEnd .= False + logUpdated <- do + -- If the inventory or info panels are currently focused, it would + -- be rude to update them right under the user's nose, so consider + -- them "sticky". They will be updated as soon as the player moves + -- the focus away. + fring <- use $ uiState . uiGameplay . uiFocusRing + let sticky = focusGetCurrent fring `elem` map (Just . FocusablePanel) [RobotPanel, InfoPanel] + + -- Check if the robot log was updated and we are allowed to change + -- the inventory+info panels. + case maybe False (view robotLogUpdated) fr && not sticky of + False -> pure False + True -> do + -- Reset the log updated flag + zoomGameState $ zoomRobots clearFocusedRobotLogUpdated + + -- Find and focus an equipped "logger" device in the inventory list. + let isLogger (EquippedEntry e) = e ^. entityName == "logger" + isLogger _ = False + focusLogger = BL.listFindBy isLogger + + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 %= focusLogger + + -- Now inform the UI that it should scroll the info panel to + -- the very end. + uiState . uiGameplay . uiScrollToEnd .= True + pure True + + goalOrWinUpdated <- doGoalUpdates + + let redraw = + g ^. needsRedraw + || inventoryUpdated + || replUpdated + || logUpdated + || goalOrWinUpdated + pure redraw + + +-- | Either pops up the updated Goals modal +-- or pops up the Congratulations (Win) modal, or pops +-- up the Condolences (Lose) modal. +-- The Win modal will take precedence if the player +-- has met the necessary conditions to win the game. +-- +-- If the player chooses to "Keep Playing" from the Win modal, the +-- updated Goals will then immediately appear. +-- This is desirable for: +-- * feedback as to the final goal the player accomplished, +-- * as a summary of all of the goals of the game +-- * shows the player more "optional" goals they can continue to pursue +doGoalUpdates :: EventM Name AppState Bool +doGoalUpdates = do + curGoal <- use (uiState . uiGameplay . uiGoal . goalsContent) + isCheating <- use (uiState . uiCheatMode) + curWinCondition <- use (gameState . winCondition) + announcementsSeq <- use (gameState . messageInfo . announcementQueue) + let announcementsList = toList announcementsSeq + + -- Decide whether we need to update the current goal text and pop + -- up a modal dialog. + case curWinCondition of + NoWinCondition -> return False + WinConditions (Unwinnable False) x -> do + -- This clears the "flag" that the Lose dialog needs to pop up + gameState . winCondition .= WinConditions (Unwinnable True) x + openModal $ ScenarioEndModal LoseModal + saveScenarioInfoOnFinishNocheat + return True + WinConditions (Won False ts) x -> do + -- This clears the "flag" that the Win dialog needs to pop up + gameState . winCondition .= WinConditions (Won True ts) x + openModal $ ScenarioEndModal WinModal + saveScenarioInfoOnFinishNocheat + -- We do NOT advance the New Game menu to the next item here (we + -- used to!), because we do not know if the user is going to + -- select 'keep playing' or 'next challenge'. We maintain the + -- invariant that the current menu item is always the same as + -- the scenario currently being played. If the user either (1) + -- quits to the menu or (2) selects 'next challenge' we will + -- advance the menu at that point. + return True + WinConditions _ oc -> do + let newGoalTracking = GoalTracking announcementsList $ constructGoalMap isCheating oc + -- The "uiGoal" field is initialized with empty members, so we know that + -- this will be the first time showing it if it will be nonempty after previously + -- being empty. + isFirstGoalDisplay = hasAnythingToShow newGoalTracking && not (hasAnythingToShow curGoal) + goalWasUpdated = isFirstGoalDisplay || not (null announcementsList) + + -- Decide whether to show a pop-up modal congratulating the user on + -- successfully completing the current challenge. + when goalWasUpdated $ do + let hasMultiple = hasMultipleGoals newGoalTracking + defaultFocus = + if hasMultiple + then ObjectivesList + else GoalSummary + + ring = + focusRing $ + map GoalWidgets $ + if hasMultiple + then enumerate + else [GoalSummary] + + -- The "uiGoal" field is necessary at least to "persist" the data that is needed + -- if the player chooses to later "recall" the goals dialog with CTRL+g. + uiState + . uiGameplay + . uiGoal + .= GoalDisplay + newGoalTracking + (GR.makeListWidget newGoalTracking) + (focusSetCurrent (GoalWidgets defaultFocus) ring) + + -- This clears the "flag" that indicate that the goals dialog needs to be + -- automatically popped up. + gameState . messageInfo . announcementQueue .= mempty + + hideGoals <- use $ uiState . uiGameplay . uiHideGoals + unless hideGoals $ + openModal GoalModal + + return goalWasUpdated + +-- | Strips the top-level @Cmd@ from a type, if any (to compute the +-- result type of a REPL command evaluation). +stripCmd :: TDCtx -> Polytype -> Polytype +stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of + TyCmd resTy -> Forall xs resTy + _ -> Forall xs ty \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index a65dbe19c..36ae407dd 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -10,10 +10,9 @@ import Control.Carrier.Lift qualified as Fused import Control.Carrier.State.Lazy qualified as Fused import Control.Lens import Control.Lens qualified as Lens -import Control.Monad (forM_, unless, void, when) -import Control.Monad.Extra (whenJust) +import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) -import Control.Monad.State (MonadState, execState) +import Control.Monad.State (MonadState) import Data.Map qualified as M import Data.Set qualified as S import Graphics.Vty qualified as V diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 176135168..5c8c062e9 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -76,7 +76,7 @@ import Brick (EventM, ViewportScroll, viewportScroll) import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Lens hiding (from, (<.>)) -import Control.Monad (forM_, (>=>)) +import Control.Monad ((>=>)) import Control.Monad.State (MonadState) import Data.List (findIndex) import Data.List.NonEmpty (NonEmpty (..)) diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs new file mode 100644 index 000000000..678eece96 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -0,0 +1,39 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +module Swarm.TUI.Model.Achievements ( + attainAchievement, + attainAchievement', +) where + +import Control.Lens hiding (from, (<.>)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.State (MonadState) +import Data.Map qualified as M +import Data.Time (ZonedTime, getZonedTime) +import Swarm.Game.Achievement.Attainment +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.TUI.Model +import Swarm.TUI.Model.UI + +attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () +attainAchievement a = do + currentTime <- liftIO getZonedTime + attainAchievement' currentTime Nothing a + +attainAchievement' :: + (MonadIO m, MonadState AppState m) => + ZonedTime -> + Maybe FilePath -> + CategorizedAchievement -> + m () +attainAchievement' t p a = do + (uiState . uiAchievements) + %= M.insertWith + (<>) + a + (Attainment a p t) + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 6d8c2a770..45c3895ed 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -43,10 +43,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) import Data.Text.IO qualified as T -import Data.Time (ZonedTime, getZonedTime) -import Swarm.Game.Achievement.Attainment -import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence +import Data.Time (getZonedTime) import Swarm.Game.Failure (SystemFailure) import Swarm.Game.Land import Swarm.Game.Scenario ( @@ -97,6 +94,7 @@ import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock import System.Exit (exitFailure) +import Swarm.TUI.Model.Achievements createEventHandlers :: KeyConfig SwarmEvent -> IO EventHandlers createEventHandlers config = do @@ -271,26 +269,6 @@ scenarioToAppState siPair@(scene, _) lp = do l .= x' return x' -attainAchievement :: (MonadIO m, MonadState AppState m) => CategorizedAchievement -> m () -attainAchievement a = do - currentTime <- liftIO getZonedTime - attainAchievement' currentTime Nothing a - -attainAchievement' :: - (MonadIO m, MonadState AppState m) => - ZonedTime -> - Maybe FilePath -> - CategorizedAchievement -> - m () -attainAchievement' t p a = do - (uiState . uiAchievements) - %= M.insertWith - (<>) - a - (Attainment a p t) - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - -- | Modify the UI state appropriately when starting a new scenario. scenarioToUIState :: Bool -> diff --git a/swarm.cabal b/swarm.cabal index d3acdc734..2c68ddd95 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -666,6 +666,8 @@ library swarm-tui Swarm.TUI.Controller Swarm.TUI.Controller.MainEventHandler Swarm.TUI.Controller.REPLEventHandler + Swarm.TUI.Controller.SaveScenario + Swarm.TUI.Controller.UpdateUI Swarm.TUI.Controller.Util Swarm.TUI.Editor.Controller Swarm.TUI.Editor.Json @@ -681,6 +683,7 @@ library swarm-tui Swarm.TUI.Launch.View Swarm.TUI.List Swarm.TUI.Model + Swarm.TUI.Model.Achievements Swarm.TUI.Model.Event Swarm.TUI.Model.Goal Swarm.TUI.Model.Menu From 676f4d48c388ceeae75a514c726a9cbdd478906d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 23 Jun 2024 22:35:12 +0200 Subject: [PATCH 04/55] Restyle --- src/swarm-tui/Swarm/TUI/Controller.hs | 5 +++-- .../Swarm/TUI/Controller/MainEventHandler.hs | 12 ++++++------ src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs | 11 +++++------ src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs | 8 ++++---- src/swarm-tui/Swarm/TUI/Model/Achievements.hs | 6 +++--- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 2 +- 6 files changed, 22 insertions(+), 22 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 68492290d..46c0389d3 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -39,6 +39,7 @@ module Swarm.TUI.Controller ( import Brick hiding (Direction, Location) import Brick.Focus + -- See Note [liftA2 re-export from Prelude] import Brick.Keybindings qualified as B import Brick.Widgets.Dialog @@ -103,8 +104,9 @@ import Swarm.Language.Typecheck ( ) import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log -import Swarm.TUI.Controller.Util +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.UpdateUI +import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) @@ -124,7 +126,6 @@ import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) import System.Clock import Prelude hiding (Applicative (..)) -import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) -- ~~~~ Note [liftA2 re-export from Prelude] -- diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index f97d1a68b..290139d49 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -11,20 +11,20 @@ module Swarm.TUI.Controller.MainEventHandler ( import Brick import Brick.Keybindings qualified as B import Control.Lens as Lens -import Control.Monad (unless, when, void) +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (liftIO) import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.State import Swarm.Game.State.Substate +import Swarm.Game.Step (finishGameTick) +import Swarm.TUI.Controller.UpdateUI (updateUI) import Swarm.TUI.Controller.Util import Swarm.TUI.Model import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI -import System.Clock (getTime, Clock (..), TimeSpec (..)) -import Control.Monad.IO.Class (liftIO) -import Swarm.Game.Step (finishGameTick) -import Swarm.TUI.Controller.UpdateUI (updateUI) +import System.Clock (Clock (..), TimeSpec (..), getTime) mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = @@ -68,7 +68,7 @@ mainEventHandlers = , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do s <- get let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode + let isCreative = s ^. gameState . creativeMode let hasDebug = hasDebugCapability isCreative s when (isPaused && hasDebug) $ do debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs index df738341c..61fdc0172 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -3,13 +3,12 @@ -- -- TODO: describe module Swarm.TUI.Controller.SaveScenario ( - saveScenarioInfoOnFinish, - saveScenarioInfoOnFinishNocheat, - saveScenarioInfoOnQuit, - getNormalizedCurrentScenarioPath, + saveScenarioInfoOnFinish, + saveScenarioInfoOnFinishNocheat, + saveScenarioInfoOnQuit, + getNormalizedCurrentScenarioPath, ) where - -- See Note [liftA2 re-export from Prelude] import Brick.Widgets.List qualified as BL import Control.Lens as Lens @@ -25,11 +24,11 @@ import Swarm.Game.State import Swarm.Game.State.Runtime import Swarm.Game.State.Substate import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements (attainAchievement') import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import System.FilePath (splitDirectories) import Prelude hiding (Applicative (..)) -import Swarm.TUI.Model.Achievements (attainAchievement') getNormalizedCurrentScenarioPath :: (MonadIO m, MonadState AppState m) => m (Maybe FilePath) getNormalizedCurrentScenarioPath = diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs index 75dbece68..9f062ab0f 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} + -- | -- SPDX-License-Identifier: BSD-3-Clause -- @@ -8,9 +9,9 @@ module Swarm.TUI.Controller.UpdateUI ( doGoalUpdates, ) where - import Brick hiding (Direction, Location) import Brick.Focus + -- See Note [liftA2 re-export from Prelude] import Brick.Widgets.List qualified as BL import Control.Applicative (liftA2, pure) @@ -30,6 +31,7 @@ import Swarm.Language.Pretty import Swarm.Language.Typed (Typed (..)) import Swarm.Language.Types import Swarm.Language.Value (Value (VExc, VUnit), envTydefs, prettyValue) +import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) import Swarm.TUI.Controller.Util import Swarm.TUI.Model import Swarm.TUI.Model.Goal @@ -39,7 +41,6 @@ import Swarm.TUI.Model.UI import Swarm.TUI.View.Objective qualified as GR import Witch (into) import Prelude hiding (Applicative (..)) -import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnFinishNocheat) import Data.List.Extra (enumerate) -- | Update the UI. This function is used after running the @@ -155,7 +156,6 @@ updateUI = do || goalOrWinUpdated pure redraw - -- | Either pops up the updated Goals modal -- or pops up the Congratulations (Win) modal, or pops -- up the Condolences (Lose) modal. @@ -248,4 +248,4 @@ doGoalUpdates = do stripCmd :: TDCtx -> Polytype -> Polytype stripCmd tdCtx (Forall xs ty) = case whnfType tdCtx ty of TyCmd resTy -> Forall xs resTy - _ -> Forall xs ty \ No newline at end of file + _ -> Forall xs ty diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs index 678eece96..f25da0e5c 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -3,8 +3,8 @@ -- -- TODO: describe module Swarm.TUI.Model.Achievements ( - attainAchievement, - attainAchievement', + attainAchievement, + attainAchievement', ) where import Control.Lens hiding (from, (<.>)) @@ -36,4 +36,4 @@ attainAchievement' t p a = do a (Attainment a p t) newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements \ No newline at end of file + liftIO $ saveAchievementsInfo $ M.elems newAchievements diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 45c3895ed..7a9649c30 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -82,6 +82,7 @@ import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model +import Swarm.TUI.Model.Achievements import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) import Swarm.TUI.Model.Goal (emptyGoalDisplay) import Swarm.TUI.Model.Name @@ -94,7 +95,6 @@ import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock import System.Exit (exitFailure) -import Swarm.TUI.Model.Achievements createEventHandlers :: KeyConfig SwarmEvent -> IO EventHandlers createEventHandlers config = do From d38770a5dcc09439b235e8b95868413fbc5194cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Wed, 26 Jun 2024 19:54:48 +0200 Subject: [PATCH 05/55] Refactor to use effect style --- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 40 +++++++++++--------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 7a9649c30..6c7acb0dc 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -42,9 +42,10 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) +import Data.Text qualified as T import Data.Text.IO qualified as T import Data.Time (getZonedTime) -import Swarm.Game.Failure (SystemFailure) +import Swarm.Game.Failure (SystemFailure (CustomFailure)) import Swarm.Game.Land import Swarm.Game.Scenario ( ScenarioInputs (..), @@ -94,34 +95,39 @@ import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock -import System.Exit (exitFailure) -createEventHandlers :: KeyConfig SwarmEvent -> IO EventHandlers +createEventHandlers :: + (Has (Throw SystemFailure) sig m) => + KeyConfig SwarmEvent -> + m EventHandlers createEventHandlers config = do mainHandler <- buildDispatcher mainEventHandlers replHandler <- buildDispatcher replEventHandlers return EventHandlers {..} where - -- this error handling code is taken from the brick demo app: + -- this error handling code is modified version of the brick demo app: -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 buildDispatcher handlers = case keyDispatcher config handlers of Right d -> return d Left collisions -> do - putStrLn "Error: some key events have the same keys bound to them." - forM_ collisions $ \(b, hs) -> do - T.putStrLn $ "Handlers with the '" <> BK.ppBinding b <> "' binding:" - forM_ hs $ \h -> do - let trigger = case BK.kehEventTrigger $ BK.khHandler h of - ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" - ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" - desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h - T.putStrLn $ " " <> desc <> " (" <> trigger <> ")" - exitFailure + let e = "Error: some key events have the same keys bound to them.\n" + let hs = flip map collisions $ \(b, hs) -> + let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" + hss = flip map hs $ \h -> + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" + ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + in " " <> desc <> " (" <> trigger <> ")" + in T.intercalate "\n" (hsm : hss) + throwError $ CustomFailure (T.intercalate "\n" $ e : hs) -initKeyHandlingState :: IO KeyEventHandlingState +initKeyHandlingState :: + (Has (Throw SystemFailure) sig m) => + m KeyEventHandlingState initKeyHandlingState = do let cfg = newKeyConfig swarmEvents defaultSwarmBindings [] - handlers <- sendIO $ createEventHandlers cfg + handlers <- createEventHandlers cfg return $ KeyEventHandlingState cfg handlers -- | Initialize the 'AppState' from scratch. @@ -131,7 +137,7 @@ initAppState :: m AppState initAppState opts = do (rs, ui) <- initPersistentState opts - keyHandling <- sendIO initKeyHandlingState + keyHandling <- initKeyHandlingState constructAppState rs ui keyHandling opts -- | Add some system failures to the list of messages in the From a9a12ffb8448d125955a3a4c01af4123277e2d67 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Wed, 26 Jun 2024 20:37:05 +0200 Subject: [PATCH 06/55] Hide accessors --- src/swarm-tui/Swarm/TUI/Model.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 5c8c062e9..65e6597ea 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -47,7 +47,7 @@ module Swarm.TUI.Model ( -- ** Utility logEvent, - KeyEventHandlingState (..), + KeyEventHandlingState (KeyEventHandlingState), EventHandlers (..), keyConfig, keyHandlers, From b9c921b9953f5963a26af173643df7e54ef39d73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Wed, 26 Jun 2024 20:41:53 +0200 Subject: [PATCH 07/55] Fix lints --- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 6c7acb0dc..4d42dd9fe 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -29,7 +29,7 @@ import Control.Effect.Accum import Control.Effect.Lift import Control.Effect.Throw import Control.Lens hiding (from, (<.>)) -import Control.Monad (forM_, guard, void) +import Control.Monad (guard, void) import Control.Monad.Except (ExceptT (..)) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execStateT) @@ -43,7 +43,6 @@ import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import Data.Time (getZonedTime) import Swarm.Game.Failure (SystemFailure (CustomFailure)) import Swarm.Game.Land @@ -110,8 +109,8 @@ createEventHandlers config = do buildDispatcher handlers = case keyDispatcher config handlers of Right d -> return d Left collisions -> do - let e = "Error: some key events have the same keys bound to them.\n" - let hs = flip map collisions $ \(b, hs) -> + let errorHeader = "Error: some key events have the same keys bound to them.\n" + let handlerErrors = flip map collisions $ \(b, hs) -> let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" hss = flip map hs $ \h -> let trigger = case BK.kehEventTrigger $ BK.khHandler h of @@ -120,7 +119,7 @@ createEventHandlers config = do desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h in " " <> desc <> " (" <> trigger <> ")" in T.intercalate "\n" (hsm : hss) - throwError $ CustomFailure (T.intercalate "\n" $ e : hs) + throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) initKeyHandlingState :: (Has (Throw SystemFailure) sig m) => From 40e2ac3b83dddda722be13a14f76dc66f81793aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Thu, 27 Jun 2024 22:05:25 +0200 Subject: [PATCH 08/55] Load keybindings from file and also print them --- app/Main.hs | 18 +++++ .../Swarm/Game/Achievement/Persistence.hs | 8 +-- src/swarm-scenario/Swarm/Game/Failure.hs | 2 +- .../Swarm/Game/ResourceLoading.hs | 41 ++++++++---- src/swarm-tui/Swarm/TUI/Model/Event.hs | 8 +++ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 66 ++++++++++++++++--- 6 files changed, 112 insertions(+), 31 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 79c0b505d..0caa1f139 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,13 +7,16 @@ module Main where import Data.Foldable qualified +import Data.Text.IO qualified as T import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) import Options.Applicative import Swarm.App (appMain) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) import Swarm.Language.Format import Swarm.Language.LSP (lspMain) import Swarm.Language.Parser.Core (LanguageVersion (..)) import Swarm.TUI.Model (AppOpts (..), ColorMode (..)) +import Swarm.TUI.Model.StateUpdate (KeybindingPrint (..), showKeybindings) import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) import Swarm.Version import Swarm.Web (defaultPort) @@ -30,6 +33,7 @@ commitInfo = case gitInfo of data CLI = Run AppOpts + | ListKeybinding KeybindingPrint | Format FormatConfig | LSP | Version @@ -41,6 +45,7 @@ cliParser = [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) + , command "keybindings" (info (ListKeybinding <$> printKeyMode) (progDesc "List the keybindings")) ] ) <|> Run @@ -73,6 +78,9 @@ cliParser = langVer :: Parser LanguageVersion langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5") + printKeyMode :: Parser KeybindingPrint + printKeyMode = flag MarkdownPrint TextPrint (long "markdown" <> help "Print in markdown table format.") + parseFormat :: Parser FormatConfig parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper @@ -125,11 +133,21 @@ showVersion = do up <- getNewerReleaseVersion gitInfo either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up +printKeybindings :: KeybindingPrint -> IO () +printKeybindings p = do + kb <- showKeybindings p + T.putStrLn kb + (iniExists, ini) <- getSwarmConfigIniFile + let iniState = if iniExists then "is" else "can be created" + putStrLn $ "The configuration file " <> iniState <> " at:" + putStrLn ini + main :: IO () main = do cli <- execParser cliInfo case cli of Run opts -> appMain opts + ListKeybinding p -> printKeybindings p Format cfg -> formatSwarmIO cfg LSP -> lspMain Version -> showVersion diff --git a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs index a2bb562d3..6b62808a4 100644 --- a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs @@ -18,17 +18,11 @@ import Data.Yaml qualified as Y import Swarm.Game.Achievement.Attainment import Swarm.Game.Achievement.Definitions import Swarm.Game.Failure -import Swarm.Game.ResourceLoading (getSwarmXdgDataSubdir) +import Swarm.Game.ResourceLoading (getSwarmAchievementsPath) import Swarm.Util.Effect (forMW) import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) import System.FilePath (()) --- | Get a path to the directory where achievement records are --- stored. If the argument is set to @True@, create the directory if --- it does not exist. -getSwarmAchievementsPath :: Bool -> IO FilePath -getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" - -- | Load saved info about achievements from XDG data directory. -- Returns a list of attained achievements. loadAchievementsInfo :: diff --git a/src/swarm-scenario/Swarm/Game/Failure.hs b/src/swarm-scenario/Swarm/Game/Failure.hs index 409fbe9f9..604cc3c20 100644 --- a/src/swarm-scenario/Swarm/Game/Failure.hs +++ b/src/swarm-scenario/Swarm/Game/Failure.hs @@ -40,7 +40,7 @@ data AssetData = AppAsset | NameGeneration | Entities | Terrain | Recipes | Worl deriving (Eq, Show) -- | Overarching enumeration of various assets we can attempt to load. -data Asset = Achievement | Data AssetData | History | Save +data Asset = Achievement | Data AssetData | History | Keybindings | Save deriving (Eq, Show) -- | Enumeration type to distinguish between directories and files. diff --git a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs index 57d3f44b4..bf4ec0df1 100644 --- a/src/swarm-scenario/Swarm/Game/ResourceLoading.hs +++ b/src/swarm-scenario/Swarm/Game/ResourceLoading.hs @@ -5,7 +5,22 @@ -- Description: Fetching game data -- -- Various utilities related to loading game data files. -module Swarm.Game.ResourceLoading where +module Swarm.Game.ResourceLoading ( + -- * Generic data access + getDataDirSafe, + getDataFileNameSafe, + + -- * Concrete data access + getSwarmConfigIniFile, + getSwarmSavePath, + getSwarmHistoryPath, + getSwarmAchievementsPath, + + -- ** Loading text files + readAppData, + NameGenerator (..), + initNameGenerator, +) where import Control.Algebra (Has) import Control.Effect.Lift (Lift, sendIO) @@ -23,7 +38,7 @@ import Paths_swarm (getDataDir) import Swarm.Game.Failure import Swarm.Util import System.Directory ( - XdgDirectory (XdgData), + XdgDirectory (..), createDirectoryIfMissing, doesDirectoryExist, doesFileExist, @@ -83,17 +98,11 @@ getDataFileNameSafe asset name = do then return fp else throwError $ AssetNotLoaded (Data asset) fp $ DoesNotExist File --- | Get a nice message suggesting to download @data@ directory to 'XdgData'. -dataNotFound :: FilePath -> IO LoadingFailure -dataNotFound f = do - d <- getSwarmXdgDataSubdir False "" - let squotes = squote . T.pack - return $ - CustomMessage $ - T.unlines - [ "Could not find the data: " <> squotes f - , "Try downloading the Swarm 'data' directory to: " <> squotes (d "data") - ] +getSwarmConfigIniFile :: IO (Bool, FilePath) +getSwarmConfigIniFile = do + ini <- ( "config.ini") <$> getXdgDirectory XdgConfig "swarm" + iniExists <- doesFileExist ini + return (iniExists, ini) -- | Get path to swarm data, optionally creating necessary -- directories. This could fail if user has bad permissions @@ -120,6 +129,12 @@ getSwarmSavePath createDirs = getSwarmXdgDataSubdir createDirs "saves" getSwarmHistoryPath :: Bool -> IO FilePath getSwarmHistoryPath createDirs = getSwarmXdgDataFile createDirs "history" +-- | Get a path to the directory where achievement records are +-- stored. If the argument is set to @True@, create the directory if +-- it does not exist. +getSwarmAchievementsPath :: Bool -> IO FilePath +getSwarmAchievementsPath createDirs = getSwarmXdgDataSubdir createDirs "achievement" + -- | Read all the @.txt@ files in the @data/@ directory. readAppData :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index cef07f0a4..5e78d989b 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -48,7 +48,15 @@ mainEvents :: KeyEvents MainEvent mainEvents = keyEvents [ ("quit", QuitEvent) + , ("view help", ViewHelpEvent) + , ("view robots", ViewRobotsEvent) + , ("view recipes", ViewRecipesEvent) + , ("view commands", ViewCommandsEvent) + , ("view messages", ViewMessagesEvent) + , ("view structures", ViewStructuresEvent) , ("view goal", ViewGoalEvent) + , ("hide robots", HideRobotsEvent) + , ("debug CESK", ShowCESKDebugEvent) ] defaultMainBindings :: [(MainEvent, [Binding])] diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 4d42dd9fe..aa3d427a4 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -15,6 +15,11 @@ module Swarm.TUI.Model.StateUpdate ( attainAchievement, attainAchievement', scenarioToAppState, + + -- ** Keybindings + initKeyHandlingState, + KeybindingPrint (..), + showKeybindings, ) where import Brick.AttrMap (applyAttrMappings) @@ -44,8 +49,9 @@ import Data.Sequence (Seq) import Data.Text (Text) import Data.Text qualified as T import Data.Time (getZonedTime) -import Swarm.Game.Failure (SystemFailure (CustomFailure)) +import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) import Swarm.Game.Land +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) import Swarm.Game.Scenario ( ScenarioInputs (..), gsiScenarioInputs, @@ -92,7 +98,7 @@ import Swarm.TUI.Model.UI import Swarm.TUI.View.Attribute.Attr (getWorldAttrName, swarmAttrMap) import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) import Swarm.TUI.View.Structure qualified as SR -import Swarm.Util.Effect (asExceptT, withThrow) +import Swarm.Util.Effect (asExceptT, warn, withThrow) import System.Clock createEventHandlers :: @@ -121,22 +127,61 @@ createEventHandlers config = do in T.intercalate "\n" (hsm : hss) throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) +loadKeybindingConfig :: + (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + m [(SwarmEvent, BindingState)] +loadKeybindingConfig = do + (iniExists, ini) <- sendIO getSwarmConfigIniFile + if not iniExists + then return [] + else do + loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini + case loadedCustomBindings of + Left e -> do + warn $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) + return [] + Right bs -> pure $ fromMaybe [] bs + initKeyHandlingState :: - (Has (Throw SystemFailure) sig m) => + (Has (Throw SystemFailure) sig m, Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => m KeyEventHandlingState initKeyHandlingState = do - let cfg = newKeyConfig swarmEvents defaultSwarmBindings [] + customBindings <- loadKeybindingConfig + let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings handlers <- createEventHandlers cfg return $ KeyEventHandlingState cfg handlers +data KeybindingPrint = MarkdownPrint | TextPrint + +showKeybindings :: KeybindingPrint -> IO Text +showKeybindings kPrint = do + bindings <- + runM + . runThrow @SystemFailure + . runAccum (mempty :: Seq SystemFailure) + $ initKeyHandlingState + pure $ case bindings of + Left e -> prettyText e + Right (w, bs) -> + showTable kPrint (bs ^. keyConfig) sections + <> "\n" + <> T.unlines (map prettyText $ F.toList w) + where + showTable = \case + MarkdownPrint -> keybindingMarkdownTable + TextPrint -> keybindingTextTable + sections = + [ ("main", mainEventHandlers) + , ("repl", replEventHandlers) + ] + -- | Initialize the 'AppState' from scratch. initAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => AppOpts -> m AppState initAppState opts = do - (rs, ui) <- initPersistentState opts - keyHandling <- initKeyHandlingState + (rs, ui, keyHandling) <- initPersistentState opts constructAppState rs ui keyHandling opts -- | Add some system failures to the list of messages in the @@ -160,14 +205,15 @@ skipMenu AppOpts {..} = isJust userScenario || isRunningInitialProgram || isJust initPersistentState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => AppOpts -> - m (RuntimeState, UIState) + m (RuntimeState, UIState, KeyEventHandlingState) initPersistentState opts@(AppOpts {..}) = do - (warnings :: Seq SystemFailure, (initRS, initUI)) <- runAccum mempty $ do + (warnings :: Seq SystemFailure, (initRS, initUI, initKs)) <- runAccum mempty $ do rs <- initRuntimeState ui <- initUIState speed (not (skipMenu opts)) cheatMode - return (rs, ui) + ks <- initKeyHandlingState + return (rs, ui, ks) let initRS' = addWarnings initRS (F.toList warnings) - return (initRS', initUI) + return (initRS', initUI, initKs) -- | Construct an 'AppState' from an already-loaded 'RuntimeState' and -- 'UIState', given the 'AppOpts' the app was started with. From f2bad05eacaf541e019e75a8057e2c7a45bfe3c7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Thu, 27 Jun 2024 22:11:22 +0200 Subject: [PATCH 09/55] Swap markdown option --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 0caa1f139..d9240f6a8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -79,7 +79,7 @@ cliParser = langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5") printKeyMode :: Parser KeybindingPrint - printKeyMode = flag MarkdownPrint TextPrint (long "markdown" <> help "Print in markdown table format.") + printKeyMode = flag TextPrint MarkdownPrint (long "markdown" <> help "Print in markdown table format.") parseFormat :: Parser FormatConfig parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper From ebdcabfbbefd1873e3fde3ced7f38d9172e686be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 13:28:39 +0200 Subject: [PATCH 10/55] Only use Throw for keybinding failures --- app/Main.hs | 2 +- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 21 ++++++-------------- 2 files changed, 7 insertions(+), 16 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index d9240f6a8..a4c3c622c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -139,7 +139,7 @@ printKeybindings p = do T.putStrLn kb (iniExists, ini) <- getSwarmConfigIniFile let iniState = if iniExists then "is" else "can be created" - putStrLn $ "The configuration file " <> iniState <> " at:" + putStrLn $ "\nThe configuration file " <> iniState <> " at:" putStrLn ini main :: IO () diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index aa3d427a4..8702bea57 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -98,7 +98,7 @@ import Swarm.TUI.Model.UI import Swarm.TUI.View.Attribute.Attr (getWorldAttrName, swarmAttrMap) import Swarm.TUI.View.Attribute.CustomStyling (toAttrPair) import Swarm.TUI.View.Structure qualified as SR -import Swarm.Util.Effect (asExceptT, warn, withThrow) +import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock createEventHandlers :: @@ -128,7 +128,7 @@ createEventHandlers config = do throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) loadKeybindingConfig :: - (Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => m [(SwarmEvent, BindingState)] loadKeybindingConfig = do (iniExists, ini) <- sendIO getSwarmConfigIniFile @@ -137,13 +137,11 @@ loadKeybindingConfig = do else do loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini case loadedCustomBindings of - Left e -> do - warn $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) - return [] + Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) Right bs -> pure $ fromMaybe [] bs initKeyHandlingState :: - (Has (Throw SystemFailure) sig m, Has (Accum (Seq SystemFailure)) sig m, Has (Lift IO) sig m) => + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => m KeyEventHandlingState initKeyHandlingState = do customBindings <- loadKeybindingConfig @@ -155,17 +153,10 @@ data KeybindingPrint = MarkdownPrint | TextPrint showKeybindings :: KeybindingPrint -> IO Text showKeybindings kPrint = do - bindings <- - runM - . runThrow @SystemFailure - . runAccum (mempty :: Seq SystemFailure) - $ initKeyHandlingState + bindings <- runM $ runThrow @SystemFailure initKeyHandlingState pure $ case bindings of Left e -> prettyText e - Right (w, bs) -> - showTable kPrint (bs ^. keyConfig) sections - <> "\n" - <> T.unlines (map prettyText $ F.toList w) + Right bs -> showTable kPrint (bs ^. keyConfig) sections where showTable = \case MarkdownPrint -> keybindingMarkdownTable From 7522fd2c359e6c41c663cc6814f418999b022f9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 14:53:34 +0200 Subject: [PATCH 11/55] Move pause and single tick to event handlers --- .../Swarm/Game/Achievement/Persistence.hs | 2 - src/swarm-tui/Swarm/TUI/Controller.hs | 146 +--------------- .../TUI/Controller/FrameEventHandling.hs | 157 ++++++++++++++++++ .../Swarm/TUI/Controller/MainEventHandler.hs | 16 ++ src/swarm-tui/Swarm/TUI/Model/Event.hs | 6 + swarm.cabal | 1 + 6 files changed, 181 insertions(+), 147 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs diff --git a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs index 6b62808a4..a90f7a6ab 100644 --- a/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs +++ b/src/swarm-engine/Swarm/Game/Achievement/Persistence.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - -- | -- SPDX-License-Identifier: BSD-3-Clause -- Description: Achievements load/save diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 46c0389d3..c57cc89e5 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -13,11 +13,8 @@ module Swarm.TUI.Controller ( -- ** Handling 'Swarm.TUI.Model.Frame' events runFrameUI, - runFrame, ticksPerFrameCap, - runFrameTicks, runGameTickUI, - runGameTick, updateUI, -- ** REPL panel @@ -54,7 +51,6 @@ import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execState) -import Data.Bits import Data.Int (Int32) import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty (..)) @@ -72,7 +68,6 @@ import Data.Vector qualified as V import Graphics.Vty qualified as V import Linear import Swarm.Game.Achievement.Definitions -import Swarm.Game.Achievement.Persistence import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), continue) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land @@ -85,7 +80,6 @@ import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Runtime import Swarm.Game.State.Substate -import Swarm.Game.Step (gameTick) import Swarm.Language.Capability ( Capability (CGod), constCaps, @@ -104,6 +98,7 @@ import Swarm.Language.Typecheck ( ) import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log +import Swarm.TUI.Controller.FrameEventHandling import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Controller.Util @@ -124,7 +119,6 @@ import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) -import System.Clock import Prelude hiding (Applicative (..)) -- ~~~~ Note [liftA2 re-export from Prelude] @@ -319,11 +313,6 @@ handleMainEvent ev = do MessagesModal -> do gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks _ -> return () - -- pausing and stepping - ControlChar 'p' | isRunning -> safeTogglePause - ControlChar 'o' | isRunning -> do - gameState . temporal . runStatus .= ManualPause - runGameTickUI -- speed controls ControlChar 'x' | isRunning -> modify $ adjustTPS (+) ControlChar 'z' | isRunning -> modify $ adjustTPS (-) @@ -486,139 +475,6 @@ quitGame = do NoMenu -> halt _ -> uiState . uiPlaying .= False ------------------------------------------------------------- --- Handling Frame events ------------------------------------------------------------- - --- | Run the game for a single /frame/ (/i.e./ screen redraw), then --- update the UI. Depending on how long it is taking to draw each --- frame, and how many ticks per second we are trying to achieve, --- this may involve stepping the game any number of ticks (including --- zero). -runFrameUI :: EventM Name AppState () -runFrameUI = do - runFrame - redraw <- updateUI - unless redraw continueWithoutRedraw - --- | Run the game for a single frame, without updating the UI. -runFrame :: EventM Name AppState () -runFrame = do - -- Reset the needsRedraw flag. While processing the frame and stepping the robots, - -- the flag will get set to true if anything changes that requires redrawing the - -- world (e.g. a robot moving or disappearing). - gameState . needsRedraw .= False - - -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . - - -- Find out how long the previous frame took, by subtracting the - -- previous time from the current time. - prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) - curTime <- liftIO $ getTime Monotonic - let frameTime = diffTimeSpec curTime prevTime - - -- Remember now as the new previous time. - uiState . uiGameplay . uiTiming . lastFrameTime .= curTime - - -- We now have some additional accumulated time to play with. The - -- idea is to now "catch up" by doing as many ticks as are supposed - -- to fit in the accumulated time. Some accumulated time may be - -- left over, but it will roll over to the next frame. This way we - -- deal smoothly with things like a variable frame rate, the frame - -- rate not being a nice multiple of the desired ticks per second, - -- etc. - uiState . uiGameplay . uiTiming . accumulatedTime += frameTime - - -- Figure out how many ticks per second we're supposed to do, - -- and compute the timestep `dt` for a single tick. - lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) - let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds - dt - | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) - | otherwise = oneSecond * (1 `shiftL` abs lgTPS) - - -- Update TPS/FPS counters every second - infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) - let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime - when (updateTime >= oneSecond) $ do - -- Wait for at least one second to have elapsed - when (infoUpdateTime /= 0) $ do - -- set how much frame got processed per second - frames <- use (uiState . uiGameplay . uiTiming . frameCount) - uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime - - -- set how much ticks got processed per frame - uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) - uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames - - -- ensure this frame gets drawn - gameState . needsRedraw .= True - - -- Reset the counter and wait another seconds for the next update - uiState . uiGameplay . uiTiming . tickCount .= 0 - uiState . uiGameplay . uiTiming . frameCount .= 0 - uiState . uiGameplay . uiTiming . lastInfoTime .= curTime - - -- Increment the frame count - uiState . uiGameplay . uiTiming . frameCount += 1 - - -- Now do as many ticks as we need to catch up. - uiState . uiGameplay . uiTiming . frameTickCount .= 0 - runFrameTicks (fromNanoSecs dt) - -ticksPerFrameCap :: Int -ticksPerFrameCap = 30 - --- | Do zero or more ticks, with each tick notionally taking the given --- timestep, until we have used up all available accumulated time, --- OR until we have hit the cap on ticks per frame, whichever comes --- first. -runFrameTicks :: TimeSpec -> EventM Name AppState () -runFrameTicks dt = do - a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) - t <- use (uiState . uiGameplay . uiTiming . frameTickCount) - - -- Ensure there is still enough time left, and we haven't hit the - -- tick limit for this frame. - when (a >= dt && t < ticksPerFrameCap) $ do - -- If so, do a tick, count it, subtract dt from the accumulated time, - -- and loop! - runGameTick - Brick.zoom (uiState . uiGameplay . uiTiming) $ do - tickCount += 1 - frameTickCount += 1 - accumulatedTime -= dt - runFrameTicks dt - --- | Run the game for a single tick, and update the UI. -runGameTickUI :: EventM Name AppState () -runGameTickUI = runGameTick >> void updateUI - -updateAchievements :: EventM Name AppState () -updateAchievements = do - -- Merge the in-game achievements with the master list in UIState - achievementsFromGame <- use $ gameState . discovery . gameAchievements - let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame - - oldMasterAchievementsList <- use $ uiState . uiAchievements - uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements - - -- Don't save to disk unless there was a change in the attainment list. - let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList - unless (null incrementalAchievements) $ do - -- TODO: #916 This is where new achievements would be displayed in a popup - newAchievements <- use $ uiState . uiAchievements - liftIO $ saveAchievementsInfo $ M.elems newAchievements - --- | Run the game for a single tick (/without/ updating the UI). --- Every robot is given a certain amount of maximum computation to --- perform a single world action (like moving, turning, grabbing, --- etc.). -runGameTick :: EventM Name AppState () -runGameTick = do - ticked <- zoomGameState gameTick - when ticked updateAchievements - ------------------------------------------------------------ -- REPL events ------------------------------------------------------------ diff --git a/src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs b/src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs new file mode 100644 index 000000000..eb5f7897b --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs @@ -0,0 +1,157 @@ +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Handling 'Swarm.TUI.Model.Frame' events. +module Swarm.TUI.Controller.FrameEventHandling ( + runFrameUI, + runGameTickUI, + + -- ** Constants + ticksPerFrameCap, +) where + +import Brick +import Control.Lens as Lens +import Control.Monad (unless, void, when) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Bits +import Data.Map qualified as M +import Swarm.Game.Achievement.Definitions +import Swarm.Game.Achievement.Persistence +import Swarm.Game.State +import Swarm.Game.State.Substate +import Swarm.Game.Step (gameTick) +import Swarm.TUI.Controller.UpdateUI +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.UI +import System.Clock + +ticksPerFrameCap :: Int +ticksPerFrameCap = 30 + +-- | Run the game for a single /frame/ (/i.e./ screen redraw), then +-- update the UI. Depending on how long it is taking to draw each +-- frame, and how many ticks per second we are trying to achieve, +-- this may involve stepping the game any number of ticks (including +-- zero). +runFrameUI :: EventM Name AppState () +runFrameUI = do + runFrame + redraw <- updateUI + unless redraw continueWithoutRedraw + +-- | Run the game for a single frame, without updating the UI. +runFrame :: EventM Name AppState () +runFrame = do + -- Reset the needsRedraw flag. While processing the frame and stepping the robots, + -- the flag will get set to true if anything changes that requires redrawing the + -- world (e.g. a robot moving or disappearing). + gameState . needsRedraw .= False + + -- The logic here is taken from https://gafferongames.com/post/fix_your_timestep/ . + + -- Find out how long the previous frame took, by subtracting the + -- previous time from the current time. + prevTime <- use (uiState . uiGameplay . uiTiming . lastFrameTime) + curTime <- liftIO $ getTime Monotonic + let frameTime = diffTimeSpec curTime prevTime + + -- Remember now as the new previous time. + uiState . uiGameplay . uiTiming . lastFrameTime .= curTime + + -- We now have some additional accumulated time to play with. The + -- idea is to now "catch up" by doing as many ticks as are supposed + -- to fit in the accumulated time. Some accumulated time may be + -- left over, but it will roll over to the next frame. This way we + -- deal smoothly with things like a variable frame rate, the frame + -- rate not being a nice multiple of the desired ticks per second, + -- etc. + uiState . uiGameplay . uiTiming . accumulatedTime += frameTime + + -- Figure out how many ticks per second we're supposed to do, + -- and compute the timestep `dt` for a single tick. + lgTPS <- use (uiState . uiGameplay . uiTiming . lgTicksPerSecond) + let oneSecond = 1_000_000_000 -- one second = 10^9 nanoseconds + dt + | lgTPS >= 0 = oneSecond `div` (1 `shiftL` lgTPS) + | otherwise = oneSecond * (1 `shiftL` abs lgTPS) + + -- Update TPS/FPS counters every second + infoUpdateTime <- use (uiState . uiGameplay . uiTiming . lastInfoTime) + let updateTime = toNanoSecs $ diffTimeSpec curTime infoUpdateTime + when (updateTime >= oneSecond) $ do + -- Wait for at least one second to have elapsed + when (infoUpdateTime /= 0) $ do + -- set how much frame got processed per second + frames <- use (uiState . uiGameplay . uiTiming . frameCount) + uiState . uiGameplay . uiTiming . uiFPS .= fromIntegral (frames * fromInteger oneSecond) / fromIntegral updateTime + + -- set how much ticks got processed per frame + uiTicks <- use (uiState . uiGameplay . uiTiming . tickCount) + uiState . uiGameplay . uiTiming . uiTPF .= fromIntegral uiTicks / fromIntegral frames + + -- ensure this frame gets drawn + gameState . needsRedraw .= True + + -- Reset the counter and wait another seconds for the next update + uiState . uiGameplay . uiTiming . tickCount .= 0 + uiState . uiGameplay . uiTiming . frameCount .= 0 + uiState . uiGameplay . uiTiming . lastInfoTime .= curTime + + -- Increment the frame count + uiState . uiGameplay . uiTiming . frameCount += 1 + + -- Now do as many ticks as we need to catch up. + uiState . uiGameplay . uiTiming . frameTickCount .= 0 + runFrameTicks (fromNanoSecs dt) + +-- | Do zero or more ticks, with each tick notionally taking the given +-- timestep, until we have used up all available accumulated time, +-- OR until we have hit the cap on ticks per frame, whichever comes +-- first. +runFrameTicks :: TimeSpec -> EventM Name AppState () +runFrameTicks dt = do + a <- use (uiState . uiGameplay . uiTiming . accumulatedTime) + t <- use (uiState . uiGameplay . uiTiming . frameTickCount) + + -- Ensure there is still enough time left, and we haven't hit the + -- tick limit for this frame. + when (a >= dt && t < ticksPerFrameCap) $ do + -- If so, do a tick, count it, subtract dt from the accumulated time, + -- and loop! + runGameTick + Brick.zoom (uiState . uiGameplay . uiTiming) $ do + tickCount += 1 + frameTickCount += 1 + accumulatedTime -= dt + runFrameTicks dt + +-- | Run the game for a single tick, and update the UI. +runGameTickUI :: EventM Name AppState () +runGameTickUI = runGameTick >> void updateUI + +updateAchievements :: EventM Name AppState () +updateAchievements = do + -- Merge the in-game achievements with the master list in UIState + achievementsFromGame <- use $ gameState . discovery . gameAchievements + let wrappedGameAchievements = M.mapKeys GameplayAchievement achievementsFromGame + + oldMasterAchievementsList <- use $ uiState . uiAchievements + uiState . uiAchievements %= M.unionWith (<>) wrappedGameAchievements + + -- Don't save to disk unless there was a change in the attainment list. + let incrementalAchievements = wrappedGameAchievements `M.difference` oldMasterAchievementsList + unless (null incrementalAchievements) $ do + -- TODO: #916 This is where new achievements would be displayed in a popup + newAchievements <- use $ uiState . uiAchievements + liftIO $ saveAchievementsInfo $ M.elems newAchievements + +-- | Run the game for a single tick (/without/ updating the UI). +-- Every robot is given a certain amount of maximum computation to +-- perform a single world action (like moving, turning, grabbing, +-- etc.). +runGameTick :: EventM Name AppState () +runGameTick = do + ticked <- zoomGameState gameTick + when ticked updateAchievements diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index 290139d49..ae464b3c6 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -18,6 +18,7 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStruct import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.Game.Step (finishGameTick) +import Swarm.TUI.Controller.FrameEventHandling (runGameTickUI) import Swarm.TUI.Controller.UpdateUI (updateUI) import Swarm.TUI.Controller.Util import Swarm.TUI.Model @@ -26,6 +27,9 @@ import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI import System.Clock (Clock (..), TimeSpec (..), getTime) +-- | Main keybindings event handler while running the game itself. +-- +-- See 'Swarm.TUI.Controller.handleMainEvent'. mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = [ B.onEvent (Main QuitEvent) "Open quit game dialog" $ do @@ -75,4 +79,16 @@ mainEventHandlers = if debug then gameState . temporal . gameStep .= RobotStep SBefore else zoomGameState finishGameTick >> void updateUI + , B.onEvent (Main PauseEvent) "Pause or unpause the game" $ whenRunning safeTogglePause + , B.onEvent (Main RunSingleTickEvent) "Run game for a single tick" $ whenRunning $ do + gameState . temporal . runStatus .= ManualPause + runGameTickUI ] + +isRunning :: EventM Name AppState Bool +isRunning = do + mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType + return $ maybe True isRunningModal mt + +whenRunning :: EventM Name AppState () -> EventM Name AppState () +whenRunning a = isRunning >>= \r -> when r a diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 5e78d989b..cad2fc8d0 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -42,6 +42,8 @@ data MainEvent | ViewGoalEvent | HideRobotsEvent | ShowCESKDebugEvent + | PauseEvent + | RunSingleTickEvent deriving (Eq, Ord, Show, Enum) mainEvents :: KeyEvents MainEvent @@ -57,6 +59,8 @@ mainEvents = , ("view goal", ViewGoalEvent) , ("hide robots", HideRobotsEvent) , ("debug CESK", ShowCESKDebugEvent) + , ("pause", PauseEvent) + , ("run single tick", RunSingleTickEvent) ] defaultMainBindings :: [(MainEvent, [Binding])] @@ -71,6 +75,8 @@ defaultMainBindings = , (ViewGoalEvent, [ctrl 'g']) , (HideRobotsEvent, [meta 'h']) , (ShowCESKDebugEvent, [meta 'd']) + , (PauseEvent, [ctrl 'p']) + , (RunSingleTickEvent, [ctrl 'o']) ] data REPLEvent diff --git a/swarm.cabal b/swarm.cabal index 2c68ddd95..392e2ca1e 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -664,6 +664,7 @@ library swarm-tui exposed-modules: Swarm.TUI.Border Swarm.TUI.Controller + Swarm.TUI.Controller.FrameEventHandling Swarm.TUI.Controller.MainEventHandler Swarm.TUI.Controller.REPLEventHandler Swarm.TUI.Controller.SaveScenario From 66019d2dbce73c76557f27e8fa4625859b41cd3f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 15:42:07 +0200 Subject: [PATCH 12/55] Refactor to use pattern matching in Event.hs --- .../Swarm/TUI/Controller/REPLEventHandler.hs | 3 + src/swarm-tui/Swarm/TUI/Model/Event.hs | 101 ++++++++++-------- 2 files changed, 60 insertions(+), 44 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs index 5908d89a6..33c2f3d1a 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs @@ -24,6 +24,9 @@ import Swarm.TUI.Model.Event import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI +-- | Handle a user input key event for the REPL. +-- +-- See 'Swarm.TUI.Controller.handleREPLEvent'. replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] replEventHandlers = [ B.onEvent (REPL CancelRunningProgramEvent) "Cancel running base robot program" $ do diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index cad2fc8d0..92063d511 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -31,6 +31,13 @@ defaultSwarmBindings = embedB Main defaultMainBindings ++ embedB REPL defaultRep where embedB f = map (first f) +-- ---------------------------------------------- +-- MAIN EVENTS +-- ---------------------------------------------- + +-- | Main abstract keybinding events while running the game itself. +-- +-- See 'Swarm.TUI.Controller.MainEventHandler.'. data MainEvent = QuitEvent | ViewHelpEvent @@ -44,65 +51,71 @@ data MainEvent | ShowCESKDebugEvent | PauseEvent | RunSingleTickEvent - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent -mainEvents = - keyEvents - [ ("quit", QuitEvent) - , ("view help", ViewHelpEvent) - , ("view robots", ViewRobotsEvent) - , ("view recipes", ViewRecipesEvent) - , ("view commands", ViewCommandsEvent) - , ("view messages", ViewMessagesEvent) - , ("view structures", ViewStructuresEvent) - , ("view goal", ViewGoalEvent) - , ("hide robots", HideRobotsEvent) - , ("debug CESK", ShowCESKDebugEvent) - , ("pause", PauseEvent) - , ("run single tick", RunSingleTickEvent) - ] +mainEvents = allKeyEvents $ \case + QuitEvent -> "quit" + ViewHelpEvent -> "view help" + ViewRobotsEvent -> "view robots" + ViewRecipesEvent -> "view recipes" + ViewCommandsEvent -> "view commands" + ViewMessagesEvent -> "view messages" + ViewStructuresEvent -> "view structures" + ViewGoalEvent -> "view goal" + HideRobotsEvent -> "hide robots" + ShowCESKDebugEvent -> "debug CESK" + PauseEvent -> "pause" + RunSingleTickEvent -> "run single tick" defaultMainBindings :: [(MainEvent, [Binding])] -defaultMainBindings = - [ (QuitEvent, [ctrl 'q']) - , (ViewHelpEvent, [fn 1]) - , (ViewRobotsEvent, [fn 2]) - , (ViewRecipesEvent, [fn 3]) - , (ViewCommandsEvent, [fn 4]) - , (ViewMessagesEvent, [fn 5]) - , (ViewStructuresEvent, [fn 6]) - , (ViewGoalEvent, [ctrl 'g']) - , (HideRobotsEvent, [meta 'h']) - , (ShowCESKDebugEvent, [meta 'd']) - , (PauseEvent, [ctrl 'p']) - , (RunSingleTickEvent, [ctrl 'o']) - ] +defaultMainBindings = allBindings $ \case + QuitEvent -> [ctrl 'q'] + ViewHelpEvent -> [fn 1] + ViewRobotsEvent -> [fn 2] + ViewRecipesEvent -> [fn 3] + ViewCommandsEvent -> [fn 4] + ViewMessagesEvent -> [fn 5] + ViewStructuresEvent -> [fn 6] + ViewGoalEvent -> [ctrl 'g'] + HideRobotsEvent -> [meta 'h'] + ShowCESKDebugEvent -> [meta 'd'] + PauseEvent -> [ctrl 'p'] + RunSingleTickEvent -> [ctrl 'o'] +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +-- | REPL abstract keybinding events. +-- +-- See 'Swarm.TUI.Controller.REPLEventHandler'. data REPLEvent = CancelRunningProgramEvent | TogglePilotingModeEvent | ToggleCustomKeyHandlingEvent - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Show, Enum, Bounded) replEvents :: KeyEvents REPLEvent -replEvents = - keyEvents - [ ("cancel running program", CancelRunningProgramEvent) - , ("toggle custom key handling", ToggleCustomKeyHandlingEvent) - , ("toggle piloting mode", TogglePilotingModeEvent) - ] +replEvents = allKeyEvents $ \case + CancelRunningProgramEvent -> "cancel running program" + ToggleCustomKeyHandlingEvent -> "toggle custom key handling" + TogglePilotingModeEvent -> "toggle piloting mode" defaultReplBindings :: [(REPLEvent, [Binding])] -defaultReplBindings = - [ (CancelRunningProgramEvent, [ctrl 'c', bind V.KEsc]) - , (TogglePilotingModeEvent, [meta 'p']) - , (ToggleCustomKeyHandlingEvent, [meta 'k']) - ] +defaultReplBindings = allBindings $ \case + CancelRunningProgramEvent -> [ctrl 'c', bind V.KEsc] + TogglePilotingModeEvent -> [meta 'p'] + ToggleCustomKeyHandlingEvent -> [meta 'k'] -- ---------------- - --- * Helper methods +-- Helper methods embed :: Ord b => (a -> b) -> KeyEvents a -> [(Text, b)] embed f = map (fmap f) . keyEventsList + +allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e +allKeyEvents f = keyEvents $ map (\e -> (f e, e)) [minBound .. maxBound] + +allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] +allBindings f = map (\e -> (e, f e)) [minBound .. maxBound] From 55404f05c4c5eae6ed8ac0bc649f805750f1982f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 16:47:41 +0200 Subject: [PATCH 13/55] Refactor to use pattern matching in event handlers This also fixes missing handler for messages. --- .../Swarm/TUI/Controller/MainEventHandler.hs | 135 +++++++++++------- .../Swarm/TUI/Controller/REPLEventHandler.hs | 68 +++++---- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 12 ++ 3 files changed, 133 insertions(+), 82 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index ae464b3c6..1ba35e7e9 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -31,59 +31,88 @@ import System.Clock (Clock (..), TimeSpec (..), getTime) -- -- See 'Swarm.TUI.Controller.handleMainEvent'. mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] -mainEventHandlers = - [ B.onEvent (Main QuitEvent) "Open quit game dialog" $ do - s <- get - case s ^. gameState . winCondition of - WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal - WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal - _ -> toggleModal QuitModal - , B.onEvent (Main ViewHelpEvent) "View Help screen" $ toggleModal HelpModal - , B.onEvent (Main ViewRobotsEvent) "View Robots screen" $ toggleModal RobotsModal - , B.onEvent (Main ViewRecipesEvent) "View Recipes screen" $ do - s <- get - unless (null (s ^. gameState . discovery . availableRecipes . notificationsContent)) $ do - toggleModal RecipesModal - gameState . discovery . availableRecipes . notificationsCount .= 0 - , B.onEvent (Main ViewCommandsEvent) "View Commands screen" $ do - s <- get - unless (null (s ^. gameState . discovery . availableCommands . notificationsContent)) $ do - toggleModal CommandsModal - gameState . discovery . availableCommands . notificationsCount .= 0 - , B.onEvent (Main ViewStructuresEvent) "View Structures screen" $ do - s <- get - unless (null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions) $ do - toggleModal StructuresModal - , B.onEvent (Main ViewGoalEvent) "View scenario goal description" $ do - s <- get - if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent - then toggleModal GoalModal - else continueWithoutRedraw - , B.onEvent (Main HideRobotsEvent) "Hide robots for a few ticks" $ do - t <- liftIO $ getTime Monotonic - h <- use $ uiState . uiGameplay . uiHideRobotsUntil - case h >= t of - -- ignore repeated keypresses - True -> continueWithoutRedraw - -- hide for two seconds - False -> do - uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 - invalidateCacheEntry WorldCache - , B.onEvent (Main ShowCESKDebugEvent) "Show active robot CESK machine debugging line" $ do - s <- get - let isPaused = s ^. gameState . temporal . paused - let isCreative = s ^. gameState . creativeMode - let hasDebug = hasDebugCapability isCreative s - when (isPaused && hasDebug) $ do - debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not - if debug - then gameState . temporal . gameStep .= RobotStep SBefore - else zoomGameState finishGameTick >> void updateUI - , B.onEvent (Main PauseEvent) "Pause or unpause the game" $ whenRunning safeTogglePause - , B.onEvent (Main RunSingleTickEvent) "Run game for a single tick" $ whenRunning $ do - gameState . temporal . runStatus .= ManualPause - runGameTickUI - ] +mainEventHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + +toggleQuitGameDialog :: EventM Name AppState () +toggleQuitGameDialog = do + s <- get + case s ^. gameState . winCondition of + WinConditions (Won _ _) _ -> toggleModal $ ScenarioEndModal WinModal + WinConditions (Unwinnable _) _ -> toggleModal $ ScenarioEndModal LoseModal + _ -> toggleModal QuitModal + +toggleGameModal :: Foldable t => ModalType -> Getter GameState (t a) -> EventM Name AppState Bool +toggleGameModal m l = do + s <- get + let nothingToShow = null $ s ^. gameState . l + unless nothingToShow $ toggleModal m + return nothingToShow + +toggleDiscoveryModal :: Foldable t => ModalType -> Lens' Discovery (t a) -> EventM Name AppState () +toggleDiscoveryModal m l = void $ toggleGameModal m (discovery . l) + +toggleDiscoveryNotificationModal :: ModalType -> Lens' Discovery (Notifications a) -> EventM Name AppState () +toggleDiscoveryNotificationModal m l = do + nothingToShow <- toggleGameModal m (discovery . l . notificationsContent) + unless nothingToShow $ gameState . discovery . l . notificationsCount .= 0 + +toggleMessagesModal :: EventM Name AppState () +toggleMessagesModal = do + s <- get + nothingToShow <- toggleGameModal MessagesModal (messageNotifications . notificationsContent) + unless nothingToShow $ gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks + +viewGoal :: EventM Name AppState () +viewGoal = do + s <- get + if hasAnythingToShow $ s ^. uiState . uiGameplay . uiGoal . goalsContent + then toggleModal GoalModal + else continueWithoutRedraw + +hideRobots :: EventM Name AppState () +hideRobots = do + t <- liftIO $ getTime Monotonic + h <- use $ uiState . uiGameplay . uiHideRobotsUntil + case h >= t of + -- ignore repeated keypresses + True -> continueWithoutRedraw + -- hide for two seconds + False -> do + uiState . uiGameplay . uiHideRobotsUntil .= t + TimeSpec 2 0 + invalidateCacheEntry WorldCache + +showCESKDebug :: EventM Name AppState () +showCESKDebug = do + s <- get + let isPaused = s ^. gameState . temporal . paused + let isCreative = s ^. gameState . creativeMode + let hasDebug = hasDebugCapability isCreative s + when (isPaused && hasDebug) $ do + debug <- uiState . uiGameplay . uiShowDebug Lens.<%= not + if debug + then gameState . temporal . gameStep .= RobotStep SBefore + else zoomGameState finishGameTick >> void updateUI + +runSingleTick :: EventM Name AppState () +runSingleTick = do + gameState . temporal . runStatus .= ManualPause + runGameTickUI + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- isRunning :: EventM Name AppState Bool isRunning = do diff --git a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs index 33c2f3d1a..dc1f3f3bc 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs @@ -28,32 +28,42 @@ import Swarm.TUI.Model.UI -- -- See 'Swarm.TUI.Controller.handleREPLEvent'. replEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] -replEventHandlers = - [ B.onEvent (REPL CancelRunningProgramEvent) "Cancel running base robot program" $ do - -- Handled here so we can always cancel the currently running - -- base program no matter what REPL control mode we are in. - working <- use $ gameState . gameControls . replWorking - when working $ gameState . baseRobot . machine %= cancel - Brick.zoom (uiState . uiGameplay . uiREPL) $ do - replPromptType .= CmdPrompt [] - replPromptText .= "" - , B.onEvent (REPL TogglePilotingModeEvent) "Toggle piloting mode" . onlyCreative $ do - s <- get - let theRepl = s ^. uiState . uiGameplay . uiREPL - uinput = theRepl ^. replPromptText - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - case curMode of - Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing - _ -> - if T.null uinput - then uiState . uiGameplay . uiREPL . replControlMode .= Piloting - else do - let err = REPLError "Please clear the REPL before engaging pilot mode." - uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err - invalidateCacheEntry REPLHistoryCache - , B.onEvent (REPL ToggleCustomKeyHandlingEvent) "Toggle custom key handling mode" $ do - s <- get - when (isJust (s ^. gameState . gameControls . inputHandler)) $ do - curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode - (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling - ] +replEventHandlers = allHandlers REPL $ \case + CancelRunningProgramEvent -> ("Cancel running base robot program", cancelRunningBase) + TogglePilotingModeEvent -> ("Toggle piloting mode", onlyCreative togglePilotingMode) + ToggleCustomKeyHandlingEvent -> ("Toggle custom key handling mode", toggleCustomKeyHandling) + +-- | Cancel the running base CESK machine and clear REPL input text. +-- +-- It is handled in top REPL handler so we can always cancel the currently running +-- base program no matter what REPL control mode we are in. +cancelRunningBase :: EventM Name AppState () +cancelRunningBase = do + working <- use $ gameState . gameControls . replWorking + when working $ gameState . baseRobot . machine %= cancel + Brick.zoom (uiState . uiGameplay . uiREPL) $ do + replPromptType .= CmdPrompt [] + replPromptText .= "" + +togglePilotingMode :: EventM Name AppState () +togglePilotingMode = do + s <- get + let theRepl = s ^. uiState . uiGameplay . uiREPL + uinput = theRepl ^. replPromptText + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + case curMode of + Piloting -> uiState . uiGameplay . uiREPL . replControlMode .= Typing + _ -> + if T.null uinput + then uiState . uiGameplay . uiREPL . replControlMode .= Piloting + else do + let err = REPLError "Please clear the REPL before engaging pilot mode." + uiState . uiGameplay . uiREPL . replHistory %= addREPLItem err + invalidateCacheEntry REPLHistoryCache + +toggleCustomKeyHandling :: EventM Name AppState () +toggleCustomKeyHandling = do + s <- get + when (isJust (s ^. gameState . gameControls . inputHandler)) $ do + curMode <- use $ uiState . uiGameplay . uiREPL . replControlMode + (uiState . uiGameplay . uiREPL . replControlMode) .= case curMode of Handling -> Typing; _ -> Handling diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 36ae407dd..86cc58b79 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -6,6 +6,7 @@ module Swarm.TUI.Controller.Util where import Brick hiding (Direction) import Brick.Focus +import Brick.Keybindings import Control.Carrier.Lift qualified as Fused import Control.Carrier.State.Lazy qualified as Fused import Control.Lens @@ -15,6 +16,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) import Control.Monad.State (MonadState) import Data.Map qualified as M import Data.Set qualified as S +import Data.Text (Text) import Graphics.Vty qualified as V import Swarm.Effect (TimeIOC, runTimeIO) import Swarm.Game.Device @@ -167,3 +169,13 @@ onlyCreative :: (MonadState AppState m) => m () -> m () onlyCreative a = do c <- use $ gameState . creativeMode when c a + +-- | Create a list of handlers with embedding events and using pattern matching. +allHandlers :: + (Ord e2, Enum e1, Bounded e1) => + (e1 -> e2) -> + (e1 -> (Text, EventM Name AppState ())) -> + [KeyEventHandler e2 (EventM Name AppState)] +allHandlers eEmbed f = map handleEvent1 [minBound .. maxBound] + where + handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a From 6fb883c9c47d83d2b2f8597765609b47f3685cd3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 17:37:10 +0200 Subject: [PATCH 14/55] Move speed controls to new handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 8 -------- src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs | 6 ++++++ src/swarm-tui/Swarm/TUI/Model/Event.hs | 7 ++++++- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index c57cc89e5..4c3a24e4c 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -28,7 +28,6 @@ module Swarm.TUI.Controller ( handleWorldEvent, keyToDir, scrollView, - adjustTPS, -- ** Info panel handleInfoPanelEvent, @@ -313,9 +312,6 @@ handleMainEvent ev = do MessagesModal -> do gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks _ -> return () - -- speed controls - ControlChar 'x' | isRunning -> modify $ adjustTPS (+) - ControlChar 'z' | isRunning -> modify $ adjustTPS (-) -- special keys that work on all panels MetaChar 'w' -> setFocus WorldPanel MetaChar 'e' -> setFocus RobotPanel @@ -857,10 +853,6 @@ keyToDir (V.KChar 'k') = north keyToDir (V.KChar 'l') = east keyToDir _ = zero --- | Adjust the ticks per second speed. -adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState -adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) - ------------------------------------------------------------ -- Robot panel events ------------------------------------------------------------ diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index 1ba35e7e9..5e1463e58 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -44,6 +44,8 @@ mainEventHandlers = allHandlers Main $ \case ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) toggleQuitGameDialog :: EventM Name AppState () toggleQuitGameDialog = do @@ -110,6 +112,10 @@ runSingleTick = do gameState . temporal . runStatus .= ManualPause runGameTickUI +-- | Adjust the ticks per second speed. +adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState +adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) + -- ---------------------------------------------- -- HELPER UTILS -- ---------------------------------------------- diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 92063d511..91eb8cf04 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -51,6 +51,8 @@ data MainEvent | ShowCESKDebugEvent | PauseEvent | RunSingleTickEvent + | IncreaseTpsEvent + | DecreaseTpsEvent deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent @@ -67,6 +69,8 @@ mainEvents = allKeyEvents $ \case ShowCESKDebugEvent -> "debug CESK" PauseEvent -> "pause" RunSingleTickEvent -> "run single tick" + IncreaseTpsEvent -> "increse TPS" + DecreaseTpsEvent -> "decrease TPS" defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = allBindings $ \case @@ -82,7 +86,8 @@ defaultMainBindings = allBindings $ \case ShowCESKDebugEvent -> [meta 'd'] PauseEvent -> [ctrl 'p'] RunSingleTickEvent -> [ctrl 'o'] - + IncreaseTpsEvent -> [ctrl 'x'] + DecreaseTpsEvent -> [ctrl 'z'] -- ---------------------------------------------- -- REPL EVENTS -- ---------------------------------------------- From f72d66d782e89154da58f840f605baeb52fb5690 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 17:48:49 +0200 Subject: [PATCH 15/55] Move set focus to new handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 5 ----- .../Swarm/TUI/Controller/MainEventHandler.hs | 4 ++++ src/swarm-tui/Swarm/TUI/Model/Event.hs | 12 ++++++++++++ 3 files changed, 16 insertions(+), 5 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 4c3a24e4c..1b5688bd1 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -312,11 +312,6 @@ handleMainEvent ev = do MessagesModal -> do gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks _ -> return () - -- special keys that work on all panels - MetaChar 'w' -> setFocus WorldPanel - MetaChar 'e' -> setFocus RobotPanel - MetaChar 'r' -> setFocus REPLPanel - MetaChar 't' -> setFocus InfoPanel -- pass keys on to modal event handler if a modal is open VtyEvent vev | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index 5e1463e58..dd2687274 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -46,6 +46,10 @@ mainEventHandlers = allHandlers Main $ \case RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) toggleQuitGameDialog :: EventM Name AppState () toggleQuitGameDialog = do diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 91eb8cf04..b47b25439 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -53,6 +53,10 @@ data MainEvent | RunSingleTickEvent | IncreaseTpsEvent | DecreaseTpsEvent + | FocusWorldEvent + | FocusRobotEvent + | FocusREPLEvent + | FocusInfoEvent deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent @@ -71,6 +75,10 @@ mainEvents = allKeyEvents $ \case RunSingleTickEvent -> "run single tick" IncreaseTpsEvent -> "increse TPS" DecreaseTpsEvent -> "decrease TPS" + FocusWorldEvent -> "focus World" + FocusRobotEvent -> "focus Robot" + FocusREPLEvent -> "focus REPL" + FocusInfoEvent -> "focus Info" defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = allBindings $ \case @@ -88,6 +96,10 @@ defaultMainBindings = allBindings $ \case RunSingleTickEvent -> [ctrl 'o'] IncreaseTpsEvent -> [ctrl 'x'] DecreaseTpsEvent -> [ctrl 'z'] + FocusWorldEvent -> [meta 'w'] + FocusRobotEvent -> [meta 'e'] + FocusREPLEvent -> [meta 'r'] + FocusInfoEvent -> [meta 't'] -- ---------------------------------------------- -- REPL EVENTS -- ---------------------------------------------- From 9b3d3ba3d2ffcc088ff41f6ef92dec8cdeaf33b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 18:18:14 +0200 Subject: [PATCH 16/55] Move Close modal to new event handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 14 +---- .../Swarm/TUI/Controller/MainEventHandler.hs | 62 ++++++++++++------- 2 files changed, 43 insertions(+), 33 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 1b5688bd1..968497924 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -298,20 +298,10 @@ handleMainEvent ev = do | otherwise -> runFrameUI Web (RunWebCode c) -> runBaseWebCode c _ -> continueWithoutRedraw + VtyEvent (V.EvResize _ _) -> invalidateCache -- pass to key handler (allows users to configure bindings) VtyEvent (V.EvKey k m) - | isJust (B.lookupVtyEvent k m keyHandler) -> do - void $ B.handleKey keyHandler k m - VtyEvent (V.EvResize _ _) -> invalidateCache - Key V.KEsc - | Just m <- s ^. uiState . uiGameplay . uiModal -> do - safeAutoUnpause - uiState . uiGameplay . uiModal .= Nothing - -- message modal is not autopaused, so update notifications when leaving it - case m ^. modalType of - MessagesModal -> do - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - _ -> return () + | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m -- pass keys on to modal event handler if a modal is open VtyEvent vev | isJust (s ^. uiState . uiGameplay . uiModal) -> handleModalEvent vev diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index dd2687274..be1044cb5 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -9,10 +9,11 @@ module Swarm.TUI.Controller.MainEventHandler ( ) where import Brick -import Brick.Keybindings qualified as B +import Brick.Keybindings import Control.Lens as Lens import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) +import Graphics.Vty.Input.Events qualified as V import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.State @@ -30,26 +31,45 @@ import System.Clock (Clock (..), TimeSpec (..), getTime) -- | Main keybindings event handler while running the game itself. -- -- See 'Swarm.TUI.Controller.handleMainEvent'. -mainEventHandlers :: [B.KeyEventHandler SwarmEvent (EventM Name AppState)] -mainEventHandlers = allHandlers Main $ \case - QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) - ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) - ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) - ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) - ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) - ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) - ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) - ViewGoalEvent -> ("View scenario goal description", viewGoal) - HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) - ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) - PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) - RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) - IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) - DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) - FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) - FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) - FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) - FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) +mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +mainEventHandlers = nonCustomizableHandlers <> customizableHandlers + where + nonCustomizableHandlers = + [ onKey V.KEsc "Close open modal" closeModal + ] + customizableHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + +closeModal :: EventM Name AppState () +closeModal = do + s <- get + case s ^. uiState . uiGameplay . uiModal of + Nothing -> return () + Just m -> do + safeAutoUnpause + uiState . uiGameplay . uiModal .= Nothing + -- message modal is not autopaused, so update notifications when leaving it + case m ^. modalType of + MessagesModal -> do + gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks + _ -> return () toggleQuitGameDialog :: EventM Name AppState () toggleQuitGameDialog = do From 2b25680747d774803199f5bfc5ecaf1455670653 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 18:46:34 +0200 Subject: [PATCH 17/55] Move creative mode and world editor toggle to new event handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 10 --- .../Swarm/TUI/Controller/MainEventHandler.hs | 62 ++++++++++++------- src/swarm-tui/Swarm/TUI/Model/Event.hs | 7 +++ 3 files changed, 46 insertions(+), 33 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 968497924..3b7b726ab 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -288,8 +288,6 @@ pressAnyKey _ _ = continueWithoutRedraw handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleMainEvent ev = do s <- get - mt <- preuse $ uiState . uiGameplay . uiModal . _Just . modalType - let isRunning = maybe True isRunningModal mt let keyHandler = s ^. keyEventHandling . keyHandlers . to mainHandler case ev of AppEvent ae -> case ae of @@ -309,14 +307,6 @@ handleMainEvent ev = do uiState . uiGameplay . uiWorldEditor . terrainList %= BL.listMoveTo pos MouseDown (EntityPaintListItem pos) V.BLeft _ _ -> uiState . uiGameplay . uiWorldEditor . entityPaintList %= BL.listMoveTo pos - -- toggle creative mode if in "cheat mode" - ControlChar 'v' - | s ^. uiState . uiCheatMode -> gameState . creativeMode %= not - -- toggle world editor mode if in "cheat mode" - ControlChar 'e' - | s ^. uiState . uiCheatMode -> do - uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not - setFocus WorldEditorPanel MouseDown WorldPositionIndicator _ _ _ -> uiState . uiGameplay . uiWorldCursor .= Nothing MouseDown (FocusablePanel WorldPanel) V.BMiddle _ mouseLoc -> -- Eye Dropper tool diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index be1044cb5..9bf7b887a 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -27,35 +27,38 @@ import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI import System.Clock (Clock (..), TimeSpec (..), getTime) +import Swarm.TUI.Editor.Model (worldOverdraw, isWorldEditorEnabled) -- | Main keybindings event handler while running the game itself. -- -- See 'Swarm.TUI.Controller.handleMainEvent'. mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] mainEventHandlers = nonCustomizableHandlers <> customizableHandlers - where - nonCustomizableHandlers = - [ onKey V.KEsc "Close open modal" closeModal - ] - customizableHandlers = allHandlers Main $ \case - QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) - ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) - ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) - ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) - ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) - ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) - ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) - ViewGoalEvent -> ("View scenario goal description", viewGoal) - HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) - ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) - PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) - RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) - IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) - DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) - FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) - FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) - FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) - FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + where + nonCustomizableHandlers = + [ onKey V.KEsc "Close open modal" closeModal + ] + customizableHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) + ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) closeModal :: EventM Name AppState () closeModal = do @@ -140,6 +143,14 @@ runSingleTick = do adjustTPS :: (Int -> Int -> Int) -> AppState -> AppState adjustTPS (+/-) = uiState . uiGameplay . uiTiming . lgTicksPerSecond %~ (+/- 1) +toggleCreativeMode :: EventM Name AppState () +toggleCreativeMode = gameState . creativeMode %= not + +toggleWorldEditor :: EventM Name AppState () +toggleWorldEditor = do + uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not + setFocus WorldEditorPanel + -- ---------------------------------------------- -- HELPER UTILS -- ---------------------------------------------- @@ -151,3 +162,8 @@ isRunning = do whenRunning :: EventM Name AppState () -> EventM Name AppState () whenRunning a = isRunning >>= \r -> when r a + +whenCheating :: EventM Name AppState () -> EventM Name AppState () +whenCheating a = do + s <- get + when (s ^. uiState . uiCheatMode) a diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index b47b25439..9214e5814 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -57,6 +57,8 @@ data MainEvent | FocusRobotEvent | FocusREPLEvent | FocusInfoEvent + | ToggleCreativeModeEvent + | ToggleWorldEditorEvent deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent @@ -79,6 +81,8 @@ mainEvents = allKeyEvents $ \case FocusRobotEvent -> "focus Robot" FocusREPLEvent -> "focus REPL" FocusInfoEvent -> "focus Info" + ToggleCreativeModeEvent -> "creative mode" + ToggleWorldEditorEvent -> "world editor" defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = allBindings $ \case @@ -100,6 +104,9 @@ defaultMainBindings = allBindings $ \case FocusRobotEvent -> [meta 'e'] FocusREPLEvent -> [meta 'r'] FocusInfoEvent -> [meta 't'] + ToggleCreativeModeEvent -> [ctrl 'v'] + ToggleWorldEditorEvent -> [ctrl 'e'] + -- ---------------------------------------------- -- REPL EVENTS -- ---------------------------------------------- From 00d6a98447e298eb46cfb6396ecc27971df4c973 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 18:50:22 +0200 Subject: [PATCH 18/55] Move collapse REPL to new event handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 4 ---- src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs | 8 +++++++- src/swarm-tui/Swarm/TUI/Model/Event.hs | 3 +++ 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 3b7b726ab..c432618f6 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -317,10 +317,6 @@ handleMainEvent ev = do MouseDown (FocusablePanel WorldPanel) V.BLeft [V.MCtrl] mouseLoc -> -- Paint with the World Editor EC.handleCtrlLeftClick mouseLoc - -- toggle collapse/expand REPL - MetaChar ',' -> do - invalidateCacheEntry WorldCache - uiState . uiGameplay . uiShowREPL %= not MouseDown n _ _ mouseLoc -> case n of FocusablePanel WorldPanel -> do diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs index 9bf7b887a..363eb3214 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs @@ -22,12 +22,12 @@ import Swarm.Game.Step (finishGameTick) import Swarm.TUI.Controller.FrameEventHandling (runGameTickUI) import Swarm.TUI.Controller.UpdateUI (updateUI) import Swarm.TUI.Controller.Util +import Swarm.TUI.Editor.Model (isWorldEditorEnabled, worldOverdraw) import Swarm.TUI.Model import Swarm.TUI.Model.Event (MainEvent (..), SwarmEvent (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.UI import System.Clock (Clock (..), TimeSpec (..), getTime) -import Swarm.TUI.Editor.Model (worldOverdraw, isWorldEditorEnabled) -- | Main keybindings event handler while running the game itself. -- @@ -59,6 +59,7 @@ mainEventHandlers = nonCustomizableHandlers <> customizableHandlers FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) + ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) closeModal :: EventM Name AppState () closeModal = do @@ -151,6 +152,11 @@ toggleWorldEditor = do uiState . uiGameplay . uiWorldEditor . worldOverdraw . isWorldEditorEnabled %= not setFocus WorldEditorPanel +toggleREPLVisibility :: EventM Name AppState () +toggleREPLVisibility = do + invalidateCacheEntry WorldCache + uiState . uiGameplay . uiShowREPL %= not + -- ---------------------------------------------- -- HELPER UTILS -- ---------------------------------------------- diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 9214e5814..6f93b9d56 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -59,6 +59,7 @@ data MainEvent | FocusInfoEvent | ToggleCreativeModeEvent | ToggleWorldEditorEvent + | ToggleREPLVisibilityEvent deriving (Eq, Ord, Show, Enum, Bounded) mainEvents :: KeyEvents MainEvent @@ -83,6 +84,7 @@ mainEvents = allKeyEvents $ \case FocusInfoEvent -> "focus Info" ToggleCreativeModeEvent -> "creative mode" ToggleWorldEditorEvent -> "world editor" + ToggleREPLVisibilityEvent -> "toggle REPL" defaultMainBindings :: [(MainEvent, [Binding])] defaultMainBindings = allBindings $ \case @@ -106,6 +108,7 @@ defaultMainBindings = allBindings $ \case FocusInfoEvent -> [meta 't'] ToggleCreativeModeEvent -> [ctrl 'v'] ToggleWorldEditorEvent -> [ctrl 'e'] + ToggleREPLVisibilityEvent -> [meta ','] -- ---------------------------------------------- -- REPL EVENTS From c4f6f292d6964072db005e1b8aed74d8088869b4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 19:08:51 +0200 Subject: [PATCH 19/55] Move event handlers to a folder --- src/swarm-tui/Swarm/TUI/Controller.hs | 2 +- .../{FrameEventHandling.hs => EventHandlers/Frame.hs} | 2 +- .../{MainEventHandler.hs => EventHandlers/Main.hs} | 4 ++-- .../{REPLEventHandler.hs => EventHandlers/REPL.hs} | 2 +- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 4 ++-- swarm.cabal | 6 +++--- 6 files changed, 10 insertions(+), 10 deletions(-) rename src/swarm-tui/Swarm/TUI/Controller/{FrameEventHandling.hs => EventHandlers/Frame.hs} (99%) rename src/swarm-tui/Swarm/TUI/Controller/{MainEventHandler.hs => EventHandlers/Main.hs} (98%) rename src/swarm-tui/Swarm/TUI/Controller/{REPLEventHandler.hs => EventHandlers/REPL.hs} (98%) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index c432618f6..fb958f258 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -97,7 +97,7 @@ import Swarm.Language.Typecheck ( ) import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log -import Swarm.TUI.Controller.FrameEventHandling +import Swarm.TUI.Controller.EventHandlers.Frame import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Controller.Util diff --git a/src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs similarity index 99% rename from src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs rename to src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs index eb5f7897b..ea278aa49 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/FrameEventHandling.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Frame.hs @@ -2,7 +2,7 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- Handling 'Swarm.TUI.Model.Frame' events. -module Swarm.TUI.Controller.FrameEventHandling ( +module Swarm.TUI.Controller.EventHandlers.Frame ( runFrameUI, runGameTickUI, diff --git a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs similarity index 98% rename from src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs rename to src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs index 363eb3214..57ad884ef 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/MainEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -4,7 +4,7 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- TODO: describe -module Swarm.TUI.Controller.MainEventHandler ( +module Swarm.TUI.Controller.EventHandlers.Main ( mainEventHandlers, ) where @@ -19,7 +19,7 @@ import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStruct import Swarm.Game.State import Swarm.Game.State.Substate import Swarm.Game.Step (finishGameTick) -import Swarm.TUI.Controller.FrameEventHandling (runGameTickUI) +import Swarm.TUI.Controller.EventHandlers.Frame (runGameTickUI) import Swarm.TUI.Controller.UpdateUI (updateUI) import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Model (isWorldEditorEnabled, worldOverdraw) diff --git a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs similarity index 98% rename from src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs rename to src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs index dc1f3f3bc..a5bf63e86 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/REPLEventHandler.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs @@ -4,7 +4,7 @@ -- SPDX-License-Identifier: BSD-3-Clause -- -- TODO: describe -module Swarm.TUI.Controller.REPLEventHandler ( +module Swarm.TUI.Controller.EventHandlers.REPL ( replEventHandlers, ) where diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 8702bea57..52d4068b3 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -81,8 +81,8 @@ import Swarm.Game.State.Substate import Swarm.Game.World.Gen (Seed) import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) -import Swarm.TUI.Controller.MainEventHandler (mainEventHandlers) -import Swarm.TUI.Controller.REPLEventHandler (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) +import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting diff --git a/swarm.cabal b/swarm.cabal index 392e2ca1e..9de14e5ac 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -664,9 +664,9 @@ library swarm-tui exposed-modules: Swarm.TUI.Border Swarm.TUI.Controller - Swarm.TUI.Controller.FrameEventHandling - Swarm.TUI.Controller.MainEventHandler - Swarm.TUI.Controller.REPLEventHandler + Swarm.TUI.Controller.EventHandlers.Frame + Swarm.TUI.Controller.EventHandlers.Main + Swarm.TUI.Controller.EventHandlers.REPL Swarm.TUI.Controller.SaveScenario Swarm.TUI.Controller.UpdateUI Swarm.TUI.Controller.Util From 28a899a0d47154485b09322e2eea84828c0de521 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 20:10:09 +0200 Subject: [PATCH 20/55] Move world panel events to new handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 68 ++----------------- .../TUI/Controller/EventHandlers/World.hs | 61 +++++++++++++++++ src/swarm-tui/Swarm/TUI/Model.hs | 1 + src/swarm-tui/Swarm/TUI/Model/Event.hs | 55 +++++++++++++-- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 3 + swarm.cabal | 1 + 6 files changed, 119 insertions(+), 70 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index fb958f258..33d0c6ebd 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -24,11 +24,6 @@ module Swarm.TUI.Controller ( adjReplHistIndex, TimeDir (..), - -- ** World panel - handleWorldEvent, - keyToDir, - scrollView, - -- ** Info panel handleInfoPanelEvent, ) where @@ -65,12 +60,10 @@ import Data.Text.Zipper qualified as TZ import Data.Text.Zipper.Generic.Words qualified as TZ import Data.Vector qualified as V import Graphics.Vty qualified as V -import Linear import Swarm.Game.Achievement.Definitions import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), continue) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land -import Swarm.Game.Location import Swarm.Game.ResourceLoading (getSwarmHistoryPath) import Swarm.Game.Robot.Concrete import Swarm.Game.ScenarioInfo @@ -354,7 +347,10 @@ handleMainEvent ev = do case focusGetCurrent fring of Just (FocusablePanel x) -> case x of REPLPanel -> handleREPLEvent ev - WorldPanel -> handleWorldEvent ev + WorldPanel | VtyEvent (V.EvKey k m) <- ev -> do + wh <- use $ keyEventHandling . keyHandlers . to worldHandler + void $ B.handleKey wh k m + WorldPanel | otherwise -> continueWithoutRedraw WorldEditorPanel -> EC.handleWorldEditorPanelEvent ev RobotPanel -> handleRobotPanelEvent ev InfoPanel -> handleInfoPanelEvent infoScroll ev @@ -768,62 +764,6 @@ adjReplHistIndex d s = oldEntry = getCurrEntry theRepl newEntry = getCurrEntry newREPL ------------------------------------------------------------- --- World events ------------------------------------------------------------- - -worldScrollDist :: Int32 -worldScrollDist = 8 - --- | Handle a user input event in the world view panel. -handleWorldEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleWorldEvent = \case - Key k - | k `elem` moveKeys -> do - c <- use $ gameState . creativeMode - s <- use $ gameState . landscape . worldScrollable - when (c || s) $ scrollView (.+^ (worldScrollDist *^ keyToDir k)) - CharKey 'c' -> do - invalidateCacheEntry WorldCache - gameState . robotInfo . viewCenterRule .= VCRobot 0 - -- show fps - CharKey 'f' -> uiState . uiGameplay . uiTiming . uiShowFPS %= not - -- Fall-through case: don't do anything. - _ -> continueWithoutRedraw - where - moveKeys = - [ V.KUp - , V.KDown - , V.KLeft - , V.KRight - , V.KChar 'h' - , V.KChar 'j' - , V.KChar 'k' - , V.KChar 'l' - ] - --- | Manually scroll the world view. -scrollView :: (Location -> Location) -> EventM Name AppState () -scrollView update = do - -- Manually invalidate the 'WorldCache' instead of just setting - -- 'needsRedraw'. I don't quite understand why the latter doesn't - -- always work, but there seems to be some sort of race condition - -- where 'needsRedraw' gets reset before the UI drawing code runs. - invalidateCacheEntry WorldCache - gameState . robotInfo %= modifyViewCenter (fmap update) - --- | Convert a directional key into a direction. -keyToDir :: V.Key -> Heading -keyToDir V.KUp = north -keyToDir V.KDown = south -keyToDir V.KRight = east -keyToDir V.KLeft = west -keyToDir (V.KChar 'h') = west -keyToDir (V.KChar 'j') = south -keyToDir (V.KChar 'k') = north -keyToDir (V.KChar 'l') = east -keyToDir _ = zero - ------------------------------------------------------------ -- Robot panel events ------------------------------------------------------------ diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs new file mode 100644 index 000000000..2c6628d4f --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +module Swarm.TUI.Controller.EventHandlers.World ( + worldEventHandlers, +) where + +import Brick hiding (Location) +import Brick.Keybindings +import Control.Lens +import Control.Monad (when) +import Data.Int (Int32) +import Linear +import Swarm.Game.Location +import Swarm.Game.State +import Swarm.Game.State.Landscape +import Swarm.Game.State.Robot +import Swarm.TUI.Controller.Util +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI + +-- | Handle a user input event in the world view panel. +worldEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +worldEventHandlers = allHandlers World $ \case + ViewBaseEvent -> ("View the base robot", viewBase) + ShowFpsEvent -> ("Show frames per second", showFps) + MoveViewNorthEvent -> ("Scroll world view in the north direction", scrollViewInDir north) + MoveViewEastEvent -> ("Scroll world view in the east direction", scrollViewInDir east) + MoveViewSouthEvent -> ("Scroll world view in the south direction", scrollViewInDir south) + MoveViewWestEvent -> ("Scroll world view in the west direction", scrollViewInDir west) + +viewBase :: EventM Name AppState () +viewBase = do + invalidateCacheEntry WorldCache + gameState . robotInfo . viewCenterRule .= VCRobot 0 + +showFps :: EventM Name AppState () +showFps = uiState . uiGameplay . uiTiming . uiShowFPS %= not + +scrollViewInDir :: V2 Int32 -> EventM Name AppState () +scrollViewInDir d = do + c <- use $ gameState . creativeMode + s <- use $ gameState . landscape . worldScrollable + when (c || s) $ scrollView (.+^ (worldScrollDist *^ d)) + +worldScrollDist :: Int32 +worldScrollDist = 8 + +-- | Manually scroll the world view. +scrollView :: (Location -> Location) -> EventM Name AppState () +scrollView update = do + -- Manually invalidate the 'WorldCache' instead of just setting + -- 'needsRedraw'. I don't quite understand why the latter doesn't + -- always work, but there seems to be some sort of race condition + -- where 'needsRedraw' gets reset before the UI drawing code runs. + invalidateCacheEntry WorldCache + gameState . robotInfo %= modifyViewCenter (fmap update) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 65e6597ea..8de39e00f 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -162,6 +162,7 @@ type SwarmEventHandler = KeyDispatcher SwarmEvent (EventM Name AppState) data EventHandlers = EventHandlers { mainHandler :: SwarmEventHandler , replHandler :: SwarmEventHandler + , worldHandler :: SwarmEventHandler } -- ---------------------------------------------------------------------------- diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 6f93b9d56..cc640ac2e 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -9,6 +9,7 @@ module Swarm.TUI.Model.Event ( SwarmEvent (..), MainEvent (..), REPLEvent (..), + WorldEvent (..), swarmEvents, defaultSwarmBindings, ) where @@ -21,15 +22,29 @@ import Graphics.Vty qualified as V data SwarmEvent = Main MainEvent | REPL REPLEvent + | World WorldEvent deriving (Eq, Ord, Show) swarmEvents :: KeyEvents SwarmEvent -swarmEvents = keyEvents (embed Main mainEvents ++ embed REPL replEvents) +swarmEvents = + keyEvents $ + concat + [ embed Main mainEvents + , embed REPL replEvents + , embed World worldPanelEvents + ] + where + embed f = map (fmap f) . keyEventsList defaultSwarmBindings :: [(SwarmEvent, [Binding])] -defaultSwarmBindings = embedB Main defaultMainBindings ++ embedB REPL defaultReplBindings +defaultSwarmBindings = + concat + [ embed Main defaultMainBindings + , embed REPL defaultReplBindings + , embed World defaultWorldPanelBindings + ] where - embedB f = map (first f) + embed = map . first -- ---------------------------------------------- -- MAIN EVENTS @@ -135,12 +150,40 @@ defaultReplBindings = allBindings $ \case TogglePilotingModeEvent -> [meta 'p'] ToggleCustomKeyHandlingEvent -> [meta 'k'] +-- ---------------------------------------------- +-- REPL EVENTS +-- ---------------------------------------------- + +data WorldEvent + = ViewBaseEvent + | ShowFpsEvent + | MoveViewNorthEvent + | MoveViewEastEvent + | MoveViewSouthEvent + | MoveViewWestEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +worldPanelEvents :: KeyEvents WorldEvent +worldPanelEvents = allKeyEvents $ \case + ViewBaseEvent -> "view base" + ShowFpsEvent -> "show fps" + MoveViewNorthEvent -> "move view north" + MoveViewEastEvent -> "move view east" + MoveViewSouthEvent -> "move view south" + MoveViewWestEvent -> "move view west" + +defaultWorldPanelBindings :: [(WorldEvent, [Binding])] +defaultWorldPanelBindings = allBindings $ \case + ViewBaseEvent -> [bind 'c'] + ShowFpsEvent -> [bind 'f'] + MoveViewWestEvent -> [bind 'h', bind V.KLeft] + MoveViewSouthEvent -> [bind 'j', bind V.KDown] + MoveViewNorthEvent -> [bind 'k', bind V.KUp] + MoveViewEastEvent -> [bind 'l', bind V.KRight] + -- ---------------- -- Helper methods -embed :: Ord b => (a -> b) -> KeyEvents a -> [(Text, b)] -embed f = map (fmap f) . keyEventsList - allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e allKeyEvents f = keyEvents $ map (\e -> (f e, e)) [minBound .. maxBound] diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 52d4068b3..7389725f0 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -83,6 +83,7 @@ import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting @@ -108,6 +109,7 @@ createEventHandlers :: createEventHandlers config = do mainHandler <- buildDispatcher mainEventHandlers replHandler <- buildDispatcher replEventHandlers + worldHandler <- buildDispatcher worldEventHandlers return EventHandlers {..} where -- this error handling code is modified version of the brick demo app: @@ -164,6 +166,7 @@ showKeybindings kPrint = do sections = [ ("main", mainEventHandlers) , ("repl", replEventHandlers) + , ("world", worldEventHandlers) ] -- | Initialize the 'AppState' from scratch. diff --git a/swarm.cabal b/swarm.cabal index 9de14e5ac..7f5e80447 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -667,6 +667,7 @@ library swarm-tui Swarm.TUI.Controller.EventHandlers.Frame Swarm.TUI.Controller.EventHandlers.Main Swarm.TUI.Controller.EventHandlers.REPL + Swarm.TUI.Controller.EventHandlers.World Swarm.TUI.Controller.SaveScenario Swarm.TUI.Controller.UpdateUI Swarm.TUI.Controller.Util From 4b2fef002aa028a0f6e636a61a283436b4aecdcd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 21:31:42 +0200 Subject: [PATCH 21/55] Move RobotPanel to new handler --- src/swarm-tui/Swarm/TUI/Controller.hs | 130 +------------- .../TUI/Controller/EventHandlers/Robot.hs | 168 ++++++++++++++++++ src/swarm-tui/Swarm/TUI/Model.hs | 1 + src/swarm-tui/Swarm/TUI/Model/Event.hs | 32 ++++ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 3 + src/swarm-web/Swarm/Web.hs | 2 +- swarm.cabal | 1 + 7 files changed, 211 insertions(+), 126 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 33d0c6ebd..ee8523a8d 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} -- | @@ -28,10 +27,11 @@ module Swarm.TUI.Controller ( handleInfoPanelEvent, ) where +-- See Note [liftA2 re-export from Prelude] +import Prelude hiding (Applicative (..)) + import Brick hiding (Direction, Location) import Brick.Focus - --- See Note [liftA2 re-export from Prelude] import Brick.Keybindings qualified as B import Brick.Widgets.Dialog import Brick.Widgets.Edit (Editor, applyEdit, handleEditorEvent) @@ -40,7 +40,6 @@ import Brick.Widgets.List qualified as BL import Control.Applicative (pure) import Control.Category ((>>>)) import Control.Lens as Lens -import Control.Lens.Extras as Lens (is) import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -61,7 +60,7 @@ import Data.Text.Zipper.Generic.Words qualified as TZ import Data.Vector qualified as V import Graphics.Vty qualified as V import Swarm.Game.Achievement.Definitions -import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend), continue) +import Swarm.Game.CESK (CESK (Out), Frame (FApp, FExec, FSuspend)) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Land import Swarm.Game.ResourceLoading (getSwarmHistoryPath) @@ -83,7 +82,6 @@ import Swarm.Language.Parser.Core (defaultParserConfig) import Swarm.Language.Parser.Lex (reservedWords) import Swarm.Language.Parser.Util (showErrorPos) import Swarm.Language.Pipeline (processParsedTerm', processTerm') -import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Syntax hiding (Key) import Swarm.Language.Typecheck ( ContextualTypeErr (..), @@ -91,12 +89,12 @@ import Swarm.Language.Typecheck ( import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log import Swarm.TUI.Controller.EventHandlers.Frame +import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, runBaseTerm) import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model -import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) import Swarm.TUI.Launch.Controller import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.Prep (prepareLaunchDialog) @@ -108,10 +106,8 @@ import Swarm.TUI.Model.Repl import Swarm.TUI.Model.StateUpdate import Swarm.TUI.Model.Structure import Swarm.TUI.Model.UI -import Swarm.TUI.View.Util (generateModal) import Swarm.Util hiding (both, (<<.=)) import Swarm.Version (NewReleaseFailure (..)) -import Prelude hiding (Applicative (..)) -- ~~~~ Note [liftA2 re-export from Prelude] -- @@ -542,21 +538,6 @@ runBaseCode uinput = do Left err -> do uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLError err) -runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () -runBaseTerm = maybe (pure ()) startBaseProgram - where - -- The player typed something at the REPL and hit Enter; this - -- function takes the resulting ProcessedTerm (if the REPL - -- input is valid) and sets up the base robot to run it. - startBaseProgram t = do - -- Set the REPL status to Working - gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing - -- Set up the robot's CESK machine to evaluate/execute the - -- given term. - gameState . baseRobot . machine %= continue t - -- Finally, be sure to activate the base robot. - gameState %= execState (zoomRobots $ activateRobot 0) - -- | Handle a user input event for the REPL. handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEventTyping = \case @@ -764,107 +745,6 @@ adjReplHistIndex d s = oldEntry = getCurrEntry theRepl newEntry = getCurrEntry newREPL ------------------------------------------------------------- --- Robot panel events ------------------------------------------------------------- - --- | Handle user input events in the robot panel. -handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleRobotPanelEvent bev = do - search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch - case search of - Just _ -> handleInventorySearchEvent bev - Nothing -> case bev of - Key V.KEnter -> - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - CharKey 'm' -> - gets focusedEntity >>= maybe continueWithoutRedraw makeEntity - CharKey '0' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiShowZero %= not - CharKey ';' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySort %= cycleSortOrder - CharKey ':' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySort %= cycleSortDirection - CharKey '/' -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Just "" - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Handle an event to navigate through the inventory list. -handleInventoryListEvent :: V.Event -> EventM Name AppState () -handleInventoryListEvent ev = do - -- Note, refactoring like this is tempting: - -- - -- Brick.zoom (uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) - -- - -- However, this does not work since we want to skip redrawing in the no-list case! - - mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 - case mList of - Nothing -> continueWithoutRedraw - Just l -> do - when (isValidListMovement ev) $ resetViewport infoScroll - l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) - uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' - --- | Handle a user input event in the robot/inventory panel, while in --- inventory search mode. -handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () -handleInventorySearchEvent = \case - -- Escape: stop filtering and go back to regular inventory mode - EscapeKey -> - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Nothing - -- Enter: return to regular inventory mode, and pop out the selected item - Key V.KEnter -> do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch .= Nothing - gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal - -- Any old character: append to the current search string - CharKey c -> do - resetViewport infoScroll - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch %= fmap (`snoc` c) - -- Backspace: chop the last character off the end of the current search string - BackspaceKey -> do - Brick.zoom (uiState . uiGameplay . uiInventory) $ do - uiInventoryShouldUpdate .= True - uiInventorySearch %= fmap (T.dropEnd 1) - -- Handle any other event as list navigation, so we can look through - -- the filtered inventory using e.g. arrow keys - VtyEvent ev -> handleInventoryListEvent ev - _ -> continueWithoutRedraw - --- | Attempt to make an entity selected from the inventory, if the --- base is not currently busy. -makeEntity :: Entity -> EventM Name AppState () -makeEntity e = do - s <- get - let name = e ^. entityName - mkT = [tmQ| make $str:name |] - - case isActive <$> (s ^? gameState . baseRobot) of - Just False -> runBaseTerm (Just mkT) - _ -> continueWithoutRedraw - --- | Display a modal window with the description of an entity. -descriptionModal :: Entity -> EventM Name AppState () -descriptionModal e = do - s <- get - resetViewport modalScroll - uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) - ------------------------------------------------------------ -- Info panel events ------------------------------------------------------------ diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs new file mode 100644 index 000000000..61dacaf4e --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- TODO: describe +module Swarm.TUI.Controller.EventHandlers.Robot ( + robotEventHandlers, + handleRobotPanelEvent, + + -- ** Helper functions + runBaseTerm, +) where + +import Brick +import Brick.Keybindings +import Control.Lens as Lens +import Control.Lens.Extras as Lens (is) +import Control.Monad (unless, when) +import Control.Monad.State (MonadState, execState) +import Data.Text qualified as T +import Graphics.Vty qualified as V +import Swarm.Game.CESK (continue) +import Swarm.Game.Entity hiding (empty) +import Swarm.Game.Robot.Concrete +import Swarm.Game.State +import Swarm.Game.State.Robot (activateRobot) +import Swarm.Game.State.Substate (REPLStatus (..), replStatus) +import Swarm.Language.Pipeline.QQ (tmQ) +import Swarm.Language.Syntax hiding (Key) +import Swarm.TUI.Controller.Util +import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder) +import Swarm.TUI.List +import Swarm.TUI.Model +import Swarm.TUI.Model.Event +import Swarm.TUI.Model.UI +import Swarm.TUI.View.Util (generateModal) + +-- | Handle user input events in the robot panel. +handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleRobotPanelEvent bev = do + search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch + keyHandler <- use $ keyEventHandling . keyHandlers . to robotHandler + case search of + Just _ -> handleInventorySearchEvent bev + Nothing -> case bev of + VtyEvent ev@(V.EvKey k m) -> do + handled <- handleKey keyHandler k m + unless handled $ handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- | Handle key events in the robot panel. +robotEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +robotEventHandlers = nonCustomizableHandlers <> customizableHandlers + where + nonCustomizableHandlers = + [ onKey V.KEnter "Show entity description" showEntityDescription + ] + customizableHandlers = allHandlers Robot $ \case + MakeEntityEvent -> ("Make the selected entity", makeFocusedEntity) + ShowZeroInventoryEntitiesEvent -> ("Show entities with zero count in inventory", zoomInventory showZero) + CycleInventorySortEvent -> ("Cycle inventory sorting type", zoomInventory cycleSort) + SwitchInventorySortDirection -> ("Switch ascending/descending inventory sort", zoomInventory switchSortDirection) + SearchInventoryEvent -> ("Start inventory search", zoomInventory searchInventory) + +-- | Display a modal window with the description of an entity. +showEntityDescription :: EventM Name AppState () +showEntityDescription = gets focusedEntity >>= maybe continueWithoutRedraw descriptionModal + where + descriptionModal :: Entity -> EventM Name AppState () + descriptionModal e = do + s <- get + resetViewport modalScroll + uiState . uiGameplay . uiModal ?= generateModal s (DescriptionModal e) + +-- | Attempt to make an entity selected from the inventory, if the +-- base is not currently busy. +makeFocusedEntity :: EventM Name AppState () +makeFocusedEntity = gets focusedEntity >>= maybe continueWithoutRedraw makeEntity + where + makeEntity :: Entity -> EventM Name AppState () + makeEntity e = do + s <- get + let name = e ^. entityName + mkT = [tmQ| make $str:name |] + case isActive <$> (s ^? gameState . baseRobot) of + Just False -> runBaseTerm (Just mkT) + _ -> continueWithoutRedraw + +showZero :: EventM Name UIInventory () +showZero = uiShowZero %= not + +cycleSort :: EventM Name UIInventory () +cycleSort = uiInventorySort %= cycleSortOrder + +switchSortDirection :: EventM Name UIInventory () +switchSortDirection = uiInventorySort %= cycleSortDirection + +searchInventory :: EventM Name UIInventory () +searchInventory = uiInventorySearch .= Just "" + +-- | Handle an event to navigate through the inventory list. +handleInventoryListEvent :: V.Event -> EventM Name AppState () +handleInventoryListEvent ev = do + -- Note, refactoring like this is tempting: + -- + -- Brick.zoom (uiState . ... . _Just . _2) (handleListEventWithSeparators ev (is _Separator)) + -- + -- However, this does not work since we want to skip redrawing in the no-list case! + mList <- preuse $ uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + case mList of + Nothing -> continueWithoutRedraw + Just l -> do + when (isValidListMovement ev) $ resetViewport infoScroll + l' <- nestEventM' l (handleListEventWithSeparators ev (is _Separator)) + uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 .= l' + +-- ---------------------------------------------- +-- INVENTORY SEARCH +-- ---------------------------------------------- + +-- | Handle a user input event in the robot/inventory panel, while in +-- inventory search mode. +handleInventorySearchEvent :: BrickEvent Name AppEvent -> EventM Name AppState () +handleInventorySearchEvent = \case + -- Escape: stop filtering and go back to regular inventory mode + EscapeKey -> + zoomInventory $ uiInventorySearch .= Nothing + -- Enter: return to regular inventory mode, and pop out the selected item + Key V.KEnter -> do + zoomInventory $ uiInventorySearch .= Nothing + showEntityDescription + -- Any old character: append to the current search string + CharKey c -> do + resetViewport infoScroll + zoomInventory $ uiInventorySearch %= fmap (`snoc` c) + -- Backspace: chop the last character off the end of the current search string + BackspaceKey -> do + zoomInventory $ uiInventorySearch %= fmap (T.dropEnd 1) + -- Handle any other event as list navigation, so we can look through + -- the filtered inventory using e.g. arrow keys + VtyEvent ev -> handleInventoryListEvent ev + _ -> continueWithoutRedraw + +-- ---------------------------------------------- +-- HELPER UTILS +-- ---------------------------------------------- + +zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () +zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do + uiInventoryShouldUpdate .= True + act + +runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () +runBaseTerm = maybe (pure ()) startBaseProgram + where + -- The player typed something at the REPL and hit Enter; this + -- function takes the resulting ProcessedTerm (if the REPL + -- input is valid) and sets up the base robot to run it. + startBaseProgram t = do + -- Set the REPL status to Working + gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing + -- Set up the robot's CESK machine to evaluate/execute the + -- given term. + gameState . baseRobot . machine %= continue t + -- Finally, be sure to activate the base robot. + gameState %= execState (zoomRobots $ activateRobot 0) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 8de39e00f..78c05f113 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -163,6 +163,7 @@ data EventHandlers = EventHandlers { mainHandler :: SwarmEventHandler , replHandler :: SwarmEventHandler , worldHandler :: SwarmEventHandler + , robotHandler :: SwarmEventHandler } -- ---------------------------------------------------------------------------- diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index cc640ac2e..27b9050d6 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -10,6 +10,7 @@ module Swarm.TUI.Model.Event ( MainEvent (..), REPLEvent (..), WorldEvent (..), + RobotEvent (..), swarmEvents, defaultSwarmBindings, ) where @@ -23,6 +24,7 @@ data SwarmEvent = Main MainEvent | REPL REPLEvent | World WorldEvent + | Robot RobotEvent deriving (Eq, Ord, Show) swarmEvents :: KeyEvents SwarmEvent @@ -32,6 +34,7 @@ swarmEvents = [ embed Main mainEvents , embed REPL replEvents , embed World worldPanelEvents + , embed Robot robotPanelEvents ] where embed f = map (fmap f) . keyEventsList @@ -42,6 +45,7 @@ defaultSwarmBindings = [ embed Main defaultMainBindings , embed REPL defaultReplBindings , embed World defaultWorldPanelBindings + , embed Robot defaultRobotPanelBindings ] where embed = map . first @@ -181,6 +185,34 @@ defaultWorldPanelBindings = allBindings $ \case MoveViewNorthEvent -> [bind 'k', bind V.KUp] MoveViewEastEvent -> [bind 'l', bind V.KRight] +-- ---------------------------------------------- +-- ROBOT EVENTS +-- ---------------------------------------------- + +data RobotEvent + = MakeEntityEvent + | ShowZeroInventoryEntitiesEvent + | CycleInventorySortEvent + | SwitchInventorySortDirection + | SearchInventoryEvent + deriving (Eq, Ord, Show, Enum, Bounded) + +robotPanelEvents :: KeyEvents RobotEvent +robotPanelEvents = allKeyEvents $ \case + MakeEntityEvent -> "make entity" + ShowZeroInventoryEntitiesEvent -> "show zero inventory entites" + CycleInventorySortEvent -> "cycle inventory sort" + SwitchInventorySortDirection -> "switch inventory direction" + SearchInventoryEvent -> "search inventory" + +defaultRobotPanelBindings :: [(RobotEvent, [Binding])] +defaultRobotPanelBindings = allBindings $ \case + MakeEntityEvent -> [bind 'm'] + ShowZeroInventoryEntitiesEvent -> [bind '0'] + CycleInventorySortEvent -> [bind ';'] + SwitchInventorySortDirection -> [bind ':'] + SearchInventoryEvent -> [bind '/'] + -- ---------------- -- Helper methods diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 7389725f0..d16f0749a 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -83,6 +83,7 @@ import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Robot (robotEventHandlers) import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU @@ -110,6 +111,7 @@ createEventHandlers config = do mainHandler <- buildDispatcher mainEventHandlers replHandler <- buildDispatcher replEventHandlers worldHandler <- buildDispatcher worldEventHandlers + robotHandler <- buildDispatcher robotEventHandlers return EventHandlers {..} where -- this error handling code is modified version of the brick demo app: @@ -167,6 +169,7 @@ showKeybindings kPrint = do [ ("main", mainEventHandlers) , ("repl", replEventHandlers) , ("world", worldEventHandlers) + , ("robot", robotEventHandlers) ] -- | Initialize the 'AppState' from scratch. diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 1a3be5931..76f8c0eb3 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -79,7 +79,7 @@ import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type import Swarm.Language.Pipeline (processTermEither) import Swarm.Language.Pretty (prettyTextLine) -import Swarm.TUI.Model +import Swarm.TUI.Model hiding (EventHandlers (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq) import Swarm.TUI.Model.UI diff --git a/swarm.cabal b/swarm.cabal index 7f5e80447..3c2ff4b14 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -667,6 +667,7 @@ library swarm-tui Swarm.TUI.Controller.EventHandlers.Frame Swarm.TUI.Controller.EventHandlers.Main Swarm.TUI.Controller.EventHandlers.REPL + Swarm.TUI.Controller.EventHandlers.Robot Swarm.TUI.Controller.EventHandlers.World Swarm.TUI.Controller.SaveScenario Swarm.TUI.Controller.UpdateUI From 8943f98fad319d10384e578539e5661bfa7dae5c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 21:37:13 +0200 Subject: [PATCH 22/55] Fixup tests --- test/integration/Main.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 6d7f9c807..d43f463f5 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -72,7 +72,7 @@ import Swarm.TUI.Model ( defaultAppOpts, gameState, runtimeState, - userScenario, + userScenario, KeyEventHandlingState, ) import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) import Swarm.TUI.Model.UI (UIState) @@ -95,7 +95,7 @@ main = do scenarioPaths <- findAllWithExt "data/scenarios" "yaml" let (unparseableScenarios, parseableScenarios) = partition isUnparseableTest scenarioPaths scenarioPrograms <- findAllWithExt "data/scenarios" "sw" - (rs, ui) <- do + (rs, ui, key) <- do out <- runM . runThrow @SystemFailure $ initPersistentState defaultAppOpts either (assertFailure . prettyString) return out let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs @@ -108,7 +108,7 @@ main = do , exampleTests scenarioPrograms , scenarioParseTests scenarioInputs parseableScenarios , scenarioParseInvalidTests scenarioInputs unparseableScenarios - , testScenarioSolutions rs' ui + , testScenarioSolutions rs' ui key , testEditorFiles ] @@ -183,8 +183,8 @@ time = \case data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show) -testScenarioSolutions :: RuntimeState -> UIState -> TestTree -testScenarioSolutions rs ui = +testScenarioSolutions :: RuntimeState -> UIState -> KeyEventHandlingState -> TestTree +testScenarioSolutions rs ui key = testGroup "Test scenario solutions" [ testGroup @@ -480,7 +480,7 @@ testScenarioSolutions rs ui = testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree testSolution' s p shouldCheckBadErrors verify = testCase p $ do - out <- runM . runThrow @SystemFailure $ constructAppState rs ui $ defaultAppOpts {userScenario = Just p} + out <- runM . runThrow @SystemFailure $ constructAppState rs ui key $ defaultAppOpts {userScenario = Just p} case out of Left err -> assertFailure $ prettyString err Right appState -> case appState ^. gameState . winSolution of From a77ccd2e6ac5986beda04b5e800fd2e0dd190e64 Mon Sep 17 00:00:00 2001 From: "restyled-io[bot]" <32688539+restyled-io[bot]@users.noreply.github.com> Date: Sat, 29 Jun 2024 21:39:56 +0200 Subject: [PATCH 23/55] Restyled by fourmolu (#2001) Co-authored-by: Restyled.io --- test/integration/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index d43f463f5..2c7d62e20 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -69,10 +69,11 @@ import Swarm.Language.Pipeline (processTerm) import Swarm.Language.Pretty (prettyString) import Swarm.Log import Swarm.TUI.Model ( + KeyEventHandlingState, defaultAppOpts, gameState, runtimeState, - userScenario, KeyEventHandlingState, + userScenario, ) import Swarm.TUI.Model.StateUpdate (constructAppState, initPersistentState) import Swarm.TUI.Model.UI (UIState) From 850d528864ba9c88aeb30a5358ea0a9a30edb10b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 22:13:35 +0200 Subject: [PATCH 24/55] Move back close modal --- src/swarm-tui/Swarm/TUI/Controller.hs | 10 +++ .../TUI/Controller/EventHandlers/Main.hs | 64 +++++++------------ src/swarm-tui/Swarm/TUI/Model/Menu.hs | 4 +- 3 files changed, 34 insertions(+), 44 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index ee8523a8d..84e35347e 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -286,6 +286,7 @@ handleMainEvent ev = do Web (RunWebCode c) -> runBaseWebCode c _ -> continueWithoutRedraw VtyEvent (V.EvResize _ _) -> invalidateCache + EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m -- pass to key handler (allows users to configure bindings) VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m @@ -352,6 +353,15 @@ handleMainEvent ev = do InfoPanel -> handleInfoPanelEvent infoScroll ev _ -> continueWithoutRedraw +closeModal :: Modal -> EventM Name AppState () +closeModal m = do + safeAutoUnpause + uiState . uiGameplay . uiModal .= Nothing + -- message modal is not autopaused, so update notifications when leaving it + when ((m ^. modalType) == MessagesModal) $ do + t <- use $ gameState . temporal . ticks + gameState . messageInfo . lastSeenMessageTime .= t + handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case V.EvKey V.KEnter [] -> do diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs index 57ad884ef..b7ff98ecc 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -13,7 +13,6 @@ import Brick.Keybindings import Control.Lens as Lens import Control.Monad (unless, void, when) import Control.Monad.IO.Class (liftIO) -import Graphics.Vty.Input.Events qualified as V import Swarm.Game.Scenario.Topography.Structure.Recognition (automatons) import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (originalStructureDefinitions) import Swarm.Game.State @@ -33,47 +32,28 @@ import System.Clock (Clock (..), TimeSpec (..), getTime) -- -- See 'Swarm.TUI.Controller.handleMainEvent'. mainEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] -mainEventHandlers = nonCustomizableHandlers <> customizableHandlers - where - nonCustomizableHandlers = - [ onKey V.KEsc "Close open modal" closeModal - ] - customizableHandlers = allHandlers Main $ \case - QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) - ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) - ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) - ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) - ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) - ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) - ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) - ViewGoalEvent -> ("View scenario goal description", viewGoal) - HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) - ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) - PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) - RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) - IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) - DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) - FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) - FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) - FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) - FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) - ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) - ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) - ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) - -closeModal :: EventM Name AppState () -closeModal = do - s <- get - case s ^. uiState . uiGameplay . uiModal of - Nothing -> return () - Just m -> do - safeAutoUnpause - uiState . uiGameplay . uiModal .= Nothing - -- message modal is not autopaused, so update notifications when leaving it - case m ^. modalType of - MessagesModal -> do - gameState . messageInfo . lastSeenMessageTime .= s ^. gameState . temporal . ticks - _ -> return () +mainEventHandlers = allHandlers Main $ \case + QuitEvent -> ("Open quit game dialog", toggleQuitGameDialog) + ViewHelpEvent -> ("View Help screen", toggleModal HelpModal) + ViewRobotsEvent -> ("View Robots screen", toggleModal RobotsModal) + ViewRecipesEvent -> ("View Recipes screen", toggleDiscoveryNotificationModal RecipesModal availableRecipes) + ViewCommandsEvent -> ("View Commands screen", toggleDiscoveryNotificationModal CommandsModal availableCommands) + ViewMessagesEvent -> ("View Messages screen", toggleMessagesModal) + ViewStructuresEvent -> ("View Structures screen", toggleDiscoveryModal StructuresModal (structureRecognition . automatons . originalStructureDefinitions)) + ViewGoalEvent -> ("View scenario goal description", viewGoal) + HideRobotsEvent -> ("Hide robots for a few ticks", hideRobots) + ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) + PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) + RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) + IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) + FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) + FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) + FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) + FocusInfoEvent -> ("Set focus on the Info panel", setFocus InfoPanel) + ToggleCreativeModeEvent -> ("Toggle creative mode", whenCheating toggleCreativeMode) + ToggleWorldEditorEvent -> ("Toggle world editor mode", whenCheating toggleWorldEditor) + ToggleREPLVisibilityEvent -> ("Collapse/Expand REPL panel", toggleREPLVisibility) toggleQuitGameDialog :: EventM Name AppState () toggleQuitGameDialog = do diff --git a/src/swarm-tui/Swarm/TUI/Model/Menu.hs b/src/swarm-tui/Swarm/TUI/Model/Menu.hs index 83c5356e1..793a8f9b0 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Menu.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Menu.hs @@ -41,7 +41,7 @@ import Witch (into) ------------------------------------------------------------ data ScenarioOutcome = WinModal | LoseModal - deriving (Show) + deriving (Show, Eq) data ModalType = HelpModal @@ -57,7 +57,7 @@ data ModalType | KeepPlayingModal | DescriptionModal Entity | GoalModal - deriving (Show) + deriving (Show, Eq) data ButtonAction = Cancel From f8280327da87a934f06a8b06d691e549b54350a1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 22:20:43 +0200 Subject: [PATCH 25/55] Add simple module docs --- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs | 2 +- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs | 2 +- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs | 6 +++++- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs | 2 +- 4 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs index b7ff98ecc..c57eb2f9b 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -3,7 +3,7 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Here is the main player configurable key event handler while playing the game. module Swarm.TUI.Controller.EventHandlers.Main ( mainEventHandlers, ) where diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs index a5bf63e86..35449cd91 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/REPL.hs @@ -3,7 +3,7 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Here is the REPL player configurable key event handler. module Swarm.TUI.Controller.EventHandlers.REPL ( replEventHandlers, ) where diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs index 61dacaf4e..4591c4c5e 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -4,7 +4,11 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Here is the RobotPanel key event handler. +-- +-- Because of how tricky the search logic is, +-- the player configurable part and the dynamic +-- search handler are both here. module Swarm.TUI.Controller.EventHandlers.Robot ( robotEventHandlers, handleRobotPanelEvent, diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs index 2c6628d4f..ba587a83e 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -3,7 +3,7 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Here is the WorldPanel player configurable key event handler. module Swarm.TUI.Controller.EventHandlers.World ( worldEventHandlers, ) where From 771e4b6f80fc658b20cb29cd83c3ee332b25a868 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 22:22:27 +0200 Subject: [PATCH 26/55] More module docs --- src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs index 61fdc0172..1c97df99b 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/SaveScenario.hs @@ -1,12 +1,11 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Collection of functions used to save the scenario metadata. module Swarm.TUI.Controller.SaveScenario ( saveScenarioInfoOnFinish, saveScenarioInfoOnFinishNocheat, saveScenarioInfoOnQuit, - getNormalizedCurrentScenarioPath, ) where -- See Note [liftA2 re-export from Prelude] From b952e1277880a95cb20ade88c6f700c434989702 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 22:26:26 +0200 Subject: [PATCH 27/55] Add UpdateUI docs --- src/swarm-tui/Swarm/TUI/Controller.hs | 2 -- src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs | 3 +-- 2 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 84e35347e..2896b965b 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -14,7 +14,6 @@ module Swarm.TUI.Controller ( runFrameUI, ticksPerFrameCap, runGameTickUI, - updateUI, -- ** REPL panel runBaseWebCode, @@ -91,7 +90,6 @@ import Swarm.Log import Swarm.TUI.Controller.EventHandlers.Frame import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, runBaseTerm) import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) -import Swarm.TUI.Controller.UpdateUI import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC import Swarm.TUI.Editor.Model diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs index 9f062ab0f..b37e54c6e 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -3,10 +3,9 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- The main TUI update logic that is called from other controller parts. module Swarm.TUI.Controller.UpdateUI ( updateUI, - doGoalUpdates, ) where import Brick hiding (Direction, Location) From 35cfa03d2c0cf581608652f88a702a134644da50 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 29 Jun 2024 22:29:22 +0200 Subject: [PATCH 28/55] Add module docs to Achievement helpers --- src/swarm-tui/Swarm/TUI/Model/Achievements.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs index f25da0e5c..a444313a7 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Achievements.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Achievements.hs @@ -1,7 +1,7 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- TODO: describe +-- Collection of helper functions for managing achievements in other controllers. module Swarm.TUI.Model.Achievements ( attainAchievement, attainAchievement', From fac6129c4e66bb5edd959e5a7c9aafe562b9854a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 14:19:09 +0200 Subject: [PATCH 29/55] Add EventHandlers module and move createEventHandlers there --- src/swarm-tui/Swarm/TUI/Controller.hs | 3 +- .../Swarm/TUI/Controller/EventHandlers.hs | 75 +++++++++++++++++++ .../TUI/Controller/EventHandlers/Robot.hs | 24 +----- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 26 +++++-- src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 33 +------- swarm.cabal | 1 + 6 files changed, 100 insertions(+), 62 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 2896b965b..1e17b05ee 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -87,8 +87,7 @@ import Swarm.Language.Typecheck ( ) import Swarm.Language.Value (Value (VKey), envTypes) import Swarm.Log -import Swarm.TUI.Controller.EventHandlers.Frame -import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, runBaseTerm) +import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Controller.SaveScenario (saveScenarioInfoOnQuit) import Swarm.TUI.Controller.Util import Swarm.TUI.Editor.Controller qualified as EC diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs new file mode 100644 index 000000000..ce56bfefc --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +-- +-- Sum types representing the Swarm events +-- abstracted away from keybindings. +module Swarm.TUI.Controller.EventHandlers ( + -- * Documentation + createEventHandlers, + + -- ** Main game handler + mainEventHandlers, + + -- ** REPL panel handler + replEventHandlers, + + -- ** World panel handler + worldEventHandlers, + + -- ** Robot panel handler + robotEventHandlers, + handleRobotPanelEvent, + + -- ** Frame + runFrameUI, + runGameTickUI, + ticksPerFrameCap, +) where + +import Brick.Keybindings as BK +import Control.Effect.Accum +import Control.Effect.Throw +import Data.Maybe (fromMaybe) +import Data.Text qualified as T +import Swarm.Game.Failure (SystemFailure (..)) +import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) +import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) +import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEventHandlers) +import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) + +-- | Create event handlers with given key config. +-- +-- Fails if any key events have conflict within one dispatcher. +createEventHandlers :: + (Has (Throw SystemFailure) sig m) => + KeyConfig SwarmEvent -> + m EventHandlers +createEventHandlers config = do + mainHandler <- buildDispatcher mainEventHandlers + replHandler <- buildDispatcher replEventHandlers + worldHandler <- buildDispatcher worldEventHandlers + robotHandler <- buildDispatcher robotEventHandlers + return EventHandlers {..} + where + -- this error handling code is modified version of the brick demo app: + -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 + buildDispatcher handlers = case keyDispatcher config handlers of + Right d -> return d + Left collisions -> do + let errorHeader = "Error: some key events have the same keys bound to them.\n" + let handlerErrors = flip map collisions $ \(b, hs) -> + let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" + hss = flip map hs $ \h -> + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" + ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + in " " <> desc <> " (" <> trigger <> ")" + in T.intercalate "\n" (hsm : hss) + throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs index 4591c4c5e..c49a2d7de 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -12,9 +12,6 @@ module Swarm.TUI.Controller.EventHandlers.Robot ( robotEventHandlers, handleRobotPanelEvent, - - -- ** Helper functions - runBaseTerm, ) where import Brick @@ -22,15 +19,11 @@ import Brick.Keybindings import Control.Lens as Lens import Control.Lens.Extras as Lens (is) import Control.Monad (unless, when) -import Control.Monad.State (MonadState, execState) import Data.Text qualified as T import Graphics.Vty qualified as V -import Swarm.Game.CESK (continue) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Robot.Concrete import Swarm.Game.State -import Swarm.Game.State.Robot (activateRobot) -import Swarm.Game.State.Substate (REPLStatus (..), replStatus) import Swarm.Language.Pipeline.QQ (tmQ) import Swarm.Language.Syntax hiding (Key) import Swarm.TUI.Controller.Util @@ -154,19 +147,4 @@ handleInventorySearchEvent = \case zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do uiInventoryShouldUpdate .= True - act - -runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () -runBaseTerm = maybe (pure ()) startBaseProgram - where - -- The player typed something at the REPL and hit Enter; this - -- function takes the resulting ProcessedTerm (if the REPL - -- input is valid) and sets up the base robot to run it. - startBaseProgram t = do - -- Set the REPL status to Working - gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing - -- Set up the robot's CESK machine to evaluate/execute the - -- given term. - gameState . baseRobot . machine %= continue t - -- Finally, be sure to activate the base robot. - gameState %= execState (zoomRobots $ activateRobot 0) + act \ No newline at end of file diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 86cc58b79..bb879b7c5 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -9,18 +9,19 @@ import Brick.Focus import Brick.Keybindings import Control.Carrier.Lift qualified as Fused import Control.Carrier.State.Lazy qualified as Fused -import Control.Lens -import Control.Lens qualified as Lens +import Control.Lens as Lens import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) -import Control.Monad.State (MonadState) +import Control.Monad.State (MonadState, execState) import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text) import Graphics.Vty qualified as V import Swarm.Effect (TimeIOC, runTimeIO) +import Swarm.Game.CESK (continue) import Swarm.Game.Device import Swarm.Game.Robot (robotCapabilities) +import Swarm.Game.Robot.Concrete import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot @@ -30,6 +31,7 @@ import Swarm.Game.Universe import Swarm.Game.World qualified as W import Swarm.Game.World.Coords import Swarm.Language.Capability (Capability (CDebug)) +import Swarm.Language.Syntax hiding (Key) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) @@ -75,8 +77,7 @@ openModal mt = do -- Set the game to AutoPause if needed ensurePause = do pause <- use $ gameState . temporal . paused - unless (pause || isRunningModal mt) $ do - gameState . temporal . runStatus .= AutoPause + unless (pause || isRunningModal mt) $ gameState . temporal . runStatus .= AutoPause -- | The running modals do not autopause the game. isRunningModal :: ModalType -> Bool @@ -179,3 +180,18 @@ allHandlers :: allHandlers eEmbed f = map handleEvent1 [minBound .. maxBound] where handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a + +runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () +runBaseTerm = maybe (pure ()) startBaseProgram + where + -- The player typed something at the REPL and hit Enter; this + -- function takes the resulting ProcessedTerm (if the REPL + -- input is valid) and sets up the base robot to run it. + startBaseProgram t = do + -- Set the REPL status to Working + gameState . gameControls . replStatus .= REPLWorking (t ^. sType) Nothing + -- Set up the robot's CESK machine to evaluate/execute the + -- given term. + gameState . baseRobot . machine %= continue t + -- Finally, be sure to activate the base robot. + gameState %= execState (zoomRobots $ activateRobot 0) diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index d16f0749a..a42c4d778 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -81,10 +81,7 @@ import Swarm.Game.State.Substate import Swarm.Game.World.Gen (Seed) import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) -import Swarm.TUI.Controller.EventHandlers.Main (mainEventHandlers) -import Swarm.TUI.Controller.EventHandlers.REPL (replEventHandlers) -import Swarm.TUI.Controller.EventHandlers.Robot (robotEventHandlers) -import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) +import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting @@ -103,34 +100,6 @@ import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock -createEventHandlers :: - (Has (Throw SystemFailure) sig m) => - KeyConfig SwarmEvent -> - m EventHandlers -createEventHandlers config = do - mainHandler <- buildDispatcher mainEventHandlers - replHandler <- buildDispatcher replEventHandlers - worldHandler <- buildDispatcher worldEventHandlers - robotHandler <- buildDispatcher robotEventHandlers - return EventHandlers {..} - where - -- this error handling code is modified version of the brick demo app: - -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 - buildDispatcher handlers = case keyDispatcher config handlers of - Right d -> return d - Left collisions -> do - let errorHeader = "Error: some key events have the same keys bound to them.\n" - let handlerErrors = flip map collisions $ \(b, hs) -> - let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" - hss = flip map hs $ \h -> - let trigger = case BK.kehEventTrigger $ BK.khHandler h of - ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" - ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" - desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h - in " " <> desc <> " (" <> trigger <> ")" - in T.intercalate "\n" (hsm : hss) - throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) - loadKeybindingConfig :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => m [(SwarmEvent, BindingState)] diff --git a/swarm.cabal b/swarm.cabal index 3c2ff4b14..d88fe90e5 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -664,6 +664,7 @@ library swarm-tui exposed-modules: Swarm.TUI.Border Swarm.TUI.Controller + Swarm.TUI.Controller.EventHandlers Swarm.TUI.Controller.EventHandlers.Frame Swarm.TUI.Controller.EventHandlers.Main Swarm.TUI.Controller.EventHandlers.REPL From 5394b8075ba72fdf8e108852043d75748c4bc95e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 15:17:35 +0200 Subject: [PATCH 30/55] Prepare for inter dispatcher collisions --- src/swarm-tui/Swarm/TUI/Controller.hs | 6 ++-- .../Swarm/TUI/Controller/EventHandlers.hs | 31 ++++++++++++++----- .../TUI/Controller/EventHandlers/Robot.hs | 4 +-- src/swarm-tui/Swarm/TUI/Model.hs | 23 +++++++------- 4 files changed, 41 insertions(+), 23 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 1e17b05ee..477b3d3cc 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -274,7 +274,7 @@ pressAnyKey _ _ = continueWithoutRedraw handleMainEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleMainEvent ev = do s <- get - let keyHandler = s ^. keyEventHandling . keyHandlers . to mainHandler + let keyHandler = s ^. keyEventHandling . keyDispatchers . to mainGameDispatcher case ev of AppEvent ae -> case ae of Frame @@ -342,7 +342,7 @@ handleMainEvent ev = do Just (FocusablePanel x) -> case x of REPLPanel -> handleREPLEvent ev WorldPanel | VtyEvent (V.EvKey k m) <- ev -> do - wh <- use $ keyEventHandling . keyHandlers . to worldHandler + wh <- use $ keyEventHandling . keyDispatchers . to worldDispatcher void $ B.handleKey wh k m WorldPanel | otherwise -> continueWithoutRedraw WorldEditorPanel -> EC.handleWorldEditorPanelEvent ev @@ -457,7 +457,7 @@ handleREPLEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEvent x = do s <- get let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode - let keyHandler = s ^. keyEventHandling . keyHandlers . to replHandler + let keyHandler = s ^. keyEventHandling . keyDispatchers . to replDispatcher case x of -- pass to key handler (allows users to configure bindings) VtyEvent (V.EvKey k m) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index ce56bfefc..f00f19922 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -29,10 +29,14 @@ module Swarm.TUI.Controller.EventHandlers ( ticksPerFrameCap, ) where +import Brick hiding (on) import Brick.Keybindings as BK import Control.Effect.Accum import Control.Effect.Throw -import Data.Maybe (fromMaybe) +import Data.Function (on) +import Data.List (groupBy, sortBy) +import Data.List.NonEmpty qualified as NE +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text qualified as T import Swarm.Game.Failure (SystemFailure (..)) import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) @@ -49,13 +53,13 @@ import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) createEventHandlers :: (Has (Throw SystemFailure) sig m) => KeyConfig SwarmEvent -> - m EventHandlers + m SwarmKeyDispatchers createEventHandlers config = do - mainHandler <- buildDispatcher mainEventHandlers - replHandler <- buildDispatcher replEventHandlers - worldHandler <- buildDispatcher worldEventHandlers - robotHandler <- buildDispatcher robotEventHandlers - return EventHandlers {..} + mainGameDispatcher <- buildDispatcher mainEventHandlers + replDispatcher <- buildDispatcher replEventHandlers + worldDispatcher <- buildDispatcher worldEventHandlers + robotDispatcher <- buildDispatcher robotEventHandlers + return SwarmKeyDispatchers {..} where -- this error handling code is modified version of the brick demo app: -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 @@ -73,3 +77,16 @@ createEventHandlers config = do in " " <> desc <> " (" <> trigger <> ")" in T.intercalate "\n" (hsm : hss) throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) + +-- | Take two dispatchers (that do not have conflict themselves) and find conflicting keys between them. +conflicts :: SwarmKeyDispatcher -> SwarmKeyDispatcher -> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])] +conflicts d1 d2 = combine <$> badGroups + where + l1 = keyDispatcherToList d1 + l2 = keyDispatcherToList d2 + gs = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) (l1 <> l2) + badGroups = filter ((1 <) . length) $ mapMaybe NE.nonEmpty gs + combine :: NE.NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m]) + combine as = + let b = fst $ NE.head as + in (b, snd <$> NE.toList as) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs index c49a2d7de..542346f76 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Robot.hs @@ -38,7 +38,7 @@ import Swarm.TUI.View.Util (generateModal) handleRobotPanelEvent :: BrickEvent Name AppEvent -> EventM Name AppState () handleRobotPanelEvent bev = do search <- use $ uiState . uiGameplay . uiInventory . uiInventorySearch - keyHandler <- use $ keyEventHandling . keyHandlers . to robotHandler + keyHandler <- use $ keyEventHandling . keyDispatchers . to robotDispatcher case search of Just _ -> handleInventorySearchEvent bev Nothing -> case bev of @@ -147,4 +147,4 @@ handleInventorySearchEvent = \case zoomInventory :: EventM Name UIInventory () -> EventM Name AppState () zoomInventory act = Brick.zoom (uiState . uiGameplay . uiInventory) $ do uiInventoryShouldUpdate .= True - act \ No newline at end of file + act diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 78c05f113..67b35183a 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -47,10 +47,11 @@ module Swarm.TUI.Model ( -- ** Utility logEvent, + SwarmKeyDispatcher, KeyEventHandlingState (KeyEventHandlingState), - EventHandlers (..), + SwarmKeyDispatchers (..), keyConfig, - keyHandlers, + keyDispatchers, -- * App state AppState (AppState), @@ -148,22 +149,22 @@ logEvent src sev who msg el = data KeyEventHandlingState = KeyEventHandlingState { _keyConfig :: KeyConfig SwarmEvent - , _keyHandlers :: EventHandlers + , _keyDispatchers :: SwarmKeyDispatchers } keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) keyConfig = lens _keyConfig (\s k -> s {_keyConfig = k}) -keyHandlers :: Lens' KeyEventHandlingState EventHandlers -keyHandlers = lens _keyHandlers (\s k -> s {_keyHandlers = k}) +keyDispatchers :: Lens' KeyEventHandlingState SwarmKeyDispatchers +keyDispatchers = lens _keyDispatchers (\s k -> s {_keyDispatchers = k}) -type SwarmEventHandler = KeyDispatcher SwarmEvent (EventM Name AppState) +type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) -data EventHandlers = EventHandlers - { mainHandler :: SwarmEventHandler - , replHandler :: SwarmEventHandler - , worldHandler :: SwarmEventHandler - , robotHandler :: SwarmEventHandler +data SwarmKeyDispatchers = SwarmKeyDispatchers + { mainGameDispatcher :: SwarmKeyDispatcher + , replDispatcher :: SwarmKeyDispatcher + , worldDispatcher :: SwarmKeyDispatcher + , robotDispatcher :: SwarmKeyDispatcher } -- ---------------------------------------------------------------------------- From e6991f57e82b3d2c1edc334be633b7a0ebbbd50c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 15:55:38 +0200 Subject: [PATCH 31/55] Handle conflict between dispatchers For example: ```bash $ cat ~/.config/swarm/config.ini [keybindings] show zero inventory entites = f1 $ cabal run swarm -O0 -- keybindings Error: some key events have keys bound to them in 'Main game events' and in 'Robot panel events' Handlers with the 'F1' binding: View Help screen (triggered by the event 'view help') Show entities with zero count in inventory (triggered by the event 'show zero inventory entites') ``` --- .../Swarm/TUI/Controller/EventHandlers.hs | 67 +++++++++++++------ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 4 +- 2 files changed, 47 insertions(+), 24 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index f00f19922..e6cd7a5e4 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -4,11 +4,20 @@ -- | -- SPDX-License-Identifier: BSD-3-Clause -- --- Sum types representing the Swarm events --- abstracted away from keybindings. +-- Swarm (abstract) event handlers allow players to customize some keybindings. +-- This all comes together in 'Swarm.TUI.Controller' which calls the handlers +-- for parts of UI and also handles mouse events and frame updates. +-- +-- The high level overview is this: +-- 1. The 'SwarmEvent' is a enumeration of abstracts key events ('PauseEvent', etc.) +-- 2. The 'AppState' stores the key configuration and key dispatchers (keys to handlers) +-- 3. Here we declare the handlers for abstract events. +-- 4. When provided with 'KeyConfig' (can include customized keybindings) we can +-- 'createKeyDispatchers in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. +-- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. module Swarm.TUI.Controller.EventHandlers ( -- * Documentation - createEventHandlers, + createKeyDispatchers, -- ** Main game handler mainEventHandlers, @@ -47,36 +56,50 @@ import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) --- | Create event handlers with given key config. +-- | Create key dispatchers that call (abstract) event handlers based on given key config. -- --- Fails if any key events have conflict within one dispatcher. -createEventHandlers :: +-- Fails if any key events have conflict within one dispatcher or when a main dispatcher +-- has conflict with one of the subdispatchers. +createKeyDispatchers :: (Has (Throw SystemFailure) sig m) => KeyConfig SwarmEvent -> m SwarmKeyDispatchers -createEventHandlers config = do +createKeyDispatchers config = do mainGameDispatcher <- buildDispatcher mainEventHandlers - replDispatcher <- buildDispatcher replEventHandlers - worldDispatcher <- buildDispatcher worldEventHandlers - robotDispatcher <- buildDispatcher robotEventHandlers + let buildSubMainDispatcher = buildSubDispatcher "Main game events" mainGameDispatcher + replDispatcher <- buildSubMainDispatcher "REPL panel events" replEventHandlers + worldDispatcher <- buildSubMainDispatcher "World panel events" worldEventHandlers + robotDispatcher <- buildSubMainDispatcher "Robot panel events" robotEventHandlers return SwarmKeyDispatchers {..} where -- this error handling code is modified version of the brick demo app: -- https://github.com/jtdaugherty/brick/blob/764e66897/programs/CustomKeybindingDemo.hs#L216 buildDispatcher handlers = case keyDispatcher config handlers of + Left collisions -> + throwLoadingFailure $ + "Error: some key events have the same keys bound to them.\n" + : handlerErrors collisions Right d -> return d - Left collisions -> do - let errorHeader = "Error: some key events have the same keys bound to them.\n" - let handlerErrors = flip map collisions $ \(b, hs) -> - let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" - hss = flip map hs $ \h -> - let trigger = case BK.kehEventTrigger $ BK.khHandler h of - ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" - ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" - desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h - in " " <> desc <> " (" <> trigger <> ")" - in T.intercalate "\n" (hsm : hss) - throwError $ CustomFailure (T.intercalate "\n" $ errorHeader : handlerErrors) + buildSubDispatcher parentName parentDispatcher name handlers = do + d <- buildDispatcher handlers + let collisions = conflicts parentDispatcher d + if null collisions + then return d + else + throwLoadingFailure $ + ("Error: some key events have keys bound to them in '" <> parentName <> "' and in '" <> name <> "'") + : handlerErrors collisions + + throwLoadingFailure = throwError . CustomFailure . T.intercalate "\n" + handlerErrors collisions = flip map collisions $ \(b, hs) -> + let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" + hss = flip map hs $ \h -> + let trigger = case BK.kehEventTrigger $ BK.khHandler h of + ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" + ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h + in " " <> desc <> " (" <> trigger <> ")" + in T.intercalate "\n" (hsm : hss) -- | Take two dispatchers (that do not have conflict themselves) and find conflicting keys between them. conflicts :: SwarmKeyDispatcher -> SwarmKeyDispatcher -> [(Binding, [KeyHandler SwarmEvent (EventM Name AppState)])] diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index a42c4d778..83ab69e78 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -119,8 +119,8 @@ initKeyHandlingState :: initKeyHandlingState = do customBindings <- loadKeybindingConfig let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings - handlers <- createEventHandlers cfg - return $ KeyEventHandlingState cfg handlers + dispatchers <- createKeyDispatchers cfg + return $ KeyEventHandlingState cfg dispatchers data KeybindingPrint = MarkdownPrint | TextPrint From 8cc493cd69fde0e281fcbc871e6e736e9aedbc6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 17:08:04 +0200 Subject: [PATCH 32/55] Add INI output --- app/Main.hs | 17 +-- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 105 +++++++++++++++++++ src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs | 54 +--------- swarm.cabal | 1 + 4 files changed, 119 insertions(+), 58 deletions(-) create mode 100644 src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs diff --git a/app/Main.hs b/app/Main.hs index a4c3c622c..729d5f4c1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -6,6 +6,7 @@ -- SPDX-License-Identifier: BSD-3-Clause module Main where +import Control.Monad (when) import Data.Foldable qualified import Data.Text.IO qualified as T import GitHash (GitInfo, giBranch, giHash, tGitInfoCwdTry) @@ -16,7 +17,7 @@ import Swarm.Language.Format import Swarm.Language.LSP (lspMain) import Swarm.Language.Parser.Core (LanguageVersion (..)) import Swarm.TUI.Model (AppOpts (..), ColorMode (..)) -import Swarm.TUI.Model.StateUpdate (KeybindingPrint (..), showKeybindings) +import Swarm.TUI.Model.KeyBindings (KeybindingPrint (..), showKeybindings) import Swarm.TUI.Model.UI (defaultInitLgTicksPerSecond) import Swarm.Version import Swarm.Web (defaultPort) @@ -79,7 +80,10 @@ cliParser = langVer = flag SwarmLangLatest SwarmLang0_5 (long "v0.5" <> help "Read (& convert) code from Swarm version 0.5") printKeyMode :: Parser KeybindingPrint - printKeyMode = flag TextPrint MarkdownPrint (long "markdown" <> help "Print in markdown table format.") + printKeyMode = + flag' IniPrint (long "ini" <> help "Print in INI format, without additional file location info.") + <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format.") + <|> pure TextPrint parseFormat :: Parser FormatConfig parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper @@ -137,10 +141,11 @@ printKeybindings :: KeybindingPrint -> IO () printKeybindings p = do kb <- showKeybindings p T.putStrLn kb - (iniExists, ini) <- getSwarmConfigIniFile - let iniState = if iniExists then "is" else "can be created" - putStrLn $ "\nThe configuration file " <> iniState <> " at:" - putStrLn ini + when (p /= IniPrint) $ do + (iniExists, ini) <- getSwarmConfigIniFile + let iniState = if iniExists then "is" else "can be created" + putStrLn $ "\nThe configuration file " <> iniState <> " at:" + putStrLn ini main :: IO () main = do diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs new file mode 100644 index 000000000..3f97f54b3 --- /dev/null +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- SPDX-License-Identifier: BSD-3-Clause +module Swarm.TUI.Model.KeyBindings ( + initKeyHandlingState, + KeybindingPrint (..), + showKeybindings, +) where + +import Brick.Keybindings as BK +import Control.Carrier.Lift (runM) +import Control.Carrier.Throw.Either (runThrow) +import Control.Effect.Accum +import Control.Effect.Lift +import Control.Effect.Throw +import Control.Lens hiding (from, (<.>)) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) +import Swarm.Language.Pretty (prettyText) +import Swarm.TUI.Controller.EventHandlers +import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) + +loadKeybindingConfig :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m [(SwarmEvent, BindingState)] +loadKeybindingConfig = do + (iniExists, ini) <- sendIO getSwarmConfigIniFile + if not iniExists + then return [] + else do + loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini + case loadedCustomBindings of + Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) + Right bs -> pure $ fromMaybe [] bs + +initKeyHandlingState :: + (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => + m KeyEventHandlingState +initKeyHandlingState = do + customBindings <- loadKeybindingConfig + let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings + dispatchers <- createKeyDispatchers cfg + return $ KeyEventHandlingState cfg dispatchers + +data KeybindingPrint = MarkdownPrint | TextPrint | IniPrint + deriving (Eq, Ord, Show) + +showKeybindings :: KeybindingPrint -> IO Text +showKeybindings kPrint = do + bindings <- runM $ runThrow @SystemFailure initKeyHandlingState + pure $ case bindings of + Left e -> prettyText e + Right bs -> showTable kPrint (bs ^. keyConfig) sections + where + showTable = \case + MarkdownPrint -> keybindingMarkdownTable + TextPrint -> keybindingTextTable + IniPrint -> keybindingINI + sections = + [ ("main", mainEventHandlers) + , ("repl", replEventHandlers) + , ("world", worldEventHandlers) + , ("robot", robotEventHandlers) + ] + +keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text +keybindingINI kc sections = + T.unlines $ + "[keybindings]\n" + : "; Uncomment the assignment and set comma separated list" + : "; of keybindings or \"unbind\" on the right. See:" + : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n" + : map (keyBindingEventINI kc) handlersData + where + handlersData = concatMap (mapMaybe handlerData . snd) sections + handlerData h = case kehEventTrigger h of + ByKey _ -> Nothing + ByEvent k -> Just (k, handlerDescription $ kehHandler h) + +keyBindingEventINI :: Ord k => KeyConfig k -> (k, Text) -> Text +keyBindingEventINI kc (ev, description) = + T.unlines + [ ";; " <> description + , commentDefault <> name <> " = " <> bindingList + ] + where + commentDefault = if custom then "" else "; " + (custom, bindingList) = case lookupKeyConfigBindings kc ev of + Just Unbound -> (True, "unbound") + Just (BindingList bs) -> (True, listBindings bs) + Nothing -> + ( False + , if null (allDefaultBindings kc ev) + then "unbound" + else listBindings $ allDefaultBindings kc ev + ) + listBindings = T.intercalate "," . fmap ppBinding + name = case keyEventName (keyConfigEvents kc) ev of + Just n -> n + Nothing -> error $ "unnamed event: " <> T.unpack description diff --git a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs index 83ab69e78..f76b9a965 100644 --- a/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs +++ b/src/swarm-tui/Swarm/TUI/Model/StateUpdate.hs @@ -15,16 +15,10 @@ module Swarm.TUI.Model.StateUpdate ( attainAchievement, attainAchievement', scenarioToAppState, - - -- ** Keybindings - initKeyHandlingState, - KeybindingPrint (..), - showKeybindings, ) where import Brick.AttrMap (applyAttrMappings) import Brick.Focus -import Brick.Keybindings as BK import Brick.Widgets.List qualified as BL import Control.Applicative ((<|>)) import Control.Carrier.Accum.FixedStrict (runAccum) @@ -47,11 +41,9 @@ import Data.Map qualified as M import Data.Maybe (fromMaybe, isJust) import Data.Sequence (Seq) import Data.Text (Text) -import Data.Text qualified as T import Data.Time (getZonedTime) -import Swarm.Game.Failure (Asset (..), LoadingFailure (..), SystemFailure (..)) +import Swarm.Game.Failure (SystemFailure (..)) import Swarm.Game.Land -import Swarm.Game.ResourceLoading (getSwarmConfigIniFile) import Swarm.Game.Scenario ( ScenarioInputs (..), gsiScenarioInputs, @@ -81,15 +73,14 @@ import Swarm.Game.State.Substate import Swarm.Game.World.Gen (Seed) import Swarm.Language.Pretty (prettyText) import Swarm.Log (LogSource (SystemLog), Severity (..)) -import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Editor.Model qualified as EM import Swarm.TUI.Editor.Util qualified as EU import Swarm.TUI.Inventory.Sorting import Swarm.TUI.Launch.Model (toSerializableParams) import Swarm.TUI.Model import Swarm.TUI.Model.Achievements -import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) import Swarm.TUI.Model.Goal (emptyGoalDisplay) +import Swarm.TUI.Model.KeyBindings import Swarm.TUI.Model.Name import Swarm.TUI.Model.Repl import Swarm.TUI.Model.Structure @@ -100,47 +91,6 @@ import Swarm.TUI.View.Structure qualified as SR import Swarm.Util.Effect (asExceptT, withThrow) import System.Clock -loadKeybindingConfig :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - m [(SwarmEvent, BindingState)] -loadKeybindingConfig = do - (iniExists, ini) <- sendIO getSwarmConfigIniFile - if not iniExists - then return [] - else do - loadedCustomBindings <- sendIO $ keybindingsFromFile swarmEvents "keybindings" ini - case loadedCustomBindings of - Left e -> throwError $ AssetNotLoaded Keybindings ini (CustomMessage $ T.pack e) - Right bs -> pure $ fromMaybe [] bs - -initKeyHandlingState :: - (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => - m KeyEventHandlingState -initKeyHandlingState = do - customBindings <- loadKeybindingConfig - let cfg = newKeyConfig swarmEvents defaultSwarmBindings customBindings - dispatchers <- createKeyDispatchers cfg - return $ KeyEventHandlingState cfg dispatchers - -data KeybindingPrint = MarkdownPrint | TextPrint - -showKeybindings :: KeybindingPrint -> IO Text -showKeybindings kPrint = do - bindings <- runM $ runThrow @SystemFailure initKeyHandlingState - pure $ case bindings of - Left e -> prettyText e - Right bs -> showTable kPrint (bs ^. keyConfig) sections - where - showTable = \case - MarkdownPrint -> keybindingMarkdownTable - TextPrint -> keybindingTextTable - sections = - [ ("main", mainEventHandlers) - , ("repl", replEventHandlers) - , ("world", worldEventHandlers) - , ("robot", robotEventHandlers) - ] - -- | Initialize the 'AppState' from scratch. initAppState :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => diff --git a/swarm.cabal b/swarm.cabal index d88fe90e5..351f34336 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -690,6 +690,7 @@ library swarm-tui Swarm.TUI.Model.Achievements Swarm.TUI.Model.Event Swarm.TUI.Model.Goal + Swarm.TUI.Model.KeyBindings Swarm.TUI.Model.Menu Swarm.TUI.Model.Name Swarm.TUI.Model.Repl From 8c1d43f589642656452e8c231cbbae09af8c0e8c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 17:30:08 +0200 Subject: [PATCH 33/55] Update dispatchers type name in Web --- src/swarm-web/Swarm/Web.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-web/Swarm/Web.hs b/src/swarm-web/Swarm/Web.hs index 76f8c0eb3..a4741c186 100644 --- a/src/swarm-web/Swarm/Web.hs +++ b/src/swarm-web/Swarm/Web.hs @@ -79,7 +79,7 @@ import Swarm.Game.State.Substate import Swarm.Game.Step.Path.Type import Swarm.Language.Pipeline (processTermEither) import Swarm.Language.Pretty (prettyTextLine) -import Swarm.TUI.Model hiding (EventHandlers (..)) +import Swarm.TUI.Model hiding (SwarmKeyDispatchers (..)) import Swarm.TUI.Model.Goal import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq) import Swarm.TUI.Model.UI From f5cceeeec2679d03bd3bc3b5eec8aa3baf2bf37d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Sun, 30 Jun 2024 20:41:19 +0200 Subject: [PATCH 34/55] Show keybindings help in CLI Co-authored-by: Brent Yorgey --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 729d5f4c1..596b3586f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -46,7 +46,7 @@ cliParser = [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) - , command "keybindings" (info (ListKeybinding <$> printKeyMode) (progDesc "List the keybindings")) + , command "keybindings" (info (ListKeybinding <$> printKeyMode <**> helper) (progDesc "List the keybindings")) ] ) <|> Run From e5053db82fd6ef834564f22a957ff0187275ab2a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?= <44544735+xsebek@users.noreply.github.com> Date: Sun, 30 Jun 2024 21:13:43 +0200 Subject: [PATCH 35/55] Apply fixes by @byorgey Thanks a lot! Co-authored-by: Brent Yorgey --- src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs | 2 +- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 2 +- src/swarm-tui/Swarm/TUI/Model/Event.hs | 2 +- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index e6cd7a5e4..0c801e8d2 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -13,7 +13,7 @@ -- 2. The 'AppState' stores the key configuration and key dispatchers (keys to handlers) -- 3. Here we declare the handlers for abstract events. -- 4. When provided with 'KeyConfig' (can include customized keybindings) we can --- 'createKeyDispatchers in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. +-- 'createKeyDispatchers' in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. -- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. module Swarm.TUI.Controller.EventHandlers ( -- * Documentation diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index bb879b7c5..2dd111f3c 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -185,7 +185,7 @@ runBaseTerm :: (MonadState AppState m) => Maybe TSyntax -> m () runBaseTerm = maybe (pure ()) startBaseProgram where -- The player typed something at the REPL and hit Enter; this - -- function takes the resulting ProcessedTerm (if the REPL + -- function takes the resulting term (if the REPL -- input is valid) and sets up the base robot to run it. startBaseProgram t = do -- Set the REPL status to Working diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 27b9050d6..c5715cc40 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -200,7 +200,7 @@ data RobotEvent robotPanelEvents :: KeyEvents RobotEvent robotPanelEvents = allKeyEvents $ \case MakeEntityEvent -> "make entity" - ShowZeroInventoryEntitiesEvent -> "show zero inventory entites" + ShowZeroInventoryEntitiesEvent -> "show zero inventory entities" CycleInventorySortEvent -> "cycle inventory sort" SwitchInventorySortDirection -> "switch inventory direction" SearchInventoryEvent -> "search inventory" diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs index 3f97f54b3..d86234e84 100644 --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -73,7 +73,7 @@ keybindingINI kc sections = T.unlines $ "[keybindings]\n" : "; Uncomment the assignment and set comma separated list" - : "; of keybindings or \"unbind\" on the right. See:" + : "; of keybindings or \"unbound\" on the right. See:" : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n" : map (keyBindingEventINI kc) handlersData where From 71fb876dbc311784f4a74a85be48c3cdf4e88bf2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 22:01:54 +0200 Subject: [PATCH 36/55] Add init flag to keybindings CLI --- app/Main.hs | 34 ++++++++++++++++++++++------------ 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 596b3586f..01aa1d989 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,7 +34,7 @@ commitInfo = case gitInfo of data CLI = Run AppOpts - | ListKeybinding KeybindingPrint + | ListKeybinding Bool KeybindingPrint | Format FormatConfig | LSP | Version @@ -46,7 +46,7 @@ cliParser = [ command "format" (info (Format <$> parseFormat) (progDesc "Format a file")) , command "lsp" (info (pure LSP) (progDesc "Start the LSP")) , command "version" (info (pure Version) (progDesc "Get current and upstream version.")) - , command "keybindings" (info (ListKeybinding <$> printKeyMode <**> helper) (progDesc "List the keybindings")) + , command "keybindings" (info (ListKeybinding <$> initKeybindingConfig <*> printKeyMode <**> helper) (progDesc "List the keybindings")) ] ) <|> Run @@ -81,10 +81,13 @@ cliParser = printKeyMode :: Parser KeybindingPrint printKeyMode = - flag' IniPrint (long "ini" <> help "Print in INI format, without additional file location info.") - <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format.") + flag' IniPrint (long "ini" <> help "Print in INI format") + <|> flag' MarkdownPrint (long "markdown" <> help "Print in Markdown table format") <|> pure TextPrint + initKeybindingConfig :: Parser Bool + initKeybindingConfig = switch (short 'i' <> long "init" <> help "Initialise the keybindings configuration file") + parseFormat :: Parser FormatConfig parseFormat = FormatConfig <$> input <*> output <*> optional widthOpt <*> langVer <**> helper @@ -137,22 +140,29 @@ showVersion = do up <- getNewerReleaseVersion gitInfo either (hPrint stderr) (putStrLn . ("New upstream release: " <>)) up -printKeybindings :: KeybindingPrint -> IO () -printKeybindings p = do +printKeybindings :: Bool -> KeybindingPrint -> IO () +printKeybindings initialize p = do kb <- showKeybindings p T.putStrLn kb - when (p /= IniPrint) $ do - (iniExists, ini) <- getSwarmConfigIniFile - let iniState = if iniExists then "is" else "can be created" - putStrLn $ "\nThe configuration file " <> iniState <> " at:" - putStrLn ini + (iniExists, ini) <- getSwarmConfigIniFile + when initialize $ do + kbi <- showKeybindings IniPrint + T.writeFile ini kbi + let iniState + | iniExists && initialize = "has been updated" + | iniExists = "is" + | initialize = "has been created" + | otherwise = "can be created (--init)" + putStrLn $ '\n' : replicate 80 '-' + putStrLn $ "The configuration file " <> iniState <> " at:" + putStrLn ini main :: IO () main = do cli <- execParser cliInfo case cli of Run opts -> appMain opts - ListKeybinding p -> printKeybindings p + ListKeybinding initialize p -> printKeybindings initialize p Format cfg -> formatSwarmIO cfg LSP -> lspMain Version -> showVersion From 7f5ee30fd5cad5fa2e6528f70ce460d664cc2f95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 22:16:44 +0200 Subject: [PATCH 37/55] Add section comments to INI --- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs index d86234e84..125a90d46 100644 --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -15,6 +15,7 @@ import Control.Effect.Accum import Control.Effect.Lift import Control.Effect.Throw import Control.Lens hiding (from, (<.>)) +import Data.Bifunctor (second) import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T @@ -62,25 +63,27 @@ showKeybindings kPrint = do TextPrint -> keybindingTextTable IniPrint -> keybindingINI sections = - [ ("main", mainEventHandlers) - , ("repl", replEventHandlers) - , ("world", worldEventHandlers) - , ("robot", robotEventHandlers) + [ ("Main game", mainEventHandlers) + , ("REPL panel ", replEventHandlers) + , ("World view", worldEventHandlers) + , ("Robot panel", robotEventHandlers) ] keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text keybindingINI kc sections = - T.unlines $ + T.intercalate "\n" $ "[keybindings]\n" : "; Uncomment the assignment and set comma separated list" : "; of keybindings or \"unbound\" on the right. See:" : "; https://hackage.haskell.org/package/brick/docs/Brick-Keybindings-Parse.html#v:parseBinding\n" - : map (keyBindingEventINI kc) handlersData + : concatMap sectionsINI handlersData where - handlersData = concatMap (mapMaybe handlerData . snd) sections + handlersData = map (second $ mapMaybe handlerData) sections handlerData h = case kehEventTrigger h of ByKey _ -> Nothing ByEvent k -> Just (k, handlerDescription $ kehHandler h) + section s = "\n;;;; " <> s <> "\n" + sectionsINI (s, hs) = section s : map (keyBindingEventINI kc) hs keyBindingEventINI :: Ord k => KeyConfig k -> (k, Text) -> Text keyBindingEventINI kc (ev, description) = From d4c2fd41e2448454d0e323f67699f551875bacfc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 22:29:39 +0200 Subject: [PATCH 38/55] Move lenses --- src/swarm-tui/Swarm/TUI/Model.hs | 93 +++++++++++++++++--------------- 1 file changed, 49 insertions(+), 44 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Model.hs b/src/swarm-tui/Swarm/TUI/Model.hs index 67b35183a..0eebb453e 100644 --- a/src/swarm-tui/Swarm/TUI/Model.hs +++ b/src/swarm-tui/Swarm/TUI/Model.hs @@ -152,12 +152,6 @@ data KeyEventHandlingState = KeyEventHandlingState , _keyDispatchers :: SwarmKeyDispatchers } -keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) -keyConfig = lens _keyConfig (\s k -> s {_keyConfig = k}) - -keyDispatchers :: Lens' KeyEventHandlingState SwarmKeyDispatchers -keyDispatchers = lens _keyDispatchers (\s k -> s {_keyDispatchers = k}) - type SwarmKeyDispatcher = KeyDispatcher SwarmEvent (EventM Name AppState) data SwarmKeyDispatchers = SwarmKeyDispatchers @@ -183,44 +177,6 @@ data AppState = AppState , _runtimeState :: RuntimeState } --------------------------------------------------- --- Lenses for AppState - -makeLensesNoSigs ''AppState - --- | The 'GameState' record. -gameState :: Lens' AppState GameState - --- | The 'UIState' record. -uiState :: Lens' AppState UIState - --- | The key event handling configuration. -keyEventHandling :: Lens' AppState KeyEventHandlingState - --- | The 'RuntimeState' record -runtimeState :: Lens' AppState RuntimeState - --------------------------------------------------- --- Utility functions - --- | Get the currently focused 'InventoryListEntry' from the robot --- info panel (if any). -focusedItem :: AppState -> Maybe InventoryListEntry -focusedItem s = do - list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 - (_, entry) <- BL.listSelectedElement list - return entry - --- | Get the currently focused entity from the robot info panel (if --- any). This is just like 'focusedItem' but forgets the --- distinction between plain inventory items and equipped devices. -focusedEntity :: AppState -> Maybe Entity -focusedEntity = - focusedItem >=> \case - Separator _ -> Nothing - InventoryEntry _ e -> Just e - EquippedEntry e -> Just e - ------------------------------------------------------------ -- Functions for updating the UI state ------------------------------------------------------------ @@ -335,3 +291,52 @@ nextScenario = \case then Nothing else BL.listSelectedElement nextMenuList >>= preview _SISingle . snd _ -> Nothing + +-------------------------------------------------- +-- Lenses for KeyEventHandlingState + +makeLensesNoSigs ''KeyEventHandlingState + +-- | Keybindings (possibly customized by player) for 'SwarmEvent's. +keyConfig :: Lens' KeyEventHandlingState (KeyConfig SwarmEvent) + +-- | Dispatchers that will call handler on key combo. +keyDispatchers :: Lens' KeyEventHandlingState SwarmKeyDispatchers + +-------------------------------------------------- +-- Lenses for AppState + +makeLensesNoSigs ''AppState + +-- | The 'GameState' record. +gameState :: Lens' AppState GameState + +-- | The 'UIState' record. +uiState :: Lens' AppState UIState + +-- | The key event handling configuration. +keyEventHandling :: Lens' AppState KeyEventHandlingState + +-- | The 'RuntimeState' record +runtimeState :: Lens' AppState RuntimeState + +-------------------------------------------------- +-- Utility functions + +-- | Get the currently focused 'InventoryListEntry' from the robot +-- info panel (if any). +focusedItem :: AppState -> Maybe InventoryListEntry +focusedItem s = do + list <- s ^? uiState . uiGameplay . uiInventory . uiInventoryList . _Just . _2 + (_, entry) <- BL.listSelectedElement list + return entry + +-- | Get the currently focused entity from the robot info panel (if +-- any). This is just like 'focusedItem' but forgets the +-- distinction between plain inventory items and equipped devices. +focusedEntity :: AppState -> Maybe Entity +focusedEntity = + focusedItem >=> \case + Separator _ -> Nothing + InventoryEntry _ e -> Just e + EquippedEntry e -> Just e From 5ee4b29162debee634c9a43ed9afcdc885c53e32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 22:35:17 +0200 Subject: [PATCH 39/55] Use listEnums --- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 3 ++- src/swarm-tui/Swarm/TUI/Model/Event.hs | 4 +++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 2dd111f3c..9b622e13b 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -35,6 +35,7 @@ import Swarm.Language.Syntax hiding (Key) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) +import Swarm.Util (listEnums) import System.Clock (Clock (..), getTime) -- | Pattern synonyms to simplify brick event handler @@ -177,7 +178,7 @@ allHandlers :: (e1 -> e2) -> (e1 -> (Text, EventM Name AppState ())) -> [KeyEventHandler e2 (EventM Name AppState)] -allHandlers eEmbed f = map handleEvent1 [minBound .. maxBound] +allHandlers eEmbed f = map handleEvent1 listEnums where handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index c5715cc40..23e7beabb 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -16,9 +16,11 @@ module Swarm.TUI.Model.Event ( ) where import Brick.Keybindings +import Control.Arrow ((&&&)) import Data.Bifunctor (first) import Data.Text (Text) import Graphics.Vty qualified as V +import Swarm.Util (listEnums) data SwarmEvent = Main MainEvent @@ -217,7 +219,7 @@ defaultRobotPanelBindings = allBindings $ \case -- Helper methods allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e -allKeyEvents f = keyEvents $ map (\e -> (f e, e)) [minBound .. maxBound] +allKeyEvents f = keyEvents $ map (f &&& id) listEnums allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] allBindings f = map (\e -> (e, f e)) [minBound .. maxBound] From 8476bd16105da0c7131124e1bbda4dd01b43c074 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 30 Jun 2024 22:35:24 +0200 Subject: [PATCH 40/55] Tweak spacing --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 01aa1d989..8f0dc7f3c 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -153,7 +153,7 @@ printKeybindings initialize p = do | iniExists = "is" | initialize = "has been created" | otherwise = "can be created (--init)" - putStrLn $ '\n' : replicate 80 '-' + putStrLn $ replicate 80 '-' putStrLn $ "The configuration file " <> iniState <> " at:" putStrLn ini From 75c883cdd01d1b7e17ddcb8e969034b8a4a39edf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 10:34:03 +0200 Subject: [PATCH 41/55] Address Map editor shortcut conflicts with move-to-end-of-line shortcut #1962 --- src/swarm-tui/Swarm/TUI/Model/Event.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 23e7beabb..d0b1dbb0b 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -128,7 +128,7 @@ defaultMainBindings = allBindings $ \case FocusREPLEvent -> [meta 'r'] FocusInfoEvent -> [meta 't'] ToggleCreativeModeEvent -> [ctrl 'v'] - ToggleWorldEditorEvent -> [ctrl 'e'] + ToggleWorldEditorEvent -> [] ToggleREPLVisibilityEvent -> [meta ','] -- ---------------------------------------------- From 31ebc3d022e5bdc83fd9e3bc7925b7d528fa9fa4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 12:00:27 +0200 Subject: [PATCH 42/55] Show custom keybindings in key menus --- src/swarm-tui/Swarm/TUI/Model/Event.hs | 8 +-- src/swarm-tui/Swarm/TUI/View.hs | 92 ++++++++++++++++++-------- 2 files changed, 69 insertions(+), 31 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index d0b1dbb0b..c75b7ff2c 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -182,10 +182,10 @@ defaultWorldPanelBindings :: [(WorldEvent, [Binding])] defaultWorldPanelBindings = allBindings $ \case ViewBaseEvent -> [bind 'c'] ShowFpsEvent -> [bind 'f'] - MoveViewWestEvent -> [bind 'h', bind V.KLeft] - MoveViewSouthEvent -> [bind 'j', bind V.KDown] - MoveViewNorthEvent -> [bind 'k', bind V.KUp] - MoveViewEastEvent -> [bind 'l', bind V.KRight] + MoveViewWestEvent -> [bind V.KLeft, bind 'h'] + MoveViewSouthEvent -> [bind V.KDown, bind 'j'] + MoveViewNorthEvent -> [bind V.KUp, bind 'k'] + MoveViewEastEvent -> [bind V.KRight, bind 'l'] -- ---------------------------------------------- -- ROBOT EVENTS diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 2220a1503..0a4f62226 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -132,6 +132,7 @@ import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View import Swarm.TUI.Model +import Swarm.TUI.Model.Event qualified as SE import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI @@ -151,6 +152,9 @@ import System.Clock (TimeSpec (..)) import Text.Printf import Text.Wrap import Witch (into) +import Swarm.TUI.Model.Event (SwarmEvent) +import Brick.Keybindings (firstActiveBinding, ppBinding, Binding (..)) +import Graphics.Vty qualified as V -- | The main entry point for drawing the entire UI. Figures out -- which menu screen we should show (if any), or just the game itself. @@ -952,30 +956,31 @@ colorSeverity = \case drawModalMenu :: AppState -> Widget Name drawModalMenu s = vLimit 1 . hBox $ map (padLeftRight 1 . drawKeyCmd) globalKeyCmds where - notificationKey :: Getter GameState (Notifications a) -> Text -> Text -> Maybe (KeyHighlight, Text, Text) + notificationKey :: Getter GameState (Notifications a) -> SE.MainEvent -> Text -> Maybe (KeyHighlight, Text, Text) notificationKey notifLens key name | null (s ^. gameState . notifLens . notificationsContent) = Nothing | otherwise = let highlight | s ^. gameState . notifLens . notificationsCount > 0 = Alert | otherwise = NoHighlight - in Just (highlight, key, name) + in Just (highlight, keyM key, name) -- Hides this key if the recognizable structure list is empty structuresKey = if null $ s ^. gameState . discovery . structureRecognition . automatons . originalStructureDefinitions then Nothing - else Just (NoHighlight, "F6", "Structures") + else Just (NoHighlight, keyM SE.ViewStructuresEvent, "Structures") globalKeyCmds = catMaybes - [ Just (NoHighlight, "F1", "Help") - , Just (NoHighlight, "F2", "Robots") - , notificationKey (discovery . availableRecipes) "F3" "Recipes" - , notificationKey (discovery . availableCommands) "F4" "Commands" - , notificationKey messageNotifications "F5" "Messages" + [ Just (NoHighlight, keyM SE.ViewHelpEvent, "Help") + , Just (NoHighlight, keyM SE.ViewRobotsEvent, "Robots") + , notificationKey (discovery . availableRecipes) SE.ViewRecipesEvent "Recipes" + , notificationKey (discovery . availableCommands) SE.ViewCommandsEvent "Commands" + , notificationKey messageNotifications SE.ViewMessagesEvent "Messages" , structuresKey ] + keyM = bindingText s . SE.Main -- | Draw a menu explaining what key commands are available for the -- current panel. This menu is displayed as one or two lines in @@ -1040,15 +1045,24 @@ drawKeyMenu s = True -> "Creative" globalKeyCmds = catMaybes - [ may goal (NoHighlight, "^g", "goal") - , may cheat (NoHighlight, "^v", "creative") - , may cheat (NoHighlight, "^e", "editor") - , Just (NoHighlight, "^p", if isPaused then "unpause" else "pause") - , may isPaused (NoHighlight, "^o", "step") - , may (isPaused && hasDebug) (if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight, "M-d", "debug") - , Just (NoHighlight, "^zx", "speed") - , Just (NoHighlight, "M-,", if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL") - , Just (if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert, "M-h", "hide robots") + [ may goal (NoHighlight, keyM SE.ViewGoalEvent, "goal") + , may cheat (NoHighlight, keyM SE.ToggleCreativeModeEvent, "creative") + , may cheat (NoHighlight, keyM SE.ToggleWorldEditorEvent, "editor") + , Just (NoHighlight, keyM SE.PauseEvent, if isPaused then "unpause" else "pause") + , may isPaused (NoHighlight, keyM SE.RunSingleTickEvent, "step") + , may (isPaused && hasDebug) + (if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight + , keyM SE.ShowCESKDebugEvent + , "debug") + , Just (NoHighlight, keyM SE.IncreaseTpsEvent <> "/" <> keyM SE.DecreaseTpsEvent, "speed") + , Just + (NoHighlight + , keyM SE.ToggleREPLVisibilityEvent + , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL") + , Just + (if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert + , keyM SE.HideRobotsEvent + , "hide robots") ] may b = if b then Just else const Nothing @@ -1060,27 +1074,51 @@ drawKeyMenu s = [ ("↓↑", "history") ] ++ [("Enter", "execute") | not isReplWorking] - ++ [("^c", "cancel") | isReplWorking] - ++ [("M-p", renderPilotModeSwitch ctrlMode) | creative] - ++ [("M-k", renderHandlerModeSwitch ctrlMode) | handlerInstalled] + ++ [(keyR SE.CancelRunningProgramEvent, "cancel") | isReplWorking] + ++ [(keyR SE.TogglePilotingModeEvent, renderPilotModeSwitch ctrlMode) | creative] + ++ [(keyR SE.ToggleCustomKeyHandlingEvent, renderHandlerModeSwitch ctrlMode) | handlerInstalled] ++ [("PgUp/Dn", "scroll")] keyCmdsFor (Just (FocusablePanel WorldPanel)) = - [ ("←↓↑→ / hjkl", "scroll") | canScroll + [ (T.intercalate "/" $ map keyW + [ SE.MoveViewWestEvent + , SE.MoveViewNorthEvent + , SE.MoveViewEastEvent + , SE.MoveViewSouthEvent + ] + , "scroll") | canScroll ] - ++ [("c", "recenter") | not viewingBase] - ++ [("f", "FPS")] + ++ [(keyW SE.ViewBaseEvent, "recenter") | not viewingBase] + ++ [(keyW SE.ShowFpsEvent, "FPS")] keyCmdsFor (Just (FocusablePanel RobotPanel)) = ("Enter", "pop out") : if isJust inventorySearch then [("Esc", "exit search")] else - [ ("m", "make") - , ("0", (if showZero then "hide" else "show") <> " 0") - , (":/;", T.unwords ["Sort:", renderSortMethod inventorySort]) - , ("/", "search") + [ (keyE SE.MakeEntityEvent, "make") + , (keyE SE.ShowZeroInventoryEntitiesEvent, (if showZero then "hide" else "show") <> " 0") + , ( keyE SE.SwitchInventorySortDirection <> "/" <> keyE SE.CycleInventorySortEvent + , T.unwords ["Sort:", renderSortMethod inventorySort] + ) + , (keyE SE.SearchInventoryEvent, "search") ] keyCmdsFor (Just (FocusablePanel InfoPanel)) = [] keyCmdsFor _ = [] + keyM = bindingText s . SE.Main + keyR = bindingText s . SE.REPL + keyE = bindingText s . SE.Robot + keyW = bindingText s . SE.World + +bindingText :: AppState -> SwarmEvent -> Text +bindingText s e = maybe "" ppBindingShort b + where + conf = s ^. keyEventHandling . keyConfig + b = firstActiveBinding conf e + ppBindingShort = \case + Binding V.KUp m | null m -> "↑" + Binding V.KDown m | null m -> "↓" + Binding V.KLeft m | null m -> "←" + Binding V.KRight m | null m -> "→" + bi -> ppBinding bi data KeyHighlight = NoHighlight | Alert | PanelSpecific From e395dbcf554782bc84962ec63d098f56c5b1bd0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 12:00:47 +0200 Subject: [PATCH 43/55] Reformat --- src/swarm-tui/Swarm/TUI/View.hs | 51 +++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 21 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 0a4f62226..f03a8ec48 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -36,6 +36,7 @@ module Swarm.TUI.View ( import Brick hiding (Direction, Location) import Brick.Focus import Brick.Forms +import Brick.Keybindings (Binding (..), firstActiveBinding, ppBinding) import Brick.Widgets.Border ( hBorder, hBorderWithLabel, @@ -69,6 +70,7 @@ import Data.Set qualified as Set (toList) import Data.Text (Text) import Data.Text qualified as T import Data.Time (NominalDiffTime, defaultTimeLocale, formatTime) +import Graphics.Vty qualified as V import Linear import Network.Wai.Handler.Warp (Port) import Numeric (showFFloat) @@ -132,6 +134,7 @@ import Swarm.TUI.Inventory.Sorting (renderSortMethod) import Swarm.TUI.Launch.Model import Swarm.TUI.Launch.View import Swarm.TUI.Model +import Swarm.TUI.Model.Event (SwarmEvent) import Swarm.TUI.Model.Event qualified as SE import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) import Swarm.TUI.Model.Repl @@ -152,9 +155,6 @@ import System.Clock (TimeSpec (..)) import Text.Printf import Text.Wrap import Witch (into) -import Swarm.TUI.Model.Event (SwarmEvent) -import Brick.Keybindings (firstActiveBinding, ppBinding, Binding (..)) -import Graphics.Vty qualified as V -- | The main entry point for drawing the entire UI. Figures out -- which menu screen we should show (if any), or just the game itself. @@ -1050,19 +1050,23 @@ drawKeyMenu s = , may cheat (NoHighlight, keyM SE.ToggleWorldEditorEvent, "editor") , Just (NoHighlight, keyM SE.PauseEvent, if isPaused then "unpause" else "pause") , may isPaused (NoHighlight, keyM SE.RunSingleTickEvent, "step") - , may (isPaused && hasDebug) - (if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight - , keyM SE.ShowCESKDebugEvent - , "debug") + , may + (isPaused && hasDebug) + ( if s ^. uiState . uiGameplay . uiShowDebug then Alert else NoHighlight + , keyM SE.ShowCESKDebugEvent + , "debug" + ) , Just (NoHighlight, keyM SE.IncreaseTpsEvent <> "/" <> keyM SE.DecreaseTpsEvent, "speed") , Just - (NoHighlight - , keyM SE.ToggleREPLVisibilityEvent - , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL") + ( NoHighlight + , keyM SE.ToggleREPLVisibilityEvent + , if s ^. uiState . uiGameplay . uiShowREPL then "hide REPL" else "show REPL" + ) , Just - (if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert - , keyM SE.HideRobotsEvent - , "hide robots") + ( if s ^. uiState . uiGameplay . uiShowRobots then NoHighlight else Alert + , keyM SE.HideRobotsEvent + , "hide robots" + ) ] may b = if b then Just else const Nothing @@ -1079,13 +1083,17 @@ drawKeyMenu s = ++ [(keyR SE.ToggleCustomKeyHandlingEvent, renderHandlerModeSwitch ctrlMode) | handlerInstalled] ++ [("PgUp/Dn", "scroll")] keyCmdsFor (Just (FocusablePanel WorldPanel)) = - [ (T.intercalate "/" $ map keyW - [ SE.MoveViewWestEvent - , SE.MoveViewNorthEvent - , SE.MoveViewEastEvent - , SE.MoveViewSouthEvent - ] - , "scroll") | canScroll + [ ( T.intercalate "/" $ + map + keyW + [ SE.MoveViewWestEvent + , SE.MoveViewNorthEvent + , SE.MoveViewEastEvent + , SE.MoveViewSouthEvent + ] + , "scroll" + ) + | canScroll ] ++ [(keyW SE.ViewBaseEvent, "recenter") | not viewingBase] ++ [(keyW SE.ShowFpsEvent, "FPS")] @@ -1096,7 +1104,8 @@ drawKeyMenu s = else [ (keyE SE.MakeEntityEvent, "make") , (keyE SE.ShowZeroInventoryEntitiesEvent, (if showZero then "hide" else "show") <> " 0") - , ( keyE SE.SwitchInventorySortDirection <> "/" <> keyE SE.CycleInventorySortEvent + , + ( keyE SE.SwitchInventorySortDirection <> "/" <> keyE SE.CycleInventorySortEvent , T.unwords ["Sort:", renderSortMethod inventorySort] ) , (keyE SE.SearchInventoryEvent, "search") From 3b872f1ffd44dfbb69d591597f246d3ef4a219b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 22:06:00 +0200 Subject: [PATCH 44/55] Show custom keybindings in Help modal dialog --- src/swarm-scenario/Swarm/Constant.hs | 3 + .../Swarm/TUI/Controller/EventHandlers.hs | 14 +++- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 40 +++++++++-- src/swarm-tui/Swarm/TUI/View.hs | 70 +++++++++---------- src/swarm-tui/Swarm/TUI/View/Util.hs | 3 +- 5 files changed, 82 insertions(+), 48 deletions(-) diff --git a/src/swarm-scenario/Swarm/Constant.hs b/src/swarm-scenario/Swarm/Constant.hs index 17e7425d3..f0e742e4b 100644 --- a/src/swarm-scenario/Swarm/Constant.hs +++ b/src/swarm-scenario/Swarm/Constant.hs @@ -15,6 +15,9 @@ import Data.Text (Text) -- By convention, all URL constants include trailing slashes -- when applicable. +swarmWebIRC :: Text +swarmWebIRC = "https://web.libera.chat/?channels=#swarm" + -- | The URL for the Swarm repository. swarmRepoUrl :: Text swarmRepoUrl = "https://github.com/swarm-game/swarm/" diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index 0c801e8d2..63c1b992f 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -18,6 +18,7 @@ module Swarm.TUI.Controller.EventHandlers ( -- * Documentation createKeyDispatchers, + allEventHandlers, -- ** Main game handler mainEventHandlers, @@ -68,8 +69,8 @@ createKeyDispatchers config = do mainGameDispatcher <- buildDispatcher mainEventHandlers let buildSubMainDispatcher = buildSubDispatcher "Main game events" mainGameDispatcher replDispatcher <- buildSubMainDispatcher "REPL panel events" replEventHandlers - worldDispatcher <- buildSubMainDispatcher "World panel events" worldEventHandlers - robotDispatcher <- buildSubMainDispatcher "Robot panel events" robotEventHandlers + worldDispatcher <- buildSubMainDispatcher "World view panel events" worldEventHandlers + robotDispatcher <- buildSubMainDispatcher "Robot inventory panel events" robotEventHandlers return SwarmKeyDispatchers {..} where -- this error handling code is modified version of the brick demo app: @@ -113,3 +114,12 @@ conflicts d1 d2 = combine <$> badGroups combine as = let b = fst $ NE.head as in (b, snd <$> NE.toList as) + +allEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] +allEventHandlers = + concat + [ mainEventHandlers + , replEventHandlers + , worldEventHandlers + , robotEventHandlers + ] diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs index 125a90d46..ecaeaffba 100644 --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -6,8 +6,10 @@ module Swarm.TUI.Model.KeyBindings ( initKeyHandlingState, KeybindingPrint (..), showKeybindings, + handlerNameKeysDescription, ) where +import Brick import Brick.Keybindings as BK import Control.Carrier.Lift (runM) import Control.Carrier.Throw.Either (runThrow) @@ -56,18 +58,20 @@ showKeybindings kPrint = do bindings <- runM $ runThrow @SystemFailure initKeyHandlingState pure $ case bindings of Left e -> prettyText e - Right bs -> showTable kPrint (bs ^. keyConfig) sections + Right bs -> showTable kPrint (bs ^. keyConfig) keySections where showTable = \case MarkdownPrint -> keybindingMarkdownTable TextPrint -> keybindingTextTable IniPrint -> keybindingINI - sections = - [ ("Main game", mainEventHandlers) - , ("REPL panel ", replEventHandlers) - , ("World view", worldEventHandlers) - , ("Robot panel", robotEventHandlers) - ] + +keySections :: [(Text, [KeyEventHandler SwarmEvent (EventM Name AppState)])] +keySections = + [ ("Main game (always active)", mainEventHandlers) + , ("REPL panel ", replEventHandlers) + , ("World view panel", worldEventHandlers) + , ("Robot inventory panel", robotEventHandlers) + ] keybindingINI :: Ord k => KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text keybindingINI kc sections = @@ -106,3 +110,25 @@ keyBindingEventINI kc (ev, description) = name = case keyEventName (keyConfigEvents kc) ev of Just n -> n Nothing -> error $ "unnamed event: " <> T.unpack description + +handlerNameKeysDescription :: Ord k => KeyConfig k -> KeyEventHandler k m -> (Text, Text, Text) +handlerNameKeysDescription kc keh = (name, keys, desc) + where + desc = handlerDescription $ kehHandler keh + (name, keys) = case kehEventTrigger keh of + ByKey b -> ("(non-customizable key)", ppBinding b) + ByEvent ev -> + let name' = fromMaybe "(unnamed)" $ keyEventName (keyConfigEvents kc) ev + in case lookupKeyConfigBindings kc ev of + Nothing -> + if not (null (allDefaultBindings kc ev)) + then (name', T.intercalate "," $ ppBinding <$> allDefaultBindings kc ev) + else (name', "unbound") + Just Unbound -> + (name', "unbound") + Just (BindingList bs) -> + let result = + if not (null bs) + then T.intercalate "," $ ppBinding <$> bs + else "unbound" + in (name', result) diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index f03a8ec48..2558d0c7c 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -127,6 +127,7 @@ import Swarm.Language.Typecheck (inferConst) import Swarm.Log import Swarm.TUI.Border import Swarm.TUI.Controller (ticksPerFrameCap) +import Swarm.TUI.Controller.EventHandlers (allEventHandlers, mainEventHandlers, replEventHandlers, robotEventHandlers, worldEventHandlers) import Swarm.TUI.Controller.Util (hasDebugCapability) import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.View qualified as EV @@ -137,6 +138,7 @@ import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent) import Swarm.TUI.Model.Event qualified as SE import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow) +import Swarm.TUI.Model.KeyBindings (handlerNameKeysDescription) import Swarm.TUI.Model.Repl import Swarm.TUI.Model.UI import Swarm.TUI.Panel @@ -627,7 +629,7 @@ drawDialog s = case s ^. uiState . uiGameplay . uiModal of -- | Draw one of the various types of modal dialog. drawModal :: AppState -> ModalType -> Widget Name drawModal s = \case - HelpModal -> helpWidget (s ^. gameState . randomness . seed) (s ^. runtimeState . webPort) + HelpModal -> helpWidget (s ^. gameState . randomness . seed) (s ^. runtimeState . webPort) (s ^. keyEventHandling) RobotsModal -> robotsListWidget s RecipesModal -> availableListWidget (s ^. gameState) RecipeList CommandsModal -> commandsListWidget (s ^. gameState) @@ -786,59 +788,53 @@ robotsListWidget s = hCenter table debugging = creative && cheat g = s ^. gameState -helpWidget :: Seed -> Maybe Port -> Widget Name -helpWidget theSeed mport = - padTop (Pad 1) $ - (hBox . map (padLeftRight 2) $ [helpKeys, info]) - <=> padTop (Pad 1) (hCenter tips) +helpWidget :: Seed -> Maybe Port -> KeyEventHandlingState -> Widget Name +helpWidget theSeed mport keyState = + padLeftRight 2 . vBox $ padTop (Pad 1) <$> [info, helpKeys, tips] where tips = vBox - [ txt "Have questions? Want some tips? Check out:" - , txt " " - , txt $ " - The Swarm wiki, " <> wikiUrl - , txt " - The #swarm IRC channel on Libera.Chat" + [ heading boldAttr "Have questions? Want some tips? Check out:" + , txt " - The Swarm wiki, " <+> hyperlink wikiUrl (txt wikiUrl) + , txt " - The #swarm IRC channel on " <+> hyperlink swarmWebIRC (txt swarmWebIRC) ] info = vBox - [ txt "Configuration" - , txt " " + [ heading boldAttr "Configuration" , txt ("Seed: " <> into @Text (show theSeed)) , txt ("Web server port: " <> maybe "none" (into @Text . show) mport) ] helpKeys = vBox - [ txt "Keybindings" - , txt " " - , mkTable glKeyBindings + [ heading boldAttr "Keybindings" + , keySection "Main (always active)" mainEventHandlers + , keySection "REPL panel" replEventHandlers + , keySection "World view panel" worldEventHandlers + , keySection "Robot inventory panel" robotEventHandlers ] - mkTable = + keySection name handlers = + padBottom (Pad 1) $ + vBox + [ heading italicAttr name + , mkKeyTable handlers + ] + mkKeyTable = BT.renderTable . BT.surroundingBorder False . BT.rowBorders False . BT.table - . map toRow - toRow (k, v) = [padRight (Pad 1) $ txt k, padLeft (Pad 1) $ txt v] - glKeyBindings = - [ ("F1", "Help") - , ("F2", "Robots list") - , ("F3", "Available recipes") - , ("F4", "Available commands") - , ("F5", "Messages") - , ("F6", "Structures") - , ("Ctrl-g", "show goal") - , ("Ctrl-p", "pause") - , ("Ctrl-o", "single step") - , ("Ctrl-z", "decrease speed") - , ("Ctrl-w", "increase speed") - , ("Ctrl-q", "quit or restart the current scenario") - , ("Meta-,", "collapse/expand REPL") - , ("Meta-h", "hide robots for 2s") - , ("Meta-w", "focus on the world map") - , ("Meta-e", "focus on the robot inventory") - , ("Meta-r", "focus on the REPL") - , ("Meta-t", "focus on the info panel") + . map (toRow . keyHandlerToText) + heading attr = padBottom (Pad 1) . withAttr attr . txt + toRow (n, k, d) = + [ padRight (Pad 1) $ txtFilled maxN n + , padLeftRight 1 $ txtFilled maxK k + , padLeft (Pad 1) $ txtFilled maxD d ] + keyHandlerToText = handlerNameKeysDescription (keyState ^. keyConfig) + -- Get maximum width of the table columns so it all neatly aligns + txtFilled n t = padRight (Pad $ max 0 (n - textWidth t)) $ txt t + (maxN, maxK, maxD) = map3 (maximum . map textWidth) . unzip3 $ keyHandlerToText <$> allEventHandlers + map3 f (n, k, d) = (f n, f k, f d) data NotificationList = RecipeList | MessageList diff --git a/src/swarm-tui/Swarm/TUI/View/Util.hs b/src/swarm-tui/Swarm/TUI/View/Util.hs index adc65c962..356593aae 100644 --- a/src/swarm-tui/Swarm/TUI/View/Util.hs +++ b/src/swarm-tui/Swarm/TUI/View/Util.hs @@ -44,10 +44,9 @@ generateModal s mt = Modal mt (dialog (Just $ str title) buttons (maxModalWindow NoMenu -> Just "Quit" _ -> Nothing descriptionWidth = 100 - helpWidth = 80 (title, buttons, requiredWidth) = case mt of - HelpModal -> (" Help ", Nothing, helpWidth) + HelpModal -> (" Help ", Nothing, descriptionWidth) RobotsModal -> ("Robots", Nothing, descriptionWidth) RecipesModal -> ("Available Recipes", Nothing, descriptionWidth) CommandsModal -> ("Available Commands", Nothing, descriptionWidth) From 5d7edf0d958f4a68115dc5abfa206bc64a476292 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 22:29:48 +0200 Subject: [PATCH 45/55] Use enumerate --- src/swarm-tui/Swarm/TUI/Controller.hs | 2 -- src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs | 2 +- src/swarm-tui/Swarm/TUI/Controller/Util.hs | 4 ++-- src/swarm-tui/Swarm/TUI/Model/Event.hs | 4 ++-- 4 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 477b3d3cc..2c52afaf3 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -43,8 +43,6 @@ import Control.Monad (unless, void, when) import Control.Monad.Extra (whenJust) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.State (MonadState, execState) -import Data.Int (Int32) -import Data.List.Extra (enumerate) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map qualified as M diff --git a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs index b37e54c6e..8985c3cf1 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/UpdateUI.hs @@ -17,6 +17,7 @@ import Control.Applicative (liftA2, pure) import Control.Lens as Lens import Control.Monad (unless, when) import Data.Foldable (toList) +import Data.List.Extra (enumerate) import Data.Maybe (isNothing) import Data.String (fromString) import Data.Text qualified as T @@ -40,7 +41,6 @@ import Swarm.TUI.Model.UI import Swarm.TUI.View.Objective qualified as GR import Witch (into) import Prelude hiding (Applicative (..)) -import Data.List.Extra (enumerate) -- | Update the UI. This function is used after running the -- game for some number of ticks. diff --git a/src/swarm-tui/Swarm/TUI/Controller/Util.hs b/src/swarm-tui/Swarm/TUI/Controller/Util.hs index 9b622e13b..3dadac994 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/Util.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/Util.hs @@ -13,6 +13,7 @@ import Control.Lens as Lens import Control.Monad (forM_, unless, when) import Control.Monad.IO.Class (MonadIO (liftIO), liftIO) import Control.Monad.State (MonadState, execState) +import Data.List.Extra (enumerate) import Data.Map qualified as M import Data.Set qualified as S import Data.Text (Text) @@ -35,7 +36,6 @@ import Swarm.Language.Syntax hiding (Key) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) -import Swarm.Util (listEnums) import System.Clock (Clock (..), getTime) -- | Pattern synonyms to simplify brick event handler @@ -178,7 +178,7 @@ allHandlers :: (e1 -> e2) -> (e1 -> (Text, EventM Name AppState ())) -> [KeyEventHandler e2 (EventM Name AppState)] -allHandlers eEmbed f = map handleEvent1 listEnums +allHandlers eEmbed f = map handleEvent1 enumerate where handleEvent1 e1 = let (n, a) = f e1 in onEvent (eEmbed e1) n a diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index c75b7ff2c..3dbef00c5 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -18,9 +18,9 @@ module Swarm.TUI.Model.Event ( import Brick.Keybindings import Control.Arrow ((&&&)) import Data.Bifunctor (first) +import Data.List.Extra (enumerate) import Data.Text (Text) import Graphics.Vty qualified as V -import Swarm.Util (listEnums) data SwarmEvent = Main MainEvent @@ -219,7 +219,7 @@ defaultRobotPanelBindings = allBindings $ \case -- Helper methods allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e -allKeyEvents f = keyEvents $ map (f &&& id) listEnums +allKeyEvents f = keyEvents $ map (f &&& id) enumerate allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] allBindings f = map (\e -> (e, f e)) [minBound .. maxBound] From 3e39ed276ce8c3d5ce412652bb9affe8b87b2ad4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 22:57:04 +0200 Subject: [PATCH 46/55] Add a note link --- src/swarm-tui/Swarm/TUI/Controller.hs | 8 +++++-- .../Swarm/TUI/Controller/EventHandlers.hs | 22 ++++++++++++------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 2c52afaf3..0ccf73006 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -282,7 +282,8 @@ handleMainEvent ev = do _ -> continueWithoutRedraw VtyEvent (V.EvResize _ _) -> invalidateCache EscapeKey | Just m <- s ^. uiState . uiGameplay . uiModal -> closeModal m - -- pass to key handler (allows users to configure bindings) + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m -- pass keys on to modal event handler if a modal is open @@ -339,6 +340,8 @@ handleMainEvent ev = do case focusGetCurrent fring of Just (FocusablePanel x) -> case x of REPLPanel -> handleREPLEvent ev + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] WorldPanel | VtyEvent (V.EvKey k m) <- ev -> do wh <- use $ keyEventHandling . keyDispatchers . to worldDispatcher void $ B.handleKey wh k m @@ -457,7 +460,8 @@ handleREPLEvent x = do let controlMode = s ^. uiState . uiGameplay . uiREPL . replControlMode let keyHandler = s ^. keyEventHandling . keyDispatchers . to replDispatcher case x of - -- pass to key handler (allows users to configure bindings) + -- Pass to key handler (allows users to configure bindings) + -- See Note [how Swarm event handlers work] VtyEvent (V.EvKey k m) | isJust (B.lookupVtyEvent k m keyHandler) -> do void $ B.handleKey keyHandler k m diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index 63c1b992f..14637eb0d 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -7,14 +7,6 @@ -- Swarm (abstract) event handlers allow players to customize some keybindings. -- This all comes together in 'Swarm.TUI.Controller' which calls the handlers -- for parts of UI and also handles mouse events and frame updates. --- --- The high level overview is this: --- 1. The 'SwarmEvent' is a enumeration of abstracts key events ('PauseEvent', etc.) --- 2. The 'AppState' stores the key configuration and key dispatchers (keys to handlers) --- 3. Here we declare the handlers for abstract events. --- 4. When provided with 'KeyConfig' (can include customized keybindings) we can --- 'createKeyDispatchers' in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. --- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. module Swarm.TUI.Controller.EventHandlers ( -- * Documentation createKeyDispatchers, @@ -57,6 +49,20 @@ import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) +-- ~~~~ Note [how Swarm event handlers work] +-- +-- Allowing players to customize keybindings requires storing the configuration in AppState. +-- By doing it as declaratively as possible, Brick also allows us to detect conflicts. +-- +-- The high level overview is this: +-- 1. The 'SwarmEvent' is a enumeration of abstracts key events ('PauseEvent', etc.) +-- 2. The 'AppState' definition contains the key configuration and dispatchers (keys to handlers) +-- 3. Here in 'Swarm.TUI.Controller.EventHandlers' we declare the handlers for abstract events +-- and also some non-customizable key handlers (e.g. escape and enter). +-- 4. When provided with 'KeyConfig' (can include customized keybindings) we can +-- 'createKeyDispatchers' in 'Swarm.TUI.Model.StateUpdate' and store them in 'AppState'. +-- 5. Finally in 'Swarm.TUI.Controller' the Brick event handler calls the stored dispatchers. + -- | Create key dispatchers that call (abstract) event handlers based on given key config. -- -- Fails if any key events have conflict within one dispatcher or when a main dispatcher From 6d4cd746e025e93c79c6fde694fee966efd84621 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 23:18:05 +0200 Subject: [PATCH 47/55] Add TODOs for unfinished handlers --- src/swarm-tui/Swarm/TUI/Controller.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 0ccf73006..75f74c383 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -152,6 +152,8 @@ handleEvent = \case AboutMenu -> pressAnyKey (MainMenu (mainMenu About)) -- | The event handler for the main menu. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleMainMenuEvent :: BL.List Name MainMenuEntry -> BrickEvent Name AppEvent -> EventM Name AppState () handleMainMenuEvent menu = \case @@ -230,6 +232,7 @@ handleMainMessagesEvent = \case where returnToMainMenu = uiState . uiMenu .= MainMenu (mainMenu Messages) +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleNewGameMenuEvent :: NonEmpty (BL.List Name ScenarioItem) -> BrickEvent Name AppEvent -> @@ -360,6 +363,7 @@ closeModal m = do t <- use $ gameState . temporal . ticks gameState . messageInfo . lastSeenMessageTime .= t +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleModalEvent :: V.Event -> EventM Name AppState () handleModalEvent = \case V.EvKey V.KEnter [] -> do @@ -498,6 +502,8 @@ runInputHandler kc = do gameState %= execState (zoomRobots $ activateRobot 0) -- | Handle a user "piloting" input event for the REPL. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleREPLEventPiloting :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEventPiloting x = case x of Key V.KUp -> inputCmd "move" @@ -548,6 +554,8 @@ runBaseCode uinput = do uiState . uiGameplay . uiREPL . replHistory %= addREPLItem (REPLError err) -- | Handle a user input event for the REPL. +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleREPLEventTyping :: BrickEvent Name AppEvent -> EventM Name AppState () handleREPLEventTyping = \case -- Scroll the REPL on PageUp or PageDown @@ -759,6 +767,8 @@ adjReplHistIndex d s = ------------------------------------------------------------ -- | Handle user events in the info panel (just scrolling). +-- +-- TODO: #2010 Finish porting Controller to KeyEventHandlers handleInfoPanelEvent :: ViewportScroll Name -> BrickEvent Name AppEvent -> EventM Name AppState () handleInfoPanelEvent vs = \case Key V.KDown -> vScrollBy vs 1 From 1eb14ec0c6bc6ec81895b9d82afa25e8716dc39e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 23:26:28 +0200 Subject: [PATCH 48/55] Add more doc links --- src/swarm-tui/Swarm/TUI/Model/Event.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 3dbef00c5..7a736d585 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -22,6 +22,8 @@ import Data.List.Extra (enumerate) import Data.Text (Text) import Graphics.Vty qualified as V +-- See Note [how Swarm event handlers work] + data SwarmEvent = Main MainEvent | REPL REPLEvent From 7f353a4f957bad701da198769698c80b0aa87e21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Fri, 5 Jul 2024 23:38:13 +0200 Subject: [PATCH 49/55] Add more docs and links --- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs index ecaeaffba..48cd8b375 100644 --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} --- | +-- | Load and show Swarm keybindings. +-- -- SPDX-License-Identifier: BSD-3-Clause module Swarm.TUI.Model.KeyBindings ( initKeyHandlingState, @@ -28,6 +29,8 @@ import Swarm.TUI.Controller.EventHandlers import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent, defaultSwarmBindings, swarmEvents) +-- See Note [how Swarm event handlers work] + loadKeybindingConfig :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => m [(SwarmEvent, BindingState)] From d7a008d5b94b2e884a4f167f311995f8088fd35e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 6 Jul 2024 20:48:57 +0200 Subject: [PATCH 50/55] Apply tips from @kostmo --- src/swarm-tui/Swarm/TUI/Controller.hs | 2 +- .../Swarm/TUI/Controller/EventHandlers.hs | 17 ++++++++--------- src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs | 2 +- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller.hs b/src/swarm-tui/Swarm/TUI/Controller.hs index 75f74c383..c6e4575f8 100644 --- a/src/swarm-tui/Swarm/TUI/Controller.hs +++ b/src/swarm-tui/Swarm/TUI/Controller.hs @@ -467,7 +467,7 @@ handleREPLEvent x = do -- Pass to key handler (allows users to configure bindings) -- See Note [how Swarm event handlers work] VtyEvent (V.EvKey k m) - | isJust (B.lookupVtyEvent k m keyHandler) -> do + | isJust (B.lookupVtyEvent k m keyHandler) -> void $ B.handleKey keyHandler k m -- Handle other events in a way appropriate to the current REPL -- control mode. diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs index 14637eb0d..f35e99aeb 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers.hs @@ -35,10 +35,8 @@ import Brick hiding (on) import Brick.Keybindings as BK import Control.Effect.Accum import Control.Effect.Throw -import Data.Function (on) -import Data.List (groupBy, sortBy) +import Data.List (sortOn) import Data.List.NonEmpty qualified as NE -import Data.Maybe (fromMaybe, mapMaybe) import Data.Text qualified as T import Swarm.Game.Failure (SystemFailure (..)) import Swarm.TUI.Controller.EventHandlers.Frame (runFrameUI, runGameTickUI, ticksPerFrameCap) @@ -48,6 +46,7 @@ import Swarm.TUI.Controller.EventHandlers.Robot (handleRobotPanelEvent, robotEve import Swarm.TUI.Controller.EventHandlers.World (worldEventHandlers) import Swarm.TUI.Model import Swarm.TUI.Model.Event (SwarmEvent, swarmEvents) +import Swarm.Util (parens, squote) -- ~~~~ Note [how Swarm event handlers work] -- @@ -99,13 +98,13 @@ createKeyDispatchers config = do throwLoadingFailure = throwError . CustomFailure . T.intercalate "\n" handlerErrors collisions = flip map collisions $ \(b, hs) -> - let hsm = "Handlers with the '" <> BK.ppBinding b <> "' binding:" + let hsm = "Handlers with the " <> squote (BK.ppBinding b) <> " binding:" hss = flip map hs $ \h -> let trigger = case BK.kehEventTrigger $ BK.khHandler h of - ByKey k -> "triggered by the key '" <> BK.ppBinding k <> "'" - ByEvent e -> "triggered by the event '" <> fromMaybe "" (BK.keyEventName swarmEvents e) <> "'" + ByKey k -> "triggered by the key " <> squote (BK.ppBinding k) + ByEvent e -> "triggered by the event " <> maybe "" squote (BK.keyEventName swarmEvents e) desc = BK.handlerDescription $ BK.kehHandler $ BK.khHandler h - in " " <> desc <> " (" <> trigger <> ")" + in " " <> desc <> " " <> parens trigger in T.intercalate "\n" (hsm : hss) -- | Take two dispatchers (that do not have conflict themselves) and find conflicting keys between them. @@ -114,8 +113,8 @@ conflicts d1 d2 = combine <$> badGroups where l1 = keyDispatcherToList d1 l2 = keyDispatcherToList d2 - gs = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) (l1 <> l2) - badGroups = filter ((1 <) . length) $ mapMaybe NE.nonEmpty gs + gs = NE.groupWith fst $ sortOn fst (l1 <> l2) + badGroups = filter ((1 <) . length) gs combine :: NE.NonEmpty (Binding, KeyHandler k m) -> (Binding, [KeyHandler k m]) combine as = let b = fst $ NE.head as diff --git a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs index 48cd8b375..2c2e52261 100644 --- a/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs +++ b/src/swarm-tui/Swarm/TUI/Model/KeyBindings.hs @@ -71,7 +71,7 @@ showKeybindings kPrint = do keySections :: [(Text, [KeyEventHandler SwarmEvent (EventM Name AppState)])] keySections = [ ("Main game (always active)", mainEventHandlers) - , ("REPL panel ", replEventHandlers) + , ("REPL panel", replEventHandlers) , ("World view panel", worldEventHandlers) , ("Robot inventory panel", robotEventHandlers) ] From 7eaed1734a7380bfe15e556063f186a6899a3c3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 6 Jul 2024 21:16:34 +0200 Subject: [PATCH 51/55] Use AbsoluteDir for MoveViewEvent --- .../TUI/Controller/EventHandlers/World.hs | 6 ++-- src/swarm-tui/Swarm/TUI/Model/Event.hs | 35 ++++++++++++------- src/swarm-tui/Swarm/TUI/View.hs | 13 +------ 3 files changed, 25 insertions(+), 29 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs index ba587a83e..b4dbe921a 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/World.hs @@ -18,6 +18,7 @@ import Swarm.Game.Location import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot +import Swarm.Language.Syntax.Direction (Direction (..), directionSyntax) import Swarm.TUI.Controller.Util import Swarm.TUI.Model import Swarm.TUI.Model.Event @@ -28,10 +29,7 @@ worldEventHandlers :: [KeyEventHandler SwarmEvent (EventM Name AppState)] worldEventHandlers = allHandlers World $ \case ViewBaseEvent -> ("View the base robot", viewBase) ShowFpsEvent -> ("Show frames per second", showFps) - MoveViewNorthEvent -> ("Scroll world view in the north direction", scrollViewInDir north) - MoveViewEastEvent -> ("Scroll world view in the east direction", scrollViewInDir east) - MoveViewSouthEvent -> ("Scroll world view in the south direction", scrollViewInDir south) - MoveViewWestEvent -> ("Scroll world view in the west direction", scrollViewInDir west) + MoveViewEvent d -> ("Scroll world view in the " <> directionSyntax (DAbsolute d) <> " direction", scrollViewInDir $ toHeading d) viewBase :: EventM Name AppState () viewBase = do diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 7a736d585..7ba55615e 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -21,6 +21,7 @@ import Data.Bifunctor (first) import Data.List.Extra (enumerate) import Data.Text (Text) import Graphics.Vty qualified as V +import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..), directionSyntax) -- See Note [how Swarm event handlers work] @@ -165,29 +166,37 @@ defaultReplBindings = allBindings $ \case data WorldEvent = ViewBaseEvent | ShowFpsEvent - | MoveViewNorthEvent - | MoveViewEastEvent - | MoveViewSouthEvent - | MoveViewWestEvent - deriving (Eq, Ord, Show, Enum, Bounded) + | MoveViewEvent AbsoluteDir + deriving (Eq, Ord, Show) + +instance Enum WorldEvent where + fromEnum = \case + ViewBaseEvent -> 0 + ShowFpsEvent -> 1 + MoveViewEvent d -> 2 + fromEnum d + toEnum = \case + 0 -> ViewBaseEvent + 1 -> ShowFpsEvent + n -> MoveViewEvent . toEnum $ n - 2 + +instance Bounded WorldEvent where + minBound = ViewBaseEvent + maxBound = MoveViewEvent maxBound worldPanelEvents :: KeyEvents WorldEvent worldPanelEvents = allKeyEvents $ \case ViewBaseEvent -> "view base" ShowFpsEvent -> "show fps" - MoveViewNorthEvent -> "move view north" - MoveViewEastEvent -> "move view east" - MoveViewSouthEvent -> "move view south" - MoveViewWestEvent -> "move view west" + MoveViewEvent d -> "move view " <> directionSyntax (DAbsolute d) defaultWorldPanelBindings :: [(WorldEvent, [Binding])] defaultWorldPanelBindings = allBindings $ \case ViewBaseEvent -> [bind 'c'] ShowFpsEvent -> [bind 'f'] - MoveViewWestEvent -> [bind V.KLeft, bind 'h'] - MoveViewSouthEvent -> [bind V.KDown, bind 'j'] - MoveViewNorthEvent -> [bind V.KUp, bind 'k'] - MoveViewEastEvent -> [bind V.KRight, bind 'l'] + MoveViewEvent DWest -> [bind V.KLeft, bind 'h'] + MoveViewEvent DSouth -> [bind V.KDown, bind 'j'] + MoveViewEvent DNorth -> [bind V.KUp, bind 'k'] + MoveViewEvent DEast -> [bind V.KRight, bind 'l'] -- ---------------------------------------------- -- ROBOT EVENTS diff --git a/src/swarm-tui/Swarm/TUI/View.hs b/src/swarm-tui/Swarm/TUI/View.hs index 2558d0c7c..0d749b448 100644 --- a/src/swarm-tui/Swarm/TUI/View.hs +++ b/src/swarm-tui/Swarm/TUI/View.hs @@ -1079,18 +1079,7 @@ drawKeyMenu s = ++ [(keyR SE.ToggleCustomKeyHandlingEvent, renderHandlerModeSwitch ctrlMode) | handlerInstalled] ++ [("PgUp/Dn", "scroll")] keyCmdsFor (Just (FocusablePanel WorldPanel)) = - [ ( T.intercalate "/" $ - map - keyW - [ SE.MoveViewWestEvent - , SE.MoveViewNorthEvent - , SE.MoveViewEastEvent - , SE.MoveViewSouthEvent - ] - , "scroll" - ) - | canScroll - ] + [(T.intercalate "/" $ map keyW enumerate, "scroll") | canScroll] ++ [(keyW SE.ViewBaseEvent, "recenter") | not viewingBase] ++ [(keyW SE.ShowFpsEvent, "FPS")] keyCmdsFor (Just (FocusablePanel RobotPanel)) = From 64f044a224d10c82fbe97e7e7570eb0205bbedb1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 6 Jul 2024 21:23:57 +0200 Subject: [PATCH 52/55] Add doc for initialize INI switch --- app/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 8f0dc7f3c..dd36cb7f5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -34,7 +34,8 @@ commitInfo = case gitInfo of data CLI = Run AppOpts - | ListKeybinding Bool KeybindingPrint + | -- | Print list of bindings, optionally initializing the INI configuration file. + ListKeybinding Bool KeybindingPrint | Format FormatConfig | LSP | Version From 5b12b55275405ada4a6182554da82f5022dc3e30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 6 Jul 2024 21:40:04 +0200 Subject: [PATCH 53/55] Fixup TPS event description - thanks @byorgey --- src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs index c57eb2f9b..ec895d5f2 100644 --- a/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs +++ b/src/swarm-tui/Swarm/TUI/Controller/EventHandlers/Main.hs @@ -45,8 +45,8 @@ mainEventHandlers = allHandlers Main $ \case ShowCESKDebugEvent -> ("Show active robot CESK machine debugging line", showCESKDebug) PauseEvent -> ("Pause or unpause the game", whenRunning safeTogglePause) RunSingleTickEvent -> ("Run game for a single tick", whenRunning runSingleTick) - IncreaseTpsEvent -> ("Increase game speed by one tick per second", whenRunning . modify $ adjustTPS (+)) - DecreaseTpsEvent -> ("Descrease game speed by one tick per second", whenRunning . modify $ adjustTPS (-)) + IncreaseTpsEvent -> ("Double game speed", whenRunning . modify $ adjustTPS (+)) + DecreaseTpsEvent -> ("Halve game speed", whenRunning . modify $ adjustTPS (-)) FocusWorldEvent -> ("Set focus on the World panel", setFocus WorldPanel) FocusRobotEvent -> ("Set focus on the Robot panel", setFocus RobotPanel) FocusREPLEvent -> ("Set focus on the REPL panel", setFocus REPLPanel) From 56eb953c166266edfcdcaaa990a38debcc17acf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sat, 6 Jul 2024 21:41:10 +0200 Subject: [PATCH 54/55] Allow brick 2.4 --- swarm.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/swarm.cabal b/swarm.cabal index 351f34336..5d711d095 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -715,7 +715,7 @@ library swarm-tui aeson >=2.2 && <2.3, array >=0.5.4 && <0.6, base >=4.14 && <4.20, - brick >=2.1.1 && <2.4, + brick >=2.1.1 && <2.5, brick-list-skip >=0.1.1.2 && <0.2, bytestring >=0.10 && <0.13, clock >=0.8.2 && <0.9, From bac439dd4759813513ee1793fee5a74e8e3f9f90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Mon, 8 Jul 2024 13:04:08 +0200 Subject: [PATCH 55/55] Use enumerate --- src/swarm-tui/Swarm/TUI/Model/Event.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-tui/Swarm/TUI/Model/Event.hs b/src/swarm-tui/Swarm/TUI/Model/Event.hs index 7ba55615e..89087e727 100644 --- a/src/swarm-tui/Swarm/TUI/Model/Event.hs +++ b/src/swarm-tui/Swarm/TUI/Model/Event.hs @@ -233,4 +233,4 @@ allKeyEvents :: (Ord e, Bounded e, Enum e) => (e -> Text) -> KeyEvents e allKeyEvents f = keyEvents $ map (f &&& id) enumerate allBindings :: (Bounded e, Enum e) => (e -> [Binding]) -> [(e, [Binding])] -allBindings f = map (\e -> (e, f e)) [minBound .. maxBound] +allBindings f = map (\e -> (e, f e)) enumerate