mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
Fix edge direction from case result to the optional case result port on the case node.
This commit is contained in:
parent
e373a6bcc5
commit
e1af41b9bf
@ -7,12 +7,13 @@ module GraphAlgorithms(
|
||||
|
||||
import qualified Data.Graph.Inductive as ING
|
||||
|
||||
import qualified Control.Arrow as Arrow
|
||||
import Data.List(foldl', find)
|
||||
import Data.Maybe(catMaybes, isJust, fromMaybe)
|
||||
--import qualified Debug.Trace
|
||||
|
||||
import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..),
|
||||
CaseOrGuardTag(..))
|
||||
CaseOrGuardTag(..), Port(..), NameAndPort(..))
|
||||
import Util(maybeBoolToBool)
|
||||
--import Util(printSelf)
|
||||
|
||||
@ -20,15 +21,27 @@ import Util(maybeBoolToBool)
|
||||
|
||||
data ParentType = ApplyParent | CaseOrGuardParent | NotAParent deriving (Eq, Show)
|
||||
|
||||
data DirectionalEdge a = ParentToChild a | ChildToParent a deriving (Eq, Show)
|
||||
|
||||
-- START HELPER functions --
|
||||
|
||||
unwrapDirectionalEdge :: DirectionalEdge a -> a
|
||||
unwrapDirectionalEdge d = case d of
|
||||
ParentToChild e -> e
|
||||
ChildToParent e -> e
|
||||
|
||||
-- | A syntaxNodeIsEmbeddable if it can be collapsed into another node
|
||||
syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Bool
|
||||
syntaxNodeIsEmbeddable parentType n = case (parentType, n) of
|
||||
(ApplyParent, LikeApplyNode _ _) -> True
|
||||
(ApplyParent, LiteralNode _) -> True
|
||||
(CaseOrGuardParent, LiteralNode _) -> True
|
||||
syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Maybe Port -> Bool
|
||||
syntaxNodeIsEmbeddable parentType n mParentPort = case (parentType, n) of
|
||||
(ApplyParent, LikeApplyNode _ _) -> notResultPort
|
||||
(ApplyParent, LiteralNode _) -> notResultPort
|
||||
(CaseOrGuardParent, LiteralNode _) -> notResultPort
|
||||
_ -> False
|
||||
where
|
||||
notResultPort = case mParentPort of
|
||||
-- TODO Don't use hardcoded port number
|
||||
Just (Port 1) -> False
|
||||
_ -> True
|
||||
|
||||
-- | A syntaxNodeCanEmbed if it can contain other nodes
|
||||
syntaxNodeCanEmbed :: SyntaxNode -> Bool
|
||||
@ -44,21 +57,23 @@ parentTypeForNode n = case n of
|
||||
-- The NotAParent case should never occur.
|
||||
_ -> NotAParent
|
||||
|
||||
findParents :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
|
||||
findParents graph node = filter parentFilter $ ING.suc graph node where
|
||||
findNeighbors :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
|
||||
findNeighbors graph node = filter parentFilter $ ING.neighbors graph node where
|
||||
parentFilter parentNode = parentNode /= node
|
||||
|
||||
findChildren :: ING.Graph gr => gr a b -> ING.Node -> [ING.Node]
|
||||
findChildren = ING.pre
|
||||
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)
|
||||
|
||||
graphNodeIsEmbeddable :: ING.Graph gr => ParentType -> IngSyntaxGraph gr -> ING.Node -> Bool
|
||||
graphNodeIsEmbeddable parentType graph node = maybeBoolToBool $ fmap (syntaxNodeIsEmbeddable parentType) (lookupSyntaxNode graph node)
|
||||
|
||||
lookupSyntaxNode :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
|
||||
lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
|
||||
|
||||
@ -81,10 +96,20 @@ findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
|
||||
labelledEdges = ING.lneighbors graph node1
|
||||
matchingEdges = find ((== node2) . snd) labelledEdges
|
||||
|
||||
findParentsThatCanEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
|
||||
findParentsThatCanEmbed graph child = filter parentFilter (findParents graph child) where
|
||||
parentFilter parentNode = graphNodeCanEmbed graph parentNode && graphNodeIsEmbeddable parentType graph child where
|
||||
parentType = lookupParentType graph parentNode
|
||||
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
|
||||
@ -92,16 +117,22 @@ findEdge graph fromNode toNode = lookup toNode $ ING.lsuc graph fromNode
|
||||
|
||||
parentIsOnlyEdge :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ING.Node -> Bool
|
||||
parentIsOnlyEdge graph parent child = case findEdge graph child parent of
|
||||
Nothing -> error "parentIsOnlyEdge: There is no edge from the child to the parent."
|
||||
Nothing -> case findEdge graph parent child of
|
||||
Nothing -> error "parentIsOnlyEdge: There is no edge from the child to the parent."
|
||||
-- TODO Finish this case
|
||||
Just edge -> numEdges == 1 where
|
||||
(parentNamePort, _) = edgeConnection edge
|
||||
edgeLabels = filter (parentNamePort ==) $ (fst . edgeConnection . snd) <$> ING.lsuc graph parent
|
||||
numEdges = length edgeLabels
|
||||
Just edge -> numEdges == 1 where
|
||||
(childNamePort, _) = edgeConnection edge
|
||||
edgeLabels = filter (childNamePort ==) $ (fst . edgeConnection . snd) <$> ING.lsuc graph child
|
||||
numEdges = length edgeLabels
|
||||
|
||||
findParentThatWillEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Maybe ING.Node
|
||||
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 parent child
|
||||
[parent] -> if parentIsOnlyEdge graph (snd parent) child
|
||||
then Just parent
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
@ -146,13 +177,14 @@ collapseTree originalGraph oldGraph rootNode = case childrenToEmbed of
|
||||
-- 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"
|
||||
childrenToEmbed = findChildrenToEmbed rootNode originalGraph
|
||||
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 childrenToEmbed graphWithEmbeddedChildren
|
||||
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
|
||||
@ -162,29 +194,29 @@ collapseTree originalGraph oldGraph rootNode = case childrenToEmbed of
|
||||
-- 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.Node]
|
||||
findChildrenToEmbed :: ING.Graph gr => ING.Node -> IngSyntaxGraph gr -> ING.Adj (DirectionalEdge Edge)-- [ING.Node]
|
||||
findChildrenToEmbed node graph = if graphNodeCanEmbed graph node
|
||||
then childrenToEmbed
|
||||
else []
|
||||
where
|
||||
childrenToEmbed = filter (childCanBeEmbedded node graph) (findChildren graph node)
|
||||
childrenToEmbed = catMaybes $ fmap (childCanBeEmbedded node graph) (findNeighbors graph node)
|
||||
|
||||
childCanBeEmbedded :: ING.Graph gr => ING.Node -> IngSyntaxGraph gr -> ING.Node -> Bool
|
||||
childCanBeEmbedded parentNode graph child =
|
||||
maybeBoolToBool $ (== parentNode) <$> findParentThatWillEmbed graph child
|
||||
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
|
||||
|
||||
findChildEdgesToTransfer :: ING.Graph gr => ING.Node -> [ING.Node] -> gr a b-> [ING.LEdge b]
|
||||
findChildEdgesToTransfer parentNode nodes graph = concatMap makeLabelledGraphEdges nodes where
|
||||
makeLabelledGraphEdges childNode = changeEdgeToParent parentNode childNode <$>
|
||||
ING.inn graph childNode
|
||||
++
|
||||
filter (not. edgeGoesToParent parentNode) (ING.out graph childNode)
|
||||
edgesNotEqual :: Eq b => DirectionalEdge b -> ING.LEdge b -> Bool
|
||||
edgesNotEqual dirEdge (_, _, e) = e /= unwrapDirectionalEdge dirEdge
|
||||
|
||||
edgeGoesToParent :: ING.Node -> ING.LEdge b -> Bool
|
||||
edgeGoesToParent parentNode (fromNode, toNode, _)
|
||||
| parentNode == fromNode = True
|
||||
| parentNode == toNode = True
|
||||
| otherwise = False
|
||||
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)
|
||||
|
@ -303,7 +303,7 @@ evalGuardedRhss c rhss = do
|
||||
|
||||
-- This is in Translate and not Translate core since currently it is only used by evalLit.
|
||||
makeLiteral :: (Show x) => x -> State IDState (SyntaxGraph, NameAndPort)
|
||||
makeLiteral = makeBox. show
|
||||
makeLiteral = makeBox . show
|
||||
|
||||
evalLit :: Exts.Literal -> State IDState (SyntaxGraph, NameAndPort)
|
||||
evalLit (Exts.Int x) = makeLiteral x
|
||||
|
@ -90,7 +90,11 @@ edgesForRefPortList inPattern portExpPairs = mconcat $ fmap makeGraph portExpPai
|
||||
Left str -> if inPattern
|
||||
then SyntaxGraph mempty mempty mempty [(str, Right port)] mempty
|
||||
else SyntaxGraph mempty mempty [(str, port)] mempty mempty
|
||||
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds (resultPort, port)] mempty mempty mempty
|
||||
Right resultPort -> SyntaxGraph mempty [Edge edgeOpts noEnds connection] mempty mempty mempty where
|
||||
connection = if inPattern
|
||||
-- If in a pattern, then the port on the case icon is the data source.
|
||||
then (port, resultPort)
|
||||
else (resultPort, port)
|
||||
|
||||
combineExpressions :: Bool -> [(GraphAndRef, NameAndPort)] -> SyntaxGraph
|
||||
combineExpressions inPattern portExpPairs = mconcat $ fmap makeGraph portExpPairs where
|
||||
|
Loading…
Reference in New Issue
Block a user