lmu/uni2work.workflows.visualiser
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

propagate merge data to json

Browse Source
This commit is contained in:
David Mosbach 2023-06-30 03:50:43 +02:00
parent 06b690c5a1
commit a4384f8bd1
3 changed files with 35 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
app/Export.hs
View File

@ -12,7 +12,7 @@ module Export where
-- import Data.YAML (Node (..)) -- import Data.YAML (Node (..))
import Data.YAML.Event (tagToText, Pos) import Data.YAML.Event (tagToText, Pos)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import YamlParser (YAMLNode (..), AnchorData (..)) import YamlParser (YAMLNode (..), AnchorData (..), MergeData (..))
import Data.Aeson.Types (toJSONKeyText) import Data.Aeson.Types (toJSONKeyText)
--------------------------------------- ---------------------------------------
@ -58,15 +58,19 @@ module Export where
toJSON (AnchorAlias a) = object ["type" .= String "alias", "name" .= a] toJSON (AnchorAlias a) = object ["type" .= String "alias", "name" .= a]
toJSON NoAnchor = Null toJSON NoAnchor = Null
instance ToJSON MergeData where
toJSON (MergeData keys anchor) = object ["keys" .= keys, "anchor" .= anchor]
instance ToJSON Pos instance ToJSON Pos
instance ToJSON Message where instance ToJSON Message where
toJSON (Message content status viewers comment anchor) = object [ toJSON (Message content status viewers comment anchor merge) = object [
"content" .= content, "content" .= content,
"status" .= status, "status" .= status,
"viewers" .= viewers, "viewers" .= viewers,
"comment" .= comment, "comment" .= comment,
"anchor" .= anchor] "anchor" .= anchor,
"merge" .= merge]
instance ToJSON Viewers where instance ToJSON Viewers where
toJSON (Viewers mappings comment anchor) = object [ toJSON (Viewers mappings comment anchor) = object [
@ -75,12 +79,13 @@ module Export where
"anchor" .= anchor "anchor" .= anchor
] ]
instance ToJSON Label where instance ToJSON Label where
toJSON (Label fallback fallbackLang translations comment anchor) = object [ toJSON (Label fallback fallbackLang translations comment anchor merge) = object [
"fallback" .= fallback, "fallback" .= fallback,
"fallback-lang" .= fallbackLang, "fallback-lang" .= fallbackLang,
"translations" .= translations, "translations" .= translations,
"comment" .= comment, "comment" .= comment,
"anchor" .= anchor] "anchor" .= anchor,
"merge" .= merge]
instance ToJSON NodeData where instance ToJSON NodeData where
toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where

35
app/Workflow.hs
View File

@ -27,14 +27,16 @@ module Workflow where
data Workflow = Workflow { data Workflow = Workflow {
nodes :: Map Text State, nodes :: Map Text State,
stages :: Maybe YAMLNode, stages :: Maybe YAMLNode,
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' Workflow where instance FromYAML' Workflow where
fromYAML (Mapping mapping _ anchor _ pos) = Workflow fromYAML (Mapping mapping _ anchor merge pos) = Workflow
<$> mapping <| "nodes" <$> mapping <| "nodes"
<*> mapping <|? "stages" <*> mapping <|? "stages"
<*> pure anchor <*> pure anchor
<*> pure merge
-- | Structure of a node. -- | Structure of a node.
@ -45,7 +47,8 @@ module Workflow where
edges :: Maybe (Map Text Action), edges :: Maybe (Map Text Action),
messages :: Maybe [Message], messages :: Maybe [Message],
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' State where instance FromYAML' State where
@ -57,6 +60,7 @@ module Workflow where
<*> mapping <|? "messages" <*> mapping <|? "messages"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
<*> pure merge
-- | Wrapper for the `final` value of any node. -- | Wrapper for the `final` value of any node.
@ -82,7 +86,8 @@ module Workflow where
name :: Either Label Text, name :: Either Label Text,
viewers :: Maybe Viewers, viewers :: Maybe Viewers,
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' StateViewers where instance FromYAML' StateViewers where
@ -91,12 +96,13 @@ module Workflow where
<*> mapping <|? "viewers" <*> mapping <|? "viewers"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
<*> pure merge
data Viewers = Viewers { data Viewers = Viewers {
viewers :: [Map Text YAMLNode], viewers :: [Map Text YAMLNode],
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData
} deriving Show } deriving Show
instance FromYAML' Viewers where instance FromYAML' Viewers where
@ -116,7 +122,8 @@ module Workflow where
fallbackLang :: Maybe Text, fallbackLang :: Maybe Text,
translations :: Maybe YAMLNode, translations :: Maybe YAMLNode,
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' Label where instance FromYAML' Label where
@ -126,6 +133,7 @@ module Workflow where
<*> mapping <|? "translations" <*> mapping <|? "translations"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
<*> pure merge
-- | Structure of an edge. -- | Structure of an edge.
@ -138,8 +146,9 @@ module Workflow where
viewers :: Maybe Viewers, viewers :: Maybe Viewers,
messages :: Maybe [Message], messages :: Maybe [Message],
form :: Maybe YAMLNode, form :: Maybe YAMLNode,
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' Action where instance FromYAML' Action where
@ -154,13 +163,15 @@ module Workflow where
<*> mapping <|? "form" <*> mapping <|? "form"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
<*> pure merge
data Message = Message { data Message = Message {
content :: Label, content :: Label,
status :: Maybe Text, status :: Maybe Text,
viewers :: Maybe Viewers, viewers :: Maybe Viewers,
comment :: [Comment], comment :: [Comment],
anchor :: AnchorData anchor :: AnchorData,
merge :: [MergeData]
} deriving Show } deriving Show
instance FromYAML' Message where instance FromYAML' Message where
@ -170,6 +181,7 @@ module Workflow where
<*> mapping <|? "viewers" <*> mapping <|? "viewers"
<*> pure comment <*> pure comment
<*> pure anchor <*> pure anchor
<*> pure merge
data Entry = Single Text data Entry = Single Text
@ -203,12 +215,13 @@ module Workflow where
buildData :: Workflow -> GraphData buildData :: Workflow -> GraphData
buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where
nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor, 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, payload = Nothing,
edges = Nothing, edges = Nothing,
messages = Nothing, messages = Nothing,
comment = [], comment = [],
anchor = NoAnchor}) wf.nodes anchor = NoAnchor,
merge = []}) wf.nodes
analyse :: Text -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) 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) analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed)
extract :: State -> Map Text Entry extract :: State -> Map Text Entry

2
app/YamlParser.hs
View File

@ -122,7 +122,7 @@ module YamlParser where
unless (isScalar key) . error $ "Key not a scalar: " ++ show key unless (isScalar key) . error $ "Key not a scalar: " ++ show key
(maybeVal, es'') <- parseNode es' (maybeVal, es'') <- parseNode es'
let val = fromJust maybeVal 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 (content', mergeKeys) = mergeMappings [] content val
let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData let mergeData' = (MergeData mergeKeys key.anchorData) : mergeData
parseMapping es'' anchor content' mergeData' parseMapping es'' anchor content' mergeData'