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

Merge branch 'hsyaml' into 'main'

Browse Source 
Hsyaml

See merge request uni2work/workflows/workflow-visualiser!3
This commit is contained in:
David Mosbach 2023-08-24 03:00:02 +00:00
commit 0abe04387d
9 changed files with 675 additions and 156 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -6,4 +6,5 @@
CHANGELOG.md
test.json
server.py
/workflows
/workflows
/spaß

88
app/Export.hs
View File

@ -10,9 +10,14 @@ module Export where
import Data.Aeson
import Data.Map hiding (fromList)
import Data.Vector hiding ((!))
import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..))
import Data.Text (pack)
import Data.Vector hiding ((!), (++))
import Workflow (NodeData(..), EdgeData(..), GraphData(..), Entry(..), Message(..), Label(..), Viewers (..), Actors (Actors))
import Data.Text (Text, pack)
-- import Data.YAML (Node (..))
import Data.YAML.Event (tagToText, Pos)
import Data.Maybe (fromMaybe)
import YamlParser (YAMLNode (..), AnchorData (..), MergeData (..))
import Data.Aeson.Types (toJSONKeyText)
---------------------------------------
@ -21,18 +26,89 @@ module Export where
instance ToJSON Entry where
toJSON (Single s) = toJSON s
toJSON (Msg m) = toJSON m
toJSON (Vie v) = toJSON v
toJSON (Act a) = toJSON a
toJSON (Dict d) = toJSON d
toJSON (List l) = toJSON l
toJSON (Val v) = toJSON v
-- instance ToJSON YAMLNode where
-- toJSON (Scalar b c a p) = object [
-- "content" .= show b,
-- "comment" .= c,
-- "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,
-- "anchor" .= a,
-- "position" .= p
-- ]
-- instance ToJSONKey YAMLNode where
-- toJSONKey = toJSONKeyText display where
-- display :: YAMLNode -> Text
-- display (Scalar bytes _ _ _) = pack $ show bytes
instance ToJSON AnchorData where
toJSON (AnchorDef a) = object ["type" .= String "anchor", "name" .= a]
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 merge) = object [
"content" .= content,
"status" .= status,
"viewers" .= viewers,
"comment" .= comment,
"anchor" .= anchor,
"merge" .= merge]
instance ToJSON Viewers where
toJSON (Viewers mappings comment anchor) = object [
"viewers" .= mappings,
"comment" .= comment,
"anchor" .= anchor
]
instance ToJSON Actors where
toJSON (Actors (Viewers mappings comment anchor)) = object [
"actors" .= mappings,
"comment" .= comment,
"anchor" .= anchor
]
instance ToJSON Label where
toJSON (Label fallback fallbackLang translations comment anchor merge) = object [
"fallback" .= fallback,
"fallback-lang" .= fallbackLang,
"translations" .= translations,
"comment" .= comment,
"anchor" .= anchor,
"merge" .= merge]
instance ToJSON NodeData where
toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where
newObject :: String -> Map String Entry -> [Value] -> [Value]
newObject :: Text -> Map Text Entry -> [Value] -> [Value]
newObject ident values result = object [
"id" .= ident,
"name" .= values ! "name",
"val" .= show 5, -- Todo adjust to number of edges
"stateData" .= object [
"comment" .= values ! "comment",
"anchor" .= values ! "anchor",
"viewers" .= values ! "viewers",
"final" .= values ! "final",
"messages" .= values ! "messages",
@ -41,13 +117,15 @@ module Export where
instance ToJSON EdgeData where
toJSON (EData d) = Array (fromList $ foldrWithKey newObject [] d) where
newObject :: String -> Map String Entry -> [Value] -> [Value]
newObject :: Text -> Map Text Entry -> [Value] -> [Value]
newObject ident values result = object [
"id" .= ident,
"name" .= values ! "name",
"source" .= values ! "source",
"target" .= values ! "target",
"actionData" .= object [
"comment" .= values ! "comment",
"anchor" .= values ! "anchor",
"mode" .= values ! "mode",
"actors" .= values ! "actors",
"viewers" .= values ! "viewers",

59
app/Index.hs
View File

@ -10,47 +10,48 @@
module Index where
import Data.Yaml
import Control.Applicative hiding (empty)
import GHC.Generics (Generic)
import Data.Map
import Data.Maybe (fromMaybe, fromJust)
import Data.Text (Text)
import YamlParser
type Index = Map String Entry
type Index = Map Text Entry
data Entry = Entry {
graphFile :: String,
category :: Maybe String,
defScope :: Maybe String,
graphFile :: Text,
category :: Maybe Text,
defScope :: Maybe Text,
defDescription :: Maybe Description,
instDescription :: Maybe Description,
instances :: Value
} deriving (Show, Generic)
instances :: YAMLNode
} deriving Show
instance FromJSON Entry where
parseJSON (Object o) = Entry <$>
o .: "graph-file" <*>
o .:? "category" <*>
o .:? "definition-scope" <*>
o .:? "definition-description" <*>
o .:? "instance-description" <*>
o .: "instances"
parseJSON _ = error "Unexpected yaml"
instance FromYAML' Entry where
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 = String
type Content = String
type Title = Text
type Content = Text
data Description = Description {
fallbackLang :: Maybe String,
fallbackLang :: Maybe Text,
fallback :: (Maybe Title, Maybe Content),
translations :: Map String (Maybe Title, Maybe Content)
} deriving (Show, Generic)
translations :: Map Text (Maybe Title, Maybe Content)
} deriving Show
instance FromJSON Description where
parseJSON (Object o) = Description <$>
o .:? "fallback-lang" <*>
o .: "fallback" <*>
o .: "translations"
instance FromYAML' Description where
fromYAML (Mapping mapping _ _ _ _) = Description
<$> mapping <|? "fallback-lang"
<*> mapping <| "fallback"
<*> mapping <| "translations"
english = "en-eu";
@ -63,8 +64,8 @@ module Index where
def = description.fallback
in findWithDefault def english description.translations
getEntryByFile :: String -> Index -> Entry
getEntryByFile :: Text -> Index -> Entry
getEntryByFile file index = query (elems index) file where
query :: [Entry] -> String -> Entry
query [] _ = error $ "No entries left for " ++ file
query :: [Entry] -> Text -> Entry
query [] _ = error $ "No entries left for " ++ show file
query (x:xs) file = if x.graphFile == file then x else query xs file

56
app/Main.hs
View File

@ -6,14 +6,16 @@ module Main where
----------------Imports----------------
import Prelude hiding (lookup)
import System.Environment (getArgs)
import System.Directory
import Data.Yaml (ParseException, decodeEither', Value (String, Null))
import Data.Aeson (encode, encodeFile)
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BS.L
import Workflow (Workflow, buildData)
import Export
import YamlParser (parse, ParseState (..), decodeWithComments1, decodeWithComments1Strict, YAMLNode)
import Data.Maybe (fromJust, isNothing, isJust, fromMaybe)
import Data.Either (isLeft, fromLeft, fromRight)
import Data.List (dropWhileEnd)
@ -21,6 +23,16 @@ module Main where
import Text.Regex.TDFA ((=~))
import Index (Index, Entry (Entry), getDefDescription, getInstDescription, getEntryByFile)
import Data.Char (isSpace)
import Data.Text (pack, unpack, Text)
import Data.YAML (decode1Strict, Node, Pos, Parser, parseEither)
import Data.YAML.Event hiding (Scalar)
import Control.Monad (forM_)
import Control.Monad.State.Lazy
import Data.Map.Lazy (Map, insert, lookup, empty)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text.Lazy (toStrict)
import Debug.Trace (trace)
---------------------------------------
@ -33,11 +45,36 @@ module Main where
main :: IO ()
main = getArgs >>= process >>= finish where
process :: [String] -> IO Bool
process [path] = printEvents path >> runParser path >> return True
process args@[_, _] = generateJSON args >> return False
process args@["--all", src, to] = processDirectory src to >> return False
process _ = print "Please provide (1) a source and (2) a target file or provide '--all' and (1) a source and (2) a target directory" >> return True
finish :: Bool -> IO ()
finish abort = if abort then return () else print "Done."
printEvents :: FilePath -> IO ()
printEvents path = do
input <- BS.L.readFile path
forM_ (parseEvents input) $ \ev -> case ev of
Left _ -> error "Failed to parse"
Right event -> putStrLn (show (eEvent event) ++ " @" ++ show (posLine $ ePos event))
runParser :: FilePath -> IO ()
runParser path = do
input <- BS.L.readFile path
-- let events = parseEvents input
-- let mainEvents = validHead events
-- unless (isJust mainEvents) . error $ "Missing DocumentStart event"
-- let initState = PState [] empty []
-- let (rootNode, state) = runState (parse $ fromJust mainEvents) initState
let decoded = decodeWithComments1 input :: Either (Pos, String) YAMLNode -- Workflow
print decoded
-- print rootNode where
-- validHead :: EvStream -> Maybe EvStream
-- validHead ((Right (EvPos StreamStart _)):(Right (EvPos (DocumentStart _) _)):es) = Just es
-- validHead _ = Nothing
@ -47,9 +84,10 @@ module Main where
generateJSON args = do
-- print $ head args
-- print $ last args
putStrLn $ "reading " ++ head args ++ "..."
content <- BS.readFile (head args)
let decoded = decodeEither' content :: Either ParseException Workflow
if isLeft decoded then throw (fromLeft undefined decoded) else do
let decoded = decodeWithComments1Strict content :: Either (Pos, String) Workflow
if isLeft decoded then error (show $ fromLeft undefined decoded) else do
let yaml = fromRight undefined decoded
-- let GData (nodeData, edgeData) = buildData yaml
-- putStrLn $ "\nNode Data:\n\n" ++ show nodeData
@ -85,25 +123,25 @@ module Main where
in (match, relative, absolute)
writeIndex :: Index -> [(String, FilePath)] -> String -> IO () -- content of _index.yaml -> targets -> content for index.json
writeIndex index [] content = print index >> writeFile (to ++ "/index.json") ('[':content)
writeIndex index (x:xs) content = let entry = findEntry (fst x) index
writeIndex index (x:xs) content = let entry = findEntry (pack $ fst x) index
(name1, description1) = getDefDescription entry
(name2, description2) = getInstDescription entry
name = if isJust name1 then name1 else name2
description = if isJust description1 then description1 else description2
url = snd x
format = dropWhileEnd isSpace . map (\y -> if y == '\n' then ' ' else y)
newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (fromMaybe (snd x) name)
newContent = (if null xs then "" else ",\n") ++ "{\n\"name\": \"" ++ format (unpack $ fromMaybe (pack $ snd x) name)
++ "\",\n\"description\": \""
++ format (fromMaybe "" description) ++ "\",\n\"url\": \"" ++ url ++ "\"}"
++ format (unpack $ fromMaybe (pack "") description) ++ "\",\n\"url\": \"" ++ url ++ "\"}"
in writeIndex index xs (newContent ++ content)
decodeIndex :: FilePath -> IO Index
decodeIndex path = do
content <- BS.readFile path
let decoded = decodeEither' content :: Either ParseException Index
let decoded = decodeWithComments1Strict content :: Either (Pos, String) Index
if isLeft decoded
then throw (fromLeft undefined decoded)
then error $ show (fromLeft undefined decoded)
else return $ fromRight undefined decoded
findEntry :: String -> Index -> Entry
findEntry :: Text -> Index -> Entry
findEntry file index = getEntryByFile file index

280
app/Workflow.hs
View File

@ -12,13 +12,20 @@ module Workflow where
----------------Imports----------------
import Data.Yaml
import Data.YAML hiding (Scalar, Mapping, Sequence, encode)
import Data.Aeson(encode, ToJSON (toJSON), ToJSONKey (toJSONKey))
import Control.Applicative hiding (empty)
import GHC.Generics (Generic)
import Data.Map
import Data.Maybe (fromMaybe, isNothing, fromJust)
import Data.Text (pack)
import Data.Text (Text, pack, unpack)
import YamlParser
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy as TL
import Debug.Trace (trace)
import Data.Aeson.Types (toJSONKeyText)
---------------------------------------
@ -26,96 +33,200 @@ module Workflow where
-- | Outer structure of a workflow, i.e. nodes and stages.
data Workflow = Workflow {
nodes :: Map String State,
stages :: Maybe Value
} deriving (Show, Generic)
nodes :: Map Text State,
stages :: Maybe YAMLNode,
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
instance FromJSON Workflow
instance FromYAML' Workflow where
fromYAML (Mapping mapping _ anchor merge pos) = Workflow
<$> mapping <| "nodes"
<*> mapping <|? "stages"
<*> pure anchor
<*> pure merge
-- | Structure of a node.
data State = State {
viewers :: Maybe StateViewers,
payload :: Maybe (Map String Value),
payload :: Maybe (Map Text YAMLNode),
final :: Maybe Final,
edges :: Maybe (Map String Action),
messages :: Maybe [Value]
} deriving (Show, Generic)
edges :: Maybe (Map Text Action),
messages :: Maybe [Message],
comment :: [Comment],
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
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"
instance FromYAML' State where
fromYAML (Mapping mapping comment anchor merge _) = State
<$> mapping <|? "viewers"
<*> mapping <|? "payload-view"
<*> mapping <|? "final"
<*> mapping <|? "edges"
<*> mapping <|? "messages"
<*> pure comment
<*> pure anchor
<*> pure merge
-- | Wrapper for the `final` value of any node.
newtype Final = Final {final :: String} deriving (Show, Generic)
data Final = Final {
final :: Text,
comment :: [Comment],
anchor :: AnchorData
} deriving Show
instance FromJSON Final where
parseJSON v = case v of
String _ -> Final <$> parseJSON v
Bool x -> Final <$> parseJSON (String . pack . show $ x)
instance FromYAML' Final where
fromYAML (Scalar bytes comment anchor _) = Final
<$> pure (decodeUtf8 bytes)
<*> pure comment
<*> pure anchor
-- case scalar of
-- SStr x -> pure . Final $ show x
-- SBool x -> pure . Final $ show x
-- | Structure of the `viewers` object of any node.
data StateViewers = StateViewers {
name :: Either Label String,
viewers :: Maybe [Map String Value]
} deriving (Show, Generic)
name :: Either Label Text,
viewers :: Maybe Viewers,
comment :: [Comment],
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
instance FromJSON StateViewers where
parseJSON (Object o) = StateViewers <$>
((Left <$> o .: "display-label") <|> (Right <$> o .: "display-label")) <*>
o .:? "viewers"
parseJSON _ = error "unexpected stateViewers data format"
instance FromYAML' StateViewers where
fromYAML (Mapping mapping comment anchor merge _) = StateViewers
<$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label"))
<*> mapping <|? "viewers"
<*> pure comment
<*> pure anchor
<*> pure merge
data Viewers = Viewers {
viewers :: [Map Text YAMLNode],
comment :: [Comment],
anchor :: AnchorData
} deriving Show
newtype Actors = Actors Viewers deriving Show
instance FromYAML' Viewers where
fromYAML (Sequence seq comment anchor _) = Viewers
<$> pure (Prelude.map (toV empty) seq)
<*> 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 md p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a md p)
instance FromYAML' Actors where
fromYAML x = Actors <$> fromYAML x
instance ToJSON YAMLNode where
toJSON (Scalar b _ _ _) = toJSON $ decodeUtf8 b
toJSON (Mapping ct _ _ _ _) = toJSON $ fromList ct
toJSON (Sequence ch _ _ _) = toJSON ch
instance ToJSONKey YAMLNode where
toJSONKey = toJSONKeyText display where
display :: YAMLNode -> Text
display (Scalar bytes _ _ _) = decodeUtf8 bytes
-- | Structure of the @display-label@ object of any node or edge.
data Label = Label {
fallback :: Maybe String,
translations :: Maybe Value
} deriving (Show, Generic)
fallback :: Maybe Text,
fallbackLang :: Maybe Text,
translations :: Maybe YAMLNode,
comment :: [Comment],
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
instance FromJSON Label
instance FromYAML' Label where
fromYAML (Mapping mapping comment anchor merge _) = Label
<$> mapping <|? "fallback"
<*> mapping <|? "fallback-lang"
<*> mapping <|? "translations"
<*> pure comment
<*> pure anchor
<*> pure merge
fromYAML (Scalar bytes comment anchor _) = Label
<$> pure (Just . decodeUtf8 $ bytes)
<*> pure (Just . pack $ "de-de-formal")
<*> pure Nothing
<*> pure comment
<*> pure anchor
<*> pure []
-- | Structure of an edge.
data Action = Action {
mode :: Maybe String,
source :: Maybe String,
mode :: Maybe Text,
source :: Maybe Text,
name :: Maybe Label,
actors :: Maybe [Map String Value],
viewActor :: Maybe [Map String Value],
viewers :: Maybe [Map String Value],
messages :: Maybe [Value],
form :: Maybe Value
} deriving (Show, Generic)
actors :: Maybe Actors,
viewActor :: Maybe Viewers,
viewers :: Maybe Viewers,
messages :: Maybe [Message],
form :: Maybe YAMLNode,
comment :: [Comment],
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
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"
instance FromYAML' Action where
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
<*> pure merge
data Message = Message {
content :: Label,
status :: Maybe Text,
viewers :: Maybe Viewers,
comment :: [Comment],
anchor :: AnchorData,
merge :: [MergeData]
} deriving Show
instance FromYAML' Message where
fromYAML (Mapping mapping comment anchor merge _) = Message
<$> mapping <| "content"
<*> mapping <|? "status"
<*> mapping <|? "viewers"
<*> pure comment
<*> pure anchor
<*> pure merge
data Entry = Single String | Dict (Map String Value) | List [Entry] | Val Value deriving(Show, Generic)
data Entry = Single Text
| Msg Message
| Vie Viewers
| Act Actors
| Dict (Map Text YAMLNode)
| List [Entry]
| Val YAMLNode deriving Show
-- | Data of all nodes prepared for JSON encoding.
newtype NodeData = NData (Map String (Map String Entry)) deriving (Show, Generic)
newtype NodeData = NData (Map Text (Map Text Entry)) deriving (Show, Generic)
-- | Data of all edges prepared for JSON encoding.
newtype EdgeData = EData (Map String (Map String Entry)) deriving (Show, Generic)
newtype EdgeData = EData (Map Text (Map Text Entry)) deriving (Show, Generic)
-- | Data of the entire workflow prepared for JSON encoding.
newtype GraphData = GData (NodeData , EdgeData) deriving (Show, Generic)
@ -134,53 +245,60 @@ 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",
viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing,
nodes = insert initID (State {final = Just $ Final "False" [] NoAnchor,
viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor [])) Nothing [] NoAnchor [],
payload = Nothing,
edges = Nothing,
messages = Nothing}) wf.nodes
analyse :: String -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData)
messages = Nothing,
comment = [],
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 String Entry
extract :: State -> Map Text Entry
extract s = fromList [("name", Single name),
("viewers", List $ Prelude.map Dict viewers),
("comment", List $ Prelude.map Single s.comment),
("anchor", Single . pack . show $ s.anchor),
("viewers", Vie viewers),
("final", Single final),
("messages", List $ Prelude.map Val messages),
("messages", List $ Prelude.map Msg messages),
("payload", payload)] where
(name, viewers) = case s.viewers of
Nothing -> ("", [empty :: Map String Value])
Nothing -> ("", Viewers [] [] NoAnchor)
Just x -> case x.name of
Left y -> (fromMaybe "" y.fallback, fromMaybe [empty :: Map String Value] x.viewers)
Right y -> (y, fromMaybe [empty :: Map String Value] x.viewers)
Left y -> (fromMaybe "" y.fallback, fromMaybe (Viewers [] [] NoAnchor) x.viewers)
Right y -> (y, fromMaybe (Viewers [] [] NoAnchor) x.viewers)
final = case s.final of
Nothing -> ""
Just x -> x.final
messages = fromMaybe [] s.messages
payload = maybe (Val Null) Dict s.payload
updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData
payload = maybe (Val (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0))) Dict s.payload
updateEdges :: Text -> Maybe (Map Text 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 Entry
updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (pack $ unpack k ++ "_@_" ++ unpack targetID) (newData k action targetID) eData) e edges
newData :: Text -> Action -> Text -> Map Text Entry
newData ident a targetID = fromList [("name", Single name),
("comment", List $ Prelude.map Single a.comment),
("anchor", Single . pack . show $ a.anchor),
("source", Single source),
("target", Single targetID),
("mode", Single mode),
("actors", List $ Prelude.map Dict actors),
("viewers", List $ Prelude.map Dict viewers),
("view-actor", List $ Prelude.map Dict viewActor),
("messages", List $ Prelude.map Val messages),
("actors", Act actors),
("viewers", Vie viewers),
("view-actor", Vie viewActor),
("messages", List $ Prelude.map Msg messages),
("form", Val form)] where
name = if isNothing a.name
then ident
else case (fromJust a.name).fallback of
Nothing -> show a.name
Nothing -> pack $ show a.name
Just x -> x
source = fromMaybe initID a.source
mode = fromMaybe "" a.mode
actors = fromMaybe [] a.actors
viewers = fromMaybe [] a.viewers
viewActor = fromMaybe [] a.viewActor
actors = fromMaybe (Actors $ Viewers [] [] NoAnchor) a.actors
viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers
viewActor = fromMaybe (Viewers [] [] NoAnchor) a.viewActor
messages = fromMaybe [] a.messages
form = fromMaybe Null a.form
form = fromMaybe (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0)) a.form
---------------------------------------

