Refactor NestedPApp and NestedPatternApplyNode.

app/Icons.hs

@@ -31,7 +31,7 @@ import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
 
 import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
             , NodeName, Port(..), LikeApplyFlavor(..),
-            SyntaxNode(..), NamedIcon(..))
+            SyntaxNode(..), NamedIcon(..), Labeled(..))
 import DrawingColors(colorScheme, ColorStyle(..))
 
 {-# ANN module "HLint: ignore Use record patterns" #-}
@@ -74,7 +74,8 @@ iconToDiagram icon = case icon of
   CaseResultIcon -> identDiaFunc caseResult
   FlatLambdaIcon x -> flatLambda x
   NestedApply flavor headIcon args -> nestedApplyDia flavor headIcon args
-  NestedPApp args -> nestedPAppDia (repeat $ patternC colorScheme) args
+  NestedPApp constructor args
+    -> nestedPAppDia (repeat $ patternC colorScheme) constructor args
   NestedCaseIcon args -> nestedCaseDia args
   NestedGuardIcon args -> nestedGuardDia args
 
@@ -104,7 +105,8 @@ guardPortAngles (Port port) = case port of
 findNestedIcon :: NodeName -> Icon -> Maybe Icon
 findNestedIcon name icon = case icon of
   NestedApply _ headIcon args -> snd <$> findIcon name (headIcon : args)
-  NestedPApp args -> snd <$> findIcon name (fmap fst args)
+  NestedPApp constructor args ->
+    snd <$> findIcon name (fmap laValue (constructor:args))
   _ -> Nothing
 
 findIcon :: NodeName -> [Maybe NamedIcon] -> Maybe (Int, Icon)
@@ -167,11 +169,9 @@ getPortAngles icon port maybeNodeName = case icon of
   FlatLambdaIcon _ -> applyPortAngles port
   NestedApply _ headIcon args ->
     generalNestedPortAngles applyPortAngles headIcon args port maybeNodeName
-  NestedPApp (headIcon : args) ->
+  NestedPApp headIcon args ->
     generalNestedPortAngles
-    pAppPortAngles (fst headIcon) (fmap fst args) port maybeNodeName
-  NestedPApp _ ->
-    error "getPortAngles called on a NestedPApp with not enough arguments."
+    pAppPortAngles (laValue headIcon) (fmap laValue args) port maybeNodeName
   NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
   NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
 
@@ -292,23 +292,25 @@ resultIcon =  lw none $ fc (lamArgResC colorScheme) unitSquare
 
 -- TODO Refactor with generalNestedDia
 nestedPAppDia :: SpecialBackend b n =>
-  [Colour Double] -> [(Maybe NamedIcon, String)] -> TransformableDia b n
+  [Colour Double]
+  -> Labeled (Maybe NamedIcon)
+  -> [Labeled (Maybe NamedIcon)]
+  -> TransformableDia b n
 nestedPAppDia
   borderCols
-  funcNodeNameAndArgs
+  maybeFunText
+  args
   (TransformParams name nestingLevel reflect angle)
   = named name $
-    case funcNodeNameAndArgs of
-      [] -> mempty
-      (maybeFunText:args) ->
         centerXY
         $ centerY finalDia ||| beside' unitX transformedText resultCircleAndPort
         where
           borderCol = borderCols !! nestingLevel
 
-          transformedText = case maybeFunText of
-            (Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
-            (Nothing, _) -> mempty
+          transformedText = case laValue maybeFunText of
+            (Just _) ->
+              makeInnerIcon True inputPortConst maybeFunText
+            Nothing -> mempty
           separation = circleRadius * 1.5
           verticalSeparation = circleRadius
           resultCircleAndPort
@@ -333,9 +335,9 @@ nestedPAppDia
               (circleRadius * 0.5)
           finalDia = argBox <> allPorts
 
-          makeInnerIcon _ portNum (Nothing, str)
+          makeInnerIcon _ portNum (Labeled Nothing str)
             = centerX $ makeLabelledPort name reflect angle str portNum
-          makeInnerIcon func _ (Just (NamedIcon iconNodeName icon), _)
+          makeInnerIcon func _ (Labeled (Just (NamedIcon iconNodeName icon)) _)
             = iconToDiagram
               icon
               (TransformParams iconNodeName innerLevel reflect angle)

app/Translate.hs

@@ -28,7 +28,7 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..), S
   makeBox, nTupleString, nTupleSectionString, nListString,
   syntaxGraphToFglGraph, getUniqueString, bindsToSyntaxGraph, graphAndRefToGraph,
   initialIdState)
