mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 06:55:42 +03:00
Convert SyntaxGraph to an FGL graph, and render it.
This commit is contained in:
parent
58a757d41a
commit
e19deaaa2d
@ -16,7 +16,8 @@ module Icons
|
||||
defaultLineWidth,
|
||||
ColorStyle(..),
|
||||
colorScheme,
|
||||
nestedApplyDia
|
||||
nestedApplyDia,
|
||||
coloredTextBox
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude hiding ((&), (#))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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 ()
|
||||
|
Loading…
Reference in New Issue
Block a user