255 lines
11 KiB
Haskell
255 lines
11 KiB
Haskell
{-# Language DuplicateRecordFields,
|
|
NoFieldSelectors,
|
|
OverloadedRecordDot,
|
|
OverloadedStrings,
|
|
DeriveGeneric #-}
|
|
|
|
module Workflow where
|
|
|
|
----------------Imports----------------
|
|
|
|
import Data.YAML hiding (Scalar, Mapping, Sequence)
|
|
import Control.Applicative hiding (empty)
|
|
import GHC.Generics (Generic)
|
|
import Data.Map
|
|
import Data.Maybe (fromMaybe, isNothing, fromJust)
|
|
import Data.Text (Text, pack)
|
|
import Parser
|
|
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
|
|
|
---------------------------------------
|
|
|
|
|
|
---------Data Types & Instances--------
|
|
|
|
-- | Outer structure of a workflow, i.e. nodes and stages.
|
|
data Workflow = Workflow {
|
|
nodes :: Map Text State,
|
|
stages :: Maybe YAMLNode,
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' Workflow where
|
|
fromYAML (Mapping mapping _ anchor pos) = Workflow
|
|
<$> mapping <| "nodes"
|
|
<*> mapping <|? "stages"
|
|
<*> pure anchor
|
|
|
|
|
|
-- | Structure of a node.
|
|
data State = State {
|
|
viewers :: Maybe StateViewers,
|
|
payload :: Maybe (Map Text YAMLNode),
|
|
final :: Maybe Final,
|
|
edges :: Maybe (Map Text Action),
|
|
messages :: Maybe [Message],
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' State where
|
|
fromYAML (Mapping mapping comment anchor _) = State
|
|
<$> mapping <|? "viewers"
|
|
<*> mapping <|? "payload-view"
|
|
<*> mapping <|? "final"
|
|
<*> mapping <|? "edges"
|
|
<*> mapping <|? "messages"
|
|
<*> pure comment
|
|
<*> pure anchor
|
|
|
|
|
|
-- | Wrapper for the `final` value of any node.
|
|
data Final = Final {
|
|
final :: String,
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' Final where
|
|
fromYAML (Scalar bytes comment anchor _) = Final
|
|
<$> pure (show $ 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 Text,
|
|
viewers :: Maybe Viewers,
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' StateViewers where
|
|
fromYAML (Mapping mapping comment anchor _) = StateViewers
|
|
<$> ((Left <$> mapping <| "display-label") <|> (Right <$> mapping <| "display-label"))
|
|
<*> mapping <|? "viewers"
|
|
<*> pure comment
|
|
<*> pure anchor
|
|
|
|
|
|
data Viewers = Viewers {
|
|
viewers :: [Map Text YAMLNode],
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} 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 p) = insert (decodeUtf8 b) v $ toV m (Mapping xs c a p)
|
|
|
|
|
|
|
|
-- | Structure of the @display-label@ object of any node or edge.
|
|
data Label = Label {
|
|
fallback :: Maybe Text,
|
|
fallbackLang :: Maybe Text,
|
|
translations :: Maybe YAMLNode,
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' Label where
|
|
fromYAML (Mapping mapping comment anchor _) = Label
|
|
<$> mapping <|? "fallback"
|
|
<*> mapping <|? "fallback-lang"
|
|
<*> mapping <|? "translations"
|
|
<*> pure comment
|
|
<*> pure anchor
|
|
|
|
|
|
-- | Structure of an edge.
|
|
data Action = Action {
|
|
mode :: Maybe Text,
|
|
source :: Maybe Text,
|
|
name :: Maybe Label,
|
|
actors :: Maybe Viewers,
|
|
viewActor :: Maybe Viewers,
|
|
viewers :: Maybe Viewers,
|
|
messages :: Maybe [Message],
|
|
form :: Maybe YAMLNode,
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' Action where
|
|
fromYAML (Mapping mapping comment anchor _) = Action
|
|
<$> mapping <|? "mode"
|
|
<*> mapping <|? "source"
|
|
<*> mapping <|? "display-label"
|
|
<*> mapping <|? "actors"
|
|
<*> mapping <|? "view-actor"
|
|
<*> mapping <|? "viewers"
|
|
<*> mapping <|? "messages"
|
|
<*> mapping <|? "form"
|
|
<*> pure comment
|
|
<*> pure anchor
|
|
|
|
data Message = Message {
|
|
content :: Label,
|
|
status :: Maybe Text,
|
|
viewers :: Maybe Viewers,
|
|
comment :: [Comment],
|
|
anchor :: AnchorData
|
|
} deriving Show
|
|
|
|
instance FromYAML' Message where
|
|
fromYAML (Mapping mapping comment anchor _) = Message
|
|
<$> mapping <| "content"
|
|
<*> mapping <|? "status"
|
|
<*> mapping <|? "viewers"
|
|
<*> pure comment
|
|
<*> pure anchor
|
|
|
|
|
|
data Entry = Single Text
|
|
| Msg Message
|
|
| Vie Viewers
|
|
| Dict (Map Text YAMLNode)
|
|
| List [Entry]
|
|
| Val YAMLNode deriving Show
|
|
|
|
|
|
-- | Data of all nodes prepared for JSON encoding.
|
|
newtype NodeData = NData (Map Text (Map Text Entry)) deriving (Show, Generic)
|
|
-- | Data of all edges prepared for JSON encoding.
|
|
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)
|
|
|
|
---------------------------------------
|
|
|
|
|
|
---------------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" [] NoAnchor,
|
|
viewers = Just $ StateViewers (Left (Label (Just initID) Nothing Nothing [] NoAnchor)) Nothing [] NoAnchor,
|
|
payload = Nothing,
|
|
edges = Nothing,
|
|
messages = Nothing,
|
|
comment = [],
|
|
anchor = NoAnchor}) 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
|
|
extract s = fromList [("name", Single name),
|
|
("viewers", Vie viewers),
|
|
("final", Single $ pack final),
|
|
("messages", List $ Prelude.map Msg messages),
|
|
("payload", payload)] where
|
|
(name, viewers) = case s.viewers of
|
|
Nothing -> ("", Viewers [] [] NoAnchor)
|
|
Just x -> case x.name of
|
|
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 (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 (pack $ show k ++ "_@_" ++ show targetID) (newData k action targetID) eData) e edges
|
|
newData :: Text -> Action -> Text -> Map Text Entry
|
|
newData ident a targetID = fromList [("name", Single name),
|
|
("source", Single source),
|
|
("target", Single targetID),
|
|
("mode", Single mode),
|
|
("actors", Vie 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 -> pack $ show a.name
|
|
Just x -> x
|
|
source = fromMaybe initID a.source
|
|
mode = fromMaybe "" a.mode
|
|
actors = fromMaybe (Viewers [] [] NoAnchor) a.actors
|
|
viewers = fromMaybe (Viewers [] [] NoAnchor) a.viewers
|
|
viewActor = fromMaybe (Viewers [] [] NoAnchor) a.viewActor
|
|
messages = fromMaybe [] a.messages
|
|
form = fromMaybe (Scalar (encodeUtf8 "null") [] NoAnchor (Pos 0 0 0 0)) a.form
|
|
|
|
--------------------------------------- |