Extract utils from Controller and View

src/Swarm/DocGen.hs

@@ -445,31 +445,32 @@ recipesToDot classic emap recipes = do
     Dot.attribute ("color", "forestgreen")
     mapM_ ((uncurry (Dot..->.) . (world,)) . getE) (toList testWorld2Entites)
   -- --------------------------------------------------------------------------
-  let -- put a hidden node above and below entities and connect them by hidden edges
-      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
-      wrapBelowAbove ns = do
-        b <- hiddenNode
-        t <- hiddenNode
-        let ns' = map nid $ toList ns
-        mapM_ (b .~>.) ns'
-        mapM_ (.~>. t) ns'
-        return (b, t)
-      -- put set of entities in nice
-      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
-      subLevel i ns = fmap snd . Dot.cluster $ do
-        Dot.attribute ("style", "filled")
-        Dot.attribute ("color", "khaki")
-        bt <- wrapBelowAbove ns
-        Dot.attribute ("rank", "sink")
-        -- the normal label for cluster would be cover by lines
-        _bigLabel <-
-          Dot.node
-            [ ("shape", "plain")
-            , ("label", "Bottom Label")
-            , ("fontsize", "20pt")
-            , ("label", "Level #" <> show i)
-            ]
-        return bt
+  let
+    -- put a hidden node above and below entities and connect them by hidden edges
+    wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
+    wrapBelowAbove ns = do
+      b <- hiddenNode
+      t <- hiddenNode
+      let ns' = map nid $ toList ns
+      mapM_ (b .~>.) ns'
+      mapM_ (.~>. t) ns'
+      return (b, t)
+    -- put set of entities in nice
+    subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
+    subLevel i ns = fmap snd . Dot.cluster $ do
+      Dot.attribute ("style", "filled")
+      Dot.attribute ("color", "khaki")
+      bt <- wrapBelowAbove ns
+      Dot.attribute ("rank", "sink")
+      -- the normal label for cluster would be cover by lines
+      _bigLabel <-
+        Dot.node
+          [ ("shape", "plain")
+          , ("label", "Bottom Label")
+          , ("fontsize", "20pt")
+          , ("label", "Level #" <> show i)
+          ]
+      return bt
   -- --------------------------------------------------------------------------
   -- order entities into clusters based on how "far" they are from
   -- what is available at the start - see 'recipeLevels'.

src/Swarm/Game/Step.hs

@@ -1558,13 +1558,14 @@ execConst c vs s k = do
     currentContext <- use $ robotContext . defReqs
     em <- use entityMap
     creative <- use creativeMode
