From 11fbdfebd84ae997eeebdd4001cd2a08d957531a Mon Sep 17 00:00:00 2001
From: Robbie Gleichman <rgleichman@gmail.com>
Date: Fri, 10 May 2019 23:10:57 -0700
Subject: [PATCH] Embed literal lambda bodies.

---
 app/GraphAlgorithms.hs       | 16 +++++++++++++++-
 app/Icons.hs                 | 27 ++++++++++++++++++---------
 app/Rendering.hs             |  2 +-
 app/Translate.hs             |  2 +-
 app/TranslateCore.hs         | 13 ++++++++++++-
 app/Types.hs                 |  4 +++-
 test/VisualRenderingTests.hs | 19 ++++++++++++++++---
 todo.md                      |  3 ++-
 8 files changed, 68 insertions(+), 18 deletions(-)

diff --git a/app/GraphAlgorithms.hs b/app/GraphAlgorithms.hs
index ac5349c..9260f6c 100644
--- a/app/GraphAlgorithms.hs
+++ b/app/GraphAlgorithms.hs
@@ -22,6 +22,7 @@ import Util(sgNamedNodeToSyntaxNode)
 data ParentType = ApplyParent
                 | CaseParent
                 | MultiIfParent
+                | LambdaParent
                 | NotAParent
   deriving (Eq, Show)
 
@@ -48,9 +49,14 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
   = case (parentType, syntaxNode) of
       (ApplyParent, ApplyNode _ _ _) -> parentPortNotResult
       (ApplyParent, LiteralNode _) -> parentPortNotResult
-      (ApplyParent, FunctionDefNode _ _)
+      (ApplyParent, FunctionDefNode _ _ _)
         -> isInput mParentPort && isResult mChildPort
 
+      -- (LambdaParent, ApplyNode _ _ _) -> parentPortIsInput
+      (LambdaParent, LiteralNode _) -> parentPortIsInput
+      -- (LambdaParent, FunctionDefNode _ _)
+      --   -> parentPortIsInput
+
       (CaseParent, LiteralNode _) -> parentPortNotResult
       (CaseParent, ApplyNode _ _ _)
         -> parentPortNotResult && parentPortNotInput
@@ -72,6 +78,8 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
       Just ResultPortConst -> True
       Just _ -> False
 
+    parentPortIsInput = isInput mParentPort
+
     parentPortNotInput = not $ isInput mParentPort
     parentPortNotResult = not $ isResult mParentPort
 
@@ -80,6 +88,7 @@ parentTypeForNode n = case n of
   ApplyNode _ _ _ -> ApplyParent
   CaseOrMultiIfNode CaseTag _ _ -> CaseParent
   CaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
+  FunctionDefNode _ _ _ -> LambdaParent
   _ -> NotAParent
 
 lookupSyntaxNode :: ING.Graph gr =>
@@ -186,6 +195,11 @@ embedChildSyntaxNode parentNode childNode oldGraph = newGraph
             CaseOrMultiIfNode tag x existingNodes
               -> CaseOrMultiIfNode tag x
                  (childrenAndEdgesToParent <> existingNodes)
+            FunctionDefNode labels existingNodes innerNodes
+              -> FunctionDefNode
+                 labels
+                 (childrenAndEdgesToParent <> existingNodes)
+                 innerNodes
             _ -> oldSyntaxNode
 
 changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
diff --git a/app/Icons.hs b/app/Icons.hs
index 614a1f8..8ef8198 100644
--- a/app/Icons.hs
+++ b/app/Icons.hs
@@ -79,7 +79,7 @@ iconToDiagram icon = case icon of
   MultiIfIcon n -> nestedMultiIfDia $ replicate (1 + (2 * n)) Nothing
   CaseIcon n -> nestedCaseDia $ replicate (1 + (2 * n)) Nothing
   CaseResultIcon -> identDiaFunc caseResult
-  FlatLambdaIcon x _ -> flatLambda x
+  LambdaIcon x bodyExp _ -> nestedLambda x bodyExp
   NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args
   NestedPApp constructor args
     -> nestedPAppDia (repeat $ patternC colorScheme) constructor args
@@ -173,7 +173,7 @@ getPortAngles icon port maybeNodeName = case icon of
   MultiIfIcon _ -> multiIfPortAngles port
   CaseIcon _ -> multiIfPortAngles port
   CaseResultIcon -> []
