Refactor the NestedApply Icon.

2024-08-16 18:30:36 +03:00 · 2018-10-28 02:16:17 -07:00 · 2018-10-28 02:16:17 -07:00 · ccee42c23e
commit ccee42c23e
parent 4b99c862a7
4 changed files with 47 additions and 61 deletions
--- 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)
--- 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
--- 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]
--- 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,