-    let -- Note that _capCtx must be empty: at least at the
-        -- moment, definitions are only allowed at the top level,
-        -- so there can't be any inside the argument to build.
-        -- (Though perhaps there is an argument that this ought to be
-        -- relaxed specifically in the cases of 'Build' and 'Reprogram'.)
-        -- See #349
-        (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd
+    let
+      -- Note that _capCtx must be empty: at least at the
+      -- moment, definitions are only allowed at the top level,
+      -- so there can't be any inside the argument to build.
+      -- (Though perhaps there is an argument that this ought to be
+      -- relaxed specifically in the cases of 'Build' and 'Reprogram'.)
+      -- See #349
+      (R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd
 
     -- Check that all required device names exist, and fail with
     -- an exception if not
@@ -1580,35 +1581,36 @@ execConst c vs s k = do
             )
     let reqInv = E.fromElems reqElems
 
-    let -- List of possible devices per requirement.  Devices for
-        -- required capabilities come first, then singleton devices
-        -- that are required directly.  This order is important since
-        -- later we zip required capabilities with this list to figure
-        -- out which capabilities are missing.
-        capDevices = map (`deviceForCap` em) caps ++ map (: []) devs
+    let
+      -- List of possible devices per requirement.  Devices for
+      -- required capabilities come first, then singleton devices
+      -- that are required directly.  This order is important since
+      -- later we zip required capabilities with this list to figure
+      -- out which capabilities are missing.
+      capDevices = map (`deviceForCap` em) caps ++ map (: []) devs
 
-        -- A device is OK if it is available in the inventory of the
-        -- parent robot, or already installed in the child robot.
-        deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d
+      -- A device is OK if it is available in the inventory of the
+      -- parent robot, or already installed in the child robot.
+      deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d
 
-        -- take a pair of device sets providing capabilities that is
-        -- split into (AVAIL,MISSING) and if there are some available
-        -- ignore missing because we only need them for error message
-        ignoreOK ([], miss) = ([], miss)
-        ignoreOK (ds, _miss) = (ds, [])
+      -- take a pair of device sets providing capabilities that is
+      -- split into (AVAIL,MISSING) and if there are some available
+      -- ignore missing because we only need them for error message
+      ignoreOK ([], miss) = ([], miss)
+      ignoreOK (ds, _miss) = (ds, [])
 
-        (deviceSets, missingDeviceSets) =
-          Lens.over both (nubOrd . map S.fromList) . unzip $
-            map (ignoreOK . L.partition deviceOK) capDevices
+      (deviceSets, missingDeviceSets) =
+        Lens.over both (nubOrd . map S.fromList) . unzip $
+          map (ignoreOK . L.partition deviceOK) capDevices
 
-        formatDevices = T.intercalate " or " . map (^. entityName) . S.toList
-        -- capabilities not provided by any device in inventory
-        missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets
+      formatDevices = T.intercalate " or " . map (^. entityName) . S.toList
+      -- capabilities not provided by any device in inventory
+      missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets
 
-        alreadyInstalled = S.fromList . map snd . E.elems $ childDevices
+      alreadyInstalled = S.fromList . map snd . E.elems $ childDevices
 
-        -- Figure out what is missing from the required inventory
-        missingChildInv = reqInv `E.difference` childInventory
+      -- Figure out what is missing from the required inventory
+      missingChildInv = reqInv `E.difference` childInventory
 
     if creative
       then -- In creative mode, just return ALL the devices

src/Swarm/TUI/Controller.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 
 -- |
 -- Module      :  Swarm.TUI.Controller
@@ -81,6 +80,7 @@ import Swarm.Language.Requirement qualified as R
 import Swarm.Language.Syntax
 import Swarm.Language.Typed (Typed (..))
 import Swarm.Language.Types
+import Swarm.TUI.Controller.ControllerUtils
 import Swarm.TUI.Inventory.Sorting (cycleSortDirection, cycleSortOrder)
 import Swarm.TUI.List
 import Swarm.TUI.Model
@@ -90,24 +90,6 @@ import Swarm.Version (NewReleaseFailure (..))
 import System.Clock
 import Witch (into)
 
--- | Pattern synonyms to simplify brick event handler
-pattern Key :: V.Key -> BrickEvent n e
-pattern Key k = VtyEvent (V.EvKey k [])
-
-pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e
-pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) [])
-pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])
-pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])
-
-pattern ShiftKey :: V.Key -> BrickEvent n e
-pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift])
-
-pattern EscapeKey :: BrickEvent n e
-pattern EscapeKey = VtyEvent (V.EvKey V.KEsc [])
-
-pattern FKey :: Int -> BrickEvent n e
-pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])
-
 -- | The top-level event handler for the TUI.
 handleEvent :: BrickEvent Name AppEvent -> EventM Name AppState ()
 handleEvent = \case

src/Swarm/TUI/Controller/ControllerUtils.hs

