mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
112 lines
3.8 KiB
Haskell
112 lines
3.8 KiB
Haskell
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE MonoLocalBinds #-}
|
|
module VisualGraphAlgorithmTests (
|
|
visualCollapseTests
|
|
) where
|
|
|
|
import Diagrams.Prelude hiding ((#), (&))
|
|
|
|
import qualified Data.GraphViz as GV
|
|
import qualified Diagrams.TwoD.GraphViz as DiaGV
|
|
import qualified Data.GraphViz.Attributes.Complete as GVA
|
|
|
|
import qualified Data.Graph.Inductive as ING
|
|
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
|
|
|
import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), SgNamedNode
|
|
, NodeInfo(..), Named(..), Embedder(..))
|
|
import Translate(translateStringToSyntaxGraph)
|
|
import TranslateCore(syntaxGraphToFglGraph)
|
|
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
|
import Rendering(customLayoutParams)
|
|
import Icons(coloredTextBox)
|
|
|
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
|
|
|
prettyPrintSyntaxNode :: SyntaxNode -> String
|
|
-- TODO Re-enable
|
|
-- prettyPrintSyntaxNode (Embedder namedNodesAndEdges _)
|
|
-- = concatMap printNameAndEdge namedNodesAndEdges
|
|
-- where
|
|
-- printNameAndEdge (namedNode, edge)
|
|
-- = "(" ++ show namedNode ++ "," ++ printEdge edge ++ ")"
|
|
-- printEdge (Edge _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
|
|
prettyPrintSyntaxNode = show
|
|
|
|
renderFglGraph :: SpecialBackend b Double
|
|
=> FGR.Gr SgNamedNode e
|
|
-> IO (SpecialQDiagram b Double)
|
|
renderFglGraph fglGraph = do
|
|
layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
|
|
pure $ DiaGV.drawGraph
|
|
nodeFunc
|
|
--(\_ _ _ _ _ p -> lc white $ stroke p)
|
|
-- TODO Draw some type of arrow if point1 == point2
|
|
(\_ point1 _ point2 _ _ -> if point1 == point2
|
|
then mempty
|
|
else lcA (withOpacity white 0.7)
|
|
$ arrowBetween'
|
|
(shaftStyle %~ lwG 0.5 $ headLength .~ global 1.5 $ with)
|
|
(scaleFactor *^ point1)
|
|
(scaleFactor *^ point2))
|
|
(ING.nmap (fmap (fmap emNode)) layedOutGraph)
|
|
where
|
|
scaleFactor = 0.3
|
|
nodeFunc (Named name syntaxNode) point
|
|
= place (coloredTextBox
|
|
white
|
|
(opaque white)
|
|
(show name ++ prettyPrintSyntaxNode syntaxNode)
|
|
{- :: Diagram B -})
|
|
(scaleFactor *^ point)
|
|
layoutParams :: GV.GraphvizParams Int v e () v
|
|
layoutParams = customLayoutParams{
|
|
GV.fmtNode = nodeAttribute
|
|
}
|
|
nodeAttribute :: (Int, l) -> [GV.Attribute]
|
|
nodeAttribute _ =
|
|
-- GVA.Width and GVA.Height have a minimum of 0.01
|
|
--[GVA.Width diaWidth, GVA.Height diaHeight]
|
|
[GVA.Width 0.01, GVA.Height 0.01]
|
|
|
|
collapseTestStrings :: [String]
|
|
collapseTestStrings = [
|
|
"y = x",
|
|
"y = 1.0",
|
|
"y = f x",
|
|
"y = f x1 x2",
|
|
"y = f (g x)",
|
|
"y = g (\\x -> x)",
|
|
"y = f $ g (\\x -> x)",
|
|
"y = foo (3 + bazOf2) (8 * bazOf2) where bazOf2 = baz 2",
|
|
"Foo x = 1",
|
|
"Foo (Bar x) = 1",
|
|
"Foo 1 x = 2",
|
|
"Foo (Bar x) = f x",
|
|
"y x = case x of {Just w -> (let (z,_) = w in z)}"
|
|
]
|
|
|
|
makeCollapseTest :: SpecialBackend b Double => String -> IO (SpecialQDiagram b Double)
|
|
makeCollapseTest str = do
|
|
before <- renderFglGraph fglGraph
|
|
afterCollapse <- renderFglGraph (ING.nmap niVal collapsedGraph)
|
|
pure $ vsep 1 [
|
|
expressionText,
|
|
beforeText,
|
|
before,
|
|
afterText,
|
|
afterCollapse]
|
|
where
|
|
fglGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph str
|
|
collapsedGraph = collapseAnnotatedGraph $ annotateGraph fglGraph
|
|
customTextBox = coloredTextBox white (opaque lime)
|
|
expressionText = alignL $ coloredTextBox white (opaque yellow) str -- :: Diagram B
|
|
beforeText = alignL $ customTextBox "Before:" -- :: Diagram B
|
|
afterText = alignL $ customTextBox "After:" -- :: Diagram B
|
|
|
|
-- TODO Make this work for many input strings
|
|
visualCollapseTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
|
visualCollapseTests = do
|
|
drawings <- traverse makeCollapseTest collapseTestStrings
|
|
pure $ vsep 1 drawings
|