mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 23:17:21 +03:00
Refactor GraphAlgorithms.hs.
This commit is contained in:
parent
b21ff534e8
commit
21e0091743
@ -8,6 +8,8 @@ module DrawingColors (
|
|||||||
|
|
||||||
import Diagrams.Prelude hiding ((&), (#))
|
import Diagrams.Prelude hiding ((&), (#))
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
-- COLO(U)RS --
|
-- COLO(U)RS --
|
||||||
colorScheme :: ColorStyle Double
|
colorScheme :: ColorStyle Double
|
||||||
colorScheme = colorOnBlackScheme
|
colorScheme = colorOnBlackScheme
|
||||||
|
@ -1,65 +1,77 @@
|
|||||||
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
module GraphAlgorithms(
|
module GraphAlgorithms(
|
||||||
ParentType(..),
|
ParentType(..),
|
||||||
collapseNodes,
|
annotateGraph,
|
||||||
findTreeRoots,
|
collapseAnnotatedGraph
|
||||||
nodeWillBeEmbedded
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import qualified Data.Graph.Inductive as ING
|
|
||||||
|
|
||||||
import qualified Control.Arrow as Arrow
|
import qualified Control.Arrow as Arrow
|
||||||
|
import qualified Data.Graph.Inductive as ING
|
||||||
import Data.List(foldl', find)
|
import Data.List(foldl', find)
|
||||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
import Data.Tuple(swap)
|
||||||
--import qualified Debug.Trace
|
|
||||||
|
|
||||||
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
|
||||||
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..))
|
CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
|
||||||
import Util(maybeBoolToBool, sgNamedNodeToSyntaxNode)
|
, AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
|
||||||
--import Util(printSelf)
|
import Util(sgNamedNodeToSyntaxNode)
|
||||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||||
|
|
||||||
-- See graph_algs.txt for pseudocode
|
data ParentType = ApplyParent
|
||||||
|
| CaseParent
|
||||||
data ParentType = ApplyParent | CaseParent | MultiIfParent | NotAParent
|
| MultiIfParent
|
||||||
|
| NotAParent
|
||||||
deriving (Eq, Show)
|
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.
|
-- End helper functions
|
||||||
unwrapDirectionalEdge :: DirectionalEdge a -> a
|
-- START annotateGraph --
|
||||||
unwrapDirectionalEdge d = case d of
|
|
||||||
ParentToChild e -> e
|
|
||||||
ChildToParent e -> e
|
|
||||||
|
|
||||||
-- | A syntaxNodeIsEmbeddable if it can be collapsed into another node
|
-- | A syntaxNodeIsEmbeddable if it can be collapsed into another node
|
||||||
syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Maybe Port -> Bool
|
syntaxNodeIsEmbeddable :: ParentType
|
||||||
syntaxNodeIsEmbeddable parentType n mParentPort = case (parentType, n) of
|
-> SyntaxNode
|
||||||
(ApplyParent, LikeApplyNode _ _) -> notResultPort
|
-> Maybe Port
|
||||||
(ApplyParent, LiteralNode _) -> notResultPort
|
-> 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, LiteralNode _) -> parentPortNotResult
|
||||||
(CaseParent, LikeApplyNode _ _) -> notResultPort && notInputPort
|
(CaseParent, LikeApplyNode _ _)
|
||||||
(CaseParent, NestedPatternApplyNode _ _) -> notResultPort && notInputPort
|
-> parentPortNotResult && parentPortNotInput
|
||||||
|
(CaseParent, NestedPatternApplyNode _ _)
|
||||||
|
-> parentPortNotResult && parentPortNotInput
|
||||||
|
|
||||||
(MultiIfParent, LiteralNode _) -> notResultPort
|
(MultiIfParent, LiteralNode _) -> parentPortNotResult
|
||||||
(MultiIfParent, LikeApplyNode _ _) -> notResultPort && notInputPort
|
(MultiIfParent, LikeApplyNode _ _)
|
||||||
|
-> parentPortNotResult && parentPortNotInput
|
||||||
|
|
||||||
_ -> False
|
_ -> False
|
||||||
where
|
where
|
||||||
notInputPort = case mParentPort of
|
isInput mPort = case mPort of
|
||||||
Just (Port 0) -> False
|
Just (Port 0) -> True
|
||||||
_ -> True
|
_ -> False
|
||||||
notResultPort = case mParentPort of
|
|
||||||
-- TODO Don't use hardcoded port number
|
isResult mPort = case mPort of
|
||||||
Just (Port 1) -> False
|
Just (Port 1) -> True
|
||||||
|
Just _ -> False
|
||||||
_ -> True
|
_ -> True
|
||||||
|
|
||||||
|
parentPortNotInput = not $ isInput mParentPort
|
||||||
-- | A syntaxNodeCanEmbed if it can contain other nodes
|
parentPortNotResult = not $ isResult mParentPort
|
||||||
syntaxNodeCanEmbed :: SyntaxNode -> Bool
|
|
||||||
syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode
|
|
||||||
|
|
||||||
parentTypeForNode :: SyntaxNode -> ParentType
|
parentTypeForNode :: SyntaxNode -> ParentType
|
||||||
parentTypeForNode n = case n of
|
parentTypeForNode n = case n of
|
||||||
@ -69,40 +81,80 @@ parentTypeForNode n = case n of
|
|||||||
MultiIfNode _ -> MultiIfParent
|
MultiIfNode _ -> MultiIfParent
|
||||||
NestedCaseOrMultiIfNode CaseTag _ _ -> CaseParent
|
NestedCaseOrMultiIfNode CaseTag _ _ -> CaseParent
|
||||||
NestedCaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
|
NestedCaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
|
||||||
-- The NotAParent case should never occur.
|
|
||||||
_ -> NotAParent
|
_ -> 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 =>
|
lookupSyntaxNode :: ING.Graph gr =>
|
||||||
IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
|
IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
|
||||||
lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
|
lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
|
||||||
|
|
||||||
lookupParentType :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ParentType
|
lookupParentType :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ParentType
|
||||||
lookupParentType graph node
|
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
|
{-# ANN edgeIsSingular "HLint: ignore Redundant bracket" #-}
|
||||||
-- where the filter function is true.
|
edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
|
||||||
filterNodes :: ING.DynGraph gr => (ING.Node -> Bool) -> gr a b -> [ING.Node]
|
edgeIsSingular graph node edge = numEdges <= 1 where
|
||||||
filterNodes condition gr = ING.nodes $ ING.nfilter condition gr
|
(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
|
-- | Replace the a node's label
|
||||||
changeNodeLabel :: ING.DynGraph gr => gr a b -> ING.Node -> a -> gr a b
|
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
|
-> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
|
||||||
(Nothing, _) -> graph
|
(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.
|
-- | Change the node label of the parent to be nested.
|
||||||
embedChildSyntaxNodes :: ING.DynGraph gr =>
|
embedChildSyntaxNode :: ING.DynGraph gr =>
|
||||||
ING.Node -> [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
|
ING.Node -> ING.Node -> AnnotatedGraph gr -> AnnotatedGraph gr
|
||||||
embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
|
embedChildSyntaxNode parentNode childNode oldGraph = newGraph
|
||||||
[] -> oldGraph
|
|
||||||
_ -> newGraph
|
|
||||||
where
|
where
|
||||||
maybeOldNodeLabel = ING.lab oldGraph parentNode
|
mChildAndEdge =
|
||||||
newGraph = case maybeOldNodeLabel of
|
(,) <$> 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
|
Nothing -> oldGraph
|
||||||
Just oldNodeLabel -> changeNodeLabel oldGraph parentNode newNodeLabel
|
Just oldNodeLabel -> changeNodeLabel oldGraph parentNode newNodeLabel
|
||||||
where
|
where
|
||||||
@ -307,19 +183,50 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
|
|||||||
newSyntaxNode = case oldSyntaxNode of
|
newSyntaxNode = case oldSyntaxNode of
|
||||||
LikeApplyNode flavor x
|
LikeApplyNode flavor x
|
||||||
-> NestedApplyNode flavor x childrenAndEdgesToParent
|
-> NestedApplyNode flavor x childrenAndEdgesToParent
|
||||||
|
NestedApplyNode flavor x existingNodes
|
||||||
|
-> NestedApplyNode flavor x
|
||||||
|
(childrenAndEdgesToParent <> existingNodes)
|
||||||
CaseNode x
|
CaseNode x
|
||||||
-> NestedCaseOrMultiIfNode CaseTag x childrenAndEdgesToParent
|
-> NestedCaseOrMultiIfNode CaseTag x childrenAndEdgesToParent
|
||||||
|
NestedCaseOrMultiIfNode tag x existingNodes
|
||||||
|
-> NestedCaseOrMultiIfNode tag x
|
||||||
|
(childrenAndEdgesToParent <> existingNodes)
|
||||||
MultiIfNode x
|
MultiIfNode x
|
||||||
-> NestedCaseOrMultiIfNode MultiIfTag x childrenAndEdgesToParent
|
-> NestedCaseOrMultiIfNode MultiIfTag x childrenAndEdgesToParent
|
||||||
_ -> oldSyntaxNode
|
_ -> oldSyntaxNode
|
||||||
childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
|
|
||||||
findChildAndEdge childNode =
|
changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
|
||||||
(,) <$> ING.lab oldGraph childNode
|
changeEdgeToParent parentNode childNode (fromNode, toNode, lab)
|
||||||
<*> findEdgeLabel oldGraph parentNode childNode
|
= (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 =>
|
collapseAnnotatedGraph :: ING.DynGraph gr
|
||||||
[ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
|
=> AnnotatedGraph gr
|
||||||
deleteChildren = ING.delNodes
|
-> AnnotatedGraph gr
|
||||||
|
collapseAnnotatedGraph origGraph = newGraph
|
||||||
-- END collapseRoots functions
|
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(..))
|
import DrawingColors(colorScheme, ColorStyle(..))
|
||||||
|
|
||||||
{-# ANN module "HLint: ignore Use record patterns" #-}
|
{-# ANN module "HLint: ignore Use record patterns" #-}
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
-- TYPES --
|
-- TYPES --
|
||||||
|
|
||||||
@ -646,7 +647,7 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
|
|||||||
-- 2,3.. : The parameters
|
-- 2,3.. : The parameters
|
||||||
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
|
||||||
flatLambda paramNames (TransformParams name _ reflect angle)
|
flatLambda paramNames (TransformParams name _ reflect angle)
|
||||||
= named name finalDia
|
= centerXY $ named name finalDia
|
||||||
where
|
where
|
||||||
lambdaCircle
|
lambdaCircle
|
||||||
= lwG defaultLineWidth
|
= lwG defaultLineWidth
|
||||||
|
@ -23,6 +23,8 @@ import Rendering(renderIngSyntaxGraph)
|
|||||||
import Translate(translateModuleToCollapsedGraphs)
|
import Translate(translateModuleToCollapsedGraphs)
|
||||||
import Util(customRenderSVG)
|
import Util(customRenderSVG)
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
data CmdLineOptions = CmdLineOptions {
|
data CmdLineOptions = CmdLineOptions {
|
||||||
cmdInputFilename :: String,
|
cmdInputFilename :: String,
|
||||||
cmdOutputFilename :: String,
|
cmdOutputFilename :: String,
|
||||||
@ -60,7 +62,7 @@ renderFile (CmdLineOptions
|
|||||||
--print "\n\n"
|
--print "\n\n"
|
||||||
--print drawings
|
--print drawings
|
||||||
|
|
||||||
diagrams <- traverse renderIngSyntaxGraph drawings
|
diagrams <- traverse (renderIngSyntaxGraph "") drawings
|
||||||
let
|
let
|
||||||
commentsInBoxes
|
commentsInBoxes
|
||||||
= fmap
|
= fmap
|
||||||
|
138
app/Rendering.hs
138
app/Rendering.hs
@ -7,7 +7,7 @@ module Rendering (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
|
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
|
, fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
|
||||||
, TrailLike, V, height, width, (*^), reflectX, rotate
|
, TrailLike, V, height, width, (*^), reflectX, rotate
|
||||||
, centerXY, place
|
, centerXY, place
|
||||||
@ -27,19 +27,19 @@ import Data.Function(on)
|
|||||||
import qualified Data.Graph.Inductive as ING
|
import qualified Data.Graph.Inductive as ING
|
||||||
import Data.Graph.Inductive.PatriciaTree (Gr)
|
import Data.Graph.Inductive.PatriciaTree (Gr)
|
||||||
import Data.List(find, minimumBy)
|
import Data.List(find, minimumBy)
|
||||||
import Data.Maybe(fromMaybe)
|
import Data.Maybe(isNothing, fromMaybe)
|
||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
|
|
||||||
--import qualified Data.GraphViz.Types
|
--import qualified Data.GraphViz.Types
|
||||||
--import Data.GraphViz.Commands
|
--import Data.GraphViz.Commands
|
||||||
--import qualified Debug.Trace
|
|
||||||
|
|
||||||
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
|
import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
|
||||||
, getPortAngles, TransformParams(..), circleRadius)
|
, getPortAngles, TransformParams(..), circleRadius)
|
||||||
import TranslateCore(nodeToIcon)
|
import TranslateCore(nodeToIcon)
|
||||||
import Types(Edge(..), EdgeOption(..), Drawing(..), EdgeEnd(..), NameAndPort(..)
|
import Types(EmbedInfo(..), AnnotatedGraph, Edge(..)
|
||||||
|
, Drawing(..), NameAndPort(..)
|
||||||
, SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..)
|
, SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..)
|
||||||
, Port(..), SgNamedNode, NamedIcon(..), Icon(..))
|
, Port(..), NamedIcon(..), Icon(..))
|
||||||
|
|
||||||
import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
|
import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
|
||||||
|
|
||||||
@ -66,12 +66,16 @@ drawingToGraphvizScaleFactor = 0.15
|
|||||||
|
|
||||||
-- TODO Refactor with syntaxGraphToFglGraph in TranslateCore
|
-- TODO Refactor with syntaxGraphToFglGraph in TranslateCore
|
||||||
-- TODO Make this work with nested icons now that names are not qualified.
|
-- 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) =
|
drawingToIconGraph (Drawing nodes edges) =
|
||||||
mkGraph nodes labeledEdges where
|
mkGraph nodes labeledEdges where
|
||||||
labeledEdges = fmap makeLabeledEdge edges
|
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
|
where
|
||||||
lookupInNodes name = fromMaybeError
|
lookupInNodes name = fromMaybeError
|
||||||
errorString
|
errorString
|
||||||
@ -91,47 +95,39 @@ bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where
|
|||||||
c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x
|
c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x
|
||||||
|
|
||||||
getArrowOpts :: (RealFloat n, Typeable n) =>
|
getArrowOpts :: (RealFloat n, Typeable n) =>
|
||||||
(EdgeEnd, EdgeEnd)
|
(Angle n, Angle n)
|
||||||
-> [EdgeOption]
|
|
||||||
-> (Angle n, Angle n)
|
|
||||||
-> NameAndPort
|
-> NameAndPort
|
||||||
-> (ArrowOpts n, DIA.Colour Double)
|
-> (ArrowOpts n, DIA.Colour Double)
|
||||||
getArrowOpts (t, h)
|
getArrowOpts
|
||||||
_
|
|
||||||
(fromAngle, toAngle)
|
(fromAngle, toAngle)
|
||||||
(NameAndPort (NodeName nodeNum) mPort)
|
(NameAndPort (NodeName nodeNum) mPort)
|
||||||
= (arrowOptions, shaftColor)
|
= (arrowOptions, shaftColor)
|
||||||
where
|
where
|
||||||
-- shaftColor = if EdgeInPattern `elem` opts
|
|
||||||
-- then patternC colorScheme
|
|
||||||
-- else hashedColor
|
|
||||||
shaftColor = hashedColor
|
|
||||||
|
|
||||||
edgeColors = edgeListC colorScheme
|
edgeColors = edgeListC colorScheme
|
||||||
numEdgeColors = length edgeColors
|
|
||||||
hashedColor = edgeColors !! namePortHash
|
|
||||||
namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
|
|
||||||
Port portNum = fromMaybe (Port 0) mPort
|
Port portNum = fromMaybe (Port 0) mPort
|
||||||
|
namePortHash = mod (portNum + (503 * nodeNum)) (length edgeColors)
|
||||||
lookupTail EndNone = id
|
shaftColor = edgeColors !! namePortHash
|
||||||
|
|
||||||
lookupHead EndNone = id
|
|
||||||
|
|
||||||
arrowOptions =
|
arrowOptions =
|
||||||
arrowHead .~ noHead $
|
arrowHead .~ DIA.noHead
|
||||||
arrowTail .~ noTail $
|
-- arrowHead .~ DIA.tri
|
||||||
arrowShaft .~ bezierShaft fromAngle toAngle $
|
$ DIA.headStyle %~ DIA.fc shaftColor
|
||||||
lengths .~ global 0.75 $
|
$ arrowTail .~ noTail
|
||||||
lookupHead h $ lookupTail t with
|
$ 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.
|
-- | Given an Edge, return a transformation on Diagrams that will draw a line.
|
||||||
connectMaybePorts :: SpecialBackend b n =>
|
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
|
connectMaybePorts portAngles
|
||||||
(Edge
|
(EmbedInfo embedDir
|
||||||
opts
|
(Edge
|
||||||
ends
|
_
|
||||||
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2))
|
(fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)))
|
||||||
-- In order to give arrows a "shadow" effect, draw a thicker semi-transparent
|
-- 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
|
-- line shaft the same color as the background underneath the normal line
|
||||||
-- shaft.
|
-- shaft.
|
||||||
@ -139,8 +135,10 @@ connectMaybePorts portAngles
|
|||||||
. connectFunc arrOptsShadow qPort0 qPort1
|
. connectFunc arrOptsShadow qPort0 qPort1
|
||||||
where
|
where
|
||||||
lineWidth = 2 * defaultLineWidth
|
lineWidth = 2 * defaultLineWidth
|
||||||
(baseArrOpts, shaftCol) = getArrowOpts ends opts portAngles fromNamePort
|
(baseArrOpts, shaftCol) = getArrowOpts portAngles fromNamePort
|
||||||
normalOpts = (shaftStyle %~ (lwG lineWidth . lc shaftCol))
|
-- 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
|
baseArrOpts
|
||||||
arrOptsShadow = (shaftStyle
|
arrOptsShadow = (shaftStyle
|
||||||
%~ (lwG (1.9 * lineWidth)
|
%~ (lwG (1.9 * lineWidth)
|
||||||
@ -218,14 +216,15 @@ lookupNodeAngle rotationMap key
|
|||||||
$ lookup key rotationMap
|
$ lookup key rotationMap
|
||||||
|
|
||||||
makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
|
makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
|
||||||
gr NamedIcon Edge
|
String -- ^ Debugging information
|
||||||
|
-> gr NamedIcon (EmbedInfo Edge)
|
||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
-> [(NamedIcon, (Bool, Angle n))]
|
-> [(NamedIcon, (Bool, Angle n))]
|
||||||
-> ING.LEdge Edge
|
-> ING.LEdge (EmbedInfo Edge)
|
||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
makeEdge graph dia rotationMap
|
makeEdge debugInfo graph dia rotationMap
|
||||||
(node0, node1, edge@(Edge _ _ (namePort0, namePort1)))
|
(node0, node1, edge@(EmbedInfo _ (Edge _ (namePort0, namePort1))))
|
||||||
= connectMaybePorts portAngles edge
|
= connectMaybePorts portAngles edge
|
||||||
where
|
where
|
||||||
node0label = fromMaybeError
|
node0label = fromMaybeError
|
||||||
@ -257,10 +256,12 @@ makeEdge graph dia rotationMap
|
|||||||
|
|
||||||
getPortPoint n = case foundPoints of
|
getPortPoint n = case foundPoints of
|
||||||
[point] -> point
|
[point] -> point
|
||||||
_ -> error $ "Multiple points with named: " <> show n
|
_ -> error $ "Multiple points. Debug info: " <> debugInfo
|
||||||
|
<> "\nn: " <> show n
|
||||||
where
|
where
|
||||||
foundPoints = fromMaybeError
|
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)
|
++ show diaNodeNamePointMap)
|
||||||
(lookup n diaNodeNamePointMap)
|
(lookup n diaNodeNamePointMap)
|
||||||
|
|
||||||
@ -268,13 +269,14 @@ makeEdge graph dia rotationMap
|
|||||||
|
|
||||||
-- | addEdges draws the edges underneath the nodes.
|
-- | addEdges draws the edges underneath the nodes.
|
||||||
addEdges :: (SpecialBackend b n, ING.Graph gr) =>
|
addEdges :: (SpecialBackend b n, ING.Graph gr) =>
|
||||||
gr NamedIcon Edge
|
String -- ^ Debugging information
|
||||||
|
-> gr NamedIcon (EmbedInfo Edge)
|
||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
-> [(NamedIcon, (Bool, Angle n))]
|
-> [(NamedIcon, (Bool, Angle n))]
|
||||||
-> SpecialQDiagram b n
|
-> SpecialQDiagram b n
|
||||||
addEdges graph dia rotationMap = applyAll connections dia
|
addEdges debugInfo graph dia rotationMap = applyAll connections dia
|
||||||
where
|
where
|
||||||
connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
|
connections = makeEdge debugInfo graph dia rotationMap <$> ING.labEdges graph
|
||||||
|
|
||||||
-- BEGIN rotateNodes --
|
-- BEGIN rotateNodes --
|
||||||
|
|
||||||
@ -296,7 +298,7 @@ scoreAngle iconPosition edges reflected angle
|
|||||||
|
|
||||||
bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
|
bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
|
||||||
Map.Map NamedIcon (Point V2 n)
|
Map.Map NamedIcon (Point V2 n)
|
||||||
-> gr NamedIcon Edge
|
-> gr NamedIcon (EmbedInfo Edge)
|
||||||
-> NamedIcon
|
-> NamedIcon
|
||||||
-> Bool
|
-> Bool
|
||||||
-> (Angle n, n)
|
-> (Angle n, n)
|
||||||
@ -322,16 +324,16 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
|
|||||||
portAngles = findPortAngles key nameAndPort
|
portAngles = findPortAngles key nameAndPort
|
||||||
|
|
||||||
-- Edge points from id to otherNode
|
-- Edge points from id to otherNode
|
||||||
getSucEdge (otherNode, edge) = (otherNode, nameAndPort) where
|
getSucEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
|
||||||
(nameAndPort, _) = edgeConnection edge
|
(nameAndPort, _) = edgeConnection edge
|
||||||
|
|
||||||
-- Edge points from otherNode to id
|
-- Edge points from otherNode to id
|
||||||
getPreEdge (otherNode, edge) = (otherNode, nameAndPort) where
|
getPreEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
|
||||||
(_, nameAndPort) = edgeConnection edge
|
(_, nameAndPort) = edgeConnection edge
|
||||||
|
|
||||||
findIconRotation :: (SpecialNum n, ING.Graph gr) =>
|
findIconRotation :: (SpecialNum n, ING.Graph gr) =>
|
||||||
Map.Map NamedIcon (Point V2 n)
|
Map.Map NamedIcon (Point V2 n)
|
||||||
-> gr NamedIcon Edge
|
-> gr NamedIcon (EmbedInfo Edge)
|
||||||
-> NamedIcon
|
-> NamedIcon
|
||||||
-> (NamedIcon, (Bool, Angle n))
|
-> (NamedIcon, (Bool, Angle n))
|
||||||
findIconRotation positionMap graph key = (key, (reflected, angle)) where
|
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) =>
|
rotateNodes :: (SpecialNum n, ING.Graph gr) =>
|
||||||
Map.Map NamedIcon (Point V2 n)
|
Map.Map NamedIcon (Point V2 n)
|
||||||
-> gr NamedIcon Edge
|
-> gr NamedIcon (EmbedInfo Edge)
|
||||||
-> [(NamedIcon, (Bool, Angle n))]
|
-> [(NamedIcon, (Bool, Angle n))]
|
||||||
rotateNodes positionMap graph
|
rotateNodes positionMap graph
|
||||||
= findIconRotation positionMap graph <$> Map.keys positionMap
|
= findIconRotation positionMap graph <$> Map.keys positionMap
|
||||||
@ -362,8 +364,8 @@ drawLambdaRegions placedNodes
|
|||||||
where
|
where
|
||||||
enclosedDias = fmap findDia enclosedNames
|
enclosedDias = fmap findDia enclosedNames
|
||||||
findDia n1
|
findDia n1
|
||||||
= fromMaybe mempty
|
= maybe mempty snd
|
||||||
$ snd <$> find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes
|
(find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes)
|
||||||
drawRegion _ = mempty
|
drawRegion _ = mempty
|
||||||
|
|
||||||
-- TODO Use something better than a rectangle
|
-- TODO Use something better than a rectangle
|
||||||
@ -414,11 +416,12 @@ customLayoutParams = GV.defaultParams{
|
|||||||
GV.fmtEdge = const [GV.arrowTo GV.noArrow]
|
GV.fmtEdge = const [GV.arrowTo GV.noArrow]
|
||||||
}
|
}
|
||||||
|
|
||||||
doGraphLayout :: forall b.
|
renderIconGraph :: forall b.
|
||||||
SpecialBackend b Double =>
|
SpecialBackend b Double =>
|
||||||
Gr NamedIcon Edge
|
String -- ^ Debugging information
|
||||||
|
-> Gr NamedIcon (EmbedInfo Edge)
|
||||||
-> IO (SpecialQDiagram b Double)
|
-> IO (SpecialQDiagram b Double)
|
||||||
doGraphLayout graph = do
|
renderIconGraph debugInfo graph = do
|
||||||
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
layoutResult <- layoutGraph' layoutParams GVA.Neato graph
|
||||||
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
-- layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
|
||||||
let
|
let
|
||||||
@ -426,7 +429,7 @@ doGraphLayout graph = do
|
|||||||
rotationMap = rotateNodes positionMap graph
|
rotationMap = rotateNodes positionMap graph
|
||||||
placedNodeList = placeNodes positionMap rotationMap
|
placedNodeList = placeNodes positionMap rotationMap
|
||||||
placedNodes = mconcat $ fmap snd placedNodeList
|
placedNodes = mconcat $ fmap snd placedNodeList
|
||||||
edges = addEdges graph placedNodes rotationMap
|
edges = addEdges debugInfo graph placedNodes rotationMap
|
||||||
placedRegions = drawLambdaRegions placedNodeList
|
placedRegions = drawLambdaRegions placedNodeList
|
||||||
pure (placedNodes <> edges <> placedRegions)
|
pure (placedNodes <> edges <> placedRegions)
|
||||||
where
|
where
|
||||||
@ -459,17 +462,14 @@ doGraphLayout graph = do
|
|||||||
|
|
||||||
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
-- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
|
||||||
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
-- lines connecting ports and icons. IO is needed for the GraphViz layout.
|
||||||
renderDrawing ::
|
renderDrawing :: SpecialBackend b Double
|
||||||
SpecialBackend b Double =>
|
=> String -- ^ Debugging information
|
||||||
Drawing -> IO (SpecialQDiagram b Double)
|
-> Drawing
|
||||||
renderDrawing = renderIconGraph . drawingToIconGraph
|
-> IO (SpecialQDiagram b Double)
|
||||||
|
renderDrawing debugInfo = renderIconGraph debugInfo . drawingToIconGraph
|
||||||
|
|
||||||
renderIngSyntaxGraph ::
|
renderIngSyntaxGraph ::
|
||||||
SpecialBackend b Double =>
|
SpecialBackend b Double =>
|
||||||
Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
|
String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
|
||||||
renderIngSyntaxGraph
|
renderIngSyntaxGraph debugInfo gr
|
||||||
= renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
|
= renderIconGraph debugInfo $ ING.nmap (mapNodeInNamedNode nodeToIcon) gr
|
||||||
|
|
||||||
renderIconGraph :: SpecialBackend b Double
|
|
||||||
=> Gr NamedIcon Edge -> IO (SpecialQDiagram b Double)
|
|
||||||
renderIconGraph = doGraphLayout
|
|
||||||
|
@ -18,7 +18,7 @@ import Data.Maybe(catMaybes, fromMaybe)
|
|||||||
import qualified Language.Haskell.Exts as Exts
|
import qualified Language.Haskell.Exts as Exts
|
||||||
import qualified Language.Haskell.Exts.Pretty as PExts
|
import qualified Language.Haskell.Exts.Pretty as PExts
|
||||||
|
|
||||||
import GraphAlgorithms(collapseNodes)
|
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
||||||
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
|
||||||
casePatternPorts)
|
casePatternPorts)
|
||||||
import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..)
|
import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..)
|
||||||
@ -32,8 +32,8 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..)
|
|||||||
, deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph
|
, deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph
|
||||||
, getUniqueString, bindsToSyntaxGraph, SgBind(..)
|
, getUniqueString, bindsToSyntaxGraph, SgBind(..)
|
||||||
, graphAndRefToGraph, initialIdState)
|
, graphAndRefToGraph, initialIdState)
|
||||||
import Types(Labeled(..), NameAndPort(..), IDState,
|
import Types(AnnotatedGraph, Labeled(..), NameAndPort(..), IDState,
|
||||||
Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
|
Edge, SyntaxNode(..), NodeName, SgNamedNode(..),
|
||||||
LikeApplyFlavor(..))
|
LikeApplyFlavor(..))
|
||||||
import Util(makeSimpleEdge, nameAndPort, justName)
|
import Util(makeSimpleEdge, nameAndPort, justName)
|
||||||
|
|
||||||
@ -643,22 +643,24 @@ translateDeclToSyntaxGraph d = graph where
|
|||||||
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
translateStringToSyntaxGraph :: String -> SyntaxGraph
|
||||||
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
|
translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
|
||||||
|
|
||||||
syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
|
syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr
|
||||||
syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
|
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
|
translateDeclToCollapsedGraph
|
||||||
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
|
= syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
|
||||||
|
|
||||||
-- Profiling: At one point, this was about 1.5% of total time.
|
-- Profiling: At one point, this was about 1.5% of total time.
|
||||||
translateStringToCollapsedGraphAndDecl ::
|
translateStringToCollapsedGraphAndDecl ::
|
||||||
String -> (IngSyntaxGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
|
String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
|
||||||
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
|
||||||
decl = customParseDecl s -- :: ParseResult Module
|
decl = customParseDecl s -- :: ParseResult Module
|
||||||
drawing = translateDeclToCollapsedGraph decl
|
drawing = translateDeclToCollapsedGraph decl
|
||||||
|
|
||||||
translateModuleToCollapsedGraphs :: Show l =>
|
translateModuleToCollapsedGraphs :: Show l =>
|
||||||
Exts.Module l -> [IngSyntaxGraph FGR.Gr]
|
Exts.Module l -> [AnnotatedGraph FGR.Gr]
|
||||||
translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls)
|
translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls)
|
||||||
= fmap translateDeclToCollapsedGraph decls
|
= fmap translateDeclToCollapsedGraph decls
|
||||||
translateModuleToCollapsedGraphs moduleSyntax
|
translateModuleToCollapsedGraphs moduleSyntax
|
||||||
|
@ -41,7 +41,7 @@ import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..)
|
|||||||
, NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port
|
, NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port
|
||||||
, LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..)
|
, LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..)
|
||||||
, NamedIcon(..))
|
, NamedIcon(..))
|
||||||
import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
|
import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
|
||||||
, mapNodeInNamedNode, nodeNameToInt)
|
, mapNodeInNamedNode, nodeNameToInt)
|
||||||
|
|
||||||
{-# ANN module "HLint: ignore Use list comprehension" #-}
|
{-# ANN module "HLint: ignore Use list comprehension" #-}
|
||||||
@ -150,7 +150,7 @@ edgesForRefPortList inPattern portExpPairs
|
|||||||
Left str -> if inPattern
|
Left str -> if inPattern
|
||||||
then bindsToSyntaxGraph [SgBind str (Right port)]
|
then bindsToSyntaxGraph [SgBind str (Right port)]
|
||||||
else sinksToSyntaxGraph [SgSink str port]
|
else sinksToSyntaxGraph [SgSink str port]
|
||||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection]
|
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection]
|
||||||
where
|
where
|
||||||
connection = if inPattern
|
connection = if inPattern
|
||||||
-- If in a pattern, then the port on the case icon is
|
-- If in a pattern, then the port on the case icon is
|
||||||
@ -167,7 +167,7 @@ combineExpressions inPattern portExpPairs
|
|||||||
Left str -> if inPattern
|
Left str -> if inPattern
|
||||||
then bindsToSyntaxGraph [SgBind str (Right port)]
|
then bindsToSyntaxGraph [SgBind str (Right port)]
|
||||||
else sinksToSyntaxGraph [SgSink str port]
|
else sinksToSyntaxGraph [SgSink str port]
|
||||||
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)]
|
Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)]
|
||||||
|
|
||||||
makeApplyGraph ::
|
makeApplyGraph ::
|
||||||
Int
|
Int
|
||||||
@ -335,7 +335,7 @@ nestedPatternNodeToIcon str children = NestedPApp
|
|||||||
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
findArg :: Port -> (SgNamedNode, Edge) -> Bool
|
||||||
findArg currentPort
|
findArg currentPort
|
||||||
(SgNamedNode argName _
|
(SgNamedNode argName _
|
||||||
, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
, Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
|
||||||
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
|
| argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
|
||||||
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
| argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
|
||||||
| otherwise = False -- This case should never happen
|
| otherwise = False -- This case should never happen
|
||||||
@ -357,7 +357,7 @@ syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
|
|||||||
ING.mkGraph (fmap makeLNode nodes) labeledEdges where
|
ING.mkGraph (fmap makeLNode nodes) labeledEdges where
|
||||||
labeledEdges = fmap makeLabeledEdge edges
|
labeledEdges = fmap makeLabeledEdge edges
|
||||||
|
|
||||||
makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) =
|
makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) =
|
||||||
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap
|
(nodeNameToInt $ lookupInEmbeddingMap name1 eMap
|
||||||
, nodeNameToInt $ lookupInEmbeddingMap name2 eMap
|
, nodeNameToInt $ lookupInEmbeddingMap name2 eMap
|
||||||
, e)
|
, e)
|
||||||
|
25
app/Types.hs
25
app/Types.hs
@ -1,4 +1,5 @@
|
|||||||
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-}
|
{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-}
|
||||||
|
{-# LANGUAGE DeriveFunctor #-}
|
||||||
|
|
||||||
module Types (
|
module Types (
|
||||||
NamedIcon(..),
|
NamedIcon(..),
|
||||||
@ -10,7 +11,6 @@ module Types (
|
|||||||
Connection,
|
Connection,
|
||||||
Edge(..),
|
Edge(..),
|
||||||
EdgeOption(..),
|
EdgeOption(..),
|
||||||
EdgeEnd(..),
|
|
||||||
Drawing(..),
|
Drawing(..),
|
||||||
IDState(..),
|
IDState(..),
|
||||||
SpecialQDiagram,
|
SpecialQDiagram,
|
||||||
@ -20,7 +20,10 @@ module Types (
|
|||||||
IngSyntaxGraph,
|
IngSyntaxGraph,
|
||||||
LikeApplyFlavor(..),
|
LikeApplyFlavor(..),
|
||||||
CaseOrMultiIfTag(..),
|
CaseOrMultiIfTag(..),
|
||||||
Labeled(..)
|
Labeled(..),
|
||||||
|
EmbedDirection(..),
|
||||||
|
EmbedInfo(..),
|
||||||
|
AnnotatedGraph,
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
|
import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
|
||||||
@ -84,6 +87,7 @@ data SyntaxNode =
|
|||||||
-- Function application, composition, and applying to a composition
|
-- Function application, composition, and applying to a composition
|
||||||
LikeApplyNode LikeApplyFlavor Int
|
LikeApplyNode LikeApplyFlavor Int
|
||||||
-- NestedApplyNode is only created in GraphAlgorithms, not during translation.
|
-- NestedApplyNode is only created in GraphAlgorithms, not during translation.
|
||||||
|
-- The list of nodes is unordered (replace with a map?)
|
||||||
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
| NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
|
||||||
| NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
|
| NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
|
||||||
| NameNode String -- Identifiers or symbols
|
| NameNode String -- Identifiers or symbols
|
||||||
@ -106,15 +110,13 @@ data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord)
|
|||||||
|
|
||||||
type Connection = (NameAndPort, NameAndPort)
|
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 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,
|
-- | 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.
|
-- and the name of the destination icon, and its optional port number.
|
||||||
data Edge = Edge { edgeOptions :: [EdgeOption]
|
data Edge = Edge { edgeOptions :: [EdgeOption]
|
||||||
, edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
|
, edgeConnection :: Connection}
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
-- | A drawing is a map from names to Icons, a list of edges,
|
-- | 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 SpecialQDiagram b n = QDiagram b V2 n Any
|
||||||
|
|
||||||
type IngSyntaxGraph gr = gr SgNamedNode Edge
|
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,
|
printSelf,
|
||||||
iconToPort,
|
iconToPort,
|
||||||
makeSimpleEdge,
|
makeSimpleEdge,
|
||||||
noEnds,
|
|
||||||
nameAndPort,
|
nameAndPort,
|
||||||
justName,
|
justName,
|
||||||
fromMaybeError,
|
fromMaybeError,
|
||||||
@ -26,14 +25,11 @@ import Data.Text(pack)
|
|||||||
import Data.Typeable(Typeable)
|
import Data.Typeable(Typeable)
|
||||||
import qualified Debug.Trace
|
import qualified Debug.Trace
|
||||||
|
|
||||||
import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..)
|
import Types(Edge(..), NameAndPort(..), Connection, NodeName(..)
|
||||||
, Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
, Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
|
||||||
|
|
||||||
noEnds :: (EdgeEnd, EdgeEnd)
|
|
||||||
noEnds = (EndNone, EndNone)
|
|
||||||
|
|
||||||
makeSimpleEdge :: Connection -> Edge
|
makeSimpleEdge :: Connection -> Edge
|
||||||
makeSimpleEdge = Edge [] noEnds
|
makeSimpleEdge = Edge []
|
||||||
|
|
||||||
nameAndPort :: NodeName -> Port -> NameAndPort
|
nameAndPort :: NodeName -> Port -> NameAndPort
|
||||||
nameAndPort n p = NameAndPort n (Just p)
|
nameAndPort n p = NameAndPort n (Just p)
|
||||||
|
@ -14,6 +14,7 @@ import VisualGraphAlgorithmTests(visualCollapseTests)
|
|||||||
import VisualRenderingTests(renderTests)
|
import VisualRenderingTests(renderTests)
|
||||||
import VisualTranslateTests(visualTranslateTests)
|
import VisualTranslateTests(visualTranslateTests)
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
drawingsAndNames :: [(String, IO (Diagram B))]
|
drawingsAndNames :: [(String, IO (Diagram B))]
|
||||||
drawingsAndNames = [
|
drawingsAndNames = [
|
||||||
|
@ -4,16 +4,12 @@ module UnitTests(
|
|||||||
|
|
||||||
import Test.HUnit
|
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 Data.List(foldl', sort, sortOn)
|
||||||
|
|
||||||
import Translate(translateStringToSyntaxGraph)
|
import Translate(translateStringToSyntaxGraph)
|
||||||
import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..))
|
import TranslateCore(SyntaxGraph(..), SgBind(..))
|
||||||
import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..),
|
import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..),
|
||||||
IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..))
|
NodeName(..), NameAndPort(..))
|
||||||
import qualified GraphAlgorithms
|
|
||||||
import Util(fromMaybeError)
|
import Util(fromMaybeError)
|
||||||
|
|
||||||
-- Unit Test Helpers --
|
-- 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
|
errorStr = "renameNamePort: name not found. name = " ++ show name ++ "\nNameAndPort = " ++ show nameAndPort ++ "\nNameMap = " ++ show nameMap
|
||||||
|
|
||||||
renameEdge :: NameMap -> Edge -> Edge
|
renameEdge :: NameMap -> Edge -> Edge
|
||||||
renameEdge nameMap (Edge options ends (np1, np2)) =
|
renameEdge nameMap (Edge options (np1, np2)) =
|
||||||
Edge options ends (renameNamePort nameMap np1, renameNamePort nameMap np2)
|
Edge options (renameNamePort nameMap np1, renameNamePort nameMap np2)
|
||||||
|
|
||||||
renameSource :: NameMap -> SgBind -> SgBind
|
renameSource :: NameMap -> SgBind -> SgBind
|
||||||
renameSource nameMap (SgBind str ref) = SgBind str newRef where
|
renameSource nameMap (SgBind str ref) = SgBind str newRef where
|
||||||
@ -107,55 +103,6 @@ renameGraph (SyntaxGraph nodes edges sinks sources embedMap) =
|
|||||||
-- END renameGraph
|
-- END renameGraph
|
||||||
|
|
||||||
-- END Unit Test Helpers --
|
-- 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
|
-- Translate unit tests
|
||||||
|
|
||||||
applyTests :: Test
|
applyTests :: Test
|
||||||
@ -402,6 +349,5 @@ translateUnitTests = TestList [
|
|||||||
|
|
||||||
allUnitTests :: Test
|
allUnitTests :: Test
|
||||||
allUnitTests = TestList[
|
allUnitTests = TestList[
|
||||||
TestLabel "collapseUnitTests" collapseUnitTests,
|
|
||||||
TestLabel "translateTests" translateUnitTests
|
TestLabel "translateTests" translateUnitTests
|
||||||
]
|
]
|
||||||
|
@ -12,22 +12,30 @@ import qualified Data.GraphViz.Attributes.Complete as GVA
|
|||||||
|
|
||||||
import qualified Data.Graph.Inductive.PatriciaTree as FGR
|
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 Translate(translateStringToSyntaxGraph)
|
||||||
import TranslateCore(syntaxGraphToFglGraph)
|
import TranslateCore(syntaxGraphToFglGraph)
|
||||||
import GraphAlgorithms(collapseNodes)
|
import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
|
||||||
import Rendering(customLayoutParams)
|
import Rendering(customLayoutParams)
|
||||||
import Icons(coloredTextBox)
|
import Icons(coloredTextBox)
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
prettyPrintSyntaxNode :: SyntaxNode -> String
|
prettyPrintSyntaxNode :: SyntaxNode -> String
|
||||||
prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges) = concatMap printNameAndEdge namedNodesAndEdges
|
prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges)
|
||||||
|
= concatMap printNameAndEdge namedNodesAndEdges
|
||||||
where
|
where
|
||||||
printNameAndEdge (namedNode, edge) = "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
|
printNameAndEdge (namedNode, edge)
|
||||||
prettyPrintNamedNode (SgNamedNode name _) = show name -- "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
|
= "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
|
||||||
printEdge (Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
|
prettyPrintNamedNode (SgNamedNode name _)
|
||||||
|
= show name -- "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
|
||||||
|
printEdge (Edge _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
|
||||||
prettyPrintSyntaxNode x = show x
|
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
|
renderFglGraph fglGraph = do
|
||||||
layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
|
layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
|
||||||
pure $ DiaGV.drawGraph
|
pure $ DiaGV.drawGraph
|
||||||
@ -36,12 +44,20 @@ renderFglGraph fglGraph = do
|
|||||||
-- TODO Draw some type of arrow if point1 == point2
|
-- TODO Draw some type of arrow if point1 == point2
|
||||||
(\_ point1 _ point2 _ _ -> if point1 == point2
|
(\_ point1 _ point2 _ _ -> if point1 == point2
|
||||||
then mempty
|
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
|
layedOutGraph
|
||||||
where
|
where
|
||||||
scaleFactor = 0.12
|
scaleFactor = 0.3
|
||||||
nodeFunc (SgNamedNode name syntaxNode) point =
|
nodeFunc (SgNamedNode name syntaxNode) point
|
||||||
place (coloredTextBox white (opaque white) (show name ++ prettyPrintSyntaxNode syntaxNode) {- :: Diagram B -})
|
= place (coloredTextBox
|
||||||
|
white
|
||||||
|
(opaque white)
|
||||||
|
(show name ++ prettyPrintSyntaxNode syntaxNode)
|
||||||
|
{- :: Diagram B -})
|
||||||
(scaleFactor *^ point)
|
(scaleFactor *^ point)
|
||||||
layoutParams :: GV.GraphvizParams Int v e () v
|
layoutParams :: GV.GraphvizParams Int v e () v
|
||||||
layoutParams = customLayoutParams{
|
layoutParams = customLayoutParams{
|
||||||
@ -82,7 +98,7 @@ makeCollapseTest str = do
|
|||||||
afterCollapse]
|
afterCollapse]
|
||||||
where
|
where
|
||||||
fglGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph str
|
fglGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph str
|
||||||
collapsedGraph = collapseNodes fglGraph
|
collapsedGraph = collapseAnnotatedGraph $ annotateGraph fglGraph
|
||||||
customTextBox = coloredTextBox white (opaque lime)
|
customTextBox = coloredTextBox white (opaque lime)
|
||||||
expressionText = alignL $ coloredTextBox white (opaque yellow) str -- :: Diagram B
|
expressionText = alignL $ coloredTextBox white (opaque yellow) str -- :: Diagram B
|
||||||
beforeText = alignL $ customTextBox "Before:" -- :: Diagram B
|
beforeText = alignL $ customTextBox "Before:" -- :: Diagram B
|
||||||
|
@ -116,7 +116,7 @@ lambdaDia = Drawing icons []
|
|||||||
--renderTests :: IO (Diagram B)
|
--renderTests :: IO (Diagram B)
|
||||||
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
||||||
renderTests = do
|
renderTests = do
|
||||||
renderedDiagrams <- traverse renderDrawing allDrawings
|
renderedDiagrams <- traverse (renderDrawing "") allDrawings
|
||||||
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
|
||||||
pure vCattedDrawings
|
pure vCattedDrawings
|
||||||
where
|
where
|
||||||
|
@ -16,6 +16,7 @@ import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..))
|
|||||||
import Rendering(renderIngSyntaxGraph)
|
import Rendering(renderIngSyntaxGraph)
|
||||||
import Icons(textBox, TransformParams(..))
|
import Icons(textBox, TransformParams(..))
|
||||||
|
|
||||||
|
{-# ANN module "HLint: ignore Unnecessary hiding" #-}
|
||||||
|
|
||||||
prettyShowList :: Show a => [a] -> String
|
prettyShowList :: Show a => [a] -> String
|
||||||
prettyShowList ls = intercalate "\n" $ fmap show ls
|
prettyShowList ls = intercalate "\n" $ fmap show ls
|
||||||
@ -45,6 +46,8 @@ composeTests = [
|
|||||||
-- | nestedTests / collapseTest
|
-- | nestedTests / collapseTest
|
||||||
nestedTests :: [String]
|
nestedTests :: [String]
|
||||||
nestedTests = [
|
nestedTests = [
|
||||||
|
"y = (\\x -> x) 0",
|
||||||
|
"y = f (\\x -> x)",
|
||||||
"y = f x",
|
"y = f x",
|
||||||
"y = let x = 1 in f (g x)",
|
"y = let x = 1 in f (g x)",
|
||||||
"y = f []",
|
"y = f []",
|
||||||
@ -333,10 +336,10 @@ translateStringToDrawing s = do
|
|||||||
print collapsedGraph
|
print collapsedGraph
|
||||||
putStr "\n\n"
|
putStr "\n\n"
|
||||||
if False then printAction else pure () -- Supress unused printAction warning
|
if False then printAction else pure () -- Supress unused printAction warning
|
||||||
renderIngSyntaxGraph collapsedGraph
|
renderIngSyntaxGraph s collapsedGraph
|
||||||
-- renderIngSyntaxGraph fglGraph
|
|
||||||
|
|
||||||
visualTranslateTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
|
visualTranslateTests :: SpecialBackend b Double
|
||||||
|
=> IO (SpecialQDiagram b Double)
|
||||||
visualTranslateTests = do
|
visualTranslateTests = do
|
||||||
drawings <- traverse translateStringToDrawing testDecls
|
drawings <- traverse translateStringToDrawing testDecls
|
||||||
let
|
let
|
||||||
|
4
todo.md
4
todo.md
@ -1,6 +1,10 @@
|
|||||||
# Todo
|
# Todo
|
||||||
|
|
||||||
## Todo Now
|
## 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..
|
* Add wiki pages discussing: Why a visual language?, History of Glance, How to contribute, Code guide [code style, ...], etc..
|
||||||
|
|
||||||
## Todo Later
|
## Todo Later
|
||||||
|
Loading…
Reference in New Issue
Block a user