Permalink
Browse files

Convert SyntaxGraph to an FGL graph, and render it.

  • Loading branch information...
1 parent 58a757d commit e19deaaa2d29ee0911d2cb2870798b69cc60566d @rgleichman committed Jul 2, 2016
Showing with 68 additions and 22 deletions.
  1. +2 −1 app/Icons.hs
  2. +22 −14 app/Translate.hs
  3. +19 −3 app/TranslateCore.hs
  4. +2 −1 app/Types.hs
  5. +3 −0 notes.txt
  6. +20 −3 test/AllTests.hs
View
@@ -16,7 +16,8 @@ module Icons
defaultLineWidth,
ColorStyle(..),
colorScheme,
- nestedApplyDia
+ nestedApplyDia,
+ coloredTextBox
) where
import Diagrams.Prelude hiding ((&), (#))
View
@@ -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
View
@@ -22,18 +22,21 @@ module TranslateCore(
makeBox,
nTupleString,
nListString,
- syntaxGraphToIconGraph
+ syntaxGraphToIconGraph,
+ syntaxGraphToFglGraph
) where
import Data.Semigroup(Semigroup, (<>))
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
View
@@ -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)
View
@@ -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
View
@@ -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 ()

0 comments on commit e19deaa

Please sign in to comment.