Merge of #2597

mergify[bot] · web-flow · commit b1bd67d7b7fc · 2025-10-24T11:32:37.000Z
diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs
@@ -660,7 +660,7 @@ stepCESK cesk = case cesk of
   Out _ s (FApp _ : _) -> badMachineState s "FApp of non-function"
   -- Start evaluating a record.  If it's empty, we're done.  Otherwise, focus
   -- on the first field and record the rest in a FRcd frame.
-  In (TRcd m) e s k -> return $ case map (first lvVar) m of
+  In (TRcd m) e s k -> return $ case map (first locVal) m of
     [] -> Out (VRcd M.empty) s k
     ((x, t) : fs) -> In (fromMaybe (TVar x) t) e s (FRcd e [] x fs : k)
   -- When we finish evaluating the last field, return a record value.
diff --git a/src/swarm-lang/Swarm/Language/LSP/Hover.hs b/src/swarm-lang/Swarm/Language/LSP/Hover.hs
@@ -238,14 +238,14 @@ explain trm = case trm ^. sTerm of
   SRequirements {} -> pure "Query the requirements of a term."
   -- definition or bindings
   SLet ls isRecursive var mTypeAnn _ _ rhs _b -> pure $ explainDefinition ls isRecursive var (rhs ^. sType) mTypeAnn
-  SLam (LV _s v) _mType _syn ->
+  SLam (Loc _s v) _mType _syn ->
     pure $
       typeSignature v ty $
         "A lambda expression binding the variable " <> U.bquote v <> "."
   SBind mv _ _ _ rhs _cmds ->
     pure $
-      typeSignature (maybe "__rhs" lvVar mv) (getInnerType $ rhs ^. sType) $
-        "A monadic bind for commands" <> maybe "." (\(LV _s v) -> ", that binds variable " <> U.bquote v <> ".") mv
+      typeSignature (maybe "__rhs" locVal mv) (getInnerType $ rhs ^. sType) $
+        "A monadic bind for commands" <> maybe "." (\(Loc _s v) -> ", that binds variable " <> U.bquote v <> ".") mv
   -- composite types
   SPair {} ->
     Node
@@ -298,7 +298,7 @@ explainFunction s =
       ]
 
 explainDefinition :: ExplainableType ty => LetSyntax -> Bool -> LocVar -> ty -> Maybe RawPolytype -> Text
