diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -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/ diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 --- /dev/null +++ b/.stylish-haskell.yaml @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.0.0 +----- +* First version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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) diff --git a/common/Prelude.hs b/common/Prelude.hs new file mode 100644 --- /dev/null +++ b/common/Prelude.hs @@ -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 diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -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" diff --git a/graphwiz.cabal b/graphwiz.cabal new file mode 100644 --- /dev/null +++ b/graphwiz.cabal @@ -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 diff --git a/src/Text/Dot.hs b/src/Text/Dot.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot.hs @@ -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). diff --git a/src/Text/Dot/Attributes.hs b/src/Text/Dot/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot/Attributes.hs @@ -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" diff --git a/src/Text/Dot/Build.hs b/src/Text/Dot/Build.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot/Build.hs @@ -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 diff --git a/src/Text/Dot/Monad.hs b/src/Text/Dot/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot/Monad.hs @@ -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 diff --git a/src/Text/Dot/Render.hs b/src/Text/Dot/Render.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot/Render.hs @@ -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 + , ["}"] + ] diff --git a/src/Text/Dot/Types.hs b/src/Text/Dot/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/Dot/Types.hs @@ -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 diff --git a/test/Golden.hs b/test/Golden.hs new file mode 100644 --- /dev/null +++ b/test/Golden.hs @@ -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 diff --git a/test/Reporter.hs b/test/Reporter.hs new file mode 100644 --- /dev/null +++ b/test/Reporter.hs @@ -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 + [ "" + , TB.intercalate " > " $ map TB.text path + , "" + , TB.text desc + , "" + ] <> "\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) diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -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