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

Hsyaml #3

Merged
mosbach merged 10 commits from hsyaml into main 2023-08-24 05:00:03 +02:00
Conversation 6 Commits 10 Files Changed 9 +35 -17
3 changed files with 35 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files
Showing only changes of commit a4384f8bd1 - Show all commits

15
app/Export.hs
View File

@ -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

35
app/Workflow.hs
View File

@ -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

2
app/YamlParser.hs
View File

@ -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'