included more information in the parser
This commit is contained in:
parent
61a8beb365
commit
04d9c0969f
@ -19,6 +19,7 @@ module Export where
|
|||||||
toJSON (Single s) = toJSON s
|
toJSON (Single s) = toJSON s
|
||||||
toJSON (Dict d) = toJSON d
|
toJSON (Dict d) = toJSON d
|
||||||
toJSON (List l) = toJSON l
|
toJSON (List l) = toJSON l
|
||||||
|
toJSON (Val v) = toJSON v
|
||||||
|
|
||||||
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
|
||||||
@ -29,7 +30,9 @@ module Export where
|
|||||||
"val" .= show 5, -- Todo adjust to number of edges
|
"val" .= show 5, -- Todo adjust to number of edges
|
||||||
"stateData" .= object [
|
"stateData" .= object [
|
||||||
"viewers" .= values ! "viewers",
|
"viewers" .= values ! "viewers",
|
||||||
"final" .= values ! "final"]] : result
|
"final" .= values ! "final",
|
||||||
|
"messages" .= values ! "messages",
|
||||||
|
"payload" .= values ! "payload"]] : result
|
||||||
-- toEncoding = genericToEncoding defaultOptions
|
-- toEncoding = genericToEncoding defaultOptions
|
||||||
|
|
||||||
instance ToJSON EdgeData where
|
instance ToJSON EdgeData where
|
||||||
@ -43,7 +46,10 @@ module Export where
|
|||||||
"actionData" .= object [
|
"actionData" .= object [
|
||||||
"mode" .= values ! "mode",
|
"mode" .= values ! "mode",
|
||||||
"actors" .= values ! "actors",
|
"actors" .= values ! "actors",
|
||||||
"viewers" .= values ! "viewers"]] : result
|
"viewers" .= values ! "viewers",
|
||||||
|
"actor Viewers" .= values ! "view-actor",
|
||||||
|
"messages" .= values ! "messages",
|
||||||
|
"form" .= values ! "form"]] : result
|
||||||
|
|
||||||
instance ToJSON GraphData where
|
instance ToJSON GraphData where
|
||||||
toJSON (GData (nd, ed)) = object ["states" .= toJSON nd, "actions" .= toJSON ed]
|
toJSON (GData (nd, ed)) = object ["states" .= toJSON nd, "actions" .= toJSON ed]
|
||||||
|
|||||||
@ -32,10 +32,10 @@ module Workflow where
|
|||||||
-- | Structure of a node.
|
-- | Structure of a node.
|
||||||
data State = State {
|
data State = State {
|
||||||
viewers :: Maybe StateViewers,
|
viewers :: Maybe StateViewers,
|
||||||
payload :: Maybe Value,
|
payload :: Maybe (Map String Value),
|
||||||
final :: Maybe Final,
|
final :: Maybe Final,
|
||||||
edges :: Maybe (Map String Action),
|
edges :: Maybe (Map String Action),
|
||||||
messages :: Maybe Value
|
messages :: Maybe [Value]
|
||||||
} deriving (Show, Generic)
|
} deriving (Show, Generic)
|
||||||
|
|
||||||
instance FromJSON State where
|
instance FromJSON State where
|
||||||
@ -86,9 +86,9 @@ module Workflow where
|
|||||||
source :: Maybe String,
|
source :: Maybe String,
|
||||||
name :: Maybe Label,
|
name :: Maybe Label,
|
||||||
actors :: Maybe [Map String Value],
|
actors :: Maybe [Map String Value],
|
||||||
viewActor :: Maybe Value,
|
viewActor :: Maybe [Map String Value],
|
||||||
viewers :: Maybe [Map String Value],
|
viewers :: Maybe [Map String Value],
|
||||||
messages :: Maybe Value,
|
messages :: Maybe [Value],
|
||||||
form :: Maybe Value
|
form :: Maybe Value
|
||||||
} deriving (Show, Generic)
|
} deriving (Show, Generic)
|
||||||
|
|
||||||
@ -105,7 +105,7 @@ module Workflow where
|
|||||||
parseJSON _ = error "unexpected action data format"
|
parseJSON _ = error "unexpected action data format"
|
||||||
|
|
||||||
|
|
||||||
data Entry = Single String | Dict (Map String Value) | List [Entry] deriving(Show, Generic)
|
data Entry = Single String | Dict (Map String Value) | List [Entry] | Val Value deriving(Show, Generic)
|
||||||
|
|
||||||
|
|
||||||
-- | Data of all nodes prepared for JSON encoding.
|
-- | Data of all nodes prepared for JSON encoding.
|
||||||
@ -138,7 +138,11 @@ module Workflow where
|
|||||||
analyse :: String -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData)
|
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)
|
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 String Entry
|
||||||
extract s = fromList [("name", Single name), ("viewers", List $ Prelude.map Dict viewers), ("final", Single final)] where
|
extract s = fromList [("name", Single name),
|
||||||
|
("viewers", List $ Prelude.map Dict viewers),
|
||||||
|
("final", Single final),
|
||||||
|
("messages", List $ Prelude.map Val messages),
|
||||||
|
("payload", payload)] where
|
||||||
(name, viewers) = case s.viewers of
|
(name, viewers) = case s.viewers of
|
||||||
Nothing -> ("", [empty :: Map String Value])
|
Nothing -> ("", [empty :: Map String Value])
|
||||||
Just x -> case x.name of
|
Just x -> case x.name of
|
||||||
@ -147,16 +151,21 @@ module Workflow where
|
|||||||
final = case s.final of
|
final = case s.final of
|
||||||
Nothing -> ""
|
Nothing -> ""
|
||||||
Just x -> x.final
|
Just x -> x.final
|
||||||
|
messages = fromMaybe [] s.messages
|
||||||
|
payload = maybe (Val Null) Dict s.payload
|
||||||
updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData
|
updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData
|
||||||
updateEdges _ Nothing e = e
|
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
|
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
|
newData :: String -> Action -> String -> Map String Entry
|
||||||
newData ident a targetID = fromList [("name", Single name),
|
newData ident a targetID = fromList [("name", Single name),
|
||||||
("source", Single source),
|
("source", Single source),
|
||||||
("target", Single targetID),
|
("target", Single targetID),
|
||||||
("mode", Single mode),
|
("mode", Single mode),
|
||||||
("actors", List $ Prelude.map Dict actors),
|
("actors", List $ Prelude.map Dict actors),
|
||||||
("viewers", List $ Prelude.map Dict viewers)] where
|
("viewers", List $ Prelude.map Dict viewers),
|
||||||
|
("view-actor", List $ Prelude.map Dict viewActor),
|
||||||
|
("messages", List $ Prelude.map Val messages),
|
||||||
|
("form", Val form)] where
|
||||||
name = if isNothing a.name
|
name = if isNothing a.name
|
||||||
then ident
|
then ident
|
||||||
else case (fromJust a.name).fallback of
|
else case (fromJust a.name).fallback of
|
||||||
@ -166,5 +175,8 @@ module Workflow where
|
|||||||
mode = fromMaybe "" a.mode
|
mode = fromMaybe "" a.mode
|
||||||
actors = fromMaybe [] a.actors
|
actors = fromMaybe [] a.actors
|
||||||
viewers = fromMaybe [] a.viewers
|
viewers = fromMaybe [] a.viewers
|
||||||
|
viewActor = fromMaybe [] a.viewActor
|
||||||
|
messages = fromMaybe [] a.messages
|
||||||
|
form = fromMaybe Null a.form
|
||||||
|
|
||||||
---------------------------------------
|
---------------------------------------
|
||||||
@ -66,9 +66,14 @@ body {
|
|||||||
}
|
}
|
||||||
|
|
||||||
#sidecontent {
|
#sidecontent {
|
||||||
|
/* position: absolute;
|
||||||
|
bottom: 20px;
|
||||||
|
left: 20px;
|
||||||
|
right: 20px; */
|
||||||
overflow-y: auto;
|
overflow-y: auto;
|
||||||
overflow-x: hidden;
|
overflow-x: hidden;
|
||||||
text-align: justify;
|
text-align: justify;
|
||||||
hyphens: auto;
|
hyphens: auto;
|
||||||
word-wrap: break-word;
|
word-wrap: break-word;
|
||||||
|
height: 80%;
|
||||||
}
|
}
|
||||||
Loading…
Reference in New Issue
Block a user