diff --git a/dotparse.cabal b/dotparse.cabal new file mode 100644 --- /dev/null +++ b/dotparse.cabal @@ -0,0 +1,68 @@ +cabal-version: 2.4 +name: dotparse +version: 0.0.1 +synopsis: dot language parsing and printing. +description: This package provides parsing and printing of the dot language. + + . + == Usage + . + >>> :set -XOverloadedLabels + >>> :set -XOverloadedStrings + >>> import DotParse + >>> import Chart + >>> import DotParse.Examples (exInt) + >>> ex <- processGraph exInt + >>> writeChartSvg "other/ex.svg" (graphToChartWith defaultChartConfig ex) + . + ![usage example](docs/other/ex.svg) + . + +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 + +source-repository head + type: git + location: https://github.com/tonyday567/dotparse + +library + hs-source-dirs: src + default-extensions: + ghc-options: + -Wall -Wcompat -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wredundant-constraints -fwrite-ide-info + -hiedir=.hie + + build-depends: + , algebraic-graphs ^>=0.6 + , base >=4.7 && <5 + , bytestring ^>=0.11.3 + , chart-svg ^>=0.3 + , containers ^>=0.6 + , flatparse ^>=0.3.2 + , neat-interpolation ^>=0.5.1 + , numhask ^>=0.10 + , 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 + + exposed-modules: + DotParse + DotParse.Examples + DotParse.Examples.NumHask + DotParse.FlatParse + DotParse.FlatParse.TH + DotParse.Types + + other-modules: + default-language: Haskell2010 diff --git a/other/ex.svg b/other/ex.svg new file mode 100644 --- /dev/null +++ b/other/ex.svg @@ -0,0 +1,25 @@ +012345678910111213141516171819 diff --git a/other/ex0.svg b/other/ex0.svg new file mode 100644 --- /dev/null +++ b/other/ex0.svg @@ -0,0 +1,12 @@ + + + + + + + + + diff --git a/other/ex1.svg b/other/ex1.svg new file mode 100644 --- /dev/null +++ b/other/ex1.svg @@ -0,0 +1,56 @@ + + + + + + +D + + + +A + +A + + + +B + +B + + + +A->B + + + + + +C + +C + + + +A->C + + + + + + + +D + +D + + + +A->D + + + + diff --git a/other/ex10.svg b/other/ex10.svg new file mode 100644 --- /dev/null +++ b/other/ex10.svg @@ -0,0 +1,22 @@ + + + + + + +H + + + +aHtmlTable +col 1 +foo +COL 2 +bar + + + + diff --git a/other/ex11.svg b/other/ex11.svg new file mode 100644 --- /dev/null +++ b/other/ex11.svg @@ -0,0 +1,56 @@ + + + + + + + + + +tbl + +foo + +bar + +baz + + +one   + +two   + +three + +four + +five + +six   + +seven + +eight + +nine + + + +eins + +zwei + +drei +sechs + +vier + +fünf + +abc + + + diff --git a/other/ex12.svg b/other/ex12.svg new file mode 100644 --- /dev/null +++ b/other/ex12.svg @@ -0,0 +1,26 @@ + + + + + + +D + + + +some_node + + +Foo + + +Bar + + +Baz + + + diff --git a/other/ex13.svg b/other/ex13.svg new file mode 100644 --- /dev/null +++ b/other/ex13.svg @@ -0,0 +1,22 @@ + + + + + + +H + + + +aHtmlTable +col 1 +foo +COL 2 +bar + + + + diff --git a/other/ex14.svg b/other/ex14.svg new file mode 100644 --- /dev/null +++ b/other/ex14.svg @@ -0,0 +1,62 @@ + + + + + + +H + + + +parent + +The foo, the bar and the baz + +First port + +Second port + +Third port + + + + +child_one +1 + + + + +parent:port_one->child_one + + + + + +child_two +2 + + + + +parent:port_two->child_two + + + + + +child_three +3 + + + + +parent:port_three->child_three + + + + + diff --git a/other/ex15.svg b/other/ex15.svg new file mode 100644 --- /dev/null +++ b/other/ex15.svg @@ -0,0 +1,91 @@ + + + + + + +D + + + +task_menu +Task 1 +Choose Menu +done + + + + +task_ingredients +Task 2 +Buy ingredients +done + + + + +task_menu->task_ingredients + + + + + +task_cook +Task 5 +Cook +todo + + + + +task_ingredients->task_cook + + + + + +task_invitation +Task 4 +Send invitation +done + + + + +task_invitation->task_cook + + + + + +task_eat +Task 6 +Eat +todo + + + + +task_cook->task_eat + + + + + +task_table +Task 3 +Lay table +todo + + + + +task_table->task_eat + + + + + diff --git a/other/ex2.svg b/other/ex2.svg new file mode 100644 --- /dev/null +++ b/other/ex2.svg @@ -0,0 +1,32 @@ + + + + + + +D + + + +node_A + +shape=record + +above + +middle + +below + +right + + + +node_B +shape=plaintext|{curly|braces and|bars without}|effect + + + diff --git a/other/ex3.svg b/other/ex3.svg new file mode 100644 --- /dev/null +++ b/other/ex3.svg @@ -0,0 +1,79 @@ + + + + + + +D + + + +A + +A + + + +B + +B + + + +A->B + + + + + +C + +C + + + +A->C + + + + + +D + +D + + + +A->D + + + + + +F + +F + + + +B->F + + + + + +C->F + + + + + +D->F + + + + + diff --git a/other/ex4.svg b/other/ex4.svg new file mode 100644 --- /dev/null +++ b/other/ex4.svg @@ -0,0 +1,49 @@ + + + + + + +L + + + +a + +one +two three +four five six seven + + + +b + +one +two three +four five six seven + + + +a->b + + + + + +c + +one +two three +four five six seven + + + +b->c + + + + + diff --git a/other/ex5.svg b/other/ex5.svg new file mode 100644 --- /dev/null +++ b/other/ex5.svg @@ -0,0 +1,41 @@ + + + + + + +D + +The foo, the bar and the baz + + +FOO +FOO + + + +BAR +BAR + + + +FOO->BAR + + + + + +BAZ +BAZ + + + +FOO->BAZ + + + + + diff --git a/other/ex6.svg b/other/ex6.svg new file mode 100644 --- /dev/null +++ b/other/ex6.svg @@ -0,0 +1,48 @@ + + + + + + +D + +The +foo +, + the +bar + and + the +baz + + +FOO +FOO + + + +BAR +BAR + + + +FOO->BAR + + + + + +BAZ +BAZ + + + +FOO->BAZ + + + + + diff --git a/other/ex7.svg b/other/ex7.svg new file mode 100644 --- /dev/null +++ b/other/ex7.svg @@ -0,0 +1,97 @@ + + + + + + +R + + + +rA + +rA + + + +sA + +sA + + + +rA->sA + + + + + +vB + +vB + + + +sA->vB + + + + + +tA + +tA + + + +uB + +uB + + + +uB->vB + + + + + +wB + +wB + + + +wB->tA + + + + + +u + +u + + + +wB->u + + + + + +t + +t + + + +t->rA + + + + + diff --git a/other/ex8.svg b/other/ex8.svg new file mode 100644 --- /dev/null +++ b/other/ex8.svg @@ -0,0 +1,93 @@ + + + + + + +Q + + +cluster_R + + + + +nd_1 + +Node 1 + + + +nd_2 + +Node 2 + + + +nd_1->nd_2 + + + + + +nd_3 + +Node 3 + + + +nd_2->nd_3 + + + + + +nd_3_a + +Above Right Node 3 + + + +nd_3_r + +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 + + + +nd_3->nd_4 + + + + + diff --git a/other/ex9.svg b/other/ex9.svg new file mode 100644 --- /dev/null +++ b/other/ex9.svg @@ -0,0 +1,68 @@ + + + + + + +D + + +cluster_p + +Parent + + +cluster_c1 + +Child one + + +cluster_gc_1 + +Grand-Child one + + +cluster_gc_2 + +Grand-Child two + + +cluster_c2 + +Child two + + + +a + +a + + + +b + +b + + + +c + +c + + + +d + +d + + + +e + +e + + + diff --git a/other/nh.svg b/other/nh.svg new file mode 100644 --- /dev/null +++ b/other/nh.svg @@ -0,0 +1,25 @@ +AdditiveDirectionDistributiveDivisiveExpFieldFieldIntegralLowerBoundedFieldModuleMultiplicativeMultiplicativeActionNormQuotientFieldRatioRingSignedSubtractiveTrigFieldUpperBoundedField diff --git a/src/DotParse.hs b/src/DotParse.hs new file mode 100644 --- /dev/null +++ b/src/DotParse.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | 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, + ) +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 new file mode 100644 --- /dev/null +++ b/src/DotParse/Examples.hs @@ -0,0 +1,610 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +-- | Examples of conversion from dot ByteStrings +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 DotParse +import Optics.Core +import Prelude hiding (replicate) + +-- $setup +-- >>> import DotParse +-- >>> import Data.Proxy +-- >>> :set -XOverloadedStrings + +-- * examples + +-- | minimal definition +-- +-- >>> runDotParser ex0 :: Graph +-- Graph {strict = Last {getLast = Just NoMergeEdges}, directed = Last {getLast = Just UnDirected}, graphid = Last {getLast = Nothing}, nodeAttributes = fromList [], graphAttributes = fromList [], edgeAttributes = fromList [], globalAttributes = fromList [], nodes = [], edges = [], subgraphs = []} +-- +-- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex0 +ex0 :: ByteString +ex0 = + encodeUtf8 + [trimming| +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| +digraph D { + A [shape=diamond] + B [shape=box] + C [shape=circle] + A -> B [style=dashed, color=grey] + A -> C [color="black:invis:black"] + A -> D [penwidth=5, arrowhead=none] + } +|] + +-- | +-- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex2 +-- +-- ![Example](other/ex2.svg) +ex2 :: ByteString +ex2 = + encodeUtf8 + [trimming| +digraph D { + + node [fontname="Arial"]; + + node_A [shape=record label="shape=record|{above|middle|below}|right"]; + node_B [shape=plaintext label="shape=plaintext|{curly|braces and|bars without}|effect"]; + +} +|] + +-- | +-- >>> testDotParser (Proxy :: Proxy Graph) defaultDotConfig ex3 +-- +-- ![Example](other/ex3.svg) +ex3 :: ByteString +ex3 = + encodeUtf8 + [trimming| +digraph D { + A -> {B, C, D} -> {F} +} +|] + +-- | +-- +-- ![Example](other/ex4.svg) +ex4 :: ByteString +ex4 = + encodeUtf8 + [trimming| +digraph L { + + node [shape=record fontname=Arial]; + + a [label="one\ltwo three\lfour five six seven\l"] + b [label="one\ntwo three\nfour five six seven"] + c [label="one\rtwo three\rfour five six seven\r"] + + a -> b -> c + +} +|] + +-- | +-- +-- ![Example](other/ex5.svg) +ex5 :: ByteString +ex5 = + encodeUtf8 + [trimming| +digraph D { + + label = "The foo, the bar and the baz"; + labelloc = "t"; // place the label at the top (b seems to be default) + + node [shape=plaintext] + + FOO -> {BAR, BAZ}; + + +} +|] + +-- | +-- +-- ![Example](other/ex6.svg) +ex6 :: ByteString +ex6 = + encodeUtf8 + [trimming| +digraph D { + + label = foo,
the bar and
the baz>; + labelloc = "t"; // place the label at the top (b seems to be default) + + node [shape=plaintext] + + FOO -> {BAR, BAZ}; + +} +|] + +-- | +-- +-- ![Example](other/ex7.svg) +ex7 :: ByteString +ex7 = + encodeUtf8 + [trimming| +digraph R { + + { rank=same rA sA tA } + { rank=same uB vB wB } + + + rA -> sA; + sA -> vB; + t -> rA; + uB -> vB; + wB -> u; + wB -> tA; + +} +|] + +-- | +-- +-- ![Example](other/ex8.svg) +ex8 :: ByteString +ex8 = + encodeUtf8 + [trimming| +digraph Q { + + nd_1 [label = "Node 1"]; + nd_2 [label = "Node 2"]; + nd_3_a [label = "Above Right Node 3"]; + nd_3_l [label = "Left of Node 3"]; + nd_3 [label = "Node 3"]; + nd_3_r [label = "Right of Node 3"]; + nd_4 [label = "Node 4"]; + + + nd_3_a -> nd_3_r; + nd_1 -> nd_2 -> nd_3 -> nd_4; + + subgraph cluster_R { + + {rank=same nd_3_l nd_3 nd_3_r} + + nd_3_l -> nd_3 -> nd_3_r [color=grey arrowhead=none]; + + } + +} +|] + +-- | +-- +-- ![Example](other/ex9.svg) +ex9 :: ByteString +ex9 = + encodeUtf8 + [trimming| +digraph D { + + subgraph cluster_p { + label = "Parent"; + + subgraph cluster_c1 { + label = "Child one"; + a; + + subgraph cluster_gc_1 { + label = "Grand-Child one"; + b; + } + subgraph cluster_gc_2 { + label = "Grand-Child two"; + c; + d; + } + + } + + subgraph cluster_c2 { + label = "Child two"; + e; + } + } +} +|] + +-- | +-- +-- ![Example](other/ex10.svg) +ex10 :: ByteString +ex10 = + encodeUtf8 + [trimming| +digraph H { + + aHtmlTable [ + shape=plaintext + color=blue // The color of the border of the table + label=< + + + + +
col 1foo
COL 2bar
+ + >]; + +}|] + +-- | +-- +-- ![Example](other/ex11.svg) +ex11 :: ByteString +ex11 = + encodeUtf8 + [trimming| +digraph { + + tbl [ + + shape=plaintext + label=< + + + + + + + + + +
foobarbaz
+ + + + +
one two three
four five six
seveneightnine
+ 		+ + + +
einszweidrei
sechs
vierfünf
+
abc
+ + >]; + +} +|] + +-- | +-- +-- ![Example](other/ex12.svg) +ex12 :: ByteString +ex12 = + encodeUtf8 + [trimming| +digraph D { + + node [shape=plaintext] + + some_node [ + label=< + + + + +
Foo
Bar
Baz
> + ]; +} +|] + +-- | +-- +-- ![Example](other/ex13.svg) +ex13 :: ByteString +ex13 = + encodeUtf8 + [trimming| +digraph H { + + aHtmlTable [ + shape=plaintext + label=< + + + + +
col 1foo
COL 2bar
+ + >]; + +} +|] + +-- | +-- +-- ![Example](other/ex14.svg) +ex14 :: ByteString +ex14 = + encodeUtf8 + [trimming| +digraph H { + + parent [ + shape=plaintext + label=< + + + +
The foo, the bar and the baz
First portSecond portThird port
+ >]; + + child_one [ + shape=plaintext + label=< + + +
1
+ >]; + + child_two [ + shape=plaintext + label=< + + +
2
+ >]; + + child_three [ + shape=plaintext + label=< + + +
3
+ >]; + + parent:port_one -> child_one; + parent:port_two -> child_two; + parent:port_three -> child_three; + +} +|] + +-- | +-- +-- ![Example](other/ex15.svg) +ex15 :: ByteString +ex15 = + encodeUtf8 + [trimming| +digraph D { + + node [shape=plaintext fontname="Sans serif" fontsize="8"]; + + task_menu [ label=< + + + + +
Task 1
Choose Menu
done
>]; + + task_ingredients [ label=< + + + + +
Task 2
Buy ingredients
done
>]; + + task_invitation [ label=< + + + + +
Task 4
Send invitation
done
>]; + + task_cook [ label=< + + + + +
Task 5
Cook
todo
>]; + + task_table[ label=< + + + + +
Task 3
Lay table
todo
>]; + + task_eat[ label=< + + + + +
Task 6
Eat
todo
>]; + + + task_menu -> task_ingredients; + task_ingredients -> task_cook; + task_invitation -> task_cook; + task_table -> task_eat; + task_cook -> task_eat; + +} +|] + +-- | Test all the examples +testAll :: IO () +testAll = + zipWithM_ + (>>) + ( putStrLn + <$> [ "ex0", + "ex1", + "ex2", + "ex3", + "ex4", + "ex5", + "ex6", + "ex7", + "ex8", + "ex9", + "ex10", + "ex11", + "ex12", + "ex13", + "ex14", + "ex15" + ] + ) + ( testDotParser (Proxy :: Proxy Graph) defaultDotConfig + <$> [ex0, ex1, ex2, ex3, ex4, ex5, ex6, ex7, ex8, ex9, ex10, ex11, ex12, ex13, ex14, ex15] + ) + +-- | Render all the examples +svgAll :: IO () +svgAll = + zipWithM_ + (>>) + ( putStrLn + <$> [ "ex0", + "ex1", + "ex2", + "ex3", + "ex4", + "ex5", + "ex6", + "ex7", + "ex8", + "ex9", + "ex10", + "ex11", + "ex12", + "ex13", + "ex14", + "ex15" + ] + ) + ( zipWith + (\b f -> processDotWith Directed ["-Tsvg", "-oother/" <> f <> ".svg"] b) + [ex0, ex1, ex2, ex3, ex4, ex5, ex6, ex7, ex8, ex9, ex10, ex11, ex12, ex13, ex14, ex15] + [ "ex0", + "ex1", + "ex2", + "ex3", + "ex4", + "ex5", + "ex6", + "ex7", + "ex8", + "ex9", + "ex10", + "ex11", + "ex12", + "ex13", + "ex14", + "ex15" + ] + ) + +-- | algebraic graph example +exGInt :: G.Graph Int +exGInt = + 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 new file mode 100644 --- /dev/null +++ b/src/DotParse/Examples/NumHask.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use ?~" #-} + +-- | Example of Dot graph construction for the NumHask class heirarchy. +module DotParse.Examples.NumHask where + +import qualified Algebra.Graph as G +import Chart +import Data.Bifunctor +import qualified Data.Map.Strict as Map +import Data.Monoid +import Data.Text (Text, pack) +import DotParse +import GHC.IO.Unsafe +import Optics.Core +import Prelude hiding (replicate) + +-- $setup +-- >>> import DotParse +-- >>> :set -XOverloadedStrings + +data Class + = Magma + | Unital + | Associative + | Commutative + | Invertible + | Idempotent + | Absorbing + | Group + | AbelianGroup + | Additive + | Subtractive + | Multiplicative + | Divisive + | Distributive + | Semiring + | Ring + | IntegralDomain + | Field + | ExpField + | QuotientField + | UpperBoundedField + | LowerBoundedField + | TrigField + | -- Higher-kinded numbers + AdditiveAction + | SubtractiveAction + | MultiplicativeAction + | DivisiveAction + | Module + | -- Lattice + JoinSemiLattice + | MeetSemiLattice + | Lattice + | BoundedJoinSemiLattice + | BoundedMeetSemiLattice + | BoundedLattice + | -- Number Types + Integral + | Ratio + | -- Measure + Signed + | Norm + | Basis + | Direction + | Epsilon + deriving (Show, Eq, Ord) + +data Family + = Addition + | Multiplication + | Actor + deriving (Show, Eq, Ord) + +data Dependency = Dependency + { _class :: Class, + _dep :: Class, + _op :: Maybe Family + } + deriving (Show, Eq, Ord) + +dependencies :: [Dependency] +dependencies = + [ Dependency Unital Magma Nothing, + Dependency Associative Magma Nothing, + Dependency Commutative Magma Nothing, + Dependency Invertible Magma Nothing, + Dependency Idempotent Magma Nothing, + Dependency Absorbing Magma Nothing, + Dependency Group Unital Nothing, + Dependency Group Invertible Nothing, + Dependency Group Associative Nothing, + Dependency AbelianGroup Unital Nothing, + Dependency AbelianGroup Invertible Nothing, + Dependency AbelianGroup Associative Nothing, + Dependency AbelianGroup Commutative Nothing, + Dependency Additive Commutative (Just Addition), + Dependency Additive Unital (Just Addition), + Dependency Additive Associative (Just Addition), + Dependency Subtractive Invertible (Just Addition), + Dependency Subtractive Additive (Just Addition), + Dependency Multiplicative Unital (Just Multiplication), + Dependency Multiplicative Associative (Just Multiplication), + Dependency Multiplicative Commutative (Just Multiplication), + Dependency Divisive Invertible (Just Multiplication), + Dependency Divisive Multiplicative (Just Multiplication), + Dependency Distributive Additive (Just Addition), + Dependency Distributive Multiplicative (Just Multiplication), + Dependency Distributive Absorbing Nothing, + Dependency Ring Distributive Nothing, + Dependency Ring Subtractive (Just Addition), + Dependency IntegralDomain Ring Nothing, + Dependency Field Ring Nothing, + Dependency Field Divisive (Just Multiplication), + Dependency ExpField Field Nothing, + Dependency QuotientField Field Nothing, + Dependency QuotientField Ring Nothing, + Dependency TrigField Field Nothing, + Dependency UpperBoundedField Field Nothing, + Dependency LowerBoundedField Field Nothing, + -- higher-kinded relationships + Dependency AdditiveAction Additive (Just Actor), + Dependency SubtractiveAction Subtractive (Just Actor), + Dependency MultiplicativeAction Multiplicative (Just Actor), + Dependency DivisiveAction Divisive (Just Actor), + Dependency Module Distributive (Just Actor), + Dependency Module MultiplicativeAction Nothing, + -- Lattice + Dependency JoinSemiLattice Associative Nothing, + Dependency JoinSemiLattice Commutative Nothing, + Dependency JoinSemiLattice Idempotent Nothing, + Dependency MeetSemiLattice Associative Nothing, + Dependency MeetSemiLattice Commutative Nothing, + Dependency MeetSemiLattice Idempotent Nothing, + Dependency Lattice JoinSemiLattice Nothing, + Dependency Lattice MeetSemiLattice Nothing, + Dependency BoundedJoinSemiLattice JoinSemiLattice Nothing, + Dependency BoundedJoinSemiLattice Unital Nothing, + Dependency BoundedMeetSemiLattice MeetSemiLattice Nothing, + Dependency BoundedMeetSemiLattice Unital Nothing, + Dependency BoundedLattice BoundedJoinSemiLattice Nothing, + Dependency BoundedLattice BoundedMeetSemiLattice Nothing, + Dependency Signed Ring Nothing, + Dependency Norm Ring Nothing, + Dependency Basis Ring Nothing, + Dependency Direction Ring Nothing, + Dependency Epsilon Subtractive Nothing, + Dependency Epsilon MeetSemiLattice Nothing, + Dependency Integral Ring Nothing, + Dependency Ratio Field Nothing + ] + +classesNH :: [Class] +classesNH = + [ Additive, + Subtractive, + Multiplicative, + Divisive, + Distributive, + Ring, + Field, + ExpField, + QuotientField, + TrigField, + Signed, + Norm, + Direction, + MultiplicativeAction, + Module, + UpperBoundedField, + LowerBoundedField, + Integral, + Ratio + ] + +classesModule :: [(Class, Text)] +classesModule = + [ (Additive, "NumHask-Algebra-Additive"), + (Subtractive, "NumHask-Algebra-Additive"), + (Multiplicative, "NumHask-Algebra-Multiplicative"), + (Divisive, "NumHask-Algebra-Multiplicative"), + (Distributive, "NumHask-Algebra-Distributive"), + (Ring, "NumHask-Algebra-Ring"), + (Field, "NumHask-Algebra-Field"), + (ExpField, "NumHask-Algebra-Field"), + (QuotientField, "NumHask-Algebra-Field"), + (TrigField, "NumHask-Algebra-Field"), + (Signed, "NumHask-Algebra-Metric"), + (Norm, "NumHask-Algebra-Metric"), + (Direction, "NumHask-Algebra-Metric"), + (MultiplicativeAction, "NumHask-Algebra-Module"), + (Module, "NumHask-Algebra-Module"), + (UpperBoundedField, "NumHask-Algebra-Field"), + (LowerBoundedField, "NumHask-Algebra-Field"), + (Integral, "NumHask-Data-Integral"), + (Ratio, "NumHask-Data-Rational") + ] + +dependenciesNH :: [Dependency] -> [Dependency] +dependenciesNH = filter (\(Dependency x0 x1 _) -> x0 `elem` classesNH && x1 `elem` classesNH) + +-- | NumHask Classes as an algebraic graph +graphNHG :: G.Graph Class +graphNHG = + 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 (packUTF8 . 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 i = [trimming|$t|] + where + t = pack (label i) + m = Map.fromList (first (pack . show) <$> classesModule) Map.! t + +-- | A chart-svg chart with label links +-- +-- > writeChartSvg "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)) diff --git a/src/DotParse/FlatParse.hs b/src/DotParse/FlatParse.hs new file mode 100644 --- /dev/null +++ b/src/DotParse/FlatParse.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use <$>" #-} + +-- | Lower-level flatparse parsers +module DotParse.FlatParse + ( Error (..), + prettyError, + keyword, + keyword', + symbol, + symbol', + ws, + token, + ident, + cut, + cut', + testParser, + runParser_, + int, + double, + signed, + quoted, + htmlLike, + sepP, + wrapSquareP, + wrapSquarePrint, + wrapCurlyP, + wrapCurlyPrint, + wrapQuotePrint, + pointP, + Spline (..), + splineP, + rectP, + boolP, + nonEmptyP, + ) +where + +import Data.Bool +import Data.ByteString hiding (empty, head, length, map, zip, zipWith) +import qualified Data.ByteString.Char8 as B +import Data.Char hiding (isDigit) +import Data.List.NonEmpty +import DotParse.FlatParse.TH hiding (merge) +import FlatParse.Basic hiding (cut, lines) +import GHC.Generics +import NumHask.Space +import Prelude hiding (replicate) + +-- $setup +-- >>> import DotParse +-- >>> import FlatParse.Basic + +-- | Run parser, print pretty error on failure. +testParser :: Show a => Parser Error a -> ByteString -> IO () +testParser p b = + case runParser p b of + Err e -> B.putStrLn $ prettyError b e + OK a _ -> print a + Fail -> B.putStrLn "uncaught parse error" + +-- | run a Parser, erroring on leftovers, Fail or Err +runParser_ :: Parser Error a -> ByteString -> a +runParser_ p b = case runParser p b of + OK r "" -> r + OK _ x -> error $ unpackUTF8 $ "leftovers: " <> x + Fail -> error "Fail" + Err e -> error $ unpackUTF8 $ prettyError b e + +-- * parsing + +digit :: Parser Error Int +digit = (\c -> ord c - ord '0') <$> satisfyASCII isDigit + +-- | (unsigned) Int parser +int :: Parser Error Int +int = token do + (place, n) <- chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0)) + case place of + 1 -> empty + _ -> pure n + +digits :: Parser Error (Int, Int) +digits = chainr (\n (!place, !acc) -> (place * 10, acc + place * n)) digit (pure (1, 0)) + +-- | +-- >>> runParser double "1.234x" +-- OK 1.234 "x" +-- +-- >>> runParser double "." +-- Fail +-- +-- >>> runParser double "123" +-- OK 123.0 "" +-- +-- >>> runParser double ".123" +-- OK 0.123 "" +-- +-- >>> runParser double "123." +-- OK 123.0 "" +double :: Parser Error Double +double = token do + (placel, nl) <- digits + optioned + ($(char '.') *> digits) + ( \(placer, nr) -> + case (placel, placer) of + (1, 1) -> empty + _ -> pure $ fromIntegral nl + fromIntegral nr / fromIntegral placer + ) + ( case placel of + 1 -> empty + _ -> pure $ fromIntegral nl + ) + +-- | +-- >>> 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 + +-- | Looks ahead for a "/"" that may be in the quoted string. +-- >>> runParser quoted (packUTF8 "\"hello\"") +-- OK "hello" "" +-- +-- >>> runParser quoted (packUTF8 "\"hello/\"\"") +-- OK "hello\"" "" +quoted :: Parser Error String +quoted = + $(symbol "\"") *> many unquoteQuote <* $(symbol' "\"") + +unquoteQuote :: Parser Error Char +unquoteQuote = do + next <- satisfy (/= '"') + case next of + '/' -> branch (lookahead $(char '"')) ('"' <$ $(char '"')) (pure '/') + x -> pure x + +-- | optional separators +sepP :: Parser e () +sepP = + token + $( switch + [| + case _ of + ";" -> pure () + "," -> pure () + |] + ) + +-- | parse wrapping square brackets +wrapSquareP :: Parser Error a -> Parser Error a +wrapSquareP p = + $(symbol "[") *> p <* $(symbol' "]") + +-- | print wrapping square brackets +wrapSquarePrint :: ByteString -> ByteString +wrapSquarePrint b = "[" <> b <> "]" + +-- | print wrapping quotes +wrapQuotePrint :: ByteString -> ByteString +wrapQuotePrint b = "\"" <> b <> "\"" + +-- | parse wrapping square brackets +wrapCurlyP :: Parser Error a -> Parser Error a +wrapCurlyP p = $(symbol "{") *> p <* $(symbol' "}") + +-- | print wrapping curly brackets +wrapCurlyPrint :: ByteString -> ByteString +wrapCurlyPrint b = "{" <> b <> "}" + +-- | comma separated Point +pointP :: Parser Error (Point Double) +pointP = token $ Point <$> double <*> ($(symbol ",") *> double) + +-- | dot specification of a cubic spline (and an arrow head which is ignored here) +data Spline = Spline {splineEnd :: Maybe (Point Double), splineStart :: Maybe (Point Double), splineP1 :: Point Double, splineTriples :: [(Point Double, Point Double, Point Double)]} deriving (Eq, Show, Generic) + +-- | +-- http://www.graphviz.org/docs/attr-types/splineType/ +splineP :: Parser Error Spline +splineP = + Spline + <$> optional ($(symbol "e,") *> pointP) + <*> optional ($(symbol "s") *> pointP) + <*> pointP + <*> some ((,,) <$> pointP <*> pointP <*> pointP) + +-- | comma separated rectangle or bounding box +rectP :: Parser Error (Rect Double) +rectP = token $ do + x <- double + _ <- $(symbol ",") + y <- double + _ <- $(symbol ",") + z <- double + _ <- $(symbol ",") + w <- double + pure $ Rect x z y w + +-- | true | false +boolP :: Parser Error Bool +boolP = + (True <$ $(symbol "true")) + <|> (False <$ $(symbol "false")) + +-- | NonEmpty version of many +nonEmptyP :: Parser e a -> Parser e () -> Parser e (NonEmpty a) +nonEmptyP p sep = token $ do + s <- p + xs <- many (optional sep *> p) + pure (s :| xs) diff --git a/src/DotParse/FlatParse/TH.hs b/src/DotParse/FlatParse/TH.hs new file mode 100644 --- /dev/null +++ b/src/DotParse/FlatParse/TH.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unused-local-binds #-} + +-- | TH stage restriction guff for flatparsing +module DotParse.FlatParse.TH where + +import Data.ByteString hiding (head, length, reverse) +import qualified Data.ByteString.Char8 as B +import Data.Functor +import FlatParse.Basic +import Language.Haskell.TH + +-- | Consume whitespace. +ws :: Parser e () +ws = + $( switch + [| + case _ of + -- order matters + " " -> ws + "\\\n" -> ws + "\\\\\\n" -> ws + "\n" -> ws + "\t" -> ws + "\r" -> ws + ";" -> ws + "//" -> lineComment + "/*" -> multilineComment + _ -> pure () + |] + ) + +-- | Consume whitespace after running a parser. +token :: Parser e a -> Parser e a +token p = p <* ws +{-# INLINE token #-} + +-- | Parse a line comment. +lineComment :: Parser e () +lineComment = + optioned + anyWord8 + ( \case + 10 -> ws + _ -> lineComment + ) + (pure ()) + +-- | Parse a potentially nested multiline comment. +multilineComment :: Parser e () +multilineComment = go (1 :: Int) + where + go 0 = ws + go n = + $( switch + [| + case _ of + "*/" -> go (n - 1) + "/*" -> go (n + 1) + _ -> branch anyWord8 (go n) (pure ()) + |] + ) + +-- | Parse a HTML-Like string by counting the angle brackets +htmlLike :: Parser e String +htmlLike = ws *> $(char '<') *> go (1 :: Int) "<" + where + go 0 acc = ws $> reverse acc + go n acc = + ($(char '>') *> go (n - 1) ('>' : acc)) + <|> ($(char '<') *> go (n + 1) ('<' : acc)) + <|> (anyChar >>= (\c -> go n (c : acc))) + +-- | First character of a dot identifier. +isValidStartChar :: Char -> Bool +isValidStartChar c = + ('A' <= c && c <= 'Z') + || ('a' <= c && c <= 'z') + || ('\200' <= c && c <= '\377') + || (c == '_') + +-- | character of a dot identifier. +isValidChar :: Char -> Bool +isValidChar c = isValidStartChar c || isDigit c + +-- | Read a starting character of an identifier. +identStartChar :: Parser e Char +identStartChar = satisfy isValidStartChar + +-- | Read a non-starting character of an identifier. +identChar :: Parser e Char +identChar = satisfy isValidChar + +-- | Parse a non-keyword string. +symbol :: String -> Q Exp +symbol str = [|token $(string str)|] + +-- | Parse a keyword string. +keyword :: String -> Q Exp +keyword str = [|token ($(string str) `notFollowedBy` identChar)|] + +-- | Parser a non-keyword string, throw precise error on failure. +symbol' :: String -> Q Exp +symbol' str = [|$(symbol str) `cut'` packUTF8 str|] + +-- | Parse a keyword string, throw precise error on failure. +keyword' :: String -> Q Exp +keyword' str = [|$(keyword str) `cut'` packUTF8 str|] + +-- | Parse an identifier. +ident :: Parser e ByteString +ident = + token $ + byteStringOf $ + identStartChar *> many_ identChar + +-- | Parse an identifier, throw a precise error on failure. +ident' :: Parser Error ByteString +ident' = ident `cut'` "identifier" + +-- | A parsing error. +data Error + = -- | A precisely known error, like leaving out "in" from "let". + Precise Pos ByteString + | -- | An imprecise error, when we expect a number of different things, + -- but parse something else. + Imprecise Pos [ByteString] + deriving (Eq, Show) + +-- | position of error +errorPos :: Error -> Pos +errorPos (Precise p _) = p +errorPos (Imprecise p _) = p + +-- | Merge two errors. Inner errors (which were thrown at points with more consumed inputs) +-- are preferred. If errors are thrown at identical input positions, we prefer precise errors +-- to imprecise ones. +-- +-- The point of prioritizing inner and precise errors is to suppress the deluge of "expected" +-- items, and instead try to point to a concrete issue to fix. +merge :: Error -> Error -> Error +merge e e' = case (errorPos e, errorPos e') of + (p, p') | p < p' -> e' + (p, p') | p > p' -> e + (p, _) -> case (e, e') of + (Precise {}, _) -> e + (_, Precise {}) -> e' + (Imprecise _ es, Imprecise _ es') -> Imprecise p (es ++ es') +{-# NOINLINE merge #-} -- merge is "cold" code, so we shouldn't inline it. + +-- | Pretty print an error. The `ByteString` input is the source file. The offending line from the +-- source is displayed in the output. +prettyError :: ByteString -> Error -> ByteString +prettyError b e = + let pos :: Pos + pos = case e of + Imprecise pos _ -> pos + Precise pos _ -> pos + ls = B.lines b + (l, c) = head $ posLineCols b [pos] + line = if l < length ls then ls !! l else "" + linum = packUTF8 $ show l + lpad = B.replicate (B.length linum) ' ' + + err (Precise _ e) = e + err (Imprecise _ es) = imprec es + + imprec :: [ByteString] -> ByteString + imprec [] = error "impossible" + imprec [e] = e + imprec (e : es) = e <> go es + where + go [] = "" + go [e] = " or " <> e + go (e : es) = ", " <> e <> go es + in packUTF8 (show l) <> ":" <> packUTF8 (show c) <> ":\n" + <> lpad + <> "|\n" + <> linum + <> "| " + <> line + <> "\n" + <> lpad + <> "| " + <> B.replicate c ' ' + <> "^\n" + <> "parse error: expected " + <> err e + +-- | Imprecise cut: we slap a list of items on inner errors. +cut :: Parser Error a -> [ByteString] -> Parser Error a +cut p es = do + pos <- getPos + cutting p (Imprecise pos es) merge + +-- | Precise cut: we propagate at most a single error. +cut' :: Parser Error a -> ByteString -> Parser Error a +cut' p e = do + pos <- getPos + cutting p (Precise pos e) merge diff --git a/src/DotParse/Types.hs b/src/DotParse/Types.hs new file mode 100644 --- /dev/null +++ b/src/DotParse/Types.hs @@ -0,0 +1,881 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# HLINT ignore "Use unwords" #-} +{-# HLINT ignore "Use <$>" #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- | Abstract Grammar for the dot language. +-- http://www.graphviz.org/doc/info/lang.html +module DotParse.Types + ( DotConfig (..), + defaultDotConfig, + DotParse (..), + testDotParser, + runDotParser, + Error (..), + prettyError, + Graph (..), + gattL, + attL, + defaultGraph, + processDotWith, + processDot, + processGraph, + processGraphWith, + + -- * components + Strict (..), + defStrict, + Directed (..), + defDirected, + ID (..), + label, + Compass (..), + Port (..), + AttributeType (..), + AttributeStatement (..), + NodeStatement (..), + EdgeID (..), + EdgeOp (..), + fromDirected, + EdgeStatement (..), + edgeID, + edgeIDs, + edgeIDsNamed, + Statement (..), + addStatement, + addStatements, + SubGraphStatement (..), + + -- * Graph Extraction + bbL, + nodesPortL, + nodesL, + edgesL, + nodesA, + edgesA, + nodePos, + nodeWidth, + edgeSpline, + edgeWidth, + NodeInfo (..), + nodeInfo, + EdgeInfo (..), + edgeInfo, + splinePath, + + -- * Conversion + graphToChartWith, + graphToChart, + ChartConfig (..), + defaultChartConfig, + toStatements, + toDotGraph, + toDotGraphWith, + ) +where + +import qualified Algebra.Graph as G +import Chart +import Control.Monad +import Data.Bool +import Data.ByteString hiding (any, empty, filter, head, length, map, zip, zipWith) +import qualified Data.ByteString.Char8 as B +import Data.List.NonEmpty hiding (filter, head, length, map, zip, zipWith, (!!)) +import Data.Map.Merge.Strict +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.Monoid +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 GHC.Generics +import NeatInterpolation +import Optics.Core +import System.Exit +import System.Process.ByteString +import Prelude hiding (replicate) + +-- $setup +-- >>> import DotParse +-- >>> import qualified Data.Map as Map +-- >>> :set -XOverloadedStrings + +-- | printing options, for separators. +data DotConfig = DotConfig + { topLevelSep :: ByteString, + statementSep :: ByteString, + attSep :: ByteString, + subGraphSep :: ByteString + } + deriving (Eq, Show, Generic) + +-- | default separators +defaultDotConfig :: DotConfig +defaultDotConfig = DotConfig " " "\n " ";" ";" + +-- | A parser & printer class for a graphviz graph and components of its dot language +class DotParse a where + dotPrint :: DotConfig -> a -> ByteString + dotParse :: Parser Error a + +-- | dotParse and then dotPrint: +-- +-- - pretty printing error on failure. +-- +-- - This is not an exact parser/printer, so the test re-parses the dotPrint, which should be idempotent +testDotParser :: forall a. (DotParse a) => Proxy a -> DotConfig -> ByteString -> IO () +testDotParser _ cfg b = + case runParser dotParse b :: Result Error a of + Err e -> B.putStrLn $ prettyError b e + OK a left -> do + when (left /= "") (B.putStrLn $ "parsed with leftovers: " <> left) + case runParser dotParse (dotPrint cfg a) :: Result Error a of + Err e -> B.putStrLn $ "round trip error: " <> prettyError (dotPrint cfg a) e + Fail -> B.putStrLn "uncaught round trip parse error" + OK _ left' -> do + when (left' /= "") (B.putStrLn $ "round trip parse with left overs" <> left) + Fail -> B.putStrLn "uncaught parse error" + +-- | run a dotParse erroring on leftovers, Fail or Err +runDotParser :: (DotParse a) => ByteString -> a +runDotParser = runParser_ dotParse + +-- | Representation of a full graphviz graph, as per the dot language specification +data Graph = Graph + { strict :: Last Strict, + directed :: Last Directed, + graphid :: Last ID, + nodeAttributes :: Map.Map ID ID, + graphAttributes :: Map.Map ID ID, + edgeAttributes :: Map.Map ID ID, + globalAttributes :: Map.Map ID ID, + nodes :: [NodeStatement], + edges :: [EdgeStatement], + subgraphs :: [SubGraphStatement] + } + deriving (Eq, Show, Generic) + +instance Semigroup Graph where + (Graph m d i na ga ea gs ns es ss) <> (Graph m' d' i' na' ga' ea' gs' ns' es' ss') = + Graph (m <> m') (d <> d') (i <> i') (na <> na') (ga <> ga') (ea <> ea') (gs <> gs') (ns <> ns') (es <> es') (ss <> ss') + +instance Monoid Graph where + mempty = Graph mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty + +-- | global attributes lens +gattL :: ID -> Lens' Graph (Maybe ID) +gattL k = #globalAttributes % at k + +-- | attributes lens +attL :: AttributeType -> ID -> Lens' Graph (Maybe ID) +attL GraphType k = #graphAttributes % at k +attL NodeType k = #nodeAttributes % at k +attL EdgeType k = #edgeAttributes % at k + +outercalate :: ByteString -> [ByteString] -> ByteString +outercalate _ [] = mempty +outercalate a xs = a <> intercalate a xs <> a + +instance DotParse Graph where + dotPrint cfg (Graph me d i na ga ea gs ns es ss) = + intercalate (cfg ^. #topLevelSep) $ + bool [] ["strict"] (me == Last (Just MergeEdges)) + <> bool ["digraph"] ["graph"] (d == Last (Just UnDirected)) + <> maybe [] ((: []) . dotPrint cfg) (getLast i) + <> [ wrapCurlyPrint $ + outercalate + (cfg ^. #statementSep) + ( [dotPrint cfg (AttributeStatement NodeType na)] + <> [dotPrint cfg (AttributeStatement GraphType ga)] + <> [dotPrint cfg (AttributeStatement EdgeType ea)] + <> (dotPrint cfg . GlobalAttributeStatement <$> Map.toList gs) + <> (dotPrint cfg <$> ns) + <> (dotPrint cfg <$> es) + <> (dotPrint cfg <$> ss) + ) + ] + + dotParse = token $ do + me <- dotParse + d <- dotParse + i <- optional dotParse + ss <- wrapCurlyP (many dotParse) + let g = + (mempty :: Graph) + & #strict .~ Last (Just me) + & #directed .~ Last (Just d) + & #graphid .~ Last i + pure $ addStatements ss g + +-- * Dot Grammar + +-- | MergeEdges (strict) +data Strict = MergeEdges | NoMergeEdges deriving (Eq, Show, Generic) + +instance DotParse Strict where + dotPrint _ MergeEdges = "strict" + dotPrint _ NoMergeEdges = "" + + dotParse = token $ optioned $(keyword "strict") (const $ pure MergeEdges) (pure NoMergeEdges) + +-- | Default Strict is NoMergeEdges +defStrict :: Last Strict -> Strict +defStrict (Last Nothing) = NoMergeEdges +defStrict (Last (Just x)) = x + +-- | Directed (digraph | graph) +data Directed = Directed | UnDirected deriving (Eq, Show, Generic) + +instance DotParse Directed where + dotPrint _ Directed = "digraph" + dotPrint _ UnDirected = "graph" + + dotParse = + token $ + (Directed <$ $(keyword "digraph")) + <|> (UnDirected <$ $(keyword "graph")) + +-- | Default Directed is Directed +defDirected :: Last Directed -> Directed +defDirected (Last Nothing) = Directed +defDirected (Last (Just x)) = x + +-- | A dot statement as per the dot language specification. +data Statement = StatementNode NodeStatement | StatementEdge EdgeStatement | StatementGlobalAttribute GlobalAttributeStatement | StatementAttribute AttributeStatement | StatementSubGraph SubGraphStatement deriving (Eq, Show, Generic) + +instance DotParse Statement where + dotPrint cfg (StatementNode x) = dotPrint cfg x + dotPrint cfg (StatementEdge x) = dotPrint cfg x + dotPrint cfg (StatementAttribute x) = dotPrint cfg x + dotPrint cfg (StatementGlobalAttribute x) = dotPrint cfg x + dotPrint cfg (StatementSubGraph x) = dotPrint cfg x + + dotParse = + token $ + -- Order is important + (StatementEdge <$> dotParse) + <|> (StatementAttribute <$> dotParse) + <|> (StatementGlobalAttribute <$> dotParse) + <|> (StatementSubGraph <$> dotParse) + <|> (StatementNode <$> dotParse) + +-- | Identifier as per the dot language specifications. +-- +-- >>> runDotParser "0" :: ID +-- IDInt 0 +-- +-- >>> runDotParser "-.123" :: ID +-- IDDouble (-0.123) +-- +-- >>> runParser dotParse "apple_1'" :: Result Error ID +-- OK (ID "apple_1") "'" +-- +-- >>> :set -XQuasiQuotes +-- >>> runParser dotParse "\"hello\"" :: Result Error ID +-- OK (IDQuoted "hello") "" +-- +-- >>> runDotParser "foo,
the bar and
the baz>" :: ID +-- IDHtml "foo,
the bar and
the baz>" +data ID = ID ByteString | IDInt Int | IDDouble Double | IDQuoted ByteString | IDHtml ByteString deriving (Eq, Show, Generic, Ord) + +instance DotParse ID where + dotPrint _ (ID s) = s + dotPrint _ (IDInt i) = packUTF8 (show i) + dotPrint _ (IDDouble x) = packUTF8 (show x) + dotPrint _ (IDQuoted x) = + wrapQuotePrint x + dotPrint _ (IDHtml s) = s + + -- order matters + dotParse = + (ID <$> ident) + <|> (IDInt <$> (signed int `notFollowedBy` $(char '.'))) + <|> (IDDouble <$> signed double) + <|> (IDQuoted . packUTF8 <$> quoted) + <|> (IDHtml . packUTF8 <$> htmlLike) + +-- | ID as the equivalent plain String +-- +-- note that the dot language identifier equivalence law is: +-- +-- > x == y if label x == label y +label :: ID -> String +label (ID s) = unpackUTF8 s +label (IDInt i) = show i +label (IDDouble d) = show d +label (IDQuoted q) = unpackUTF8 q +label (IDHtml h) = unpackUTF8 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 + + dotParse = token $ + do + x0 <- token dotParse + _ <- token $(symbol "=") + x1 <- dotParse + pure (x0, x1) + +-- | 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 = + bool + (wrapSquarePrint (intercalate (cfg ^. #attSep) $ dotPrint cfg <$> Map.toList as)) + mempty + (as == Map.empty) + + dotParse = + Map.fromList . mconcat . fmap toList + <$> token (many (wrapSquareP (nonEmptyP dotParse sepP)) <|> ([] <$ wrapSquareP ws)) + +-- | Compass instructions which are optionally associated with an identifier +data Compass = CompassN | CompassNE | CompassE | CompassSE | CompassS | CompassSW | CompassW | CompassNW | CompassC | Compass_ deriving (Eq, Show, Generic) + +instance DotParse Compass where + dotPrint _ CompassN = "n" + dotPrint _ CompassNE = "ne" + dotPrint _ CompassE = "e" + dotPrint _ CompassSE = "se" + dotPrint _ CompassS = "s" + dotPrint _ CompassSW = "sw" + dotPrint _ CompassW = "w" + dotPrint _ CompassNW = "nw" + dotPrint _ CompassC = "c" + dotPrint _ Compass_ = "_" + + dotParse = + token + $( switch + [| + case _ of + "n" -> pure CompassN + "ne" -> pure CompassNE + "e" -> pure CompassE + "se" -> pure CompassSE + "s" -> pure CompassS + "sw" -> pure CompassSW + "w" -> pure CompassW + "nw" -> pure CompassNW + "c" -> pure CompassC + "_" -> pure Compass_ + |] + ) + +-- | Port instructions which are optionally associated with an identifier +newtype Port = Port {portID :: These ID Compass} deriving (Eq, Show, Generic) + +instance DotParse Port where + dotPrint cfg (Port (This i)) = ": " <> dotPrint cfg i + dotPrint cfg (Port (That c)) = ": " <> dotPrint cfg c + dotPrint cfg (Port (These i c)) = ": " <> dotPrint cfg i <> " : " <> dotPrint cfg c + + dotParse = + token $ + ((\x0 x1 -> Port (These x0 x1)) <$> ($(symbol ":") *> dotParse) <*> ($(symbol ":") *> dotParse)) + <|> (Port . This <$> ($(symbol ":") *> dotParse)) + <|> (Port . That <$> ($(symbol ":") *> dotParse)) + +-- | A top-level attribute +-- +-- >>> runDotParser "rankdir=\"BT\"" :: Statement +-- StatementGlobalAttribute (GlobalAttributeStatement {globalAttributeStatement = (ID "rankdir",IDQuoted "BT")}) +newtype GlobalAttributeStatement = GlobalAttributeStatement {globalAttributeStatement :: (ID, ID)} deriving (Eq, Show, Generic) + +instance DotParse GlobalAttributeStatement where + dotPrint cfg (GlobalAttributeStatement s) = dotPrint cfg s + dotParse = GlobalAttributeStatement <$> dotParse + +-- | Category of attribute +data AttributeType = GraphType | NodeType | EdgeType deriving (Eq, Show, Generic) + +instance DotParse AttributeType where + dotPrint _ GraphType = "graph" + dotPrint _ NodeType = "node" + dotPrint _ EdgeType = "edge" + + dotParse = + token + (GraphType <$ $(keyword "graph")) + <|> (NodeType <$ $(keyword "node")) + <|> (EdgeType <$ $(keyword "edge")) + +-- | Top-level attribute statement +-- +-- >>> runDotParser "graph [overlap=false, splines=spline, size=\"1!\"];" :: Statement +-- StatementAttribute (AttributeStatement {attributeType = GraphType, attributes = fromList [(ID "overlap",ID "false"),(ID "size",IDQuoted "1!"),(ID "splines",ID "spline")]}) +data AttributeStatement = AttributeStatement {attributeType :: AttributeType, attributes :: Map.Map ID ID} deriving (Eq, Show, Generic) + +instance DotParse AttributeStatement where + dotPrint cfg (AttributeStatement t as) = + intercalate + " " + [dotPrint cfg t, dotPrint cfg as] + + dotParse = AttributeStatement <$> dotParse <*> dotParse + +-- | Node statement +-- +-- >>> runDotParser "A [shape=diamond; color=blue]" :: Statement +-- StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList [(ID "color",ID "blue"),(ID "shape",ID "diamond")]}) +data NodeStatement = NodeStatement {nodeID :: ID, port :: Maybe Port, nodeAttrs :: Map.Map ID ID} deriving (Eq, Show, Generic) + +instance DotParse NodeStatement where + dotPrint cfg (NodeStatement i p as) = + intercalate " " $ + [dotPrint cfg i] + <> (dotPrint cfg <$> maybeToList p) + <> [dotPrint cfg as] + + dotParse = NodeStatement <$> dotParse <*> optional dotParse <*> dotParse + +-- | An edge can be specified in as a NodeID or as a SubGraph +data EdgeID + = EdgeID ID (Maybe Port) + | EdgeSubGraph SubGraphStatement + deriving (Eq, Show, Generic) + +instance DotParse EdgeID where + dotPrint cfg (EdgeID e p) = + mconcat $ [dotPrint cfg e] <> (dotPrint cfg <$> maybeToList p) + dotPrint cfg (EdgeSubGraph s) = dotPrint cfg s + + dotParse = + (EdgeID <$> dotParse <*> optional dotParse) + <|> (EdgeSubGraph <$> dotParse) + +-- | An edgeop is -> in directed graphs and -- in undirected graphs. +data EdgeOp = EdgeDirected | EdgeUndirected deriving (Eq, Show, Generic) + +instance DotParse EdgeOp where + dotPrint _ EdgeDirected = "->" + dotPrint _ EdgeUndirected = "--" + + dotParse = + token + $( switch + [| + case _ of + "->" -> pure EdgeDirected + "--" -> pure EdgeUndirected + |] + ) + +-- | generate an EdgeOp given the type of graph. +fromDirected :: Directed -> EdgeOp +fromDirected Directed = EdgeDirected +fromDirected UnDirected = EdgeUndirected + +-- | Edge statement +-- +-- >>> runDotParser "A -> B [style=dashed, color=grey]" :: Statement +-- StatementEdge (EdgeStatement {edgeOp = EdgeDirected, leftEdge = EdgeID (ID "A") Nothing, rightEdges = EdgeID (ID "B") Nothing :| [], edgeAttrs = fromList [(ID "color",ID "grey"),(ID "style",ID "dashed")]}) +data EdgeStatement = EdgeStatement {edgeOp :: EdgeOp, leftEdge :: EdgeID, rightEdges :: NonEmpty EdgeID, edgeAttrs :: Map.Map ID ID} deriving (Eq, Show, Generic) + +instance DotParse EdgeStatement where + dotPrint cfg (EdgeStatement l rs xs as) = + intercalate + " " + ( [intercalate (" " <> dotPrint cfg l <> " ") (dotPrint cfg <$> (rs : toList xs))] + <> [dotPrint cfg as] + ) + + dotParse = token $ do + l <- dotParse + o0 <- dotParse + r0 <- dotParse + ors <- many ((,) <$> dotParse <*> dotParse) + as <- dotParse + bool + (pure (EdgeStatement o0 l (r0 :| (snd <$> ors)) as)) + empty + (any ((/= o0) . fst) ors) + +-- | The edge ID or subgraph ID (if any) +edgeID :: EdgeID -> Maybe ID +edgeID (EdgeID i _) = Just i +edgeID (EdgeSubGraph (SubGraphStatement i _)) = i + +-- | edge IDs +edgeIDsNamed :: EdgeStatement -> [(ID, ID)] +edgeIDsNamed e = [(x, y) | (Just x, Just y) <- edgeIDs e] + +-- | list of edges in a given EdgeStatement, including anonymous SugGraphs +edgeIDs :: EdgeStatement -> [(Maybe ID, Maybe ID)] +edgeIDs e = zip (id0 : id1) id1 + where + id0 = edgeID (view #leftEdge e) + id1 = edgeID <$> toList (view #rightEdges e) + +-- | A subgraph statement. +-- +-- Note: each subgraph must have a unique name +-- +-- >>> runDotParser "subgraph A {A, B, C}" :: Statement +-- StatementSubGraph (SubGraphStatement {subgraphID = Just (ID "A"), subgraphStatements = [StatementNode (NodeStatement {nodeID = ID "A", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "B", port = Nothing, nodeAttrs = fromList []}),StatementNode (NodeStatement {nodeID = ID "C", port = Nothing, nodeAttrs = fromList []})]}) +data SubGraphStatement = SubGraphStatement {subgraphID :: Maybe ID, subgraphStatements :: [Statement]} deriving (Eq, Show, Generic) + +instance DotParse SubGraphStatement where + dotPrint cfg (SubGraphStatement x xs) = + intercalate " " $ + maybe + [] + (\x' -> [intercalate " " ["subgraph", dotPrint cfg x']]) + x + <> (: []) (wrapCurlyPrint (intercalate (cfg ^. #subGraphSep) $ dotPrint cfg <$> xs)) + + dotParse = token $ do + x <- optional ($(keyword "subgraph") *> dotParse) + pure (SubGraphStatement x) <*> wrapCurlyP (many (optional sepP *> dotParse)) + +-- | add a graphviz statement to a 'Graph' +addStatement :: Statement -> Graph -> Graph +addStatement (StatementNode n) g = g & #nodes %~ (<> [n]) +addStatement (StatementEdge e) g = g & #edges %~ (<> [e]) +addStatement (StatementSubGraph s) g = g & #subgraphs %~ (<> [s]) +addStatement (StatementAttribute (AttributeStatement GraphType as)) g = g & #graphAttributes %~ (<> as) +addStatement (StatementAttribute (AttributeStatement NodeType as)) g = g & #nodeAttributes %~ (<> as) +addStatement (StatementAttribute (AttributeStatement EdgeType as)) g = g & #edgeAttributes %~ (<> as) +addStatement (StatementGlobalAttribute (GlobalAttributeStatement s)) g = g & #globalAttributes %~ (<> Map.fromList [s]) + +-- | add a list of graphviz statements to a 'Graph' +addStatements :: [Statement] -> Graph -> Graph +addStatements ss g = Prelude.foldr addStatement g ss + +-- | default dot graph as a ByteString +defaultBS :: ByteString +defaultBS = + encodeUtf8 + [trimming| +digraph { + node [shape=circle + ,height=0.5]; + graph [overlap=false + ,splines=spline + ,size="1!"]; + edge [arrowsize=0]; + } +|] + +-- | 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] +-- } +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 + let cmd = case d of + Directed -> "dot" + UnDirected -> "neato" + (r, input, e) <- readProcessWithExitCode cmd args i + bool + (error $ unpackUTF8 e) + (pure input) + (r == ExitSuccess) + +-- | run a dot string through graphviz, collecting the augmented dot string output +processDot :: Directed -> ByteString -> IO ByteString +processDot d = processDotWith d ["-Tdot"] + +-- | Augment a Graph via the graphviz process +processGraphWith :: DotConfig -> Graph -> IO Graph +processGraphWith cfg g = + runDotParser <$> processDot (defDirected $ view #directed g) (dotPrint cfg g) + +-- | Augment a Graph via the graphviz process +processGraph :: Graph -> IO Graph +processGraph g = + runDotParser <$> processDot (defDirected $ view #directed g) (dotPrint defaultDotConfig g) + +instance DotParse (Point Double) where + dotPrint _ (Point x y) = + intercalate "," $ + packUTF8 . show <$> [x, y] + + dotParse = token pointP + +pointI :: Iso' ID (Point Double) +pointI = + iso + (runParser_ pointP . packUTF8 . label) + (IDQuoted . dotPrint defaultDotConfig) + +instance DotParse (Rect Double) where + dotPrint _ (Rect x z y w) = + intercalate "," $ + packUTF8 . show <$> [x, y, z, w] + + dotParse = token rectP + +rectI :: Iso' ID (Rect Double) +rectI = + iso + (runParser_ rectP . packUTF8 . label) + (IDQuoted . dotPrint defaultDotConfig) + +-- | Bounding box ID lens +bb_ :: Lens' Graph (Maybe ID) +bb_ = #graphAttributes % at (ID "bb") + +-- | Bounding Box lens as a 'Rect' +bbL :: Lens' Graph (Maybe (Rect Double)) +bbL = lens (preview (bb_ % _Just % rectI)) (\g r -> set bb_ (review rectI <$> r) g) + +-- | nodes lens +nodesPortL :: Lens' Graph (Map.Map ID (Maybe Port, Map.Map ID ID)) +nodesPortL = + lens + ( \g -> + g & view #nodes + & fmap (\x -> (view #nodeID x, (view #port x, view #nodeAttrs x))) + & Map.fromList + ) + (\g m -> g & #nodes .~ ((\(n, (p, a)) -> NodeStatement n p a) <$> Map.toList m)) + +-- | nodes lens ignoring/forgetting port information +nodesL :: Lens' Graph (Map.Map ID (Map.Map ID ID)) +nodesL = + lens + ( \g -> + g & view #nodes + & fmap (\x -> (view #nodeID x, view #nodeAttrs x)) + & Map.fromList + ) + (\g m -> g & #nodes .~ ((\(n, a) -> NodeStatement n Nothing a) <$> Map.toList m)) + +-- | edges lens ignoring/forgetting port information +edgesL :: Lens' Graph (Map.Map (ID, ID) (Map.Map ID ID)) +edgesL = + lens getEdges_ setEdges_ + +-- | edge & attribute map +-- ignores anonymous subgraphs +getEdges_ :: Graph -> Map.Map (ID, ID) (Map.Map ID ID) +getEdges_ g = + Map.fromList $ + mconcat $ + fmap + (\(xs, a) -> (,a) <$> xs) + [(edgeIDsNamed e, view #edgeAttrs e) | e <- view #edges g] + +setEdges_ :: Graph -> Map.Map (ID, ID) (Map.Map ID ID) -> Graph +setEdges_ g m = + g + & #edges + .~ ( ( \((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) +nodesA a g = fmap (Map.lookup a) (view nodesL g) + +-- | node position (as a Point) +nodePos :: Graph -> Map.Map ID (Maybe (Point Double)) +nodePos = fmap (fmap (view pointI)) . nodesA (ID "pos") + +-- + +-- | Specific attribute for all edges +edgesA :: Graph -> ID -> Map.Map (ID, ID) (Maybe ID) +edgesA g a = fmap (Map.lookup a) (view edgesL g) + +-- | node width attributes +nodeWidth :: Graph -> Map.Map ID (Maybe Double) +nodeWidth g = + fmap + ( \case + Just (IDDouble x') -> Just x' + _ -> Nothing + ) + $ nodesA (ID "width") g + +-- | edge width attributes +edgeWidth :: Graph -> Map.Map (ID, ID) (Maybe Double) +edgeWidth g = + fmap + ( \case + Just (IDDouble x') -> Just x' + _ -> Nothing + ) + $ edgesA g (ID "width") + +-- | edge path attributes +edgeSpline :: Graph -> Map.Map (ID, ID) (Maybe Spline) +edgeSpline g = + fmap + ( \case + Just (IDQuoted x') -> Just (runParser_ splineP x') + _ -> Nothing + ) + $ edgesA g (ID "pos") + +-- | typical node information after processing a dot bytestring. +data NodeInfo = NodeInfo {nlabel :: ID, nwidth :: Double, pos :: Point Double} deriving (Eq, Show, Generic) + +-- | Create a list of NodeInfo from a graph. +nodeInfo :: Graph -> Double -> [NodeInfo] +nodeInfo g w = [NodeInfo x (fromMaybe w (join w')) p | (x, (Just p, w')) <- xs] + where + xs = + Map.toList $ + merge + (mapMissing (\_ v -> (v, Nothing))) + dropMissing + (zipWithMatched (\_ x y -> (x, Just y))) + (nodePos g) + (nodeWidth g) + +-- | typical edge information after processing a dot bytestring. +data EdgeInfo = EdgeInfo {elabel :: (ID, ID), ewidth :: Double, curve :: [PathData Double]} deriving (Eq, Show, Generic) + +-- | Create a list of EdgeInfo from a graph +edgeInfo :: Graph -> Double -> [EdgeInfo] +edgeInfo g w = [EdgeInfo (x, y) (fromMaybe w (join w')) (splinePath p) | ((x, y), (Just p, w')) <- xs] + where + xs = + Map.toList $ + merge + (mapMissing (\_ v -> (v, Nothing))) + dropMissing + (zipWithMatched (\_ x y -> (x, Just y))) + (edgeSpline g) + (edgeWidth g) + +-- | +-- +-- https://graphviz.org/docs/attr-types/splineType/ +-- format of the example is end point point and then triples (5,8,11 lengths are 1, 2 and 3 cubics) +splinePath :: Spline -> [PathData Double] +splinePath sp = s' <> p1' <> cs <> e' + where + s' = maybe [] (\s -> [StartP s, LineP $ view #splineP1 sp]) (view #splineStart sp) + e' = maybe [] (\e -> [LineP e]) (view #splineEnd sp) + p1' = [StartP (view #splineP1 sp)] + cs = (\(x, y, z) -> CubicP x y z) <$> view #splineTriples sp + +-- | create Statements from a (no edge label) algebraic graph +toStatements :: Directed -> G.Graph ByteString -> [Statement] +toStatements d g = + ((\x -> StatementNode $ NodeStatement (IDQuoted x) Nothing Map.empty) <$> G.vertexList g) + <> ( ( \(x, y) -> + StatementEdge $ + EdgeStatement + (fromDirected d) + (EdgeID (IDQuoted x) Nothing) + (fromList [EdgeID (IDQuoted y) Nothing]) + Map.empty + ) + <$> G.edgeList g + ) + +-- | Various configutaion parameters for the chart-svg Chart +data ChartConfig = ChartConfig + { chartHeight :: Double, + chartScale :: Double, + edgeSize :: Double, + chartColor :: Colour, + chartBackgroundColor :: Colour, + nodeHeight :: Double, + nodeSize :: Double, + vshift :: Double, + textSize :: Double, + labelf :: ID -> Text + } + deriving (Generic) + +-- | 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) + +-- | 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) +-- +-- ![Example](other/ex.svg) +graphToChartWith :: ChartConfig -> Graph -> ChartSvg +graphToChartWith cfg g = + mempty + & #charts .~ named "edges" ps <> named "shapes" c0 <> named "labels" [ts] + & #svgOptions % #svgHeight .~ (cfg ^. #chartHeight) + & #hudOptions .~ (mempty & #chartAspect .~ ChartAspect) + 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) + -- 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) + vshift' = cfg ^. #vshift + -- node information + ns = nodeInfo g (cfg ^. #nodeSize) + -- edge information + es = edgeInfo g (cfg ^. #edgeSize) + -- paths + ps = fmap (\(EdgeInfo _ w p) -> PathChart (defaultPathStyle & #borderSize .~ (2 * w) & #borderColor .~ (cfg ^. #chartColor) & #color .~ transparent) p) es + -- circles + 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) + +-- | convert a 'Graph' processed via the graphviz commands to a 'ChartSvg' using the default ChartConfig. +graphToChart :: Graph -> ChartSvg +graphToChart = graphToChartWith defaultChartConfig + +-- | Convert an algebraic graph to a dotparse graph. +toDotGraphWith :: Directed -> Graph -> G.Graph ByteString -> Graph +toDotGraphWith d g gg = g & #directed .~ Last (Just d) & addStatements (toStatements d gg) + +-- | Convert an algebraic graph to a dotparse graph, starting with the 'defaultGraph'. +toDotGraph :: G.Graph ByteString -> Graph +toDotGraph = toDotGraphWith Directed defaultGraph