-  FlatLambdaIcon _ _ -> applyPortAngles port
+  LambdaIcon _ _ _ -> applyPortAngles port
   NestedApply _ headIcon args ->
     generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
   NestedPApp headIcon args ->
@@ -212,7 +212,7 @@ argumentPorts :: SyntaxNode -> [Port]
 argumentPorts n = case n of
   ApplyNode _ _ _ -> defaultPorts
   PatternApplyNode _ _-> defaultPorts
-  FunctionDefNode _ _ -> defaultPorts
+  FunctionDefNode _ _ _ -> defaultPorts
   CaseOrMultiIfNode _ _ _-> defaultPorts
   NameNode _ -> []
   BindNameNode _ -> []
@@ -290,9 +290,9 @@ resultIcon =  lw none $ fc (lamArgResC colorScheme) unitSquare
 
 makeAppInnerIcon :: SpecialBackend b n =>
   TransformParams n ->
-  Bool ->
-  Port ->
-  Labeled (Maybe NamedIcon) ->
+  Bool ->  -- If False then add one to the nesting level.
+  Port ->  -- Port number (if the NamedIcon is Nothing)
+  Labeled (Maybe NamedIcon) ->  -- The icon
   SpecialQDiagram b n
 makeAppInnerIcon (TransformParams name _ reflect angle) _ portNum
   (Labeled Nothing str)
@@ -641,9 +641,12 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
 -- 0: Result icon
 -- 1: The lambda function value
 -- 2,3.. : The parameters
-flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
-flatLambda paramNames (TransformParams name _ reflect angle)
-  = centerXY $ named name finalDia
+nestedLambda :: SpecialBackend b n
+           => [String]
+           -> Maybe NamedIcon
+           -> TransformableDia b n
+nestedLambda paramNames mBodyExp (TransformParams name level reflect angle)
+  = centerXY $ bodyExpIcon ||| centerY (named name finalDia)
   where
   lambdaCircle
     = lwG defaultLineWidth
@@ -654,6 +657,12 @@ flatLambda paramNames (TransformParams name _ reflect angle)
       :
       (portIcons
         ++ [makeQualifiedPort name ResultPortConst <> alignR lambdaCircle])
+  bodyExpIcon = case mBodyExp of
+    Nothing -> mempty
+    Just (NamedIcon bodyNodeName bodyIcon)
+      -> iconToDiagram
+         bodyIcon
+         (TransformParams bodyNodeName level reflect angle)
 
   portIcons
     = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
diff --git a/app/Rendering.hs b/app/Rendering.hs
index efd519a..de4fbc9 100644
--- a/app/Rendering.hs
+++ b/app/Rendering.hs
@@ -367,7 +367,7 @@ drawLambdaRegions placedNodes
     -- Also draw the region around the icon the lambda is in.
     drawRegion :: [NodeName] -> NamedIcon -> SpecialQDiagram b Double
     drawRegion parentNames icon = case icon of
-      NamedIcon _ (FlatLambdaIcon _ enclosedNames)
+      NamedIcon _ (LambdaIcon _ _ enclosedNames)
         -> regionRect $ fmap findDia (parentNames <> enclosedNames)
       NamedIcon parentName (NestedApply _ headIcon icons)
         -> mconcat
diff --git a/app/Translate.hs b/app/Translate.hs
index f7a46c0..37fab3d 100644
--- a/app/Translate.hs
+++ b/app/Translate.hs
@@ -531,7 +531,7 @@ evalLambda _ context patterns expr = do
   let
     paramNames = fmap patternName patternValsWithAsNames
     enclosedNodeNames = snnName <$> sgNodes combinedGraph
-    lambdaNode = FunctionDefNode paramNames enclosedNodeNames
+    lambdaNode = FunctionDefNode paramNames [] enclosedNodeNames
     lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
     patternGraph = mconcat $ fmap graphAndRefToGraph patternVals
 
diff --git a/app/TranslateCore.hs b/app/TranslateCore.hs
index 6a4c649..cb2cc49 100644
--- a/app/TranslateCore.hs
+++ b/app/TranslateCore.hs
@@ -285,7 +285,8 @@ nodeToIcon (PatternApplyNode s children)
 nodeToIcon (NameNode s) = TextBoxIcon s
 nodeToIcon (BindNameNode s) = BindTextBoxIcon s
 nodeToIcon (LiteralNode s) = TextBoxIcon s