231
app/YamlParser.hs Normal file
View File

@ -0,0 +1,231 @@
{-# Language DuplicateRecordFields,
NoFieldSelectors,
OverloadedRecordDot #-}
module YamlParser where
import Prelude hiding (lookup)
import qualified Prelude as P
import Control.Monad.State.Lazy
import Data.Map.Lazy (Map, insert, lookup, empty, fromList, toList, (!))
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text.Lazy (toStrict)
import Debug.Trace (trace)
import Data.Maybe (fromJust, isNothing, isJust, fromMaybe)
import Data.Text (pack, unpack, Text)
import Data.YAML (decode1Strict, Node, Pos, Parser, parseEither)
import Data.YAML.Event hiding (Scalar)
import qualified Data.YAML.Event as Y
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as BS.L
activateTrace = False
showTrace :: EvPos -> a -> a
showTrace event action = if activateTrace
then trace (show (eEvent event) ++ " @" ++ show (posLine $ ePos event)) action
else action
data ParseState = PState {
rootNodes :: [YAMLNode],
anchors :: Map Text YAMLNode,
comments :: [Comment] -- YAML comment queue for the next node.
}
data AnchorData = NoAnchor | AnchorDef Text | AnchorAlias Text deriving (Show, Eq, Ord)
data MergeData = MergeData {keys :: [Text], anchor :: AnchorData} deriving (Show, Eq, Ord)
data YAMLNode =
Scalar {
bytes :: BS.ByteString,
{-tag :: Tag,-}
{-style :: Style,-}
comment :: [Comment], -- TODO every node preceded by a scalar preceded by a comment stores said comment
anchorData :: AnchorData,
pos :: Pos
} | Mapping {
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, Eq)
instance Ord YAMLNode where
(Scalar b1 _ _ _) <= (Scalar b2 _ _ _) = b1 <= b2
_ <= _ = undefined
type Comment = Text
parse :: EvStream -> State ParseState YAMLNode
parse ((Right (EvPos (DocumentEnd _) pos)):_) = get >>= \pState -> return $ if length pState.rootNodes == 1
then head pState.rootNodes
else Sequence pState.rootNodes [] NoAnchor pos
parse [] = get >>= \pState -> return $ if length pState.rootNodes == 1
then head pState.rootNodes
else Sequence pState.rootNodes [] NoAnchor undefined
parse ((Right (EvPos StreamStart _)):es) = parseComment es >>= parse
parse ((Right (EvPos (DocumentStart _) _)):es) = parse es
parse es = do
(root, es') <- parseNode es
pState <- get
when (isJust root) . put $ pState {rootNodes = fromJust root : pState.rootNodes}
parse es'
parseComment :: EvStream -> State ParseState EvStream
parseComment ((Right (EvPos (Y.Comment comment) _)):es) = do
pState <- get
put $ pState {comments = comment : pState.comments}
parseComment es
parseComment es = return es
parseNode :: EvStream -> State ParseState (Maybe YAMLNode, EvStream)
parseNode [] = trace "Unexpected eof" $ return (Nothing, [])
parseNode ((Left (p,s)):es) = trace ("Failed to parse: " ++ show s ++ " @ line " ++ show p.posLine) $ parseNode es
parseNode es@((Right (EvPos event pos)):es') = do
pState <- get
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.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)
parseSequence :: EvStream -> Maybe Anchor -> [YAMLNode] -> State ParseState (YAMLNode, EvStream)
parseSequence ((Right (EvPos SequenceEnd pos)):es) anchor children = showTrace (EvPos SequenceEnd pos) $ do
pState <- get
let anchorData = maybe NoAnchor AnchorDef anchor
let seq = Sequence (reverse children) [] anchorData pos
let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) seq pState.anchors
put $ pState {anchors = anchors}
return (seq, es)
parseSequence es anchor children = do
(child, es') <- parseNode es
case child of
Nothing -> parseSequence es' anchor children
Just c -> parseSequence es' anchor (c : children)
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 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 mergeData = do
(maybeKey, es') <- parseNode es
case maybeKey of
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
if 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
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
parseScalar anchor text pos = do
pState <- get
let comments = pState.comments
let anchorData = maybe NoAnchor AnchorDef anchor
let scal = Scalar (encodeUtf8 text) comments anchorData pos
let anchors = if isNothing anchor then pState.anchors else insert (fromJust anchor) scal pState.anchors
put $ pState {anchors = anchors, comments = []}
return scal
parseAlias :: Anchor -> State ParseState YAMLNode
parseAlias anchor = do
pState <- get
case lookup anchor pState.anchors of
Nothing -> error $ "Anchor '" ++ show anchor ++ "' not defined"
Just node -> return node {anchorData = AnchorAlias anchor}
class FromYAML' a where
fromYAML :: YAMLNode -> Parser a
instance FromYAML' a => FromYAML' (Maybe a) where
fromYAML y@(Scalar bs _ _ _)
| decodeUtf8 bs == pack "null" = pure Nothing
| otherwise = Just <$> fromYAML y
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
instance FromYAML' Text where
fromYAML (Scalar bs _ _ _) = pure $ decodeUtf8 bs
instance FromYAML' YAMLNode where
fromYAML = pure
instance FromYAML' v => FromYAML' [v] where
fromYAML (Sequence c _ _ _) = mapM fromYAML c
instance (FromYAML' a, FromYAML' b) => FromYAML' (a,b) where
fromYAML (Sequence [n1, n2] _ _ _) = (,) <$> fromYAML n1
<*> fromYAML n2
decodeWithComments1 :: FromYAML' v => BS.L.ByteString -> Either (Pos, String) v
decodeWithComments1 input = do
let events = parseEvents input
-- let mainEvents = validHead events
-- unless (isJust mainEvents) . error $ "Missing DocumentStart event"
let initState = PState [] empty []
let content = evalState (parse events) initState
parseEither . fromYAML $ content
where
validHead :: EvStream -> Maybe EvStream
validHead ((Right (EvPos StreamStart _)):(Right (EvPos (DocumentStart _) _)):es) = Just es
validHead _ = Nothing
decodeWithComments1Strict :: FromYAML' v => BS.ByteString -> Either (Pos, String) v
decodeWithComments1Strict = decodeWithComments1 . BS.L.fromChunks . (:[])
(<|) :: FromYAML' a => [(YAMLNode, YAMLNode)] -> Text -> Parser a
mapping <| key = maybe (fail $ "key " ++ show key ++ " not found") fromYAML (P.lookup key $ prep mapping) where
prep :: [(YAMLNode, YAMLNode)] -> [(Text, YAMLNode)]
prep mapping = [(decodeUtf8 scalar.bytes, val) | (scalar, val) <- mapping]
(<|?) :: FromYAML' a => [(YAMLNode, YAMLNode)] -> Text -> Parser (Maybe a)
mapping <|? key = maybe (pure Nothing) fromYAML (P.lookup key $ prep mapping) where
prep :: [(YAMLNode, YAMLNode)] -> [(Text, YAMLNode)]
prep mapping = [(decodeUtf8 scalar.bytes, val) | (scalar, val) <- mapping]

32
editor.js
View File

@ -567,9 +567,11 @@ function generatePanelContent(selection) {
viewerList.appendChild(v);
});
children.push(viewerList);
} else if (content instanceof Roles) {
content.format().forEach(child => children.push(child));
} else {
var p = document.createElement('p');
var text = document.createTextNode(JSON.stringify(data[key]));
var text = document.createTextNode((key == 'comment') ? data[key].join(' ') : JSON.stringify(data[key]));
p.appendChild(text);
children.push(p);
}
@ -685,9 +687,7 @@ function prepareWorkflow() {
var messages = [];
state.stateData.messages.forEach(msg => messages.push(new Message(msg)));
state.stateData.messages = messages;
var viewers = [];
state.stateData.viewers.forEach(v => viewers.push(new Role(v)));
state.stateData.viewers = viewers;
state.stateData.viewers = new Viewers(state.stateData.viewers);
state.stateData.payload = new Payload(state.stateData.payload);
nodeIndex.add(state.id, state.name);
})
@ -696,20 +696,14 @@ function prepareWorkflow() {
var messages = [];
action.actionData.messages.forEach(msg => messages.push(new Message(msg)));
action.actionData.messages = messages;
var viewers = [];
action.actionData.viewers.forEach(v => viewers.push(new Role(v)));
action.actionData.viewers = viewers;
var actors = [];
action.actionData.actors.forEach(v => actors.push(new Role(v)));
action.actionData.actors = actors;
var viewActors = [];
action.actionData['actor Viewers'].forEach(v => viewActors.push(new Role(v)));
action.actionData['actor Viewers'] = viewActors;
action.actionData.viewers = new Viewers(action.actionData.viewers);
action.actionData.actors = new Actors(action.actionData.actors);
action.actionData['actor Viewers'] = new Viewers(action.actionData['actor Viewers']);
action.actionData.form = new Payload(action.actionData.form);
actionIndex.add(action.id, action.name);
})
workflow.actions.forEach(act => act.actionData.actors.forEach(a => {
workflow.actions.forEach(act => act.actionData.actors.actors.forEach(a => {
var includes = false;
actors.forEach(actor => includes = includes || equalRoles(a, actor));
(!includes) && actors.push(a);
@ -729,10 +723,10 @@ function prepareWorkflow() {
//Identify all viewers of every action
workflow.actions.forEach(act => {
if (act.actionData.viewers.length === 0) {
if (act.actionData.viewers.viewers.length === 0) {
viewableByAll.push(act.actionData);
} else {
act.actionData.viewers.forEach(v => {
act.actionData.viewers.viewers.forEach(v => {
var includes = false;
viewers.forEach(viewer => includes = includes || equalRoles(v, viewer));
(!includes) && viewers.push(v);
@ -751,7 +745,7 @@ function prepareWorkflow() {
} else if (st.stateData.viewers.length === 0) {
viewableByAll.push(st.stateData);
} else {
st.stateData.viewers.forEach(v => {
st.stateData.viewers.viewers.forEach(v => {
var includes = false;
viewers.forEach(viewer => includes = includes || equalRoles(v, viewer));
(!includes) && viewers.push(v);
@ -871,8 +865,8 @@ function getNodeColour(node) {
|| highlightedSources.includes(node.id) || highlightedTargets.includes(node.id)
var alpha = standard ? 'ff' : '55';
var isSelected = selection === node || rightSelection === node;
if (node.stateData && node.stateData.final !== 'False' && node.stateData.final !== '') {
if (node.stateData.final === 'True' || node.stateData.final === 'ok') {
if (node.stateData && node.stateData.final !== 'false' && node.stateData.final !== '') {
if (node.stateData.final === 'true' || node.stateData.final === 'ok') {
return (isSelected ? '#3ac713' : '#31a810') + alpha;
} else if (node.stateData.final === 'not-ok') {
return (isSelected ? '#ec4e7b' : '#e7215a') + alpha;

8
workflow-visualiser.cabal
View File

@ -27,18 +27,20 @@ executable workflow-visualiser
-- Modules included in this executable, other than Main.
other-modules: Workflow,
Export,
Index
Index,
YamlParser
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:
build-depends: base ^>=4.16.3.0,
yaml >= 0.11.11.0,
HsYAML,
aeson >= 2.1.2.0,
bytestring,
containers,
text,
vector,
directory,
regex-tdfa
regex-tdfa,
mtl
hs-source-dirs: app
default-language: Haskell2010

74
workflow.js
View File

@ -24,6 +24,66 @@ class Role {
}
}
class Roles {
constructor(json, roleName) {
this.roleName = roleName
this.anchor = json.anchor && new Anchor(json.anchor)
this[roleName] = [];
for (const role of json[roleName])
this[roleName].push(new Role(role));
this.comment = json.comment;
}
format() {
var r = document.createElement('h4');
var roles = document.createTextNode('Roles');
r.appendChild(roles);
var rolesList = document.createElement('ul');
this[this.roleName].forEach(r => {
var role = document.createElement('li');
role.appendChild(document.createTextNode(r.name));
rolesList.appendChild(role);
});
var result = [];
if (this.comment.length > 0) {
var c = document.createElement('h4');
c.innerText = 'Comment';
var comment = document.createElement('p');
comment.innerText = this.comment.join(' ');
result.push(c, comment);
}
if (this.anchor) {
var a = document.createElement('h4');
a.appendChild(this.anchor.format());
result.push(a);
} else result.push(r)
result.push(rolesList);
return result;
}
}
class Viewers extends Roles {
constructor(json) {
super(json, 'viewers');
}
}
class Actors extends Roles {
constructor(json) {
super(json, 'actors');
}
}
class Anchor {
constructor(json) {
this.name = json.name;
this.type = json.type;
}
format() {
return document.createTextNode(`${this.type == 'alias' ? '*' : '&'}${this.name}`);
}
}
class Message {
constructor(json) {
@ -32,8 +92,7 @@ class Message {
this.fallbackLang = content['fallback-lang'];
this.translations = content.translations;
this.status = json.status;
this.viewers = [];
json.viewers.forEach(v => this.viewers.push(new Role(v)));
this.viewers = new Viewers(json.viewers);
}
@ -41,19 +100,16 @@ class Message {
var v = document.createElement('h3');
var viewers = document.createTextNode('Viewers');
v.appendChild(viewers);
var viewerList = document.createElement('ul');
this.viewers.forEach(v => {
var viewer = document.createElement('li');
viewer.appendChild(document.createTextNode(v.name));
viewerList.appendChild(viewer);
});
var viewerList = this.viewers.format();
var h = document.createElement('h3');
var heading = document.createTextNode('Status');
h.appendChild(heading);
var p = document.createElement('p');
var text = document.createTextNode(this.status);
p.appendChild(text);
var result = [v, viewerList, h, p];
var result = [v];
result = result.concat(viewerList);
result.push(h, p);
h = document.createElement('h3');
heading = document.createTextNode(this.fallbackLang);
h.appendChild(heading);