From e19deaaa2d29ee0911d2cb2870798b69cc60566d Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Sat, 2 Jul 2016 14:43:18 -0700 Subject: [PATCH] Convert SyntaxGraph to an FGL graph, and render it. --- app/Icons.hs | 3 ++- app/Translate.hs | 36 ++++++++++++++++++++++-------------- app/TranslateCore.hs | 22 +++++++++++++++++++--- app/Types.hs | 3 ++- notes.txt | 3 +++ test/AllTests.hs | 23 ++++++++++++++++++++--- 6 files changed, 68 insertions(+), 22 deletions(-) diff --git a/app/Icons.hs b/app/Icons.hs index 754a87f..1570d3c 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -16,7 +16,8 @@ module Icons defaultLineWidth, ColorStyle(..), colorScheme, - nestedApplyDia + nestedApplyDia, + coloredTextBox ) where import Diagrams.Prelude hiding ((&), (#)) diff --git a/app/Translate.hs b/app/Translate.hs index 0d43358..a662187 100644 --- a/app/Translate.hs +++ b/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 diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index f9199fb..d312b46 100644 --- a/app/TranslateCore.hs +++ b/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 diff --git a/app/Types.hs b/app/Types.hs index 7f16f26..8f1f052 100644 --- a/app/Types.hs +++ b/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) diff --git a/notes.txt b/notes.txt index c47394f..41f0ed6 100644 --- a/notes.txt +++ b/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 diff --git a/test/AllTests.hs b/test/AllTests.hs index fa9f6e6..1fb8f03 100644 --- a/test/AllTests.hs +++ b/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 ()