{-# 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 ---------------------------------------