expose waypoint and portal info to web API

src/swarm-scenario/Swarm/Game/Scenario/Topography/Navigation/Portal.hs

@@ -46,7 +46,7 @@ data AnnotatedDestination a = AnnotatedDestination
   , reorientation :: Direction
   , destination :: Cosmic a
   }
-  deriving (Show, Eq)
+  deriving (Show, Eq, Generic, ToJSON)
 
 -- | Parameterized on waypoint dimensionality ('additionalDimension') and
 -- on the portal location specification method ('portalExitLoc').
@@ -71,6 +71,7 @@ data Navigation additionalDimension portalExitLoc = Navigation
   -- coordinates (as with applying the "ul" offset).
   , portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
   }
+  deriving (Generic)
 
 deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b)
 deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b)

src/swarm-topography/Swarm/Game/Scenario/Topography/Navigation/Waypoint.hs

@@ -21,6 +21,7 @@
 -- precise control of ordering.
 module Swarm.Game.Scenario.Topography.Navigation.Waypoint where
 
+import Data.Aeson (ToJSONKey)
 import Data.Text qualified as T
 import Data.Yaml as Y
 import GHC.Generics (Generic)
@@ -42,7 +43,7 @@ data Originated a = Originated
   deriving (Show, Eq, Functor)
 
 newtype WaypointName = WaypointName T.Text
-  deriving (Show, Eq, Ord, Generic, FromJSON)
+  deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON, ToJSONKey)
 
 -- | Metadata about a waypoint
 data WaypointConfig = WaypointConfig

src/swarm-topography/Swarm/Game/Universe.hs

@@ -10,6 +10,7 @@
 module Swarm.Game.Universe where
 
 import Control.Lens (makeLenses, view)
+import Data.Aeson (ToJSONKey)
 import Data.Function (on)
 import Data.Int (Int32)
 import Data.Text (Text)
@@ -23,7 +24,7 @@ import Swarm.Util (quote)
 -- * Referring to subworlds
 
 data SubworldName = DefaultRootSubworld | SubworldName Text
-  deriving (Show, Eq, Ord, Generic, ToJSON)
+  deriving (Show, Eq, Ord, Generic, ToJSON, ToJSONKey)
 
 instance FromJSON SubworldName where
   parseJSON = withText "subworld name" $ return . SubworldName
@@ -48,7 +49,7 @@ data Cosmic a = Cosmic
   { _subworld :: SubworldName
   , _planar :: a
   }
-  deriving (Show, Eq, Ord, Functor, Generic, ToJSON)
+  deriving (Show, Eq, Ord, Functor, Generic, ToJSON, ToJSONKey)
 
 makeLenses ''Cosmic
 

src/swarm-web/Swarm/Web.hs

@@ -41,6 +41,7 @@ import Control.Exception (Exception (displayException), IOException, catch, thro
 import Control.Lens
 import Control.Monad (void)
 import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (ToJSON)
 import Data.ByteString.Lazy (ByteString)
 import Data.Foldable (toList)
 import Data.IntMap qualified as IM
@@ -63,18 +64,22 @@ import Servant.Docs qualified as SD
 import Servant.Docs.Internal qualified as SD (renderCurlBasePath)
 import Servant.Types.SourceT qualified as S
 import Swarm.Game.Entity (EntityName, entityName)
+import Swarm.Game.Location (Location)
 import Swarm.Game.Robot
 import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Objective.Graph
 import Swarm.Game.Scenario.Objective.WinCheck
 import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
+import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Structure.Recognition
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Log
 import Swarm.Game.Scenario.Topography.Structure.Recognition.Registry
 import Swarm.Game.State
+import Swarm.Game.State.Landscape
 import Swarm.Game.State.Robot
 import Swarm.Game.State.Substate
 import Swarm.Game.Step.Path.Type
+import Swarm.Game.Universe (SubworldName)
 import Swarm.Language.Pipeline (processTermEither)
 import Swarm.Pretty (prettyTextLine)
 import Swarm.TUI.Model hiding (SwarmKeyDispatchers (..))
@@ -104,6 +109,7 @@ type SwarmAPI =
     :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo)
     :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking
     :<|> "goals" :> Get '[JSON] WinCondition
+    :<|> "navigation" :> Get '[JSON] (Navigation (M.Map SubworldName) Location)
     :<|> "recognize" :> "log" :> Get '[JSON] [SearchLog EntityName]
     :<|> "recognize" :> "found" :> Get '[JSON] [StructureLocation]
     :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
@@ -160,6 +166,7 @@ mkApp state events =
     :<|> goalsGraphHandler state
     :<|> uiGoalHandler state
     :<|> goalsHandler state
+    :<|> navigationHandler state
     :<|> recogLogHandler state
     :<|> recogFoundHandler state
     :<|> codeRenderHandler
@@ -209,6 +216,16 @@ goalsHandler appStateRef = do
   appState <- liftIO appStateRef
   return $ appState ^. gameState . winCondition
 
+deriving instance ToJSON (Navigation (M.Map SubworldName) Location)
+
+instance SD.ToSample (Navigation (M.Map SubworldName) Location) where
+  toSamples _ = SD.noSamples
+
+navigationHandler :: IO AppState -> Handler (Navigation (M.Map SubworldName) Location)
+navigationHandler appStateRef = do
+  appState <- liftIO appStateRef
+  return $ appState ^. gameState . landscape . worldNavigation
+
 recogLogHandler :: IO AppState -> Handler [SearchLog EntityName]
 recogLogHandler appStateRef = do
   appState <- liftIO appStateRef