Split structure assembly into separate module (#1811)

Split the `Structure.hs` module in preparation for #1780.  This refactoring entails no functional change.

# Also included
* follow-up to #1804 to remove REPL re-exports
* reformat `swarm.cabal` for the latest version of `cabal-gild`

src/Swarm/TUI/Model.hs

@@ -33,47 +33,12 @@ module Swarm.TUI.Model (
 
   -- * UI state
 
-  -- ** REPL
-  REPLHistItem (..),
-  replItemText,
-  isREPLEntry,
-  getREPLEntry,
-  REPLHistory,
-  replIndex,
-  replLength,
-  replSeq,
-  newREPLHistory,
-  addREPLItem,
-  restartREPLHistory,
-  getLatestREPLHistoryItems,
-  moveReplHistIndex,
-  getCurrentItemText,
-  replIndexIsAtInput,
-  TimeDir (..),
-
-  -- ** Prompt utils
-  REPLPrompt (..),
-  removeEntry,
-
   -- ** Inventory
   InventoryListEntry (..),
   _Separator,
   _InventoryEntry,
   _EquippedEntry,
 
-  -- *** REPL Panel Model
-  REPLState,
-  ReplControlMode (..),
-  replPromptType,
-  replPromptEditor,
-  replPromptText,
-  replValid,
-  replLast,
-  replType,
-  replControlMode,
-  replHistory,
-  newREPLEditor,
-
   -- ** Updating
   populateInventoryList,
   infoScroll,
@@ -132,7 +97,6 @@ import Swarm.Log
 import Swarm.TUI.Inventory.Sorting
 import Swarm.TUI.Model.Menu
 import Swarm.TUI.Model.Name
-import Swarm.TUI.Model.Repl
 import Swarm.TUI.Model.UI
 import Swarm.Util.Lens (makeLensesNoSigs)
 import Swarm.Version (NewReleaseFailure)

src/Swarm/TUI/View.hs

@@ -132,7 +132,7 @@ import Swarm.TUI.Launch.Model
 import Swarm.TUI.Launch.View
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal (goalsContent, hasAnythingToShow)
-import Swarm.TUI.Model.Repl (getSessionREPLHistoryItems, lastEntry)
+import Swarm.TUI.Model.Repl
 import Swarm.TUI.Model.UI
 import Swarm.TUI.Panel
 import Swarm.TUI.View.Achievement

src/swarm-scenario/Swarm/Game/Scenario.hs

@@ -99,6 +99,7 @@ import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (Parentage (..))
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly qualified as Assembly
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Symmetry
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Type (SymmetryAnnotatedGrid (..))
 import Swarm.Game.Scenario.Topography.WorldDescription
@@ -333,7 +334,7 @@ instance FromJSONE ScenarioInputs Scenario where
       mergedStructures <-
         either (fail . T.unpack) return $
           mapM
-            (sequenceA . (id &&& (Structure.mergeStructures mempty Root . Structure.structure)))
+            (sequenceA . (id &&& (Assembly.mergeStructures mempty Root . Structure.structure)))
             rootLevelSharedStructures
 
       let namedGrids = map (\(ns, Structure.MergedStructure s _ _) -> Grid s <$ ns) mergedStructures

src/swarm-scenario/Swarm/Game/Scenario/Topography/Placement.hs

@@ -67,16 +67,23 @@ applyOrientationTransform (Orientation upDir shouldFlip) =
     DEast -> transpose . flipV
     DWest -> flipV . transpose
 
+data Pose = Pose
+  { offset :: Location
+  , orient :: Orientation
+  }
+  deriving (Eq, Show)
+
 data Placement = Placement
   { src :: StructureName
-  , offset :: Location
-  , orient :: Orientation
+  , structurePose :: Pose
   }
   deriving (Eq, Show)
 
 instance FromJSON Placement where
   parseJSON = withObject "structure placement" $ \v -> do
     sName <- v .: "src"
-    Placement sName
-      <$> v .:? "offset" .!= origin
-      <*> v .:? "orient" .!= defaultOrientation
+    p <-
+      Pose
+        <$> v .:? "offset" .!= origin
+        <*> v .:? "orient" .!= defaultOrientation
+    return $ Placement sName p

src/swarm-scenario/Swarm/Game/Scenario/Topography/Structure.hs

@@ -7,18 +7,10 @@
 -- as well as logic for combining them.
 module Swarm.Game.Scenario.Topography.Structure where
 
-import Control.Applicative ((<|>))
-import Control.Arrow (left, (&&&))
-import Control.Monad (when)
 import Data.Aeson.Key qualified as Key
 import Data.Aeson.KeyMap qualified as KeyMap
-import Data.Coerce
-import Data.Either.Extra (maybeToEither)
-import Data.Foldable (foldrM)
-import Data.Map qualified as M
 import Data.Maybe (catMaybes)
 import Data.Set (Set)
-import Data.Set qualified as Set
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Yaml as Y
@@ -30,8 +22,8 @@ import Swarm.Game.Scenario.Topography.Cell
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Scenario.Topography.Placement
 import Swarm.Game.Scenario.Topography.WorldPalette
-import Swarm.Language.Direction (AbsoluteDir, directionJsonModifier)
-import Swarm.Util (commaList, failT, quote, showT)
+import Swarm.Language.Direction (AbsoluteDir)
+import Swarm.Util (failT, showT)
 import Swarm.Util.Yaml
 import Witch (into)
 
@@ -94,123 +86,6 @@ instance HasLocation LocatedStructure where
 
 data MergedStructure c = MergedStructure [[c]] [LocatedStructure] [Originated Waypoint]
 
--- | Destructively overlays one direct child structure
--- upon the input structure.
--- However, the child structure is assembled recursively.
-overlaySingleStructure ::
-  M.Map StructureName (NamedStructure (Maybe a)) ->
-  Placed (Maybe a) ->
-  MergedStructure (Maybe a) ->
-  Either Text (MergedStructure (Maybe a))
-overlaySingleStructure
-  inheritedStrucDefs
-  (Placed p@(Placement _ loc@(Location colOffset rowOffset) orientation) ns)
-  (MergedStructure inputArea inputPlacements inputWaypoints) = do
-    MergedStructure overlayArea overlayPlacements overlayWaypoints <-
-      mergeStructures inheritedStrucDefs (WithParent p) $ structure ns
-
-    let mergedWaypoints = inputWaypoints <> map (fmap $ placeOnArea overlayArea) overlayWaypoints
-        mergedPlacements = inputPlacements <> map (placeOnArea overlayArea) overlayPlacements
-        mergedArea = zipWithPad mergeSingleRow inputArea $ paddedOverlayRows overlayArea
-
-    return $ MergedStructure mergedArea mergedPlacements mergedWaypoints
-   where
-    placeOnArea overArea =
-      offsetLoc (coerce loc)
-        . modifyLoc (reorientLandmark orientation $ getAreaDimensions overArea)
-
-    zipWithPad f a b = zipWith f a $ b <> repeat Nothing
-
-    affineTransformedOverlay = applyOrientationTransform orientation
-
-    mergeSingleRow inputRow maybeOverlayRow =
-      zipWithPad (flip (<|>)) inputRow paddedSingleOverlayRow
-     where
-      paddedSingleOverlayRow = maybe [] (applyOffset colOffset) maybeOverlayRow
-
-    paddedOverlayRows = applyOffset (negate rowOffset) . map Just . affineTransformedOverlay
-    applyOffset offsetNum = modifyFront
-     where
-      integralOffset = fromIntegral offsetNum
-      modifyFront =
-        if integralOffset >= 0
-          then (replicate integralOffset Nothing <>)
-          else drop $ abs integralOffset
-
-elaboratePlacement :: Parentage Placement -> Either Text a -> Either Text a
-elaboratePlacement p = left (elaboration <>)
- where
-  pTxt = case p of
-    Root -> "root placement"
-    WithParent (Placement (StructureName sn) loc _) ->
-      T.unwords
-        [ "placement of"
-        , quote sn
-        , "at"
-        , showT loc
-        ]
-  elaboration =
-    T.unwords
-      [ "Within"
-      , pTxt <> ":"
-      , ""
-      ]
-
--- | Overlays all of the "child placements", such that the children encountered earlier
--- in the YAML file supersede the later ones (due to use of 'foldr' instead of 'foldl').
-mergeStructures ::
-  M.Map StructureName (NamedStructure (Maybe a)) ->
-  Parentage Placement ->
-  PStructure (Maybe a) ->
-  Either Text (MergedStructure (Maybe a))
-mergeStructures inheritedStrucDefs parentPlacement (Structure origArea subStructures subPlacements subWaypoints) = do
-  overlays <- elaboratePlacement parentPlacement $ mapM g subPlacements
-  let wrapPlacement (Placed z ns) = LocatedStructure (name ns) (up $ orient z) $ offset z
-      wrappedOverlays = map wrapPlacement $ filter (\(Placed _ ns) -> isRecognizable ns) overlays
-  foldrM
-    (overlaySingleStructure structureMap)
-    (MergedStructure origArea wrappedOverlays originatedWaypoints)
-    overlays
- where
-  originatedWaypoints = map (Originated parentPlacement) subWaypoints
-
-  -- deeper definitions override the outer (toplevel) ones
-  structureMap = M.union (M.fromList $ map (name &&& id) subStructures) inheritedStrucDefs
-
-  g placement@(Placement sName@(StructureName n) _ orientation) = do
-    t@(_, ns) <-
-      maybeToEither
-        (T.unwords ["Could not look up structure", quote n])
-        $ sequenceA (placement, M.lookup sName structureMap)
-    let placementDirection = up orientation
-        recognizedOrientations = recognize ns
-    when (isRecognizable ns) $ do
-      when (flipped orientation) $
-        Left $
-          T.unwords
-            [ "Placing recognizable structure"
-            , quote n
-            , "with flipped orientation is not supported."
-            ]
-
-      -- Redundant orientations by rotational symmetry are accounted
-      -- for at scenario parse time
-      when (Set.notMember placementDirection recognizedOrientations) $
-        Left $
-          T.unwords
-            [ "Placing recognizable structure"
-            , quote n
-            , "with"
-            , renderDir placementDirection
-            , "orientation is not supported."
-            , "Try"
-            , commaList $ map renderDir $ Set.toList recognizedOrientations
-            , "instead."
-            ]
-    return $ uncurry Placed t
-   where
-    renderDir = quote . T.pack . directionJsonModifier . show
-
 instance FromJSONE (TerrainEntityMaps, RobotMap) (PStructure (Maybe Cell)) where
   parseJSONE = withObjectE "structure definition" $ \v -> do
     pal <- v ..:? "palette" ..!= WorldPalette mempty