graphwiz 2.0.0 → 3.0.0

raw patch · 10 files changed

+398/−237 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +52/−4
• example/Main.hs +9/−1
• graphwiz.cabal +1/−1
• src/Text/Dot.hs +6/−5
• src/Text/Dot/Build.hs +91/−83
• src/Text/Dot/Monad.hs +54/−8
• src/Text/Dot/Render.hs +79/−112
• src/Text/Dot/Types.hs +65/−4
• test/Golden.hs +35/−19

@@ -5,3 +5,9 @@ 2.0.0 ----- * Upgrade text-builder to 1.0++3.0.0+-----+* Add node anchoring: edges can be created by referring to an entity's name, even if that name hasn't been registered yet, allowing for cycles and reducing the amount of manual bookkeeping+* Remove `subgraphWith` and `clusterWith` functions, as the subgraph or cluster's entity is always accessible via `its` or `itsID`+* Resolve `lhead` and `ltail` as late possible, fixing a rare edge case where an edge pointing to a cluster would not set the attributes properly.

@@ -31,9 +31,43 @@     b --> c ``` +### Node anchoring++To avoid having to keep track of entities manually, it's possible to register any `Entity` under a given name, and to create edges by referring to that name. As names are resolved when the graph is complete, it is possible to make reference to a name that hasn't been registered yet, allowing for cycles:++```haskell+digraph do+  cluster do+    its label ?= "function entry"+    n1 <- node "jump"+    n1 --> retrieve "while condition"++  cluster do+    its label ?= "while condition"+    registerItAs "while condition"+    n1 <- node "test EQ"+    n2 <- node "branch"+    n1 --> n2+    n2 --> retrieve "while body"+    n2 --> retrieve "function end"++  cluster do+    its label ?= "while body"+    registerItAs "while body"+    n1 <- node "increment variable"+    n2 <- node "jump"+    n1 --> n2+    n2 --> retrieve "while condition"++  cluster do+    its label ?= "function end"+    registerItAs "function end"+    node "return"+```+ ### Attributes -You can set default attributes for an entity type with `defaults`. You can access the attributes of a specific entity with `attributes`, and the latest created entity's attributes are accessible with `its`. All of those give you lenses to values within the underlying state; you can manipulate them with the `=` [lens operators](https://hackage.haskell.org/package/lens-5.3.3/docs/Control-Lens-Setter.html#g:5).+Default attributes for an entity type can be set  with `defaults`, attributes of a specific entity with `attributes`. The latest created entity's attributes are accessible with `its`. All of those give you lenses to values within the underlying state; you can manipulate them with the `=` [lens operators](https://hackage.haskell.org/package/lens-5.3.3/docs/Control-Lens-Setter.html#g:5).  Attributes are represented as a simple mapping from `Text` to `Text`, to avoid being too restrictive. There is, however, one lens per attribute listed in the [Graphviz documentation](https://graphviz.org/doc/info/attrs.html), allowing you to avoid strings in attributes declarations. @@ -79,11 +113,11 @@ ##### Haskell source ```haskell main =-  TB.putLnToStdOut $+  T.putStrLn $ TB.toText $     digraph do       defaults Node . style ?= "filled" -      ast <- cluster_ do+      ast <- cluster do         its label ?= "front end"          source <- node "source code"@@ -101,18 +135,27 @@         its label ?= "middle end"          ir <- node "IR"-        its shape     ?= "diamond"+        its shape   ?= "diamond"         its fillcolor ?= "salmon"          ast --> ir         its label ?= "lowering"         its style ?= "dotted"++        ir --> retrieve "backend"++      cluster do+        its label ?= "back end"+        registerItAs "backend"+        node "{%1 = cmp %0,0 | br i1 i2 %1}"+        its shape ?= "record" ```  #### Resulting DOT file  ```DOT digraph {+  compound="true";   subgraph cluster0 {     label="front end";     node1 [label="source code",style="filled",fillcolor="#c3ffd8"]@@ -124,6 +167,11 @@     node5 [label="IR",style="filled",fillcolor="salmon",shape="diamond"]     node2 -> node5 [label="lowering",style="dotted"]   }+  subgraph cluster8 {+    label="back end";+    node9 [label="{%1 = cmp %0,0 | br i1 i2 %1}",style="filled",shape="record"]+  }+  node5 -> node9 [lhead="cluster8"] } ``` 

@@ -11,7 +11,7 @@     digraph do       defaults Node . style ?= "filled" -      ast <- cluster_ do+      ast <- cluster do         its label ?= "front end"          source <- node "source code"@@ -35,3 +35,11 @@         ast --> ir         its label ?= "lowering"         its style ?= "dotted"++        ir --> retrieve "backend"++      cluster do+        its label ?= "back end"+        registerItAs "backend"+        node "{%1 = cmp %0,0 | br i1 i2 %1}"+        its shape ?= "record"

@@ -1,7 +1,7 @@ cabal-version:      3.4 name:               graphwiz synopsis:           Monadic DOT graph builder DSL-version:            2.0.0+version:            3.0.0 category:           Data, Text license:            BSD-3-Clause license-file:       LICENSE

@@ -21,6 +21,7 @@   , EntityType (..)   , getType   , itsID+  , rootGraph     -- * Attributes #attributes#   , Attributes   , attributes@@ -32,14 +33,15 @@   , node   , edge   , (-->)-  , subgraphWith+  , retrieve   , subgraph-  , subgraphWith_   , subgraph_-  , clusterWith   , cluster-  , clusterWith_   , cluster_+  , register+  , registerItAs+  , ToEdgeNode+  , EdgeNode     -- * Monad #monad#   , DotT   , Dot@@ -47,7 +49,6 @@   , DotGraph   , Path   , currentPath-  , rootGraph     -- * Rendering the graph #render#   , module Render     -- * Re-exports from "Control.Lens.Setter"

@@ -2,19 +2,19 @@   ( node   , edge   , (-->)-  , subgraphWith   , subgraph-  , subgraphWith_   , subgraph_-  , clusterWith   , cluster-  , clusterWith_   , cluster_+  , registerItAs+  , register+  , retrieve   ) where  import "this" Prelude  import Control.Lens+import Data.HashMap.Strict qualified as M import Data.List.NonEmpty  qualified as NE  import Text.Dot.Attributes@@ -34,7 +34,7 @@ -- This function updates the 'its' entity to this node. node :: MonadDot m => Text -> m Entity node desc = do-  entity <- register Node+  entity <- record Node   its label ?= desc   pure entity @@ -44,17 +44,39 @@ -- (see 'defaults'). This returns a new t'Entity' that uniquely identifies this -- edge in the graph. ----- If an entity is a cluster, we set the graph's "compound" property to true,--- and we attempt to locate any node within it. If there isn't any, we fail--- silently by outputing a valid but unexpected edge.+-- There are two ways to specify each end of an edge: either by directly giving+-- an entity, or by giving an entity's "name", registered via 'register', and+-- obtained via 'retrieve'. The name is only resolved after the entire graph has+-- been processed; this method allows the user to reference a node that has yet+-- to be created, or to reference a node without manually propagating its+-- entity. --+-- > digraph do+-- >   x <- node "x"+-- >   y <- node "y"+-- >   edge x y+-- >   edge (retrieve "z node") x+-- >   edge y (retrieve "z node")+-- >   z <- node "z"+-- >   registerItAs "z node"+--+-- If any of the two target entiies is a cluster, the root graph's "compound"+-- property will be set to true, and the edge will be adjusted to make use of+-- 'lhead' or 'ltail' accordingly.+--+-- If an edge makes reference to a node that doesn't exist yet (see 'retrieve'),+-- its declaration will be moved to the top level of the graph, but its+-- attributes will remain unchanged.+-- -- This function updates the 'its' entity to this edge.-edge :: MonadDot m => Entity -> Entity -> m Entity+edge+  :: (ToEdgeNode a, ToEdgeNode b, MonadDot m)+  => a+  -> b+  -> m Entity edge a b = do-  na <- getTail a-  nb <- getHead b-  entity <- register Edge-  edgeInfo . at entity ?= EdgeInfo a b na nb+  entity <- record Edge+  edgeInfo . at entity ?= EdgeInfo (toEdgeNode a) (toEdgeNode b) Nothing Nothing   pure entity  -- | Alias for 'edge'.@@ -70,81 +92,95 @@ -- >   x --> z -- -- This function updates the 'its' entity to this edge.-(-->) :: MonadDot m => Entity -> Entity -> m Entity+(-->)+  :: (ToEdgeNode a, ToEdgeNode b, MonadDot m)+  => a+  -> b+  -> m Entity (-->) = edge  -- | Creates a subgraph in the given context. -- -- The newly created subgraph will be assigned all of the default 'Subgraph'--- attributes (see 'defaults'). The argument to this function is a callback that--- takes the newly minted t'Entity' and creates the corresponding subgraph.+-- attributes (see 'defaults'). The argument to this function is an action in+-- the monad: all entities created in this action will be added to this new+-- subgraph. -- -- This function updates the 'its' entity to this node *twice*: before executing -- the callback, and before returning. -- -- > graph do--- >   (subgraphID, nodeID) <- subgraphWith \subgraphID -> do+-- >   subgraph_ do -- >     its fontcolor ?= "green" -- points to the subgraph -- >     x <- node "x" -- >     its fontcolor ?= "red"   -- points to node "x" -- >     pure x -- >   use (its fontcolor)        -- points to the subgraph, returns green ----- This returns a pair containing the subgraph's t'Entity' and the result of the--- subexpression.-subgraphWith :: MonadDot m => (Entity -> m a) -> m (Entity, a)-subgraphWith = recurse Subgraph---- | Like 'subgraphWith', but the subexpression doesn't take the t'Entity' as--- argument.-subgraph :: MonadDot m => m a -> m (Entity, a)-subgraph = recurse Subgraph . const---- | Like 'subgraphWith', but does not return the subgraph's t'Entity'.-subgraphWith_ :: MonadDot m => (Entity -> m a) -> m a-subgraphWith_ = fmap snd . recurse Subgraph+-- The resulting monadic action will return the value return by the given action.+subgraph :: MonadDot m => m a -> m a+subgraph = recurse Subgraph --- | Like 'subgraphWith', but the subexpression doesn't take the t'Entity' as--- argument, and it does not return the subgraph's t'Entity'.-subgraph_ :: MonadDot m => m a -> m a-subgraph_ = fmap snd . recurse Subgraph . const+-- | Like 'subgraph', but ignores the result of the nested action.+subgraph_ :: MonadDot m => m a -> m ()+subgraph_ = void . recurse Subgraph --- | Like 'subgraphWith', but creates a cluster instead.+-- | Like 'subgraph', but creates a cluster instead. -- -- The created entity will use the default 'Cluster' attributes.-clusterWith :: MonadDot m => (Entity -> m a) -> m (Entity, a)-clusterWith = recurse Cluster+cluster :: MonadDot m => m a -> m a+cluster = recurse Cluster --- | Like 'clusterWith', but the subexpression doesn't take the t'Entity' as--- argument.-cluster :: MonadDot m => m a -> m (Entity, a)-cluster = recurse Cluster . const+-- | Like 'cluster', but ignores the result of the nested action.+cluster_ :: MonadDot m => m a -> m ()+cluster_ = void . recurse Cluster --- | Like 'clusterWith', but does not return the cluster's t'Entity'.-clusterWith_ :: MonadDot m => (Entity -> m a) -> m a-clusterWith_ = fmap snd . recurse Cluster+-- | Associate the given entity to the given name.+--+-- The 'DotT' monad will store an association from the name to the entity,+-- allowing edges to be declared by making reference to that name using+-- 'Text.Dot.retrieve'.+--+-- > digraph do+-- >   cluster_ do+-- >     cluster_ do+-- >       cluster_ do+-- >         cluster_ do+-- >           a <- node "A"+-- >           register a "the A node"+-- >   b <- node "B"+-- >   edge (retrieve "the A node") b+--+-- See also 'Text.Dot.edge'.+register :: MonadDot m => Entity -> Text -> m ()+register entity name = do+  entityRegister %= M.insert name entity --- | Like 'clusterWith', but the subexpression doesn't take the t'Entity' as--- argument, and it does not return the cluster's t'Entity'.-cluster_ :: MonadDot m => m a -> m a-cluster_ = fmap snd . recurse Cluster . const+-- | Associate the latest entity to the given name.+--+-- Like 'register', but uses the last created entity.+registerItAs :: MonadDot m => Text -> m ()+registerItAs name = do+  currentEntity <- itsID+  register currentEntity name  + -------------------------------------------------------------------------------- -- Internal helpers -recurse :: MonadDot m => EntityType -> (Entity -> m a) -> m (Entity, a)-recurse etype callback = do-  entity <- register etype+recurse :: MonadDot m => EntityType -> m a -> m a+recurse etype action = do+  entity <- record etype   contextStack %= NE.cons mempty-  result <- withPath entity $ callback entity+  result <- withPath entity action   sub <- popContext   subgraphInfo . at entity ?= sub   latest .= entity-  pure (entity, result)+  pure result -register :: MonadDot m => EntityType -> m Entity-register etype = do+record :: MonadDot m => EntityType -> m Entity+record etype = do   suffix <- use entityIndex   let entity = Entity etype suffix   defAttrs <- use $ defaultAttributes . at etype . non mempty@@ -153,31 +189,3 @@   attributes entity .= defAttrs   latest .= entity   pure entity--getTail, getHead :: MonadDot m => Entity -> m Entity-getTail eid =-  case getType eid of-    Cluster -> do-      g <- rootGraph-      attributes g . compound ?= "true"-      fromMaybe eid <$> locateNode eid-    _ -> pure eid-getHead eid =-  case getType eid of-    Cluster -> do-      g <- rootGraph-      attributes g . compound ?= "true"-      fromMaybe eid <$> locateNode eid-    _ -> pure eid--locateNode :: MonadDot m => Entity -> m (Maybe Entity)-locateNode e = do-  dg <- get-  pure $ e ^? go dg-  where-    go dg f eid =-      case getType eid of-        Cluster  -> foldMapOf (subgraphInfo . at eid . traverse . traverse) (go dg f) dg-        Subgraph -> foldMapOf (subgraphInfo . at eid . traverse . traverse) (go dg f) dg-        Node     -> f eid-        Edge     -> mempty

@@ -3,9 +3,12 @@ import "this" Prelude  import Control.Lens-import Control.Monad.RWS.Class-import Data.List.NonEmpty      qualified as NE+import Control.Monad.Writer+import Data.HashMap.Strict  qualified as M+import Data.List.NonEmpty   qualified as NE+import Data.Text            qualified as T +import Text.Dot.Attributes import Text.Dot.Types  @@ -37,8 +40,10 @@ -- for simplicity. type MonadDot m = (MonadState DotGraph m, MonadReader Path m) -run :: Monad m => Entity -> DotT m a -> m DotGraph-run e (DotT f) = snd <$> f (initialGraph e) (Path $ pure e)+run :: Monad m => DotT m a -> m DotGraph+run action =+  let DotT f = action >> postProcess+  in  snd <$> f initialGraph (Path $ pure rootGraph)   --------------------------------------------------------------------------------@@ -63,10 +68,6 @@ itsID :: MonadDot m => m Entity itsID = use latest --- | Retrieves the unique ID of the top-level graph.-rootGraph :: MonadDot m => m Entity-rootGraph = views _Path NE.last- withPath :: MonadDot m => Entity -> m a -> m a withPath e = local (_Path <>:~ pure e) @@ -81,3 +82,48 @@   c <- use context   contextStack %= NE.fromList . NE.tail   pure c++postProcess :: Monad m => DotT m ()+postProcess = do+  fixedEdges <- traverse fixEdge =<< use edgeInfo+  edgeInfo .= fixedEdges+  where+    fixEdge (EdgeInfo a b _ _) = do+      ea <- resolve a+      eb <- resolve b+      na <- getEnd ea+      nb <- getEnd eb+      pure $ EdgeInfo (KnownNode ea) (KnownNode eb) na nb++    resolve = \case+      KnownNode   eid  -> pure eid+      UnknownNode name -> dereference name++    getEnd eid =+      case getType eid of+        Cluster -> do+          attributes rootGraph . compound ?= "true"+          locateNode eid+        _ -> pure Nothing++    locateNode eid = do+      dg <- get+      pure $ eid ^? visit dg++    visit dg f eid =+      case getType eid of+        Cluster  -> foldMapOf (subgraphInfo . at eid . traverse . traverse) (visit dg f) dg+        Subgraph -> foldMapOf (subgraphInfo . at eid . traverse . traverse) (visit dg f) dg+        Node     -> f eid+        Edge     -> mempty++dereference :: Monad m => Text -> DotT m Entity+dereference name = do+  uses entityRegister (M.lookup name) >>= \case+    Just eid -> pure eid+    Nothing -> do+      error $ concat+        [ "Text.Dot.Monad.retrieve: unknown entity \""+        , T.unpack name+        , "\"\nall names must be registered via a call to `register` or `registerItAs`"+        ]

@@ -1,25 +1,19 @@ module Text.Dot.Render-  ( graphWithT-  , graphT-  , graphWith+  ( graphT   , graph-  , digraphWithT   , digraphT-  , digraphWith   , digraph-  , strictGraphWithT   , strictGraphT-  , strictGraphWith   , strictGraph-  , strictDigraphWithT   , strictDigraphT-  , strictDigraphWith   , strictDigraph   ) where  import "this" Prelude +import Control.Lens import Data.HashMap.Strict qualified as M+import Data.HashSet        qualified as S import Data.List.NonEmpty  qualified as NE import Text.Printf import TextBuilder         (TextBuilder)@@ -36,133 +30,80 @@ -- -- Given a t'DotT' expression that builds a graph, this function evaluates it -- and builds an undirected non-strict graph. It returns the result in the--- underlying monad, as a 'TextBuilder'. The callback takes the graph's--- identifier as argument.+-- underlying monad, as a 'TextBuilder'. -- -- The result of the graph building expression itself is ignored.-graphWithT :: Monad m => (Entity -> DotT m a) -> m TextBuilder-graphWithT = render "graph" "--"---- | Renders a given graph.------ Like 'graphWithT', but the expression doesn't take the identifier as agument. graphT :: Monad m => DotT m a -> m TextBuilder-graphT = render "graph" "--" . const---- | Renders a given graph.------ Like 'graphWithT', but in the 'Dot' monad.-graphWith :: (Entity -> Dot a) -> TextBuilder-graphWith = runIdentity . render "graph" "--"+graphT = render "graph" "--"  -- | Renders a given graph. -- -- Like 'graphT', but in the 'Dot' monad. graph :: Dot a -> TextBuilder-graph = runIdentity . render "graph" "--" . const+graph = runIdentity . render "graph" "--"  -- | Renders a given graph. -- -- Given a t'DotT' expression that builds a graph, this function evaluates it -- and builds a directed non-strict graph. It returns the result in the--- underlying monad, as a 'TextBuilder'. The callback takes the graph's--- identifier as argument.+-- underlying monad, as a 'TextBuilder'. -- -- The result of the graph building expression itself is ignored.-digraphWithT :: Monad m => (Entity -> DotT m a) -> m TextBuilder-digraphWithT = render "digraph" "->"---- | Renders a given graph.------ Like 'digraphWithT', but the expression doesn't take the entity as agument. digraphT :: Monad m => DotT m a -> m TextBuilder-digraphT = render "digraph" "->" . const---- | Renders a given graph.------ Like 'digraphWithT', but in the 'Dot' monad.-digraphWith :: (Entity -> Dot a) -> TextBuilder-digraphWith = runIdentity . render "digraph" "->"+digraphT = render "digraph" "->"  -- | Renders a given graph. -- -- Like 'digraphT', but in the 'Dot' monad. digraph :: Dot a -> TextBuilder-digraph = runIdentity . render "digraph" "->" . const+digraph = runIdentity . render "digraph" "->"  -- | Renders a given graph. -- -- Given a t'DotT' expression that builds a graph, this function evaluates it -- and builds an undirected strict graph. It returns the result in the--- underlying monad, as a 'TextBuilder'. The callback takes the graph's--- identifier as argument.+-- underlying monad, as a 'TextBuilder'. -- -- The result of the graph building expression itself is ignored.-strictGraphWithT :: Monad m => (Entity -> DotT m a) -> m TextBuilder-strictGraphWithT = render "strict graph" "--"---- | Renders a given graph.------ Like 'strictGraphWithT', but the expression doesn't take the entity as agument. strictGraphT :: Monad m => DotT m a -> m TextBuilder-strictGraphT = render "strict graph" "--" . const---- | Renders a given graph.------ Like 'strictGraphWithT', but in the 'Dot' monad.-strictGraphWith :: (Entity -> Dot a) -> TextBuilder-strictGraphWith = runIdentity . render "strict graph" "--"+strictGraphT = render "strict graph" "--"  -- | Renders a given graph. -- -- Like 'strictGraphT', but in the 'Dot' monad. strictGraph :: Dot a -> TextBuilder-strictGraph = runIdentity . render "strict graph" "--" . const+strictGraph = runIdentity . render "strict graph" "--"  -- | Renders a given graph. -- -- Given a t'DotT' expression that builds a graph, this function evaluates it -- and builds a directed strict graph. It returns the result in the underlying--- monad, as a 'TextBuilder'. The callback takes the graph's identifier as--- argument.+-- monad, as a 'TextBuilder'. -- -- The result of the graph building expression itself is ignored.-strictDigraphWithT :: Monad m => (Entity -> DotT m a) -> m TextBuilder-strictDigraphWithT = render "strict digraph" "->"---- | Renders a given graph.------ Like 'strictDigraphWithT', but the expression doesn't take the entity as agument. strictDigraphT :: Monad m => DotT m a -> m TextBuilder-strictDigraphT = render "strict digraph" "->" . const---- | Renders a given graph.------ Like 'strictDigraphWithT', but in the 'Dot' monad.-strictDigraphWith :: (Entity -> Dot a) -> TextBuilder-strictDigraphWith = runIdentity . render "strict digraph" "->"+strictDigraphT = render "strict digraph" "->"  -- | Renders a given graph. -- -- Like 'strictDigraphT', but in the 'Dot' monad. strictDigraph :: Dot a -> TextBuilder-strictDigraph = runIdentity . render "strict digraph" "->" . const+strictDigraph = runIdentity . render "strict digraph" "->"   -------------------------------------------------------------------------------- -- Internal helpers -render :: Monad m => TextBuilder -> TextBuilder -> (Entity -> DotT m a) -> m TextBuilder-render gtype arrow f = do-  let root = Entity Subgraph (-1)-  allGraph <- run root (f root)-  pure $ TB.intercalate "\n" $ visit allGraph gtype arrow root+render :: Monad m => TextBuilder -> TextBuilder -> DotT m a -> m TextBuilder+render gtype arrow action = do+  allGraph <- run action+  pure $ TB.intercalate "\n" $ visit allGraph gtype arrow  indent :: [TextBuilder] -> [TextBuilder] indent = map ("  " <>) -visit :: DotGraph -> TextBuilder -> TextBuilder -> Entity -> [TextBuilder]-visit DotGraph {..} gtype arrow = visitGraph+visit :: DotGraph -> TextBuilder -> TextBuilder -> [TextBuilder]+visit DotGraph {..} gtype arrow = evalState visitGraph initialRenderState   where     magnitude = ceiling (logBase 10 (fromIntegral _entityIndex :: Double)) :: Int     intFormat = mconcat ["%0", show magnitude, "d"]@@ -176,54 +117,80 @@           suffix = TB.string $ printf intFormat i       in prefix <> suffix +    retrieveEdgeNode = \case+      KnownNode e -> e+      UnknownNode _ -> error "Text.Dot.Render.visit: found unresolved edge name"+     visitAttribute (name, value) =       mconcat [TB.text name, "=\"", TB.text value, "\""]      visitAttributes =       map visitAttribute . M.toList -    visitEntity e =+    visitEntity e = do       let attrs = fromMaybe mempty $ M.lookup e _entityAttributes-      in  indent $ case getType e of-                     Node     -> visitNode     e attrs-                     Edge     -> visitEdge     e attrs (_edgeInfo     M.! e)-                     Cluster  -> visitSubgraph e attrs (_subgraphInfo M.! e)-                     Subgraph -> visitSubgraph e attrs (_subgraphInfo M.! e)+      case getType e of+        Node     -> visitNode     e attrs+        Edge     -> visitEdge     e attrs (_edgeInfo     M.! e)+        Cluster  -> visitSubgraph e attrs (_subgraphInfo M.! e)+        Subgraph -> visitSubgraph e attrs (_subgraphInfo M.! e)      visitEntities =-      concatMap visitEntity . reverse+      fmap concat . traverse visitEntity . reverse -    visitNode e attrs =-      pure $ mconcat+    visitNode e attrs = do+      knownNodes %= S.insert e+      pure $ pure $ mconcat         [ renderIndex e         , " ["         , TB.intercalate "," $ visitAttributes attrs         , "]"         ] -    visitEdge _ attrs (EdgeInfo o1 o2 p1 p2) =-      pure $ mconcat-        [ renderIndex p1-        , " "-        , arrow-        , " "-        , renderIndex p2-        , " ["-        , TB.intercalate "," $ visitAttributes $ attrs-          <> M.fromList [("ltail", TB.toText $ renderIndex o1) | getType o1 == Cluster]-          <> M.fromList [("lhead", TB.toText $ renderIndex o2) | getType o2 == Cluster]-        , "]"-        ]+    visitEdge _ attrs (EdgeInfo o1 o2 p1 p2) = do+      let+        e1 = retrieveEdgeNode o1+        e2 = retrieveEdgeNode o2+        result = pure $ mconcat+          [ renderIndex (fromMaybe e1 p1)+          , " "+          , arrow+          , " "+          , renderIndex (fromMaybe e2 p2)+          , " ["+          , TB.intercalate "," $ visitAttributes $ attrs+            <> M.fromList [("ltail", TB.toText $ renderIndex e1) | _ <- toList p1]+            <> M.fromList [("lhead", TB.toText $ renderIndex e2) | _ <- toList p2]+          , "]"+          ]+      knownCache <- use knownNodes+      let allKnown = and do+            Just n <- [Just e1, Just e2, p1, p2]+            pure $ S.member n knownCache+      if allKnown+      then+        pure result+      else do+        delayedEdges <>:= result+        pure [] -    visitGraph e =-      visitInner gtype e (fromMaybe mempty $ M.lookup e _entityAttributes) (NE.head _contextStack)+    visitGraph = visitInner+      gtype+      (uses delayedEdges reverse)+      (fromMaybe mempty $ M.lookup rootGraph _entityAttributes)+      (NE.head _contextStack) -    visitSubgraph e =-      visitInner ("subgraph " <> renderIndex e) e+    visitSubgraph e = visitInner+      ("subgraph " <> renderIndex e)+      (pure []) -    visitInner etype _ attrs entities = concat-      [ [etype <> " {"]-      , indent $ map (<> ";") $ visitAttributes attrs-      , visitEntities entities-      , ["}"]-      ]+    visitInner etype edgeAction attrs entities = do+      innerEntities <- visitEntities entities+      extraEdges <- edgeAction+      pure $ concat+        [ [etype <> " {"]+        , indent $ map (<> ";") $ visitAttributes attrs+        , indent innerEntities+        , indent extraEdges+        , ["}"]+        ]

@@ -6,6 +6,7 @@  import Control.Lens import Data.Hashable+import TextBuilder    (TextBuilder)   --------------------------------------------------------------------------------@@ -39,10 +40,59 @@ getType :: Entity -> EntityType getType (Entity t _) = t +-- | Unique entity of the top-level graph.+rootGraph :: Entity+rootGraph = Entity Subgraph (-1) +-- | Describes types that can be used as the end of an edge.+--+-- When declaring an edge, each node can be described in two different ways:+-- either via its 'Entity', or by using a 'Text' name.+--+-- For more information, see 'Text.Dot.edge', 'Text.Dot.register', and+-- 'Text.Dot.retrieve'.+class ToEdgeNode a where+  toEdgeNode :: a -> EdgeNode++instance ToEdgeNode Entity where+  toEdgeNode = KnownNode++instance ToEdgeNode EdgeNode where+  toEdgeNode = id++-- | Constructs an edge node from the given text name.+--+-- This allows for an edge to be declared using the name given to this+-- function. The name won't be resolved immediately, but must be registered at+-- some point within the graph.+--+-- > digraph do+-- >   node "A"+-- >   registerItAs "a"+-- >+-- >   edge (retrieve "a") (retrieve "b")+-- >+-- >   node "B"+-- >   registerItAs "b"+--+-- See also 'Text.Dot.edge'.+retrieve :: Text -> EdgeNode+retrieve = UnknownNode++ -------------------------------------------------------------------------------- -- Internal state +-- | Opaque internal type.+--+-- Represent one end of an edge: either an 'Entity', or an arbitrary 'Text'+-- name.+--+-- See also 'Text.Dot.edge' and 'retrieve'.+data EdgeNode+  = KnownNode Entity+  | UnknownNode Text+ -- | An entity's attributes. -- -- Attributes are untyped, and are a simple mapping from 'Text' to 'Text', for@@ -52,14 +102,14 @@ -- | A path through the graph. -- -- This opaque type represents the path from the root to the current scope. The--- current path can be obtained via 'Text.Dot.path'.+-- current path can be obtained via 'Text.Dot.currentPath'. newtype Path = Path { unwrapPath :: NonEmpty Entity }  makePrisms ''Path  type DotContext = [Entity] -data EdgeInfo = EdgeInfo Entity Entity Entity Entity+data EdgeInfo = EdgeInfo EdgeNode EdgeNode (Maybe Entity) (Maybe Entity)  -- | Internal opaque graph state. data DotGraph = DotGraph@@ -67,6 +117,7 @@   , _entityAttributes  :: HashMap Entity Attributes   , _edgeInfo          :: HashMap Entity EdgeInfo   , _subgraphInfo      :: HashMap Entity DotContext+  , _entityRegister    :: HashMap Text Entity   , _contextStack      :: NonEmpty DotContext   , _entityIndex       :: Int   , _latest            :: Entity@@ -74,5 +125,15 @@  makeLenses ''DotGraph -initialGraph :: Entity -> DotGraph-initialGraph = DotGraph mempty mempty mempty mempty (pure mempty) 0+initialGraph :: DotGraph+initialGraph = DotGraph mempty mempty mempty mempty mempty (pure mempty) 0 rootGraph++data RenderState = RenderState+  { _knownNodes   :: HashSet Entity+  , _delayedEdges :: [TextBuilder]+  }++makeLenses ''RenderState++initialRenderState :: RenderState+initialRenderState = RenderState mempty mempty

@@ -1,8 +1,7 @@ {- AUTOCOLLECT.TEST -}+{-# LANGUAGE OverloadedLists #-} -module Golden-  ( {- AUTOCOLLECT.TEST.export -}-  ) where+module Golden where  import "this" Prelude @@ -56,10 +55,10 @@ test =   go "strict digraph with clusters" $     strictDigraph do-      a <- cluster_ do+      a <- cluster do         its label ?= "cluster A"         node "a"-      b <- cluster_ do+      b <- cluster do         its label ?= "cluster B"         node "b"       a --> b@@ -69,23 +68,23 @@ test =   go "automatic compound" $     digraph do-      (clusterA1, _) <-+      cluster do+        its label ?= "cluster A1"+        registerItAs "clusterA1"         cluster do-          its label ?= "cluster A1"+          its label ?= "cluster A2"           cluster do-            its label ?= "cluster A2"-            cluster do-              its label ?= "cluster A3"-              node "a"-      (clusterB3, _) <-+            its label ?= "cluster A3"+            node "a"+      cluster_ do+        its label ?= "cluster B1"         cluster_ do-          its label ?= "cluster B1"-          cluster_ do-            its label ?= "cluster B2"-            cluster do-              its label ?= "cluster B3"-              node "b"-      clusterA1 --> clusterB3+          its label ?= "cluster B2"+          cluster do+            its label ?= "cluster B3"+            registerItAs "clusterB3"+            node "b"+      retrieve "clusterA1" --> retrieve "clusterB3"  test =   go "path test" $@@ -118,3 +117,20 @@         eid <- toList entityStack         pure $ use $ attributes eid . label       node $ TB.toText $ TB.intercalate " > " $ reverse $ map TB.text $ catMaybes path++test =+  go "cyclic graph" $+    digraph do+      cluster_ do+        its label ?= "cluster A"+        registerItAs "cA"+        defaults Edge <>:= [("color", "red")]+        na <- node "node A"+        na --> retrieve "cB"+      cluster_ do+        its label ?= "cluster B"+        registerItAs "cB"+        defaults Edge <>:= [("color", "green")]+        nb <- node "node B"+        nb --> retrieve "cA"+      pure ()