From a4384f8bd13327791776d9763898c769a7fba586 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Fri, 30 Jun 2023 03:50:43 +0200 Subject: [PATCH] propagate merge data to json --- app/Export.hs | 15 ++++++++++----- app/Workflow.hs | 35 ++++++++++++++++++++++++----------- app/YamlParser.hs | 2 +- 3 files changed, 35 insertions(+), 17 deletions(-) diff --git a/app/Export.hs b/app/Export.hs index 090c6a3..81d689d 100644 --- a/app/Export.hs +++ b/app/Export.hs @@ -12,7 +12,7 @@ module Export where -- import Data.YAML (Node (..)) import Data.YAML.Event (tagToText, Pos) import Data.Maybe (fromMaybe) - import YamlParser (YAMLNode (..), AnchorData (..)) + import YamlParser (YAMLNode (..), AnchorData (..), MergeData (..)) import Data.Aeson.Types (toJSONKeyText) --------------------------------------- @@ -58,15 +58,19 @@ module Export where toJSON (AnchorAlias a) = object ["type" .= String "alias", "name" .= a] toJSON NoAnchor = Null + instance ToJSON MergeData where + toJSON (MergeData keys anchor) = object ["keys" .= keys, "anchor" .= anchor] + instance ToJSON Pos instance ToJSON Message where - toJSON (Message content status viewers comment anchor) = object [ + toJSON (Message content status viewers comment anchor merge) = object [ "content" .= content, "status" .= status, "viewers" .= viewers, "comment" .= comment, - "anchor" .= anchor] + "anchor" .= anchor, + "merge" .= merge] instance ToJSON Viewers where toJSON (Viewers mappings comment anchor) = object [ @@ -75,12 +79,13 @@ module Export where "anchor" .= anchor ] instance ToJSON Label where - toJSON (Label fallback fallbackLang translations comment anchor) = object [ + toJSON (Label fallback fallbackLang translations comment anchor merge) = object [ "fallback" .= fallback, "fallback-lang" .= fallbackLang, "translations" .= translations, "comment" .= comment, - "anchor" .= anchor] + "anchor" .= anchor, + "merge" .= merge] instance ToJSON NodeData where toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where diff --git a/app/Workflow.hs b/app/Workflow.hs index 0446888..21c86f3 100644 --- a/app/Workflow.hs +++ b/app/Workflow.hs @@ -27,14 +27,16 @@ module Workflow where data Workflow = Workflow { nodes :: Map Text State, stages :: Maybe YAMLNode, - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Workflow where - fromYAML (Mapping mapping _ anchor _ pos) = Workflow + fromYAML (Mapping mapping _ anchor merge pos) = Workflow <$> mapping <| "nodes" <*> mapping <|? "stages" <*> pure anchor + <*> pure merge -- | Structure of a node. @@ -45,7 +47,8 @@ module Workflow where edges :: Maybe (Map Text Action), messages :: Maybe [Message], comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' State where @@ -57,6 +60,7 @@ module Workflow where <*> mapping <|? "messages" <*> pure comment <*> pure anchor + <*> pure merge -- | Wrapper for the `final` value of any node. @@ -82,7 +86,8 @@ module Workflow where name :: Either Label Text, viewers :: Maybe Viewers, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' StateViewers where @@ -91,12 +96,13 @@ module Workflow where <*> mapping <|? "viewers" <*> pure comment <*> pure anchor + <*> pure merge data Viewers = Viewers { viewers :: [Map Text YAMLNode], comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData } deriving Show instance FromYAML' Viewers where @@ -116,7 +122,8 @@ module Workflow where fallbackLang :: Maybe Text, translations :: Maybe YAMLNode, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Label where @@ -126,6 +133,7 @@ module Workflow where <*> mapping <|? "translations" <*> pure comment <*> pure anchor + <*> pure merge -- | Structure of an edge. @@ -138,8 +146,9 @@ module Workflow where viewers :: Maybe Viewers, messages :: Maybe [Message], form :: Maybe YAMLNode, - comment :: [Comment], - anchor :: AnchorData + comment :: [Comment], + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Action where @@ -154,13 +163,15 @@ module Workflow where <*> mapping <|? "form" <*> pure comment <*> pure anchor + <*> pure merge data Message = Message { content :: Label, status :: Maybe Text, viewers :: Maybe Viewers, comment :: [Comment], - anchor :: AnchorData + anchor :: AnchorData, + merge :: [MergeData] } deriving Show instance FromYAML' Message where @@ -170,6 +181,7 @@ module Workflow where <*> mapping <|? "viewers" <*> pure comment <*> pure anchor + <*> pure merge data Entry = Single Text @@ -203,12 +215,13 @@ module Workflow where buildData :: Workflow -> GraphData buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor, - viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor)) Nothing [] NoAnchor, + viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor [])) Nothing [] NoAnchor [], payload = Nothing, edges = Nothing, messages = Nothing, comment = [], - anchor = NoAnchor}) wf.nodes + anchor = NoAnchor, + merge = []}) wf.nodes analyse :: Text -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed) extract :: State -> Map Text Entry diff --git a/app/YamlParser.hs b/app/YamlParser.hs index 4a2543e..437ed35 100644 --- a/app/YamlParser.hs +++ b/app/YamlParser.hs @@ -122,7 +122,7 @@ module YamlParser where unless (isScalar key) . error $ "Key not a scalar: " ++ show key (maybeVal, es'') <- parseNode es' let val = fromJust maybeVal - if trace (show key.bytes ++ " is merge: " ++ show (isMerge key)) (isMerge key) then do + if isMerge key then do let (content', mergeKeys) = mergeMappings [] content val let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData parseMapping es'' anchor content' mergeData'