Carry metadata across vertex trees

examples/regression_jbeam/metadata-across-trees-repro.jbeam

@@ -0,0 +1,40 @@
+{
+"testpart":{
+    "nodes":[
+        ["id", "posX", "posY", "posZ"],
+        // Synthetic regression-test fixture for issue #221, not vetted by
+        // the jbeam maintainer and not intended as a demo/example.
+        // Real node positions from a gen4-style body file, both sides kept.
+        //
+        // The leading metadata row plus the alternating nl/nr prefixes are
+        // what matter here. breakVertices splits on prefix, so alternating
+        // names put every vertex in a chunk of its own and only nl0, the
+        // one sharing a chunk with the metadata row, ends up with a
+        // non-empty aMeta. examples/jbeam/frame.jbeam cannot stand in for
+        // this: it names both sides rl_f, so its vertices share one chunk.
+        {"nodeWeight":0.78},
+        ["nl0", 0.953, -1.967, 0.122],
+        ["nr1", -0.877, -1.967, 0.122],
+        ["nl2", 0.92, -1.953, 0.439],
+        ["nr3", -0.845, -1.953, 0.439],
+        ["nl4", 0.78, -1.815, 0.719],
+        ["nr5", -0.704, -1.815, 0.719],
+        ["nl6", 1.036, -1.807, 0.125],
+        ["nr7", -0.961, -1.807, 0.125],
+        ["nl8", 0.998, -1.791, 0.473],
+        ["nr9", -0.922, -1.791, 0.473],
+        ["nl10", 0.944, -1.644, 0.72],
+        ["nr11", -0.869, -1.644, 0.72],
+        ["nl12", 0.823, -1.362, 0.841],
+        ["nr13", -0.747, -1.362, 0.841],
+        ["nl14", 0.952, -1.354, 0.772],
+        ["nr15", -0.876, -1.354, 0.772],
+    ],
+    "beams":[
+        ["id1:", "id2:"],
+    ],
+    "triangles":[
+        ["id1:", "id2:", "id3:"],
+    ],
+},
+}

src-extra/transformation/JbeamEdit/Transformation/VertexExtraction.hs

@@ -12,12 +12,13 @@ import Control.Monad.Except (runExcept)
 import Control.Monad.Trans.Except (except)
 import Data.Bifunctor (first)
 import Data.Char (isDigit)
+import Data.List (partition)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Map.Ordered (OMap)
-import Data.Maybe (isJust, isNothing, mapMaybe)
+import Data.Maybe (isJust, isNothing, listToMaybe, mapMaybe)
 import Data.Scientific (Scientific)
 import Data.Set (Set)
 import Data.Set qualified as S
@@ -93,8 +94,11 @@ isCollision vertexNode vertexNames =
         else Right (S.insert vertexName vertexNames)
     Nothing -> Right vertexNames
 
-maybeConsComment :: [Node] -> Maybe InternalComment -> [Node]
-maybeConsComment xs = maybe xs ((: xs) . Comment)
+takeTrailingAssocPriorCmt :: [Node] -> (Maybe Node, [Node], [Node])
+takeTrailingAssocPriorCmt acc = (listToMaybe assocPriorCmt, metaBefore, currentTree)
+  where
+    (nonVertices, currentTree) = span isNonVertex acc
+    (assocPriorCmt, metaBefore) = partition isPriorAssocCommentNode nonVertices
 
 breakVertices
   :: Maybe Text
@@ -110,19 +114,20 @@ breakVertices vertexPrefix allVertexNames ns = go [] ns allVertexNames
           || isNothing vertexPrefix && any isSupportVertex maybeVertex =
           isCollision node vertexNames >>= go (node : acc) rest
       | isJust maybeVertex =
