mirror of
https://github.com/rgleichman/glance.git
synced 2024-08-18 03:10:34 +03:00
Refactor GraphAlgorithms.hs.
This commit is contained in:
Robbie Gleichman
parent
b21ff534e8
commit
21e0091743
@ -8,6 +8,8 @@ module DrawingColors (
|
||||
|
||||
import Diagrams.Prelude hiding ((&), (#))
|
||||
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
-- COLO(U)RS --
|
||||
colorScheme :: ColorStyle Double
|
||||
colorScheme = colorOnBlackScheme
|
||||
|
||||
@ -1,65 +1,77 @@
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
module GraphAlgorithms(
|
||||
ParentType(..),
|
||||
collapseNodes,
|
||||
findTreeRoots,
|
||||
nodeWillBeEmbedded
|
||||
annotateGraph,
|
||||
collapseAnnotatedGraph
|
||||
) where
|
||||
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import Data.List(foldl', find)
|
||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||
--import qualified Debug.Trace
|
||||
import Data.Tuple(swap)
|
||||
|
||||
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
||||
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..))
|
||||
import Util(maybeBoolToBool, sgNamedNodeToSyntaxNode)
|
||||
--import Util(printSelf)
|
||||
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
|
||||
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
|
||||
import Util(sgNamedNodeToSyntaxNode)
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
|
||||
-- See graph_algs.txt for pseudocode
|
||||
|
||||
data ParentType = ApplyParent | CaseParent | MultiIfParent | NotAParent
|
||||
data ParentType = ApplyParent
|
||||
| CaseParent
|
||||
| MultiIfParent
|
||||
| NotAParent
|
||||
deriving (Eq, Show)
|
||||
|
||||
data DirectionalEdge a = ParentToChild a | ChildToParent a deriving (Eq, Show)
|
||||
-- Helper functions
|
||||
|
||||
-- START HELPER functions --
|
||||
parentAndChild :: EmbedDirection
|
||||
-> (a, a) -- ^ (from, to)
|
||||
-> (a, a) -- ^ (parent, child)
|
||||
parentAndChild embedDirection
|
||||
= case embedDirection of
|
||||
EdEmbedTo -> id
|
||||
EdEmbedFrom -> swap
|
||||
|
||||
-- TODO Replace with records.
|
||||
unwrapDirectionalEdge :: DirectionalEdge a -> a
|
||||
unwrapDirectionalEdge d = case d of
|
||||
ParentToChild e -> e
|
||||
ChildToParent e -> e
|
||||
-- End helper functions
|
||||
-- START annotateGraph --
|
||||
|
||||
-- | A syntaxNodeIsEmbeddable if it can be collapsed into another node
|
||||
syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Maybe Port -> Bool
|
||||
syntaxNodeIsEmbeddable parentType n mParentPort = case (parentType, n) of
|
||||
(ApplyParent, LikeApplyNode _ _) -> notResultPort
|
||||
(ApplyParent, LiteralNode _) -> notResultPort
|
||||
syntaxNodeIsEmbeddable :: ParentType
|
||||
-> SyntaxNode
|
||||
-> Maybe Port
|
||||
-> Maybe Port
|
||||
-> Bool
|
||||
syntaxNodeIsEmbeddable parentType n mParentPort _mChildPort
|
||||
= case (parentType, n) of
|
||||
(ApplyParent, LikeApplyNode _ _) -> parentPortNotResult
|
||||
(ApplyParent, LiteralNode _) -> parentPortNotResult
|
||||
-- TODO Embedded FunctionDefNodes are missing their enclosures.
|
||||
-- (ApplyParent, FunctionDefNode _ _)
|
||||
-- -> isInput mParentPort && isResult mChildPort
|
||||
|
||||
(CaseParent, LiteralNode _) -> notResultPort
|
||||
(CaseParent, LikeApplyNode _ _) -> notResultPort && notInputPort
|
||||
(CaseParent, NestedPatternApplyNode _ _) -> notResultPort && notInputPort
|
||||
(CaseParent, LiteralNode _) -> parentPortNotResult
|
||||
(CaseParent, LikeApplyNode _ _)
|
||||
-> parentPortNotResult && parentPortNotInput
|
||||
(CaseParent, NestedPatternApplyNode _ _)
|
||||
-> parentPortNotResult && parentPortNotInput
|
||||
|
||||
(MultiIfParent, LiteralNode _) -> notResultPort
|
||||
(MultiIfParent, LikeApplyNode _ _) -> notResultPort && notInputPort
|
||||
(MultiIfParent, LiteralNode _) -> parentPortNotResult
|
||||
(MultiIfParent, LikeApplyNode _ _)
|
||||
-> parentPortNotResult && parentPortNotInput
|
||||
|
||||
_ -> False
|
||||
_ -> False
|
||||
where
|
||||
notInputPort = case mParentPort of
|
||||
Just (Port 0) -> False
|
||||
_ -> True
|
||||
notResultPort = case mParentPort of
|
||||
-- TODO Don't use hardcoded port number
|
||||
Just (Port 1) -> False
|
||||
isInput mPort = case mPort of
|
||||
Just (Port 0) -> True
|
||||
_ -> False
|
||||
|
||||
isResult mPort = case mPort of
|
||||
Just (Port 1) -> True
|
||||
Just _ -> False
|
||||
_ -> True
|
||||
|
||||
|
||||
-- | A syntaxNodeCanEmbed if it can contain other nodes
|
||||
syntaxNodeCanEmbed :: SyntaxNode -> Bool
|
||||
syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode
|
||||
parentPortNotInput = not $ isInput mParentPort
|
||||
parentPortNotResult = not $ isResult mParentPort
|
||||
|
||||
parentTypeForNode :: SyntaxNode -> ParentType
|
||||
parentTypeForNode n = case n of
|
||||
@ -69,40 +81,80 @@ parentTypeForNode n = case n of
|
||||
MultiIfNode _ -> MultiIfParent
|
||||
NestedCaseOrMultiIfNode CaseTag _ _ -> CaseParent
|
||||
NestedCaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
|
||||
-- The NotAParent case should never occur.
|
||||
_ -> NotAParent
|
||||
|
||||
findNeighbors :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
|
||||
findNeighbors graph node = filter parentFilter $ ING.neighbors graph node where
|
||||
parentFilter parentNode = parentNode /= node
|
||||
|
||||
findParentsWithEdges :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
|
||||
findParentsWithEdges graph node = filter parentFilter adjacencies where
|
||||
parentFilter (_, parentNode) = parentNode /= node
|
||||
(incomingEdges, _, _, outgoingEdges) = ING.context graph node
|
||||
mappedIncomingEdges = fmap (Arrow.first ParentToChild) incomingEdges
|
||||
mappedOutgoingEdges = fmap (Arrow.first ChildToParent) outgoingEdges
|
||||
adjacencies = mappedIncomingEdges ++ mappedOutgoingEdges
|
||||
|
||||
-- | graphNodeCanEmbed returns true if the label (SyntaxNode) associated with
|
||||
-- the node can be embedded in other SyntaxNodes (i.e. nodeCanEmbed is True)
|
||||
graphNodeCanEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
|
||||
graphNodeCanEmbed graph node
|
||||
= maybeBoolToBool $ fmap syntaxNodeCanEmbed (lookupSyntaxNode graph node)
|
||||
|
||||
lookupSyntaxNode :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
|
||||
lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
|
||||
|
||||
lookupParentType :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ParentType
|
||||
lookupParentType graph node
|
||||
= fromMaybe NotAParent $ parentTypeForNode <$> lookupSyntaxNode graph node
|
||||
= maybe NotAParent parentTypeForNode $ lookupSyntaxNode graph node
|
||||
|
||||
-- | filterNodes returns a list of the nodes in the graph
|
||||
-- where the filter function is true.
|
||||
filterNodes :: ING.DynGraph gr => (ING.Node -> Bool) -> gr a b -> [ING.Node]
|
||||
filterNodes condition gr = ING.nodes $ ING.nfilter condition gr
|
||||
{-# ANN edgeIsSingular "HLint: ignore Redundant bracket" #-}
|
||||
edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
|
||||
edgeIsSingular graph node edge = numEdges <= 1 where
|
||||
(childNamePort, _) = edgeConnection edge
|
||||
edgeLabels = filter
|
||||
(childNamePort ==)
|
||||
((fst . edgeConnection . snd) <$> ING.lsuc graph node)
|
||||
numEdges = length edgeLabels
|
||||
|
||||
parentCanEmbedChild :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> ING.Node -> Edge -> EmbedDirection -> Bool
|
||||
parentCanEmbedChild graph parent child edge embedDirection
|
||||
= case lookupSyntaxNode graph child of
|
||||
Nothing -> False
|
||||
Just childSyntaxNode ->
|
||||
edgeIsSingular graph child edge
|
||||
&& syntaxNodeIsEmbeddable
|
||||
parentType
|
||||
childSyntaxNode
|
||||
parentPort
|
||||
childPort
|
||||
where
|
||||
parentType = lookupParentType graph parent
|
||||
(NameAndPort _ fromPort, NameAndPort _ toPort) = edgeConnection edge
|
||||
(parentPort, childPort)
|
||||
= parentAndChild embedDirection (fromPort, toPort)
|
||||
|
||||
findEmbedDir :: ING.Graph gr
|
||||
=> IngSyntaxGraph gr
|
||||
-> ING.Node
|
||||
-> ING.Node
|
||||
-> Edge
|
||||
-> Maybe EmbedDirection
|
||||
findEmbedDir gr fromNode toNode e = if
|
||||
| parentCanEmbedChild gr fromNode toNode e EdEmbedTo
|
||||
-> Just EdEmbedTo
|
||||
| parentCanEmbedChild gr toNode fromNode e EdEmbedFrom
|
||||
-> Just EdEmbedFrom
|
||||
| otherwise -> Nothing
|
||||
|
||||
annotateGraph :: ING.DynGraph gr => IngSyntaxGraph gr -> AnnotatedGraph gr
|
||||
annotateGraph gr = ING.gmap edgeMapper gr
|
||||
where
|
||||
edgeMapper :: ING.Context SgNamedNode Edge
|
||||
-> ING.Context SgNamedNode (EmbedInfo Edge)
|
||||
edgeMapper (inEdges, node, nodeLabel, outEdges)
|
||||
= (getInEmbedInfo node inEdges
|
||||
, node
|
||||
, nodeLabel
|
||||
, getOutEmbedInfo node outEdges)
|
||||
getInEmbedInfo toNode
|
||||
= fmap (\(e, fromNode)
|
||||
-> (EmbedInfo (findEmbedDir gr fromNode toNode e) e, fromNode))
|
||||
getOutEmbedInfo fromNode
|
||||
= fmap (\(e, toNode)
|
||||
-> (EmbedInfo (findEmbedDir gr fromNode toNode e) e, toNode))
|
||||
|
||||
-- END annotateGraph --
|
||||
-- START collapseAnnotatedGraph --
|
||||
|
||||
findEdgeLabel :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
|
||||
findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
|
||||
labelledEdges = ING.lneighbors graph node1
|
||||
matchingEdges = find ((== node2) . snd) labelledEdges
|
||||
|
||||
-- | Replace the a node's label
|
||||
changeNodeLabel :: ING.DynGraph gr => gr a b -> ING.Node -> a -> gr a b
|
||||
@ -111,194 +163,18 @@ changeNodeLabel graph node newLabel = case ING.match node graph of
|
||||
-> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
|
||||
(Nothing, _) -> graph
|
||||
|
||||
findEdgeLabel :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
|
||||
findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
|
||||
labelledEdges = ING.lneighbors graph node1
|
||||
matchingEdges = find ((== node2) . snd) labelledEdges
|
||||
|
||||
parentCanEmbedChild :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> ING.Node -> DirectionalEdge Edge -> Bool
|
||||
parentCanEmbedChild graph parent child directionalEdge
|
||||
= case lookupSyntaxNode graph child of
|
||||
Nothing -> False
|
||||
Just childSyntaxNode
|
||||
-> syntaxNodeIsEmbeddable parentType childSyntaxNode parentPort
|
||||
where
|
||||
parentType = lookupParentType graph parent
|
||||
parentPort = case directionalEdge of
|
||||
ParentToChild edge -> port where
|
||||
(NameAndPort _ port, _) = edgeConnection edge
|
||||
ChildToParent edge -> port where
|
||||
(_, NameAndPort _ port) = edgeConnection edge
|
||||
|
||||
findParentsThatCanEmbed :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
|
||||
findParentsThatCanEmbed graph child
|
||||
= filter parentFilter (findParentsWithEdges graph child)
|
||||
where
|
||||
parentFilter (directionalEdge, parentNode)
|
||||
= graphNodeCanEmbed graph parentNode
|
||||
&& parentCanEmbedChild graph parentNode child directionalEdge
|
||||
|
||||
-- | Finds the first edge from the first node to the second node
|
||||
findEdge :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
|
||||
findEdge graph fromNode toNode = lookup toNode $ ING.lsuc graph fromNode
|
||||
|
||||
edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
|
||||
edgeIsSingular graph node edge = numEdges == 1 where
|
||||
(childNamePort, _) = edgeConnection edge
|
||||
edgeLabels = filter
|
||||
(childNamePort ==)
|
||||
((fst . edgeConnection . snd) <$> ING.lsuc graph node)
|
||||
numEdges = length edgeLabels
|
||||
|
||||
parentIsOnlyEdge :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> ING.Node -> Bool
|
||||
parentIsOnlyEdge graph parent child = case findEdge graph child parent of
|
||||
Just edge -> edgeIsSingular graph child edge
|
||||
Nothing -> case findEdge graph parent child of
|
||||
Just edge -> edgeIsSingular graph parent edge
|
||||
Nothing
|
||||
-> error
|
||||
"parentIsOnlyEdge: There is no edge from the child to the parent."
|
||||
|
||||
findParentThatWillEmbed :: ING.Graph gr =>
|
||||
IngSyntaxGraph gr -> ING.Node -> Maybe (DirectionalEdge Edge, ING.Node)
|
||||
findParentThatWillEmbed graph child =
|
||||
case findParentsThatCanEmbed graph child of
|
||||
[parent] -> if parentIsOnlyEdge graph (snd parent) child
|
||||
then Just parent
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
-- END helper functions --
|
||||
|
||||
collapseNodes :: (ING.DynGraph gr) => IngSyntaxGraph gr -> IngSyntaxGraph gr
|
||||
collapseNodes originalGraph = finalGraph where
|
||||
-- findTreeRoots returns a list of nodes that will embed other nodes, but are
|
||||
-- not embedded themselves.
|
||||
-- These nodes are thus each a root of a collapsed node tree.
|
||||
treeRoots = findTreeRoots originalGraph
|
||||
-- Now collapse each tree of nodes
|
||||
finalGraph = collapseRoots originalGraph originalGraph treeRoots
|
||||
|
||||
-- START findTreeRoots functions --
|
||||
|
||||
-- | findTreeRoots returns a list of nodes that might embed other nodes, but are
|
||||
-- not embedded themselves.
|
||||
-- These nodes are thus each a root of a collapsed node tree.
|
||||
-- A node is a treeRoot if all of these conditions are true:
|
||||
-- 1. The SyntaxNode can embed other nodes (i.e. syntaxNodeCanEmbed is true)
|
||||
-- 2. The node will not be embedded.
|
||||
-- Note: A treeRoot may not actually have any embeddable children, since
|
||||
-- collapseTree will do nothing in that case.
|
||||
findTreeRoots :: ING.DynGraph gr => IngSyntaxGraph gr -> [ING.Node]
|
||||
findTreeRoots graph = filterNodes isTreeRoot graph where
|
||||
isTreeRoot node
|
||||
= graphNodeCanEmbed graph node && not (nodeWillBeEmbedded graph node)
|
||||
|
||||
nodeWillBeEmbedded :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
|
||||
nodeWillBeEmbedded graph node = isJust $ findParentThatWillEmbed graph node
|
||||
|
||||
-- END findTreeRoots functions
|
||||
-- START collapseRoots functions
|
||||
|
||||
collapseRoots :: ING.DynGraph gr =>
|
||||
IngSyntaxGraph gr -> IngSyntaxGraph gr -> [ING.Node] -> IngSyntaxGraph gr
|
||||
collapseRoots originalGraph = foldl' (collapseTree originalGraph)
|
||||
|
||||
collapseTree :: ING.DynGraph gr =>
|
||||
IngSyntaxGraph gr -> IngSyntaxGraph gr -> ING.Node -> IngSyntaxGraph gr
|
||||
collapseTree originalGraph oldGraph rootNode = case childrenToEmbed of
|
||||
[] -> oldGraph
|
||||
_ -> finalGraph
|
||||
where
|
||||
-- Need to use the original graph for finding children, otherwise a node can
|
||||
-- be embedded when it is used twice in what will be a single embedding
|
||||
-- node.
|
||||
-- Examples:
|
||||
-- "y = foo (3 + bazOf2) bazOf2 where bazOf2 = baz 2",
|
||||
-- "y = foo (3 + bazOf2) (8 * bazOf2) where bazOf2 = baz 2"
|
||||
childrenToEmbedWithEdges = findChildrenToEmbed rootNode originalGraph
|
||||
childrenToEmbed = fmap snd childrenToEmbedWithEdges
|
||||
-- Recursively collapse the children nodes
|
||||
graphWithCollapsedChildren
|
||||
= collapseRoots originalGraph oldGraph childrenToEmbed
|
||||
-- Modify the rootNode label (i.e. SyntaxNode) to incorporate the children
|
||||
-- it is embedding.
|
||||
graphWithEmbeddedChildren = embedChildSyntaxNodes
|
||||
rootNode
|
||||
childrenToEmbed
|
||||
graphWithCollapsedChildren
|
||||
-- Transfer the edges of the children to rootNode.
|
||||
childEdgesToTransfer = findChildEdgesToTransfer
|
||||
rootNode
|
||||
childrenToEmbedWithEdges
|
||||
graphWithEmbeddedChildren
|
||||
graphWithEdgesTransferred
|
||||
= ING.insEdges childEdgesToTransfer graphWithEmbeddedChildren
|
||||
-- Delete the children that have been embedded (and any or their remaining
|
||||
-- edges).
|
||||
finalGraph = deleteChildren childrenToEmbed graphWithEdgesTransferred
|
||||
|
||||
-- | findChildrenToEmbed returns a list of the node's children that can be
|
||||
-- embedded.
|
||||
-- A child can be embedded iff all of these conditions are true:
|
||||
-- 1. The node is not a treeRoot (otherwise a cycle of embedding could occur).
|
||||
-- 2. The SyntaxNode is embeddable (i.e. syntaxNodeIsEmbeddable is True).
|
||||
-- 3. The node has exactly one parent that can embed (i.e. nodeCanEmbed is True
|
||||
-- for one parent).
|
||||
findChildrenToEmbed :: ING.Graph gr =>
|
||||
ING.Node -> IngSyntaxGraph gr -> ING.Adj (DirectionalEdge Edge)
|
||||
findChildrenToEmbed node graph = if graphNodeCanEmbed graph node
|
||||
then childrenToEmbed
|
||||
else []
|
||||
where
|
||||
childrenToEmbed =
|
||||
catMaybes
|
||||
$ fmap (childCanBeEmbedded node graph) (findNeighbors graph node)
|
||||
|
||||
childCanBeEmbedded :: ING.Graph gr =>
|
||||
ING.Node
|
||||
-> IngSyntaxGraph gr
|
||||
-> ING.Node
|
||||
-> Maybe (DirectionalEdge Edge, ING.Node)
|
||||
childCanBeEmbedded parentNode graph child = case
|
||||
findParentThatWillEmbed graph child of
|
||||
Nothing -> Nothing
|
||||
Just (edge, childsParent) -> if childsParent == parentNode
|
||||
then Just (edge, child)
|
||||
else Nothing
|
||||
|
||||
edgesNotEqual :: Eq b => DirectionalEdge b -> ING.LEdge b -> Bool
|
||||
edgesNotEqual dirEdge (_, _, e) = e /= unwrapDirectionalEdge dirEdge
|
||||
|
||||
findChildEdgesToTransfer :: (Eq b, ING.Graph gr) =>
|
||||
ING.Node -> ING.Adj (DirectionalEdge b) -> gr a b-> [ING.LEdge b]
|
||||
findChildEdgesToTransfer parentNode childrenToEmbed graph
|
||||
= concatMap makeLabelledGraphEdges childrenToEmbed
|
||||
where
|
||||
makeLabelledGraphEdges (directionalParentToChildEdge, childNode)
|
||||
= changeEdgeToParent parentNode childNode
|
||||
<$> filter
|
||||
(edgesNotEqual directionalParentToChildEdge)
|
||||
(ING.inn graph childNode ++ ING.out graph childNode)
|
||||
|
||||
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
|
||||
changeEdgeToParent parentNode childNode lEdge@(fromNode, toNode, edgeLabel)
|
||||
| childNode == fromNode = (parentNode, toNode, edgeLabel)
|
||||
| childNode == toNode = (fromNode, parentNode, edgeLabel)
|
||||
| otherwise = lEdge
|
||||
|
||||
-- | Change the node label of the parent to be nested.
|
||||
embedChildSyntaxNodes :: ING.DynGraph gr =>
|
||||
ING.Node -> [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
|
||||
embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
|
||||
[] -> oldGraph
|
||||
_ -> newGraph
|
||||
embedChildSyntaxNode :: ING.DynGraph gr =>
|
||||
ING.Node -> ING.Node -> AnnotatedGraph gr -> AnnotatedGraph gr
|
||||
embedChildSyntaxNode parentNode childNode oldGraph = newGraph
|
||||
where
|
||||
maybeOldNodeLabel = ING.lab oldGraph parentNode
|
||||
newGraph = case maybeOldNodeLabel of
|
||||
mChildAndEdge =
|
||||
(,) <$> ING.lab oldGraph childNode
|
||||
<*> findEdgeLabel oldGraph parentNode childNode
|
||||
childrenAndEdgesToParent = case mChildAndEdge of
|
||||
Nothing -> []
|
||||
Just childAndEdge -> [Arrow.second eiVal childAndEdge]
|
||||
newGraph = case ING.lab oldGraph parentNode of
|
||||
Nothing -> oldGraph
|
||||
Just oldNodeLabel -> changeNodeLabel oldGraph parentNode newNodeLabel
|
||||
where
|
||||
@ -307,19 +183,50 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
|
||||
newSyntaxNode = case oldSyntaxNode of
|
||||
LikeApplyNode flavor x
|
||||
-> NestedApplyNode flavor x childrenAndEdgesToParent
|
||||
NestedApplyNode flavor x existingNodes
|
||||
-> NestedApplyNode flavor x
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
CaseNode x
|
||||
-> NestedCaseOrMultiIfNode CaseTag x childrenAndEdgesToParent
|
||||
NestedCaseOrMultiIfNode tag x existingNodes
|
||||
-> NestedCaseOrMultiIfNode tag x
|
||||
(childrenAndEdgesToParent <> existingNodes)
|
||||
MultiIfNode x
|
||||
-> NestedCaseOrMultiIfNode MultiIfTag x childrenAndEdgesToParent
|
||||
_ -> oldSyntaxNode
|
||||
childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
|
||||
findChildAndEdge childNode =
|
||||
(,) <$> ING.lab oldGraph childNode
|
||||
<*> findEdgeLabel oldGraph parentNode childNode
|
||||
|
||||
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
|
||||
changeEdgeToParent parentNode childNode (fromNode, toNode, lab)
|
||||
= (toParent fromNode, toParent toNode, lab)
|
||||
where
|
||||
toParent node = if node == childNode then parentNode else node
|
||||
|
||||
collapseEdge :: ING.DynGraph gr
|
||||
=> AnnotatedGraph gr
|
||||
-> ING.LEdge (EmbedInfo Edge)
|
||||
-> AnnotatedGraph gr
|
||||
collapseEdge oldGraph (fromNode, toNode, e@(EmbedInfo mEmbedDir _))
|
||||
= case mEmbedDir of
|
||||
Nothing -> oldGraph
|
||||
Just embedDir -> childDeletedGraph
|
||||
where
|
||||
(parentNode, childNode) = parentAndChild embedDir (fromNode, toNode)
|
||||
childEmbeddedGraph
|
||||
= embedChildSyntaxNode parentNode childNode oldGraph
|
||||
childEdgesToTransfer
|
||||
= changeEdgeToParent parentNode childNode
|
||||
<$> filter
|
||||
(\(_, _, edge) -> edge /= e)
|
||||
(ING.inn oldGraph childNode <> ING.out oldGraph childNode)
|
||||
graphWithEdgesTransferred
|
||||
= ING.insEdges childEdgesToTransfer childEmbeddedGraph
|
||||
childDeletedGraph = ING.delNode childNode graphWithEdgesTransferred
|
||||
|
||||
|
||||
deleteChildren :: ING.Graph gr =>
|
||||
[ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
|
||||
deleteChildren = ING.delNodes
|
||||
|
||||
-- END collapseRoots functions
|
||||
collapseAnnotatedGraph :: ING.DynGraph gr
|
||||
=> AnnotatedGraph gr
|
||||
-> AnnotatedGraph gr
|
||||
collapseAnnotatedGraph origGraph = newGraph
|
||||
where
|
||||
-- TODO Check that there are no embedded edges left.
|
||||
newGraph = foldl' collapseEdge origGraph (ING.labEdges origGraph)
|
||||
|
||||
@ -36,6 +36,7 @@ import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
|
||||
import DrawingColors(colorScheme, ColorStyle(..))
|
||||
|
||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
-- TYPES --
|
||||
|
||||
@ -646,7 +647,7 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
|
||||
-- 2,3.. : The parameters
|
||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||
flatLambda paramNames (TransformParams name _ reflect angle)
|
||||
= named name finalDia
|
||||
= centerXY $ named name finalDia
|
||||
where
|
||||
lambdaCircle
|
||||
= lwG defaultLineWidth
|
||||
|
||||
@ -23,6 +23,8 @@ import Rendering(renderIngSyntaxGraph)
|
||||
import Translate(translateModuleToCollapsedGraphs)
|
||||
import Util(customRenderSVG)
|
||||
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
data CmdLineOptions = CmdLineOptions {
|
||||
cmdInputFilename :: String,
|
||||
cmdOutputFilename :: String,
|
||||
@ -60,7 +62,7 @@ renderFile (CmdLineOptions
|
||||
--print "\n\n"
|
||||
--print drawings
|
||||
|
||||
diagrams <- traverse renderIngSyntaxGraph drawings
|
||||
diagrams <- traverse (renderIngSyntaxGraph "") drawings
|
||||
let
|
||||
commentsInBoxes
|
||||
= fmap
|
||||
|
||||
138
app/Rendering.hs
138
app/Rendering.hs
@ -7,7 +7,7 @@ module Rendering (
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
||||
, arrowTail, noHead, arrowHead, scale, r2, bezier3
|
||||
, arrowTail, arrowHead, scale, r2, bezier3
|
||||
, fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
|
||||
, TrailLike, V, height, width, (*^), reflectX, rotate
|
||||
, centerXY, place
|
||||
@ -27,19 +27,19 @@ import Data.Function(on)
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||
import Data.List(find, minimumBy)
|
||||
import Data.Maybe(fromMaybe)
|
||||
import Data.Maybe(isNothing, fromMaybe)
|
||||
import Data.Typeable(Typeable)
|
||||
|
||||
--import qualified Data.GraphViz.Types
|
||||
--import Data.GraphViz.Commands
|
||||
--import qualified Debug.Trace
|
||||
|
||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
|
||||
, getPortAngles, TransformParams(..), circleRadius)
|
||||
import TranslateCore(nodeToIcon)
|
||||
import Types(Edge(..), EdgeOption(..), Drawing(..), EdgeEnd(..), NameAndPort(..)
|
||||
import Types(EmbedInfo(..), AnnotatedGraph, Edge(..)
|
||||
, Drawing(..), NameAndPort(..)
|
||||
, SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..)
|
||||
, Port(..), SgNamedNode, NamedIcon(..), Icon(..))
|
||||
, Port(..), NamedIcon(..), Icon(..))
|
||||
|
||||
import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
|
||||
|
||||
@ -66,12 +66,16 @@ drawingToGraphvizScaleFactor = 0.15
|
||||
|
||||
-- TODO Refactor with syntaxGraphToFglGraph in TranslateCore
|
||||
-- TODO Make this work with nested icons now that names are not qualified.
|
||||
drawingToIconGraph :: Drawing -> Gr NamedIcon Edge
|
||||
drawingToIconGraph :: Drawing -> Gr NamedIcon (EmbedInfo Edge)
|
||||
drawingToIconGraph (Drawing nodes edges) =
|
||||
mkGraph nodes labeledEdges where
|
||||
labeledEdges = fmap makeLabeledEdge edges
|
||||
makeLabeledEdge e@(Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) =
|
||||
(NamedIcon n1 (lookupInNodes n1), NamedIcon n2 (lookupInNodes n2), e)
|
||||
|
||||
makeLabeledEdge :: Edge -> (NamedIcon, NamedIcon, EmbedInfo Edge)
|
||||
makeLabeledEdge e@(Edge _ (NameAndPort n1 _, NameAndPort n2 _))
|
||||
= (NamedIcon n1 (lookupInNodes n1)
|
||||
, NamedIcon n2 (lookupInNodes n2)
|
||||
, EmbedInfo Nothing e)
|
||||
where
|
||||
lookupInNodes name = fromMaybeError
|
||||
errorString
|
||||
@ -91,47 +95,39 @@ bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where
|
||||
c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x
|
||||
|
||||
getArrowOpts :: (RealFloat n, Typeable n) =>
|
||||
(EdgeEnd, EdgeEnd)
|
||||
-> [EdgeOption]
|
||||
-> (Angle n, Angle n)
|
||||
(Angle n, Angle n)
|
||||
-> NameAndPort
|
||||
-> (ArrowOpts n, DIA.Colour Double)
|
||||
getArrowOpts (t, h)
|
||||
_
|
||||
getArrowOpts
|
||||
(fromAngle, toAngle)
|
||||
(NameAndPort (NodeName nodeNum) mPort)
|
||||
= (arrowOptions, shaftColor)
|
||||
where
|
||||
-- shaftColor = if EdgeInPattern `elem` opts
|
||||
-- then patternC colorScheme
|
||||
-- else hashedColor
|
||||
shaftColor = hashedColor
|
||||
|
||||
edgeColors = edgeListC colorScheme
|
||||
numEdgeColors = length edgeColors
|
||||
hashedColor = edgeColors !! namePortHash
|
||||
namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
|
||||
Port portNum = fromMaybe (Port 0) mPort
|
||||
|
||||
lookupTail EndNone = id
|
||||
|
||||
lookupHead EndNone = id
|
||||
|
||||
namePortHash = mod (portNum + (503 * nodeNum)) (length edgeColors)
|
||||
shaftColor = edgeColors !! namePortHash
|
||||
arrowOptions =
|
||||
arrowHead .~ noHead $
|
||||
arrowTail .~ noTail $
|
||||
arrowShaft .~ bezierShaft fromAngle toAngle $
|
||||
lengths .~ global 0.75 $
|
||||
lookupHead h $ lookupTail t with
|
||||
arrowHead .~ DIA.noHead
|
||||
-- arrowHead .~ DIA.tri
|
||||
$ DIA.headStyle %~ DIA.fc shaftColor
|
||||
$ arrowTail .~ noTail
|
||||
$ arrowShaft .~ bezierShaft fromAngle toAngle
|
||||
-- TODO Don't use a magic number for lengths (headLength and tailLength)
|
||||
$ lengths .~ global 0.5
|
||||
$ with
|
||||
|
||||
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||
connectMaybePorts :: SpecialBackend b n =>
|
||||
(Angle n, Angle n)-> Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
|
||||
(Angle n, Angle n)
|
||||
-> EmbedInfo Edge
|
||||
-> SpecialQDiagram b n
|
||||
-> SpecialQDiagram b n
|
||||
connectMaybePorts portAngles
|
||||
(Edge
|
||||
opts
|
||||
ends
|
||||
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2))
|
||||
(EmbedInfo embedDir
|
||||
(Edge
|
||||
_
|
||||
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)))
|
||||
-- In order to give arrows a "shadow" effect, draw a thicker semi-transparent
|
||||
-- line shaft the same color as the background underneath the normal line
|
||||
-- shaft.
|
||||
@ -139,8 +135,10 @@ connectMaybePorts portAngles
|
||||
. connectFunc arrOptsShadow qPort0 qPort1
|
||||
where
|
||||
lineWidth = 2 * defaultLineWidth
|
||||
(baseArrOpts, shaftCol) = getArrowOpts ends opts portAngles fromNamePort
|
||||
normalOpts = (shaftStyle %~ (lwG lineWidth . lc shaftCol))
|
||||
(baseArrOpts, shaftCol) = getArrowOpts portAngles fromNamePort
|
||||
-- TODO Use a color from the color scheme for un-embedded shafts.
|
||||
shaftCol' = if isNothing embedDir then shaftCol else DIA.lime
|
||||
normalOpts = (shaftStyle %~ (lwG lineWidth . lc shaftCol'))
|
||||
baseArrOpts
|
||||
arrOptsShadow = (shaftStyle
|
||||
%~ (lwG (1.9 * lineWidth)
|
||||
@ -218,14 +216,15 @@ lookupNodeAngle rotationMap key
|
||||
$ lookup key rotationMap
|
||||
|
||||
makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr NamedIcon Edge
|
||||
String -- ^ Debugging information
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
-> ING.LEdge Edge
|
||||
-> ING.LEdge (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> SpecialQDiagram b n
|
||||
makeEdge graph dia rotationMap
|
||||
(node0, node1, edge@(Edge _ _ (namePort0, namePort1)))
|
||||
makeEdge debugInfo graph dia rotationMap
|
||||
(node0, node1, edge@(EmbedInfo _ (Edge _ (namePort0, namePort1))))
|
||||
= connectMaybePorts portAngles edge
|
||||
where
|
||||
node0label = fromMaybeError
|
||||
@ -257,10 +256,12 @@ makeEdge graph dia rotationMap
|
||||
|
||||
getPortPoint n = case foundPoints of
|
||||
[point] -> point
|
||||
_ -> error $ "Multiple points with named: " <> show n
|
||||
_ -> error $ "Multiple points. Debug info: " <> debugInfo
|
||||
<> "\nn: " <> show n
|
||||
where
|
||||
foundPoints = fromMaybeError
|
||||
( "makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: "
|
||||
( "makeEdge: port not found. Debug info: " <> debugInfo
|
||||
<> "\nPort: " ++ show n ++ "\nValid ports: "
|
||||
++ show diaNodeNamePointMap)
|
||||
(lookup n diaNodeNamePointMap)
|
||||
|
||||
@ -268,13 +269,14 @@ makeEdge graph dia rotationMap
|
||||
|
||||
-- | addEdges draws the edges underneath the nodes.
|
||||
addEdges :: (SpecialBackend b n, ING.Graph gr) =>
|
||||
gr NamedIcon Edge
|
||||
String -- ^ Debugging information
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> SpecialQDiagram b n
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
-> SpecialQDiagram b n
|
||||
addEdges graph dia rotationMap = applyAll connections dia
|
||||
addEdges debugInfo graph dia rotationMap = applyAll connections dia
|
||||
where
|
||||
connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
|
||||
connections = makeEdge debugInfo graph dia rotationMap <$> ING.labEdges graph
|
||||
|
||||
-- BEGIN rotateNodes --
|
||||
|
||||
@ -296,7 +298,7 @@ scoreAngle iconPosition edges reflected angle
|
||||
|
||||
bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> NamedIcon
|
||||
-> Bool
|
||||
-> (Angle n, n)
|
||||
@ -322,16 +324,16 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
||||
portAngles = findPortAngles key nameAndPort
|
||||
|
||||
-- Edge points from id to otherNode
|
||||
getSucEdge (otherNode, edge) = (otherNode, nameAndPort) where
|
||||
getSucEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
|
||||
(nameAndPort, _) = edgeConnection edge
|
||||
|
||||
-- Edge points from otherNode to id
|
||||
getPreEdge (otherNode, edge) = (otherNode, nameAndPort) where
|
||||
getPreEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
|
||||
(_, nameAndPort) = edgeConnection edge
|
||||
|
||||
findIconRotation :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> NamedIcon
|
||||
-> (NamedIcon, (Bool, Angle n))
|
||||
findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
@ -344,7 +346,7 @@ findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
||||
|
||||
rotateNodes :: (SpecialNum n, ING.Graph gr) =>
|
||||
Map.Map NamedIcon (Point V2 n)
|
||||
-> gr NamedIcon Edge
|
||||
-> gr NamedIcon (EmbedInfo Edge)
|
||||
-> [(NamedIcon, (Bool, Angle n))]
|
||||
rotateNodes positionMap graph
|
||||
= findIconRotation positionMap graph <$> Map.keys positionMap
|
||||
@ -362,8 +364,8 @@ drawLambdaRegions placedNodes
|
||||
where
|
||||
enclosedDias = fmap findDia enclosedNames
|
||||
findDia n1
|
||||
= fromMaybe mempty
|
||||
$ snd <$> find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes
|
||||
= maybe mempty snd
|
||||
(find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes)
|
||||
drawRegion _ = mempty
|
||||
|
||||
-- TODO Use something better than a rectangle
|
||||
@ -414,11 +416,12 @@ customLayoutParams = GV.defaultParams{
|
||||
GV.fmtEdge = const [GV.arrowTo GV.noArrow]
|
||||
}
|
||||
|
||||
doGraphLayout :: forall b.
|
||||
renderIconGraph :: forall b.
|
||||
SpecialBackend b Double =>
|
||||
Gr NamedIcon Edge
|
||||
String -- ^ Debugging information
|
||||
-> Gr NamedIcon (EmbedInfo Edge)
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
doGraphLayout graph = do
|
||||
renderIconGraph debugInfo graph = do
|
||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||
let
|
||||
@ -426,7 +429,7 @@ doGraphLayout graph = do
|
||||
rotationMap = rotateNodes positionMap graph
|
||||
placedNodeList = placeNodes positionMap rotationMap
|
||||
placedNodes = mconcat $ fmap snd placedNodeList
|
||||
edges = addEdges graph placedNodes rotationMap
|
||||
edges = addEdges debugInfo graph placedNodes rotationMap
|
||||
placedRegions = drawLambdaRegions placedNodeList
|
||||
pure (placedNodes <> edges <> placedRegions)
|
||||
where
|
||||
@ -459,17 +462,14 @@ doGraphLayout graph = do
|
||||
|
||||
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
||||
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
||||
renderDrawing ::
|
||||
SpecialBackend b Double =>
|
||||
Drawing -> IO (SpecialQDiagram b Double)
|
||||
renderDrawing = renderIconGraph . drawingToIconGraph
|
||||
renderDrawing :: SpecialBackend b Double
|
||||
=> String -- ^ Debugging information
|
||||
-> Drawing
|
||||
-> IO (SpecialQDiagram b Double)
|
||||
renderDrawing debugInfo = renderIconGraph debugInfo . drawingToIconGraph
|
||||
|
||||
renderIngSyntaxGraph ::
|
||||
SpecialBackend b Double =>
|
||||
Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph
|
||||
= renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
|
||||
|
||||
renderIconGraph :: SpecialBackend b Double
|
||||
=> Gr NamedIcon Edge -> IO (SpecialQDiagram b Double)
|
||||
renderIconGraph = doGraphLayout
|
||||
String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
|
||||
renderIngSyntaxGraph debugInfo gr
|
||||
= renderIconGraph debugInfo $ ING.nmap (mapNodeInNamedNode nodeToIcon) gr
|
||||
|
||||
@ -18,7 +18,7 @@ import Data.Maybe(catMaybes, fromMaybe)
|
||||
import qualified Language.Haskell.Exts as Exts
|
||||
import qualified Language.Haskell.Exts.Pretty as PExts
|
||||
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||
casePatternPorts)
|
||||
import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..)
|
||||
@ -32,8 +32,8 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..)
|
||||
, deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph
|
||||
, getUniqueString, bindsToSyntaxGraph, SgBind(..)
|
||||
, graphAndRefToGraph, initialIdState)
|
||||
import Types(Labeled(..), NameAndPort(..), IDState,
|
||||
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
||||
import Types(AnnotatedGraph, Labeled(..), NameAndPort(..), IDState,
|
||||
Edge, SyntaxNode(..), NodeName, SgNamedNode(..),
|
||||
LikeApplyFlavor(..))
|
||||
import Util(makeSimpleEdge, nameAndPort, justName)
|
||||
|
||||
@ -643,22 +643,24 @@ translateDeclToSyntaxGraph d = graph where
|
||||
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
||||
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
|
||||
|
||||
syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
|
||||
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
|
||||
syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr
|
||||
syntaxGraphToCollapsedGraph
|
||||
= collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph
|
||||
-- = annotateGraph . syntaxGraphToFglGraph
|
||||
|
||||
translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> IngSyntaxGraph FGR.Gr
|
||||
translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> AnnotatedGraph FGR.Gr
|
||||
translateDeclToCollapsedGraph
|
||||
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
|
||||
|
||||
-- Profiling: At one point, this was about 1.5% of total time.
|
||||
translateStringToCollapsedGraphAndDecl ::
|
||||
String -> (IngSyntaxGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
|
||||
String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
|
||||
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
||||
decl = customParseDecl s -- :: ParseResult Module
|
||||
drawing = translateDeclToCollapsedGraph decl
|
||||
|
||||
translateModuleToCollapsedGraphs :: Show l =>
|
||||
Exts.Module l -> [IngSyntaxGraph FGR.Gr]
|
||||
Exts.Module l -> [AnnotatedGraph FGR.Gr]
|
||||
translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls)
|
||||
= fmap translateDeclToCollapsedGraph decls
|
||||
translateModuleToCollapsedGraphs moduleSyntax
|
||||
|
||||
@ -41,7 +41,7 @@ import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..)
|
||||
, NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port
|
||||
, LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..)
|
||||
, NamedIcon(..))
|
||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
|
||||
import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
|
||||
, mapNodeInNamedNode, nodeNameToInt)
|
||||
|
||||
{-# ANN module "HLint: ignore Use list comprehension" #-}
|
||||
@ -150,7 +150,7 @@ edgesForRefPortList inPattern portExpPairs
|
||||
Left str -> if inPattern
|
||||
then bindsToSyntaxGraph [SgBind str (Right port)]
|
||||
else sinksToSyntaxGraph [SgSink str port]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection]
|
||||
where
|
||||
connection = if inPattern
|
||||
-- If in a pattern, then the port on the case icon is
|
||||
@ -167,7 +167,7 @@ combineExpressions inPattern portExpPairs
|
||||
Left str -> if inPattern
|
||||
then bindsToSyntaxGraph [SgBind str (Right port)]
|
||||
else sinksToSyntaxGraph [SgSink str port]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)]
|
||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)]
|
||||
|
||||
makeApplyGraph ::
|
||||
Int
|
||||
@ -335,7 +335,7 @@ nestedPatternNodeToIcon str children = NestedPApp
|
||||
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
||||
findArg currentPort
|
||||
(SgNamedNode argName _
|
||||
, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
, Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
|
||||
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
||||
| otherwise = False -- This case should never happen
|
||||
@ -357,7 +357,7 @@ syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
|
||||
ING.mkGraph (fmap makeLNode nodes) labeledEdges where
|
||||
labeledEdges = fmap makeLabeledEdge edges
|
||||
|
||||
makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) =
|
||||
makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) =
|
||||
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap
|
||||
, nodeNameToInt $ lookupInEmbeddingMap name2 eMap
|
||||
, e)
|
||||
|
||||
25
app/Types.hs
25
app/Types.hs
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
|
||||
module Types (
|
||||
NamedIcon(..),
|
||||
@ -10,7 +11,6 @@ module Types (
|
||||
Connection,
|
||||
Edge(..),
|
||||
EdgeOption(..),
|
||||
EdgeEnd(..),
|
||||
Drawing(..),
|
||||
IDState(..),
|
||||
SpecialQDiagram,
|
||||
@ -20,7 +20,10 @@ module Types (
|
||||
IngSyntaxGraph,
|
||||
LikeApplyFlavor(..),
|
||||
CaseOrMultiIfTag(..),
|
||||
Labeled(..)
|
||||
Labeled(..),
|
||||
EmbedDirection(..),
|
||||
EmbedInfo(..),
|
||||
AnnotatedGraph,
|
||||
) where
|
||||
|
||||
import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
|
||||
@ -84,6 +87,7 @@ data SyntaxNode =
|
||||
-- Function application, composition, and applying to a composition
|
||||
LikeApplyNode LikeApplyFlavor Int
|
||||
-- NestedApplyNode is only created in GraphAlgorithms, not during translation.
|
||||
-- The list of nodes is unordered (replace with a map?)
|
||||
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
||||
| NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
|
||||
| NameNode String -- Identifiers or symbols
|
||||
@ -106,15 +110,13 @@ data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord)
|
||||
|
||||
type Connection = (NameAndPort, NameAndPort)
|
||||
|
||||
-- TODO Consider removing EdgeOption and EdgeEnd since they are unused.
|
||||
-- TODO Consider removing EdgeOption since it's unused.
|
||||
data EdgeOption = EdgeInPattern deriving (Show, Eq, Ord)
|
||||
|
||||
data EdgeEnd = EndNone deriving (Show, Eq, Ord)
|
||||
|
||||
-- | An Edge has an name of the source icon, and its optional port number,
|
||||
-- and the name of the destination icon, and its optional port number.
|
||||
data Edge = Edge { edgeOptions :: [EdgeOption]
|
||||
, edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
|
||||
, edgeConnection :: Connection}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | A drawing is a map from names to Icons, a list of edges,
|
||||
@ -135,3 +137,14 @@ type SpecialBackend b n
|
||||
type SpecialQDiagram b n = QDiagram b V2 n Any
|
||||
|
||||
type IngSyntaxGraph gr = gr SgNamedNode Edge
|
||||
|
||||
data EmbedDirection =
|
||||
EdEmbedFrom -- The tail
|
||||
| EdEmbedTo -- The head
|
||||
deriving (Show, Eq)
|
||||
|
||||
-- A Nothing eiEmbedDir means the edge is not embedded.
|
||||
data EmbedInfo a = EmbedInfo {eiEmbedDir :: Maybe EmbedDirection, eiVal :: a}
|
||||
deriving (Show, Eq, Functor)
|
||||
|
||||
type AnnotatedGraph gr = gr SgNamedNode (EmbedInfo Edge)
|
||||
|
||||
@ -4,7 +4,6 @@ module Util (
|
||||
printSelf,
|
||||
iconToPort,
|
||||
makeSimpleEdge,
|
||||
noEnds,
|
||||
nameAndPort,
|
||||
justName,
|
||||
fromMaybeError,
|
||||
@ -26,14 +25,11 @@ import Data.Text(pack)
|
||||
import Data.Typeable(Typeable)
|
||||
import qualified Debug.Trace
|
||||
|
||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..)
|
||||
import Types(Edge(..), NameAndPort(..), Connection, NodeName(..)
|
||||
, Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
||||
|
||||
noEnds :: (EdgeEnd, EdgeEnd)
|
||||
noEnds = (EndNone, EndNone)
|
||||
|
||||
makeSimpleEdge :: Connection -> Edge
|
||||
makeSimpleEdge = Edge [] noEnds
|
||||
makeSimpleEdge = Edge []
|
||||
|
||||
nameAndPort :: NodeName -> Port -> NameAndPort
|
||||
nameAndPort n p = NameAndPort n (Just p)
|
||||
|
||||
@ -14,6 +14,7 @@ import VisualGraphAlgorithmTests(visualCollapseTests)
|
||||
import VisualRenderingTests(renderTests)
|
||||
import VisualTranslateTests(visualTranslateTests)
|
||||
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
drawingsAndNames :: [(String, IO (Diagram B))]
|
||||
drawingsAndNames = [
|
||||
|
||||
@ -4,16 +4,12 @@ module UnitTests(
|
||||
|
||||
import Test.HUnit
|
||||
|
||||
import qualified Data.Graph.Inductive.Graph as ING
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
|
||||
import Data.List(foldl', sort, sortOn)
|
||||
|
||||
import Translate(translateStringToSyntaxGraph)
|
||||
import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..))
|
||||
import TranslateCore(SyntaxGraph(..), SgBind(..))
|
||||
import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..),
|
||||
IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..))
|
||||
import qualified GraphAlgorithms
|
||||
NodeName(..), NameAndPort(..))
|
||||
import Util(fromMaybeError)
|
||||
|
||||
-- Unit Test Helpers --
|
||||
@ -75,8 +71,8 @@ renameNamePort nameMap nameAndPort@(NameAndPort name port) = NameAndPort newName
|
||||
errorStr = "renameNamePort: name not found. name = " ++ show name ++ "\nNameAndPort = " ++ show nameAndPort ++ "\nNameMap = " ++ show nameMap
|
||||
|
||||
renameEdge :: NameMap -> Edge -> Edge
|
||||
renameEdge nameMap (Edge options ends (np1, np2)) =
|
||||
Edge options ends (renameNamePort nameMap np1, renameNamePort nameMap np2)
|
||||
renameEdge nameMap (Edge options (np1, np2)) =
|
||||
Edge options (renameNamePort nameMap np1, renameNamePort nameMap np2)
|
||||
|
||||
renameSource :: NameMap -> SgBind -> SgBind
|
||||
renameSource nameMap (SgBind str ref) = SgBind str newRef where
|
||||
@ -107,55 +103,6 @@ renameGraph (SyntaxGraph nodes edges sinks sources embedMap) =
|
||||
-- END renameGraph
|
||||
|
||||
-- END Unit Test Helpers --
|
||||
|
||||
|
||||
-- 0:(toName "app02",ApplyNode 1)->[]
|
||||
-- 1:(toName "f0",LiteralNode "f")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "f0") Nothing,NameAndPort (toName "app02") (Just 0))},0)]
|
||||
-- 2:(toName "x1",LiteralNode "x")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "x1") Nothing,NameAndPort (toName "app02") (Just 2))},0)]
|
||||
-- 3:(toName "y3",NameNode "y")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "y3") Nothing,NameAndPort (toName "app02") (Just 1))},0)]
|
||||
singleApplyGraph :: FGR.Gr SgNamedNode Edge
|
||||
singleApplyGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph "y = f x"
|
||||
|
||||
makeTreeRootTest :: (String, [Maybe SgNamedNode], String) -> Test
|
||||
makeTreeRootTest (testName, expected, haskellString) = TestCase $ assertEqual testName expected actual where
|
||||
actual = fmap (ING.lab graph) treeRoots
|
||||
graph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph haskellString
|
||||
treeRoots = GraphAlgorithms.findTreeRoots graph
|
||||
|
||||
treeRootTests :: Test
|
||||
treeRootTests = TestList $ fmap makeTreeRootTest treeRootTestList where
|
||||
treeRootTestList = [
|
||||
("single apply", [Just $ SgNamedNode (NodeName 2) (LikeApplyNode ApplyNodeFlavor 1)], "y = f x"),
|
||||
-- TODO Fix test below
|
||||
("double apply", [Just $ SgNamedNode (NodeName 3) (LikeApplyNode ComposeNodeFlavor 2)], "y = f (g x)"),
|
||||
("recursive apply", [Just $ SgNamedNode (NodeName 3) (LikeApplyNode ComposeNodeFlavor 2)], "y = f (g y)")
|
||||
]
|
||||
|
||||
makeChildCanBeEmbeddedTest ::
|
||||
ING.Graph gr =>
|
||||
(String, IngSyntaxGraph gr, ING.Node, Bool) -> Test
|
||||
makeChildCanBeEmbeddedTest (testName, graph, node, expected) =TestCase $ assertEqual testName expected canBeEmbedded where
|
||||
canBeEmbedded = GraphAlgorithms.nodeWillBeEmbedded graph node
|
||||
|
||||
-- TODO Add more cases for childCanBeEmbeddedTests
|
||||
-- TODO Fix these tests
|
||||
childCanBeEmbeddedTests :: Test
|
||||
childCanBeEmbeddedTests
|
||||
= TestList $ fmap makeChildCanBeEmbeddedTest childCanBeEmbeddedList
|
||||
where
|
||||
childCanBeEmbeddedList = [
|
||||
-- ("single apply, ap", singleApplyGraph, 0, False),
|
||||
("single apply, f", singleApplyGraph, 1, True),
|
||||
-- ("single apply, x", singleApplyGraph, 2, True),
|
||||
("single apply, y", singleApplyGraph, 3, False)
|
||||
]
|
||||
|
||||
collapseUnitTests :: Test
|
||||
collapseUnitTests = TestList[
|
||||
TestLabel "findTreeRoots" treeRootTests
|
||||
, TestLabel "childCanBeEmbedded" childCanBeEmbeddedTests
|
||||
]
|
||||
|
||||
-- Translate unit tests
|
||||
|
||||
applyTests :: Test
|
||||
@ -402,6 +349,5 @@ translateUnitTests = TestList [
|
||||
|
||||
allUnitTests :: Test
|
||||
allUnitTests = TestList[
|
||||
TestLabel "collapseUnitTests" collapseUnitTests,
|
||||
TestLabel "translateTests" translateUnitTests
|
||||
]
|
||||
|
||||
@ -12,22 +12,30 @@ import qualified Data.GraphViz.Attributes.Complete as GVA
|
||||
|
||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
||||
|
||||
import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), NameAndPort(..), SgNamedNode(..), Edge(..))
|
||||
import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), NameAndPort(..)
|
||||
, SgNamedNode(..), Edge(..))
|
||||
import Translate(translateStringToSyntaxGraph)
|
||||
import TranslateCore(syntaxGraphToFglGraph)
|
||||
import GraphAlgorithms(collapseNodes)
|
||||
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
||||
import Rendering(customLayoutParams)
|
||||
import Icons(coloredTextBox)
|
||||
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
prettyPrintSyntaxNode :: SyntaxNode -> String
|
||||
prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges) = concatMap printNameAndEdge namedNodesAndEdges
|
||||
prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges)
|
||||
= concatMap printNameAndEdge namedNodesAndEdges
|
||||
where
|
||||
printNameAndEdge (namedNode, edge) = "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
|
||||
prettyPrintNamedNode (SgNamedNode name _) = show name -- "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
|
||||
printEdge (Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
|
||||
printNameAndEdge (namedNode, edge)
|
||||
= "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
|
||||
prettyPrintNamedNode (SgNamedNode name _)
|
||||
= show name -- "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
|
||||
printEdge (Edge _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
|
||||
prettyPrintSyntaxNode x = show x
|
||||
|
||||
renderFglGraph :: SpecialBackend b Double => FGR.Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
|
||||
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
|
||||
@ -36,12 +44,20 @@ renderFglGraph fglGraph = do
|
||||
-- TODO Draw some type of arrow if point1 == point2
|
||||
(\_ point1 _ point2 _ _ -> if point1 == point2
|
||||
then mempty
|
||||
else lcA (withOpacity white 0.5) $ arrowBetween (scaleFactor *^ point1) (scaleFactor *^ point2))
|
||||
else lcA (withOpacity white 0.7)
|
||||
$ arrowBetween'
|
||||
(shaftStyle %~ lwG 0.5 $ headLength .~ global 1.5 $ with)
|
||||
(scaleFactor *^ point1)
|
||||
(scaleFactor *^ point2))
|
||||
layedOutGraph
|
||||
where
|
||||
scaleFactor = 0.12
|
||||
nodeFunc (SgNamedNode name syntaxNode) point =
|
||||
place (coloredTextBox white (opaque white) (show name ++ prettyPrintSyntaxNode syntaxNode) {- :: Diagram B -})
|
||||
scaleFactor = 0.3
|
||||
nodeFunc (SgNamedNode 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{
|
||||
@ -82,7 +98,7 @@ makeCollapseTest str = do
|
||||
afterCollapse]
|
||||
where
|
||||
fglGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph str
|
||||
collapsedGraph = collapseNodes fglGraph
|
||||
collapsedGraph = collapseAnnotatedGraph $ annotateGraph fglGraph
|
||||
customTextBox = coloredTextBox white (opaque lime)
|
||||
expressionText = alignL $ coloredTextBox white (opaque yellow) str -- :: Diagram B
|
||||
beforeText = alignL $ customTextBox "Before:" -- :: Diagram B
|
||||
|
||||
@ -116,7 +116,7 @@ lambdaDia = Drawing icons []
|
||||
--renderTests :: IO (Diagram B)
|
||||
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||
renderTests = do
|
||||
renderedDiagrams <- traverse renderDrawing allDrawings
|
||||
renderedDiagrams <- traverse (renderDrawing "") allDrawings
|
||||
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
||||
pure vCattedDrawings
|
||||
where
|
||||
|
||||
@ -16,6 +16,7 @@ import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..))
|
||||
import Rendering(renderIngSyntaxGraph)
|
||||
import Icons(textBox, TransformParams(..))
|
||||
|
||||
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||
|
||||
prettyShowList :: Show a => [a] -> String
|
||||
prettyShowList ls = intercalate "\n" $ fmap show ls
|
||||
@ -45,6 +46,8 @@ composeTests = [
|
||||
-- | nestedTests / collapseTest
|
||||
nestedTests :: [String]
|
||||
nestedTests = [
|
||||
"y = (\\x -> x) 0",
|
||||
"y = f (\\x -> x)",
|
||||
"y = f x",
|
||||
"y = let x = 1 in f (g x)",
|
||||
"y = f []",
|
||||
@ -333,10 +336,10 @@ translateStringToDrawing s = do
|
||||
print collapsedGraph
|
||||
putStr "\n\n"
|
||||
if False then printAction else pure () -- Supress unused printAction warning
|
||||
renderIngSyntaxGraph collapsedGraph
|
||||
-- renderIngSyntaxGraph fglGraph
|
||||
renderIngSyntaxGraph s collapsedGraph
|
||||
|
||||
visualTranslateTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||
visualTranslateTests :: SpecialBackend b Double
|
||||
=> IO (SpecialQDiagram b Double)
|
||||
visualTranslateTests = do
|
||||
drawings <- traverse translateStringToDrawing testDecls
|
||||
let
|
||||
|
||||
4
todo.md
4
todo.md
@ -1,6 +1,10 @@
|
||||
# Todo
|
||||
|
||||
## Todo Now
|
||||
* Remove port number magic numbers in GraphAlgorithms.hs.
|
||||
* Consider removing LikeApplyNode and CaseNode, or their embedded versions.
|
||||
* Fix embedded lambdas missing their enclosures.
|
||||
* Add command line flags for color style, embedding, and whether to draw arrowheads.
|
||||
* Add wiki pages discussing: Why a visual language?, History of Glance, How to contribute, Code guide [code style, ...], etc..
|
||||
|
||||
## Todo Later
|
||||
|
||||
Loading…
Reference in New Issue
Block a user