Case and guard icons can now embed literals.

app/GraphAlgorithms.hs

@@ -11,13 +11,14 @@ import Data.List(foldl', find)
 import Data.Maybe(catMaybes, isJust, fromMaybe)
 --import qualified Debug.Trace
 
-import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..))
+import Types(SyntaxNode(..), sgNamedNodeToSyntaxNode, IngSyntaxGraph, Edge(..),
+            CaseOrGuardTag(..))
 import Util(maybeBoolToBool)
 --import Util(printSelf)
 
 -- See graph_algs.txt for pseudocode
 
-data ParentType = ApplyParent | NotAParent
+data ParentType = ApplyParent | CaseOrGuardParent | NotAParent deriving (Eq, Show)
 
 -- START HELPER functions --
 
@@ -26,19 +27,20 @@ syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Bool
 syntaxNodeIsEmbeddable parentType n = case (parentType, n) of
   (ApplyParent, LikeApplyNode _ _) -> True 
   (ApplyParent, LiteralNode _) -> True
+  (CaseOrGuardParent, LiteralNode _) -> True
   _ -> False
 
 -- | A syntaxNodeCanEmbed if it can contain other nodes
 syntaxNodeCanEmbed :: SyntaxNode -> Bool
-syntaxNodeCanEmbed n = case n of
+syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode
-  LikeApplyNode _ _ -> True
-  NestedApplyNode _ _ _ -> True -- This case should not happen
-  _ -> False
 
 parentTypeForNode :: SyntaxNode -> ParentType
 parentTypeForNode n = case n of
   LikeApplyNode _ _ -> ApplyParent
   NestedApplyNode _ _ _ -> ApplyParent
+  CaseNode _ -> CaseOrGuardParent
+  GuardNode _ -> CaseOrGuardParent
+  NestedCaseOrGuardNode _ _ _ -> CaseOrGuardParent
   -- The NotAParent case should never occur.
   _ -> NotAParent
 
@@ -205,6 +207,8 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
           newNodeLabel = (nodeName, newSyntaxNode)
           newSyntaxNode = case oldSyntaxNode of
             LikeApplyNode flavor x -> NestedApplyNode flavor x childrenAndEdgesToParent
+            CaseNode x -> NestedCaseOrGuardNode CaseTag x childrenAndEdgesToParent
+            GuardNode x -> NestedCaseOrGuardNode GuardTag x childrenAndEdgesToParent
             _ -> oldSyntaxNode
     childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
     findChildAndEdge childNode =

app/Icons.hs

