From 9829b61e8d472bfd87c709d4fd2b81d80272d6e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 14 Jul 2024 01:13:51 +0200 Subject: [PATCH 1/2] Filter recipe graph --- 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..440be2301 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")] +-- | Hidden edge - used for layout. +(.-<>.) :: 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")] From e69fc54fc65c5dca4fca20a1e6b57accfa815a1e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ondr=CC=8Cej=20S=CC=8Cebek?= Date: Sun, 14 Jul 2024 01:23:40 +0200 Subject: [PATCH 2/2] Fix doc --- src/swarm-doc/Swarm/Doc/Gen.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/swarm-doc/Swarm/Doc/Gen.hs b/src/swarm-doc/Swarm/Doc/Gen.hs index 440be2301..07b26ec6b 100644 --- a/src/swarm-doc/Swarm/Doc/Gen.hs +++ b/src/swarm-doc/Swarm/Doc/Gen.hs @@ -349,7 +349,7 @@ diamond = customNode [("shape", "diamond")] hiddenNode :: Dot NodeId hiddenNode = Dot.node [("style", "invis")] --- | Hidden edge - used for layout. +-- | Edge for yielded entities. (.-<>.) :: NodeId -> NodeId -> Dot () e1 .-<>. e2 = Dot.edge e1 e2 attrs where