Integrate text with apply icons.

app/Icons.hs

@@ -40,7 +40,8 @@ data ColorStyle a = ColorStyle {
   lamArgResC :: Colour a,
   regionPerimC :: Colour a,
   caseRhsC :: Colour a,
-  patternC :: Colour a
+  patternC :: Colour a,
+  patternTextC :: Colour a
 }
 
 colorOnBlackScheme :: (Floating a, Ord a) => ColorStyle a
@@ -55,7 +56,8 @@ colorOnBlackScheme = ColorStyle {
   lamArgResC = lightSlightlyPurpleBlue,
   regionPerimC = lime,
   caseRhsC = slightlyGreenYellow,
-  patternC = lightMagenta
+  patternC = lightMagenta,
+  patternTextC = cyan
 }
   where
     slightlyGreenYellow = sRGB24 212 255 0
@@ -74,7 +76,8 @@ whiteOnBlackScheme = ColorStyle {
   lamArgResC = white,
   regionPerimC = white,
   caseRhsC = white,
-  patternC = white
+  patternC = white,
+  patternTextC = white
 }
 
 -- Use this to test that all of the colors use the colorScheme
@@ -90,7 +93,8 @@ randomColorScheme = ColorStyle {
   lamArgResC = red,
   regionPerimC = cyan,
   caseRhsC = red,
-  patternC = olive
+  patternC = olive,
+  patternTextC = coral
 }
 
 lineCol :: (Floating a, Ord a) => Colour a
@@ -103,6 +107,8 @@ iconToDiagram ::
       Renderable (Text n) b) =>
      Icon -> [(Name, QDiagram b V2 n Any)] -> QDiagram b V2 n Any
 iconToDiagram (ApplyAIcon n) _ = applyADia n
+iconToDiagram (PAppIcon n str) _ = pAppDia n str
+iconToDiagram (TextApplyAIcon n str) _ = textApplyADia n str
 iconToDiagram ResultIcon _ = resultIcon
 iconToDiagram BranchIcon _ = branchIcon
 iconToDiagram (TextBoxIcon s) _ = textBox s
@@ -167,7 +173,7 @@ applyA0Dia ::
    (RealFloat n, Typeable n, Monoid m, Semigroup m,
       TrailLike (QDiagram b V2 n m)) =>
      QDiagram b V2 n m
