packages feed

graphwiz (empty) → 1.0.0

raw patch · 17 files changed

+1967/−0 lines, 17 filesdep +basedep +containersdep +directory

Dependencies added: base, containers, directory, filepath, graphwiz, hashable, lens, mtl, stm, tagged, tasty, tasty-autocollect, tasty-golden, text, text-builder, transformers, unordered-containers

Files

+ .gitignore view
@@ -0,0 +1,24 @@+dist+dist-*+cabal-dev+*.o+*.hi+*.hie+*.chi+*.chs.h+*.dyn_o+*.dyn_hi+.hpc+.hsenv+.cabal-sandbox/+cabal.sandbox.config+*.prof+*.aux+*.hp+*.eventlog+.stack-work/+cabal.project.local+cabal.project.local~+.HTF/+.ghc.environment.*+documentation/
+ .stylish-haskell.yaml view
@@ -0,0 +1,36 @@+steps:+  - module_header:+      indent: 2+      sort: false+      separate_lists: true+      break_where: single+      open_bracket: next_line++  - simple_align:+      cases: always+      top_level_patterns: always+      records: always+      multi_way_if: always++  - imports:+      align: global+      list_align: after_alias+      pad_module_names: true+      long_list_align: inline+      empty_list_align: inherit+      list_padding: 2+      separate_lists: true+      space_surround: false+      post_qualify: true+      group_imports: false++  - language_pragmas:+      style: vertical+      align: true+      remove_redundant: true+      language_prefix: LANGUAGE++  - trailing_whitespace: {}++newline: lf+cabal: true
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+1.0.0+-----+* First version
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Antoine Leblanc++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,132 @@+# :mage_woman: GraphWiz++[![build status][BuildShield]][BuildLink] [![hackage version][HackageShield]][HackageLink]+++GraphWiz provides a small monadic DSL to generate DOT files. It aims at being intuitive to use, by replicating in your code the structure of the resulting DOT file.++It's a "wizard" for Graphviz's DOT format, hence the name "GraphWiz".++[BuildLink]:   https://github.com/nicuveo/graphwiz/actions/workflows/haskell.yml?query=branch%3Amain+[BuildShield]: https://img.shields.io/github/actions/workflow/status/nicuveo/graphwiz/haskell.yml?event=push&style=flat&branch=main&label=build+[HackageLink]:   https://hackage.haskell.org/package/graphwiz+[HackageShield]: https://img.shields.io/hackage/v/graphwiz++## Overview++### Graph creation++This library exports a simple monad: `Dot` (and its transformer version `DotT`), that you can only run with a function that indicates how the graph should be rendered: `graph`, `digraph`, `strictGraph`, `strictDigraph`. Within this monad, you can create graph elements with `node`, `edge` (or `-->`), `subgraph`, `cluster`, and their variants.++All such functions that create an element return an `Entity`, an ID that uniquely identifies that element within the graph. Additionally, the ID of the latest created entity (regardless of its type) can be accessed with `itsID`.++```haskell+digraph do+  a <- node "a"+  b <- node "b"+  a --> b+  subgraph do+    c <- node "c"+    a --> c+    b --> c+```++### 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).++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.++```haskell+graphT do+  defaults Edge .= [("style", "dotted"), ("color", "blue")]+  defaults Node . shape ?= "hexagon"+  x <- node "x"+  its fontcolor ?= "red"+  liftIO $ print =<< use (attributes x)+```++### Text.Builder++For efficiency and convenience, the result of running the `Dot` monad is not a `String` or `Text`; it's a [Text.Builder](https://hackage.haskell.org/package/text-builder-0.6.7.3/docs/Text-Builder.html), that can be converted to a strict `Text` or even printed directly to the standard output.++### Auto compound++The DOT syntax to draw edges between clusters is quite cumbersome. We have to declare the graph to be `compound`, and we have to create the edge between two nodes within the clusters, with specific attributes.++```dot+graph foo {+  compound = true;+  subgraph cluster_a { a }+  subgraph cluster_b { b }+  a -- b [ltail="cluster_a", lhead="cluster_b"]+}+```++GraphWiz automates the task: if one end of an edge is a cluster, the `compound` attribute is added to the graph, and the correct attributes are set at rendering time. To be as unobtrusive as possible, the values of `ltail` and `lhead` will not be updated if already present, trusting the user to know best.++```haskell+graph do+  (cluster_a, _) <- cluster $ node "a"+  (cluster_b, _) <- cluster $ node "b"+  cluster_a --> cluster_b+```++## Full example++From the [example](example) folder:++##### Haskell source+```haskell+main =+  TB.putLnToStdOut $+    digraph do+      defaults Node . style ?= "filled"++      ast <- cluster_ do+        its label ?= "front end"++        source <- node "source code"+        its fillcolor ?= "#c3ffd8"++        ast <- node "AST"+        its fillcolor ?= "yellow"++        source --> ast+        its label ?= "parsing"++        pure ast++      cluster do+        its label ?= "middle end"++        ir <- node "IR"+        its shape     ?= "diamond"+        its fillcolor ?= "salmon"++        ast --> ir+        its label ?= "lowering"+        its style ?= "dotted"+```++#### Resulting DOT file++```DOT+digraph {+  subgraph cluster0 {+    label="front end";+    node1 [label="source code",style="filled",fillcolor="#c3ffd8"]+    node2 [label="AST",style="filled",fillcolor="yellow"]+    node1 -> node2 [label="parsing"]+  }+  subgraph cluster4 {+    label="middle end";+    node5 [label="IR",style="filled",fillcolor="salmon",shape="diamond"]+    node2 -> node5 [label="lowering",style="dotted"]+  }+}+```++#### Resulting PNG++![example of a generated PNG](example/output.png)
+ common/Prelude.hs view
@@ -0,0 +1,129 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE PatternSynonyms #-}++{- |++Internal module that re-exports the regular prelude, plus some common useful+functions.++-}++module Prelude+  ( -- * re-exports from useful "default" modules+    module P+    -- * custom operators+  , (...)+    -- * maybe helpers+  , onNothing+  , onNothingM+    -- * either helpers+  , onLeft+  , onLeftM+    -- * sequence helpers+  , Seq (.., Lone)+    -- * hashmap helpers+  , unionWithM+  , unionWithKeyM+  ) where+++-- re-exports++import Control.Applicative        as P (liftA, (<|>))+import Control.Arrow              as P (first, left, second, (&&&), (***),+                                        (<<<), (>>>))+import Control.Monad              as P+import Control.Monad.Except       as P+import Control.Monad.Identity     as P+import Control.Monad.Reader       as P+import Control.Monad.State.Strict as P+import Control.Monad.Trans.Maybe  as P (MaybeT (..))+import Data.Bifunctor             as P (bimap)+import Data.Bool                  as P (bool)+import Data.Char                  as P (chr, ord)+import Data.Either                as P (lefts, partitionEithers, rights)+import Data.Foldable              as P (asum, fold, foldMap', foldlM, foldrM,+                                        for_, toList, traverse_)+import Data.Function              as P (on, (&))+import Data.Functor               as P (($>), (<&>))+import Data.Functor.Const         as P (Const (..))+import Data.Hashable              as P (Hashable)+import Data.HashMap.Strict        as P (HashMap, mapKeys)+import Data.HashSet               as P (HashSet)+import Data.List                  as P (find, findIndex, group, intercalate,+                                        intersect, intersperse, lookup, sort,+                                        sortBy, sortOn, union, unionBy, (\\))+import Data.List.NonEmpty         as P (NonEmpty (..), nonEmpty)+import Data.Maybe                 as P (catMaybes, fromMaybe, isJust, isNothing,+                                        listToMaybe, maybeToList)+import Data.Ord                   as P (comparing)+import Data.Semigroup             as P (Semigroup (..))+import Data.Sequence              as P (Seq)+import Data.String                as P (IsString)+import Data.Text                  as P (Text)+import Data.Traversable           as P (for)+import Data.Void                  as P (Void, absurd)+import GHC.Generics               as P (Generic)+import "base" Prelude             as P hiding (lookup)+++-- internal imports++import Data.HashMap.Strict        qualified as M+import Data.Sequence              (Seq (..))+++-- operators++(...) :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)+f ... g = \x y -> f (g x y)+infixr 8 ...+++-- maybe helpers++onNothing :: Applicative m => Maybe a -> m a -> m a+onNothing a d = maybe d pure a++onNothingM :: Monad m => m (Maybe a) -> m a -> m a+onNothingM a d = a >>= flip onNothing d+++-- either helpers++onLeft :: Applicative m => Either e a -> (e -> m a) -> m a+onLeft a f = either f pure a++onLeftM :: Monad m => m (Either e a) -> (e -> m a) -> m a+onLeftM a f = a >>= flip onLeft f+++-- sequence helpers++pattern Lone :: a -> Seq a+pattern Lone x = x :<| Empty+++-- hashmap helpers++unionWithM ::+  (Monad m, Hashable k) =>+  (v -> v -> m v) ->+  HashMap k v ->+  HashMap k v ->+  m (HashMap k v)+unionWithM = unionWithKeyM . const++unionWithKeyM ::+  (Monad m, Hashable k) =>+  (k -> v -> v -> m v) ->+  HashMap k v ->+  HashMap k v ->+  m (HashMap k v)+unionWithKeyM f m1 m2 = foldM step m1 (M.toList m2)+  where+    step m (k, new) = case M.lookup k m of+      Nothing -> pure $ M.insert k new m+      Just old -> do+        combined <- f k new old+        pure $ M.insert k combined m
+ example/Main.hs view
@@ -0,0 +1,36 @@+module Main where++import Control.Lens+import Text.Builder qualified as TB+import Text.Dot++main :: IO ()+main =+  TB.putLnToStdOut $+    digraph do+      defaults Node . style ?= "filled"++      ast <- cluster_ do+        its label ?= "front end"++        source <- node "source code"+        its fillcolor ?= "#c3ffd8"++        ast <- node "AST"+        its fillcolor ?= "yellow"++        source --> ast+        its label ?= "parsing"++        pure ast++      cluster do+        its label ?= "middle end"++        ir <- node "IR"+        its shape   ?= "diamond"+        its fillcolor ?= "salmon"++        ast --> ir+        its label ?= "lowering"+        its style ?= "dotted"
+ graphwiz.cabal view
@@ -0,0 +1,137 @@+cabal-version:      3.4+name:               graphwiz+synopsis:           Monadic DOT graph builder DSL+version:            1.0.0+category:           Data, Text+license:            BSD-3-Clause+license-file:       LICENSE+copyright:          Copyright (C) 2025 Antoine Leblanc+maintainer:         nicuveo@gmail.com+author:             Antoine Leblanc+homepage:           https://github.com/nicuveo/graphwiz#readme+bug-reports:        https://github.com/nicuveo/graphwiz/issues+tested-with:        GHC ==9.8 || ==9.10 || ==9.12+description:        Small monadic DSL to build Graphviz DOT files.+extra-source-files:+  .gitignore+  .stylish-haskell.yaml+  README.md++extra-doc-files:    CHANGELOG.md++source-repository head+  type:     git+  location: https://github.com/nicuveo/graphwiz.git++flag export-internals-for-coverage+  description:+    Whether internal modules should be exported so that coverage can be analyzed.++  default:     False+  manual:      True++common setup+  default-language:   GHC2021+  default-extensions:+    AllowAmbiguousTypes+    ApplicativeDo+    BlockArguments+    DataKinds+    DefaultSignatures+    DerivingVia+    FunctionalDependencies+    GADTs+    LambdaCase+    MultiWayIf+    NoImplicitPrelude+    OverloadedStrings+    PackageImports+    RecordWildCards+    RoleAnnotations+    StrictData+    TypeFamilies+    ViewPatterns++  ghc-options:+    -Wall -Wcompat -Widentities -Wincomplete-uni-patterns+    -Winvalid-haddock -Wpartial-fields -Wredundant-constraints -Wtabs+    -Wunused-packages -Wno-unused-do-bind -fhide-source-paths+    -foptimal-applicative-do -funbox-small-strict-fields+    -fwrite-ide-info++library+  import:         setup++  if flag(export-internals-for-coverage)+    other-modules:   Prelude+    exposed-modules:+      Text.Dot+      Text.Dot.Attributes+      Text.Dot.Build+      Text.Dot.Monad+      Text.Dot.Render+      Text.Dot.Types++  else+    exposed-modules: Text.Dot+    other-modules:+      Prelude+      Text.Dot.Attributes+      Text.Dot.Build+      Text.Dot.Monad+      Text.Dot.Render+      Text.Dot.Types++  hs-source-dirs: common src+  build-depends:+    , base                  >=4.16 && <5+    , containers            <1+    , hashable              >=1    && <2+    , lens                  >=5    && <6+    , mtl                   >=2    && <3+    , text                  >=2    && <3+    , text-builder          <1+    , transformers          <1+    , unordered-containers  <1++test-suite tests+  import:             setup+  type:               exitcode-stdio-1.0+  main-is:            Tests.hs+  other-modules:+    Golden+    Prelude+    Reporter++  hs-source-dirs:     common test+  ghc-options:        -F -pgmF=tasty-autocollect+  build-tool-depends: tasty-autocollect:tasty-autocollect+  build-depends:+    , base                  >=4.16 && <5+    , containers+    , directory+    , filepath+    , graphwiz+    , hashable+    , lens+    , mtl+    , stm+    , tagged+    , tasty+    , tasty-autocollect+    , tasty-golden+    , text+    , text-builder+    , transformers+    , unordered-containers++executable example+  import:             setup+  main-is:            Main.hs+  hs-source-dirs:     example+  default-extensions: ImplicitPrelude+  build-depends:+    , base+    , graphwiz+    , lens+    , text-builder
+ src/Text/Dot.hs view
@@ -0,0 +1,95 @@+{- |++GraphWiz is a small monadic DSL used to write DOT files.++To run the monad, use one of the [graph functions](#g:render), like 'graph' and+'digraph'. Those also have a transformer version if you want to use 'Dot' on top+of other monads.++Within the monad, you can use any of the [construction](#g:construction)+functions to create one of the four graph [entities](#g:entities). Their+attributes can be set via lenses such as '?=', see [attributes](#g:attributes).++The output is a 'Text.Builder.Builder', that you can convert to a strict+'Data.Text.Text' or print directly.++-}++module Text.Dot+  ( -- * Entities #entities#+    Entity+  , EntityType (..)+  , getType+  , itsID+    -- * Attributes #attributes#+  , Attributes+  , attributes+  , defaults+  , attribute+  , its+  , ifAbsent+    -- * Construction #construction#+  , node+  , edge+  , (-->)+  , subgraphWith+  , subgraph+  , subgraphWith_+  , subgraph_+  , clusterWith+  , cluster+  , clusterWith_+  , cluster_+    -- * Monad #monad#+  , DotT+  , Dot+  , MonadDot+  , DotGraph+  , Path+  , currentPath+  , rootGraph+    -- * Rendering the graph #render#+  , module Render+    -- * Re-exports from "Control.Lens.Setter"+  , (.=)+  , (?=)+  , (%=)+  , (<>=)+  , (<>:=)+    -- * All known attributes+    -- ** Renamed attributes+    -- $attributes+  , background+  , damping+  , isCcluster+  , k+  , svgClass+  , svgID+  , tbbalance+  , url+    -- ** All others #hell#+  , module Attributes+  ) where++import Control.Lens.Setter++import Text.Dot.Attributes (attribute, attributes, background, damping,+                            defaults, ifAbsent, isCcluster, its, k, svgClass,+                            svgID, tbbalance, url)+import Text.Dot.Attributes as Attributes hiding (attribute, attributes,+                                          background, damping, defaults,+                                          ifAbsent, isCcluster, its, k,+                                          svgClass, svgID, tbbalance, url)+import Text.Dot.Build+import Text.Dot.Monad+import Text.Dot.Render     as Render+import Text.Dot.Types++-- $attributes+--+-- All attributes listed in [Graphviz's+-- documentation](https://graphviz.org/doc/info/attrs.html) have an accompanying+-- lens, so that any standard attribute can be accessed without using strings+-- (like with 'attribute'). Not all of them are valid haskell names, however:+-- the following are the ones that have been remamed, the others ones can be+-- found [below](#g:hell).
+ src/Text/Dot/Attributes.hs view
@@ -0,0 +1,497 @@+module Text.Dot.Attributes where++import "this" Prelude++import Control.Lens++import Text.Dot.Types+++--------------------------------------------------------------------------------+-- Attributes access++-- | Retrieves the 'Attributes' of the given t'Entity'.+--+-- Given an entity attribute, return a lens to the corresponding attributes map+-- in a given 'Text.Dot.DotGraph', which is an internal opaque type. This is+-- meant to be used inside the 'Text.Dot.DotT' monad, relying on the fact that+-- it is a State monad under the hood.+--+-- Using @OverloadedLists@ makes working with the full attributes map a bit+-- easier.+--+-- > graph do+-- >   x <- node "x"+-- >+-- >   -- replaces the entire mapping (erases the label!)+-- >   attributes x .= [("fontcolor", "red")]+-- >+-- >   -- combines the existing mapping with the new one, favoring old values+-- >   attributes x <>= [("fontcolor", "blue"), ("fontsize", "12")]+-- >+-- >   -- combines the existing mapping with the new one, favoring new values+-- >   attributes x <>:= [("fontcolor", "blue"), ("fontsize", "12")]+--+-- This function is best used with the provided field accessors, such as+-- 'fontcolor', to be more explicit about the way to deal with previous values.+attributes :: Entity -> Lens' DotGraph Attributes+attributes e = entityAttributes . at e . non mempty++-- | Retrieves the default 'Attributes' of the given 'EntityType'.+--+-- Given an entity type, return a lens to the corresponding default attributes+-- map in a given 'Text.Dot.DotGraph', which is an internal opaque type. This is+-- meant to be used inside the 'Text.Dot.DotT' monad, relying on the fact that+-- it is a State monad under the hood.+--+-- After modifying the defaults for a given entity type, any new such entity+-- will have its attributes set to the new default values.+--+-- > graph do+-- >   node "x"+-- >   use (its fillcolor) -- Nothing+-- >+-- >   defaults Cluster . style ?= "dashed"+-- >   defaults Node <>= [("style", "filled"), ("fillcolor", "forestgreen")]+-- >+-- >   node "y"+-- >   use (its fillcolor) -- Just "forestgreen"+--+-- This function is best used with the provided field accessors, such as+-- 'fontcolor', to be more explicit about the way to deal with previous values.+defaults :: EntityType -> Lens' DotGraph Attributes+defaults t = defaultAttributes . at t . non mempty++-- | Retrieves an attribute from the latest created t'Entity'.+--+-- Given a lens for a specific attribute, such as 'style' or 'label', this+-- combinator creates a lens that points to that attribute for the latest+-- created t'Entity'. Like 'attributes', it is meant to be used within the+-- 'Text.Dot.DotT' monad.+--+-- > graph do+-- >   its title ?= "my graph"+-- >+-- >   bar <- node "bar"+-- >   its fontsize ?= "34"+-- >+-- >   edge bar bar+-- >   its style ?= "dotted"+-- >+-- >   cluster do+-- >     its label ?= "cluster"+its :: Lens' Attributes (Maybe Text) -> Lens' DotGraph (Maybe Text)+its l f d = (attributes (_latest d) . l) f d++-- | Simple alias for 'at'.+--+-- This makes the code a tiny bit more natural when accessing fields by name:+--+-- > graph do+-- >   node "x"+-- >+-- >   -- replace the old value, if any+-- >   its (attribute "fontcolor") ?= "red"+-- >   its (attribute "fontcolor") .= Just "red"+-- >+-- >   -- erase the attribute+-- >   its (attribute "fontcolor") .= Nothing+-- >+-- >   -- set the value if it wasn't previously set+-- >   its (attribute "fontcolor") %= ifAbsent "blue"+--+-- It is however preferable to use one of the provided attribute lenses to avoid+-- raw strings.+attribute :: Text -> Lens' Attributes (Maybe Text)+attribute = at++-- | Replaces a 'Maybe' value only if it wasn't set.+--+-- >>> ifAbsent "foo" Nothing+-- Just "foo"+--+-- >>> ifAbsent "foo" (Just "bar")+-- Just "bar"+--+-- This is best used in conjuction with 'attribute', or one of the explicit+-- attribute accessors.+--+-- > foo <- node "foo"+-- > its fillcolor %= ifAbsent "blue"+ifAbsent :: a -> Maybe a -> Maybe a+ifAbsent x m = m <|> Just x+++--------------------------------------------------------------------------------+-- All attributes++-- | Maps to the @_background@ attribute.+background         :: Lens' Attributes (Maybe Text)+background         = attribute "_background"++-- | Maps to the @Damping@ attribute.+damping            :: Lens' Attributes (Maybe Text)+damping            = attribute "Damping"++-- | Maps to the @cluster@ attribute.+isCcluster         :: Lens' Attributes (Maybe Text)+isCcluster         = attribute "cluster"++-- | Maps to the @K@ attribute.+k                  :: Lens' Attributes (Maybe Text)+k                  = attribute "K"++-- | Maps to the @class@ attribute.+svgClass           :: Lens' Attributes (Maybe Text)+svgClass           = attribute "class"++-- | Maps to the @id@ attribute.+svgID              :: Lens' Attributes (Maybe Text)+svgID              = attribute "id"++-- | Maps to the @TBbalance@ attribute.+tbbalance          :: Lens' Attributes (Maybe Text)+tbbalance          = attribute "TBbalance"++-- | Maps to the @URL@ attribute.+url                :: Lens' Attributes (Maybe Text)+url                = attribute "URL"++area               :: Lens' Attributes (Maybe Text)+area               = attribute "area"+arrowhead          :: Lens' Attributes (Maybe Text)+arrowhead          = attribute "arrowhead"+arrowsize          :: Lens' Attributes (Maybe Text)+arrowsize          = attribute "arrowsize"+arrowtail          :: Lens' Attributes (Maybe Text)+arrowtail          = attribute "arrowtail"+bb                 :: Lens' Attributes (Maybe Text)+bb                 = attribute "bb"+beautify           :: Lens' Attributes (Maybe Text)+beautify           = attribute "beautify"+bgcolor            :: Lens' Attributes (Maybe Text)+bgcolor            = attribute "bgcolor"+black              :: Lens' Attributes (Maybe Text)+black              = attribute "black"+center             :: Lens' Attributes (Maybe Text)+center             = attribute "center"+charset            :: Lens' Attributes (Maybe Text)+charset            = attribute "charset"+clusterrank        :: Lens' Attributes (Maybe Text)+clusterrank        = attribute "clusterrank"+color              :: Lens' Attributes (Maybe Text)+color              = attribute "color"+colorscheme        :: Lens' Attributes (Maybe Text)+colorscheme        = attribute "colorscheme"+comment            :: Lens' Attributes (Maybe Text)+comment            = attribute "comment"+compound           :: Lens' Attributes (Maybe Text)+compound           = attribute "compound"+concentrate        :: Lens' Attributes (Maybe Text)+concentrate        = attribute "concentrate"+constraint         :: Lens' Attributes (Maybe Text)+constraint         = attribute "constraint"+decorate           :: Lens' Attributes (Maybe Text)+decorate           = attribute "decorate"+defaultdist        :: Lens' Attributes (Maybe Text)+defaultdist        = attribute "defaultdist"+dim                :: Lens' Attributes (Maybe Text)+dim                = attribute "dim"+dimen              :: Lens' Attributes (Maybe Text)+dimen              = attribute "dimen"+dir                :: Lens' Attributes (Maybe Text)+dir                = attribute "dir"+diredgeconstraints :: Lens' Attributes (Maybe Text)+diredgeconstraints = attribute "diredgeconstraints"+distortion         :: Lens' Attributes (Maybe Text)+distortion         = attribute "distortion"+dpi                :: Lens' Attributes (Maybe Text)+dpi                = attribute "dpi"+edgeURL            :: Lens' Attributes (Maybe Text)+edgeURL            = attribute "edgeURL"+edgehref           :: Lens' Attributes (Maybe Text)+edgehref           = attribute "edgehref"+edgetarget         :: Lens' Attributes (Maybe Text)+edgetarget         = attribute "edgetarget"+edgetooltip        :: Lens' Attributes (Maybe Text)+edgetooltip        = attribute "edgetooltip"+epsilon            :: Lens' Attributes (Maybe Text)+epsilon            = attribute "epsilon"+esep               :: Lens' Attributes (Maybe Text)+esep               = attribute "esep"+fillcolor          :: Lens' Attributes (Maybe Text)+fillcolor          = attribute "fillcolor"+fixedsize          :: Lens' Attributes (Maybe Text)+fixedsize          = attribute "fixedsize"+fontcolor          :: Lens' Attributes (Maybe Text)+fontcolor          = attribute "fontcolor"+fontname           :: Lens' Attributes (Maybe Text)+fontname           = attribute "fontname"+fontnames          :: Lens' Attributes (Maybe Text)+fontnames          = attribute "fontnames"+fontpath           :: Lens' Attributes (Maybe Text)+fontpath           = attribute "fontpath"+fontsize           :: Lens' Attributes (Maybe Text)+fontsize           = attribute "fontsize"+forcelabels        :: Lens' Attributes (Maybe Text)+forcelabels        = attribute "forcelabels"+gradientangle      :: Lens' Attributes (Maybe Text)+gradientangle      = attribute "gradientangle"+group              :: Lens' Attributes (Maybe Text)+group              = attribute "group"+headURL            :: Lens' Attributes (Maybe Text)+headURL            = attribute "headURL"+head_lp            :: Lens' Attributes (Maybe Text)+head_lp            = attribute "head_lp"+headclip           :: Lens' Attributes (Maybe Text)+headclip           = attribute "headclip"+headhref           :: Lens' Attributes (Maybe Text)+headhref           = attribute "headhref"+headlabel          :: Lens' Attributes (Maybe Text)+headlabel          = attribute "headlabel"+headport           :: Lens' Attributes (Maybe Text)+headport           = attribute "headport"+headtarget         :: Lens' Attributes (Maybe Text)+headtarget         = attribute "headtarget"+headtooltip        :: Lens' Attributes (Maybe Text)+headtooltip        = attribute "headtooltip"+height             :: Lens' Attributes (Maybe Text)+height             = attribute "height"+href               :: Lens' Attributes (Maybe Text)+href               = attribute "href"+image              :: Lens' Attributes (Maybe Text)+image              = attribute "image"+imagepath          :: Lens' Attributes (Maybe Text)+imagepath          = attribute "imagepath"+imagepos           :: Lens' Attributes (Maybe Text)+imagepos           = attribute "imagepos"+imagescale         :: Lens' Attributes (Maybe Text)+imagescale         = attribute "imagescale"+inputscale         :: Lens' Attributes (Maybe Text)+inputscale         = attribute "inputscale"+label              :: Lens' Attributes (Maybe Text)+label              = attribute "label"+labelURL           :: Lens' Attributes (Maybe Text)+labelURL           = attribute "labelURL"+label_scheme       :: Lens' Attributes (Maybe Text)+label_scheme       = attribute "label_scheme"+labelangle         :: Lens' Attributes (Maybe Text)+labelangle         = attribute "labelangle"+labeldistance      :: Lens' Attributes (Maybe Text)+labeldistance      = attribute "labeldistance"+labelfloat         :: Lens' Attributes (Maybe Text)+labelfloat         = attribute "labelfloat"+labelfontcolor     :: Lens' Attributes (Maybe Text)+labelfontcolor     = attribute "labelfontcolor"+labelfontname      :: Lens' Attributes (Maybe Text)+labelfontname      = attribute "labelfontname"+labelfontsize      :: Lens' Attributes (Maybe Text)+labelfontsize      = attribute "labelfontsize"+labelhref          :: Lens' Attributes (Maybe Text)+labelhref          = attribute "labelhref"+labeljust          :: Lens' Attributes (Maybe Text)+labeljust          = attribute "labeljust"+labelloc           :: Lens' Attributes (Maybe Text)+labelloc           = attribute "labelloc"+labeltarget        :: Lens' Attributes (Maybe Text)+labeltarget        = attribute "labeltarget"+labeltooltip       :: Lens' Attributes (Maybe Text)+labeltooltip       = attribute "labeltooltip"+landscape          :: Lens' Attributes (Maybe Text)+landscape          = attribute "landscape"+layer              :: Lens' Attributes (Maybe Text)+layer              = attribute "layer"+layerlistsep       :: Lens' Attributes (Maybe Text)+layerlistsep       = attribute "layerlistsep"+layers             :: Lens' Attributes (Maybe Text)+layers             = attribute "layers"+layerselect        :: Lens' Attributes (Maybe Text)+layerselect        = attribute "layerselect"+layersep           :: Lens' Attributes (Maybe Text)+layersep           = attribute "layersep"+layout             :: Lens' Attributes (Maybe Text)+layout             = attribute "layout"+len                :: Lens' Attributes (Maybe Text)+len                = attribute "len"+levels             :: Lens' Attributes (Maybe Text)+levels             = attribute "levels"+levelsgap          :: Lens' Attributes (Maybe Text)+levelsgap          = attribute "levelsgap"+lhead              :: Lens' Attributes (Maybe Text)+lhead              = attribute "lhead"+lheight            :: Lens' Attributes (Maybe Text)+lheight            = attribute "lheight"+linelength         :: Lens' Attributes (Maybe Text)+linelength         = attribute "linelength"+lp                 :: Lens' Attributes (Maybe Text)+lp                 = attribute "lp"+ltail              :: Lens' Attributes (Maybe Text)+ltail              = attribute "ltail"+lwidth             :: Lens' Attributes (Maybe Text)+lwidth             = attribute "lwidth"+margin             :: Lens' Attributes (Maybe Text)+margin             = attribute "margin"+maxiter            :: Lens' Attributes (Maybe Text)+maxiter            = attribute "maxiter"+mclimit            :: Lens' Attributes (Maybe Text)+mclimit            = attribute "mclimit"+mindist            :: Lens' Attributes (Maybe Text)+mindist            = attribute "mindist"+minlen             :: Lens' Attributes (Maybe Text)+minlen             = attribute "minlen"+mode               :: Lens' Attributes (Maybe Text)+mode               = attribute "mode"+model              :: Lens' Attributes (Maybe Text)+model              = attribute "model"+newrank            :: Lens' Attributes (Maybe Text)+newrank            = attribute "newrank"+nodesep            :: Lens' Attributes (Maybe Text)+nodesep            = attribute "nodesep"+nojustify          :: Lens' Attributes (Maybe Text)+nojustify          = attribute "nojustify"+normalize          :: Lens' Attributes (Maybe Text)+normalize          = attribute "normalize"+notranslate        :: Lens' Attributes (Maybe Text)+notranslate        = attribute "notranslate"+nslimit            :: Lens' Attributes (Maybe Text)+nslimit            = attribute "nslimit"+nslimit1           :: Lens' Attributes (Maybe Text)+nslimit1           = attribute "nslimit1"+oneblock           :: Lens' Attributes (Maybe Text)+oneblock           = attribute "oneblock"+ordering           :: Lens' Attributes (Maybe Text)+ordering           = attribute "ordering"+orientation        :: Lens' Attributes (Maybe Text)+orientation        = attribute "orientation"+outputorder        :: Lens' Attributes (Maybe Text)+outputorder        = attribute "outputorder"+overlap            :: Lens' Attributes (Maybe Text)+overlap            = attribute "overlap"+overlap_scaling    :: Lens' Attributes (Maybe Text)+overlap_scaling    = attribute "overlap_scaling"+overlap_shrink     :: Lens' Attributes (Maybe Text)+overlap_shrink     = attribute "overlap_shrink"+pack               :: Lens' Attributes (Maybe Text)+pack               = attribute "pack"+packmode           :: Lens' Attributes (Maybe Text)+packmode           = attribute "packmode"+pad                :: Lens' Attributes (Maybe Text)+pad                = attribute "pad"+page               :: Lens' Attributes (Maybe Text)+page               = attribute "page"+pagedir            :: Lens' Attributes (Maybe Text)+pagedir            = attribute "pagedir"+pencolor           :: Lens' Attributes (Maybe Text)+pencolor           = attribute "pencolor"+penwidth           :: Lens' Attributes (Maybe Text)+penwidth           = attribute "penwidth"+peripheries        :: Lens' Attributes (Maybe Text)+peripheries        = attribute "peripheries"+pin                :: Lens' Attributes (Maybe Text)+pin                = attribute "pin"+pos                :: Lens' Attributes (Maybe Text)+pos                = attribute "pos"+quadtree           :: Lens' Attributes (Maybe Text)+quadtree           = attribute "quadtree"+quantum            :: Lens' Attributes (Maybe Text)+quantum            = attribute "quantum"+rank               :: Lens' Attributes (Maybe Text)+rank               = attribute "rank"+rankdir            :: Lens' Attributes (Maybe Text)+rankdir            = attribute "rankdir"+ranksep            :: Lens' Attributes (Maybe Text)+ranksep            = attribute "ranksep"+ratio              :: Lens' Attributes (Maybe Text)+ratio              = attribute "ratio"+rects              :: Lens' Attributes (Maybe Text)+rects              = attribute "rects"+regular            :: Lens' Attributes (Maybe Text)+regular            = attribute "regular"+remincross         :: Lens' Attributes (Maybe Text)+remincross         = attribute "remincross"+repulsiveforce     :: Lens' Attributes (Maybe Text)+repulsiveforce     = attribute "repulsiveforce"+resolution         :: Lens' Attributes (Maybe Text)+resolution         = attribute "resolution"+root               :: Lens' Attributes (Maybe Text)+root               = attribute "root"+rotate             :: Lens' Attributes (Maybe Text)+rotate             = attribute "rotate"+rotation           :: Lens' Attributes (Maybe Text)+rotation           = attribute "rotation"+samehead           :: Lens' Attributes (Maybe Text)+samehead           = attribute "samehead"+sametail           :: Lens' Attributes (Maybe Text)+sametail           = attribute "sametail"+samplepoints       :: Lens' Attributes (Maybe Text)+samplepoints       = attribute "samplepoints"+scale              :: Lens' Attributes (Maybe Text)+scale              = attribute "scale"+searchsize         :: Lens' Attributes (Maybe Text)+searchsize         = attribute "searchsize"+sep                :: Lens' Attributes (Maybe Text)+sep                = attribute "sep"+shape              :: Lens' Attributes (Maybe Text)+shape              = attribute "shape"+shapefile          :: Lens' Attributes (Maybe Text)+shapefile          = attribute "shapefile"+showboxes          :: Lens' Attributes (Maybe Text)+showboxes          = attribute "showboxes"+sides              :: Lens' Attributes (Maybe Text)+sides              = attribute "sides"+size               :: Lens' Attributes (Maybe Text)+size               = attribute "size"+skew               :: Lens' Attributes (Maybe Text)+skew               = attribute "skew"+smoothing          :: Lens' Attributes (Maybe Text)+smoothing          = attribute "smoothing"+sortv              :: Lens' Attributes (Maybe Text)+sortv              = attribute "sortv"+splines            :: Lens' Attributes (Maybe Text)+splines            = attribute "splines"+start              :: Lens' Attributes (Maybe Text)+start              = attribute "start"+style              :: Lens' Attributes (Maybe Text)+style              = attribute "style"+stylesheet         :: Lens' Attributes (Maybe Text)+stylesheet         = attribute "stylesheet"+tailURL            :: Lens' Attributes (Maybe Text)+tailURL            = attribute "tailURL"+tail_lp            :: Lens' Attributes (Maybe Text)+tail_lp            = attribute "tail_lp"+tailclip           :: Lens' Attributes (Maybe Text)+tailclip           = attribute "tailclip"+tailhref           :: Lens' Attributes (Maybe Text)+tailhref           = attribute "tailhref"+taillabel          :: Lens' Attributes (Maybe Text)+taillabel          = attribute "taillabel"+tailport           :: Lens' Attributes (Maybe Text)+tailport           = attribute "tailport"+tailtarget         :: Lens' Attributes (Maybe Text)+tailtarget         = attribute "tailtarget"+tailtooltip        :: Lens' Attributes (Maybe Text)+tailtooltip        = attribute "tailtooltip"+target             :: Lens' Attributes (Maybe Text)+target             = attribute "target"+tooltip            :: Lens' Attributes (Maybe Text)+tooltip            = attribute "tooltip"+truecolor          :: Lens' Attributes (Maybe Text)+truecolor          = attribute "truecolor"+vertices           :: Lens' Attributes (Maybe Text)+vertices           = attribute "vertices"+viewport           :: Lens' Attributes (Maybe Text)+viewport           = attribute "viewport"+voro_margin        :: Lens' Attributes (Maybe Text)+voro_margin        = attribute "voro_margin"+weight             :: Lens' Attributes (Maybe Text)+weight             = attribute "weight"+width              :: Lens' Attributes (Maybe Text)+width              = attribute "width"+xdotversion        :: Lens' Attributes (Maybe Text)+xdotversion        = attribute "xdotversion"+xlabel             :: Lens' Attributes (Maybe Text)+xlabel             = attribute "xlabel"+xlp                :: Lens' Attributes (Maybe Text)+xlp                = attribute "xlp"+z                  :: Lens' Attributes (Maybe Text)+z                  = attribute "z"
+ src/Text/Dot/Build.hs view
@@ -0,0 +1,183 @@+module Text.Dot.Build+  ( node+  , edge+  , (-->)+  , subgraphWith+  , subgraph+  , subgraphWith_+  , subgraph_+  , clusterWith+  , cluster+  , clusterWith_+  , cluster_+  ) where++import "this" Prelude++import Control.Lens+import Data.List.NonEmpty  qualified as NE++import Text.Dot.Attributes+import Text.Dot.Monad+import Text.Dot.Types+++--------------------------------------------------------------------------------+-- Entity creation functions++-- | Creates a node in the graph, at the current t'Path', with the given label.+--+-- The newly created node will be assigned all of the default 'Node' attributes+-- (see 'defaults'). This returns a new t'Entity' that uniquely identifies this+-- node in the graph, with the attribute "label" set to the given argument.+--+-- This function updates the 'its' entity to this node.+node :: MonadDot m => Text -> m Entity+node desc = do+  entity <- register Node+  its label ?= desc+  pure entity++-- | Creates an edge in the graph, at the current t'Path'.+--+-- The newly created edge will be assigned all of the default 'Edge' attributes+-- (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.+--+-- This function updates the 'its' entity to this edge.+edge :: MonadDot m => Entity -> Entity -> m Entity+edge a b = do+  na <- getTail a+  nb <- getHead b+  entity <- register Edge+  edgeInfo . at entity ?= EdgeInfo a b na nb+  pure entity++-- | Alias for 'edge'.+--+-- This can be used in both directed and undirected graphs: the rendering+-- process will tke care of using the correct symbol in the generated DOT file.+--+-- > graph do+-- >   x <- node "x"+-- >   y <- node "y"+-- >   z <- node "z"+-- >   x --> y+-- >   x --> z+--+-- This function updates the 'its' entity to this edge.+(-->) :: MonadDot m => Entity -> Entity -> 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.+--+-- This function updates the 'its' entity to this node *twice*: before executing+-- the callback, and before returning.+--+-- > graph do+-- >   (subgraphID, nodeID) <- subgraphWith \subgraphID -> 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++-- | 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 'subgraphWith', 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++-- | 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 'clusterWith', but does not return the cluster's t'Entity'.+clusterWith_ :: MonadDot m => (Entity -> m a) -> m a+clusterWith_ = fmap snd . recurse Cluster++-- | 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+++--------------------------------------------------------------------------------+-- Internal helpers++recurse :: MonadDot m => EntityType -> (Entity -> m a) -> m (Entity, a)+recurse etype callback = do+  entity <- register etype+  contextStack %= NE.cons mempty+  result <- withPath entity $ callback entity+  sub <- popContext+  subgraphInfo . at entity ?= sub+  latest .= entity+  pure (entity, result)++register :: MonadDot m => EntityType -> m Entity+register etype = do+  suffix <- use entityIndex+  let entity = Entity etype suffix+  defAttrs <- use $ defaultAttributes . at etype . non mempty+  context <>:= [entity]+  entityIndex += 1+  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
+ src/Text/Dot/Monad.hs view
@@ -0,0 +1,83 @@+module Text.Dot.Monad where++import "this" Prelude++import Control.Lens+import Control.Monad.RWS.Class+import Data.List.NonEmpty      qualified as NE++import Text.Dot.Types+++--------------------------------------------------------------------------------+-- Dot monad++-- | Dot creation monad.+newtype DotT m a = DotT (DotGraph -> Path -> m (a, DotGraph))+  deriving+    ( Functor+    , Applicative+    , Monad+    , MonadReader Path+    , MonadState  DotGraph+    , MonadIO+    , MonadWriter w+    , MonadError  e+    ) via (StateT DotGraph (ReaderT Path m))++instance MonadTrans DotT where+  lift x = DotT \s _ -> fmap (,s) x++-- | An alias for @DotT Identity@.+type Dot = DotT Identity++-- | The constraint that all functions require.+--+-- We choose to express this as a constraint rather than a typeclass+-- 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)+++--------------------------------------------------------------------------------+-- State manipulation++-- | Retrieve the current path.+--+-- The path is the stack of entities, representing the graph /+-- subgraphs / clusters between the root of the graph and the current+-- location.+--+-- > graph do+-- >   p1 <- currentPath     -- returns [$graphID]+-- >   subgraph do+-- >     cluster do+-- >       p2 <- currentPath -- returns [$clusterID, $subgraphID, $graphID]+-- >       doStuff+currentPath :: MonadDot m => m (NonEmpty Entity)+currentPath = asks unwrapPath++-- | Retrieves the unique ID of the last created t'Entity'.+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)++context :: Lens' DotGraph DotContext+context f d = fmap go (f c)+  where+    (c :| cs) = d ^. contextStack+    go nc = d & contextStack .~ nc :| cs++popContext :: MonadDot m => m DotContext+popContext = do+  c <- use context+  contextStack %= NE.fromList . NE.tail+  pure c
+ src/Text/Dot/Render.hs view
@@ -0,0 +1,228 @@+module Text.Dot.Render+  ( graphWithT+  , graphT+  , graphWith+  , graph+  , digraphWithT+  , digraphT+  , digraphWith+  , digraph+  , strictGraphWithT+  , strictGraphT+  , strictGraphWith+  , strictGraph+  , strictDigraphWithT+  , strictDigraphT+  , strictDigraphWith+  , strictDigraph+  ) where++import "this" Prelude++import Data.HashMap.Strict qualified as M+import Data.List.NonEmpty  qualified as NE+import Text.Builder        (Builder)+import Text.Builder        qualified as TB+import Text.Printf++import Text.Dot.Monad+import Text.Dot.Types+++--------------------------------------------------------------------------------+-- Render functions++-- | Renders a given graph.+--+-- 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 'Builder'. The callback takes the graph's identifier+-- as argument.+--+-- The result of the graph building expression itself is ignored.+graphWithT :: Monad m => (Entity -> DotT m a) -> m Builder+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 Builder+graphT = render "graph" "--" . const++-- | Renders a given graph.+--+-- Like 'graphWithT', but in the 'Dot' monad.+graphWith :: (Entity -> Dot a) -> Builder+graphWith = runIdentity . render "graph" "--"++-- | Renders a given graph.+--+-- Like 'graphT', but in the 'Dot' monad.+graph :: Dot a -> Builder+graph = runIdentity . render "graph" "--" . const++-- | 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 'Builder'. The callback takes the graph's identifier+-- as argument.+--+-- The result of the graph building expression itself is ignored.+digraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder+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 Builder+digraphT = render "digraph" "->" . const++-- | Renders a given graph.+--+-- Like 'digraphWithT', but in the 'Dot' monad.+digraphWith :: (Entity -> Dot a) -> Builder+digraphWith = runIdentity . render "digraph" "->"++-- | Renders a given graph.+--+-- Like 'digraphT', but in the 'Dot' monad.+digraph :: Dot a -> Builder+digraph = runIdentity . render "digraph" "->" . const++-- | 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 'Builder'. The callback takes the graph's identifier+-- as argument.+--+-- The result of the graph building expression itself is ignored.+strictGraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder+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 Builder+strictGraphT = render "strict graph" "--" . const++-- | Renders a given graph.+--+-- Like 'strictGraphWithT', but in the 'Dot' monad.+strictGraphWith :: (Entity -> Dot a) -> Builder+strictGraphWith = runIdentity . render "strict graph" "--"++-- | Renders a given graph.+--+-- Like 'strictGraphT', but in the 'Dot' monad.+strictGraph :: Dot a -> Builder+strictGraph = runIdentity . render "strict graph" "--" . const++-- | 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 'Builder'. The callback takes the graph's identifier as argument.+--+-- The result of the graph building expression itself is ignored.+strictDigraphWithT :: Monad m => (Entity -> DotT m a) -> m Builder+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 Builder+strictDigraphT = render "strict digraph" "->" . const++-- | Renders a given graph.+--+-- Like 'strictDigraphWithT', but in the 'Dot' monad.+strictDigraphWith :: (Entity -> Dot a) -> Builder+strictDigraphWith = runIdentity . render "strict digraph" "->"++-- | Renders a given graph.+--+-- Like 'strictDigraphT', but in the 'Dot' monad.+strictDigraph :: Dot a -> Builder+strictDigraph = runIdentity . render "strict digraph" "->" . const+++--------------------------------------------------------------------------------+-- Internal helpers++render :: Monad m => Builder -> Builder -> (Entity -> DotT m a) -> m Builder+render gtype arrow f = do+  let root = Entity Subgraph (-1)+  allGraph <- run root (f root)+  pure $ TB.intercalate "\n" $ visit allGraph gtype arrow root++indent :: [Builder] -> [Builder]+indent = map ("  " <>)++visit :: DotGraph -> Builder -> Builder -> Entity -> [Builder]+visit DotGraph {..} gtype arrow = visitGraph+  where+    magnitude = ceiling (logBase 10 (fromIntegral _entityIndex :: Double)) :: Int+    intFormat = mconcat ["%0", show magnitude, "d"]++    renderIndex (Entity t i) =+      let prefix = case t of+            Subgraph -> "subgraph"+            Cluster  -> "cluster"+            Node     -> "node"+            Edge     -> error "Text.Dot.Render.visit: tried to render an edge id"+          suffix = TB.string $ printf intFormat i+      in prefix <> suffix++    visitAttribute (name, value) =+      mconcat [TB.text name, "=\"", TB.text value, "\""]++    visitAttributes =+      map visitAttribute . M.toList++    visitEntity e =+      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)++    visitEntities =+      concatMap visitEntity . reverse++    visitNode e attrs =+      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.run $ renderIndex o1) | getType o1 == Cluster]+          <> M.fromList [("lhead", TB.run $ renderIndex o2) | getType o2 == Cluster]+        , "]"+        ]++    visitGraph e =+      visitInner gtype e (fromMaybe mempty $ M.lookup e _entityAttributes) (NE.head _contextStack)++    visitSubgraph e =+      visitInner ("subgraph " <> renderIndex e) e++    visitInner etype _ attrs entities = concat+      [ [etype <> " {"]+      , indent $ map (<> ";") $ visitAttributes attrs+      , visitEntities entities+      , ["}"]+      ]
+ src/Text/Dot/Types.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE TemplateHaskell #-}++module Text.Dot.Types where++import "this" Prelude++import Control.Lens+import Data.Hashable+++--------------------------------------------------------------------------------+-- Entities++-- | Represents the type of a graph entity.+--+-- DOT distinguishes between graphs, nodes, edges, and subgraphs /+-- clusters. This type differs slightly: it does not have a value for graphs, as it+-- is never required, and we differentiate subgraphs and clusters.+--+-- This type is used internally to distinguish entities, mostly for the purpose+-- of default attributes (see 'Text.Dot.defaults').+data EntityType = Node | Edge | Subgraph | Cluster+  deriving (Show, Eq, Ord, Enum, Bounded)++instance Hashable EntityType where+  hashWithSalt s e = hashWithSalt s (fromEnum e)++-- | Opaque identifier for graph entities.+--+-- This type uniquely identifies an entity within the graph. To create one, see+-- 'Text.Dot.node', 'Text.Dot.edge', 'Text.Dot.subgraph', or 'Text.Dot.cluster'.+data Entity = Entity EntityType Int+  deriving (Eq, Ord)++instance Hashable Entity where+  hashWithSalt s (Entity t i) = s `hashWithSalt` t `hashWithSalt` i++-- | Retrieves the type of a given t'Entity'.+getType :: Entity -> EntityType+getType (Entity t _) = t+++--------------------------------------------------------------------------------+-- Internal state++-- | An entity's attributes.+--+-- Attributes are untyped, and are a simple mapping from 'Text' to 'Text', for+-- flexibility.+type Attributes = HashMap Text Text++-- | 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'.+newtype Path = Path { unwrapPath :: NonEmpty Entity }++makePrisms ''Path++type DotContext = [Entity]++data EdgeInfo = EdgeInfo Entity Entity Entity Entity++-- | Internal opaque graph state.+data DotGraph = DotGraph+  { _defaultAttributes :: HashMap EntityType Attributes+  , _entityAttributes  :: HashMap Entity Attributes+  , _edgeInfo          :: HashMap Entity EdgeInfo+  , _subgraphInfo      :: HashMap Entity DotContext+  , _contextStack      :: NonEmpty DotContext+  , _entityIndex       :: Int+  , _latest            :: Entity+  }++makeLenses ''DotGraph++initialGraph :: Entity -> DotGraph+initialGraph = DotGraph mempty mempty mempty mempty (pure mempty) 0
+ test/Golden.hs view
@@ -0,0 +1,119 @@+{- AUTOCOLLECT.TEST -}++module Golden+  ( {- AUTOCOLLECT.TEST.export -}+  ) where++import "this" Prelude++import Control.Lens+import Data.Text.Lazy          qualified as T+import Data.Text.Lazy.Encoding qualified as T+import System.FilePath+import Test.Tasty+import Test.Tasty.Golden+import Text.Builder            qualified as TB+import Text.Dot++go :: String -> TB.Builder -> TestTree+go testname = goldenVsString testname filename . pure . builderToBytestring+  where+    filename = "test" </> "golden" </> intercalate "_" (words testname) <> ".dot"+    builderToBytestring = T.encodeUtf8 . T.fromStrict . TB.run . (<> "\n")++test =+  go "simple graph" $+    graph do+      a <- node "a"+      b <- node "b"+      c <- node "c"+      a --> b+      a --> b+      b --> c+      b --> c+      subgraph do+        d <- node "d"+        c --> d+        d --> a++test =+  go "digraph with attributes" $+    digraph do+      a <- node "a"+      its color ?= "red"+      its distortion %= ifAbsent "2"++      b <- node "b"+      c <- node "c"++      a --> b+      its style ?= "dotted"++      b --> c+      its color .= Just "green"++test =+  go "strict digraph with clusters" $+    strictDigraph do+      a <- cluster_ do+        its label ?= "cluster A"+        node "a"+      b <- cluster_ do+        its label ?= "cluster B"+        node "b"+      a --> b+      its style ?= "dotted"+      a --> b++test =+  go "automatic compound" $+    digraph do+      (clusterA1, _) <-+        cluster do+          its label ?= "cluster A1"+          cluster do+            its label ?= "cluster A2"+            cluster do+              its label ?= "cluster A3"+              node "a"+      (clusterB3, _) <-+        cluster_ do+          its label ?= "cluster B1"+          cluster_ do+            its label ?= "cluster B2"+            cluster do+              its label ?= "cluster B3"+              node "b"+      clusterA1 --> clusterB3++test =+  go "path test" $+    strictGraph do+      cluster do+        its label ?= "ROOT"+        makeNode+        cluster do+          its label ?= "L"+          makeNode+          cluster do+            its label ?= "L"+            makeNode+            cluster do+              its label ?= "L"+              makeNode+            cluster do+              its label ?= "R"+              makeNode+        cluster_ do+          its label ?= "R"+          makeNode+          cluster do+            its label ?= "L"+            makeNode+  where+    makeNode = do+      entityStack <- currentPath+      path <- sequence do+        eid <- toList entityStack+        pure $ use $ attributes eid . label+      node $ TB.run $ TB.intercalate " > " $ reverse $ map TB.text $ catMaybes path
+ test/Reporter.hs view
@@ -0,0 +1,134 @@+module Reporter (customReporter) where++import "this" Prelude++import Control.Concurrent.STM qualified as STM+import Data.IntMap            qualified as IM+import Data.Maybe             (mapMaybe)+import Data.Proxy+import Data.Tagged+import Data.Text              qualified as T+import Data.Text.IO           qualified as T+import System.Directory+import System.FilePath+import Test.Tasty+import Test.Tasty.Options+import Test.Tasty.Providers+import Test.Tasty.Runners+import Text.Builder           qualified as TB+++-- custom CI reporter++customReporter :: String -> Ingredient+customReporter = TestReporter [Option (Proxy :: Proxy PathPrefix)] . mkRunner+++-- option++newtype PathPrefix = PathPrefix FilePath+  deriving (IsString)++instance IsOption PathPrefix where+  defaultValue = "report"+  parseValue = Just . PathPrefix+  optionName = Tagged "report"+  optionHelp = Tagged "prefix for output files"+++-- internal monad++newtype FoldMonad m a = FoldMonad (StateT Int m a)+  deriving ( Functor+           , Applicative+           , Monad+           , MonadState Int+           , MonadIO+           )++runFold :: Monad m => FoldMonad m a -> m a+runFold (FoldMonad m) = evalStateT m 0++getIndex :: Monad m => FoldMonad m Int+getIndex = get <* modify (+1)+++-- cursed+--+-- a monoid instance is required, but not actually used, since we run our own+-- custon fold. `foldTestTree` just uses mempty once. so we make those weird+-- instances just for compatibility++instance (Monad m, Semigroup a) => Semigroup (FoldMonad m a) where+  (<>) = liftA2 (<>)++instance (Monoid a, Monad m) => Monoid (FoldMonad m a) where+  mempty = pure mempty+++-- runner implemetation++mkRunner :: String -> OptionSet -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool))+mkRunner suiteName options testTree =+  pure \statusMap -> do+    let PathPrefix prefix = lookupOption options+        summaryFile = prefix ++ "-summary.md"+        failingFile = prefix ++ "-failing.md"+    createDirectoryIfMissing True =<< canonicalizePath (takeDirectory prefix)+    result <- runFold $ foldTestTree (customFold statusMap) options testTree+    pure \timeElapsed -> do+      let+        total   = length result+        failure = length $ mapMaybe snd result+        success = total - failure+        summary = TB.intercalate " | "+          [ TB.string suiteName+          , TB.decimal total+          , TB.decimal success+          , TB.decimal failure+          , TB.decimal @Int $ round $ timeElapsed * 1000+          ]+        failing = TB.intercalate "\n" do+          (path, Just desc) <- result+          pure $ mconcat+            [ "<tr><td>"+            , TB.intercalate " &gt; " $ map TB.text path+            , "</td><td>"+            , TB.text desc+            , "</td></tr>"+            ] <> "\n"+      T.writeFile summaryFile $ TB.run ("| " <> summary <> " |\n")+      T.writeFile failingFile $ TB.run failing+      pure $ failure == 0++customFold :: StatusMap -> TreeFold (FoldMonad IO [([Text], Maybe Text)])+customFold status = trivialFold+  { foldSingle   = visitTest+  , foldGroup    = visitGroup+  }+  where+    visitTest :: forall t. OptionSet -> TestName -> t -> FoldMonad IO [([Text], Maybe Text)]+    visitTest _options testName _test = do+      index <- getIndex+      description <- liftIO $ readResult $ status IM.! index+      pure $ pure ([T.pack testName], description)++    visitGroup _options groupName actions = do+      results <- concat <$> sequence actions+      pure do+        (testPath, testDesc) <- results+        pure (T.pack groupName : testPath, testDesc)++readResult :: STM.TVar Status -> IO (Maybe Text)+readResult var =+  STM.atomically $+    STM.readTVar var >>= \case+      Done result -> pure $ getDescription result+      _           -> STM.retry++getDescription :: Result -> Maybe Text+getDescription result = case resultOutcome result of+  Success                        -> Nothing+  Failure (TestTimedOut       _) -> Just "TimeOut"+  Failure (TestThrewException e) -> Just (T.pack $ show e)+  _                              -> Just (T.pack $ resultDescription result)
+ test/Tests.hs view
@@ -0,0 +1,27 @@+module Main where++{- AUTOCOLLECT.MAIN++group_type = tree+custom_main = True++-}++import "this" Prelude++import Data.List          (isPrefixOf)+import System.Environment+import Test.Tasty++import Reporter++{- AUTOCOLLECT.MAIN.imports -}++main :: IO ()+main = do+  args <- getArgs+  suiteName <- fromMaybe "graphwiz" <$> lookupEnv "TEST_SUITE_NAME"+  let tests = testGroup suiteName ({- AUTOCOLLECT.MAIN.tests -})+  if any ("--report" `isPrefixOf`) args+  then defaultMainWithIngredients [customReporter suiteName] tests+  else defaultMain tests