From 6e04814723beee29b8781959d171f82d4cb1dd95 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Fri, 19 Jul 2019 00:35:31 -0700 Subject: [PATCH] Use Embedder for case and multi-if. --- app/GraphAlgorithms.hs | 22 ++++++---------- app/Icons.hs | 22 ++++++++++++---- app/Translate.hs | 2 +- app/TranslateCore.hs | 49 ++++++++++++++---------------------- app/Types.hs | 7 +++--- test/VisualRenderingTests.hs | 45 ++++++++++++++++++++------------- 6 files changed, 75 insertions(+), 72 deletions(-) diff --git a/app/GraphAlgorithms.hs b/app/GraphAlgorithms.hs index bf06cdf..bc057e5 100644 --- a/app/GraphAlgorithms.hs +++ b/app/GraphAlgorithms.hs @@ -6,7 +6,6 @@ module GraphAlgorithms( collapseAnnotatedGraph ) where -import Control.Arrow(first) import qualified Data.Graph.Inductive as ING import Data.List(foldl', find) import Data.Tuple(swap) @@ -16,7 +15,7 @@ import Constants(pattern ResultPortConst, pattern InputPortConst) import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..), CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode , AnnotatedGraph, EmbedInfo(..), EmbedDirection(..), NodeInfo(..) - , Embedder(..), Named(..), EmbedderSyntaxNode) + , Embedder(..), Named(..), EmbedderSyntaxNode, NodeName) import Util(fromMaybeError) {-# ANN module "HLint: ignore Use record patterns" #-} @@ -91,8 +90,8 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort parentTypeForNode :: SyntaxNode -> ParentType parentTypeForNode n = case n of (ApplyNode _ _) -> ApplyParent - CaseOrMultiIfNode CaseTag _ _ -> CaseParent - CaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent + CaseOrMultiIfNode CaseTag _ -> CaseParent + CaseOrMultiIfNode MultiIfTag _ -> MultiIfParent (FunctionDefNode _ _) -> LambdaParent _ -> NotAParent @@ -177,16 +176,10 @@ changeNodeLabel node newLabel graph = case ING.match node graph of -> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph (Nothing, _) -> graph --- TODO Change CaseOrMultiIfNode to use Embedder, then simplify the --- type of children. addChildrenToNodeLabel :: - [(SgNamedNode, Edge)] -> EmbedderSyntaxNode -> EmbedderSyntaxNode + [(NodeName, Edge)] -> EmbedderSyntaxNode -> EmbedderSyntaxNode addChildrenToNodeLabel children (Embedder existingNodes oldSyntaxNode) - = case oldSyntaxNode of - CaseOrMultiIfNode tag x caseExistingNodes - -> Embedder [] $ CaseOrMultiIfNode tag x - (children <> caseExistingNodes) - _ -> Embedder (fmap (first naName) children <> existingNodes) oldSyntaxNode + = Embedder (children <> existingNodes) oldSyntaxNode -- | Change the node label of the parent to be nested. embedChildSyntaxNode :: ING.DynGraph gr => @@ -209,8 +202,9 @@ embedChildSyntaxNode parentNode childNode oldGraph = newGraph $ changeNodeLabel parentNode newNodeLabel oldGraph where Named nodeName oldSyntaxNode = oldNodeLabel - newSyntaxNode - = addChildrenToNodeLabel [(childNodeLab, edge)] oldSyntaxNode + newSyntaxNode = addChildrenToNodeLabel + [(naName childNodeLab, edge)] + oldSyntaxNode newNodeLabel = NodeInfo isChild (Named nodeName newSyntaxNode) collapseEdge :: (HasCallStack, ING.DynGraph gr) diff --git a/app/Icons.hs b/app/Icons.hs index 9e0ac57..634f4b9 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -105,8 +105,12 @@ iconToDiagram iconInfo icon = case icon of ((fmap . fmap) (findIconFromName iconInfo) args) NestedPApp constructor args -> nestedPAppDia iconInfo (repeat $ patternC colorScheme) constructor args - NestedCaseIcon args -> nestedCaseDia iconInfo args - NestedMultiIfIcon args -> nestedMultiIfDia iconInfo args + NestedCaseIcon args -> nestedCaseDia + iconInfo + ((fmap . fmap) (findIconFromName iconInfo) args) + NestedMultiIfIcon args -> nestedMultiIfDia + iconInfo + ((fmap . fmap) (findIconFromName iconInfo) args) -- BEGIN getPortAngles -- @@ -221,9 +225,17 @@ getPortAngles iconInfo icon port maybeNodeName = case icon of port maybeNodeName NestedCaseIcon args - -> nestedMultiIfPortAngles iconInfo args port maybeNodeName + -> nestedMultiIfPortAngles + iconInfo + ((fmap . fmap) (findIconFromName iconInfo) args) + port + maybeNodeName NestedMultiIfIcon args - -> nestedMultiIfPortAngles iconInfo args port maybeNodeName + -> nestedMultiIfPortAngles + iconInfo + ((fmap . fmap) (findIconFromName iconInfo) args) + port + maybeNodeName -- END getPortAngles -- @@ -256,7 +268,7 @@ argumentPorts n = case n of (ApplyNode _ _) -> defaultPorts PatternApplyNode _ _-> defaultPorts (FunctionDefNode _ _) -> defaultPorts - CaseOrMultiIfNode _ _ _-> defaultPorts + CaseOrMultiIfNode _ _ -> defaultPorts NameNode _ -> [] BindNameNode _ -> [] LiteralNode _ -> [] diff --git a/app/Translate.hs b/app/Translate.hs index 9cf5d0a..6174d33 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -458,7 +458,7 @@ evalCaseHelper numAlts caseIconName resultIconNames where (patRhsConnected, altGraphs, patRefs, rhsRefs, asNames) = unzip5 evaledAlts combindedAltGraph = mconcat altGraphs - caseNode = CaseOrMultiIfNode CaseTag numAlts [] + caseNode = CaseOrMultiIfNode CaseTag numAlts icons = [Named caseIconName (mkEmbedder caseNode)] caseGraph = syntaxGraphFromNodes icons expEdge = (expRef, nameAndPort caseIconName (inputPort caseNode)) diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index 1121296..2bfbf9d 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -28,7 +28,6 @@ module TranslateCore( initialIdState ) where -import Control.Arrow(first) import Control.Monad.State(State, state) import Data.Either(partitionEithers) import qualified Data.Graph.Inductive.Graph as ING @@ -41,7 +40,7 @@ import Icons(inputPort, resultPort, argumentPorts, multiIfRhsPorts import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..) , NameAndPort(..), IDState, SgNamedNode, NodeName(..), Port , LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..) - , NamedIcon, Embedder(..), mkEmbedder, Named(..) + , Embedder(..), mkEmbedder, Named(..) , EmbedderSyntaxNode) import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool , nodeNameToInt) @@ -202,7 +201,7 @@ makeMultiIfGraph :: makeMultiIfGraph numPairs multiIfName bools exps = (newGraph, nameAndPort multiIfName (resultPort multiIfNode)) where - multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs [] + multiIfNode = CaseOrMultiIfNode MultiIfTag numPairs expsWithPorts = zip exps $ map (nameAndPort multiIfName) multiIfRhsPorts boolsWithPorts = zip bools $ map (nameAndPort multiIfName) multiIfBoolPorts combindedGraph = combineExpressions False $ expsWithPorts <> boolsWithPorts @@ -292,18 +291,20 @@ nodeToIcon (Embedder embeddedNodes node) = case node of (FunctionDefNode labels bodyNodes) -> nestedLambdaToIcon labels embeddedNodes bodyNodes CaseResultNode -> CaseResultIcon - (CaseOrMultiIfNode tag x edges) - -> nestedCaseOrMultiIfNodeToIcon tag x edges + (CaseOrMultiIfNode tag x) + -> nestedCaseOrMultiIfNodeToIcon tag x embeddedNodes -makeArg :: [(SgNamedNode, Edge)] -> Port -> Maybe NamedIcon -makeArg args port = case find (findArg port) args of - Nothing -> Nothing - Just (Named argName argSyntaxNode, _) - -> Just $ Named argName (nodeToIcon argSyntaxNode) +-- | Helper for makeArg +findArg :: Port -> (NodeName, Edge) -> Bool +findArg currentPort + (argName + , Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) + | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort + | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort + | otherwise = False -- This case should never happen --- TOOD Change all the types so that makeArg' becomes makeArg. -makeArg' :: [(NodeName, Edge)] -> Port -> Maybe NodeName -makeArg' args port = fst <$> find (findArg' port) args +makeArg :: [(NodeName, Edge)] -> Port -> Maybe NodeName +makeArg args port = fst <$> find (findArg port) args nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int @@ -314,8 +315,8 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = where dummyNode = ApplyNode flavor numArgs argPorts = take numArgs (argumentPorts dummyNode) - headIcon = makeArg' args (inputPort dummyNode) - argList = fmap (makeArg' args) argPorts + headIcon = makeArg args (inputPort dummyNode) + argList = fmap (makeArg args) argPorts nestedLambdaToIcon :: [String] -- labels -> [(NodeName, Edge)] -- embedded icons @@ -325,18 +326,18 @@ nestedLambdaToIcon labels embeddedNodes = LambdaIcon labels embeddedBodyNode where dummyNode = FunctionDefNode [] [] - embeddedBodyNode = makeArg' embeddedNodes (inputPort dummyNode) + embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode) nestedCaseOrMultiIfNodeToIcon :: CaseOrMultiIfTag -> Int - -> [(SgNamedNode, Edge)] + -> [(NodeName, Edge)] -> Icon nestedCaseOrMultiIfNodeToIcon tag numArgs args = case tag of CaseTag -> NestedCaseIcon argList MultiIfTag -> NestedMultiIfIcon argList where - dummyNode = CaseOrMultiIfNode CaseTag numArgs [] + dummyNode = CaseOrMultiIfNode CaseTag numArgs argPorts = take (2 * numArgs) $ argumentPorts dummyNode argList = fmap (makeArg args) (inputPort dummyNode : argPorts) @@ -346,18 +347,6 @@ nestedPatternNodeToIcon str children = NestedPApp -- Why so many fmaps? ( (fmap . fmap . fmap . fmap) nodeToIcon children) -findArg :: Port -> (SgNamedNode, Edge) -> Bool -findArg currentPort arg - = findArg' currentPort (first naName arg) - -findArg' :: Port -> (NodeName, Edge) -> Bool -findArg' currentPort - (argName - , Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort)) - | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort - | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort - | otherwise = False -- This case should never happen - makeLNode :: SgNamedNode -> ING.LNode SgNamedNode makeLNode namedNode@(Named (NodeName name) _) = (name, namedNode) diff --git a/app/Types.hs b/app/Types.hs index d56d2c4..d8aac3c 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -80,8 +80,8 @@ data Icon = TextBoxIcon String | NestedPApp (Labeled (Maybe NamedIcon)) -- Data constructor [Labeled (Maybe NamedIcon)] -- Arguments - | NestedCaseIcon [Maybe NamedIcon] - | NestedMultiIfIcon [Maybe NamedIcon] + | NestedCaseIcon [Maybe NodeName] + | NestedMultiIfIcon [Maybe NodeName] deriving (Show, Eq, Ord) data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor @@ -116,8 +116,7 @@ data SyntaxNode = [String] -- Parameter labels [NodeName] -- Nodes inside the lambda | CaseResultNode -- TODO remove caseResultNode - -- TODO Move CaseOrMultiIfNode's embedded nodes to Embedder. - | CaseOrMultiIfNode CaseOrMultiIfTag Int [(SgNamedNode, Edge)] + | CaseOrMultiIfNode CaseOrMultiIfTag Int deriving (Show, Eq, Ord) newtype Port = Port Int deriving (Typeable, Eq, Ord, Show) diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs index 0ce5db1..7b45a11 100644 --- a/test/VisualRenderingTests.hs +++ b/test/VisualRenderingTests.hs @@ -18,41 +18,50 @@ import Util(iconToPort, tupleToNamed) iconToIntPort :: NodeName -> NodeName -> Int -> Edge iconToIntPort x y p = iconToPort x y (Port p) -n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10 :: NodeName +n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10 :: NodeName nodeNames :: [NodeName] -nodeNames@[n0, n1, _n2, n3, _n4, n5, _n6, _n7, _n8, _n9, n10] +nodeNames@[n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10] = fmap NodeName [0..10] ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10 :: Icon -> NamedIcon [ni0, ni1, ni2, ni3, ni4, ni5, ni6, ni7, ni8, ni9, ni10] = fmap Named nodeNames +textBoxIcons :: [NamedIcon] +textBoxIcons = + [ ni2 (TextBoxIcon "n2") + , ni4 (TextBoxIcon "n4") + , ni10 $ TextBoxIcon "n10" + , ni6 (TextBoxIcon "n6") + , ni7 (TextBoxIcon "n7") + , ni8 (TextBoxIcon "n8") + , ni9 (TextBoxIcon "n9")] + -- TODO refactor these Drawings nestedCaseDrawing :: Drawing nestedCaseDrawing = Drawing icons [] where - icons = fmap tupleToNamed [ + icons = textBoxIcons <> fmap tupleToNamed [ (n0, NestedCaseIcon [Nothing, Nothing, Nothing]), - (n1, NestedCaseIcon [Nothing, Just $ ni2 (TextBoxIcon "n2"), Nothing]), - (n3, NestedCaseIcon [Nothing, Nothing, Just $ ni4 (TextBoxIcon "n4")]), + (n1, NestedCaseIcon [Nothing, Just n2, Nothing]), + (n3, NestedCaseIcon [Nothing, Nothing, Just n4]), (n5, NestedCaseIcon [Nothing, - Just $ ni6 (TextBoxIcon "n6"), - Just $ ni7 (TextBoxIcon "n7"), - Just $ ni8 (TextBoxIcon "n8"), - Just $ ni9 (TextBoxIcon "n9")]) + Just n6, + Just n7, + Just n8, + Just n9]) ] nestedMultiIfDrawing :: Drawing nestedMultiIfDrawing = Drawing icons edges where - icons = [ - ni10 $ TextBoxIcon "n10" - , ni0 $ NestedMultiIfIcon [Nothing, Nothing, Nothing] - , ni1 $ NestedMultiIfIcon [Nothing, Just $ ni2 (TextBoxIcon "n2"), Nothing] - , ni3 $ NestedMultiIfIcon [Nothing, Nothing, Just $ ni4 (TextBoxIcon "n4")] + icons = textBoxIcons <> + [ ni0 $ NestedMultiIfIcon [Nothing, Nothing, Nothing] + , ni1 $ NestedMultiIfIcon [Nothing, Just n2, Nothing] + , ni3 $ NestedMultiIfIcon [Nothing, Nothing, Just n4] , ni5 $ NestedMultiIfIcon [Nothing, - Just $ ni6 (TextBoxIcon "n6"), - Just $ ni7 (TextBoxIcon "n7"), - Just $ ni8 (TextBoxIcon "n8"), - Just $ ni9 (TextBoxIcon "n9")] + Just n6, + Just n7, + Just n8, + Just n9] ] edges = [ iconToIntPort n10 n5 0