-explainDefinition ls isRecursive (LV _s var) ty maybeTypeAnnotation =
+explainDefinition ls isRecursive (Loc _s var) ty maybeTypeAnnotation =
   typeSignature var ty $
     T.unwords
       [ "A"
diff --git a/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs
@@ -44,7 +44,7 @@ instance Monoid Usage where
   mempty = Usage mempty mempty
 
 toErrPos :: Text -> VarUsage -> Maybe (J.Range, Text)
-toErrPos code (VarUsage (LV loc v) scope) = do
+toErrPos code (VarUsage (Loc loc v) scope) = do
   -- A leading underscore will suppress the unused variable warning
   guard $ not $ "_" `T.isPrefixOf` v
   rangePair <- case loc of
@@ -78,12 +78,12 @@ checkOccurrences ::
   BindingType ->
   [Syntax] ->
   Usage
-checkOccurrences bindings lv@(LV loc v) declType childSyntaxes =
+checkOccurrences bindings lc@(Loc loc v) declType childSyntaxes =
   Usage childUsages $ missing <> deeperMissing
  where
   deeperBindings = M.insertWith (<>) v (pure loc) bindings
   Usage childUsages deeperMissing = mconcat $ map (getUsage deeperBindings) childSyntaxes
-  missing = [VarUsage lv declType | lv `S.notMember` childUsages]
+  missing = [VarUsage lc declType | lc `S.notMember` childUsages]
 
 -- | Build up the bindings map as a function argument as
 -- we descend into the syntax tree.
@@ -97,7 +97,7 @@ getUsage bindings (CSyntax _pos t _comments) = case t of
    where
     myUsages = case M.lookup v bindings of
       Nothing -> mempty
-      Just (loc :| _) -> S.singleton $ LV loc v
+      Just (loc :| _) -> S.singleton $ Loc loc v
   SLam v _ s -> checkOccurrences bindings v Lambda [s]
   SApp s1 s2 -> getUsage bindings s1 <> getUsage bindings s2
   -- Warn on unused 'let' bindings...
@@ -110,7 +110,7 @@ getUsage bindings (CSyntax _pos t _comments) = case t of
     Just v -> checkOccurrences bindings v Bind [s1, s2]
     Nothing -> getUsage bindings s1 <> getUsage bindings s2
   SDelay s -> getUsage bindings s
-  SRcd m -> foldMap (\(LV _ x, mt) -> maybe (getUsage bindings (STerm (TVar x))) (getUsage bindings) mt) m
+  SRcd m -> foldMap (\(Loc _ x, mt) -> maybe (getUsage bindings (STerm (TVar x))) (getUsage bindings) mt) m
   SProj s _ -> getUsage bindings s
   SAnnotate s _ -> getUsage bindings s
   SSuspend s -> getUsage bindings s
diff --git a/src/swarm-lang/Swarm/Language/Parser/Lex.hs b/src/swarm-lang/Swarm/Language/Parser/Lex.hs
@@ -215,7 +215,7 @@ data IdentifierType = IDTyVar | IDTyName | IDTmVar
 -- | Parse an identifier together with its source location info.
 locIdentifier :: IdentifierType -> Parser LocVar
 locIdentifier idTy =
-  uncurry LV <$> parseLocG ((lexeme . try) (p >>= check) <?> "variable name")
+  uncurry Loc <$> parseLocG ((lexeme . try) (p >>= check) <?> "variable name")
  where
   p = (:) <$> (letterChar <|> char '_') <*> many (alphaNumChar <|> char '_' <|> char '\'')
   check (into @Text -> t)
@@ -248,7 +248,7 @@ locTyName = (fmap . fmap) mkTDVar (locIdentifier IDTyName)
 --   alphanumeric characters and underscores, not starting with a
 --   digit. The Bool indicates whether we are parsing a type variable.
 identifier :: IdentifierType -> Parser Var
-identifier = fmap lvVar . locIdentifier
+identifier = fmap locVal . locIdentifier
 
 -- | Parse a type variable, which must start with an underscore or
 --   lowercase letter and cannot be the lowercase version of a type
diff --git a/src/swarm-lang/Swarm/Language/Parser/Record.hs b/src/swarm-lang/Swarm/Language/Parser/Record.hs
@@ -10,7 +10,7 @@ module Swarm.Language.Parser.Record (
 
 import Swarm.Language.Parser.Core (Parser)
 import Swarm.Language.Parser.Lex (locTmVar, symbol)
-import Swarm.Language.Syntax.Loc (LocVar, lvVar)
+import Swarm.Language.Syntax.Loc (LocVar, locVal)
 import Swarm.Util (failT, findDup, squote)
 import Text.Megaparsec (sepBy)
 
@@ -24,6 +24,6 @@ parseRecord :: Parser a -> Parser [(LocVar, a)]
 parseRecord p = (parseBinding `sepBy` symbol ",") >>= fromListUnique
  where
   parseBinding = (,) <$> locTmVar <*> p
-  fromListUnique kvs = case findDup (map (lvVar . fst) kvs) of
+  fromListUnique kvs = case findDup (map (locVal . fst) kvs) of
     Nothing -> pure kvs
     Just x -> failT ["duplicate field name", squote x, "in record literal"]
diff --git a/src/swarm-lang/Swarm/Language/Parser/Term.hs b/src/swarm-lang/Swarm/Language/Parser/Term.hs
@@ -89,7 +89,7 @@ parseTermAtom2 =
           <*> (reserved "in" *> parseTerm)
         <|> do
           reserved "def"
-          locVar@(LV _srcLoc nameText) <- locTmVar
+          locVar@(Loc _srcLoc nameText) <- locTmVar
           mTy <- optional (symbol ":" *> parsePolytype)
           _ <- symbol "="
           body <- parseTerm
@@ -127,7 +127,7 @@ parseStock =
 -- | Construct an 'SLet', automatically filling in the Boolean field
 --   indicating whether it is recursive.
 sLet :: LetSyntax -> LocVar -> Maybe RawPolytype -> Syntax -> Syntax -> Term
-sLet ls x ty t1 = SLet ls (lvVar x `S.member` setOf freeVarsV t1) x ty Nothing mempty t1
+sLet ls x ty t1 = SLet ls (locVal x `S.member` setOf freeVarsV t1) x ty Nothing mempty t1
 
 sNoop :: Syntax
 sNoop = STerm (TConst Noop)
@@ -159,7 +159,7 @@ parseTerm = sepEndBy1 parseStmt (symbol ";") >>= mkBindChain
 
 mkBindChain :: [Stmt] -> Parser Syntax
 mkBindChain stmts = case last stmts of
-  Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Pure) (TVar (lvVar x)))) stmts
+  Binder x _ -> return $ foldr mkBind (STerm (TApp (TConst Pure) (TVar (locVal x)))) stmts
   BareTerm t -> return $ foldr mkBind t (init stmts)
  where
   mkBind (BareTerm t1) t2 = loc Nothing t1 t2 $ SBind Nothing Nothing Nothing Nothing t1 t2
