diff --git a/app/Icons.hs b/app/Icons.hs index 843553f..f7063f6 100644 --- a/app/Icons.hs +++ b/app/Icons.hs @@ -57,8 +57,10 @@ lineCol = lineC colorScheme iconToDiagram :: SpecialBackend b n => Icon -> TransformableDia b n iconToDiagram icon = case icon of - ApplyAIcon n -> nestedApplyDia ApplyNodeFlavor $ replicate (1 + n) Nothing - ComposeIcon n -> nestedApplyDia ComposeNodeFlavor $ replicate (1 + n) Nothing + ApplyAIcon n -> + nestedApplyDia ApplyNodeFlavor Nothing $ replicate (1 + n) Nothing + ComposeIcon n -> + nestedApplyDia ComposeNodeFlavor Nothing $ replicate (1 + n) Nothing PAppIcon n str -> generalTextAppDia (patternTextC colorScheme) (patternC colorScheme) n str TextBoxIcon s -> textBox s BindTextBoxIcon s -> identDiaFunc $ bindTextBox s @@ -66,7 +68,7 @@ iconToDiagram icon = case icon of CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing CaseResultIcon -> identDiaFunc caseResult FlatLambdaIcon x -> flatLambda x - NestedApply flavor args -> nestedApplyDia flavor args + NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args NestedPApp args -> nestedPAppDia (repeat $ patternC colorScheme) args NestedCaseIcon args -> nestedCaseDia args NestedGuardIcon args -> nestedGuardDia args @@ -96,7 +98,7 @@ guardPortAngles (Port port) = case port of findNestedIcon :: NodeName -> Icon -> Maybe Icon findNestedIcon name icon = case icon of - NestedApply _ args -> snd <$> findIcon name args + NestedApply _ headIcon args -> snd <$> findIcon name (headIcon : args) NestedPApp args -> snd <$> findIcon name (fmap fst args) _ -> Nothing @@ -113,13 +115,17 @@ findIcon name args = icon where Nothing -> Nothing Just x -> Just (argNum, x) -generalNestedPortAngles :: SpecialNum n => - (Port -> [Angle n]) -> [Maybe NamedIcon] -> Port -> Maybe NodeName -> [Angle n] -generalNestedPortAngles defaultAngles args port maybeNodeName = case maybeNodeName of - Nothing -> defaultAngles port - Just name -> case findIcon name args of - Nothing -> [] - Just (_, icon) -> getPortAngles icon port Nothing +generalNestedPortAngles :: SpecialNum n + => (Port -> [Angle n]) + -> Maybe NamedIcon + -> [Maybe NamedIcon] + -> Port -> Maybe NodeName -> [Angle n] +generalNestedPortAngles defaultAngles headIcon args port maybeNodeName = + case maybeNodeName of + Nothing -> defaultAngles port + Just name -> case findIcon name (headIcon : args) of + Nothing -> [] + Just (_, icon) -> getPortAngles icon port Nothing reflectXAngle :: SpecialNum n => Angle n -> Angle n reflectXAngle x = reflectedAngle where @@ -152,8 +158,11 @@ getPortAngles icon port maybeNodeName = case icon of CaseIcon _ -> guardPortAngles port CaseResultIcon -> [] FlatLambdaIcon _ -> applyPortAngles port - NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName - NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName + NestedApply _ headIcon args -> + generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName + NestedPApp (headIcon : args) -> + generalNestedPortAngles + pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName @@ -322,12 +331,15 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where innerLevel = if func then nestingLevel else nestingLevel + 1 - -generalNestedDia :: SpecialBackend b n => - (Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe NamedIcon] -> TransformableDia b n -generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of +generalNestedDia :: SpecialBackend b n + => (Colour Double -> SpecialQDiagram b n) + -> [Colour Double] + -> Maybe NamedIcon + -> [Maybe NamedIcon] + -> TransformableDia b n +generalNestedDia dia borderCols maybeFunText funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of [] -> mempty - (maybeFunText:args) -> centerXY $ transformedText ||| centerY finalDia + args -> centerXY $ transformedText ||| centerY finalDia where borderCol = borderCols !! nestingLevel @@ -351,8 +363,11 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an makeInnerIcon func _ (Just (NamedIcon iconNodeName icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where innerLevel = if func then nestingLevel else nestingLevel + 1 -nestedApplyDia :: SpecialBackend b n => - LikeApplyFlavor -> [Maybe NamedIcon] -> TransformableDia b n +nestedApplyDia :: SpecialBackend b n + => LikeApplyFlavor + -> Maybe NamedIcon + -> [Maybe NamedIcon] + -> TransformableDia b n nestedApplyDia flavor = case flavor of ApplyNodeFlavor -> generalNestedDia apply0Triangle (nestingC colorScheme) ComposeNodeFlavor -> generalNestedDia composeSemiCircle (repeat $ apply1C colorScheme) diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs index ed08390..c2c4df5 100644 --- a/app/TranslateCore.hs +++ b/app/TranslateCore.hs @@ -265,12 +265,17 @@ makeArg args port = case find (findArg port) args of Nothing -> Nothing Just (SgNamedNode argName argSyntaxNode, _) -> Just $ NamedIcon argName (nodeToIcon argSyntaxNode) -nestedApplySyntaxNodeToIcon :: LikeApplyFlavor -> Int -> [(SgNamedNode, Edge)] -> Icon -nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList where - -- argList should be of length numArgs + 1, since argList includes the function expression - dummyNode = LikeApplyNode flavor numArgs - argPorts = take numArgs (argumentPorts dummyNode) - argList = fmap (makeArg args) (inputPort dummyNode : argPorts) +nestedApplySyntaxNodeToIcon :: LikeApplyFlavor + -> Int + -> [(SgNamedNode, Edge)] + -> Icon +nestedApplySyntaxNodeToIcon flavor numArgs args = + NestedApply flavor headIcon argList + where + dummyNode = LikeApplyNode flavor numArgs + argPorts = take numArgs (argumentPorts dummyNode) + headIcon = makeArg args (inputPort dummyNode) + argList = fmap (makeArg args) argPorts nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of diff --git a/app/Types.hs b/app/Types.hs index a478854..e4bf211 100644 --- a/app/Types.hs +++ b/app/Types.hs @@ -39,9 +39,9 @@ data Icon = TextBoxIcon String | GuardIcon Int | FlatLambdaIcon [String] | ApplyAIcon Int | ComposeIcon Int | PAppIcon Int String | CaseIcon Int | CaseResultIcon | BindTextBoxIcon String - -- TODO: NestedApply should have the type NestedApply (Maybe NamedIcon) [Maybe NamedIcon] | NestedApply LikeApplyFlavor -- apply or compose + (Maybe NamedIcon) -- The function for apply, or the argument for compose [Maybe NamedIcon] -- list of arguments or functions | NestedPApp [(Maybe NamedIcon, String)] | NestedCaseIcon [Maybe NamedIcon] diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs index 6116c90..a807751 100644 --- a/test/VisualRenderingTests.hs +++ b/test/VisualRenderingTests.hs @@ -158,39 +158,6 @@ arrowTestDrawing = Drawing arrowTestIcons arrowTestEdges where iconToIconEnds arr1 EndAp1Arg arr4 EndAp1Arg ] -nestedTextDrawing :: Drawing -nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where - [n1, t1, t2, inner, t, n2, n3, foo, in1, n4] = fmap NodeName [0..9] - nestedTestIcons = fmap tupleToNamedIcon [ - (n1, NestedApply ApplyNodeFlavor args), - (t1, TextBoxIcon "T1"), - (t2, TextBoxIcon "t2") - ] - where - innerArgs = fmap (fmap tupleToNamedIcon) [ - Just (inner, TextBoxIcon "inner"), - Just (t, TextBoxIcon "t"), - Nothing, - Just (n2, - NestedApply - ApplyNodeFlavor - (fmap (fmap tupleToNamedIcon) [Just (n4, TextBoxIcon "N4"), Nothing])) - ] - args = fmap (fmap tupleToNamedIcon) [ - Just (n3, TextBoxIcon "n3"), - Nothing, - Just (foo, TextBoxIcon "3"), - Just (in1, NestedApply ApplyNodeFlavor innerArgs) - ] - nestedTestEdges = [ - iconToIntPort t1 n1 2, - --iconToIntPort "t1" "in" 1, - --iconToIntPort "t2" ("n1" .> "in") 3, - --iconToIntPort "t2" ("n1" .> "in" .> "n2") 2 - -- TODO This edge is not drawn currently. See todo in drawingToIconGraph in Rendering. - iconToIntPort t2 n2 2 - ] - -- TODO refactor these Drawings nestedCaseDrawing :: Drawing nestedCaseDrawing = Drawing icons [] where @@ -255,7 +222,6 @@ renderTests = do fact1Drawing, fact2Drawing, arrowTestDrawing, - nestedTextDrawing, nestedCaseDrawing, nestedGuardDrawing, flatCaseDrawing,