diff --git a/dotparse.cabal b/dotparse.cabal --- a/dotparse.cabal +++ b/dotparse.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: dotparse -version: 0.0.1 +version: 0.0.2 synopsis: dot language parsing and printing. description: This package provides parsing and printing of the dot language. @@ -13,7 +13,7 @@ >>> import Chart >>> import DotParse.Examples (exInt) >>> ex <- processGraph exInt - >>> writeChartSvg "other/ex.svg" (graphToChartWith defaultChartConfig ex) + >>> writeChartOptions "other/ex.svg" (graphToChartWith defaultChartConfig ex) . ![usage example](docs/other/ex.svg) . @@ -37,24 +37,22 @@ default-extensions: ghc-options: -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info - -hiedir=.hie + -Wincomplete-uni-patterns -Wredundant-constraints build-depends: - , algebraic-graphs ^>=0.6 + , algebraic-graphs >=0.6 && <0.8 , base >=4.7 && <5 , bytestring ^>=0.11.3 - , chart-svg ^>=0.3 + , chart-svg >=0.3 && < 0.5 , containers ^>=0.6 - , flatparse ^>=0.3.2 - , neat-interpolation ^>=0.5.1 - , numhask ^>=0.10 + , flatparse >=0.3.2 && <0.5 , numhask-space ^>=0.10 , optics-core ^>=0.4 , process-extras ^>=0.7.4 - , template-haskell >=2.16 && < 2.20 - , text ^>=1.2 - , these ^>=1.1.1 + , string-interpolate ^>=0.3 + , template-haskell >=2.16 && < 2.21 + , text >=1.2 && <2.1 + , these >=1.1.1 && < 1.3 exposed-modules: DotParse diff --git a/other/ex.svg b/other/ex.svg deleted file mode 100644 --- a/other/ex.svg +++ /dev/null @@ -1,25 +0,0 @@ -012345678910111213141516171819 diff --git a/other/ex0.svg b/other/ex0.svg --- a/other/ex0.svg +++ b/other/ex0.svg @@ -1,12 +1,12 @@ - - + diff --git a/other/ex1.svg b/other/ex1.svg --- a/other/ex1.svg +++ b/other/ex1.svg @@ -1,14 +1,14 @@ - D - + A @@ -24,8 +24,8 @@ A->B - - + + @@ -36,10 +36,10 @@ A->C - - - - + + + + @@ -50,7 +50,7 @@ A->D - + diff --git a/other/ex10.svg b/other/ex10.svg --- a/other/ex10.svg +++ b/other/ex10.svg @@ -1,22 +1,22 @@ - - + H - + aHtmlTable -col 1 -foo -COL 2 -bar - +col 1 +foo +COL 2 +bar + diff --git a/other/ex11.svg b/other/ex11.svg --- a/other/ex11.svg +++ b/other/ex11.svg @@ -1,55 +1,55 @@ - - + - + tbl - -foo - -bar - -baz - - + +foo + +bar + +baz + + one   - -two   - -three - + +two   + +three + four - -five - -six   - -seven - -eight - -nine - - - -eins - -zwei - -drei -sechs - -vier - -fünf - + +five + +six   + +seven + +eight + +nine + + + +eins + +zwei + +drei +sechs + +vier + +fünf + abc diff --git a/other/ex12.svg b/other/ex12.svg --- a/other/ex12.svg +++ b/other/ex12.svg @@ -1,24 +1,24 @@ - D - + some_node - + Foo - + -Bar - +Bar + Baz diff --git a/other/ex13.svg b/other/ex13.svg --- a/other/ex13.svg +++ b/other/ex13.svg @@ -1,22 +1,22 @@ - - + H - + aHtmlTable -col 1 -foo -COL 2 -bar - +col 1 +foo +COL 2 +bar + diff --git a/other/ex14.svg b/other/ex14.svg --- a/other/ex14.svg +++ b/other/ex14.svg @@ -1,62 +1,62 @@ - - + H - + parent - -The foo, the bar and the baz - -First port - -Second port - -Third port - + +The foo, the bar and the baz + +First port + +Second port + +Third port + child_one -1 - +1 + parent:port_one->child_one - - + + child_two -2 - +2 + parent:port_two->child_two - - + + child_three -3 - +3 + parent:port_three->child_three - - + + diff --git a/other/ex15.svg b/other/ex15.svg --- a/other/ex15.svg +++ b/other/ex15.svg @@ -1,91 +1,91 @@ - - + D - + task_menu -Task 1 -Choose Menu -done - +Task 1 +Choose Menu +done + task_ingredients -Task 2 -Buy ingredients -done - +Task 2 +Buy ingredients +done + task_menu->task_ingredients - - + + task_cook -Task 5 -Cook -todo - +Task 5 +Cook +todo + task_ingredients->task_cook - - + + task_invitation -Task 4 -Send invitation -done - +Task 4 +Send invitation +done + task_invitation->task_cook - - + + task_eat -Task 6 -Eat -todo - +Task 6 +Eat +todo + task_cook->task_eat - - + + task_table -Task 3 -Lay table -todo - +Task 3 +Lay table +todo + task_table->task_eat - - + + diff --git a/other/ex2.svg b/other/ex2.svg --- a/other/ex2.svg +++ b/other/ex2.svg @@ -1,32 +1,32 @@ - - + D - + node_A - -shape=record - -above - -middle - -below - -right + +shape=record + +above + +middle + +below + +right node_B -shape=plaintext|{curly|braces and|bars without}|effect +shape=plaintext|{curly|braces and|bars without}|effect diff --git a/other/ex3.svg b/other/ex3.svg --- a/other/ex3.svg +++ b/other/ex3.svg @@ -1,14 +1,14 @@ - D - + A @@ -24,8 +24,8 @@ A->B - - + + @@ -36,8 +36,8 @@ A->C - - + + @@ -48,8 +48,8 @@ A->D - - + + @@ -60,20 +60,20 @@ B->F - - + + C->F - - + + D->F - - + + diff --git a/other/ex4.svg b/other/ex4.svg --- a/other/ex4.svg +++ b/other/ex4.svg @@ -1,49 +1,43 @@ - - - + + L - + a - -one -two three -four five six seven + +onetwo threefour five six seven b - -one -two three -four five six seven + +onetwo threefour five six seven a->b - - + + c - -one -two three -four five six seven + +onetwo threefour five six seven b->c - - + + diff --git a/other/ex5.svg b/other/ex5.svg --- a/other/ex5.svg +++ b/other/ex5.svg @@ -1,41 +1,41 @@ - - + D - -The foo, the bar and the baz + +The foo, the bar and the baz FOO -FOO +FOO BAR -BAR +BAR FOO->BAR - - + + BAZ -BAZ +BAZ FOO->BAZ - - + + diff --git a/other/ex6.svg b/other/ex6.svg --- a/other/ex6.svg +++ b/other/ex6.svg @@ -1,22 +1,22 @@ - D - -The -foo -, + +The +foo +, the bar and - the -baz + the +baz FOO @@ -30,8 +30,8 @@ FOO->BAR - - + + @@ -41,8 +41,8 @@ FOO->BAZ - - + + diff --git a/other/ex7.svg b/other/ex7.svg --- a/other/ex7.svg +++ b/other/ex7.svg @@ -1,14 +1,14 @@ - R - + rA @@ -24,8 +24,8 @@ rA->sA - - + + @@ -36,8 +36,8 @@ sA->vB - - + + @@ -54,8 +54,8 @@ uB->vB - - + + @@ -66,8 +66,8 @@ wB->tA - - + + @@ -78,8 +78,8 @@ wB->u - - + + @@ -90,8 +90,8 @@ t->rA - - + + diff --git a/other/ex8.svg b/other/ex8.svg --- a/other/ex8.svg +++ b/other/ex8.svg @@ -1,93 +1,93 @@ - - + Q - + cluster_R - + nd_1 - -Node 1 + +Node 1 nd_2 - -Node 2 + +Node 2 nd_1->nd_2 - - + + nd_3 - -Node 3 + +Node 3 nd_2->nd_3 - - + + nd_3_a - -Above Right Node 3 + +Above Right Node 3 nd_3_r - -Right of Node 3 + +Right of Node 3 nd_3_a->nd_3_r - - + + nd_3_l - + Left of Node 3 nd_3_l->nd_3 - + nd_3->nd_3_r - + nd_4 - -Node 4 + +Node 4 nd_3->nd_4 - - + + diff --git a/other/ex9.svg b/other/ex9.svg --- a/other/ex9.svg +++ b/other/ex9.svg @@ -1,68 +1,68 @@ - - + D - + cluster_p - -Parent + +Parent cluster_c1 - -Child one + +Child one cluster_gc_1 - -Grand-Child one + +Grand-Child one cluster_gc_2 - -Grand-Child two + +Grand-Child two cluster_c2 - -Child two + +Child two a - -a + +a b - -b + +b c - -c + +c d - -d + +d e - -e + +e diff --git a/other/exdirect.svg b/other/exdirect.svg new file mode 100644 --- /dev/null +++ b/other/exdirect.svg @@ -0,0 +1,276 @@ + + + + + + + + + +9 + +9 + + + +8 + +8 + + + +7 + +7 + + + +6 + +6 + + + +5 + +5 + + + +17 + +17 + + + +5->17 + + + + + +11 + +11 + + + +5->11 + + + + + +0 + +0 + + + +5->0 + + + + + +4 + +4 + + + +4->5 + + + + + +16 + +16 + + + +4->16 + + + + + +10 + +10 + + + +4->10 + + + + + +3 + +3 + + + +3->9 + + + + + +3->4 + + + + + +15 + +15 + + + +3->15 + + + + + +2 + +2 + + + +2->8 + + + + + +2->3 + + + + + +19 + +19 + + + +2->19 + + + + + +18 + +18 + + + +2->18 + + + + + +14 + +14 + + + +2->14 + + + + + +19->3 + + + + + +18->3 + + + + + +15->19 + + + + + +15->18 + + + + + +13 + +13 + + + +12 + +12 + + + +1 + +1 + + + +1->7 + + + + + +1->2 + + + + + +1->13 + + + + + +0->6 + + + + + +0->12 + + + + + +0->1 + + + + + diff --git a/other/exga.svg b/other/exga.svg new file mode 100644 --- /dev/null +++ b/other/exga.svg @@ -0,0 +1,25 @@ +012345678910111213141516171819 diff --git a/other/nh.svg b/other/nh.svg --- a/other/nh.svg +++ b/other/nh.svg @@ -1,25 +1,25 @@ -AdditiveDirectionDistributiveDivisiveExpFieldFieldIntegralLowerBoundedFieldModuleMultiplicativeMultiplicativeActionNormQuotientFieldRatioRingSignedSubtractiveTrigFieldUpperBoundedField diff --git a/src/DotParse.hs b/src/DotParse.hs --- a/src/DotParse.hs +++ b/src/DotParse.hs @@ -1,23 +1,62 @@ -{-# OPTIONS_HADDOCK prune #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_HADDOCK prune #-} -- | Parser & Printer for the dot language of -- -- See "DotParse.Examples" for usage. --- module DotParse - ( module DotParse.Types, - module DotParse.FlatParse, - module FlatParse.Basic, - module NeatInterpolation, + ( + DotConfig(..), + defaultDotConfig, + DotParse (..), + testDotParser, + runDotParser, + + Graph (..), + defaultGraph, + attL, + gattL, + processDot, + processDotWith, + processGraph, + processGraphWith, + + Strict(..), + defStrict, + Directed(..), + defDirected, + ID(..), + label, + Compass (..), + Port (..), + AttributeType (..), + AttributeStatement (..), + NodeStatement (..), + EdgeID (..), + EdgeOp (..), + fromDirected, + EdgeStatement (..), + edgeID, + edgeIDs, + edgeIDsNamed, + Statement (..), + addStatement, + addStatements, + SubGraphStatement (..), + + -- * Conversion + graphToChartWith, + graphToChart, + ChartConfig (..), + defaultChartConfig, + toStatements, + toDotGraph, + toDotGraphWith, + ) where -import DotParse.FlatParse import DotParse.Types -import FlatParse.Basic hiding (cut, lines) -import NeatInterpolation -import Prelude hiding (replicate) diff --git a/src/DotParse/Examples.hs b/src/DotParse/Examples.hs --- a/src/DotParse/Examples.hs +++ b/src/DotParse/Examples.hs @@ -14,21 +14,26 @@ {-# OPTIONS_GHC -Wno-unused-local-binds #-} -- | Examples of conversion from dot ByteStrings +-- +-- Most examples from https://renenyffenegger.ch/notes/tools/Graphviz/examples/index module DotParse.Examples where import qualified Algebra.Graph as G -import Control.Monad -import Data.ByteString hiding (empty, head, length, map, zip, zipWith) -import Data.Proxy -import Data.Text.Encoding (encodeUtf8) +import Control.Monad ( zipWithM_ ) +import Data.ByteString ( ByteString ) +import Data.Proxy ( Proxy(..) ) import DotParse -import Optics.Core import Prelude hiding (replicate) +import Data.String.Interpolate -- $setup -- >>> import DotParse -- >>> import Data.Proxy -- >>> :set -XOverloadedStrings +-- >>> import Data.String.Interpolate +-- >>> import qualified Data.ByteString.Char8 as Char8 +-- >>> import Optics.Core +-- >>> import Chart -- * examples @@ -40,20 +45,17 @@ -- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex0 ex0 :: ByteString ex0 = - encodeUtf8 - [trimming| + + [i| graph {} |] --- | Examples from https://renenyffenegger.ch/notes/tools/Graphviz/examples/index --- --- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex1 --- +-- | -- ![Example](other/ex1.svg) ex1 :: ByteString ex1 = - encodeUtf8 - [trimming| + + [i| digraph D { A [shape=diamond] B [shape=box] @@ -65,13 +67,11 @@ |] -- | --- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex2 --- -- ![Example](other/ex2.svg) ex2 :: ByteString ex2 = - encodeUtf8 - [trimming| + + [i| digraph D { node [fontname="Arial"]; @@ -83,13 +83,11 @@ |] -- | --- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex3 --- -- ![Example](other/ex3.svg) ex3 :: ByteString ex3 = - encodeUtf8 - [trimming| + + [i| digraph D { A -> {B, C, D} -> {F} } @@ -100,13 +98,13 @@ -- ![Example](other/ex4.svg) ex4 :: ByteString ex4 = - encodeUtf8 - [trimming| + + [i| digraph L { node [shape=record fontname=Arial]; - a [label="one\ltwo three\lfour five six seven\l"] + a [label="one\ntwo three\nfour five six seven\n"] b [label="one\ntwo three\nfour five six seven"] c [label="one\rtwo three\rfour five six seven\r"] @@ -120,8 +118,8 @@ -- ![Example](other/ex5.svg) ex5 :: ByteString ex5 = - encodeUtf8 - [trimming| + + [i| digraph D { label = "The foo, the bar and the baz"; @@ -140,8 +138,8 @@ -- ![Example](other/ex6.svg) ex6 :: ByteString ex6 = - encodeUtf8 - [trimming| + + [i| digraph D { label = foo,
the bar and
the baz>; @@ -159,8 +157,8 @@ -- ![Example](other/ex7.svg) ex7 :: ByteString ex7 = - encodeUtf8 - [trimming| + + [i| digraph R { { rank=same rA sA tA } @@ -182,8 +180,8 @@ -- ![Example](other/ex8.svg) ex8 :: ByteString ex8 = - encodeUtf8 - [trimming| + + [i| digraph Q { nd_1 [label = "Node 1"]; @@ -214,8 +212,8 @@ -- ![Example](other/ex9.svg) ex9 :: ByteString ex9 = - encodeUtf8 - [trimming| + + [i| digraph D { subgraph cluster_p { @@ -250,8 +248,8 @@ -- ![Example](other/ex10.svg) ex10 :: ByteString ex10 = - encodeUtf8 - [trimming| + + [i| digraph H { aHtmlTable [ @@ -273,8 +271,8 @@ -- ![Example](other/ex11.svg) ex11 :: ByteString ex11 = - encodeUtf8 - [trimming| + + [i| digraph { tbl [ @@ -313,8 +311,7 @@ -- ![Example](other/ex12.svg) ex12 :: ByteString ex12 = - encodeUtf8 - [trimming| + [i| digraph D { node [shape=plaintext] @@ -323,8 +320,8 @@ label=< - - + +
Foo
Bar
Baz
Bar
Baz
> ]; } @@ -335,8 +332,8 @@ -- ![Example](other/ex13.svg) ex13 :: ByteString ex13 = - encodeUtf8 - [trimming| + + [i| digraph H { aHtmlTable [ @@ -358,8 +355,8 @@ -- ![Example](other/ex14.svg) ex14 :: ByteString ex14 = - encodeUtf8 - [trimming| + + [i| digraph H { parent [ @@ -407,8 +404,8 @@ -- ![Example](other/ex15.svg) ex15 :: ByteString ex15 = - encodeUtf8 - [trimming| + + [i| digraph D { node [shape=plaintext fontname="Sans serif" fontsize="8"]; @@ -540,71 +537,16 @@ ) -- | algebraic graph example -exGInt :: G.Graph Int -exGInt = +-- +-- >>> exGraph = defaultGraph & addStatements (toStatements Directed (Char8.pack . show <$> exAGraph)) +-- >>> exGraphAugmented <- processGraph exGraph +-- >>> writeChartOptions "other/exga.svg" (graphToChartWith defaultChartConfig exGraphAugmented) +-- +-- ![augmentation example](other/exga.svg) +-- +exAGraph :: G.Graph Int +exAGraph = G.edges $ [(v, (v + 1) `mod` 6) | v <- [0 .. 5]] ++ [(v, v + k) | v <- [0 .. 5], k <- [6, 12]] ++ [(2, 18), (2, 19), (15, 18), (15, 19), (18, 3), (19, 3)] - --- | --- --- > exInt = defaultGraph & addStatements (toStatements Directed (packUTF8 . show <$> exGInt)) --- > import qualified Data.ByteString.Char8 as B --- > g <- processGraph exInt --- > B.putStrLn $ dotPrint g --- digraph { --- graph [bb="0,0,495.65,493.78";overlap=false;size="1!";splines=spline] --- node [height=0.5;label="\N";shape=circle] --- edge [arrowsize=0] --- 0 [pos="384.5,475.78";width=0.5] --- 1 [pos="357.5,401.63";width=0.5] --- 0 -> 1 [pos="e,363.57,418.85 378.51,458.77 374.1,446.99 368.12,431.02 363.67,419.13"] --- 6 [pos="411.5,401.63";width=0.5] --- 0 -> 6 [pos="e,405.43,418.85 390.49,458.77 394.9,446.99 400.87,431.02 405.32,419.13"] --- 12 [height=0.55967;pos="467.5,401.63";width=0.55967] --- 0 -> 12 [pos="e,452.8,415.41 397.83,463.19 412.75,450.22 436.85,429.27 452.43,415.73"] --- 2 [pos="330.5,325.33";width=0.5] --- 1 -> 2 [pos="e,336.35,342.42 351.64,384.51 347.15,372.14 340.97,355.15 336.45,342.72"] --- 7 [pos="384.5,325.33";width=0.5] --- 1 -> 7 [pos="e,378.65,342.42 363.36,384.51 367.85,372.14 374.03,355.15 378.54,342.72"] --- 13 [height=0.55967;pos="440.5,325.33";width=0.55967] --- 1 -> 13 [pos="e,425.95,339.36 370.47,389.02 385.4,375.66 409.87,353.75 425.58,339.69"] --- 3 [pos="263.5,249.04";width=0.5] --- 2 -> 3 [pos="e,275.26,263.08 318.83,311.39 306.7,297.94 287.81,277 275.55,263.4"] --- 8 [pos="419.5,249.04";width=0.5] --- 2 -> 8 [pos="e,406.15,261.18 344.02,313.05 360.71,299.11 388.95,275.54 405.75,261.51"] --- 14 [height=0.55967;pos="475.5,249.04";width=0.55967] --- 2 -> 14 [pos="e,459.28,261.56 344.39,313.55 348.48,310.63 353.06,307.61 357.5,305.19 394.93,284.71 408.73,289.04 446.5,269.19 450.64,267.01 454.93,\ --- 264.4 458.9,261.81"] --- 18 [height=0.55967;pos="239.5,96.445";width=0.55967] --- 2 -> 18 [pos="e,221.18,105.3 313.92,317.87 277.75,302.66 192.9,260.73 166.5,192.89 160,176.2 158.52,168.63 166.5,152.59 177.74,130.02 203.11,114.24 \ --- 220.76,105.5"] --- 19 [height=0.55967;pos="335.5,96.445";width=0.55967] --- 2 -> 19 [pos="e,335.94,116.84 331.52,307.33 332.98,282.28 335.56,234 336.5,192.89 336.91,174.98 336.66,170.5 336.5,152.59 336.39,140.81 336.16,\ --- 127.62 335.94,117.09"] --- 4 [pos="101.5,172.74";width=0.5] --- 3 -> 4 [pos="e,117.56,181.11 247.37,240.64 216.44,226.46 149.09,195.57 117.92,181.27"] --- 9 [pos="193.5,172.74";width=0.5] --- 3 -> 9 [pos="e,205.67,186.66 251.62,235.43 238.93,221.96 218.89,200.69 205.97,186.98"] --- 15 [height=0.55967;pos="287.5,172.74";width=0.55967] --- 3 -> 15 [pos="e,281.6,192.01 268.82,231.55 272.58,219.93 277.61,204.35 281.51,192.29"] --- 5 [pos="48.498,96.445";width=0.5] --- 4 -> 5 [pos="e,58.506,111.47 91.279,157.42 81.908,144.28 68.101,124.92 58.727,111.78"] --- 10 [height=0.55967;pos="104.5,96.445";width=0.55967] --- 4 -> 10 [pos="e,103.72,116.67 102.19,154.51 102.65,143.28 103.24,128.61 103.71,116.95"] --- 16 [height=0.55967;pos="162.5,96.445";width=0.55967] --- 4 -> 16 [pos="e,150.12,112.52 112.69,158.11 123.2,145.31 138.91,126.18 149.86,112.83"] --- 5 -> 0 [pos="e,366.23,475.02 49.439,114.6 50.887,142.55 53.498,199.64 53.498,248.04 53.498,326.33 53.498,326.33 53.498,326.33 53.498,464.3 295.89,\ --- 474.85 365.82,475.02"] --- 11 [height=0.54162;pos="19.498,20.148";width=0.54162] --- 5 -> 11 [pos="e,26.284,38.534 42.206,79.323 37.545,67.382 31.197,51.119 26.397,38.823"] --- 17 [height=0.55967;pos="77.498,20.148";width=0.55967] --- 5 -> 17 [pos="e,70.506,39.061 54.791,79.323 59.386,67.552 65.62,51.579 70.394,39.349"] --- 15 -> 18 [pos="e,250.12,113.89 276.85,155.25 268.95,143.04 258.24,126.45 250.31,114.18"] --- 15 -> 19 [pos="e,324.88,113.89 298.15,155.25 306.04,143.04 316.76,126.45 324.69,114.18"] --- 18 -> 3 [pos="e,260.79,231.06 242.53,116.49 247.24,145.99 256.21,202.31 260.74,230.72"] --- 19 -> 3 [pos="e,277.53,237.38 334.82,116.79 333.41,136.85 329.16,168.62 316.5,192.89 307.11,210.88 290.05,227.04 277.82,237.15"] --- } -exInt :: Graph -exInt = defaultGraph & addStatements (toStatements Directed (packUTF8 . show <$> exGInt)) 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 @@ -22,6 +22,8 @@ import GHC.IO.Unsafe import Optics.Core import Prelude hiding (replicate) +import Data.String.Interpolate +import FlatParse.Basic -- $setup -- >>> import DotParse @@ -219,7 +221,7 @@ dotGraphNH d = defaultGraph & #directed .~ Last (Just d) - & addStatements (toStatements d (packUTF8 . show <$> graphNHG)) + & addStatements (toStatements d (strToUtf8 . show <$> graphNHG)) & attL NodeType (ID "shape") .~ Just (ID "box") & gattL (ID "rankdir") .~ Just (IDQuoted "BT") @@ -229,18 +231,17 @@ {-# 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 i = [trimming|$t|] +toLink id_ =[i|#{t}|] where - t = pack (label i) + t = pack (label id_) m = Map.fromList (first (pack . show) <$> classesModule) Map.! t -- | A chart-svg chart with label links -- --- > writeChartSvg "other/nh.svg" (graphToChart toLink (dotGraphNH' Directed)) +-- > writeChartOptions "other/nh.svg" (graphToChart toLink (dotGraphNH' Directed)) -- -- ![NumHask Example](other/nh.svg) writeNHChart :: IO () -writeNHChart = writeChartSvg "other/nh.svg" (graphToChartWith (defaultChartConfig & #labelf .~ toLink) (dotGraphNH' Directed)) +writeNHChart = writeChartOptions "other/nh.svg" (graphToChartWith (defaultChartConfig & #labelf .~ toLink) (dotGraphNH' Directed)) diff --git a/src/DotParse/FlatParse.hs b/src/DotParse/FlatParse.hs --- a/src/DotParse/FlatParse.hs +++ b/src/DotParse/FlatParse.hs @@ -56,7 +56,7 @@ import Data.Char hiding (isDigit) import Data.List.NonEmpty import DotParse.FlatParse.TH hiding (merge) -import FlatParse.Basic hiding (cut, lines) +import FlatParse.Basic hiding (cut) import GHC.Generics import NumHask.Space import Prelude hiding (replicate) @@ -66,7 +66,7 @@ -- >>> import FlatParse.Basic -- | Run parser, print pretty error on failure. -testParser :: Show a => Parser Error a -> ByteString -> IO () +testParser :: (Show a) => Parser Error a -> ByteString -> IO () testParser p b = case runParser p b of Err e -> B.putStrLn $ prettyError b e @@ -77,14 +77,14 @@ runParser_ :: Parser Error a -> ByteString -> a runParser_ p b = case runParser p b of OK r "" -> r - OK _ x -> error $ unpackUTF8 $ "leftovers: " <> x + OK _ x -> error $ utf8ToStr $ "leftovers: " <> x Fail -> error "Fail" - Err e -> error $ unpackUTF8 $ prettyError b e + Err e -> error $ utf8ToStr $ prettyError b e -- * parsing digit :: Parser Error Int -digit = (\c -> ord c - ord '0') <$> satisfyASCII isDigit +digit = (\c -> ord c - ord '0') <$> satisfyAscii isDigit -- | (unsigned) Int parser int :: Parser Error Int @@ -115,7 +115,7 @@ double :: Parser Error Double double = token do (placel, nl) <- digits - optioned + withOption ($(char '.') *> digits) ( \(placer, nr) -> case (placel, placer) of @@ -130,14 +130,14 @@ -- | -- >>> runParser (signed double) "-1.234x" -- OK (-1.234) "x" -signed :: Num b => Parser e b -> Parser e b -signed p = optioned $(char '-') (const (((-1) *) <$> p)) p +signed :: (Num b) => Parser e b -> Parser e b +signed p = withOption ($(char '-')) (const (((-1) *) <$> p)) p -- | Looks ahead for a "/"" that may be in the quoted string. --- >>> runParser quoted (packUTF8 "\"hello\"") +-- >>> runParser quoted (strToUtf8 "\"hello\"") -- OK "hello" "" -- --- >>> runParser quoted (packUTF8 "\"hello/\"\"") +-- >>> runParser quoted (strToUtf8 "\"hello/\"\"") -- OK "hello\"" "" quoted :: Parser Error String quoted = 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 @@ -12,6 +12,7 @@ import Data.ByteString hiding (head, length, reverse) import qualified Data.ByteString.Char8 as B +import Data.Char hiding (isDigit) import Data.Functor import FlatParse.Basic import Language.Haskell.TH @@ -44,7 +45,7 @@ -- | Parse a line comment. lineComment :: Parser e () lineComment = - optioned + withOption anyWord8 ( \case 10 -> ws @@ -80,8 +81,8 @@ -- | First character of a dot identifier. isValidStartChar :: Char -> Bool isValidStartChar c = - ('A' <= c && c <= 'Z') - || ('a' <= c && c <= 'z') + isAsciiUpper c + || isAsciiLower c || ('\200' <= c && c <= '\377') || (c == '_') @@ -107,18 +108,18 @@ -- | Parser a non-keyword string, throw precise error on failure. symbol' :: String -> Q Exp -symbol' str = [|$(symbol str) `cut'` packUTF8 str|] +symbol' str = [|$(symbol str) `cut'` strToUtf8 str|] -- | Parse a keyword string, throw precise error on failure. keyword' :: String -> Q Exp -keyword' str = [|$(keyword str) `cut'` packUTF8 str|] +keyword' str = [|$(keyword str) `cut'` strToUtf8 str|] -- | Parse an identifier. ident :: Parser e ByteString ident = token $ byteStringOf $ - identStartChar *> many_ identChar + identStartChar *> skipMany identChar -- | Parse an identifier, throw a precise error on failure. ident' :: Parser Error ByteString @@ -165,7 +166,7 @@ ls = B.lines b (l, c) = head $ posLineCols b [pos] line = if l < length ls then ls !! l else "" - linum = packUTF8 $ show l + linum = strToUtf8 $ show l lpad = B.replicate (B.length linum) ' ' err (Precise _ e) = e @@ -179,7 +180,10 @@ go [] = "" go [e] = " or " <> e go (e : es) = ", " <> e <> go es - in packUTF8 (show l) <> ":" <> packUTF8 (show c) <> ":\n" + in strToUtf8 (show l) + <> ":" + <> strToUtf8 (show c) + <> ":\n" <> lpad <> "|\n" <> linum diff --git a/src/DotParse/Types.hs b/src/DotParse/Types.hs --- a/src/DotParse/Types.hs +++ b/src/DotParse/Types.hs @@ -105,20 +105,21 @@ import Data.Proxy import Data.Text (Text) import qualified Data.Text as Text -import Data.Text.Encoding (encodeUtf8) import Data.These import DotParse.FlatParse -import FlatParse.Basic hiding (cut, lines) +import FlatParse.Basic hiding (cut) import GHC.Generics -import NeatInterpolation import Optics.Core import System.Exit import System.Process.ByteString import Prelude hiding (replicate) +import Data.String.Interpolate -- $setup -- >>> import DotParse -- >>> import qualified Data.Map as Map +-- >>> import qualified FlatParse.Basic as FP +-- >>> import FlatParse.Basic (runParser, Result) -- >>> :set -XOverloadedStrings -- | printing options, for separators. @@ -237,7 +238,7 @@ dotPrint _ MergeEdges = "strict" dotPrint _ NoMergeEdges = "" - dotParse = token $ optioned $(keyword "strict") (const $ pure MergeEdges) (pure NoMergeEdges) + dotParse = token $ withOption ($(keyword "strict")) (const $ pure MergeEdges) (pure NoMergeEdges) -- | Default Strict is NoMergeEdges defStrict :: Last Strict -> Strict @@ -301,8 +302,8 @@ instance DotParse ID where dotPrint _ (ID s) = s - dotPrint _ (IDInt i) = packUTF8 (show i) - dotPrint _ (IDDouble x) = packUTF8 (show x) + dotPrint _ (IDInt i) = strToUtf8 (show i) + dotPrint _ (IDDouble x) = strToUtf8 (show x) dotPrint _ (IDQuoted x) = wrapQuotePrint x dotPrint _ (IDHtml s) = s @@ -312,8 +313,8 @@ (ID <$> ident) <|> (IDInt <$> (signed int `notFollowedBy` $(char '.'))) <|> (IDDouble <$> signed double) - <|> (IDQuoted . packUTF8 <$> quoted) - <|> (IDHtml . packUTF8 <$> htmlLike) + <|> (IDQuoted . strToUtf8 <$> quoted) + <|> (IDHtml . strToUtf8 <$> htmlLike) -- | ID as the equivalent plain String -- @@ -321,11 +322,11 @@ -- -- > x == y if label x == label y label :: ID -> String -label (ID s) = unpackUTF8 s +label (ID s) = utf8ToStr s label (IDInt i) = show i label (IDDouble d) = show d -label (IDQuoted q) = unpackUTF8 q -label (IDHtml h) = unpackUTF8 h +label (IDQuoted q) = utf8ToStr q +label (IDHtml h) = utf8ToStr h -- | Attribute key-value pair of identifiers -- @@ -440,9 +441,11 @@ instance DotParse AttributeStatement where dotPrint cfg (AttributeStatement t as) = - intercalate + bool + (intercalate " " - [dotPrint cfg t, dotPrint cfg as] + [dotPrint cfg t, dotPrint cfg as]) + mempty (mempty == as) dotParse = AttributeStatement <$> dotParse <*> dotParse @@ -577,15 +580,14 @@ -- | default dot graph as a ByteString defaultBS :: ByteString defaultBS = - encodeUtf8 - [trimming| + [i| digraph { node [shape=circle ,height=0.5]; graph [overlap=false ,splines=spline ,size="1!"]; - edge [arrowsize=0]; + edge [arrowsize=0.5]; } |] @@ -596,7 +598,7 @@ -- digraph { -- node [height=0.5;shape=circle] -- graph [overlap=false;size="1!";splines=spline] --- edge [arrowsize=0] +-- edge [arrowsize=0.5] -- } defaultGraph :: Graph defaultGraph = runDotParser defaultBS @@ -609,7 +611,7 @@ UnDirected -> "neato" (r, input, e) <- readProcessWithExitCode cmd args i bool - (error $ unpackUTF8 e) + (error $ utf8ToStr e) (pure input) (r == ExitSuccess) @@ -630,27 +632,27 @@ instance DotParse (Point Double) where dotPrint _ (Point x y) = intercalate "," $ - packUTF8 . show <$> [x, y] + strToUtf8 . show <$> [x, y] dotParse = token pointP pointI :: Iso' ID (Point Double) pointI = iso - (runParser_ pointP . packUTF8 . label) + (runParser_ pointP . strToUtf8 . label) (IDQuoted . dotPrint defaultDotConfig) instance DotParse (Rect Double) where dotPrint _ (Rect x z y w) = intercalate "," $ - packUTF8 . show <$> [x, y, z, w] + strToUtf8 . show <$> [x, y, z, w] dotParse = token rectP rectI :: Iso' ID (Rect Double) rectI = iso - (runParser_ rectP . packUTF8 . label) + (runParser_ rectP . strToUtf8 . label) (IDQuoted . dotPrint defaultDotConfig) -- | Bounding box ID lens @@ -666,7 +668,8 @@ nodesPortL = lens ( \g -> - g & view #nodes + g + & view #nodes & fmap (\x -> (view #nodeID x, (view #port x, view #nodeAttrs x))) & Map.fromList ) @@ -677,7 +680,8 @@ nodesL = lens ( \g -> - g & view #nodes + g + & view #nodes & fmap (\x -> (view #nodeID x, view #nodeAttrs x)) & Map.fromList ) @@ -702,15 +706,15 @@ setEdges_ g m = g & #edges - .~ ( ( \((x0, x1), as) -> - EdgeStatement - (fromDirected (defDirected $ view #directed g)) - (EdgeID x0 Nothing) - (EdgeID x1 Nothing :| []) - as + .~ ( ( \((x0, x1), as) -> + EdgeStatement + (fromDirected (defDirected $ view #directed g)) + (EdgeID x0 Nothing) + (EdgeID x1 Nothing :| []) + as + ) + <$> Map.toList m ) - <$> Map.toList m - ) -- | A specific attribute for all nodes in a graph nodesA :: ID -> Graph -> Map.Map ID (Maybe ID) @@ -834,19 +838,13 @@ 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) --- | convert a 'Graph' processed via the graphviz commands to a 'ChartSvg' --- --- >>> import Chart --- >>> import DotParse.Examples (exInt) --- >>> ex <- processGraph exInt --- >>> writeChartSvg "other/ex.svg" (graphToChartWith defaultChartConfig ex) +-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions' -- --- ![Example](other/ex.svg) -graphToChartWith :: ChartConfig -> Graph -> ChartSvg +graphToChartWith :: ChartConfig -> Graph -> ChartOptions graphToChartWith cfg g = mempty & #charts .~ named "edges" ps <> named "shapes" c0 <> named "labels" [ts] - & #svgOptions % #svgHeight .~ (cfg ^. #chartHeight) + & #markupOptions % #markupHeight .~ (cfg ^. #chartHeight) & #hudOptions .~ (mempty & #chartAspect .~ ChartAspect) where glyphs w = case view (attL NodeType (ID "shape")) g of @@ -854,7 +852,7 @@ Just (ID "box") -> defaultGlyphStyle & #shape .~ RectSharpGlyph (h / w) & #size .~ 72 * w & #borderSize .~ 1 & #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 . packUTF8 . label) (view (attL NodeType (ID "height")) g) + h = maybe (cfg ^. #nodeHeight) (runParser_ double . strToUtf8 . label) (view (attL NodeType (ID "height")) g) vshift' = cfg ^. #vshift -- node information ns = nodeInfo g (cfg ^. #nodeSize) @@ -868,8 +866,8 @@ ts = TextChart (defaultTextStyle & #size .~ (cfg ^. #textSize) & #color .~ (cfg ^. #chartColor)) ((\(NodeInfo l _ (Point x y)) -> ((cfg ^. #labelf) l, Point x (vshift' + y))) <$> ns) --- | convert a 'Graph' processed via the graphviz commands to a 'ChartSvg' using the default ChartConfig. -graphToChart :: Graph -> ChartSvg +-- | convert a 'Graph' processed via the graphviz commands to a 'ChartOptions' using the default ChartConfig. +graphToChart :: Graph -> ChartOptions graphToChart = graphToChartWith defaultChartConfig -- | Convert an algebraic graph to a dotparse graph.