From 06b690c5a18851c9f3dcf6a6e045f968e9a162de Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 03:39:33 +0200 Subject: [PATCH] merge mappings after merge key << --- app/Export.hs | 12 +++---- app/Index.hs | 22 ++++++------- app/Workflow.hs | 84 +++++++++++++++++++++++------------------------ app/YamlParser.hs | 49 ++++++++++++++++++--------- 4 files changed, 92 insertions(+), 75 deletions(-) diff --git a/app/Export.hs b/app/Export.hs index e2894b7..090c6a3 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -35,12 +35,12 @@ module Export where "anchor" .= a, "position" .= p ] - toJSON (Mapping ct cm a p) = object [ - "content" .= ct, - "comment" .= cm, - "anchor" .= a, - "position" .= p - ] + toJSON (Mapping ct cm a md p) = object [ + "content" .= ct, + "comment" .= cm, + "anchor" .= a, + "position" .= p + ] toJSON (Sequence ch cm a p) = object [ "content" .= ch, "comment" .= cm, diff --git a/app/Index.hs b/app/Index.hs index dfac639..b73f3d7 100644 --- a/app/Index.hs +++ b/app/Index.hs @@ -25,13 +25,13 @@ module Index where } deriving Show instance FromYAML' Entry where - fromYAML (Mapping mapping _ _ _) = Entry - <$> mapping <| "graph-file" - <*> mapping <|? "category" - <*> mapping <|? "definition-scope" - <*> mapping <|? "definition-description" - <*> mapping <|? "instance-description" - <*> mapping <| "instances" + fromYAML (Mapping mapping _ _ _ _) = Entry + <$> mapping <| "graph-file" + <*> mapping <|? "category" + <*> mapping <|? "definition-scope" + <*> mapping <|? "definition-description" + <*> mapping <|? "instance-description" + <*> mapping <| "instances" -- parseJSON _ = error "Unexpected yaml" type Title = Text @@ -44,10 +44,10 @@ module Index where } deriving Show instance FromYAML' Description where - fromYAML (Mapping mapping _ _ _) = Description - <$> mapping <|? "fallback-lang" - <*> mapping <| "fallback" - <*> mapping <| "translations" + fromYAML (Mapping mapping _ _ _ _) = Description + <$> mapping <|? "fallback-lang" + <*> mapping <| "fallback" + <*> mapping <| "translations" english = "en-eu"; diff --git a/app/Workflow.hs b/app/Workflow.hs index 7fc8d1d..0446888 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -31,10 +31,10 @@ module Workflow where } deriving Show instance FromYAML' Workflow where - fromYAML (Mapping mapping _ anchor pos) = Workflow - <$> mapping <| "nodes" - <*> mapping <|? "stages" - <*> pure anchor + fromYAML (Mapping mapping _ anchor _ pos) = Workflow + <$> mapping <| "nodes" + <*> mapping <|? "stages" + <*> pure anchor -- | Structure of a node. @@ -49,14 +49,14 @@ module Workflow where } deriving Show instance FromYAML' State where - fromYAML (Mapping mapping comment anchor _) = State - <$> mapping <|? "viewers" - <*> mapping <|? "payload-view" - <*> mapping <|? "final" - <*> mapping <|? "edges" - <*> mapping <|? "messages" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = State + <$> mapping <|? "viewers" + <*> mapping <|? "payload-view" + <*> mapping <|? "final" + <*> mapping <|? "edges" + <*> mapping <|? "messages" + <*> pure comment + <*> pure anchor -- | Wrapper for the `final` value of any node. @@ -86,11 +86,11 @@ module Workflow where } deriving Show instance FromYAML' StateViewers where - fromYAML (Mapping mapping comment anchor _) = StateViewers - <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) - <*> mapping <|? "viewers" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = StateViewers + <$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label")) + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor data Viewers = Viewers { @@ -105,8 +105,8 @@ module Workflow where <*> pure comment <*> pure anchor where toV :: Map Text YAMLNode -> YAMLNode -> Map Text YAMLNode - toV m (Mapping [] _ _ _) = m - toV m (Mapping ((Scalar b _ _ _,v):xs) c a p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a p) + toV m (Mapping [] _ _ _ _) = m + toV m (Mapping ((Scalar b _ _ _,v):xs) c a md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p) @@ -120,12 +120,12 @@ module Workflow where } deriving Show instance FromYAML' Label where - fromYAML (Mapping mapping comment anchor _) = Label - <$> mapping <|? "fallback" - <*> mapping <|? "fallback-lang" - <*> mapping <|? "translations" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Label + <$> mapping <|? "fallback" + <*> mapping <|? "fallback-lang" + <*> mapping <|? "translations" + <*> pure comment + <*> pure anchor -- | Structure of an edge. @@ -143,17 +143,17 @@ module Workflow where } deriving Show instance FromYAML' Action where - fromYAML (Mapping mapping comment anchor _) = Action - <$> mapping <|? "mode" - <*> mapping <|? "source" - <*> mapping <|? "display-label" - <*> mapping <|? "actors" - <*> mapping <|? "view-actor" - <*> mapping <|? "viewers" - <*> mapping <|? "messages" - <*> mapping <|? "form" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Action + <$> mapping <|? "mode" + <*> mapping <|? "source" + <*> mapping <|? "display-label" + <*> mapping <|? "actors" + <*> mapping <|? "view-actor" + <*> mapping <|? "viewers" + <*> mapping <|? "messages" + <*> mapping <|? "form" + <*> pure comment + <*> pure anchor data Message = Message { content :: Label, @@ -164,12 +164,12 @@ module Workflow where } deriving Show instance FromYAML' Message where - fromYAML (Mapping mapping comment anchor _) = Message - <$> mapping <| "content" - <*> mapping <|? "status" - <*> mapping <|? "viewers" - <*> pure comment - <*> pure anchor + fromYAML (Mapping mapping comment anchor merge _) = Message + <$> mapping <| "content" + <*> mapping <|? "status" + <*> mapping <|? "viewers" + <*> pure comment + <*> pure anchor data Entry = Single Text diff --git a/app/YamlParser.hs b/app/YamlParser.hs index fa8694f..4a2543e 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -32,6 +32,7 @@ module YamlParser where } data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq) + data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq) data YAMLNode = @@ -46,13 +47,14 @@ module YamlParser where content :: [(YAMLNode, YAMLNode)], comment :: [Comment], anchorData :: AnchorData, + mergeData :: [MergeData], -- keys of the maps merged into this mapping by "<<" pos :: Pos } | Sequence { children :: [YAMLNode], comment :: [Comment], anchorData :: AnchorData, pos :: Pos - } deriving Show + } deriving (Show, Eq) type Comment = Text @@ -83,7 +85,7 @@ module YamlParser where showTrace (EvPos event pos) $ case event of Y.Comment _ -> parseComment es >>= parseNode Y.SequenceStart anchor _ _ -> parseSequence es' anchor [] >>= \(seq, es'') -> return (Just seq, es'') - Y.MappingStart anchor _ _ -> parseMapping es' anchor [] >>= \(map, es'') -> return (Just map, es'') + Y.MappingStart anchor _ _ -> parseMapping es' anchor [] [] >>= \(map, es'') -> return (Just map, es'') Y.Scalar anchor _ _ text -> parseScalar anchor text pos >>= \scal -> return (Just scal, es') Y.Alias anchor -> parseAlias anchor >>= \a -> return (Just a, es') _ -> return (Nothing, es) -- error $ "Unexpected event: " ++ show event ++ " @" ++ show (posLine pos) @@ -104,33 +106,48 @@ module YamlParser where Just c -> parseSequence es' anchor (c : children) - parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> State ParseState (YAMLNode, EvStream) - parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content = showTrace (EvPos MappingEnd pos) $ do + parseMapping :: EvStream -> Maybe Anchor -> [(YAMLNode, YAMLNode)] -> [MergeData] -> State ParseState (YAMLNode, EvStream) + parseMapping ((Right (EvPos MappingEnd pos)):es) anchor content mergeData = showTrace (EvPos MappingEnd pos) $ do pState <- get let anchorData = maybe NoAnchor AnchorDef anchor - let map = Mapping (reverse content) [] anchorData pos + let map = Mapping (reverse content) [] anchorData mergeData pos let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) map pState.anchors put $ pState {anchors = anchors} return (map, es) - parseMapping es anchor content = do + parseMapping es anchor content mergeData = do (maybeKey, es') <- parseNode es case maybeKey of - Nothing -> parseMapping es' anchor content + Nothing -> parseMapping es' anchor content mergeData Just key -> do unless (isScalar key) . error $ "Key not a scalar: " ++ show key (maybeVal, es'') <- parseNode es' let val = fromJust maybeVal - let content' = (key {comment = []}, val {comment = if null val.comment then key.comment else val.comment}) : content -- migrate comment to val to preserve it for the workflow data structure - when (not (null key.comment) && (safeHead . unpack . head $ key.comment) == '#' ) $ trace ("Migr to: " ++ show (snd . head $ content').comment) return() - parseMapping es'' anchor content' where + if trace (show key.bytes ++ " is merge: " ++ show (isMerge key)) (isMerge key) then do + let (content', mergeKeys) = mergeMappings [] content val + let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData + parseMapping es'' anchor content' mergeData' + else do + let content' = (key {comment = []}, val {comment = key.comment}) : content -- migrate comment to val to preserve it for the workflow data structure. alternative. don't use Data.Map for e.g. nodes and stages but a custom type and transfer it later. + parseMapping es'' anchor content' mergeData where isScalar :: YAMLNode -> Bool isScalar (Scalar {}) = True isScalar _ = False - safeHead [] = ' ' -- TODO remove those - safeHead (x:xs) = x - showType (Scalar {}) = "Scalar" - showType (Mapping {}) = "Mapping" - showType (Sequence {}) = "Sequence" + isMapping :: YAMLNode -> Bool + isMapping (Mapping {}) = True + isMapping _ = False + isSequence :: YAMLNode -> Bool + isSequence (Sequence {}) = True + isSequence _ = False + isMerge :: YAMLNode -> Bool + isMerge (Scalar b _ _ _) = unpack (decodeUtf8 b) == "<<" + mergeMappings :: [Text] -> [(YAMLNode, YAMLNode)] -> YAMLNode -> ([(YAMLNode, YAMLNode)], [Text]) + mergeMappings mergeKeys content (Mapping [] _ _ _ _) = (content, mergeKeys) + mergeMappings mergeKeys content m@(Mapping (x@(key, _):xs) _ _ _ _) + | isJust $ P.lookup key content = mergeMappings mergeKeys content m {content = xs} + | otherwise = mergeMappings ((decodeUtf8 key.bytes) : mergeKeys) (x : content) m {content = xs} + mergeMappings mergeKeys content (Sequence [] _ _ _) = (content, mergeKeys) + mergeMappings mergeKeys content s@(Sequence (m@(Mapping {}):xs) _ _ _) = mergeMappings mergeKeys' content' s {children = xs} where + (content', mergeKeys') = mergeMappings mergeKeys content m parseScalar :: Maybe Anchor -> Text -> Pos -> State ParseState YAMLNode @@ -162,7 +179,7 @@ module YamlParser where fromYAML y = Just <$> fromYAML y instance (Ord k, FromYAML' k, FromYAML' v) => FromYAML' (Map k v) where - fromYAML (Mapping c _ _ _) = fromList <$> mapM (\(a,b) -> (,) <$> fromYAML a <*> fromYAML b) c + fromYAML (Mapping c _ _ _ _) = fromList <$> mapM (\(a,b) -> (,) <$> fromYAML a <*> fromYAML b) c instance FromYAML' Text where fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs