fradrive/src/Utils/Workflow/Lint.hs

module Utils.Workflow.Lint
  ( lintWorkflowGraph
  , WorkflowGraphLinterIssue(..)
  ) where

import Import.NoFoundation

import qualified Data.Set as Set
import qualified Data.MultiSet as MultiSet
import qualified Data.Map as Map
import qualified Data.Sequence as Seq

  
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}


data WorkflowGraphLinterIssue
  = WGLUnknownGraphNodeLabel WorkflowGraphNodeLabel
  | WGLPayloadInvisibleInTargetNode (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) WorkflowPayloadLabel
  | WGLFinalNodeHasOutgoingEdges WorkflowGraphNodeLabel | WGLNonFinalNodeHasNoOutgoingEdges WorkflowGraphNodeLabel
  | WGLUndefinedFieldOrder (WorkflowGraphNodeLabel, WorkflowGraphEdgeLabel) (NonNull (MultiSet WorkflowPayloadLabel))
  | WGLNodeUnreachable WorkflowGraphNodeLabel
  | WGLNodeUnfinalizable WorkflowGraphNodeLabel
  deriving (Eq, Ord, Read, Show, Generic, Typeable)

instance Exception WorkflowGraphLinterIssue where
  displayException = \case
    WGLUnknownGraphNodeLabel nodeLbl
      -> unpack [st|Unknown GraphNodeLabel: #{tshow (toPathPiece nodeLbl)}|]
    WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl
      -> unpack [st|Payload #{tshow (toPathPiece payloadLbl)} has form on edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} but no viewers on target node|]
    WGLFinalNodeHasOutgoingEdges nodeLbl
      -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is marked “final” but has outgoing edges|]
    WGLNonFinalNodeHasNoOutgoingEdges nodeLbl
      -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} isn't marked “final” but has no outgoing edges|]
    WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloads
      -> unpack [st|Form for edge #{tshow (toPathPiece edgeLbl)} to target node #{tshow (toPathPiece nodeLbl)} has ill defined field order for payload(s): “#{intercalate ", " (map (tshow . toPathPiece) (MultiSet.elems (toNullable payloads)))}”|]
    WGLNodeUnreachable nodeLbl
      -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} is unreachable from all initial edges|]
    WGLNodeUnfinalizable nodeLbl
      -> unpack [st|Node #{tshow (toPathPiece nodeLbl)} has no path to a final node|]

lintWorkflowGraph :: forall fileid userid. WorkflowGraph fileid userid -> Maybe (NonNull (Set WorkflowGraphLinterIssue))
lintWorkflowGraph graph = fromNullable . Set.fromList $ concatMap ($ graph)
  [ checkEdgesForUnknownGraphNodeLabel
  , checkFormPayloadVisibleInTargetNode -- TODO: Satisfiability of automatic edges?
  , finalMatchesOutgoingEdges
  , checkUndefinedFieldOrder
  , checkNodeUnreachable -- TODO: Satisfiability of automatic edges
  , checkNodeUnfinalizable -- TODO: Satisfiability of automatic edges
    -- Future ideas:
    --   - WorkflowRolePayloadReference for unknown payload
    --   - wgePayloadRestriction for unknown payload
    --   - FieldReference for payload not defined in same form
    --   - WorkflowRolePayloadReference to payload without user fields
    --   - all initial edges have only payload-reference
    --   - cycles of automatic edges (also consider payload restrictions; computationally equivalent to SAT)
    --   - unsatisfiable restrictions
  ]
  where
    checkEdgesForUnknownGraphNodeLabel WorkflowGraph{wgNodes} = foldMap (pure . WGLUnknownGraphNodeLabel) $ Set.fromList edgeNodeLabels `Set.difference` Map.keysSet wgNodes
      where
        edges = foldMap (Map.elems . wgnEdges) wgNodes
        edgeNodeLabels = flip foldMap edges $ \case
          WorkflowGraphEdgeManual{wgeSource} -> pure wgeSource
          WorkflowGraphEdgeAutomatic{wgeSource} -> pure wgeSource
          WorkflowGraphEdgeInitial{} -> []
    checkFormPayloadVisibleInTargetNode WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbl) -> WGLPayloadInvisibleInTargetNode (nodeLbl, edgeLbl) payloadLbl) . Set.toList $ doCheck node) wgNodes
      where
        doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, WorkflowPayloadLabel)
        doCheck WGN{wgnEdges, wgnPayloadView} = ifoldMap (\edgeLbl -> Set.map (edgeLbl, ) . doCheck') wgnEdges
          where
            doCheck' :: WorkflowGraphEdge fileid userid -> Set WorkflowPayloadLabel
            doCheck' wge = fromMaybe Set.empty $ do
              WorkflowGraphEdgeForm{wgefFields} <- wge ^? _wgeForm
              return $ Map.keysSet wgefFields `Set.difference` Map.keysSet wgnPayloadView
    finalMatchesOutgoingEdges WorkflowGraph{wgNodes} = foldMap (\nodeLbl -> pure $ bool WGLFinalNodeHasOutgoingEdges WGLNonFinalNodeHasNoOutgoingEdges (nodeLbl `Set.notMember` markedFinalNodes) nodeLbl) $ markedFinalNodes `setSymmDiff` edgeFinalNodes
      where
        markedFinalNodes = Set.fromList $ do
          (nodeLbl, WGN{wgnFinal}) <- Map.toList wgNodes
          guard $ is _Just wgnFinal
          return nodeLbl
        edgeFinalNodes = Set.fromList $ do
          nodeLbl <- Map.keys wgNodes
          guard $ noneOf (folded . _wgnEdges . folded . _wgeSource) (== nodeLbl) wgNodes
          return nodeLbl
    checkUndefinedFieldOrder WorkflowGraph{wgNodes} = ifoldMap (\nodeLbl node -> map (\(edgeLbl, payloadLbls) -> WGLUndefinedFieldOrder (nodeLbl, edgeLbl) payloadLbls) . Set.toList $ doCheck node) wgNodes
      where
        doCheck :: WorkflowGraphNode fileid userid -> Set (WorkflowGraphEdgeLabel, NonNull (MultiSet WorkflowPayloadLabel))
        doCheck WGN{wgnEdges} = ifoldMap (\edgeLbl -> foldMap (Set.singleton . (edgeLbl, )) . doCheck') wgnEdges
          where
            doCheck' :: WorkflowGraphEdge fileid userid -> [NonNull (MultiSet WorkflowPayloadLabel)]
            doCheck' wge = do
              WorkflowGraphEdgeForm{wgefFields} <- hoistMaybe $ wge ^? _wgeForm
              let MergeMap orderMap = ifoldMap go wgefFields
                    where
                      go :: WorkflowPayloadLabel
                        -> NonNull (Set (NonNull (Map WorkflowGraphEdgeFormOrder (WorkflowPayloadSpec fileid userid))))
                        -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
                      go payloadLbl = foldMap (go' . Map.keysSet . toNullable) . Set.toList . toNullable
                        where
                          go' :: Set WorkflowGraphEdgeFormOrder
                              -> MergeMap WorkflowGraphEdgeFormOrder (NonNull (MultiSet WorkflowPayloadLabel))
                          go' = foldMap $ \formOrder -> MergeMap . Map.singleton formOrder . impureNonNull $ MultiSet.singleton payloadLbl
              filter ((> 1) . MultiSet.size . toNullable) $ Map.elems orderMap
    checkNodeUnreachable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnreachable) $ Map.keysSet wgNodes `Set.difference` reachableNodes
      where
        initialNodes = Map.keysSet $ Map.filter isInitial wgNodes
          where isInitial WGN{wgnEdges} = any (is _WorkflowGraphEdgeInitial) wgnEdges
        reachableNodes = extendAfter graph initialNodes
    checkNodeUnfinalizable WorkflowGraph{wgNodes} = foldMap (pure . WGLNodeUnfinalizable) $ Map.keysSet wgNodes `Set.difference` finalizableNodes
      where
        finalNodes = Map.keysSet $ Map.filter (has $ _wgnFinal . _Just) wgNodes
        finalizableNodes = extendBefore graph finalNodes

extendAfter, extendBefore :: forall fileid userid. WorkflowGraph fileid userid -> Set WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel
extendAfter WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
  where
    go :: Set WorkflowGraphNodeLabel -- ^ Already known reachable
       -> Seq WorkflowGraphNodeLabel -- ^ Queue to check
       -> Set WorkflowGraphNodeLabel
    go known Seq.Empty = known
    go known (n Seq.:<| ns)
      | n `Set.member` known = go known ns
      | otherwise = go (Set.insert n known) $ ns `searchStrategy` nextNodes
      where nextNodes = Map.keysSet $ Map.filter hasSource wgNodes
            hasSource WGN{wgnEdges} = anyOf (folded . _wgeSource) (== n) wgnEdges
extendBefore WorkflowGraph{wgNodes} = go Set.empty . Seq.fromList . Set.toList
  where
    go :: Set WorkflowGraphNodeLabel
       -> Seq WorkflowGraphNodeLabel
       -> Set WorkflowGraphNodeLabel
    go known Seq.Empty = known
    go known (n Seq.:<| ns)
      | n `Set.member` known = go known ns
      | otherwise = go (Set.insert n known) $ ns `searchStrategy` prevNodes
      where
        prevNodes = flip foldMap (wgNodes Map.!? n) $ \WGN{wgnEdges} -> setOf (folded . _wgeSource) wgnEdges

searchStrategy :: Seq WorkflowGraphNodeLabel -> Set WorkflowGraphNodeLabel -> Seq WorkflowGraphNodeLabel
-- ^ BFS
searchStrategy queue next = queue <> Seq.fromList (Set.toList next)