-          let (assocPriorCmt, acc') = extractPreviousAssocCmt acc
-              (metaBefore, currentTree) = span isNonVertex acc'
+          let (assocPriorCmt, metaBefore, currentTree) = takeTrailingAssocPriorCmt acc
            in if null currentTree
                 then
                   Right
                     ( vertexNames
-                    , reverse (maybeConsComment [node] assocPriorCmt)
+                    , case assocPriorCmt of
+                        Just cmt -> [node, cmt]
+                        Nothing -> [node]
                     , reverse metaBefore ++ rest
                     )
                 else
                   Right
                     ( vertexNames
-                    , reverse (maybeConsComment currentTree assocPriorCmt)
+                    , reverse (maybe currentTree (: currentTree) assocPriorCmt)
                     , reverse metaBefore ++ (node : rest)
                     )
       | otherwise = go (node : acc) rest vertexNames
@@ -178,55 +183,66 @@ addCommentToAn ic (AnnotatedVertex comments vertex meta) = AnnotatedVertex (ic :
 nodesToAnnotatedVertices
   :: MetaMap
   -> [Node]
-  -> Either Text ([Node], NonEmpty AnnotatedVertex)
-nodesToAnnotatedVertices initialMeta nodes = go initialMeta [] nodes ([], [])
+  -> Either Text ([Node], NonEmpty AnnotatedVertex, MetaMap)
+nodesToAnnotatedVertices initialMeta nodes = go [] nodes ([], [], initialMeta)
   where
-    go _ _ [] (badNodes, acc) =
+    go _ [] (badNodes, acc, pendingMeta) =
       case reverse acc of
         [] -> Left "no vertices found"
-        revAcc -> Right (badNodes, fromList revAcc)
-    go pendingMeta pendingComments (n : ns) acc@(badNodes, vertices) =
+        revAcc -> Right (badNodes, fromList revAcc, pendingMeta)
+    go pendingComments (n : ns) acc@(badNodes, vertices, pendingMeta) =
       case newVertex n of
         Just v ->
           let av = AnnotatedVertex (reverse pendingComments) v pendingMeta
-           in go pendingMeta [] ns (badNodes, av : vertices)
+           in go [] ns (badNodes, av : vertices, pendingMeta)
         Nothing
           | isObjectNode n ->
               let newMeta = M.union (metaMapFromObject n) pendingMeta
-               in go newMeta pendingComments ns acc
+               in go pendingComments ns (badNodes, vertices, newMeta)
           | isCommentNode n ->
               case (toInternalComment n, acc) of
-                (Just ic@(InternalComment _ _ PreviousNode _), (_, an : ans)) ->
-                  go pendingMeta pendingComments ns (badNodes, addCommentToAn ic an : ans)
+                (Just ic@(InternalComment _ _ PreviousNode _), (_, an : ans, _)) ->
+                  go pendingComments ns (badNodes, addCommentToAn ic an : ans, pendingMeta)
                 (Just ic, _) ->
-                  go pendingMeta (ic : pendingComments) ns acc
+                  go (ic : pendingComments) ns acc
                 (Nothing, _) ->
-                  go pendingMeta pendingComments ns acc
-          | otherwise -> go pendingMeta pendingComments ns (n : badNodes, vertices)
+                  go pendingComments ns acc
+          | otherwise -> go pendingComments ns (n : badNodes, vertices, pendingMeta)
 
 newVertexTree
   :: XGroupBreakpoints
   -> Set Text
   -> [Node]
+  -> MetaMap
   -> VertexForest
   -> NonEmpty Node
-  -> Either Text (Set Text, [Node], VertexTreeType, VertexTree, VertexForest, [Node])
-newVertexTree brks vertexNames badAcc vertexForest nodes =
+  -> Either
+       Text
+       (Set Text, [Node], MetaMap, VertexTreeType, VertexTree, VertexForest, [Node])
+newVertexTree brks vertexNames badAcc startingMeta vertexForest nodes =
   let (topNodes, nodes') = NE.span isNonVertex nodes
       topComments = mapMaybe toInternalComment topNodes
-      topMeta = M.unions . map metaMapFromObject $ topNodes
+      topMeta = foldr (M.union . metaMapFromObject) startingMeta topNodes
       vertexPrefix = getVertexPrefix' nodes'
    in runExcept
         ( do
             (vertexNames', vertexNodes, rest') <-
               except (breakVertices vertexPrefix vertexNames nodes')
-            (badNodes, avNE) <- except (nodesToAnnotatedVertices topMeta vertexNodes)
+            (badNodes, avNE, finalMetaMap) <-
+              except (nodesToAnnotatedVertices topMeta vertexNodes)
             let firstAV = NE.head avNE
                 vertexTree = VertexTree topComments avNE
             treeType <- except . determineGroup brks . aVertex $ firstAV
             let updatedForest = insertTreeInForest treeType vertexTree vertexForest
             pure
-              (vertexNames', badAcc <> badNodes, treeType, vertexTree, updatedForest, rest')
+              ( vertexNames'
+              , badAcc <> badNodes
+              , finalMetaMap
+              , treeType
+              , vertexTree
+              , updatedForest
+              , rest'
+              )
         )
 
 determineGroup :: XGroupBreakpoints -> Vertex -> Either Text VertexTreeType
@@ -245,21 +261,28 @@ nodesListToTree
   -> NonEmpty Node
   -> Either Text ([Node], VertexTreeType, VertexForest)
 nodesListToTree brks nodes =
-  case newVertexTree brks S.empty [] M.empty nodes of
+  case newVertexTree brks S.empty [] M.empty M.empty nodes of
     Left err -> Left err
     Right
-      (vertexNames, badNodes, firstTreeType, _firstVertexTree, vertexForest, rest) ->
+      ( vertexNames
+        , badNodes
+        , metaMap
+        , firstTreeType
+        , _firstVertexTree
+        , vertexForest
+        , rest
+        ) ->
         case NE.nonEmpty rest of
           Nothing -> Right (badNodes, firstTreeType, vertexForest)
-          Just nonEmptyRest -> go vertexNames badNodes vertexForest nonEmptyRest firstTreeType
+          Just nonEmptyRest -> go vertexNames badNodes metaMap vertexForest nonEmptyRest firstTreeType
   where
-    go vertexNames badNodes acc rest firstTreeType =
-      case newVertexTree brks vertexNames badNodes acc rest of
+    go vertexNames badNodes metaMap acc rest firstTreeType =
+      case newVertexTree brks vertexNames badNodes metaMap acc rest of
         Left err -> Left err
-        Right (vertexNames', badNodes', _treeType, _vt, acc', rest') ->
+        Right (vertexNames', badNodes', metaFromTree, _treeType, _vt, acc', rest') ->
           case NE.nonEmpty rest' of
-            Nothing -> Right (badNodes, firstTreeType, acc')
-            Just ne -> go vertexNames' (badNodes ++ badNodes') acc' ne firstTreeType
+            Nothing -> Right (badNodes', firstTreeType, acc')
+            Just ne -> go vertexNames' badNodes' metaFromTree acc' ne firstTreeType
 
 objectKeysToObjects :: Map Text Node -> [Node]
 objectKeysToObjects =

src/JbeamEdit/Core/Node.hs

@@ -8,8 +8,8 @@ module JbeamEdit.Core.Node (
   maybeObjectKey,
   isSinglelineComment,
   commentIsAttachedToPreviousNode,
+  isPriorAssocCommentNode,
   isComplexNode,
-  extractPreviousAssocCmt,
   possiblyChildren,
   numberValueToScientific,
   scientificToText,
@@ -101,13 +101,6 @@ data Node
 commentIsAttachedToPreviousNode :: InternalComment -> Bool
 commentIsAttachedToPreviousNode = (==) PreviousNode . cAssociationDirection
 
-extractPreviousAssocCmt
-  :: [Node]
-  -> (Maybe InternalComment, [Node])
-extractPreviousAssocCmt (Comment cmt : ns)
-  | commentIsAttachedToPreviousNode cmt = (Just cmt, ns)
-extractPreviousAssocCmt ns = (Nothing, ns)
-
 maybeObjectKey :: Node -> Maybe Text
 maybeObjectKey (ObjectKey (String key, _)) = Just key
 maybeObjectKey _ = Nothing
@@ -153,6 +146,10 @@ isNumberNode :: Node -> Bool
 isNumberNode (Number _) = True
 isNumberNode _ = False
 
+isPriorAssocCommentNode :: Node -> Bool
+isPriorAssocCommentNode (Comment cmt) = commentIsAttachedToPreviousNode cmt
+isPriorAssocCommentNode _ = False
+
 numberValueToScientific :: NumberValue -> Scientific
 numberValueToScientific = nvValue
 

test-extra/transformation/Spec.hs

@@ -4,7 +4,7 @@ module Spec (
 
 import Data.ByteString.Lazy qualified as LBS
 import Data.Char (isDigit)
-import Data.List (isInfixOf, isPrefixOf, isSuffixOf)
+import Data.List (isPrefixOf, isSuffixOf)
 import Data.Map qualified as M
 import Data.Set (Set)
 import Data.Set qualified as S
@@ -82,11 +82,7 @@ fixedPointSpec rs cfName tfConfig outFilename = do
             case transform M.empty tfConfig node of
               Left err -> expectationFailure ("transform failed: " ++ T.unpack err)
               Right (_, _, _, again) -> formatNode rs again `shouldBe` expected
-  describe desc . it "works" $
-    if "suspension" `isInfixOf` outFilename
-      then
-        pendingWith "metadata is not carried across vertex tree boundaries, issue #221"
-      else check
+  describe desc . it "works" $ check
 
 parseJbeamFile :: FilePath -> IO Node
 parseJbeamFile path = do
@@ -223,6 +219,26 @@ supportRenameIdempotencySpec =
               once `shouldNotBe` []
               vertexPositionsInOrder twiceNode `shouldBe` once
 
+{- | Y positions of vertex pairs a transform wrote out of order: a later
+vertex sitting more than the threshold further forward than an earlier
+one in the same output group. Only vertices within one group are
+compared (e.g. "nll", "nlm"): a Left-tree vertex and a Middle-tree
+vertex are unrelated blocks in the file, not a single ordered sequence,
+so their relative position isn't meaningful.
+-}
+outOfOrderPairs :: Double -> Node -> [(Double, Double)]
+outOfOrderPairs thr resultNode =
+  [ (y1, y2)
+  | ((n1, y1), i1) <- positions
+  , ((n2, y2), i2) <- positions
+  , i1 < i2
+  , groupPrefix n1 == groupPrefix n2
+  , y1 - y2 > thr
+  ]
+  where
+    positions = zip (vertexPositionsInOrder resultNode) [0 :: Int ..]
+    groupPrefix = T.dropWhileEnd isDigit
+
 {- | Real left-side structural node positions from a NASCAR gen4-style body
 file (see issue #214). This specific spacing reproduces a real transform
 run: with y-sorting-threshold 0.1, the frontmost node (nl0, Y=-1.967) ends
@@ -237,27 +253,37 @@ ySortingBandingSpec =
     . it
       "never places a node behind another node that is more than the threshold further forward"
     $ do
-      let thr = 0.1 :: Double
-          cfg = newTransformationConfig {ySortingThreshold = 0.1}
+      let cfg = newTransformationConfig {ySortingThreshold = 0.1}
       topNode <- parseJbeamFile ySortingReproFixture
       case transform M.empty cfg topNode of
+        Left err -> expectationFailure ("transform failed: " ++ T.unpack err)
+        Right (_, _, _, resultNode) -> outOfOrderPairs 0.1 resultNode `shouldBe` []
+
+{- | A metadata row ahead of the first vertex applies to the whole section,
+and the transform writes it back out at the top, so it says nothing about
+any individual vertex and must not decide where one is placed. It does
+today (issue #221): `newVertexTree` seeds each tree from its own leading
+block, and `breakVertices` splits on prefix, so alternating nl/nr names
+leave only the first vertex carrying the row. `compareAV` sorts on `aMeta`
+ahead of the Y band and an empty map sorts first, which drops that one
+vertex at the end of its group while its mirror on the other side stays
+in front.
+-}
+metadataAcrossTreesFixture :: FilePath
+metadataAcrossTreesFixture =
+  "examples/regression_jbeam/metadata-across-trees-repro.jbeam"
+
+metadataAcrossTreesSpec :: Spec
+metadataAcrossTreesSpec =
+  describe "metadata ahead of the first vertex"
+    . it "does not decide where a vertex is placed"
+    $ do
+      topNode <- parseJbeamFile metadataAcrossTreesFixture
+      case transform M.empty newTransformationConfig topNode of
         Left err -> expectationFailure ("transform failed: " ++ T.unpack err)
         Right (_, _, _, resultNode) -> do
-          let positions = zip (vertexPositionsInOrder resultNode) [0 :: Int ..]
-              groupPrefix = T.dropWhileEnd isDigit
-              -- Only compare nodes within the same output group (e.g.
-              -- "nll", "nlm"): a Left-tree node and a Middle-tree node
-              -- are unrelated blocks in the file, not a single ordered
-              -- sequence, so their relative position isn't meaningful.
-              outOfOrder =
-                [ (y1, y2)
-                | ((n1, y1), i1) <- positions
-                , ((n2, y2), i2) <- positions
-                , i1 < i2
-                , groupPrefix n1 == groupPrefix n2
-                , y1 - y2 > thr
-                ]
-          outOfOrder `shouldBe` []
+          vertexPositionsInOrder resultNode `shouldNotBe` []
+          outOfOrderPairs 0.05 resultNode `shouldBe` []
 
 main :: IO ()
 main = hspec $ do
@@ -283,3 +309,4 @@ main = hspec $ do
   supportRenameIdempotencySpec
   letterEndingNodesSpec
   ySortingBandingSpec
+  metadataAcrossTreesSpec