diff --git a/src/swarm-lang/Swarm/Language/Parser/Type.hs b/src/swarm-lang/Swarm/Language/Parser/Type.hs
@@ -32,7 +32,7 @@ import Swarm.Language.Parser.Lex (
   tyVar,
  )
 import Swarm.Language.Parser.Record (parseRecord)
-import Swarm.Language.Syntax.Loc (lvVar)
+import Swarm.Language.Syntax.Loc (locVal)
 import Swarm.Language.Types
 import Text.Megaparsec (choice, optional, some, (<|>))
 
@@ -65,17 +65,19 @@ parseTypeMolecule =
   TyConApp <$> parseTyCon <*> many parseTypeAtom
     <|> parseTypeAtom
 
--- | A "type atom" consists of some atomic type snytax --- type
+-- | A "type atom" consists of some atomic type syntax --- type
 --   variables, things in brackets of some kind, or a lone type
 --   constructor.
 parseTypeAtom :: Parser Type
 parseTypeAtom =
   TyVar <$> tyVar
     <|> TyConApp <$> parseTyCon <*> pure []
     <|> TyDelay <$> braces parseType
-    <|> TyRcd <$> brackets (M.fromList . (map . first) lvVar <$> parseRecord (symbol ":" *> parseType))
+    <|> TyRcd <$> brackets (toRecFieldsMap <$> parseRecord (symbol ":" *> parseType))
     <|> tyRec <$> (reserved "rec" *> tyVar) <*> (symbol "." *> parseType)
     <|> parens parseType
+ where
+  toRecFieldsMap = M.fromList . map (first locVal)
 
 -- | A type constructor.
 parseTyCon :: Parser TyCon
diff --git a/src/swarm-lang/Swarm/Language/Parser/Value.hs b/src/swarm-lang/Swarm/Language/Parser/Value.hs
@@ -62,7 +62,7 @@ toValue = \case
       VKey <$> eitherToMaybe (MP.runParser parseKeyComboFull "" k)
     _ -> Nothing
   TPair t1 t2 -> VPair <$> toValue t1 <*> toValue t2
