mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +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,
|
defaultLineWidth,
|
||||||
ColorStyle(..),
|
ColorStyle(..),
|
||||||
colorScheme,
|
colorScheme,
|
||||||
nestedApplyDia
|
nestedApplyDia,
|
||||||
|
coloredTextBox
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude hiding ((&), (#))
|
import Diagrams.Prelude hiding ((&), (#))
|
||||||
|
@ -2,7 +2,8 @@
|
|||||||
module Translate(
|
module Translate(
|
||||||
translateString,
|
translateString,
|
||||||
drawingFromDecl,
|
drawingFromDecl,
|
||||||
drawingsFromModule
|
drawingsFromModule,
|
||||||
|
stringToSyntaxGraph
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Diagrams.Prelude as DIA hiding ((#), (&))
|
import qualified Diagrams.Prelude as DIA hiding ((#), (&))
|
||||||
@ -474,23 +475,24 @@ evalDecl c d = evaluatedDecl where
|
|||||||
--TODO: Add other cases here
|
--TODO: Add other cases here
|
||||||
_ -> pure mempty
|
_ -> 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 :: Decl -> Drawing
|
||||||
drawingFromDecl d = iconGraphToDrawing $ syntaxGraphToIconGraph $ evalState evaluatedDecl initialIdState
|
drawingFromDecl d = iconGraphToDrawing $ syntaxGraphToIconGraph $ evalState evaluatedDecl initialIdState
|
||||||
where
|
where
|
||||||
evaluatedDecl = evalDecl mempty d >>= showTopLevelBinds
|
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.
|
-- Profiling: about 1.5% of total time.
|
||||||
translateString :: String -> (Drawing, Decl)
|
translateString :: String -> (Drawing, Decl)
|
||||||
@ -500,3 +502,9 @@ translateString s = (drawing, decl) where
|
|||||||
|
|
||||||
drawingsFromModule :: Module -> [Drawing]
|
drawingsFromModule :: Module -> [Drawing]
|
||||||
drawingsFromModule (Module _ _ _ _ _ _ decls) = fmap drawingFromDecl decls
|
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,
|
makeBox,
|
||||||
nTupleString,
|
nTupleString,
|
||||||
nListString,
|
nListString,
|
||||||
syntaxGraphToIconGraph
|
syntaxGraphToIconGraph,
|
||||||
|
syntaxGraphToFglGraph
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Semigroup(Semigroup, (<>))
|
import Data.Semigroup(Semigroup, (<>))
|
||||||
@ -30,10 +31,12 @@ import qualified Diagrams.Prelude as DIA
|
|||||||
import Control.Monad.State(State)
|
import Control.Monad.State(State)
|
||||||
import Data.Either(partitionEithers)
|
import Data.Either(partitionEithers)
|
||||||
import Control.Arrow(second)
|
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,
|
import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..), Drawing(..), NameAndPort(..), IDState,
|
||||||
getId)
|
getId)
|
||||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName)
|
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, fromMaybeError)
|
||||||
import Icons(Icon(..))
|
import Icons(Icon(..))
|
||||||
|
|
||||||
-- OVERVIEW --
|
-- OVERVIEW --
|
||||||
@ -44,11 +47,12 @@ import Icons(Icon(..))
|
|||||||
-- used in Translate.
|
-- used in Translate.
|
||||||
|
|
||||||
type Reference = Either String NameAndPort
|
type Reference = Either String NameAndPort
|
||||||
|
type SgNamedNode = (DIA.Name, SyntaxNode)
|
||||||
|
|
||||||
-- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
|
-- | SyntaxGraph is an abstract representation for Haskell syntax. SyntaxGraphs are
|
||||||
-- generated from the Haskell syntax tree, and are used to generate IconGraphs
|
-- generated from the Haskell syntax tree, and are used to generate IconGraphs
|
||||||
data SyntaxGraph = SyntaxGraph {
|
data SyntaxGraph = SyntaxGraph {
|
||||||
sgNodes :: [(DIA.Name, SyntaxNode)],
|
sgNodes :: [SgNamedNode],
|
||||||
sgEdges :: [Edge],
|
sgEdges :: [Edge],
|
||||||
sgSinks :: [(String, NameAndPort)],
|
sgSinks :: [(String, NameAndPort)],
|
||||||
sgSources :: [(String, Reference)]
|
sgSources :: [(String, Reference)]
|
||||||
@ -203,6 +207,18 @@ nodeToIcon (CaseNode n) = CaseIcon n
|
|||||||
nodeToIcon BranchNode = BranchIcon
|
nodeToIcon BranchNode = BranchIcon
|
||||||
nodeToIcon CaseResultNode = CaseResultIcon
|
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 -> IconGraph
|
||||||
syntaxGraphToIconGraph (SyntaxGraph nodes edges sources sinks) =
|
syntaxGraphToIconGraph (SyntaxGraph nodes edges sources sinks) =
|
||||||
IconGraph icons edges mempty sources sinks where
|
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)]
|
| NestedPApp (Maybe String) [Maybe (Name, Icon)]
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
|
-- TODO remove Ints from SyntaxNode data constructors.
|
||||||
data SyntaxNode = ApplyNode Int-- Function application
|
data SyntaxNode = ApplyNode Int-- Function application
|
||||||
| PatternApplyNode String Int -- Destructors as used in patterns
|
| PatternApplyNode String Int -- Destructors as used in patterns
|
||||||
| NameNode String -- Identifiers or symbols
|
| NameNode String -- Identifiers or symbols
|
||||||
@ -44,7 +45,7 @@ data SyntaxNode = ApplyNode Int-- Function application
|
|||||||
| CaseNode Int
|
| CaseNode Int
|
||||||
| BranchNode -- TODO remove BranchNode
|
| BranchNode -- TODO remove BranchNode
|
||||||
| CaseResultNode -- TODO remove caseResultNode
|
| CaseResultNode -- TODO remove caseResultNode
|
||||||
deriving (Show, Eq)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show, Eq)
|
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.
|
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:
|
To use ghci with the test file:
|
||||||
stack ghci glance:test:glance-test
|
stack ghci glance:test:glance-test
|
||||||
|
|
||||||
|
@ -2,13 +2,16 @@ import Prelude hiding (return)
|
|||||||
import Diagrams.Prelude hiding ((#), (&))
|
import Diagrams.Prelude hiding ((#), (&))
|
||||||
import Diagrams.Backend.SVG.CmdLine
|
import Diagrams.Backend.SVG.CmdLine
|
||||||
import Diagrams.Backend.SVG (renderSVG)
|
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 Rendering(renderDrawing)
|
||||||
import Util(toNames, portToPort, iconToPort, iconToIcon,
|
import Util(toNames, portToPort, iconToPort, iconToIcon,
|
||||||
iconToIconEnds, iconTailToPort)
|
iconToIconEnds, iconTailToPort)
|
||||||
import Types(Icon(..), Drawing(..), EdgeEnd(..))
|
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")
|
(d0A, d0B, d0Res, d0Foo, d0Bar) = ("A", "B", "res", "foo", "bar")
|
||||||
d0Icons = toNames
|
d0Icons = toNames
|
||||||
@ -396,10 +399,24 @@ translateTests = do
|
|||||||
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
vCattedDrawings = vsep 1 $ zipWith (===) (fmap alignL drawings) textDrawings
|
||||||
pure vCattedDrawings
|
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 :: [(String, IO (Diagram B))]
|
||||||
drawingsAndNames = [
|
drawingsAndNames = [
|
||||||
("translate-tests", translateTests),
|
("translate-tests", translateTests),
|
||||||
("render-tests", renderTests)
|
("render-tests", renderTests),
|
||||||
|
("graph-tests", graphTests)
|
||||||
]
|
]
|
||||||
|
|
||||||
renderDrawings :: [(String, IO (Diagram B))] -> IO ()
|
renderDrawings :: [(String, IO (Diagram B))] -> IO ()
|
||||||
|
Loading…
Reference in New Issue
Block a user