From 363f1085c9ff9c811f788c2bfeab0f7048e7c5cb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ond=C5=99ej=20=C5=A0ebek?=
 <44544735+xsebek@users.noreply.github.com>
Date: Sun, 14 Jul 2024 04:20:51 +0200
Subject: [PATCH] Filter recipe graph (#2033)

* add filter options to the recipe graph to cut down the noise
---
 app/doc/Main.hs                | 11 ++++++++--
 src/swarm-doc/Swarm/Doc/Gen.hs | 39 +++++++++++++++++++++++++---------
 2 files changed, 38 insertions(+), 12 deletions(-)

diff --git a/app/doc/Main.hs b/app/doc/Main.hs
index 3b4ee0c1e..37d7e720c 100644
--- a/app/doc/Main.hs
+++ b/app/doc/Main.hs
@@ -8,14 +8,14 @@ import Data.Foldable qualified
 import Data.Maybe (fromMaybe)
 import Data.Text qualified as T
 import Options.Applicative
-import Swarm.Doc.Gen (GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs)
+import Swarm.Doc.Gen (EdgeFilter (..), GenerateDocs (..), PageAddress (..), SheetType (..), generateDocs)
 import Swarm.Doc.Keyword (EditorType (..))
 
 cliParser :: Parser GenerateDocs
 cliParser =
   subparser $
     mconcat
-      [ command "recipes" (info (pure RecipeGraph) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")
+      [ command "recipes" (info (RecipeGraph <$> edgeFilter <**> helper) $ progDesc "Output graphviz dotfile of entity dependencies based on recipes")
       , command "editors" (info (EditorKeywords <$> editor <**> helper) $ progDesc "Output editor keywords")
       , command "keys" (info (pure SpecialKeyNames) $ progDesc "Output list of recognized special key names")
       , command "cheatsheet" (info (CheatSheet <$> address <*> cheatsheet <**> helper) $ progDesc "Output nice Wiki tables")
@@ -30,6 +30,13 @@ cliParser =
       , Just Emacs <$ switch (long "emacs" <> help "Generate for the Emacs editor")
       , Just Vim <$ switch (long "vim" <> help "Generate for the Vim editor")
       ]
+  edgeFilter :: Parser EdgeFilter
+  edgeFilter =
+    Data.Foldable.asum
+      [ pure NoFilter
+      , FilterForward <$ switch (long "forward" <> help "Show only forward edges")
+      , FilterNext <$ switch (long "next" <> help "Show only edges to next group")
+      ]
   address :: Parser PageAddress
   address =
     let replace a b = T.unpack . T.replace a b . T.pack
diff --git a/src/swarm-doc/Swarm/Doc/Gen.hs b/src/swarm-doc/Swarm/Doc/Gen.hs
index cf4136d99..07b26ec6b 100644
--- a/src/swarm-doc/Swarm/Doc/Gen.hs
+++ b/src/swarm-doc/Swarm/Doc/Gen.hs
@@ -17,6 +17,7 @@ module Swarm.Doc.Gen (
 
   -- ** Recipe graph data
   RecipeGraphData (..),
+  EdgeFilter (..),
   classicScenarioRecipeGraphData,
   ignoredEntities,
 ) where
@@ -25,6 +26,7 @@ import Control.Lens (view, (^.))
 import Control.Monad (zipWithM, zipWithM_)
 import Data.Containers.ListUtils (nubOrd)
 import Data.Foldable (toList)
+import Data.List qualified as List
 import Data.List.Extra (enumerate)
 import Data.Map.Lazy (Map, (!))
 import Data.Map.Lazy qualified as Map
@@ -64,7 +66,7 @@ import Text.Dot qualified as Dot
 -- | An enumeration of the kinds of documentation we can generate.
 data GenerateDocs where
   -- | Entity dependencies by recipes.
-  RecipeGraph :: GenerateDocs
+  RecipeGraph :: EdgeFilter -> GenerateDocs
   -- | Keyword lists for editors.
   EditorKeywords :: Maybe EditorType -> GenerateDocs
   -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command
@@ -78,7 +80,7 @@ data GenerateDocs where
 -- | Generate the requested kind of documentation to stdout.
 generateDocs :: GenerateDocs -> IO ()
 generateDocs = \case
-  RecipeGraph -> generateRecipe >>= putStrLn
+  RecipeGraph ef -> generateRecipe ef >>= putStrLn
   EditorKeywords e ->
     case e of
       Just et -> generateEditorKeywords et
@@ -139,13 +141,22 @@ generateSpecialKeyNames =
 -- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES
 -- ----------------------------------------------------------------------------
 
-generateRecipe :: IO String
-generateRecipe = do
+generateRecipe :: EdgeFilter -> IO String
+generateRecipe ef = do
   graphData <- classicScenarioRecipeGraphData
-  return . Dot.showDot $ recipesToDot graphData
+  return . Dot.showDot $ recipesToDot graphData ef
 
-recipesToDot :: RecipeGraphData -> Dot ()
-recipesToDot graphData = do
+data EdgeFilter = NoFilter | FilterForward | FilterNext
+  deriving (Eq, Show)
+
+filterEdge :: EdgeFilter -> Int -> Int -> Bool
+filterEdge ef i o = case ef of
+  NoFilter -> True
+  FilterForward -> i <= o
+  FilterNext -> i + 1 == o
+
+recipesToDot :: RecipeGraphData -> EdgeFilter -> Dot ()
+recipesToDot graphData ef = do
   Dot.attribute ("rankdir", "LR")
   Dot.attribute ("ranksep", "2")
   world <- diamond "World"
@@ -222,15 +233,17 @@ recipesToDot graphData = do
   -- --------------------------------------------------------------------------
   -- add node for the world and draw a line to each entity found in the wild
   -- finally draw recipes
-  let recipeInOut r = [(snd i, snd o) | i <- r ^. recipeInputs, o <- r ^. recipeOutputs]
-      recipeReqOut r = [(snd q, snd o) | q <- r ^. recipeCatalysts, o <- r ^. recipeOutputs]
+  let eFilter = filterEdge ef
+      lvl e = fromMaybe (-1) $ List.findIndex (Set.member e) levels
+      recipeInOut r = [(i, o) | (_, i) <- r ^. recipeInputs, (_, o) <- r ^. recipeOutputs, lvl i `eFilter` lvl o]
+      recipeReqOut r = [(q, o) | (_, q) <- r ^. recipeCatalysts, (_, o) <- r ^. recipeOutputs, lvl q `eFilter` lvl o]
       recipesToPairs f rs = both nid <$> nubOrd (concatMap f rs)
   mapM_ (uncurry (.->.)) (recipesToPairs recipeInOut recipes)
   mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut recipes)
   -- --------------------------------------------------------------------------
   -- also draw an edge for each entity that "yields" another entity
   let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . toList $ rgAllEntities graphData
-  mapM_ (uncurry (.->.)) (both getE <$> yieldPairs)
+  mapM_ (uncurry (.-<>.)) (both getE <$> yieldPairs)
 
 data RecipeGraphData = RecipeGraphData
   { rgWorldEntities :: Set Entity
@@ -336,6 +349,12 @@ diamond = customNode [("shape", "diamond")]
 hiddenNode :: Dot NodeId
 hiddenNode = Dot.node [("style", "invis")]
 
+-- | Edge for yielded entities.
+(.-<>.) :: NodeId -> NodeId -> Dot ()
+e1 .-<>. e2 = Dot.edge e1 e2 attrs
+ where
+  attrs = [("arrowhead", "diamond"), ("color", "purple")]
+
 -- | Hidden edge - used for layout.
 (.~>.) :: NodeId -> NodeId -> Dot ()
 i .~>. j = Dot.edge i j [("style", "invis")]