From 37122c433bbc42d0ad2068a5046576e78b65ea0b Mon Sep 17 00:00:00 2001
From: Ignat Insarov <kindaro@gmail.com>
Date: Thu, 3 Apr 2025 13:40:04 +0700
Subject: [PATCH] add orthogonal edges feature

---
 src/Calligraphy/Phases/Render/GraphViz.hs | 21 ++++++++++++++++++---
 1 file changed, 18 insertions(+), 3 deletions(-)

diff --git a/src/Calligraphy/Phases/Render/GraphViz.hs b/src/Calligraphy/Phases/Render/GraphViz.hs
index 0bdd1c7..8364afe 100644
--- a/src/Calligraphy/Phases/Render/GraphViz.hs
+++ b/src/Calligraphy/Phases/Render/GraphViz.hs
@@ -18,13 +18,25 @@ import Data.Maybe (catMaybes)
 import Data.Tree (Tree)
 import qualified Data.Tree as Tree
 import Options.Applicative hiding (style)
+import Options.Applicative.Types
 import Text.Show (showListWith)
 
+data Splines = Curved | Straight | Orthogonal
+
+spline :: ReadM Splines
+spline = do
+  string <- readerAsk
+  case string of
+    "curved" -> pure Curved
+    "straight" -> pure Straight
+    "orthogonal" -> pure Orthogonal
+    _ -> readerError $ "Wrong argument: '" <> string <> "'.\nMust be either 'curved', 'straight' or 'orthogonal'."
+
 data GraphVizConfig = GraphVizConfig
   { showChildArrowhead :: Bool,
     clusterGroups :: Bool,
     leftToRight :: Bool,
-    splines :: Bool,
+    splines :: Splines,
     reverseDependencyRank :: Bool
   }
 
@@ -34,13 +46,16 @@ pGraphVizConfig =
     <$> flag False True (long "show-child-arrowhead" <> help "Put an arrowhead at the end of a parent-child edge")
     <*> flag True False (long "no-cluster-trees" <> help "Don't draw definition trees as a cluster.")
     <*> flag False True (long "left-to-right" <> help "Draw the tree from left to right.")
-    <*> flag True False (long "no-splines" <> help "Render arrows as straight lines instead of splines")
+    <*> option spline (long "splines" <> help "Set shape of splines; can be 'curved', 'straight' or 'orthogonal'." <> value Curved)
     <*> flag False True (long "reverse-dependency-rank" <> help "Make dependencies have lower rank than the dependee, i.e. show dependencies above their parent.")
 
 renderGraphViz :: GraphVizConfig -> Prints RenderGraph
 renderGraphViz GraphVizConfig {..} (RenderGraph roots calls types) = do
   brack "digraph calligraphy {" "}" $ do
-    unless splines $ textLn "splines=false;"
+    case splines of
+      Curved -> pure ()
+      Straight -> textLn "splines=false"
+      Orthogonal -> textLn "splines=ortho"
     when leftToRight $ textLn "rankdir=\"RL\";"
     textLn "node [style=filled fillcolor=\"#ffffffcf\"];"
     textLn "graph [outputorder=edgesfirst];"