Change SRcd to contain a list of tuples instead of a Map (#2584)

byorgey · web-flow · commit c8f2b7b098f6 · 2025-10-05T21:14:39.000Z
It makes sense for, say, a record type to consist of a `Map` from field names to types. However, we were also storing record literal AST nodes using a `Map`, but after a question from @oliverpauffley I realized this is probably not the right thing to do. For one thing, the AST should store the fields in the same order as they were written (otherwise pretty-printing would always sort record fields alphabetically). For another, the field names should be stored as `LocVar`s, not just `Var`s, so we know where they were in the source.
diff --git a/data/test/language-snippets/format/record-nosort.sw b/data/test/language-snippets/format/record-nosort.sw
@@ -0,0 +1,3 @@
+// Test that record literals are pretty-printed with fields in the
+// same order they were written
+([x = 3, y = 5], [y = 3, x = 5])
diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs
@@ -42,6 +42,7 @@ import Control.Effect.Lens
 import Control.Effect.Lift
 import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
 import Control.Monad (foldM, forM_, unless, when)
+import Data.Bifunctor (first)
 import Data.Foldable.Extra (notNull)
 import Data.Functor (void)
 import Data.IntMap qualified as IM
@@ -659,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 M.assocs m of
+  In (TRcd m) e s k -> return $ case map (first lvVar) 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
@@ -24,8 +24,7 @@ import Data.Foldable (asum)
 import Data.Graph
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NE
-import Data.Map qualified as M
-import Data.Maybe (catMaybes, fromMaybe, isNothing)
+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Data.Text.Lines qualified as R
@@ -124,7 +123,7 @@ pathToPosition s0 pos = s0 :| fromMaybe [] (innerPath s0)
     STydef typ typBody _ti s1 -> d s1 <|> Just [locVarToSyntax' (tdVarName <$> typ) $ fromPoly typBody]
     SPair s1 s2 -> d s1 <|> d s2
     SDelay s -> d s
-    SRcd m -> asum . map d . catMaybes . M.elems $ m
+    SRcd m -> asum . map d . mapMaybe snd $ m
     SProj s1 _ -> d s1
     SAnnotate s _ -> d s
     SRequirements _ s -> d s
diff --git a/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs b/src/swarm-lang/Swarm/Language/LSP/VarUsage.hs
@@ -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 -> M.foldMapWithKey (\x -> maybe (getUsage bindings (STerm (TVar x))) (getUsage bindings)) m
+  SRcd m -> foldMap (\(LV _ 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/Record.hs b/src/swarm-lang/Swarm/Language/Parser/Record.hs
@@ -8,11 +8,9 @@ module Swarm.Language.Parser.Record (
   parseRecord,
 ) where
 
-import Data.Map (Map)
-import Data.Map qualified as M
 import Swarm.Language.Parser.Core (Parser)
-import Swarm.Language.Parser.Lex (symbol, tmVar)
-import Swarm.Language.Var (Var)
+import Swarm.Language.Parser.Lex (locTmVar, symbol)
+import Swarm.Language.Syntax.Loc (LocVar, lvVar)
 import Swarm.Util (failT, findDup, squote)
 import Text.Megaparsec (sepBy)
 
@@ -22,10 +20,10 @@ import Text.Megaparsec (sepBy)
 --
 --   The @Parser a@ argument is the parser to use for the RHS of each
 --   binding in the record.
-parseRecord :: Parser a -> Parser (Map Var a)
+parseRecord :: Parser a -> Parser [(LocVar, a)]
 parseRecord p = (parseBinding `sepBy` symbol ",") >>= fromListUnique
  where
-  parseBinding = (,) <$> tmVar <*> p
-  fromListUnique kvs = case findDup (map fst kvs) of
-    Nothing -> return $ M.fromList kvs
+  parseBinding = (,) <$> locTmVar <*> p
+  fromListUnique kvs = case findDup (map (lvVar . 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/Type.hs b/src/swarm-lang/Swarm/Language/Parser/Type.hs
@@ -15,8 +15,10 @@ module Swarm.Language.Parser.Type (
 
 import Control.Monad.Combinators (many)
 import Control.Monad.Combinators.Expr (Operator (..), makeExprParser)
+import Data.Bifunctor (first)
 import Data.Fix (Fix (..), foldFix)
 import Data.List.Extra (enumerate)
+import Data.Map.Strict qualified as M
 import Data.Maybe (fromMaybe)
 import Swarm.Language.Parser.Core (Parser)
 import Swarm.Language.Parser.Lex (
@@ -30,6 +32,7 @@ import Swarm.Language.Parser.Lex (
   tyVar,
  )
 import Swarm.Language.Parser.Record (parseRecord)
+import Swarm.Language.Syntax.Loc (lvVar)
 import Swarm.Language.Types
 import Text.Megaparsec (choice, optional, some, (<|>))
 
@@ -70,7 +73,7 @@ parseTypeAtom =
   TyVar <$> tyVar
     <|> TyConApp <$> parseTyCon <*> pure []
     <|> TyDelay <$> braces parseType
-    <|> TyRcd <$> brackets (parseRecord (symbol ":" *> parseType))
+    <|> TyRcd <$> brackets (M.fromList . (map . first) lvVar <$> parseRecord (symbol ":" *> parseType))
     <|> tyRec <$> (reserved "rec" *> tyVar) <*> (symbol "." *> parseType)
     <|> parens parseType
 
diff --git a/src/swarm-lang/Swarm/Language/Parser/Value.hs b/src/swarm-lang/Swarm/Language/Parser/Value.hs
@@ -9,7 +9,9 @@
 module Swarm.Language.Parser.Value (readValue) where
 
 import Control.Lens ((^.))
+import Data.Bifunctor (first)
 import Data.Either.Extra (eitherToMaybe)
+import Data.Map.Strict qualified as M
 import Data.Text (Text)
 import Data.Text qualified as T
 import Swarm.Language.Context qualified as Ctx
@@ -60,7 +62,7 @@ toValue = \case
       VKey <$> eitherToMaybe (MP.runParser parseKeyComboFull "" k)
     _ -> Nothing
   TPair t1 t2 -> VPair <$> toValue t1 <*> toValue t2
-  TRcd m -> VRcd <$> traverse (>>= toValue) m
+  TRcd m -> VRcd . M.fromList <$> traverse (traverse (>>= toValue) . first lvVar) 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/Requirements/Analysis.hs b/src/swarm-lang/Swarm/Language/Requirements/Analysis.hs
@@ -20,7 +20,6 @@ import Control.Effect.Reader (Reader, ask, local)
 import Control.Monad (when)
 import Data.Fix (Fix (..))
 import Data.Foldable (forM_)
-import Data.Map qualified as M
 import Swarm.Language.Capability (Capability (..), constCaps)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Requirements.Type
@@ -156,9 +155,9 @@ requirements tdCtx ctx =
     -- Everything else is straightforward.
     TPair t1 t2 -> add (singletonCap CProd) *> go t1 *> go t2
     TDelay t -> go t
-    TRcd m -> add (singletonCap CRecord) *> forM_ (M.assocs m) (go . expandEq)
+    TRcd m -> add (singletonCap CRecord) *> forM_ m (go . expandEq)
      where
-      expandEq (x, Nothing) = TVar x
+      expandEq (LV _ 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/AST.hs b/src/swarm-lang/Swarm/Language/Syntax/AST.hs
@@ -17,7 +17,6 @@ import Data.Aeson.Types hiding (Key)
 import Data.Data (Data)
 import Data.Data.Lens (uniplate)
 import Data.Hashable (Hashable)
-import Data.Map.Strict (Map)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Swarm.Language.Requirements.Type (Requirements)
@@ -137,7 +136,7 @@ data Term' ty
   | -- | Record literals @[x1 = e1, x2 = e2, x3, ...]@ Names @x@
     --   without an accompanying definition are sugar for writing
     --   @x=x@.
-    SRcd (Map Var (Maybe (Syntax' ty)))
+    SRcd [(LocVar, Maybe (Syntax' ty))]
   | -- | Record projection @e.x@
     SProj (Syntax' ty) Var
   | -- | Annotate a term with a type
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs b/src/swarm-lang/Swarm/Language/Syntax/Pattern.hs
@@ -38,7 +38,7 @@ module Swarm.Language.Syntax.Pattern (
 ) where
 
 import Control.Lens (makeLenses, pattern Empty)
-import Data.Map.Strict (Map)
+import Data.Bifunctor (second)
 import Data.Text (Text)
 import Swarm.Language.Requirements.Type (Requirements)
 import Swarm.Language.Syntax.AST
@@ -130,10 +130,10 @@ pattern TDelay :: Term -> Term
 pattern TDelay t = SDelay (STerm t)
 
 -- | Match a TRcd without annotations.
-pattern TRcd :: Map Var (Maybe Term) -> Term
-pattern TRcd m <- SRcd ((fmap . fmap) _sTerm -> m)
+pattern TRcd :: [(LocVar, Maybe Term)] -> Term
+pattern TRcd m <- SRcd ((map . second . fmap) _sTerm -> m)
   where
-    TRcd m = SRcd ((fmap . fmap) STerm m)
+    TRcd m = SRcd ((map . second . fmap) STerm m)
 
 pattern TProj :: Term -> Var -> Term
 pattern TProj t x = SProj (STerm t) x
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs b/src/swarm-lang/Swarm/Language/Syntax/Pretty.hs
@@ -22,9 +22,9 @@ module Swarm.Language.Syntax.Pretty (
 
 import Control.Lens ((&), (<>~))
 import Control.Lens.Empty (pattern Empty)
+import Data.Bifunctor (first)
 import Data.Bool (bool)
 import Data.Foldable qualified as F
-import Data.Map qualified as M
 import Data.Sequence qualified as Seq
 import Data.String (fromString)
 import Prettyprinter
@@ -133,7 +133,7 @@ instance PrettyPrec (Term' ty) where
     SBind (Just (LV _ x)) _ _ _ t1 t2 ->
       pparens (p > 0) $
         ppr x <+> "<-" <+> prettyPrec 1 t1 <> ";" <> line <> prettyPrec 0 t2
-    SRcd m -> brackets $ hsep (punctuate "," (map prettyEquality (M.assocs m)))
+    SRcd m -> brackets $ hsep (punctuate "," (map (prettyEquality . first lvVar) m))
     SProj t x -> prettyPrec 11 t <> "." <> ppr x
     SAnnotate t pt ->
       pparens (p > 0) $
diff --git a/src/swarm-lang/Swarm/Language/Syntax/Util.hs b/src/swarm-lang/Swarm/Language/Syntax/Util.hs
@@ -147,7 +147,7 @@ freeVarsS f = go S.empty
     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
     SDelay s1 -> rewrap $ SDelay <$> go bound s1
-    SRcd m -> rewrap $ SRcd <$> (traverse . traverse) (go bound) m
+    SRcd m -> rewrap $ SRcd <$> (traverse . traverse . traverse) (go bound) m
     SProj s1 x -> rewrap $ SProj <$> go bound s1 <*> pure x
     SAnnotate s1 pty -> rewrap $ SAnnotate <$> go bound s1 <*> pure pty
     SSuspend s1 -> rewrap $ SSuspend <$> go bound s1
diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs
@@ -59,6 +59,7 @@ import Control.Lens (view, (^.))
 import Control.Lens.Indexed (itraverse)
 import Control.Monad (forM, forM_, void, when, (<=<), (>=>))
 import Control.Monad.Free qualified as Free
+import Data.Bifunctor (first, second)
 import Data.Data (Data, gmapM)
 import Data.Foldable (fold)
 import Data.Functor.Identity
@@ -998,8 +999,9 @@ infer s@(CSyntax l t cs) = addLocToTypeErr l $ case t of
 
   -- See Note [Checking and inference for record literals]
   SRcd m -> do
-    m' <- itraverse (\x -> infer . fromMaybe (STerm (TVar x))) m
-    return $ Syntax' l (SRcd (Just <$> m')) cs (UTyRcd (fmap (^. sType) m'))
+    m' <- traverse (itraverse $ \x -> infer . fromMaybe (STerm (TVar (lvVar x)))) m
+    let rcdTy = M.fromList $ map (lvVar *** (^. sType)) m'
+    return $ Syntax' l (SRcd ((map . second) Just m')) cs (UTyRcd rcdTy)
 
   -- Once we're typechecking, we don't need to keep around explicit
   -- parens any more
@@ -1321,18 +1323,21 @@ check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of
   -- for record literals].
   SRcd fields
     | UTyRcd tyMap <- expected -> do
-        let expectedFields = M.keysSet tyMap
-            actualFields = M.keysSet fields
+        let fieldMap = M.fromList $ map (first lvVar) fields
+            expectedFields = M.keysSet tyMap
+            actualFields = M.keysSet fieldMap
         when (actualFields /= expectedFields) $
           throwTypeErr l $
             FieldsMismatch (joined expectedFields actualFields)
-        m' <-
-          itraverse
-            (\x (ms, ty) -> check (fromMaybe (STerm (TVar x)) ms) ty)
-            -- Since we checked above that 'fields' and 'tyMap' have the
-            -- same keys, intersectionWith is really just a zip.
-            (M.intersectionWith (,) fields tyMap)
-        return $ Syntax' l (SRcd (Just <$> m')) cs expected
+        -- Since we checked above that 'fields' and 'tyMap' have the
+        -- same keys, we know this lookup into the tyMap will never fail;
+        -- however, we still use lookup + mapMaybe to avoid partial functions.
+        let fieldsWithTypes = mapMaybe (\(x, mt) -> (x,mt,) <$> M.lookup (lvVar x) tyMap) fields
+        fields' <-
+          traverse
+            (\(x, mt, ty) -> (x,) . Just <$> check (fromMaybe (STerm (TVar (lvVar x))) mt) ty)
+            fieldsWithTypes
+        return $ Syntax' l (SRcd fields') cs expected
 
   -- The type of @suspend t@ is @Cmd T@ if @t : T@.
   SSuspend s1 -> do
@@ -1349,17 +1354,18 @@ check s@(CSyntax l t cs) expected = addLocToTypeErr l $ case t of
 -- ~~~~ Note [Checking and inference for record literals]
 --
 -- We need to handle record literals in both inference and checking
--- mode.  By way of contrast, with a pair, if we are in checking
--- mode and the expected type is not manifestly a product type, we
--- can just generate fresh unification variables for the types of
--- the two components, generate a constraint that the expected type
--- is equal to a product type of these two fresh types, and continue
--- in checking mode on both sides.  With records, however, we cannot
--- do that; if we are checking a record and the expected type is not
--- manifestly a record type, we must simply switch into inference
--- mode.  However, it is still helpful to be able to handle records
--- in checking mode too, since if we know a record type it is
--- helpful to be able to push the field types down into the fields.
+-- mode.  By way of contrast, with a pair, if we are in checking mode
+-- and the expected type is not manifestly a product type, we can just
+-- generate fresh unification variables for the types of the two
+-- components, generate a constraint that the expected type is equal
+-- to a product type of these two fresh types, and continue in
+-- checking mode on both sides.  With records, however, we cannot do
+-- that, since we don't know what field names to generate. If we are
+-- checking a record and the expected type is not manifestly a record
+-- type, we must simply switch into inference mode.  However, it is
+-- still helpful to be able to handle records in checking mode too,
+-- since if we know a record type it is helpful to be able to push the
+-- field types down into the fields.
 
 ------------------------------------------------------------
 -- Special atomic checking
@@ -1453,17 +1459,17 @@ analyzeAtomic locals (Syntax l t) = case t of
   -- Bind is similarly simple except that we have to keep track of a local variable
   -- bound in the RHS.
   SBind mx _ _ _ s1 s2 -> (+) <$> analyzeAtomic locals s1 <*> analyzeAtomic (maybe id (S.insert . lvVar) mx locals) s2
-  SRcd m -> sum <$> mapM analyzeField (M.assocs m)
+  SRcd m -> sum <$> mapM analyzeField m
    where
     analyzeField ::
       ( Has (Reader UCtx) sig m
       , Has (Reader TCStack) sig m
       , Has Unification sig m
       , Has (Throw ContextualTypeErr) sig m
       ) =>
-      (Var, Maybe Syntax) ->
+      (LocVar, Maybe Syntax) ->
       m Int
-    analyzeField (x, Nothing) = analyzeAtomic locals (STerm (TVar x))
+    analyzeField (LV _ x, Nothing) = analyzeAtomic locals (STerm (TVar x))
     analyzeField (_, Just s) = analyzeAtomic locals s
   SProj {} -> return 0
   -- Variables are allowed if bound locally, or if they have a simple type.
diff --git a/src/swarm-lang/Swarm/Language/Value.hs b/src/swarm-lang/Swarm/Language/Value.hs
@@ -251,7 +251,7 @@ valueToTerm = \case
   VDelay t _ -> TDelay t
   VRef n -> TRef n
   VIndir n -> TRef n
-  VRcd m -> TRcd (Just . valueToTerm <$> m)
+  VRcd m -> TRcd (map (bimap (LV NoLoc) (Just . valueToTerm)) $ M.assocs m)
   VKey kc -> TApp (TConst Key) (TText (prettyKeyCombo kc))
   VRequirements x t _ -> TRequirements x t
   VSuspend t _ -> TSuspend t

Original file line number	Diff line number	Diff line change
`@@ -0,0 +1,3 @@`
	`1`	`+// Test that record literals are pretty-printed with fields in the`
	`2`	`+// same order they were written`
	`3`	`+([x = 3, y = 5], [y = 3, x = 5])`