Create and use lenses for ProcessedTerm and Module

src/swarm-doc/Swarm/Doc/Pedagogy.hs

@@ -54,8 +54,7 @@ import Swarm.Game.ScenarioInfo (
   scenarioPath,
  )
 import Swarm.Game.World.Load (loadWorlds)
-import Swarm.Language.Module (Module (..))
-import Swarm.Language.Pipeline (ProcessedTerm (..))
+import Swarm.Language.Pipeline (ProcessedTerm, processedSyntax)
 import Swarm.Language.Syntax
 import Swarm.Language.Text.Markdown (docToText, findCode)
 import Swarm.Language.Types (Polytype)
@@ -131,11 +130,11 @@ isConsidered c = isUserFunc c && c `S.notMember` ignoredCommands
 -- Also, the code from `run` is not parsed transitively yet.
 getCommands :: Maybe ProcessedTerm -> Map Const [SrcLoc]
 getCommands Nothing = mempty
-getCommands (Just (ProcessedTerm (Module stx _) _ _)) =
+getCommands (Just pt) =
   M.fromListWith (<>) $ mapMaybe isCommand nodelist
  where
   nodelist :: [Syntax' Polytype]
-  nodelist = universe stx
+  nodelist = universe (pt ^. processedSyntax)
   isCommand (Syntax' sloc t _ _) = case t of
     TConst c -> guard (isConsidered c) >> Just (c, [sloc])
     _ -> Nothing

src/swarm-engine/Swarm/Game/Scenario/Scoring/CodeSize.hs

@@ -5,12 +5,12 @@
 -- in terms of textual length and AST nodes.
 module Swarm.Game.Scenario.Scoring.CodeSize where
 
+import Control.Lens ((^.))
 import Control.Monad (guard)
 import Data.Aeson
 import Data.Data (Data)
 import GHC.Generics (Generic)
-import Swarm.Language.Module
-import Swarm.Language.Pipeline
+import Swarm.Language.Pipeline (ProcessedTerm, processedSyntax)
 import Swarm.Language.Syntax
 
 data CodeSizeDeterminators = CodeSizeDeterminators
@@ -39,5 +39,5 @@ codeMetricsFromSyntax s@(Syntax' srcLoc _ _ _) =
 codeSizeFromDeterminator :: CodeSizeDeterminators -> Maybe ScenarioCodeMetrics
 codeSizeFromDeterminator (CodeSizeDeterminators maybeInitialCode usedRepl) = do
   guard $ not usedRepl
-  ProcessedTerm (Module s _) _ _ <- maybeInitialCode
-  return $ codeMetricsFromSyntax s
+  pt <- maybeInitialCode
+  return $ codeMetricsFromSyntax (pt ^. processedSyntax)

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -1206,13 +1206,13 @@ execConst runChildProg c vs s k = do
 
         case mt of
           Nothing -> return $ mkReturn ()
-          Just t@(ProcessedTerm _ _ reqCtx) -> do
+          Just pt -> do
             -- Add the reqCtx from the ProcessedTerm to the current robot's defReqs.
             -- See #827 for an explanation of (1) why this is needed, (2) why
             -- it's slightly technically incorrect, and (3) why it is still way
             -- better than what we had before.
-            robotContext . defReqs <>= reqCtx
-            return $ initMachine' t empty s k
+            robotContext . defReqs <>= (pt ^. processedReqCtx)
+            return $ initMachine' pt empty s k
       _ -> badConst
     Not -> case vs of
       [VBool b] -> return $ Out (VBool (not b)) s k

src/swarm-lang/Swarm/Language/LSP/Hover.hs

@@ -31,10 +31,9 @@ import Data.Text.Utf16.Rope.Mixed qualified as R
 import Language.LSP.Protocol.Types qualified as J
 import Language.LSP.VFS
 import Swarm.Language.Context as Ctx
-import Swarm.Language.Module (Module (..))
 import Swarm.Language.Parser (readTerm')
 import Swarm.Language.Parser.Core (defaultParserConfig)
-import Swarm.Language.Pipeline (ProcessedTerm (..), processParsedTerm)
+import Swarm.Language.Pipeline (processParsedTerm, processedSyntax)
 import Swarm.Language.Pretty (prettyText, prettyTextLine)
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck (inferConst)
@@ -68,12 +67,13 @@ showHoverInfo _ p vf@(VirtualFile _ _ myRope) =
   genHoverInfo stx =
     case processParsedTerm stx of
       Left _e ->
-        let found@(Syntax foundSloc _) = narrowToPosition stx $ fromIntegral absolutePos
-            finalPos = posToRange myRope foundSloc
+        let found = narrowToPosition stx $ fromIntegral absolutePos
+            finalPos = posToRange myRope (found ^. sLoc)
          in (,finalPos) . treeToMarkdown 0 $ explain found
-      Right (ProcessedTerm modul _req _reqCtx) ->
-        let found@(Syntax' foundSloc _ _ _) = narrowToPosition (moduleAST modul) $ fromIntegral absolutePos
-            finalPos = posToRange myRope foundSloc
+      Right pt ->
+        let found =
+              narrowToPosition (pt ^. processedSyntax) $ fromIntegral absolutePos
+            finalPos = posToRange myRope (found ^. sLoc)
          in (,finalPos) . treeToMarkdown 0 $ explain found
 
 posToRange :: R.Rope -> SrcLoc -> Maybe J.Range

src/swarm-lang/Swarm/Language/Module.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE TemplateHaskell #-}
+
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 --
@@ -6,11 +8,14 @@
 module Swarm.Language.Module (
   -- * Modules
   Module (..),
+  moduleSyntax,
+  moduleCtx,
   TModule,
   UModule,
   trivMod,
 ) where
 
+import Control.Lens (makeLenses)
 import Data.Data (Data)
 import Data.Yaml (FromJSON, ToJSON)
 import GHC.Generics (Generic)
@@ -27,9 +32,11 @@ import Swarm.Language.Types (Polytype, UPolytype, UType)
 --   contain definitions ('Swarm.Language.Syntax.TDef').  A module
 --   contains the type-annotated AST of the expression itself, as well
 --   as the context giving the types of any defined variables.
-data Module s t = Module {moduleAST :: Syntax' s, moduleCtx :: Ctx t}
+data Module s t = Module {_moduleSyntax :: Syntax' s, _moduleCtx :: Ctx t}
   deriving (Show, Eq, Functor, Data, Generic, FromJSON, ToJSON)
 
+makeLenses ''Module
+
 -- | A 'TModule' is the final result of the type inference process on
 --   an expression: we get a polytype for the expression, and a
 --   context of polytypes for the defined variables.

src/swarm-lang/Swarm/Language/Pipeline.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
@@ -9,15 +10,22 @@
 -- text representing a Swarm program into something useful, this is
 -- probably the module you want.
 module Swarm.Language.Pipeline (
+  -- * ProcessedTerm
   ProcessedTerm (..),
+  processedModule,
+  processedSyntax,
+  processedRequirements,
+  processedReqCtx,
+
+  -- * Pipeline functions for producing ProcessedTerm
   processTerm,
   processParsedTerm,
   processTerm',
   processParsedTerm',
   processTermEither,
 ) where
 
-import Control.Lens ((^.))
+import Control.Lens (Lens', makeLenses, view, (^.))
 import Data.Bifunctor (first)
 import Data.Data (Data)
 import Data.Text (Text)
@@ -46,9 +54,20 @@ import Witch (into)
 --
 --   * The requirements context for any definitions embedded in the
 --     term ('ReqCtx')
-data ProcessedTerm = ProcessedTerm TModule Requirements ReqCtx
+data ProcessedTerm = ProcessedTerm
+  { _processedModule :: TModule
+  , _processedRequirements :: Requirements
+  , _processedReqCtx :: ReqCtx
+  }
   deriving (Data, Show, Eq, Generic)
 
+makeLenses ''ProcessedTerm
+
+-- | A convenient lens directly targeting the AST stored in a
+--   ProcessedTerm.
+processedSyntax :: Lens' ProcessedTerm (Syntax' Polytype)
+processedSyntax = processedModule . moduleSyntax
+
 processTermEither :: Text -> Either Text ProcessedTerm
 processTermEither t = case processTerm t of
   Left err -> Left $ T.unwords ["Could not parse term:", err]
@@ -59,7 +78,7 @@ instance FromJSON ProcessedTerm where
   parseJSON = withText "Term" $ either (fail . into @String) return . processTermEither
 
 instance ToJSON ProcessedTerm where
-  toJSON (ProcessedTerm t _ _) = String $ prettyText (moduleAST t)
+  toJSON = String . prettyText . view processedSyntax
 
 -- | Given a 'Text' value representing a Swarm program,
 --

src/swarm-tournament/Swarm/Web/Tournament/Validate.hs

@@ -34,8 +34,7 @@ import Swarm.Game.State.Runtime (initGameStateConfig, initScenarioInputs)
 import Swarm.Game.State.Substate (initState, seed)
 import Swarm.Game.Step.Validate (playUntilWin)
 import Swarm.Language.Context qualified as Ctx
-import Swarm.Language.Module (Module (..))
-import Swarm.Language.Pipeline (ProcessedTerm (..), processTermEither)
+import Swarm.Language.Pipeline
 import Swarm.Util.Yaml
 import Swarm.Web.Tournament.Database.Query
 import Swarm.Web.Tournament.Type
@@ -213,12 +212,11 @@ verifySolution (SolutionTimeout timeoutSeconds) sol gs = do
       (gs ^. randomness . seed)
       codeMetrics
  where
-  ProcessedTerm (Module s _) _ reqCtx = sol
-  codeMetrics = codeMetricsFromSyntax s
+  codeMetrics = codeMetricsFromSyntax (sol ^. processedSyntax)
   gs' =
     gs
       -- See #827 for an explanation of why it's important to add to
       -- the robotContext defReqs here (and also why this will,
       -- hopefully, eventually, go away).
-      & baseRobot . robotContext . defReqs <>~ reqCtx
+      & baseRobot . robotContext . defReqs <>~ (sol ^. processedReqCtx)
       & baseRobot . machine .~ initMachine sol Ctx.empty emptyStore

src/swarm-tui/Swarm/TUI/Controller.hs

@@ -95,9 +95,9 @@ import Swarm.Game.Step (finishGameTick, gameTick)
 import Swarm.Language.Capability (Capability (CGod, CMake), constCaps)
 import Swarm.Language.Context
 import Swarm.Language.Key (KeyCombo, mkKeyCombo)
-import Swarm.Language.Module
+import Swarm.Language.Module (Module (..))
 import Swarm.Language.Parser.Lex (reservedWords)
-import Swarm.Language.Pipeline
+import Swarm.Language.Pipeline (ProcessedTerm (..), processTerm', processedSyntax)
 import Swarm.Language.Pipeline.QQ (tmQ)
 import Swarm.Language.Pretty
 import Swarm.Language.Requirement qualified as R
@@ -1301,7 +1301,7 @@ validateREPLForm s =
       | otherwise ->
           let result = processTerm' (topCtx ^. defTypes) (topCtx ^. defReqs) uinput
               theType = case result of
-                Right (Just (ProcessedTerm (Module tm _) _ _)) -> Just (tm ^. sType)
+                Right (Just pt) -> Just (pt ^. processedSyntax . sType)
                 _ -> Nothing
            in s
                 & uiState . uiGameplay . uiREPL . replValid .~ isRight result

src/swarm-web/Swarm/Web.hs

@@ -76,10 +76,8 @@ import Swarm.Game.State
 import Swarm.Game.State.Robot
 import Swarm.Game.State.Substate
 import Swarm.Game.Step.Path.Type
-import Swarm.Language.Module
-import Swarm.Language.Pipeline
+import Swarm.Language.Pipeline (processTermEither, processedSyntax)
 import Swarm.Language.Pretty (prettyTextLine)
-import Swarm.Language.Syntax
 import Swarm.TUI.Model
 import Swarm.TUI.Model.Goal
 import Swarm.TUI.Model.Repl (REPLHistItem, replHistory, replSeq)
@@ -231,8 +229,8 @@ recogFoundHandler appStateRef = do
 codeRenderHandler :: Text -> Handler Text
 codeRenderHandler contents = do
   return $ case processTermEither contents of
-    Right (ProcessedTerm (Module stx@(Syntax' _srcLoc _term _ _) _) _ _) ->
-      into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ stx
+    Right pt ->
+      into @Text . drawTree . fmap (T.unpack . prettyTextLine) . para Node $ pt ^. processedSyntax
     Left x -> x
 
 codeRunHandler :: BChan AppEvent -> Text -> Handler Text