diff --git a/ChangeLog.md b/ChangeLog.md
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,3 +1,8 @@
+0.1
+===
+- Added AST example
+- defaultChartConfig/graphToChartWith refactor
+
0.0.3
===
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2020, Tony Day
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * 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.
+
+ * Neither the name of Tony Day nor the names of other
+ 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
+OWNER 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/dotparse.cabal b/dotparse.cabal
--- a/dotparse.cabal
+++ b/dotparse.cabal
@@ -1,127 +1,132 @@
-cabal-version: 3.0
-name: dotparse
-version: 0.0.3
-synopsis: dot language parsing and printing.
-description: This package provides parsing and printing of the dot language.
+cabal-version: 3.0
+name: dotparse
+version: 0.1.0.0
+license: BSD-3-Clause
+license-file: LICENSE
+copyright: Tony Day (c) 2020
+category: graphics
+author: Tony Day
+maintainer: tonyday567@gmail.com
+homepage: https://github.com/tonyday567/dotparse#readme
+bug-reports: https://github.com/tonyday567/dotparse/issues
+synopsis: dot language parsing and printing.
+description:
+ This package provides parsing and printing of the dot language.
- == Usage
+ == Usage
- >>> :set -XOverloadedLabels
- >>> :set -XOverloadedStrings
- >>> import DotParse
- >>> import Chart
- >>> import DotParse.Examples (exInt)
- >>> ex <- processGraph exInt
- >>> writeChartOptions "other/exga.svg" (graphToChartWith defaultChartConfig ex)
+ >>> :set -XOverloadedLabels
+ >>> :set -XOverloadedStrings
+ >>> import DotParse
+ >>> import Chart
+ >>> import Data.Text (pack)
+ >>> import DotParse.Examples (exInt)
+ >>> ex <- processGraph exInt
+ >>> writeChartOptions "other/exga.svg" (graphToChart ex)
- 
+ 
-category: project
-author: Tony Day
-maintainer: tonyday567@gmail.com
-copyright: Tony Day (c) 2022
-license: BSD-3-Clause
-homepage: https://github.com/tonyday567/dotparse#readme
-bug-reports: https://github.com/tonyday567/dotparse/issues
-build-type: Simple
-extra-doc-files: other/*.svg
- ChangeLog.md
- readme.org
+build-type: Simple
+tested-with: GHC == 8.10.7 || ==9.2.8 || ==9.4.5 || ==9.6.2 || ==9.8.1
+extra-doc-files:
+ ChangeLog.md
+ other/*.svg
+ readme.org
source-repository head
- type: git
- location: https://github.com/tonyday567/dotparse
+ type: git
+ location: https://github.com/tonyday567/dotparse
+common ghc-options-stanza
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Widentities
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wpartial-fields
+ -Wredundant-constraints
+
common ghc2021-stanza
- if impl(ghc >=9.2)
- default-language:
- GHC2021
- if impl(ghc <9.2)
- default-language:
- Haskell2010
- default-extensions:
- BangPatterns
- BinaryLiterals
- ConstrainedClassMethods
- ConstraintKinds
- DeriveDataTypeable
- DeriveFoldable
- DeriveFunctor
- DeriveGeneric
- DeriveLift
- DeriveTraversable
- DoAndIfThenElse
- EmptyCase
- EmptyDataDecls
- EmptyDataDeriving
- ExistentialQuantification
- ExplicitForAll
- FlexibleContexts
- FlexibleInstances
- ForeignFunctionInterface
- GADTSyntax
- GeneralisedNewtypeDeriving
- HexFloatLiterals
- ImplicitPrelude
- InstanceSigs
- KindSignatures
- MonomorphismRestriction
- MultiParamTypeClasses
- NamedFieldPuns
- NamedWildCards
- NumericUnderscores
- PatternGuards
- PolyKinds
- PostfixOperators
- RankNTypes
- RelaxedPolyRec
- ScopedTypeVariables
- StandaloneDeriving
- StarIsType
- TraditionalRecordSyntax
- TupleSections
- TypeApplications
- TypeOperators
- TypeSynonymInstances
- if impl(ghc <9.2) && impl(ghc >=8.10)
- default-extensions:
- ImportQualifiedPost
- StandaloneKindSignatures
+ if impl ( ghc >= 9.2 )
+ default-language: GHC2021
-common ghc-options-stanza
- ghc-options:
- -Wall
- -Wcompat
- -Wincomplete-record-updates
- -Wincomplete-uni-patterns
- -Wredundant-constraints
- -Widentities
- -Wpartial-fields
+ if impl ( ghc < 9.2 )
+ default-language: Haskell2010
+ default-extensions:
+ BangPatterns
+ BinaryLiterals
+ ConstrainedClassMethods
+ ConstraintKinds
+ DeriveDataTypeable
+ DeriveFoldable
+ DeriveFunctor
+ DeriveGeneric
+ DeriveLift
+ DeriveTraversable
+ DoAndIfThenElse
+ EmptyCase
+ EmptyDataDecls
+ EmptyDataDeriving
+ ExistentialQuantification
+ ExplicitForAll
+ FlexibleContexts
+ FlexibleInstances
+ ForeignFunctionInterface
+ GADTSyntax
+ GeneralisedNewtypeDeriving
+ HexFloatLiterals
+ ImplicitPrelude
+ InstanceSigs
+ KindSignatures
+ MonomorphismRestriction
+ MultiParamTypeClasses
+ NamedFieldPuns
+ NamedWildCards
+ NumericUnderscores
+ PatternGuards
+ PolyKinds
+ PostfixOperators
+ RankNTypes
+ RelaxedPolyRec
+ ScopedTypeVariables
+ StandaloneDeriving
+ StarIsType
+ TraditionalRecordSyntax
+ TupleSections
+ TypeApplications
+ TypeOperators
+ TypeSynonymInstances
-library
- import: ghc2021-stanza
- import: ghc-options-stanza
- hs-source-dirs: src
- build-depends:
- , algebraic-graphs >=0.6 && <0.8
- , base >=4.7 && <5
- , bytestring >=0.11.3 && <0.13
- , chart-svg >=0.3 && < 0.5
- , containers ^>=0.6
- , flatparse >=0.3.2 && <0.6
- , numhask-space >=0.10 && <0.12
- , optics-core ^>=0.4
- , process-extras ^>=0.7.4
- , string-interpolate ^>=0.3
- , template-haskell >=2.16 && < 2.21
- , text >=1.2 && <2.1
- , these >=1.1.1 && < 1.3
+ if impl ( ghc < 9.2 ) && impl ( ghc >= 8.10 )
+ default-extensions:
+ ImportQualifiedPost
+ StandaloneKindSignatures
- exposed-modules:
- DotParse
- DotParse.Examples
- DotParse.Examples.NumHask
- DotParse.FlatParse
- DotParse.FlatParse.TH
- DotParse.Types
+library
+ import: ghc-options-stanza
+ import: ghc2021-stanza
+ hs-source-dirs: src
+ build-depends:
+ , algebraic-graphs >=0.6 && <0.8
+ , base >=4.7 && <5
+ , bytestring >=0.11.3 && <0.13
+ , chart-svg >=0.6 && <0.7
+ , containers >=0.6 && <0.8
+ , flatparse >=0.3.5 && <0.6
+ , numhask-space >=0.10 && <0.12
+ , optics-core >=0.4 && <0.5
+ , process-extras >=0.7.4 && <0.8
+ , string-interpolate >=0.3 && <0.4
+ , template-haskell >=2.16 && <2.22
+ , text >=1.2 && <2.2
+ , these >=1.1 && <1.3
+ exposed-modules:
+ DotParse
+ DotParse.Examples
+ DotParse.Examples.AST
+ DotParse.Examples.NumHask
+ DotParse.FlatParse
+ DotParse.FlatParse.TH
+ DotParse.Types
diff --git a/other/ast.svg b/other/ast.svg
new file mode 100644
--- /dev/null
+++ b/other/ast.svg
@@ -0,0 +1,1114 @@
+
+
+
+
+
diff --git a/other/exga.svg b/other/exga.svg
--- a/other/exga.svg
+++ b/other/exga.svg
@@ -1,4 +1,4 @@
-
+}
+svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji";
+}
+
+ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace;
+}
+
+012345678910111213141516171819
diff --git a/other/nh.svg b/other/nh.svg
--- a/other/nh.svg
+++ b/other/nh.svg
@@ -1,4 +1,4 @@
-
+}
+svg { font-family: system-ui,-apple-system,"Segoe UI",Roboto,"Helvetica Neue",Arial,"Noto Sans","Liberation Sans",sans-serif,"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji";
+}
+
+ticktext { font-family: SFMono-Regular,Menlo,Monaco,Consolas,"Liberation Mono","Courier New",monospace;
+}
+
+ActionsAdditiveBasisDirectionDistributiveDivisiveExpFieldFieldIntegralMultiplicativeQuotientFieldRatioRingSubtractiveTrigField
diff --git a/readme.org b/readme.org
--- a/readme.org
+++ b/readme.org
@@ -1,6 +1,6 @@
#+TITLE: dotparse
-[[https://hackage.haskell.org/package/dotparse][file:https://img.shields.io/hackage/v/dotparse.svg]]
+[[https://hackage.haskell.org/package/dotparse][file:https://img.shields.io/hackage/v/dotparse.svg]] [[https://github.com/tonyday567/chart-svg/actions?query=workflow%3Ahaskell-ci][file:https://github.com/tonyday567/dotparse/workflows/haskell-ci/badge.svg]]
* Introduction
@@ -165,9 +165,9 @@
ByteString of the processed Graph
- #+begin_src haskell :results output
+#+begin_src haskell :results output
BS.putStr =<< processDot Directed (dotPrint defaultDotConfig exInt)
- #+end_src
+#+end_src
** processGraph
@@ -187,44 +187,41 @@
#+begin_src haskell :file other/exga.svg :results output graphics file :exports both
import Chart (writeChartOptions)
-writeChartOptions "other/exga.svg" (graphToChartWith defaultChartConfig exGraphAugmented)
+writeChartOptions "other/exga.svg" (graphToChart exGraphAugmented)
#+end_src
#+RESULTS:
[[file:other/exga.svg]]
* Development
-
** imports
-#+begin_src haskell :results output
+#+begin_src haskell-ng :results output
:reload
-:set prompt "> "
:set -XOverloadedLabels
:set -XOverloadedStrings
:set -Wno-type-defaults
+:set -Wno-x-partial
:set -XImportQualifiedPost
import Chart
import Optics.Core
import FlatParse.Basic qualified as FP
import qualified Data.ByteString as BS
+import qualified Data.Text as Text
import qualified Data.ByteString.Char8 as Char8
+import Algebra.Graph qualified as G
+import Data.Monoid
import GHC.Exts
import DotParse
import DotParse.Examples
+import DotParse.Examples.AST
import DotParse.Examples.NumHask
+import DotParse.Examples.Base
import Data.Proxy
print "ok"
#+end_src
-#+RESULTS:
-: [3 of 6] Compiling DotParse.Types ( src/DotParse/Types.hs, interpreted ) [Source file changed]
-: [5 of 6] Compiling DotParse.Examples.NumHask ( src/DotParse/Examples/NumHask.hs, interpreted ) [Source file changed]
-: Ok, six modules loaded.
-: >
-: ok
-
-** write examples
+** testAll
Round-trip test
@@ -252,36 +249,14 @@
ex15
#+end_example
-Render examples
+* chart-svg AST
-#+begin_src haskell
-svgAll
+#+begin_src haskell-ng :results output
+g1 = dotAST allSC componentEdges
+BS.writeFile "other/ast.dot" $ dotPrint defaultDotConfig g1
#+end_src
-#+RESULTS:
-#+begin_example
-ex0
-ex1
-ex2
-ex3
-ex4
-ex5
-ex6
-ex7
-ex8
-ex9
-ex10
-ex11
-ex12
-ex13
-ex14
-ex15
-#+end_example
-
-** numhask example
-
- #+begin_src haskell
-writeNHChart
- #+end_src
+#+begin_src sh :results output
+dot other/ast.dot -Tsvg >other/ast.svg
+#+end_src
-This is bugged downstream as chart-svg uses the link string (which is very long compared with the displayed text) to estimate the bounding box and results in a very wide chart with a lot of white space either side.
diff --git a/src/DotParse/Examples.hs b/src/DotParse/Examples.hs
--- a/src/DotParse/Examples.hs
+++ b/src/DotParse/Examples.hs
@@ -514,9 +514,9 @@
-- | algebraic graph example
--
--- >>> exGraph = defaultGraph & addStatements (toStatements Directed (Char8.pack . show <$> exAGraph))
--- >>> exGraphAugmented <- processGraph exGraph
--- >>> writeChartOptions "other/exga.svg" (graphToChartWith defaultChartConfig exGraphAugmented)
+-- > exGraph = defaultGraph & addStatements (toStatements Directed (Char8.pack . show <$> exAGraph))
+-- > exGraphAugmented <- processGraph exGraph
+-- > writeChartOptions "other/exga.svg" (graphToChart exGraphAugmented)
--
-- 
exAGraph :: G.Graph Int
diff --git a/src/DotParse/Examples/AST.hs b/src/DotParse/Examples/AST.hs
new file mode 100644
--- /dev/null
+++ b/src/DotParse/Examples/AST.hs
@@ -0,0 +1,592 @@
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+-- | Example of Dot graph construction for the class heirarchy.
+module DotParse.Examples.AST where
+
+import Algebra.Graph.Labelled qualified as L
+import Data.ByteString (ByteString)
+import Data.ByteString.Char8 qualified as B
+import Data.List qualified as List
+import Data.List.NonEmpty hiding (filter, head, length, map, zip, zipWith, (!!))
+import Data.Map.Strict qualified as Map
+import Data.Maybe
+import Data.Monoid
+import Data.String.Interpolate
+import Data.These
+import DotParse.Types
+import GHC.Generics
+import Optics.Core
+import Prelude hiding (replicate)
+
+-- $setup
+-- >>> import DotParse
+-- >>> :set -XOverloadedStrings
+
+-- | A Haskell class and (informal) list of sub-components.
+data SubComponents = SubComponents
+ { classComponent :: ByteString,
+ subComponents :: [ByteString]
+ }
+ deriving (Eq, Show, Ord, Generic)
+
+-- | Relationship between a class, a sub-component and the class of the sub-component.
+data ComponentEdge = ComponentEdge
+ { edgeClassComponent :: ByteString,
+ edgeSubComponent :: ByteString,
+ subComponentClass :: ByteString,
+ edgeLabel :: Maybe ByteString
+ }
+ deriving (Eq, Show, Ord, Generic)
+
+-- | algebraic graph vertices
+graphVs :: (Monoid a) => [SubComponents] -> L.Graph a (ByteString, ByteString)
+graphVs cs =
+ L.vertices $
+ ((\x -> (x, x)) . view #classComponent <$> cs)
+ <> (mconcat $ subs <$> cs)
+
+-- | Convert sub-components to a list of class, subcomponent bytestring tuples.
+subs :: SubComponents -> [(ByteString, ByteString)]
+subs c = (view #classComponent c,) <$> view #subComponents c
+
+-- | algebraic graph edges
+graphEs :: [ComponentEdge] -> L.Graph (Maybe ByteString) (ByteString, ByteString)
+graphEs es =
+ L.edges ((\c -> (view #edgeLabel c, (view #edgeClassComponent c, view #edgeSubComponent c), (view #subComponentClass c, view #subComponentClass c))) <$> es)
+
+-- | algebraic graph
+graphAST :: [SubComponents] -> [ComponentEdge] -> L.Graph (Maybe ByteString) (ByteString, ByteString)
+graphAST cs es =
+ graphVs cs <> graphEs es
+
+-- | Create a list of 'SubComponents' from a list of 'ComponentEdge's
+fromCEs :: [ComponentEdge] -> [SubComponents]
+fromCEs es = fmap (uncurry SubComponents) $ Map.toList $ Map.fromListWith (<>) ((\e -> (view #edgeClassComponent e, [view #edgeSubComponent e])) <$> es)
+
+-- | Convert an algebraic Graph into dot record nodes
+recordNodes :: L.Graph (Maybe ByteString) (ByteString, ByteString) -> [Statement]
+recordNodes g = (\(s, cs) -> StatementNode $ NodeStatement (IDQuoted s) Nothing (Map.fromList ([(ID "label", IDQuoted (ls (s, cs)))] <> maybe [] (\url -> [(ID "URL", IDQuoted url)]) (toURL s)))) <$> supers
+ where
+ ls (s, cs) = B.intercalate "|" $ (" s <> "> " <> s) : fmap (\y -> " y <> "> " <> y) cs
+ supers = (\(s, cs) -> (s, filter (/= s) cs)) <$> (Map.toList $ Map.fromListWith (++) ((\(s, c) -> (s, [c])) <$> L.vertexList g))
+
+-- | Convert an algebraic Graph into dot edges
+recordEdges :: Directed -> L.Graph (Maybe ByteString) (ByteString, ByteString) -> [Statement]
+recordEdges d g =
+ ( \(l, (s0, c0), (s1, c1)) ->
+ StatementEdge $
+ EdgeStatement
+ (fromDirected d)
+ (EdgeID (IDQuoted s0) (Just (Port (This (IDQuoted ("x" <> c0))))))
+ (fromList [EdgeID (IDQuoted c1) (Just (Port (This (IDQuoted ("x" <> s1)))))])
+ (Map.fromList [(ID "label", IDQuoted (fromMaybe "x" l))])
+ )
+ <$> L.edgeList g
+
+-- | create Statements from a (edge labelled) algebraic graph
+--
+-- https://graphviz.org/Gallery/directed/datastruct.html
+toStatementsRecord :: Directed -> L.Graph (Maybe ByteString) (ByteString, ByteString) -> [Statement]
+toStatementsRecord d g =
+ recordEdges d g <> recordNodes g
+
+-- | Convert a node ID to a label for chart-svg charts
+-- Doing this directly in dot doesn't quite work because the engines get the width of the link wrong.
+toURL :: ByteString -> Maybe ByteString
+toURL name = fmap (\i' -> [i|https://hackage.haskell.org/package/#{view #itemPackage i'}/docs/#{view #itemModule i'}.html\#t:#{view #item i'}|]) item
+ where
+ item = List.find ((== name) . view #item) itemModules
+
+-- | AST 'Graph'
+--
+-- > gAST = dotAST allSC componentEdges
+-- > C.writeFile "other/ast.dot" $ dotPrint defaultDotConfig gAST
+-- > bsSvg <- processDotWith Directed ["-Tsvg"] (dotPrint defaultDotConfig gAST)
+-- > C.writeFile "other/ast.svg" bsSvg
+dotAST :: [SubComponents] -> [ComponentEdge] -> Graph
+dotAST sc ce =
+ defaultGraph
+ & set (attL GraphType (ID "size")) (Just $ IDQuoted "5")
+ & addStatements (toStatementsRecord Directed (graphAST sc ce))
+ & attL NodeType (ID "shape")
+ .~ Just (ID "record")
+ & gattL (ID "rankdir")
+ .~ Just (IDQuoted "LR")
+
+-- | Link values
+data ItemModule = ItemModule {item :: ByteString, itemModule :: ByteString, itemPackage :: ByteString} deriving (Eq, Show, Generic)
+
+-- | List of link values
+itemModules :: [ItemModule]
+itemModules =
+ [ ItemModule "ChartOptions" "Chart-Markup" "chart-svg",
+ ItemModule "MarkupOptions" "Chart-Markup" "chart-svg",
+ ItemModule "CssOptions" "Chart-Markup" "chart-svg",
+ ItemModule "ChartTree" "Chart-Primitive" "chart-svg",
+ ItemModule "Chart" "Chart-Primitive" "chart-svg",
+ ItemModule "HudOptions" "Chart-Hud" "chart-svg",
+ ItemModule "RenderStyle" "Chart-Markup" "chart-svg",
+ ItemModule "ChartAspect" "Chart-Primitive" "chart-svg",
+ ItemModule "ShapeRendering" "Chart-Markup" "chart-svg",
+ ItemModule "PreferColorScheme" "Chart-Primitive" "chart-svg",
+ ItemModule "Tree" "Data-Tree" "containers",
+ ItemModule "Priority" "Chart-Hud" "chart-svg",
+ ItemModule "TitleOptions" "Chart-Hud" "chart-svg",
+ ItemModule "AxisOptions" "Chart-Hud" "chart-svg",
+ ItemModule "LegendOptions" "Chart-Hud" "chart-svg",
+ ItemModule "FrameOptions" "Chart-Hud" "chart-svg",
+ ItemModule "Adjustments" "Chart-Hud" "chart-svg",
+ ItemModule "Ticks" "Chart-Hud" "chart-svg",
+ ItemModule "Tick" "Chart-Hud" "chart-svg",
+ ItemModule "Place" "Chart-Hud" "chart-svg",
+ ItemModule "TickStyle" "Chart-Hud" "chart-svg",
+ ItemModule "AxisBar" "Chart-Hud" "chart-svg",
+ ItemModule "HudChartSection" "Chart-Hud" "chart-svg",
+ ItemModule "TickExtend" "Chart-Hud" "chart-svg",
+ ItemModule "FormatN" "Data-FormatN" "formatn",
+ ItemModule "FStyle" "Data-FormatN" "formatn",
+ ItemModule "Colour" "Data-Colour" "chart-svg",
+ ItemModule "Style" "Chart-Style" "chart-svg",
+ ItemModule "EscapeText" "Chart-Style" "chart-svg",
+ ItemModule "GlyphShape" "Chart-Style" "chart-svg",
+ ItemModule "Anchor" "Chart-Style" "chart-svg",
+ ItemModule "LineCap" "Chart-Style" "chart-svg",
+ ItemModule "LineJoin" "Chart-Style" "chart-svg",
+ ItemModule "ScaleP" "Chart-Style" "chart-svg",
+ ItemModule "ChartData" "Chart-Primitive" "chart-svg",
+ ItemModule "PathData" "Data-Path" "chart-svg",
+ ItemModule "ArcInfo" "Data-Path" "chart-svg",
+ ItemModule "Rect" "NumHask-Space-Rect" "numhask-space",
+ ItemModule "Point" "NumHask-Space-Point" "numhask-space"
+ ]
+
+-- | list of chart-svg component edges
+componentEdges :: [ComponentEdge]
+componentEdges =
+ [ ComponentEdge "ChartOptions" "markupOptions" "MarkupOptions" (Just ""),
+ ComponentEdge "ChartOptions" "hudOptions" "HudOptions" (Just ""),
+ ComponentEdge "ChartOptions" "chartTree" "ChartTree" (Just ""),
+ ComponentEdge "MarkupOptions" "chartAspect" "ChartAspect" (Just ""),
+ ComponentEdge "MarkupOptions" "cssOptions" "CssOptions" (Just ""),
+ ComponentEdge "MarkupOptions" "renderStyle" "RenderStyle" (Just ""),
+ ComponentEdge "CssOptions" "shapeRendering" "ShapeRendering" (Just ""),
+ ComponentEdge "CssOptions" "preferColorScheme" "PreferColorScheme" (Just ""),
+ ComponentEdge "HudOptions" "axes" "AxisOptions" (Just "each % #item"),
+ ComponentEdge "HudOptions" "frames" "FrameOptions" (Just "each % #item"),
+ ComponentEdge "HudOptions" "legends" "LegendOptions" (Just "each % #item"),
+ ComponentEdge "HudOptions" "titles" "TitleOptions" (Just "each % #item"),
+ ComponentEdge "HudOptions" "axes" "Priority" (Just "each % #priority"),
+ ComponentEdge "HudOptions" "frames" "Priority" (Just "each % #priority"),
+ ComponentEdge "HudOptions" "legends" "Priority" (Just "each % #priority"),
+ ComponentEdge "HudOptions" "titles" "Priority" (Just "each % #priority"),
+ ComponentEdge "AxisOptions" "axisBar" "AxisBar" (Just "_Just"),
+ ComponentEdge "AxisOptions" "adjustments" "Adjustments" (Just "_Just"),
+ ComponentEdge "AxisOptions" "ticks" "Ticks" (Just ""),
+ ComponentEdge "AxisOptions" "place" "Place" (Just ""),
+ ComponentEdge "AxisBar" "style" "Style" (Just ""),
+ ComponentEdge "AxisBar" "anchorTo" "HudChartSection" (Just ""),
+ ComponentEdge "Tick" "formatN'" "FormatN" (Just "_Just"),
+ ComponentEdge "FormatN" "fstyle" "FStyle" (Just ""),
+ ComponentEdge "Tick" "tickExtend'" "TickExtend" (Just "_Just"),
+ ComponentEdge "Ticks" "tick" "Tick" (Just "_Just"),
+ ComponentEdge "Ticks" "glyphTick" "TickStyle" (Just "_Just"),
+ ComponentEdge "Ticks" "textTick" "TickStyle" (Just "_Just"),
+ ComponentEdge "Ticks" "lineTick" "TickStyle" (Just "_Just"),
+ ComponentEdge "TickStyle" "style" "Style" (Just ""),
+ ComponentEdge "TickStyle" "anchorTo" "HudChartSection" (Just ""),
+ ComponentEdge "FrameOptions" "frame" "Style" (Just "#frame % _Just"),
+ ComponentEdge "FrameOptions" "anchorTo" "HudChartSection" (Just ""),
+ ComponentEdge "TitleOptions" "style" "Style" (Just ""),
+ ComponentEdge "TitleOptions" "place" "Place" (Just ""),
+ ComponentEdge "TitleOptions" "anchor" "Anchor" (Just ""),
+ ComponentEdge "ChartTree" "tree" "Tree" (Just ""),
+ ComponentEdge "ChartTree" "charts'" "Chart" (Just "each"),
+ ComponentEdge "Chart" "chartStyle" "Style" (Just ""),
+ ComponentEdge "Chart" "chartData" "ChartData" (Just ""),
+ ComponentEdge "ChartData" "rectData'" "Rect" (Just "_Just % each"),
+ ComponentEdge "ChartData" "lineData'" "Point" (Just "_Just % each % each"),
+ ComponentEdge "ChartData" "glyphData'" "Point" (Just "_Just % each"),
+ ComponentEdge "ChartData" "textData'" "(Text,Point)" (Just "_Just % each"),
+ ComponentEdge "(Text,Point)" "_2" "Point" (Just ""),
+ ComponentEdge "ChartData" "pathData'" "PathData" (Just "_Just % each"),
+ ComponentEdge "ChartData" "blankData'" "Rect" (Just "_Just % each"),
+ ComponentEdge "LegendOptions" "textStyle" "Style" (Just ""),
+ ComponentEdge "LegendOptions" "frame" "Style" (Just "_Just"),
+ ComponentEdge "LegendOptions" "place" "Place" (Just ""),
+ ComponentEdge "LegendOptions" "scaleP" "ScaleP" (Just ""),
+ ComponentEdge "LegendOptions" "legendCharts" "Chart" (Just "each % _2 % each"),
+ ComponentEdge "PathData" "ArcP" "ArcInfo" (Just "(ArcP arcinfo _)"),
+ ComponentEdge "Style" "color" "Colour" (Just ""),
+ ComponentEdge "Style" "borderColor" "Colour" (Just ""),
+ ComponentEdge "Style" "scaleP" "ScaleP" (Just ""),
+ ComponentEdge "Style" "anchor" "Anchor" (Just ""),
+ ComponentEdge "Style" "translate" "Point" (Just "_Just"),
+ ComponentEdge "Style" "escapeText" "EscapeText" (Just ""),
+ ComponentEdge "Style" "frame" "Style" (Just "_Just"),
+ ComponentEdge "Style" "lineCap" "LineCap" (Just "_Just"),
+ ComponentEdge "Style" "lineJoin" "LineJoin" (Just "_Just"),
+ ComponentEdge "Style" "glyphShape" "GlyphShape" (Just "")
+ ]
+
+-- | list of chart-svg subcomponents
+allSC :: [SubComponents]
+allSC =
+ [ SubComponents
+ { classComponent = "AxisBar",
+ subComponents =
+ [ "style",
+ "size",
+ "buffer",
+ "overhang",
+ "anchorTo"
+ ]
+ },
+ SubComponents
+ { classComponent = "AxisOptions",
+ subComponents =
+ [ "axisBar",
+ "adjustments",
+ "ticks",
+ "place"
+ ]
+ },
+ SubComponents
+ { classComponent = "Chart",
+ subComponents =
+ [ "chartStyle",
+ "chartData"
+ ]
+ },
+ SubComponents
+ { classComponent = "ChartData",
+ subComponents =
+ [ "rectData'",
+ "lineData'",
+ "glyphData'",
+ "textData'",
+ "pathData'",
+ "blankData'"
+ ]
+ },
+ SubComponents
+ { classComponent = "ChartOptions",
+ subComponents =
+ [ "markupOptions",
+ "hudOptions",
+ "chartTree"
+ ]
+ },
+ SubComponents
+ { classComponent = "ChartTree",
+ subComponents =
+ [ "tree",
+ "charts'"
+ ]
+ },
+ SubComponents
+ { classComponent = "FrameOptions",
+ subComponents =
+ [ "frame",
+ "anchorTo",
+ "buffer"
+ ]
+ },
+ SubComponents
+ { classComponent = "HudOptions",
+ subComponents =
+ [ "axes",
+ "frames",
+ "legends",
+ "titles"
+ ]
+ },
+ SubComponents
+ { classComponent = "MarkupOptions",
+ subComponents =
+ [ "markupHeight",
+ "chartAspect",
+ "cssOptions",
+ "renderStyle"
+ ]
+ },
+ SubComponents
+ { classComponent = "(Text,Point)",
+ subComponents =
+ [ "_1",
+ "_2"
+ ]
+ },
+ SubComponents
+ { classComponent = "TickStyle",
+ subComponents =
+ [ "style",
+ "anchorTo",
+ "buffer"
+ ]
+ },
+ SubComponents
+ { classComponent = "Ticks",
+ subComponents =
+ [ "tick",
+ "glyphTick",
+ "textTick",
+ "lineTick"
+ ]
+ },
+ SubComponents
+ { classComponent = "TitleOptions",
+ subComponents =
+ [ "text",
+ "style",
+ "place",
+ "anchor",
+ "buffer"
+ ]
+ },
+ SubComponents
+ { classComponent = "RenderStyle",
+ subComponents =
+ [ "Compact",
+ "Indented"
+ ]
+ },
+ SubComponents
+ { classComponent = "CssOptions",
+ subComponents =
+ [ "shapeRendering",
+ "preferColorScheme",
+ "fontFamilies",
+ "cssExtra"
+ ]
+ },
+ SubComponents
+ { classComponent = "ChartAspect",
+ subComponents =
+ [ "FixedAspect",
+ "CanvasAspect",
+ "ChartAspect",
+ "UnscaledAspect"
+ ]
+ },
+ SubComponents
+ { classComponent = "HudChartSection",
+ subComponents =
+ [ "CanvasSection",
+ "CanvasStyleSection",
+ "HudSection",
+ "HudStyleSection"
+ ]
+ },
+ SubComponents
+ { classComponent = "Adjustments",
+ subComponents =
+ [ "maxXRatio",
+ "maxYRatio",
+ "angledRatio",
+ "allowDiagonal"
+ ]
+ },
+ SubComponents
+ { classComponent = "Tick",
+ subComponents =
+ [ "TickNone",
+ "TickLabels",
+ "TickRound",
+ "TickExact",
+ "TickPlaced",
+ "numTicks'",
+ "formatN'",
+ "tickExtend'"
+ ]
+ },
+ SubComponents
+ { classComponent = "TickExtend",
+ subComponents =
+ [ "TickExtend",
+ "NoTickExtend"
+ ]
+ },
+ SubComponents
+ { classComponent = "FStyle",
+ subComponents =
+ [ "FSDecimal",
+ "FSExponent",
+ "FSComma",
+ "FSFixed Int",
+ "FSPercent",
+ "FSDollar",
+ "FSPrec",
+ "FSCommaPrec",
+ "FSNone"
+ ]
+ },
+ SubComponents
+ { classComponent = "FormatN",
+ subComponents =
+ [ "fstyle",
+ "sigFigs",
+ "maxDistinguishIterations",
+ "addLPad",
+ "cutRightZeros"
+ ]
+ },
+ SubComponents
+ { classComponent = "ShapeRendering",
+ subComponents =
+ [ "UseGeometricPrecision",
+ "UseCssCrisp",
+ "NoShapeRendering"
+ ]
+ },
+ SubComponents
+ { classComponent = "PreferColorScheme",
+ subComponents =
+ [ "PreferHud",
+ "PreferDark",
+ "PreferLight",
+ "PreferNormal"
+ ]
+ },
+ SubComponents
+ { classComponent = "Place",
+ subComponents =
+ [ "PlaceLeft",
+ "PlaceRight",
+ "PlaceTop",
+ "PlaceBottom",
+ "PlaceAbsolute"
+ ]
+ },
+ SubComponents
+ { classComponent = "LegendOptions",
+ subComponents =
+ [ "legendSize",
+ "buffer",
+ "vgap",
+ "hgap",
+ "textStyle",
+ "innerPad",
+ "outerPad",
+ "frame",
+ "place",
+ "scaleChartsBy",
+ "scaleP",
+ "legendCharts"
+ ]
+ },
+ SubComponents
+ { classComponent = "Anchor",
+ subComponents =
+ [ "AnchorMiddle",
+ "AnchorStart",
+ "AnchorEnd"
+ ]
+ },
+ SubComponents
+ { classComponent = "Point",
+ subComponents =
+ [ "_x",
+ "_y"
+ ]
+ },
+ SubComponents
+ { classComponent = "PathData",
+ subComponents =
+ [ "StartP",
+ "LineP",
+ "CubicP",
+ "QuadP",
+ "ArcP"
+ ]
+ },
+ SubComponents
+ { classComponent = "ArcInfo",
+ subComponents =
+ [ "radii",
+ "phi",
+ "large",
+ "clockwise"
+ ]
+ },
+ SubComponents
+ { classComponent = "Style",
+ subComponents =
+ [ "size",
+ "borderSize",
+ "color",
+ "borderColor",
+ "scaleP",
+ "anchor",
+ "rotation",
+ "translate",
+ "escapeText",
+ "frame",
+ "lineCap",
+ "lineJoin",
+ "dasharray",
+ "dashoffset",
+ "hsize",
+ "vsize",
+ "vshift",
+ "glyphShape"
+ ]
+ },
+ SubComponents
+ { classComponent = "ScaleP",
+ subComponents =
+ [ "NoScaleP",
+ "ScalePX",
+ "ScalePY",
+ "ScalePMinDim",
+ "ScalePArea"
+ ]
+ },
+ SubComponents
+ { classComponent = "Colour",
+ subComponents =
+ [ "opac'",
+ "lightness'",
+ "chroma'",
+ "hue'"
+ ]
+ },
+ SubComponents
+ { classComponent = "EscapeText",
+ subComponents =
+ [ "EscapeText",
+ "NoEscapeText"
+ ]
+ },
+ SubComponents
+ { classComponent = "LineCap",
+ subComponents =
+ [ "LineCapButt",
+ "LineCapRound",
+ "LineCapSquare"
+ ]
+ },
+ SubComponents
+ { classComponent = "LineJoin",
+ subComponents =
+ [ "LineJoinMiter",
+ "LineJoinBevel",
+ "LineJoinRound"
+ ]
+ },
+ SubComponents
+ { classComponent = "GlyphShape",
+ subComponents =
+ [ "CircleGlyph",
+ "SquareGlyph",
+ "EllipseGlyph",
+ "RectSharpGlyph",
+ "RectRoundedGlyph",
+ "TriangleGlyph",
+ "VLineGlyph",
+ "HLineGlyph",
+ "PathGlyph"
+ ]
+ }
+ ]
diff --git a/src/DotParse/Examples/NumHask.hs b/src/DotParse/Examples/NumHask.hs
--- a/src/DotParse/Examples/NumHask.hs
+++ b/src/DotParse/Examples/NumHask.hs
@@ -6,7 +6,6 @@
module DotParse.Examples.NumHask where
import Algebra.Graph qualified as G
-import Chart
import Data.Bifunctor
import Data.Map.Strict qualified as Map
import Data.Monoid
@@ -14,13 +13,15 @@
import Data.Text (Text, pack)
import DotParse
import FlatParse.Basic
-import GHC.IO.Unsafe
import Optics.Core
import Prelude hiding (replicate)
-- $setup
-- >>> import DotParse
+-- >>> import Chart
+-- >>> import Optics.Core
-- >>> :set -XOverloadedStrings
+-- >>> :set -XOverloadedLabels
-- | Names of the various classes used in numhask
data Class
@@ -197,32 +198,27 @@
G.edges ((\(Dependency x y) -> (x, y)) <$> dependenciesNH dependencies)
<> G.vertices classesNH
--- | NumHask statements in a dot Graph with box shapes for the nodes.
-dotGraphNH :: Directed -> Graph
-dotGraphNH d =
- defaultGraph
- & #directed .~ Last (Just d)
- & addStatements (toStatements d (strToUtf8 . show <$> graphNHG))
- & attL NodeType (ID "shape") .~ Just (ID "box")
- & gattL (ID "rankdir") .~ Just (IDQuoted "BT")
-
--- | 'dotGraphNH' after being positionally processed via 'processGraph'
-dotGraphNH' :: Directed -> Graph
-dotGraphNH' d = unsafePerformIO $ processGraph (dotGraphNH d)
-{-# NOINLINE dotGraphNH' #-}
-
-- | Convert a node ID to a label for chart-svg charts
-- Doing this directly in dot doesn't quite work because the engines get the width of the link wrong.
-toLink :: ID -> Text
-toLink id_ = [i|#{t}|]
+toLinkNH :: ID -> Text
+toLinkNH id_ = [i|#{t}|]
where
t = pack (label id_)
m = Map.fromList (first (pack . show) <$> classesModule) Map.! t
--- | A chart-svg chart with label links
+-- | NumHask statements in a dot Graph with box shapes for the nodes.
--
--- > writeChartOptions "other/nh.svg" (graphToChart toLink (dotGraphNH' Directed))
+-- > g <- processGraph (dotGraphNH Directed)
+-- > writeChartOptions "other/nh.svg" (graphToChartWith (defaultChartConfig & set #chartVshift (-4) & set #textSize 12) toLinkNH g)
--
-- 
-writeNHChart :: IO ()
-writeNHChart = writeChartOptions "other/nh.svg" (graphToChartWith (defaultChartConfig & #labelf .~ toLink & #chartColor .~ over lightness' (* 0.5) (palette1 2) & #chartBackgroundColor .~ set opac' 0.1 (palette1 1)) (dotGraphNH' Directed))
+dotGraphNH :: Directed -> Graph
+dotGraphNH d =
+ defaultGraph
+ & #directed
+ .~ Last (Just d)
+ & addStatements (toStatements d (strToUtf8 . show <$> graphNHG))
+ & attL NodeType (ID "shape")
+ .~ Just (ID "box")
+ & gattL (ID "rankdir")
+ .~ Just (IDQuoted "BT")
diff --git a/src/DotParse/FlatParse/TH.hs b/src/DotParse/FlatParse/TH.hs
--- a/src/DotParse/FlatParse/TH.hs
+++ b/src/DotParse/FlatParse/TH.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
-- | TH stage restriction guff for flatparsing
module DotParse.FlatParse.TH where
diff --git a/src/DotParse/Types.hs b/src/DotParse/Types.hs
--- a/src/DotParse/Types.hs
+++ b/src/DotParse/Types.hs
@@ -90,7 +90,6 @@
import Data.Maybe
import Data.Monoid
import Data.Proxy
-import Data.String.Interpolate
import Data.Text (Text)
import Data.Text qualified as Text
import Data.These
@@ -106,6 +105,7 @@
-- >>> import DotParse
-- >>> import qualified Data.Map as Map
-- >>> import qualified FlatParse.Basic as FP
+-- >>> import qualified Data.ByteString as BS
-- >>> import FlatParse.Basic (runParser, Result)
-- >>> :set -XOverloadedStrings
@@ -171,6 +171,27 @@
instance Monoid Graph where
mempty = Graph mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty
+-- | 'Directed' graph of size 1.
+--
+-- >>> BS.putStr $ dotPrint defaultDotConfig defaultGraph <> "\n"
+-- digraph {
+-- node [height=0.5;shape=circle]
+-- graph [overlap=false;size="1!";splines=spline]
+-- edge [arrowsize=0.5]
+-- rankdir="TB"
+-- }
+defaultGraph :: Graph
+defaultGraph =
+ mempty
+ & set (attL NodeType (ID "height")) (Just $ IDDouble 0.5)
+ & set (attL NodeType (ID "shape")) (Just $ ID "circle")
+ & set (attL GraphType (ID "overlap")) (Just $ ID "false")
+ & set (attL GraphType (ID "size")) (Just $ IDQuoted "1!")
+ & set (attL GraphType (ID "splines")) (Just $ ID "spline")
+ & set (attL EdgeType (ID "arrowsize")) (Just $ IDDouble 0.5)
+ & set #directed (Last (Just Directed))
+ & set (gattL (ID "rankdir")) (Just (IDQuoted "TB"))
+
-- | global attributes lens
gattL :: ID -> Lens' Graph (Maybe ID)
gattL k = #globalAttributes % at k
@@ -211,9 +232,12 @@
ss <- wrapCurlyP (many dotParse)
let g =
(mempty :: Graph)
- & #strict .~ Last (Just me)
- & #directed .~ Last (Just d)
- & #graphid .~ Last i
+ & #strict
+ .~ Last (Just me)
+ & #directed
+ .~ Last (Just d)
+ & #graphid
+ .~ Last i
pure $ addStatements ss g
-- * Dot Grammar
@@ -285,6 +309,15 @@
--
-- >>> runDotParser "foo,
the bar and
the baz>" :: ID
-- IDHtml "foo,
the bar and
the baz>"
+--
+-- >>> runDotParser "shape=diamond" :: (ID,ID)
+-- (ID "shape",ID "diamond")
+--
+-- >>> runDotParser "fontname=\"Arial\"" :: (ID,ID)
+-- (ID "fontname",IDQuoted "Arial")
+--
+-- >>> runDotParser "[shape=diamond; color=blue] [label=label]" :: Map.Map ID ID
+-- fromList [(ID "color",ID "blue"),(ID "label",ID "label"),(ID "shape",ID "diamond")]
data ID = ID ByteString | IDInt Int | IDDouble Double | IDQuoted ByteString | IDHtml ByteString deriving (Eq, Show, Generic, Ord)
instance DotParse ID where
@@ -316,12 +349,6 @@
label (IDHtml h) = utf8ToStr h
-- | Attribute key-value pair of identifiers
---
--- >>> runDotParser "shape=diamond" :: (ID,ID)
--- (ID "shape",ID "diamond")
---
--- >>> runDotParser "fontname=\"Arial\"" :: (ID,ID)
--- (ID "fontname",IDQuoted "Arial")
instance DotParse (ID, ID) where
dotPrint cfg (x0, x1) = dotPrint cfg x0 <> "=" <> dotPrint cfg x1
@@ -334,9 +361,6 @@
-- | Attribute collections
--
--- >>> runDotParser "[shape=diamond; color=blue] [label=label]" :: Map.Map ID ID
--- fromList [(ID "color",ID "blue"),(ID "label",ID "label"),(ID "shape",ID "diamond")]
---
-- A given entity can have multiple attribute lists. For simplicity, these are mconcat'ed on parsing.
instance DotParse (Map.Map ID ID) where
dotPrint cfg as =
@@ -566,32 +590,6 @@
addStatements :: [Statement] -> Graph -> Graph
addStatements ss g = Prelude.foldr addStatement g ss
--- | default dot graph as a ByteString
-defaultBS :: ByteString
-defaultBS =
- [i|
-digraph {
- node [shape=circle
- ,height=0.5];
- graph [overlap=false
- ,splines=spline
- ,size="1!"];
- edge [arrowsize=0.5];
- }
-|]
-
--- | A default dot graph
---
--- >>> import qualified Data.ByteString.Char8 as B
--- >>> B.putStrLn $ dotPrint defaultDotConfig defaultGraph
--- digraph {
--- node [height=0.5;shape=circle]
--- graph [overlap=false;size="1!";splines=spline]
--- edge [arrowsize=0.5]
--- }
-defaultGraph :: Graph
-defaultGraph = runDotParser defaultBS
-
-- | run a dot string through graphviz, supplying arguments and collecting stdout
processDotWith :: Directed -> [String] -> ByteString -> IO ByteString
processDotWith d args i = do
@@ -695,15 +693,15 @@
setEdges_ g m =
g
& #edges
- .~ ( ( \((x0, x1), as) ->
- EdgeStatement
- (fromDirected (defDirected $ view #directed g))
- (EdgeID x0 Nothing)
- (EdgeID x1 Nothing :| [])
- as
- )
- <$> Map.toList m
+ .~ ( ( \((x0, x1), as) ->
+ EdgeStatement
+ (fromDirected (defDirected $ view #directed g))
+ (EdgeID x0 Nothing)
+ (EdgeID x1 Nothing :| [])
+ as
)
+ <$> Map.toList m
+ )
-- | A specific attribute for all nodes in a graph
nodesA :: ID -> Graph -> Map.Map ID (Maybe ID)
@@ -813,37 +811,45 @@
{ chartHeight :: Double,
chartScale :: Double,
edgeSize :: Double,
+ nodeBorderSize :: Double,
chartColor :: Colour,
chartBackgroundColor :: Colour,
- nodeHeight :: Double,
- nodeSize :: Double,
- vshift :: Double,
+ backupNodeHeight :: Double,
+ backupNodeWidth :: Double,
+ chartVshift :: Double,
textSize :: Double,
- labelf :: ID -> Text
+ escapeText :: EscapeText
}
- deriving (Generic)
+ deriving (Generic, Show, Eq)
-- | default parameters
defaultChartConfig :: ChartConfig
-defaultChartConfig = ChartConfig 500 72 0.5 (over lightness' (* 0.5) (palette1 0)) (set opac' 0.2 (palette1 0)) 0.5 0.5 (-3.7) 14 (Text.pack . label)
+defaultChartConfig = ChartConfig 500 72 0.5 1 (grey 0.4 0.8) (grey 0.5 0.2) 0.5 0.5 (-6) 16 NoEscapeText
-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions'
-graphToChartWith :: ChartConfig -> Graph -> ChartOptions
-graphToChartWith cfg g =
+graphToChartWith :: ChartConfig -> (ID -> Text) -> Graph -> ChartOptions
+graphToChartWith cfg labelf g =
mempty
- & #charts .~ named "edges" ps <> named "shapes" c0 <> named "labels" [ts]
- & #markupOptions % #markupHeight .~ (cfg ^. #chartHeight)
- & #hudOptions .~ (mempty & #chartAspect .~ ChartAspect)
+ & set #chartTree (named "edges" ps <> named "shapes" c0 <> named "labels" [ts])
+ & set (#chartTree % charts' % each % #chartStyle % #scaleP) ScalePArea
+ & #markupOptions
+ % #markupHeight
+ .~ (Just $ cfg ^. #chartHeight)
+ & #markupOptions
+ % #chartAspect
+ .~ ChartAspect
+ & #hudOptions
+ .~ mempty
where
glyphs w = case view (attL NodeType (ID "shape")) g of
- Just (ID "circle") -> defaultGlyphStyle & #shape .~ CircleGlyph & #size .~ (cfg ^. #chartScale) * w & #borderSize .~ (cfg ^. #edgeSize) & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
- Just (ID "box") -> defaultGlyphStyle & #shape .~ RectSharpGlyph (h / w) & #size .~ 72 * w & #borderSize .~ 1 & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
+ Just (ID "circle") -> defaultGlyphStyle & #glyphShape .~ CircleGlyph & #size .~ (cfg ^. #chartScale) * w & #borderSize .~ (cfg ^. #edgeSize) & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
+ Just (ID "box") -> defaultGlyphStyle & #glyphShape .~ RectSharpGlyph (h / w) & #size .~ (cfg ^. #chartScale) * w & #borderSize .~ view #nodeBorderSize cfg & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
-- defaults to circle
- _ -> defaultGlyphStyle & #shape .~ CircleGlyph & #size .~ 72 * w & #borderSize .~ 1 & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
- h = maybe (cfg ^. #nodeHeight) (runParser_ double . strToUtf8 . label) (view (attL NodeType (ID "height")) g)
- vshift' = cfg ^. #vshift
+ _ -> defaultGlyphStyle & #glyphShape .~ CircleGlyph & #size .~ (cfg ^. #chartScale) * w & #borderSize .~ view #nodeBorderSize cfg & #borderColor .~ (cfg ^. #chartColor) & #color .~ (cfg ^. #chartBackgroundColor)
+ h = maybe (cfg ^. #backupNodeHeight) (runParser_ double . strToUtf8 . label) (view (attL NodeType (ID "height")) g)
+ vshift' = cfg ^. #chartVshift
-- node information
- ns = nodeInfo g (cfg ^. #nodeSize)
+ ns = nodeInfo g (cfg ^. #backupNodeWidth)
-- edge information
es = edgeInfo g (cfg ^. #edgeSize)
-- paths
@@ -852,11 +858,11 @@
c0 = fmap (\(NodeInfo _ w p) -> GlyphChart (glyphs w) [p]) ns
-- labels
ts =
- TextChart (defaultTextStyle & #size .~ (cfg ^. #textSize) & #color .~ (cfg ^. #chartColor)) ((\(NodeInfo l _ (Point x y)) -> ((cfg ^. #labelf) l, Point x (vshift' + y))) <$> ns)
+ TextChart (defaultTextStyle & #escapeText .~ (cfg ^. #escapeText) & #size .~ (cfg ^. #textSize) & #color .~ (cfg ^. #chartColor)) ((\(NodeInfo l _ (Point x y)) -> (labelf l, Point x (vshift' + y))) <$> ns)
-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions' using the default ChartConfig.
graphToChart :: Graph -> ChartOptions
-graphToChart = graphToChartWith defaultChartConfig
+graphToChart = graphToChartWith defaultChartConfig (Text.pack . label)
-- | Convert an algebraic graph to a dotparse graph.
toDotGraphWith :: Directed -> Graph -> G.Graph ByteString -> Graph