init

.gitignore

@@ -0,0 +1,3 @@
+/dist-newstyle
+CHANGELOG.md
+test.json

app/Export.hs

@@ -0,0 +1,43 @@
+{-# Language OverloadedStrings #-}
+
+module Export where
+
+  ----------------Imports----------------
+
+  import Data.Aeson
+  import Data.Map hiding (fromList)
+  import Data.Vector hiding ((!))
+  import Workflow (NodeData(..), EdgeData(..), GraphData(..))
+
+  ---------------------------------------
+
+
+  ---------------Instances---------------
+
+  instance ToJSON NodeData where
+    toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where
+      newObject :: String -> Map String String -> [Value] -> [Value]
+      newObject ident values result = object [
+                                        "id" .= ident,
+                                        "name" .= values ! "name",
+                                        "val" .= show 5, -- Todo adjust to number of edges
+                                        "stateData" .= object [
+                                                          "viewers" .= values ! "viewers",
+                                                          "final" .= values ! "final"]] : result
+    -- toEncoding = genericToEncoding defaultOptions
+
+  instance ToJSON EdgeData where
+    toJSON (EData d) = Array (fromList $ foldrWithKey newObject [] d) where
+      newObject :: String -> Map String String -> [Value] -> [Value]
+      newObject ident values result = object [
+                                        "id" .= ident,
+                                        "name" .= values ! "name",
+                                        "source" .= values ! "source",
+                                        "target" .= values ! "target",
+                                        "actionData" .= object [
+                                                          "mode" .= values ! "mode"]] : result
+
+  instance ToJSON GraphData where
+    toJSON (GData (nd, ed)) = object ["states" .= toJSON nd, "actions" .= toJSON ed]
+
+  ---------------------------------------

app/Main.hs

@@ -0,0 +1,52 @@
+module Main where
+
+  ----------------Imports----------------
+
+  import System.Environment (getArgs)
+  import Data.Yaml (ParseException, decodeEither')
+  import Data.Aeson (encode, encodeFile)
+
+  import qualified Data.ByteString.Char8 as BS
+  import Workflow (Workflow, buildData)
+  import Export
+  import Data.Maybe (fromJust, isNothing)
+  import Data.Either (isLeft, fromLeft, fromRight)
+  import Control.Exception (throw)
+
+  ---------------------------------------
+
+
+  ----------------Methods----------------  
+
+  -- | Required command line arguments:
+  -- 1. A workflow source file (YAML)
+  -- 2. A graph data target file (JSON) 
+  main :: IO ()
+  main = getArgs >>= process >>= finish where
+    process :: [String] -> IO Bool
+    process args = if   length args /= 2
+                   then print "Please provide (1) a source and (2) a target file" >> return True
+                   else generateJSON args >> return False
+    finish :: Bool -> IO ()
+    finish abort = if abort then return () else print "Done."
+         
+
+
+  -- | Imports the YAML document specified in the first command line argument and
+  --   exports the graph data to the JSON file specified in the second argument.
+  generateJSON :: [String] -> IO ()
+  generateJSON args = do
+    content <- BS.readFile (head args)
+    let decoded = decodeEither' content :: Either ParseException Workflow
+    if isLeft decoded then throw (fromLeft undefined decoded) else do
+      let yaml = fromRight undefined decoded
+      -- let GData (nodeData, edgeData) = buildData yaml
+      -- putStrLn $ "\nNode Data:\n\n" ++ show nodeData
+      -- putStrLn $ "\nEdge Data:\n\n" ++ show edgeData
+      -- encodeFile (last args) $ GData (nodeData, edgeData)
+      encodeFile (last args) $ buildData yaml
+
+  ---------------------------------------
+
+-- https://stackoverflow.com/questions/59903779/how-to-parse-json-with-field-of-optional-and-variant-type-in-haskell
+-- https://stackoverflow.com/questions/21292428/reading-yaml-lists-of-objects-in-haskell

app/Workflow.hs

@@ -0,0 +1,160 @@
+{-# Language DuplicateRecordFields,
+    NoFieldSelectors,
+    OverloadedRecordDot,
+    OverloadedStrings,
+    DeriveGeneric #-}
+
+module Workflow where
+
+  ----------------Imports----------------
+
+  import Data.Yaml
+  import Control.Applicative hiding (empty)
+  import GHC.Generics (Generic)
+  import Data.Map
+  import Data.Maybe (fromMaybe, isNothing, fromJust)
+  import Data.Text (pack)
+
+  ---------------------------------------
+
+
+  ---------Data Types & Instances--------
+  
+  -- | Outer structure of a workflow, i.e. nodes and stages.
+  data Workflow = Workflow {
+    nodes  :: Map String State,
+    stages :: Maybe Value
+  } deriving (Show, Generic)
+
+  instance FromJSON Workflow
+
+
+  -- | Structure of a node.
+  data State = State {
+    viewers  :: Maybe StateViewers,
+    payload  :: Maybe Value,
+    final    :: Maybe Final,
+    edges    :: Maybe (Map String Action),
+    messages :: Maybe Value
+  } deriving (Show, Generic)
+
+  instance FromJSON State where
+    parseJSON (Object o) = State <$>
+                           o .:? "viewers" <*>
+                           o .:? "payload-view" <*>
+                           o .:? "final" <*>
+                           o .:? "edges" <*>
+                           o .:? "messages"
+    parseJSON _ = error "unexpected state data format"
+
+  
+  -- | Wrapper for the `final` value of any node.
+  newtype Final =  Final {final :: String} deriving (Show, Generic)
+
+  instance FromJSON Final where
+    parseJSON v = case v of
+                    String _ -> Final <$> parseJSON v
+                    Bool x   -> Final <$> parseJSON (String . pack . show $ x)
+
+
+  -- | Structure of the `viewers` object of any node.
+  data StateViewers = StateViewers {
+    name    :: Either Label String,
+    viewers :: Maybe Value
+  } deriving (Show, Generic)
+
+  instance FromJSON StateViewers where
+    parseJSON (Object o) = StateViewers <$>
+                           ((Left <$> o .:  "display-label") <|> (Right <$> o .:  "display-label")) <*>
+                           o .:? "viewers"
+    parseJSON _ = error "unexpected stateViewers data format"
+
+
+  
+  -- | Structure of the @display-label@ object of any node or edge.
+  data Label = Label {
+    fallback :: Maybe String,
+    translations :: Maybe Value
+  } deriving (Show, Generic)
+
+  instance FromJSON Label
+
+
+  -- | Structure of an edge.
+  data Action = Action {
+    mode      :: Maybe String,
+    source    :: Maybe String,
+    name      :: Maybe Label,
+    actors    :: Maybe Value,
+    viewActor :: Maybe Value,
+    viewers   :: Maybe Value,
+    messages  :: Maybe Value,
+    form      :: Maybe Value
+  } deriving (Show, Generic)
+
+  instance FromJSON Action where
+    parseJSON (Object o) = Action <$>
+                           o .:? "mode" <*>
+                           o .:? "source" <*>
+                           o .:? "display-label" <*>
+                           o .:? "actors" <*>
+                           o .:? "view-actor" <*>
+                           o .:? "viewers" <*>
+                           o .:? "messages" <*>
+                           o .:? "form"
+    parseJSON _ = error "unexpected action data format"
+  
+  
+  -- | Data of all nodes prepared for JSON encoding.
+  newtype NodeData  = NData (Map String (Map String String)) deriving (Show, Generic)
+  -- | Data of all edges prepared for JSON encoding.
+  newtype EdgeData  = EData (Map String (Map String String)) deriving (Show, Generic)
+  -- | Data of the entire workflow prepared for JSON encoding.
+  newtype GraphData = GData (NodeData , EdgeData) deriving (Show, Generic)
+
+  ---------------------------------------
+
+  
+  ---------------Constants---------------
+  
+  -- | Name of the source of an initial action.
+  initID = "@@INIT"
+
+  ---------------------------------------
+
+
+  ----------------Methods----------------
+
+  buildData :: Workflow -> GraphData
+  buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where
+    nodes = insert initID (State {final = Just $ Final "False",
+                                  viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing,
+                                  payload = Nothing,
+                                  edges = Nothing,
+                                  messages = Nothing}) wf.nodes
+    analyse :: String -> 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 String String
+    extract s = fromList [("name", name), ("viewers", viewers), ("final", final)] where
+      (name, viewers) = case s.viewers of
+                          Nothing -> ("", "")
+                          Just x -> case x.name of
+                                      Left y  -> (fromMaybe "" y.fallback, show x.viewers)
+                                      Right y -> (y, show x.viewers)
+      final = case s.final of
+                Nothing -> ""
+                Just x  -> x.final
+    updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData
+    updateEdges _ Nothing e = e
+    updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (k ++ "_@_" ++ targetID) (newData k action targetID) eData) e edges
+    newData :: String -> Action -> String -> Map String String
+    newData ident a targetID = fromList [("name", name), ("source", source), ("target", targetID), ("mode", mode)] where
+      name = if isNothing a.name
+             then ident
+             else case (fromJust a.name).fallback of
+                  Nothing -> show a.name
+                  Just x  -> x
+      source = fromMaybe initID a.source
+      mode = fromMaybe "" a.mode
+
+  ---------------------------------------

editor.css

@@ -0,0 +1,7 @@
+/* .body {
+  margin: 50px 50px 50px 50px;
+}
+
+#editor {
+  border: 10px solid red;
+} */

editor.html

@@ -0,0 +1,23 @@
+<head>
+  <link rel="STYLESHEET" type="text/css" href="./editor.css">
+  <meta charset="utf-8">
+
+  <!-- <script src="//unpkg.com/force-graph"></script> -->
+  <script src="https://unpkg.com/force-graph@1.43.0/dist/force-graph.min.js"></script>
+  <!-- <script src="./force-graph-master/src/force-graph.js"></script> -->
+  <!--<script src="../../dist/force-graph.js"></script>-->
+</head>
+
+<body>
+  <div id="editor">
+    <!-- <br/>
+    <div style="text-align: center; color: silver">
+      <b>New node:</b> click on the canvas, <b>New link:</b> drag one node close enough to another one,
+      <b>Rename</b> node or link by clicking on it, <b>Remove</b> node or link by right-clicking on it
+    </div> -->
+    <div id="graph"></div>
+    hello
+  </div>
+  
+  <script src="./editor.js"></script>
+</body>

editor.js

@@ -0,0 +1,257 @@
+var workflow = {}
+
+// fetch('./test.json')
+//   .then((response) => response.json())
+//   .then((data) => {
+//     for (var key in data) 
+//       workflow[key] = data[key];
+//   });
+
+// Counters for placeholder IDs of states/actions added via GUI
+var stateIdCounter  = workflow.states ? workflow.states.length  : 0;
+var actionIdCounter = workflow.states ? workflow.actions.length : 0;
+
+
+var selfLoops         = {};  // All edges whose targets equal their sources.
+var overlappingEdges  = {};  // All edges whose target and source are connected by further.
+const selfLoopCurvMin = 0.5; // Minimum curvature of a self loop.
+const curvatureMinMax = 0.2; // Minimum/maximum curvature (1 +/- x) of overlapping edges.
+
+var selection = null; // The currently selected node/edge.
+
+
+/**
+ * Identifies and stores self loops as well as overlapping edges (i.e. multiple edges sharing the
+ * same source and target).
+ */
+function identifyOverlappingEdges() {
+  selfLoops = {};
+  overlappingEdges = {};
+  workflow.actions.forEach(edge => {
+    var source = typeof(edge.source) === 'string' ? edge.source : edge.source.id;
+    var target = typeof(edge.target) === 'string' ? edge.target : edge.target.id;
+    var pre  = source <= target ? source : target;
+    var post = source <= target ? target : source;
+    edge.nodePairId = pre + '_' + post;
+    var category = edge.source === edge.target ? selfLoops : overlappingEdges;
+    if (!category[edge.nodePairId]) category[edge.nodePairId] = [];
+    category[edge.nodePairId].push(edge);
+  });
+}
+
+
+/**
+ * Computes the curvature of the loops stored in `selfLoops` and overlapping edges
+ * stored in `overlappingEdges`.
+ */
+function computeCurvatures() {
+  // Self loops
+  Object.keys(selfLoops).forEach(id => {
+    var edges = selfLoops[id];
+    for (let i = 0; i < edges.length; i++)
+      edges[i].curvature = selfLoopCurvMin + i / 10;
+  });
+  // Overlapping edges
+  Object.keys(overlappingEdges)
+        .filter(nodePairId => overlappingEdges[nodePairId].length > 1)
+        .forEach(nodePairId => {
+    var edges     = overlappingEdges[nodePairId];
+    var lastIndex = edges.length - 1;
+    var lastEdge  = edges[lastIndex];
+    lastEdge.curvature = curvatureMinMax;
+    let delta = 2 * curvatureMinMax / lastIndex;
+    for (let i = 0; i < lastIndex; i++) {
+      edges[i].curvature = - curvatureMinMax + i * delta;
+      if (lastEdge.source !== edges[i].source) edges[i].curvature *= -1;
+    }
+  });
+}
+
+
+/**
+ * Marks the given item as selected.
+ * @param {*} item The node or edge to select.
+ */
+function select(item) {
+  selection = item;
+  console.log(item);
+  // TODO
+}
+
+
+/**
+ * Updates the nodes and edges of the workflow graph.
+ */
+function updateGraph() {
+  identifyOverlappingEdges()
+  computeCurvatures()
+  Graph.graphData({nodes: workflow.states, links: workflow.actions});
+}
+
+
+/**
+ * Adds a new action between two states.
+ * @param {*} source The source state.
+ * @param {*} target The target state.
+ */
+function connect(source, target) {
+  let linkId = actionIdCounter ++;
+  action = {id: linkId, source: source, target: target, name: 'action_' + linkId};
+  workflow.actions.push(action);
+  updateGraph();
+}
+
+
+/**
+ * Adds a new state to the workflow.
+ * @param {*} x The x coordinate on the canvas.
+ * @param {*} y The y coordinate on the canvas.
+ * @returns The new state.
+ */
+function addState(x, y) {
+  let nodeId = stateIdCounter ++;
+  state = {id: nodeId, x: x, y: y, name: 'state_' + nodeId, fx: x, fy: y, val: 5};
+  workflow.states.push(state);
+  updateGraph();
+  return state;
+}
+
+
+/**
+ * Removes an edge from the workflow.
+ * @param {*} action The action to remove.
+ */
+function removeAction(action) {
+  workflow.actions.splice(workflow.actions.indexOf(action), 1);
+}
+
+
+/**
+ * Removes a state from the workflow.
+ * @param {*} state The state to remove.
+ */
+function removeState(state) {
+  workflow.actions
+          .filter(edge => edge.source === state || edge.target === state)
+          .forEach(edge => removeAction(edge));
+  workflow.states.splice(workflow.states.indexOf(state), 1);
+}
+
+const Graph = ForceGraph()
+  (document.getElementById('graph'))
+    .linkDirectionalArrowLength(6)
+    .linkDirectionalArrowRelPos(1)
+    .nodeColor(node => {
+      if (node.stateData && node.stateData.final !== 'False' && node.stateData.final !== '') {
+        if (node.stateData.final === 'True' || node.stateData.final === 'ok') {
+          return selection === node ? '#a4eb34' : '#7fad36';
+        } else if (node.stateData.final === 'not-ok') {
+          return selection === node ? '#f77474' : '#f25050';
+        } else {
+          //console.log(node.stateData.final);
+        }
+      } else if (node.name === '@@INIT') {
+        return selection === node ? '#e8cd84' : '#d1ad4b';
+      } else {
+        return selection === node ? '#5fbad9' : '#4496b3';
+      }
+    })
+    .linkColor(edge => selection === edge ? 'black' : '#999999')
+    .linkCurvature('curvature')
+    .linkCanvasObjectMode(() => 'after')
+    .linkCanvasObject((edge, context) => {
+      const MAX_FONT_SIZE = 4;
+      const LABEL_NODE_MARGIN = Graph.nodeRelSize() * edge.source.val * 1.5;
+
+      const source = edge.source;
+      const target   = edge.target;
+      const curvature = edge.curvature || 0;
+
+      var textPos = (source === target) ? {x: source.x, y: source.y} : Object.assign(...['x', 'y'].map(c => ({
+        [c]: source[c] + (target[c] - source[c]) / 2
+      })));
+
+      const edgeVector = {x: target.x - source.x, y: target.y - source.y};
+      if (source !== target) {
+        var evLength = Math.sqrt(Math.pow(edgeVector.x, 2) + Math.pow(edgeVector.y, 2));
+        var perpendicular = {x: edgeVector.x, y: (-Math.pow(edgeVector.x, 2) / edgeVector.y)};
+        var pLength = Math.sqrt(Math.pow(perpendicular.x, 2) + Math.pow(perpendicular.y, 2));
+        perpendicular.x = perpendicular.x / pLength;
+        perpendicular.y = perpendicular.y / pLength;
+        var fromSource = {x: source.x + perpendicular.x, y: source.y + perpendicular.y};
+        // If source would cycle around target in clockwise direction, would fromSource point into this direction?
+        // If not, the perpendicular vector must be flipped in order to ensure that the label is displayed on the
+        // intended curved edge.
+        var isClockwise = (source.x < target.x && fromSource.y > source.y) ||
+                          (source.x > target.x && fromSource.y < source.y) ||
+                          (source.x === target.x && ((source.y < target.y && fromSource.x < source.x) ||
+                                                      source.y > target.y && fromSource.x > source.x));
+        var offset = 0.5 * evLength * (isClockwise ? -curvature : curvature);
+        textPos = {x: textPos.x + perpendicular.x * offset, y: textPos.y + perpendicular.y * offset};
+      } else if (edge.__controlPoints) { // Position label relative to the Bezier control points of the self loop
+        edgeVector.x = edge.__controlPoints[2] - edge.__controlPoints[0];
+        edgeVector.y = edge.__controlPoints[3] - edge.__controlPoints[1];
+        var ctrlCenter = {x: edge.__controlPoints[0] + (edge.__controlPoints[2] - edge.__controlPoints[0]) / 2,
+                          y: edge.__controlPoints[1] + (edge.__controlPoints[3] - edge.__controlPoints[1]) / 2};
+        var fromSource = {x: ctrlCenter.x - source.x, y: ctrlCenter.y - source.y};
+        var fromSrcLen = Math.sqrt(Math.pow(fromSource.x, 2) + Math.pow(fromSource.y, 2));
+        fromSource.x /= fromSrcLen;
+        fromSource.y /= fromSrcLen;
+        // The distance of the control point is 70 * curvature. Slightly more than half of it is appropriate here:
+        textPos = {x: source.x + fromSource.x * 37 * curvature, y: source.y + fromSource.y * 37 * curvature};
+      }
+
+      const maxTextLength = (source !== target) ? Math.sqrt(Math.pow(edgeVector.x, 2) + Math.pow(edgeVector.y, 2)) - LABEL_NODE_MARGIN
+                                                : 1.5 * Math.sqrt(4 * source.val);
+
+      var textAngle = Math.atan2(edgeVector.y, edgeVector.x);
+      // maintain label vertical orientation for legibility
+      if (textAngle > Math.PI / 2) textAngle = -(Math.PI - textAngle);
+      if (textAngle < -Math.PI / 2) textAngle = -(-Math.PI - textAngle);
+
+      var label = edge.name;
+
+      // estimate fontSize to fit in link length
+      //context.font = '1px Sans-Serif';
+      const fontSize = MAX_FONT_SIZE;// Math.min(MAX_FONT_SIZE, maxTextLength / context.measureText(label).width);
+      context.font = `${fontSize}px Sans-Serif`;
+
+      var textLen = context.measureText(label).width;
+      if (textLen > maxTextLength) {
+        var allowedLen = maxTextLength * (label.length / textLen);
+        label = label.substring(0, allowedLen);
+        if (label !== edge.name) label += '...';
+        textLen = context.measureText(label).width;
+      }
+
+      const bckgDimensions = [textLen, fontSize];
+
+      // draw text label (with background rect)
+      context.save();
+      context.translate(textPos.x, textPos.y);
+      context.rotate(textAngle);
+
+      context.fillStyle = 'rgba(255, 255, 255, 0.8)';
+      context.fillRect(- bckgDimensions[0] / 2, - bckgDimensions[1] / 2, ...bckgDimensions);
+
+      context.textAlign = 'center';
+      context.textBaseline = 'middle';
+      context.fillStyle = selection === edge ? 'black' : 'darkgrey';
+      context.fillText(label, 0, 0);
+      context.restore();
+    })
+    .onNodeDragEnd(node => {
+      node.fx = node.x;
+      node.fy = node.y;
+    })
+    .onNodeClick((node, _) => select(node))
+    .onNodeRightClick((node, _) => removeState(node))
+    .onLinkClick((edge, _) => select(edge))
+    .onLinkRightClick((edge, _) => removeAction(edge))
+    .onBackgroundClick(event => {
+      var coords = Graph.screen2GraphCoords(event.layerX, event.layerY);
+      var newState = addState(coords.x, coords.y);
+      selection = newState;
+    });
+
+updateGraph();

workflow-visualiser.cabal

@@ -0,0 +1,41 @@
+cabal-version:      2.4
+name:               workflow-visualiser
+version:            0.1.0.0
+
+-- A short (one-line) description of the package.
+-- synopsis:
+
+-- A longer description of the package.
+-- description:
+
+-- A URL where users can report bugs.
+-- bug-reports:
+
+-- The license under which the package is released.
+-- license:
+author:             David Mosbach
+maintainer:         david.mosbach@live.de
+
+-- A copyright notice.
+-- copyright:
+-- category:
+extra-source-files: CHANGELOG.md
+
+executable workflow-visualiser
+    main-is:          Main.hs
+
+    -- Modules included in this executable, other than Main.
+    other-modules: Workflow,
+                   Export
+
+    -- LANGUAGE extensions used by modules in this package.
+    -- other-extensions:
+    build-depends:    base ^>=4.16.3.0,
+                      yaml >= 0.11.11.0,
+                      aeson >= 2.1.2.0,
+                      bytestring,
+                      containers,
+                      text,
+                      vector
+    hs-source-dirs:   app
+    default-language: Haskell2010