Convert SyntaxGraph to an FGL graph, and render it.

app/Icons.hs

@@ -16,7 +16,8 @@ module Icons
     defaultLineWidth,
     ColorStyle(..),
     colorScheme,
-    nestedApplyDia
+    nestedApplyDia,
+    coloredTextBox
     ) where
 
 import Diagrams.Prelude hiding ((&), (#))

app/Translate.hs

@@ -2,7 +2,8 @@
 module Translate(
   translateString,
   drawingFromDecl,
-  drawingsFromModule
+  drawingsFromModule,
+  stringToSyntaxGraph
 ) where
 
 import qualified Diagrams.Prelude as DIA hiding ((#), (&))
@@ -474,23 +475,24 @@ evalDecl c d = evaluatedDecl where
     --TODO: Add other cases here
     _ -> pure mempty
 
+showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph
+showTopLevelBinds gr@(SyntaxGraph _ _ _ binds) = do
+  let
+    addBind (_, Left _) = pure mempty
+    addBind (patName, Right port) = do
+      uniquePatName <- getUniqueName patName
+      let
+        icons = toNames [(uniquePatName, NameNode patName)]
+        edges = [makeSimpleEdge (justName uniquePatName, port)]
+        edgeGraph = syntaxGraphFromNodesEdges icons edges
+      pure edgeGraph
+  newGraph <- mconcat <$> mapM addBind binds
+  pure $ newGraph <> gr
+
 drawingFromDecl :: Decl -> Drawing
 drawingFromDecl d = iconGraphToDrawing $ syntaxGraphToIconGraph $ evalState evaluatedDecl initialIdState
   where
     evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
-    showTopLevelBinds :: SyntaxGraph -> State IDState SyntaxGraph
-    showTopLevelBinds gr@(SyntaxGraph _ _ _ binds) = do
-      let
-        addBind (_, Left _) = pure mempty
-        addBind (patName, Right port) = do
-          uniquePatName <- getUniqueName patName
-          let
-            icons = toNames [(uniquePatName, NameNode patName)]
-            edges = [makeSimpleEdge (justName uniquePatName, port)]
-            edgeGraph = syntaxGraphFromNodesEdges icons edges
-          pure edgeGraph
-      newGraph <- mconcat <$> mapM addBind binds
-      pure $ newGraph <> gr
 
 -- Profiling: about 1.5% of total time.
 translateString :: String -> (Drawing, Decl)
@@ -500,3 +502,9 @@ translateString s = (drawing, decl) where
 
 drawingsFromModule :: Module -> [Drawing]
 drawingsFromModule (Module _ _ _ _ _ _ decls) = fmap drawingFromDecl decls
+
+stringToSyntaxGraph :: String -> SyntaxGraph
+stringToSyntaxGraph s = graph where
+  decl = fromParseResult (parseDecl s)
+  evaluatedDecl = evalDecl mempty decl >>= showTopLevelBinds
+  graph = evalState evaluatedDecl initialIdState

app/TranslateCore.hs

@@ -22,7 +22,8 @@ module TranslateCore(
   makeBox,
   nTupleString,
   nListString,
-  syntaxGraphToIconGraph
+  syntaxGraphToIconGraph,
+  syntaxGraphToFglGraph
 ) where
 
 import Data.Semigroup(Semigroup, (<>))
@@ -30,10 +31,12 @@ import qualified Diagrams.Prelude as DIA
 import Control.Monad.State(State)
 import Data.Either(partitionEithers)
 import Control.Arrow(second)
+import Data.Graph.Inductive.PatriciaTree as FGR
+import Diagrams.TwoD.GraphViz as DiaGV
 
 import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState,
   getId)
-import Util(noEnds, nameAndPort, makeSimpleEdge, justName)
+import Util(noEnds, nameAndPort, makeSimpleEdge, justName, fromMaybeError)
 import Icons(Icon(..))
 
 -- OVERVIEW --
@@ -44,11 +47,12 @@ import Icons(Icon(..))
 -- used in Translate.
 
 type Reference = Either String NameAndPort
+type SgNamedNode = (DIA.Name, SyntaxNode)
 
 -- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
 -- generated from the Haskell syntax tree, and are used to generate IconGraphs
 data SyntaxGraph = SyntaxGraph {
-  sgNodes :: [(DIA.Name, SyntaxNode)],
+  sgNodes :: [SgNamedNode],
   sgEdges :: [Edge],
   sgSinks :: [(String, NameAndPort)],
   sgSources :: [(String, Reference)]
@@ -203,6 +207,18 @@ nodeToIcon (CaseNode n) = CaseIcon n
 nodeToIcon BranchNode = BranchIcon
 nodeToIcon CaseResultNode = CaseResultIcon
 
+syntaxGraphToFglGraph :: SyntaxGraph -> FGR.Gr SgNamedNode Edge
+syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _) =
+  DiaGV.mkGraph nodes labeledEdges where
+    labeledEdges = fmap makeLabeledEdge edges
+    makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) =
+      ((name1, lookupInNodes name1), (name2, lookupInNodes name2), e) where
+        lookupInNodes name = fromMaybeError errorString (lookup name nodes) where
+          errorString =
+            "syntaxGraphToFglGraph edge connects to non-existent node. Node Name ="
+            ++ show name ++ " Edge=" ++ show e
+
+
 syntaxGraphToIconGraph :: SyntaxGraph -> IconGraph
 syntaxGraphToIconGraph (SyntaxGraph nodes edges sources sinks) =
   IconGraph icons edges mempty sources sinks where

app/Types.hs

@@ -35,6 +35,7 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
   | NestedPApp (Maybe String) [Maybe (Name, Icon)]
   deriving (Show, Eq)
 
+-- TODO remove Ints from SyntaxNode data constructors.
 data SyntaxNode = ApplyNode Int-- Function application
   | PatternApplyNode String Int -- Destructors as used in patterns
   | NameNode String -- Identifiers or symbols
@@ -44,7 +45,7 @@ data SyntaxNode = ApplyNode Int-- Function application
   | CaseNode Int
   | BranchNode -- TODO remove BranchNode
   | CaseResultNode -- TODO remove caseResultNode
-  deriving (Show, Eq)
+  deriving (Show, Eq, Ord)
 
 data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show, Eq)
 

notes.txt

@@ -9,6 +9,9 @@ stack build  --exec "glance-exe -o output.svg -w 500"
 
 View circle.svg with svg-preview plug-in.
 
+To use ghci for the main executable:
+stack ghci glance
+
 To use ghci with the test file:
 stack ghci glance:test:glance-test
 

test/AllTests.hs

@@ -2,13 +2,16 @@ import Prelude hiding (return)
 import Diagrams.Prelude hiding ((#), (&))
 import Diagrams.Backend.SVG.CmdLine
 import Diagrams.Backend.SVG (renderSVG)
+import Diagrams.TwoD.GraphViz as DiaGV
+import qualified Data.GraphViz.Attributes.Complete as GVA
 
-import Icons(textBox, colorScheme, ColorStyle(..))
+import Icons(textBox, colorScheme, ColorStyle(..), coloredTextBox)
 import Rendering(renderDrawing)
 import Util(toNames, portToPort, iconToPort, iconToIcon,
   iconToIconEnds, iconTailToPort)
 import Types(Icon(..), Drawing(..), EdgeEnd(..))
-import Translate(translateString)
+import Translate(translateString, stringToSyntaxGraph)
+import TranslateCore(syntaxGraphToFglGraph)
 
 (d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
 d0Icons = toNames
@@ -396,10 +399,24 @@ translateTests = do
     vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
   pure vCattedDrawings
 
+graphTests :: IO (Diagram B)
+graphTests = do
+  layedOutGraph <- DiaGV.layoutGraph GVA.Neato fglGraph
+  pure $ DiaGV.drawGraph
+    nodeFunc
+    (\_ _ _ _ _ p -> lc white $ stroke p)
+    layedOutGraph
+  where
+    fglGraph = syntaxGraphToFglGraph $ stringToSyntaxGraph "y = f x"
+    nodeFunc (name, syntaxNode) =
+      place (coloredTextBox white (opaque white) (show syntaxNode) :: Diagram B)
+
+
 drawingsAndNames :: [(String, IO (Diagram B))]
 drawingsAndNames = [
   ("translate-tests", translateTests),
-  ("render-tests", renderTests)
+  ("render-tests", renderTests),
+  ("graph-tests", graphTests)
   ]
 
 renderDrawings :: [(String, IO (Diagram B))] -> IO ()