uni2work.workflows.visualiser/app/Workflow.hs

-- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# Language DuplicateRecordFields,
    NoFieldSelectors,
    OverloadedRecordDot,
    OverloadedStrings,
    DeriveGeneric #-}

module Workflow where

  ----------------Imports----------------

  import Data.Yaml
  import Control.Applicative hiding (empty)
  import GHC.Generics (Generic)
  import Data.Map
  import Data.Maybe (fromMaybe, isNothing, fromJust)
  import Data.Text (pack)

  ---------------------------------------


  ---------Data Types & Instances--------
  
  -- | Outer structure of a workflow, i.e. nodes and stages.
  data Workflow = Workflow {
    nodes  :: Map String State,
    stages :: Maybe Value
  } deriving (Show, Generic)

  instance FromJSON Workflow


  -- | Structure of a node.
  data State = State {
    viewers  :: Maybe StateViewers,
    payload  :: Maybe (Map String Value),
    final    :: Maybe Final,
    edges    :: Maybe (Map String Action),
    messages :: Maybe [Value]
  } deriving (Show, Generic)

  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"

  
  -- | Wrapper for the `final` value of any node.
  newtype Final =  Final {final :: String} deriving (Show, Generic)

  instance FromJSON Final where
    parseJSON v = case v of
                    String _ -> Final <$> parseJSON v
                    Bool x   -> Final <$> parseJSON (String . pack . 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)

  instance FromJSON StateViewers where
    parseJSON (Object o) = StateViewers <$>
                           ((Left <$> o .:  "display-label") <|> (Right <$> o .:  "display-label")) <*>
                           o .:? "viewers"
    parseJSON _ = error "unexpected stateViewers data format"


  
  -- | Structure of the @display-label@ object of any node or edge.
  data Label = Label {
    fallback :: Maybe String,
    translations :: Maybe Value
  } deriving (Show, Generic)

  instance FromJSON Label


  -- | Structure of an edge.
  data Action = Action {
    mode      :: Maybe String,
    source    :: Maybe String,
    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)

  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"


  data Entry = Single String | Dict (Map String Value) | List [Entry] | Val Value deriving(Show, Generic)
  
  
  -- | Data of all nodes prepared for JSON encoding.
  newtype NodeData  = NData (Map String (Map String Entry)) deriving (Show, Generic)
  -- | Data of all edges prepared for JSON encoding.
  newtype EdgeData  = EData (Map String (Map String 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",
                                  viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing,
                                  payload = Nothing,
                                  edges = Nothing,
                                  messages = Nothing}) wf.nodes
    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)
    extract :: State -> Map String Entry
    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
                          Nothing -> ("", [empty :: Map String Value])
                          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)
      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
    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
    newData ident a targetID = fromList [("name",       Single name),
                                         ("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),
                                         ("form",       Val form)] where
      name = if isNothing a.name
             then ident
             else case (fromJust a.name).fallback of
                  Nothing -> 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
      messages = fromMaybe [] a.messages
      form = fromMaybe Null a.form

  ---------------------------------------