Add pattern names to PApp.

.gitignore

@@ -16,6 +16,7 @@ cabal.sandbox.config
 .stack-work/
 *.*~
 *~
+*#
 
 # You can put SVG images created by Glance in /images
 /images

app/DrawingColors.hs

@@ -44,7 +44,7 @@ colorOnBlackScheme = ColorStyle {
   patternC = lightMagenta,
   patternTextC = cyan,
   bindTextBoxC = reddishOrange,
-  bindTextBoxTextC = lime,
+  bindTextBoxTextC = lightGreen,
   edgeListC = [white, lime, reddishOrange, lightPurple, yellow, lightBlue],
   nestingC = cycle [red, reddishOrange, yellow]
 }
@@ -56,6 +56,7 @@ colorOnBlackScheme = ColorStyle {
     --lightBlue = sRGB24 126 127 255
     lightBlue = sRGB24 35 156 255
     lightPurple = sRGB24 208 137 255
+    lightGreen = sRGB24 180 255 145
     
 
 whiteOnBlackScheme :: (Floating a, Ord a) => ColorStyle a

app/Icons.hs

@@ -23,10 +23,10 @@ module Icons
 
 import Diagrams.Prelude hiding ((&), (#), Name)
 
+import qualified Control.Arrow as Arrow
+import Data.Either(partitionEithers)
 import Data.List(find)
 import Data.Maybe(catMaybes, listToMaybe, isJust, fromJust)
-import Data.Either(partitionEithers)
-import qualified Control.Arrow as Arrow
 
 import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum, NodeName, Port(..), LikeApplyFlavor(..),
             SyntaxNode(..))
@@ -94,7 +94,7 @@ guardPortAngles (Port port) = case port of
 findNestedIcon :: NodeName -> Icon -> Maybe Icon
 findNestedIcon name icon = case icon of
   NestedApply _ args -> snd <$> findIcon name args
-  NestedPApp args -> snd <$> findIcon name args
+  NestedPApp args -> snd <$> findIcon name (fmap fst args)
   _ -> Nothing
 
 findIcon :: NodeName -> [Maybe (NodeName, Icon)] -> Maybe (Int, Icon)
@@ -150,7 +150,7 @@ getPortAngles icon port maybeNodeName = case icon of
   CaseResultIcon -> []
   FlatLambdaIcon _ -> applyPortAngles port
   NestedApply _ args -> generalNestedPortAngles applyPortAngles args port maybeNodeName
-  NestedPApp args -> generalNestedPortAngles pAppPortAngles args port maybeNodeName
+  NestedPApp args -> generalNestedPortAngles pAppPortAngles (fmap fst args) port maybeNodeName
   NestedCaseIcon args -> nestedGuardPortAngles args port maybeNodeName
   NestedGuardIcon args -> nestedGuardPortAngles args port maybeNodeName
 
@@ -228,6 +228,17 @@ makePort x = named x mempty
 makeQualifiedPort :: SpecialNum n => NodeName -> Port -> SpecialQDiagram b n
 makeQualifiedPort n x = n .>> makePort x
 
+makeLabelledPort :: SpecialBackend b n =>
+  NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
+makeLabelledPort name reflect angle str portNum = case str of
+  -- Don't display " tempvar" from Translate.hs/matchesToCase
+  (' ':_) -> portAndCircle
+  (_:_:_) -> portAndCircle ||| label
+  _ -> portAndCircle
+  where
+    portAndCircle = makeQualifiedPort name portNum <> portCircle
+    label = transformableBindTextBox str reflect angle
+
 -- END Diagram helper functions
 
 
@@ -279,7 +290,7 @@ generalTextAppDia textCol borderCol numArgs str name _ reflect angle = nameDiagr
 
 -- TODO Refactor with generalNestedDia
 nestedPAppDia :: SpecialBackend b n =>
-  [Colour Double] -> [Maybe (NodeName, Icon)] -> TransformableDia b n
+  [Colour Double] -> [(Maybe (NodeName, Icon), String)] -> TransformableDia b n
 nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = named name $ case funcNodeNameAndArgs of
   [] -> mempty
   (maybeFunText:args) -> centerXY $ centerY finalDia ||| transformedText ||| resultCircleAndPort
@@ -287,8 +298,8 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
       borderCol = borderCols !! nestingLevel
 
       transformedText = case maybeFunText of
-        Just _ -> makeInnerIcon True inputPortConst maybeFunText
+        (Just _, _) -> makeInnerIcon True inputPortConst maybeFunText
-        Nothing -> mempty
+        (Nothing, _) -> mempty
       separation = circleRadius * 1.5
       verticalSeparation = circleRadius
       resultCircleAndPort = makeQualifiedPort name resultPortConst <> alignR (lc borderCol $ lwG defaultLineWidth $ fc borderCol $ circle circleRadius)
@@ -303,9 +314,9 @@ nestedPAppDia borderCols funcNodeNameAndArgs name nestingLevel reflect angle = n
       argBox = alignT $ lwG defaultLineWidth $ lc borderCol $ roundedRect topAndBottomLineWidth (height allPorts + verticalSeparation) (circleRadius * 0.5)
       finalDia = argBox <> allPorts
 
-      makeInnerIcon _ portNum Nothing = makeQualifiedPort name portNum <> portCircle
+      makeInnerIcon _ portNum (Nothing, str) = centerX $ makeLabelledPort name reflect angle str portNum
-      makeInnerIcon True _ (Just (_, TextBoxIcon t)) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
+      makeInnerIcon True _ ((Just (_, TextBoxIcon t)), _) = transformCorrectedTextBox t (textBoxTextC colorScheme) borderCol reflect angle
-      makeInnerIcon func _ (Just (iconNodeName, icon)) = iconToDiagram icon iconNodeName innerLevel reflect angle where
+      makeInnerIcon func _ ((Just (iconNodeName, icon)), _) = iconToDiagram icon iconNodeName innerLevel reflect angle where
         innerLevel = if func then nestingLevel else nestingLevel + 1
   
 
@@ -395,10 +406,6 @@ coloredTextBox textColor boxColor t =
   fontSize (local textBoxFontSize) (bold $ font "freemono" $ fc textColor $ text t)
   <>  lwG (0.6 * defaultLineWidth) (lcA boxColor $ fcA (withOpacity (backgroundC colorScheme) 0.5) $ rectForText (length t))
 
-bindTextBox :: SpecialBackend b n =>
-  String -> SpecialQDiagram b n
-bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
-
 transformCorrectedTextBox :: SpecialBackend b n =>
   String -> Colour Double -> Colour Double -> Bool -> Angle n -> SpecialQDiagram b n
 transformCorrectedTextBox str textCol borderCol reflect angle =
@@ -409,13 +416,17 @@ transformCorrectedTextBox str textCol borderCol reflect angle =
     textBoxRotation = if (reducedAngle > (1/4)) && (reducedAngle < (3/4)) then 1 / 2 else 0
     reflectIfTrue shouldReflect dia = if shouldReflect then reflectX dia else dia
 
-defaultColoredTextBox :: SpecialBackend b n =>
+transformableBindTextBox :: SpecialBackend b n =>
   String -> Bool -> Angle n -> SpecialQDiagram b n
-defaultColoredTextBox str = transformCorrectedTextBox str (textBoxTextC colorScheme) (textBoxC colorScheme)
+transformableBindTextBox str = transformCorrectedTextBox str (bindTextBoxTextC colorScheme) (bindTextBoxC colorScheme)
+
+bindTextBox :: SpecialBackend b n =>
+  String -> SpecialQDiagram b n
+bindTextBox = coloredTextBox (bindTextBoxTextC colorScheme) $ opaque (bindTextBoxC colorScheme)
 
 textBox :: SpecialBackend b n =>
   String -> TransformableDia b n
-textBox t name _ reflect angle = nameDiagram name $ defaultColoredTextBox t reflect angle
+textBox t name _ reflect angle = nameDiagram name $ transformCorrectedTextBox t (textBoxTextC colorScheme) (textBoxC colorScheme) reflect angle
 
 -- END Text boxes and icons
 
@@ -507,25 +518,13 @@ nestedCaseDia = generalNestedGuard (patternC colorScheme) caseC caseResult
 
 -- END Guard and case icons
 
--- BEGIN Lambda icon --
-makeLabelledPort :: SpecialBackend b n =>
-  NodeName -> Bool -> Angle n -> String -> Port -> SpecialQDiagram b n
-makeLabelledPort name reflect angle str portNum = case str of
-  -- Don't display " tempvar" from Translate.hs/matchesToCase
-  (' ':_) -> portAndCircle
-  (_:_:_) -> portAndCircle ||| label
-  _ -> portAndCircle
-  where
-    portAndCircle = makeQualifiedPort name portNum <> portCircle
-    label = defaultColoredTextBox str reflect angle
-
 -- | The ports of flatLambdaIcon are:
 -- 0: Result icon
 -- 1: The lambda function value
 -- 2,3.. : The parameters
 flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
 flatLambda paramNames name _ reflect angle = named name finalDia where
-  lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle circleRadius
+  lambdaCircle = lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ fc (regionPerimC colorScheme) $ circle (1.5 * circleRadius)
   lambdaParts = (makeQualifiedPort name inputPortConst <> resultIcon) : (portIcons ++  [makeQualifiedPort name resultPortConst <> alignR lambdaCircle])
 
   portIcons = zipWith (makeLabelledPort name reflect angle) paramNames argPortsConst
@@ -534,6 +533,5 @@ flatLambda paramNames name _ reflect angle = named name finalDia where
   topAndBottomLine = alignL $ lwG defaultLineWidth $ lc (regionPerimC colorScheme) $ hrule topAndBottomLineWidth
   finalDia = topAndBottomLine <> alignB (topAndBottomLine <> alignT middle)
 
--- END Lambda icon --
 -- END Main icons
 -- END Icons

app/Translate.hs

@@ -13,6 +13,7 @@ import Data.Either(partitionEithers)
 import qualified Data.Graph.Inductive.PatriciaTree as FGR
 import Data.List(unzip5, partition, intercalate)
 import Data.Maybe(catMaybes, isJust, fromMaybe)
+
 import qualified Language.Haskell.Exts as Exts
 
 import Language.Haskell.Exts(Decl(..), parseDeclWithMode, Name(..), Pat(..), Rhs(..),
@@ -70,6 +71,14 @@ bindOrAltHelper c pat rhs maybeWhereBinds = do
   rhsGraphAndRef <- rhsWithBinds maybeWhereBinds rhs rhsContext
   pure (patGraphAndRef, rhsGraphAndRef)
 
+patternName :: (GraphAndRef, Maybe String) -> String
+patternName (GraphAndRef _ ref, mStr) = fromMaybe
+  (case ref of
+    Left str -> str
+    Right _ -> ""
+  )
+  mStr
+
 -- END Helper Functions --
 
 -- BEGIN Names helper functions --
@@ -121,11 +130,16 @@ asNameBind (GraphAndRef _ ref, mAsName) = case mAsName of
   Nothing -> Nothing
   Just asName -> Just $ SgBind asName ref
 
-patternArgumentMapper :: (GraphAndRef, t) -> Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph)
+patternArgumentMapper :: ((GraphAndRef, Maybe String), t) -> (String, Either (GraphAndRef, t) (SgNamedNode, SyntaxGraph))
-patternArgumentMapper argAndPort = case graph of
+patternArgumentMapper (asGraphAndRef@(graphAndRef, _), port) = (patName, eitherVal)
+  where
+    graph = graphAndRefToGraph graphAndRef
+    patName = patternName asGraphAndRef
+
+    eitherVal = case graph of
       (SyntaxGraph [namedNode] [] _ _ _) -> Right (namedNode, graph)
-  _ -> Left argAndPort
+      _ -> Left (graphAndRef, port)
-  where graph = graphAndRefToGraph $ fst argAndPort
+
 
 graphToTuple :: SyntaxGraph -> ([SgNamedNode], [Edge], [SgSink], [SgBind], [(NodeName, NodeName)])
 graphToTuple (SyntaxGraph a b c d e) = (a, b, c, d, e)
@@ -137,22 +151,24 @@ graphsToComponents graphs = (concat a, concat b, concat c, concat d, concat e) w
 makeNestedPatternGraph :: NodeName -> String -> [(GraphAndRef, Maybe String)] -> (SyntaxGraph, NameAndPort)
 makeNestedPatternGraph applyIconName funStr argVals = nestedApplyResult
   where
-    pAppNode = NestedPatternApplyNode funStr argList
+    dummyNode = NestedPatternApplyNode "" []
-    argsAndPorts = zip (fmap fst argVals) $ map (nameAndPort applyIconName) $ argumentPorts pAppNode
+
+    argsAndPorts = zip argVals $ map (nameAndPort applyIconName) $ argumentPorts dummyNode
     mappedArgs = fmap patternArgumentMapper argsAndPorts
 
-    (unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers mappedArgs
+    (unnestedArgsAndPort, nestedNamedNodesAndGraphs) = partitionEithers (fmap snd mappedArgs)
 
     (nestedArgs, _, nestedSinks, nestedBinds, nestedEMaps) = graphsToComponents $ fmap snd nestedNamedNodesAndGraphs
 
-    argListMapper arg = case arg of
+    argListMapper (str, arg) = case arg of
-      Left _ -> Nothing
+      Left _ -> (Nothing, str)
-      Right (namedNode, _) -> Just namedNode
+      Right (namedNode, _) -> (Just namedNode, str)
 
     argList = fmap argListMapper mappedArgs
 
     combinedGraph = combineExpressions True unnestedArgsAndPort
 
+    pAppNode = NestedPatternApplyNode funStr argList
     icons = [SgNamedNode applyIconName pAppNode]
 
     asNameBinds = catMaybes $ fmap asNameBind argVals
@@ -615,14 +631,6 @@ evalRecConstr c qName _ = evalQName qName c
 asBindGraphZipper :: Maybe String -> NameAndPort -> SyntaxGraph
 asBindGraphZipper asName nameNPort = makeAsBindGraph (Right nameNPort) [asName]
 
-paramName :: (GraphAndRef, Maybe String) -> String
-paramName (GraphAndRef _ ref, mStr) = fromMaybe
-  (case ref of
-    Left str -> str
-    Right _ -> ""
-  )
-  mStr
-
 generalEvalLambda :: EvalContext -> [Pat] -> (EvalContext -> State IDState GraphAndRef) -> State IDState (SyntaxGraph, NameAndPort)
 generalEvalLambda context patterns rhsEvalFun = do
   lambdaName <- getUniqueName
@@ -631,7 +639,7 @@ generalEvalLambda context patterns rhsEvalFun = do
     patternVals = fmap fst patternValsWithAsNames
     patternStrings = concatMap namesInPattern patternValsWithAsNames
     rhsContext = patternStrings <> context
-    paramNames = fmap paramName patternValsWithAsNames
+    paramNames = fmap patternName patternValsWithAsNames
     lambdaNode = FunctionDefNode paramNames
     lambdaPorts = map (nameAndPort lambdaName) $ argumentPorts lambdaNode
     patternGraph = mconcat $ fmap graphAndRefToGraph patternVals

app/TranslateCore.hs

@@ -31,6 +31,7 @@ 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
@@ -278,11 +279,11 @@ nestedCaseOrGuardNodeToIcon tag numArgs args = case tag of
     argPorts = take (2 * numArgs) $ argumentPorts dummyNode
     argList = fmap (makeArg args) (inputPort dummyNode : argPorts)
 
-nestedPatternNodeToIcon :: String -> [Maybe SgNamedNode] -> Icon
+nestedPatternNodeToIcon :: String -> [(Maybe SgNamedNode, String)] -> Icon
 nestedPatternNodeToIcon str children = NestedPApp $
-  Just (NodeName (-1), TextBoxIcon str)
+  (Just (NodeName (-1), TextBoxIcon str), "")
   :
-  (fmap (mapNodeInNamedNode nodeToIcon) <$> children)
+  fmap (Arrow.first $ fmap (mapNodeInNamedNode nodeToIcon)) children
 
 findArg :: Port -> (SgNamedNode, Edge) -> Bool
 findArg currentPort (SgNamedNode argName _, Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))

app/Types.hs

@@ -37,7 +37,7 @@ data Icon = TextBoxIcon String | GuardIcon Int
   | BindTextBoxIcon String
   -- TODO: NestedApply should have the type NestedApply (Maybe (Name, Icon)) [Maybe (Name, Icon)]
   | NestedApply LikeApplyFlavor [Maybe (NodeName, Icon)]
-  | NestedPApp [Maybe (NodeName, Icon)]
+  | NestedPApp [(Maybe (NodeName, Icon), String)]
   | NestedCaseIcon [Maybe (NodeName, Icon)]
   | NestedGuardIcon [Maybe (NodeName, Icon)]
   deriving (Show, Eq, Ord)
@@ -52,7 +52,7 @@ data SyntaxNode =
   | NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
   | PatternApplyNode String Int -- Destructors as used in patterns
   -- | NestedPatternApplyNode String Int [(SgNamedNode, Edge)]
-  | NestedPatternApplyNode String [Maybe SgNamedNode]
+  | NestedPatternApplyNode String [(Maybe SgNamedNode, String)]
   | NameNode String -- Identifiers or symbols
   | BindNameNode String
   | LiteralNode String -- Literal values like the string "Hello World"

test/UnitTests.hs

@@ -38,10 +38,10 @@ renameNode nameMap counter (SgNamedNode nodeName syntaxNode) = (newNamedNode, na
   newNamedNode = SgNamedNode newNodeName newSyntaxNode
 
 maybeRenameNodeFolder ::
-  ([Maybe SgNamedNode], NameMap, Int) -> Maybe SgNamedNode -> ([Maybe SgNamedNode], NameMap, Int)
+  ([(Maybe SgNamedNode, String)], NameMap, Int) -> Maybe SgNamedNode -> ([(Maybe SgNamedNode, String)], NameMap, Int)
 maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of
-  Nothing -> (Nothing:renamedNodes, nameMap, counter)
+  Nothing -> ((Nothing, ""):renamedNodes, nameMap, counter)
-  Just node -> (Just newNamedNode:renamedNodes, newNameMap, newCounter) where
+  Just node -> ((Just newNamedNode, ""):renamedNodes, newNameMap, newCounter) where
     (newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node
 
 renameSyntaxNode :: NameMap -> SyntaxNode -> Int  -> (SyntaxNode, NameMap, Int)
@@ -49,7 +49,7 @@ renameSyntaxNode nameMap node counter = case node of
   -- TODO Keep the Nothing subNodes
   NestedPatternApplyNode s subNodes -> (NestedPatternApplyNode s (reverse renamedSubNodes), newNameMap, counter2)
     where
-      (renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) subNodes
+      (renamedSubNodes, newNameMap, counter2) = foldl' maybeRenameNodeFolder ([], nameMap, counter) (fmap fst subNodes)
   _ -> (node, nameMap, counter)
 
 renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int)

test/VisualTranslateTests.hs

@@ -166,7 +166,10 @@ patternTests = [
 
   "y = let {(x, y) = (1,2)} in x + y",
   "y = let {(x, y) = (1,2); (z, w) = x; (m, g) = y} in foo x y z w m g",
-  "(x:y) = 2"
+  "(x:y) = 2",
+
+  -- test labelled ports
+  "Foo x1 x2 = 4"
   ]
 
 lambdaTests :: [String]