-applyA0Dia = (resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations # centerXY
+applyA0Dia = ((resultCircle ||| apply0Line ||| apply0Triangle) <> makePortDiagrams apply0PortLocations) # reflectX # centerXY
 
 apply0PortLocations :: Floating a => [P2 a]
 apply0PortLocations = map p2 [
@@ -191,7 +197,7 @@ applyADia ::
    (RealFloat n, Typeable n, Monoid m, Semigroup m,
       TrailLike (QDiagram b V2 n m)) =>
      Int -> QDiagram b V2 n m
-applyADia 1 = applyA0Dia
+--applyADia 1 = applyA0Dia
 applyADia n = finalDia # centerXY where
   seperation = circleRadius * 1.5
   trianglePortsCircle = hcat [
@@ -204,6 +210,16 @@ applyADia n = finalDia # centerXY where
   topAndBottomLine = hrule topAndBottomLineWidth # lc (apply0C colorScheme) # lwG defaultLineWidth # alignL
   finalDia = topAndBottomLine === allPorts === topAndBottomLine
 
+--textApplyADia :: _ => Int -> String -> QDiagram b V2 n m
+textApplyADia :: (RealFloat n, Typeable n, Renderable (Path V2 n) b,
+  Renderable (Text n) b) =>
+  Int -> String -> QDiagram b V2 n Any
+textApplyADia numArgs functionName = textBox functionName ||| applyADia numArgs
+
+pAppDia numArgs constructorName =
+  coloredTextBox (patternTextC colorScheme) (opaque (patternC colorScheme)) constructorName
+  ||| applyADia numArgs
+
 -- TEXT ICON --
 textBoxFontSize :: (Num a) => a
 textBoxFontSize = 1
@@ -347,7 +363,7 @@ caseIcon = generalGuardIcon (patternC colorScheme) caseC caseResult
 -- 2,3.. : The parameters
 flatLambda n = finalDia where
   lambdaCircle = circle circleRadius # fc (regionPerimC colorScheme) # lc (regionPerimC colorScheme) # lwG defaultLineWidth
-  lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++  [makePort 1 <> lambdaCircle])
+  lambdaParts = (makePort 0 <> resultIcon) : (portIcons ++  [makePort 1 <> (alignR lambdaCircle)])
   portIcons = take n $ map (\x -> makePort x <> portCircle) [2,3..]
   middle = alignL (hsep 0.5 lambdaParts)
   topAndBottomLineWidth = width middle - circleRadius

app/Translate.hs

@@ -52,12 +52,10 @@ evalPApp :: QName -> [Pat] -> State IDState (IconGraph, NameAndPort)
 evalPApp name [] = makeBox $ qNameToString name
 evalPApp name patterns = do
   patName <- DIA.toName <$> getUniqueName "pat"
-  let
-    context = mempty
   evaledPatterns <- mapM evalPattern patterns
-  constructorName <- evalQName name context
   let
-    gr = makeApplyGraph True patName constructorName evaledPatterns (length evaledPatterns)
+    constructorName = qNameToString name
+    gr = makeTextApplyGraph True patName constructorName evaledPatterns (length evaledPatterns)
   pure gr
 
 
@@ -106,8 +104,33 @@ evalQOp :: QOp -> EvalContext -> State IDState (IconGraph, Reference)
 evalQOp (QVarOp n) = evalQName n
 evalQOp (QConOp n) = evalQName n
 
+makeTextApplyGraph :: Bool -> DIA.Name -> String -> [(IconGraph, Reference)] -> Int -> (IconGraph, NameAndPort)
+makeTextApplyGraph inPattern applyIconName funStr argVals numArgs = (newGraph <> combinedGraph, nameAndPort applyIconName 1)
+  where
+    argumentPorts = map (nameAndPort applyIconName) [2,3..]
+    combinedGraph = combineExpressions inPattern $ zip argVals argumentPorts
+    icon = if inPattern
+      then PAppIcon
+      else TextApplyAIcon
+    icons = [(applyIconName, icon numArgs funStr)]
+    newGraph = iconGraphFromIcons icons
+
 evalApp :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort)
-evalApp c (funExp, argExps) = do
+evalApp c exps@(funExp, argExps) = case funExp of
+  (Var n) -> makeTextApp n
+  (Con n) -> makeTextApp n
+  _ -> evalAppNoText c exps
+  where
+    makeTextApp funName = let funStr = qNameToString funName in
+      if funStr `elem` c
+      then evalAppNoText c exps
+      else do
+        argVals <- mapM (evalExp c) argExps
+        applyIconName <- DIA.toName <$> getUniqueName "app0"
+        pure $ makeTextApplyGraph False applyIconName funStr argVals (length argExps)
+
+evalAppNoText :: EvalContext -> (Exp, [Exp]) -> State IDState (IconGraph, NameAndPort)
+evalAppNoText c (funExp, argExps) = do
   funVal <- evalExp c funExp
   argVals <- mapM (evalExp c) argExps
   applyIconName <- DIA.toName <$> getUniqueName "app0"
@@ -399,6 +422,7 @@ generalEvalLambda context patterns rhsEvalFun = do
   pure (deleteBindings . makeEdges $ (rhsRawGraph <> patternGraph <> finalGraph), nameAndPort lambdaName 1)
   where
     -- TODO Like evalPatBind, this edge should have an indicator that it is the input to a pattern.
+    -- makePatternEdges creates the edges between the patterns and the parameter ports.
     makePatternEdges :: String -> GraphAndRef -> NameAndPort -> Either Edge (String, Reference)
     makePatternEdges lambdaName (_, Right patPort) lamPort =
       Left $ makeSimpleEdge (lamPort, patPort)

app/Types.hs

@@ -23,7 +23,8 @@ import Control.Monad.State(State, state)
 -- The LambdaRegionIcon's data is the number of lambda ports, and the name of it's
 -- subdrawing.
 data Icon = ResultIcon | BranchIcon | TextBoxIcon String | GuardIcon Int
-  | LambdaRegionIcon Int Name | FlatLambdaIcon Int | ApplyAIcon Int | CaseIcon Int | CaseResultIcon
+  | LambdaRegionIcon Int Name | FlatLambdaIcon Int | ApplyAIcon Int
+  | TextApplyAIcon Int String | PAppIcon Int String | CaseIcon Int | CaseResultIcon
   deriving (Show)
 
 data NameAndPort = NameAndPort Name (Maybe Int) deriving (Show)