@@ -0,0 +1,24 @@
+{-# LANGUAGE PatternSynonyms #-}
+
+module Swarm.TUI.Controller.ControllerUtils where
+
+import Brick hiding (Direction)
+import Graphics.Vty qualified as V
+
+-- | Pattern synonyms to simplify brick event handler
+pattern Key :: V.Key -> BrickEvent n e
+pattern Key k = VtyEvent (V.EvKey k [])
+
+pattern CharKey, ControlChar, MetaChar :: Char -> BrickEvent n e
+pattern CharKey c = VtyEvent (V.EvKey (V.KChar c) [])
+pattern ControlChar c = VtyEvent (V.EvKey (V.KChar c) [V.MCtrl])
+pattern MetaChar c = VtyEvent (V.EvKey (V.KChar c) [V.MMeta])
+
+pattern ShiftKey :: V.Key -> BrickEvent n e
+pattern ShiftKey k = VtyEvent (V.EvKey k [V.MShift])
+
+pattern EscapeKey :: BrickEvent n e
+pattern EscapeKey = VtyEvent (V.EvKey V.KEsc [])
+
+pattern FKey :: Int -> BrickEvent n e
+pattern FKey c = VtyEvent (V.EvKey (V.KFun c) [])

src/Swarm/TUI/View.hs

@@ -91,12 +91,12 @@ import Swarm.Game.World qualified as W
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck (inferConst)
-import Swarm.Language.Types (Polytype)
 import Swarm.TUI.Attr
 import Swarm.TUI.Border
 import Swarm.TUI.Inventory.Sorting (renderSortMethod)
 import Swarm.TUI.Model
 import Swarm.TUI.Panel
+import Swarm.TUI.View.ViewUtils
 import Swarm.Util
 import Swarm.Version (NewReleaseFailure (..))
 import System.Clock (TimeSpec (..))
@@ -390,10 +390,6 @@ drawTime t showTicks =
 maybeDrawTime :: Integer -> Bool -> GameState -> Maybe (Widget n)
 maybeDrawTime t showTicks gs = guard (clockInstalled gs) $> drawTime t showTicks
 
--- | Render the type of the current REPL input to be shown to the user.
-drawType :: Polytype -> Widget Name
-drawType = withAttr infoAttr . padLeftRight 1 . txt . prettyText
-
 -- | Draw info about the current number of ticks per second.
 drawTPS :: AppState -> Widget Name
 drawTPS s = hBox (tpsInfo : rateInfo)
@@ -426,10 +422,6 @@ chooseCursor s locs = case s ^. uiState . uiModal of
   Nothing -> showFirstCursor s locs
   Just _ -> Nothing
 
--- | Width cap for modal and error message windows
-maxModalWindowWidth :: Int
-maxModalWindowWidth = 500
-
 -- | Render the error dialog window with a given error message
 renderErrorDialog :: Text -> Widget Name
 renderErrorDialog err = renderDialog (dialog (Just "Error") Nothing (maxModalWindowWidth `min` requiredWidth)) errContent
@@ -473,77 +465,6 @@ drawModal s = \case
   GoalModal g -> padLeftRight 1 (displayParagraphs g)
   KeepPlayingModal -> padLeftRight 1 (displayParagraphs ["Have fun!  Hit Ctrl-Q whenever you're ready to proceed to the next challenge or return to the menu."])
 
-quitMsg :: Menu -> Text
-quitMsg m = "Are you sure you want to " <> quitAction <> "? All progress on this scenario will be lost!"
- where
-  quitAction = case m of
-    NoMenu -> "quit"
-    _ -> "return to the menu"
-
--- | Generate a fresh modal window of the requested type.
-generateModal :: AppState -> ModalType -> Modal
-generateModal s mt = Modal mt (dialog (Just title) buttons (maxModalWindowWidth `min` requiredWidth))
- where
-  currentScenario = s ^. uiState . scenarioRef
-  currentSeed = s ^. gameState . seed
-  haltingMessage = case s ^. uiState . uiMenu of
-    NoMenu -> Just "Quit"
-    _ -> Nothing
-  descriptionWidth = 100
-  helpWidth = 80
-  (title, buttons, requiredWidth) =
-    case mt of
-      HelpModal -> (" Help ", Nothing, helpWidth)
-      RobotsModal -> ("Robots", Nothing, descriptionWidth)
-      RecipesModal -> ("Available Recipes", Nothing, descriptionWidth)
-      CommandsModal -> ("Available Commands", Nothing, descriptionWidth)
-      MessagesModal -> ("Messages", Nothing, descriptionWidth)
-      WinModal ->
-        let nextMsg = "Next challenge!"
-            stopMsg = fromMaybe "Return to the menu" haltingMessage
-            continueMsg = "Keep playing"
-         in ( ""
-            , Just
-                ( 0
-                , [ (nextMsg, NextButton scene)
-                  | Just scene <- [nextScenario (s ^. uiState . uiMenu)]
-                  ]
-                    ++ [ (stopMsg, QuitButton)
-                       , (continueMsg, KeepPlayingButton)
-                       ]
-                )
-            , sum (map length [nextMsg, stopMsg, continueMsg]) + 32
-            )
-      DescriptionModal e -> (descriptionTitle e, Nothing, descriptionWidth)
-      QuitModal ->
-        let stopMsg = fromMaybe ("Quit to" ++ maybe "" (" " ++) (into @String <$> curMenuName s) ++ " menu") haltingMessage
-            maybeStartOver = sequenceA ("Start over", StartOverButton currentSeed <$> currentScenario)
-         in ( ""
-            , Just
-                ( 0
-                , catMaybes
-                    [ Just ("Keep playing", CancelButton)
-                    , maybeStartOver
-                    , Just (stopMsg, QuitButton)
-                    ]
-                )
-            , T.length (quitMsg (s ^. uiState . uiMenu)) + 4
-            )
-      GoalModal _ ->
-        let goalModalTitle = case currentScenario of
-              Nothing -> "Goal"
-              Just (scenario, _) -> scenario ^. scenarioName
-         in (" " <> T.unpack goalModalTitle <> " ", Nothing, 80)
-      KeepPlayingModal -> ("", Just (0, [("OK", CancelButton)]), 80)
-
--- | Get the name of the current New Game menu.
-curMenuName :: AppState -> Maybe Text
-curMenuName s = case s ^. uiState . uiMenu of
-  NewGameMenu (_ :| (parentMenu : _)) ->
-    Just (parentMenu ^. BL.listSelectedElementL . to scenarioItemName)
-  NewGameMenu _ -> Just "Scenarios"
-  _ -> Nothing
-
 robotsListWidget :: AppState -> Widget Name
 robotsListWidget s = hCenter table
  where
@@ -713,9 +634,6 @@ drawConst c = hBox [padLeft (Pad $ 13 - T.length constName) (txt constName), txt
   constName = syntax . constInfo $ c
   constSig = " : " <> prettyText (inferConst c)
 
-descriptionTitle :: Entity -> String
-descriptionTitle e = " " ++ from @Text (e ^. entityName) ++ " "
-
 -- | Generate a pop-up widget to display the description of an entity.
 descriptionWidget :: AppState -> Entity -> Widget Name
 descriptionWidget s e = padLeftRight 1 (explainEntry s e)