@@ -25,6 +25,7 @@ import Diagrams.Prelude hiding ((&), (#), Name)
 
 import Data.List(find)
 import Data.Maybe(catMaybes, listToMaybe)
+import Data.Either(partitionEithers)
 
 -- import Diagrams.Backend.SVG(B)
 --import Diagrams.TwoD.Text(Text)
@@ -54,6 +55,8 @@ iconToDiagram CaseResultIcon = identDiaFunc caseResult
 iconToDiagram (FlatLambdaIcon n) = identDiaFunc $ flatLambda n
 iconToDiagram (NestedApply flavor args) = nestedApplyDia flavor args
 iconToDiagram (NestedPApp args) = nestedPAppDia args
+iconToDiagram (NestedCaseIcon args) = nestedCaseDia args
+iconToDiagram (NestedGuardIcon args) = nestedGuardDia args
 
 applyPortAngles :: Floating n => Port -> [Angle n]
 applyPortAngles (Port x) = fmap (@@ turn) $ case x of
@@ -107,6 +110,8 @@ getPortAngles icon port maybeNodeName = case icon of
   FlatLambdaIcon _ -> applyPortAngles port
   NestedApply _ args -> nestedApplyPortAngles args port maybeNodeName
   NestedPApp args -> nestedApplyPortAngles args port maybeNodeName
+  NestedCaseIcon _ -> guardPortAngles port
+  NestedGuardIcon _ -> guardPortAngles port
 
 -- END FUNCTIONS --
 
@@ -208,6 +213,9 @@ nestedPAppDia :: SpecialBackend b n =>
   [Maybe (NodeName, Icon)] -> TransformableDia b n
 nestedPAppDia = generalNestedDia apply0Triangle (repeat $ patternC colorScheme)
 
+makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
+makeQualifiedPort n x = n .>> makePort x
+
 generalNestedDia :: SpecialBackend b n =>
   (Colour Double -> SpecialQDiagram b n) -> [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
 generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
@@ -215,7 +223,7 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
   (maybeFunText:args) -> centerXY $  transformedText ||| centerY finalDia
     where
       borderCol = borderCols !! nestingLevel
-      makeQualifiedPort x = name .>> makePort x
+
       transformedText = case maybeFunText of
         Just _ -> makeInnerIcon True 0 maybeFunText
         Nothing -> mempty
@@ -224,14 +232,14 @@ generalNestedDia dia borderCols funcNodeNameAndArgs name nestingLevel reflect an
       trianglePortsCircle = hsep seperation $
         reflectX (dia borderCol) :
         zipWith (makeInnerIcon False) [2,3..] args ++
-        [makeQualifiedPort (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
+        [makeQualifiedPort name (Port 1) <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)]
   
-      allPorts = makeQualifiedPort (Port 0) <> alignL trianglePortsCircle
+      allPorts = makeQualifiedPort name (Port 0) <> alignL trianglePortsCircle
       topAndBottomLineWidth = width allPorts - circleRadius
       argBox = alignL $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeperation) (circleRadius * 0.5)
       finalDia = argBox <> allPorts
 
-      makeInnerIcon _ portNum Nothing = makeQualifiedPort (Port portNum) <> portCircle
+      makeInnerIcon _ portNum Nothing = makeQualifiedPort name (Port portNum) <> portCircle
       makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
       makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
         innerLevel = if func then nestingLevel else nestingLevel + 1
@@ -322,16 +330,16 @@ guardSize :: (Fractional a) => a
 guardSize = 0.7
 
 guardTriangle :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
+  SpecialQDiagram b n -> SpecialQDiagram b n
-guardTriangle x =
+guardTriangle portDia =
-  alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> makePort (Port x)
+  alignL $ alignR (triangleAndPort ||| lwG defaultLineWidth (hrule (guardSize * 0.8))) <> portDia
   where
     triangleAndPort = alignR $ alignT $ lwG defaultLineWidth $ rotateBy (1/8) $
       polygon (polyType .~ PolySides [90 @@ deg, 45 @@ deg] [guardSize, guardSize] $ with)
 
 guardLBracket :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
+  SpecialQDiagram b n -> SpecialQDiagram b n
-guardLBracket x = alignL (alignT ell) <> makePort (Port x)
+guardLBracket portDia = alignL (alignT ell) <> portDia
   where
     ellShape = fromOffsets $ map r2 [(0, guardSize), (-guardSize,0)]
     ell = lineJoin LineJoinRound $ lwG defaultLineWidth $ lc (boolC colorScheme) (strokeLine ellShape)
@@ -342,12 +350,12 @@ guardLBracket x = alignL (alignT ell) <> makePort (Port x)
 -- odds -> left
 -- evens -> right
 generalGuardIcon :: SpecialBackend b n =>
-  Colour Double -> (Int -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
+  Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> Int -> SpecialQDiagram b n
 generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomDia <> makePort (Port 1)) <> alignB (bigVerticalLine <> guardDia <> makePort (Port 0))
   where
     --guardTriangles = vsep 0.4 (take n (map guardTriangle [0,1..]))
-    trianglesWithPorts = map guardTriangle [2,4..]
+    trianglesWithPorts = map (guardTriangle . makePort . Port) [2,4..]
-    lBrackets = map lBracket [3, 5..]
+    lBrackets = map (lBracket . makePort . Port) [3, 5..]
     trianglesAndBrackets =
       zipWith zipper trianglesWithPorts lBrackets
     zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
@@ -356,6 +364,41 @@ generalGuardIcon triangleColor lBracket bottomDia n = centerXY $ alignT (bottomD
     guardDia = vcat (alignT $ take n trianglesAndBrackets)
     bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
 
+generalNestedGuard :: SpecialBackend b n =>
+  Colour Double -> (SpecialQDiagram b n -> SpecialQDiagram b n) -> SpecialQDiagram b n -> [Maybe (NodeName, Icon)] -> TransformableDia b n
+generalNestedGuard triangleColor lBracket bottomDia inputAndArgs name nestingLevel reflect angle = named name $ case inputAndArgs of
+  [] -> mempty
+  (input : args) -> centerXY finalDia where
+    finalDia = alignT (bottomDia <> makeQualifiedPort name (Port 1)) <> alignB (inputIcon === (bigVerticalLine <> guardDia <> makeQualifiedPort name (Port 0)))
+
+    argPortNums = [2..]
+    innerIcons = fmap makeInnerIcon args
+
+    iconMapper portNum innerIcon
+      | even portNum = Right $ guardTriangle port ||| innerIcon
+      | otherwise = Left $ innerIcon ||| lBracket port
+      where
+        port = (makeQualifiedPort name (Port portNum))
+
+    -- TODO argPortNums is duplicated
+    (lBrackets, trianglesWithPorts) = partitionEithers $ zipWith iconMapper argPortNums innerIcons
+
+    trianglesAndBrackets =
+      zipWith zipper trianglesWithPorts lBrackets
+
+    zipper thisTriangle lBrack = verticalLine === (alignR (extrudeRight guardSize lBrack) <> lc triangleColor (alignL thisTriangle))
+      where
+        verticalLine = strutY 0.4
+
+    inputIcon = makeInnerIcon input
+    
+    guardDia = vcat (alignT $ trianglesAndBrackets)
+    bigVerticalLine = alignT $ lwG defaultLineWidth $ lc triangleColor $ vrule (height guardDia)
+
+    makeInnerIcon mNameAndIcon = case mNameAndIcon of
+      Nothing -> mempty
+      Just (iconNodeName, icon) -> iconToDiagram icon iconNodeName nestingLevel reflect angle
+
 -- | The ports of the guard icon are as follows:
 -- Port 0: Top result port
 -- Port 1: Bottom result port
@@ -365,6 +408,9 @@ guardIcon :: SpecialBackend b n =>
   Int -> SpecialQDiagram b n
 guardIcon = generalGuardIcon lineCol guardLBracket mempty
 
+nestedGuardDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
+nestedGuardDia = generalNestedGuard lineCol guardLBracket mempty
+
 -- TODO Improve design to be more than a circle.
 caseResult :: SpecialBackend b n =>
   SpecialQDiagram b n
@@ -373,8 +419,8 @@ caseResult = lw none $ lc caseCColor $ fc caseCColor $ circle (circleRadius * 0.
     caseCColor = caseRhsC colorScheme
 
 caseC :: SpecialBackend b n =>
-  Int -> SpecialQDiagram b n
+  SpecialQDiagram b n -> SpecialQDiagram b n
-caseC n = caseResult <> makePort (Port n)
+caseC portDia = caseResult <> portDia
 
 
 -- | The ports of the case icon are as follows:
@@ -386,6 +432,9 @@ caseIcon :: SpecialBackend b n =>
   Int -> SpecialQDiagram b n
 caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
 
+nestedCaseDia :: SpecialBackend b n => [Maybe (NodeName, Icon)] -> TransformableDia b n
+nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
+
 -- | The ports of flatLambdaIcon are:
 -- 0: Result icon
 -- 1: The lambda function value

app/Rendering.hs

@@ -92,7 +92,7 @@ getArrowOpts (t, h) _ (fromAngle, toAngle) (NameAndPort (NodeName nodeNum) mPort
     edgeColors = edgeListC colorScheme
     numEdgeColors = length edgeColors
     hashedColor = edgeColors !! namePortHash
-    namePortHash = mod (nodeNum + (503 * portNum)) numEdgeColors
+    namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
     Port portNum = fromMaybe (Port 0) mPort
 
     ap1ArgTexture = solid (backgroundC colorScheme)

app/Translate.hs

@@ -274,7 +274,7 @@ evalIf c e1 e2 e3 = do
     combinedGraph =
       combineExpressions False $ zip [e1Val, e2Val, e3Val] (map (nameAndPort guardName . Port) [3, 2, 4])
     newGraph = syntaxGraphFromNodes icons <> combinedGraph
-  pure (newGraph, nameAndPort guardName (Port 0))
+  pure (newGraph, nameAndPort guardName (Port 1))
 
 evalStmt :: EvalContext -> Stmt -> State IDState GraphAndRef
 evalStmt c (Qualifier e) = evalExp c e

app/TranslateCore.hs

@@ -34,7 +34,7 @@ import Data.Semigroup(Semigroup, (<>))
 
 import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
   NameAndPort(..), IDState, getId, SgNamedNode, NodeName(..), Port(..), nodeNameToInt,
-  LikeApplyFlavor(..))
+  LikeApplyFlavor(..), CaseOrGuardTag(..))
 import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool)
 import Icons(Icon(..))
 
@@ -177,6 +177,7 @@ nodeToIcon (FunctionDefNode n) = FlatLambdaIcon n
 nodeToIcon (GuardNode n) = GuardIcon n
 nodeToIcon (CaseNode n) = CaseIcon n
 nodeToIcon CaseResultNode = CaseResultIcon
+nodeToIcon (NestedCaseOrGuardNode tag x edges) = nestedCaseOrGuardNodeToIcon tag x edges
 
 makeArg :: [(SgNamedNode, Edge)] -> Int -> Maybe (NodeName, Icon)
 makeArg args port = case find (findArg (Port port)) args of
@@ -190,6 +191,13 @@ nestedApplySyntaxNodeToIcon flavor numArgs args = NestedApply flavor argList whe
   -- TODO Don't use hardcoded port numbers
   argList = fmap (makeArg args) (0:[2..numArgs + 1])
 
+nestedCaseOrGuardNodeToIcon :: CaseOrGuardTag -> Int -> [(SgNamedNode, Edge)] -> Icon
+nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
+  CaseTag -> NestedCaseIcon argList
+  GuardTag -> NestedGuardIcon argList
+  where
+    argList = fmap (makeArg args) (0:[2..( 1 + (2 * numArgs))])
+
 nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
 nestedPatternNodeToIcon str children = NestedPApp $
   Just (NodeName (-1), TextBoxIcon str)

app/Types.hs

@@ -18,6 +18,7 @@ module Types (
   SgNamedNode,
   IngSyntaxGraph,
   LikeApplyFlavor(..),
+  CaseOrGuardTag(..),
   initialIdState,
   getId,
   sgNamedNodeToSyntaxNode,
@@ -42,10 +43,14 @@ data Icon = ResultIcon | TextBoxIcon String | GuardIcon Int
   -- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
   | NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
   | NestedPApp [Maybe (NodeName, Icon)]
+  | NestedCaseIcon [Maybe (NodeName, Icon)]
+  | NestedGuardIcon [Maybe (NodeName, Icon)]
   deriving (Show, Eq, Ord)
 
 data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)
 
+data CaseOrGuardTag = CaseTag | GuardTag deriving (Show, Eq, Ord)
+
 -- TODO remove Ints from SyntaxNode data constructors.
 data SyntaxNode =
   LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
@@ -60,6 +65,7 @@ data SyntaxNode =
   | GuardNode Int
   | CaseNode Int
   | CaseResultNode -- TODO remove caseResultNode
+  | NestedCaseOrGuardNode CaseOrGuardTag Int [(SgNamedNode, Edge)]
   deriving (Show, Eq, Ord)
 
 newtype NodeName = NodeName Int deriving (Typeable, Eq, Ord, Show)

test/VisualRenderingTests.hs

@@ -187,6 +187,38 @@ nestedTextDrawing = Drawing nestedTestIcons nestedTestEdges where
     iconToIntPort t2 n2 2
     ]
 
+nestedCaseDrawing :: Drawing
+nestedCaseDrawing = Drawing icons [] where
+  [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9] = fmap NodeName [0..9]
+  icons = [
+    (n0, NestedCaseIcon [Nothing, Nothing, Nothing]),
+    (n1, NestedCaseIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
+    (n3, NestedCaseIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
+    (n5, NestedCaseIcon [Nothing,
+                         Just (n6, TextBoxIcon "n6"),
+                         Just (n7, TextBoxIcon "n7"),
+                         Just (n8, TextBoxIcon "n8"),
+                         Just (n9, TextBoxIcon "n9")])
+    ]
+
+nestedGuardDrawing :: Drawing
+nestedGuardDrawing = Drawing icons edges where
+  [n0, n1, n2, n3, n4, n5, n6, n7, n8, n9, n10] = fmap NodeName [0..10]
+  icons = [
+    (n10, TextBoxIcon "n10"),
+    (n0, NestedGuardIcon [Nothing, Nothing, Nothing]),
+    (n1, NestedGuardIcon [Nothing, Just (n2, TextBoxIcon "n2"), Nothing]),
+    (n3, NestedGuardIcon [Nothing, Nothing, Just (n4, TextBoxIcon "n4")]),
+    (n5, NestedGuardIcon [Nothing,
+                          Just (n6, TextBoxIcon "n6"),
+                          Just (n7, TextBoxIcon "n7"),
+                          Just (n8, TextBoxIcon "n8"),
+                          Just (n9, TextBoxIcon "n9")])
+    ]
+  edges = [
+    iconToIntPort n10 n5 0
+    ]
+
 --renderTests :: IO (Diagram B)
 renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
 renderTests = do
@@ -200,6 +232,8 @@ renderTests = do
       fact1Drawing,
       fact2Drawing,
       arrowTestDrawing,
-      nestedTextDrawing
+      nestedTextDrawing,
+      nestedCaseDrawing,
+      nestedGuardDrawing
       -- TODO Add a nested test where the function expression is nested.
       ]

test/VisualTranslateTests.hs

@@ -209,7 +209,8 @@ otherTests = [
   "y = f x",
   "y = f (g x1 x2) x3",
   "y = (f x1 x2) (g x1 x2)",
-  "y = Foo.bar"
+  "y = Foo.bar",
+  "y x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 = f x1 x2 x3 x4 x5 x6 x7 x8 x9 x10"
   ]
 
 testDecls :: [String]

todo.txt

@@ -1,6 +1,4 @@
 -- TODO Now --
-Case icon that can embed literals
-
 Consider adding binding variable names to the lambda icon and match icon. Don't display the name if it is only one character.
 
 -- TODO Later --
@@ -15,11 +13,12 @@ Draw bounding boxes for lambdas (use dashed lines)
 -- Make an icon font/library with labeled ports. E.g. the apply icon would have text labels "function", "result", "arg 0", "arg 1", etc.
 -- Don't rotate text and nested icons, give them rectangular bounding boxes in GraphViz. (Perhaps use a typeclass for isRotateAble)
 -- Give lines a black border to make line crossings easier to see.
--- Let lines connect to ports in multiple locations (e.g. guard result)
+-- Let lines connect to ports other than the original source
 -- Use different line styles (e.g. dashed, solid, wavy) in addition to colors
 Use diagrams to shrink the drawing until icons start overlapping.
 
 -- Translate todos:
+Allow case and guard nodes to embed simple patterns and expressions.
 
 Fix this test so that the line colors are correct. Consider connecting the t line to the origial rhs (3,4), not the pattern result.
 y = let {t@(_,_) = (3,4)} in t + 3