-  TRcd m -> VRcd . M.fromList <$> traverse (traverse (>>= toValue) . first lvVar) m
+  TRcd m -> VRcd . M.fromList <$> traverse (traverse (>>= toValue) . first locVal) m
   TParens t -> toValue t
   -- List the other cases explicitly, instead of a catch-all, so that
   -- we will get a warning if we ever add new constructors in the
diff --git a/src/swarm-lang/Swarm/Language/Pipeline.hs b/src/swarm-lang/Swarm/Language/Pipeline.hs
@@ -77,12 +77,12 @@ extractTCtx :: Syntax' ty -> TCtx
 extractTCtx (Syntax' _ t _ _) = extractTCtxTerm t
  where
   extractTCtxTerm = \case
-    SLet _ _ (LV _ x) _ mty _ _ t2 -> maybe id (Ctx.addBinding x) mty (extractTCtx t2)
+    SLet _ _ (Loc _ x) _ mty _ _ t2 -> maybe id (Ctx.addBinding x) mty (extractTCtx t2)
     SBind mx _ mty _ c1 c2 ->
       maybe
         id
         (uncurry Ctx.addBinding)
-        ((,) . lvVar <$> mx <*> mty)
+        ((,) . locVal <$> mx <*> mty)
         (extractTCtx c1 <> extractTCtx c2)
     SAnnotate t1 _ -> extractTCtx t1
     _ -> mempty
@@ -94,12 +94,12 @@ extractReqCtx :: Syntax' ty -> ReqCtx
 extractReqCtx (Syntax' _ t _ _) = extractReqCtxTerm t
  where
   extractReqCtxTerm = \case
-    SLet _ _ (LV _ x) _ _ mreq _ t2 -> maybe id (Ctx.addBinding x) mreq (extractReqCtx t2)
+    SLet _ _ (Loc _ x) _ _ mreq _ t2 -> maybe id (Ctx.addBinding x) mreq (extractReqCtx t2)
     SBind mx _ _ mreq c1 c2 ->
       maybe
         id
         (uncurry Ctx.addBinding)
-        ((,) . lvVar <$> mx <*> mreq)
+        ((,) . locVal <$> mx <*> mreq)
         (extractReqCtx c1 <> extractReqCtx c2)
     SAnnotate t1 _ -> extractReqCtx t1
     _ -> mempty
diff --git a/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs
@@ -157,7 +157,7 @@ requirements tdCtx ctx =
     TDelay t -> go t
     TRcd m -> add (singletonCap CRecord) *> forM_ m (go . expandEq)
      where
-      expandEq (LV _ x, Nothing) = TVar x
+      expandEq (Loc _ x, Nothing) = TVar x
       expandEq (_, Just t) = t
     TProj t _ -> add (singletonCap CRecord) *> go t
     -- A type ascription doesn't change requirements
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Loc.hs b/src/swarm-lang/Swarm/Language/Syntax/Loc.hs
@@ -66,10 +66,11 @@ srcLocEndsBefore :: SrcLoc -> SrcLoc -> Bool
 srcLocEndsBefore (SrcLoc _ a) (SrcLoc _ b) = a <= b
 srcLocEndsBefore _ _ = False
 
+-- | A value with associated source location.
+data Located v = Loc {lvSrcLoc :: SrcLoc, locVal :: v}
+  deriving (Eq, Ord, Functor, Show, Data, Generic, Hashable, FromJSON, ToJSON)
+
 -- | A variable with associated source location, used for variable
 --   binding sites. (Variable occurrences are a bare TVar which gets
 --   wrapped in a Syntax node, so we don't need LocVar for those.)
-data Located v = LV {lvSrcLoc :: SrcLoc, lvVar :: v}
-  deriving (Eq, Ord, Functor, Show, Data, Generic, Hashable, FromJSON, ToJSON)
-
 type LocVar = Located Var
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs
@@ -93,9 +93,9 @@ pattern TPair t1 t2 = SPair (STerm t1) (STerm t2)
 
 -- | Match a TLam without annotations.
 pattern TLam :: Var -> Maybe Type -> Term -> Term
-pattern TLam v ty t <- SLam (lvVar -> v) ty (STerm t)
+pattern TLam v ty t <- SLam (locVal -> v) ty (STerm t)
   where
-    TLam v ty t = SLam (LV NoLoc v) ty (STerm t)
+    TLam v ty t = SLam (Loc NoLoc v) ty (STerm t)
 
 -- | Match a TApp without annotations.
 pattern TApp :: Term -> Term -> Term
@@ -109,21 +109,21 @@ pattern (:$:) t1 s2 = SApp (STerm t1) s2
 
 -- | Match a TLet without annotations.
 pattern TLet :: LetSyntax -> Bool -> Var -> Maybe RawPolytype -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term
-pattern TLet ls r v mty mpty mreq t1 t2 <- SLet ls r (lvVar -> v) mty mpty mreq (STerm t1) (STerm t2)
+pattern TLet ls r v mty mpty mreq t1 t2 <- SLet ls r (locVal -> v) mty mpty mreq (STerm t1) (STerm t2)
   where
-    TLet ls r v mty mpty mreq t1 t2 = SLet ls r (LV NoLoc v) mty mpty mreq (STerm t1) (STerm t2)
+    TLet ls r v mty mpty mreq t1 t2 = SLet ls r (Loc NoLoc v) mty mpty mreq (STerm t1) (STerm t2)
 
 -- | Match a STydef without annotations.
 pattern TTydef :: TDVar -> Polytype -> Maybe TydefInfo -> Term -> Term
-pattern TTydef v ty mtd t1 <- STydef (lvVar -> v) ty mtd (STerm t1)
+pattern TTydef v ty mtd t1 <- STydef (locVal -> v) ty mtd (STerm t1)
   where
-    TTydef v ty mtd t1 = STydef (LV NoLoc v) ty mtd (STerm t1)
+    TTydef v ty mtd t1 = STydef (Loc NoLoc v) ty mtd (STerm t1)
 
 -- | Match a TBind without annotations.
 pattern TBind :: Maybe Var -> Maybe Polytype -> Maybe Requirements -> Term -> Term -> Term
-pattern TBind mv mty mreq t1 t2 <- SBind (fmap lvVar -> mv) _ mty mreq (STerm t1) (STerm t2)
+pattern TBind mv mty mreq t1 t2 <- SBind (fmap locVal -> mv) _ mty mreq (STerm t1) (STerm t2)
   where
-    TBind mv mty mreq t1 t2 = SBind (LV NoLoc <$> mv) Nothing mty mreq (STerm t1) (STerm t2)
+    TBind mv mty mreq t1 t2 = SBind (Loc NoLoc <$> mv) Nothing mty mreq (STerm t1) (STerm t2)
 
 -- | Match a TDelay without annotations.
 pattern TDelay :: Term -> Term
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs b/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs
@@ -110,18 +110,18 @@ instance PrettyPrec (Term' ty) where
               ConstMUnOp S -> pparens (p > pC) $ prettyPrec (succ pC) t2 <> ppr t1
               _ -> prettyPrecApp p t1 t2
       _ -> prettyPrecApp p t1 t2
-    SLet LSLet _ (LV _ x) mty _ _ t1 t2 ->
+    SLet LSLet _ (Loc _ x) mty _ _ t1 t2 ->
       sep
         [ prettyDefinition "let" x mty t1 <+> "in"
         , ppr t2
         ]
-    SLet LSDef _ (LV _ x) mty _ _ t1 t2 ->
+    SLet LSDef _ (Loc _ x) mty _ _ t1 t2 ->
       mconcat $
         sep [prettyDefinition "def" x mty t1, "end"]
           : case t2 of
             Syntax' _ (TConst Noop) _ _ -> []
             _ -> [hardline, hardline, ppr t2]
-    STydef (LV _ x) pty _ t1 ->
+    STydef (Loc _ x) pty _ t1 ->
       mconcat $
         prettyTydef x pty
           : case t1 of
@@ -130,10 +130,10 @@ instance PrettyPrec (Term' ty) where
     SBind Nothing _ _ _ t1 t2 ->
       pparens (p > 0) $
         prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2
-    SBind (Just (LV _ x)) _ _ _ t1 t2 ->
+    SBind (Just (Loc _ x)) _ _ _ t1 t2 ->
       pparens (p > 0) $
         ppr x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2
-    SRcd m -> brackets $ hsep (punctuate "," (map (prettyEquality . first lvVar) m))
+    SRcd m -> brackets $ hsep (punctuate "," (map (prettyEquality . first locVal) m))
     SProj t x -> prettyPrec 11 t <> "." <> ppr x
     SAnnotate t pt ->
       pparens (p > 0) $
@@ -181,7 +181,7 @@ unchainLambdas :: Syntax' ty -> (Syntax' ty, [(Var, Maybe Type)])
 unchainLambdas = \case
   -- Peel off consecutive lambdas, being sure to accumulate any
   -- attached comments along the way so they attach to the body
-  Syntax' _ (SLam (LV _ x) mty body) coms _ -> ((x, mty) :) <$> unchainLambdas (body & sComments <>~ coms)
+  Syntax' _ (SLam (Loc _ x) mty body) coms _ -> ((x, mty) :) <$> unchainLambdas (body & sComments <>~ coms)
   body -> (body, [])
 
 prettyLambda :: (PrettyPrec a1, PrettyPrec a2) => (a1, Maybe a2) -> Doc ann
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Util.hs b/src/swarm-lang/Swarm/Language/Syntax/Util.hs
@@ -138,14 +138,14 @@ freeVarsS f = go S.empty
     TVar x
       | x `S.member` bound -> pure s
       | otherwise -> f s
-    SLam x xty s1 -> rewrap $ SLam x xty <$> go (S.insert (lvVar x) bound) s1
+    SLam x xty s1 -> rewrap $ SLam x xty <$> go (S.insert (locVal x) bound) s1
     SApp s1 s2 -> rewrap $ SApp <$> go bound s1 <*> go bound s2
     SLet ls r x xty xpty xreq s1 s2 ->
-      let bound' = S.insert (lvVar x) bound
+      let bound' = S.insert (locVal x) bound
        in rewrap $ SLet ls r x xty xpty xreq <$> go bound' s1 <*> go bound' s2
     STydef x xdef tdInfo t1 -> rewrap $ STydef x xdef tdInfo <$> go bound t1
     SPair s1 s2 -> rewrap $ SPair <$> go bound s1 <*> go bound s2
-    SBind mx mty mpty mreq s1 s2 -> rewrap $ SBind mx mty mpty mreq <$> go bound s1 <*> go (maybe id (S.insert . lvVar) mx bound) s2
+    SBind mx mty mpty mreq s1 s2 -> rewrap $ SBind mx mty mpty mreq <$> go bound s1 <*> go (maybe id (S.insert . locVal) mx bound) s2
     SDelay s1 -> rewrap $ SDelay <$> go bound s1
     SRcd m -> rewrap $ SRcd <$> (traverse . traverse . traverse) (go bound) m
     SProj s1 x -> rewrap $ SProj <$> go bound s1 <*> pure x
@@ -194,4 +194,4 @@ isNoop = \case
   _ -> False
 
 locVarToSyntax' :: LocVar -> ty -> Syntax' ty
-locVarToSyntax' (LV s v) = Syntax' s (TVar v) Empty
+locVarToSyntax' (Loc s v) = Syntax' s (TVar v) Empty
diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs
diff --git a/src/swarm-lang/Swarm/Language/Value.hs b/src/swarm-lang/Swarm/Language/Value.hs
diff --git a/test/unit/TestLSP.hs b/test/unit/TestLSP.hs
