Create and use lenses for ProcessedTerm and Module (#1866)

Splitting out an independent refactoring to simplify #1865.  There were many places in the code where we were pattern-matching on `ProcessedTerm` and/or `Module`, sometimes only to extract a single field, *e.g.*
```
ProcessedTerm (Module s _) _ _ <- maybeInitialCode
```
This was already getting a bit out of hand, and it also meant that any time we wanted to add an extra field to either `ProcessedTerm` or `Module` (as I will be doing in #1865), we would have to change every single such place in the code to add an extra wildcard pattern.

This PR is a refactoring to
1. Derive lenses for all the fields of `ProcessedTerm` and `Module`, and
2. Prefer extracting named fields via lenses over pattern-matching in most places in the code.

There were a few places in the code where we destructure a `ProcessedTerm` and use almost all the fields (e.g. when initializing a robot machine); I left those alone, first because extracting all the individual fields would be tedious, but more importantly because if we ever added any new fields in the future, it's likely we would actually want to use them in those contexts as well.

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

@@ -1228,13 +1228,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,7 +10,14 @@
 -- 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',
@@ -17,7 +25,7 @@ module Swarm.Language.Pipeline (
   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