-nodeToIcon (FunctionDefNode x names) = FlatLambdaIcon x names
+nodeToIcon (FunctionDefNode labels embeddedNodes bodyNodes)
+  = nestedLambdaToIcon labels embeddedNodes bodyNodes
 nodeToIcon CaseResultNode = CaseResultIcon
 nodeToIcon (CaseOrMultiIfNode tag x edges)
   = nestedCaseOrMultiIfNodeToIcon tag x edges
@@ -308,6 +309,16 @@ nestedApplySyntaxNodeToIcon flavor numArgs args =
     headIcon = makeArg args (inputPort dummyNode)
     argList = fmap (makeArg args) argPorts
 
+nestedLambdaToIcon :: [String]  -- labels
+                   -> [(SgNamedNode, Edge)]  -- embedded icons
+                   -> [NodeName]  -- body nodes
+                   -> Icon
+nestedLambdaToIcon labels embeddedNodes =
+  LambdaIcon labels embeddedBodyNode
+  where
+    dummyNode = FunctionDefNode [] [] []
+    embeddedBodyNode = makeArg embeddedNodes (inputPort dummyNode)
+
 nestedCaseOrMultiIfNodeToIcon ::
   CaseOrMultiIfTag
   -> Int
diff --git a/app/Types.hs b/app/Types.hs
index 6be8b95..20c3222 100644
--- a/app/Types.hs
+++ b/app/Types.hs
@@ -54,8 +54,9 @@ instance Applicative Labeled where
 data Icon = TextBoxIcon String
   | MultiIfIcon
     Int  -- Number of alternatives
-  | FlatLambdaIcon
+  | LambdaIcon
     [String]  -- Parameter labels
+    (Maybe NamedIcon)  -- Function body expression
     [NodeName]  -- Nodes inside the lambda
   | CaseIcon Int
   | CaseResultIcon
@@ -93,6 +94,7 @@ data SyntaxNode =
   | LiteralNode String -- Literal values like the string "Hello World"
   | FunctionDefNode  -- Function definition (ie. lambda expression)
     [String]  -- Parameter labels
+    [(SgNamedNode, Edge)]  -- Embedded nodes
     [NodeName]  -- Nodes inside the lambda
   | CaseResultNode -- TODO remove caseResultNode
   | CaseOrMultiIfNode CaseOrMultiIfTag Int [(SgNamedNode, Edge)]
diff --git a/test/VisualRenderingTests.hs b/test/VisualRenderingTests.hs
index dcca866..1937f74 100644
--- a/test/VisualRenderingTests.hs
+++ b/test/VisualRenderingTests.hs
@@ -15,9 +15,9 @@ import Util(iconToPort, tupleToNamedIcon)
 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
@@ -107,7 +107,19 @@ lambdaDia :: Drawing
 lambdaDia = Drawing icons []
   where
     icons = [
-      ni0 $ FlatLambdaIcon ["foo", "bar"] [n0, n1]
+      ni0 $ LambdaIcon ["foo", "bar"] Nothing [n0, n1]
+      , ni1 CaseResultIcon
+      , ni2 $ MultiIfIcon 3
+      ]
+
+nestedLambdaDia :: Drawing
+nestedLambdaDia = Drawing icons []
+  where
+    icons = [
+      ni0 $ LambdaIcon
+        ["baz", "cat"]
+        (Just $ NamedIcon n2 (TextBoxIcon "foobar"))
+        [n0, n1]
       , ni1 CaseResultIcon
       , ni2 $ MultiIfIcon 3
       ]
@@ -128,4 +140,5 @@ renderTests = do
       , nestedPAppDia
       , nestedApplyDia
       , lambdaDia
+      , nestedLambdaDia
       ]
diff --git a/todo.md b/todo.md
index 2e21fe5..32b77f1 100644
--- a/todo.md
+++ b/todo.md
@@ -1,7 +1,8 @@
 # Todo
 
 ## Todo Now
-* Let lambda icons embed results.
+* Let lambda icons embed more icons.
+* Refactor out embedded nodes from SyntaxNodes into a common data structure.
 * Redesign case to avoid non-locality.
 * Add command line flags for color style, embedding, and whether to draw arrowheads.
 * Add wiki pages discussing: Why a visual language?, History of Glance, How to contribute, Code guide [code style, ...], etc..