{-# 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 YamlParser import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Debug.Trace (trace) --------------------------------------- ---------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, merge :: [MergeData] } deriving Show 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 Text YAMLNode), final :: Maybe Final, edges :: Maybe (Map Text Action), messages :: Maybe [Message], comment :: [Comment], anchor :: AnchorData, merge :: [MergeData] } deriving Show 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. 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, merge :: [MergeData] } deriving Show 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 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) -- | 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, merge :: [MergeData] } deriving Show 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 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, merge :: [MergeData] } deriving Show 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 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, 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 extract s = fromList [("name", Single name), ("comment", List $ Prelude.map Single s.comment), ("anchor", Single . pack . show $ s.anchor), ("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), ("comment", List $ Prelude.map Single a.comment), ("anchor", Single . pack . show $ a.anchor), ("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 ---------------------------------------