-import Types(NameAndPort(..), IDState,
+import Types(Labeled(..), NameAndPort(..), IDState,
   Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
   LikeApplyFlavor(..))
 import Util(makeSimpleEdge, nameAndPort, justName)
@@ -164,8 +164,8 @@ makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
     (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
 
     argListMapper (str, arg) = case arg of
-      Left _ -> (Nothing, str)
-      Right (namedNode, _) -> (Just namedNode, str)
+      Left _ -> Labeled Nothing str
+      Right (namedNode, _) -> Labeled (Just namedNode) str
 
     argList = fmap argListMapper mappedArgs
 

app/TranslateCore.hs

@@ -31,14 +31,13 @@ module TranslateCore(
 ) where
 
 import Control.Monad.State(State, state)
-import qualified Control.Arrow as Arrow
 import Data.Either(partitionEithers)
 import qualified Data.Graph.Inductive.PatriciaTree as FGR
 import qualified Data.Graph.Inductive.Graph as ING
 import Data.List(find)
 import Data.Semigroup(Semigroup, (<>))
 
-import Types(Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
+import Types(Labeled(..), Icon, SyntaxNode(..), Edge(..), EdgeOption(..),
   NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port,
   LikeApplyFlavor(..), CaseOrGuardTag(..), IDState(..), NamedIcon(..))
 import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
@@ -289,11 +288,12 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
     argPorts = take (2 * numArgs) $ argumentPorts dummyNode
     argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
 
-nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon
-nestedPatternNodeToIcon str children = NestedPApp $
-  (Just (NamedIcon (NodeName (-1)) (TextBoxIcon str)), "")
-  :
-  fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children
+nestedPatternNodeToIcon :: String -> [Labeled (Maybe SgNamedNode)] -> Icon
+nestedPatternNodeToIcon str children = NestedPApp
+  (pure (Just (NamedIcon (NodeName (-1)) (TextBoxIcon str))))
+  (fmap
+    (fmap (fmap (mapNodeInNamedNode nodeToIcon)))
+    children)
 
 findArg :: Port -> (SgNamedNode, Edge) -> Bool
 findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))

app/Types.hs

@@ -19,17 +19,29 @@ module Types (
   SgNamedNode(..),
   IngSyntaxGraph,
   LikeApplyFlavor(..),
-  CaseOrGuardTag(..)
+  CaseOrGuardTag(..),
+  Labeled(..)
 ) where
 
 import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
 import Diagrams.TwoD.Text(Text)
 
+import Control.Applicative(Applicative(..))
 import Data.Typeable(Typeable)
 
 data NamedIcon = NamedIcon {niName :: NodeName, niIcon :: Icon}
   deriving (Show, Eq, Ord)
 
+data Labeled a = Labeled {laValue :: a, laLabel :: String}
+  deriving (Show, Eq, Ord)
+
+instance Functor Labeled where
+  fmap f (Labeled value str) = Labeled (f value) str
+
+instance Applicative Labeled where
+  pure x = Labeled x ""
+  (Labeled f fStr) <*> (Labeled x xStr) = Labeled (f x) (fStr <> xStr)
+
 -- TYPES --
 -- | A datatype that represents an icon.
 -- The TextBoxIcon's data is the text that appears in the text box.
@@ -44,12 +56,15 @@ data Icon = TextBoxIcon String
     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)]
+  | NestedPApp
+    (Labeled (Maybe NamedIcon))  -- Data constructor
+    [Labeled (Maybe NamedIcon)]  -- Arguments
   | NestedCaseIcon [Maybe NamedIcon]
   | NestedGuardIcon [Maybe NamedIcon]
   deriving (Show, Eq, Ord)
 
-data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor deriving (Show, Eq, Ord)
+data LikeApplyFlavor = ApplyNodeFlavor | ComposeNodeFlavor
+  deriving (Show, Eq, Ord)
 
 data CaseOrGuardTag = CaseTag | GuardTag deriving (Show, Eq, Ord)
 
@@ -58,7 +73,7 @@ data SyntaxNode =
   LikeApplyNode LikeApplyFlavor Int -- Function application, composition, and applying to a composition
   -- NestedApplyNode is only created in GraphAlgorithms, not during translation.
   | NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
