mirror of
https://github.com/swarm-game/swarm.git
synced 2024-09-11 22:58:21 +03:00
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.
This commit is contained in:
parent
7a8035500d
commit
902ceda8ad
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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,
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user