diff --git a/app/Translate.hs b/app/Translate.hs index fa53447..68f0808 100644 --- a/app/Translate.hs +++ b/app/Translate.hs @@ -364,22 +364,23 @@ evalLet :: EvalContext -> Binds -> Exp -> State IDState (SyntaxGraph, Reference) evalLet context binds e = evalGeneralLet (`evalExp` e) context binds -- TODO: Refactor this with evalPatBind -evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, NameAndPort) +evalPatAndRhs :: EvalContext -> Pat -> Rhs -> Maybe Binds -> State IDState (Bool, SyntaxGraph, Reference, Reference) evalPatAndRhs c pat rhs maybeWhereBinds = do patternNames <- namesInPattern <$> evalPattern pat let rhsContext = patternNames <> c - -- TODO: remove coerceExpressionResult - (rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext >>= coerceExpressionResult + (rhsGraph, rhsRef) <- rhsWithBinds maybeWhereBinds rhs rhsContext (patGraph, patRef) <- evalPattern pat let grWithEdges = makeEdges (rhsGraph <> patGraph) - -- The pattern and rhs are conneted if makeEdges added extra edges. - patRhsAreConnected = + lookedUpRhsRef = lookupReference (sgSources grWithEdges) rhsRef + -- The pattern and rhs are conneted if makeEdges added extra edges, or if the rhsRef refers to a source + -- in the pattern + patRhsAreConnected = (rhsRef /= lookedUpRhsRef) || length (sgEdges grWithEdges) > (length (sgEdges rhsGraph) + length (sgEdges patGraph)) - pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, rhsRef) + pure (patRhsAreConnected, deleteBindings grWithEdges, patRef, lookedUpRhsRef) -- returns (combined graph, pattern reference, rhs reference) -evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, NameAndPort) +evalAlt :: EvalContext -> Exts.Alt -> State IDState (Bool, SyntaxGraph, Reference, Reference) evalAlt c (Exts.Alt _ pat rhs maybeBinds) = evalPatAndRhs c pat rhs maybeBinds evalCase :: EvalContext -> Exp -> [Alt] -> State IDState (SyntaxGraph, NameAndPort) @@ -399,12 +400,15 @@ evalCase c e alts = do (connectedRhss, unConnectedRhss) = partition fst rhsEdges resultIconNames <- replicateM numAlts (getUniqueName "caseResult") let - makeCaseResult resultIconName rhsPort = syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges - where - rhsNewIcons = [(resultIconName, CaseResultNode)] - rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] + makeCaseResult :: NodeName -> Reference -> SyntaxGraph + makeCaseResult resultIconName rhsRef = case rhsRef of + Left _ -> mempty + Right rhsPort -> syntaxGraphFromNodesEdges rhsNewIcons rhsNewEdges + where + rhsNewIcons = [(resultIconName, CaseResultNode)] + rhsNewEdges = [makeSimpleEdge (rhsPort, justName resultIconName)] caseResultGraphs = mconcat $ zipWith makeCaseResult resultIconNames (fmap (fst . snd) connectedRhss) - filteredRhsEdges = mapFst Right $ fmap snd unConnectedRhss + filteredRhsEdges = fmap snd unConnectedRhss patternEdgesGraph = edgesForRefPortList True patEdges caseEdgeGraph = edgesForRefPortList False (expEdge : filteredRhsEdges) finalGraph = mconcat [patternEdgesGraph, caseResultGraphs, expGraph, caseEdgeGraph, caseGraph, combindedAltGraph] diff --git a/app/Types.hs b/app/Types.hs index cd16ba4..5df0832 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -48,7 +48,6 @@ data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord) -- TODO remove Ints from SyntaxNode data constructors. --- TODO Add NestedApplyNode, and NestedPatternApplyNode data SyntaxNode = LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition | NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)] diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs index ed41e51..0712c40 100644 --- a/test/VisualTranslateTests.hs +++ b/test/VisualTranslateTests.hs @@ -115,7 +115,8 @@ caseTests = [ "y = case x of {Foo a -> f a; Bar a -> f a}", "y = case x of {F x -> x; G x -> x}", "y = case x of {F -> 0; G -> 1}", - "z = case x of {0 -> 1; y -> y}" + "z = case x of {0 -> 1; y -> y}", + "y x = case f x of {0 -> x; Foo x -> x}" ] guardTests :: [String]