rgleichman/glance
1
1
Fork 0
mirror of https://github.com/rgleichman/glance.git synced 2024-08-17 02:40:28 +03:00
Code Issues Projects Releases Wiki Activity

Fix edge direction from case result to the optional case result port on the case node.

Browse Source
This commit is contained in:
Robbie Gleichman 2016-12-24 02:02:59 -08:00
parent e373a6bcc5
commit e1af41b9bf
3 changed files with 76 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

108
app/GraphAlgorithms.hs
View File

@ -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)

2
app/Translate.hs
View File

@ -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

6
app/TranslateCore.hs
View File

@ -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