-  | NestedPatternApplyNode String [(Maybe SgNamedNode, String)]
+  | NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
   | NameNode String -- Identifiers or symbols
   | BindNameNode String
   | LiteralNode String -- Literal values like the string "Hello World"

test/AllTests.hs

@@ -1,3 +1,4 @@
+module Main (main) where
 import Prelude hiding (return)
 
 import Diagrams.Backend.SVG.CmdLine(B)

test/UnitTests.hs

@@ -11,7 +11,7 @@ import Data.List(foldl', sort, sortOn)
 
 import Translate(translateStringToSyntaxGraph)
 import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..))
-import Types(SgNamedNode(..), Edge(..), SyntaxNode(..),
+import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..),
              IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..))
 import qualified GraphAlgorithms
 import Util(fromMaybeError)
@@ -38,18 +38,27 @@ renameNode nameMap counter (SgNamedNode nodeName syntaxNode) = (newNamedNode, na
   newNamedNode = SgNamedNode newNodeName newSyntaxNode
 
 maybeRenameNodeFolder ::
-  ([(Maybe SgNamedNode, String)], NameMap, Int) -> Maybe SgNamedNode -> ([(Maybe SgNamedNode, String)], NameMap, Int)
+  ([Labeled (Maybe SgNamedNode)], NameMap, Int)
+  -> Maybe SgNamedNode
+  -> ([Labeled (Maybe SgNamedNode)], NameMap, Int)
 maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of
-  Nothing -> ((Nothing, ""):renamedNodes, nameMap, counter)
-  Just node -> ((Just newNamedNode, ""):renamedNodes, newNameMap, newCounter) where
+  Nothing -> ((pure Nothing) : renamedNodes, nameMap, counter)
+  Just node -> ((pure $ Just newNamedNode) : renamedNodes, newNameMap, newCounter) where
     (newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node
 
 renameSyntaxNode :: NameMap -> SyntaxNode -> Int  -> (SyntaxNode, NameMap, Int)
 renameSyntaxNode nameMap node counter = case node of
   -- TODO Keep the Nothing subNodes
-  NestedPatternApplyNode s subNodes -> (NestedPatternApplyNode s (reverse renamedSubNodes), newNameMap, counter2)
+  NestedPatternApplyNode s subNodes
+    -> (NestedPatternApplyNode s (reverse renamedSubNodes)
+       , newNameMap
+       , counter2)
     where
-      (renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) (fmap fst subNodes)
+      (renamedSubNodes, newNameMap, counter2)
+        = foldl'
+          maybeRenameNodeFolder
+          ([], nameMap, counter)
+          (fmap laValue subNodes)
   _ -> (node, nameMap, counter)
 
 renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int)

test/VisualRenderingTests.hs

@@ -7,7 +7,7 @@ module VisualRenderingTests (
 import Diagrams.Prelude hiding ((#), (&))
 
 import Rendering (renderDrawing)
-import Types (NodeName(..), Drawing(..), Edge, Icon(..), Port(..), LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..))
+import Types (Labeled(..), NodeName(..), Drawing(..), Edge, Icon(..), Port(..), LikeApplyFlavor(..), SpecialQDiagram, SpecialBackend, NamedIcon(..))
 
 import Util(iconToPort, tupleToNamedIcon)
 
@@ -70,19 +70,18 @@ nestedPAppDia :: Drawing
 nestedPAppDia = Drawing icons []
   where
     icons = [
-      NamedIcon (NodeName 1) (NestedPApp [(Nothing, "baz")])
+      NamedIcon (NodeName 1) (NestedPApp (Labeled Nothing "baz") [])
       , NamedIcon
         (NodeName 2)
         (NestedPApp
-          [ (Nothing, "")
-          , (Just (NamedIcon (NodeName 1) (TextBoxIcon "foo")), "bar")
-          , (Nothing, "bar")])
+          (Labeled Nothing "")
+          [ Labeled (Just (NamedIcon (NodeName 1) (TextBoxIcon "foo"))) "bar"
+          , Labeled Nothing "bar"])
       , NamedIcon
         (NodeName 3)
         (NestedPApp
-          [
-            (Just (NamedIcon (NodeName 4) (TextBoxIcon "foo")), "bar")
-          , (Nothing, "bar")])
+          (Labeled (Just (NamedIcon (NodeName 4) (TextBoxIcon "foo"))) "bar")
+          [Labeled Nothing "bar"])
       ]
 
 nestedApplyDia :: Drawing