Refactor GraphAlgorithms.hs.

app/DrawingColors.hs

@@ -8,6 +8,8 @@ module DrawingColors (
 
 import Diagrams.Prelude hiding ((&), (#))
 
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
+
 -- COLO(U)RS --
 colorScheme :: ColorStyle Double
 colorScheme = colorOnBlackScheme

app/GraphAlgorithms.hs

@@ -1,65 +1,77 @@
+{-# LANGUAGE MultiWayIf #-}
 module GraphAlgorithms(
   ParentType(..),
-  collapseNodes,
+  annotateGraph,
-  findTreeRoots,
+  collapseAnnotatedGraph
-  nodeWillBeEmbedded
   ) where
 
-import qualified Data.Graph.Inductive as ING
-
 import qualified Control.Arrow as Arrow
+import qualified Data.Graph.Inductive as ING
 import Data.List(foldl', find)
-import Data.Maybe(catMaybes, isJust, fromMaybe)
+import Data.Tuple(swap)
---import qualified Debug.Trace
 
 import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
-             CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..))
+             CaseOrMultiIfTag(..), Port(..), NameAndPort(..), SgNamedNode(..)
-import Util(maybeBoolToBool, sgNamedNodeToSyntaxNode)
+            , AnnotatedGraph, EmbedInfo(..), EmbedDirection(..))
---import Util(printSelf)
+import Util(sgNamedNodeToSyntaxNode)
 {-# ANN module "HLint: ignore Use record patterns" #-}
 
--- See graph_algs.txt for pseudocode
+data ParentType = ApplyParent
-
+                | CaseParent
-data ParentType = ApplyParent | CaseParent | MultiIfParent | NotAParent
+                | MultiIfParent
+                | NotAParent
   deriving (Eq, Show)
 
-data DirectionalEdge a = ParentToChild a | ChildToParent a deriving (Eq, Show)
+-- Helper functions
 
--- START HELPER functions --
+parentAndChild :: EmbedDirection
+               -> (a, a) -- ^ (from, to)
+               -> (a, a) -- ^ (parent, child)
+parentAndChild embedDirection
+  = case embedDirection of
+      EdEmbedTo -> id
+      EdEmbedFrom -> swap
 
--- TODO Replace with records.
+-- End helper functions
-unwrapDirectionalEdge :: DirectionalEdge a -> a
+-- START annotateGraph --
-unwrapDirectionalEdge d = case d of
-  ParentToChild e -> e
-  ChildToParent e -> e
 
 -- | A syntaxNodeIsEmbeddable if it can be collapsed into another node
-syntaxNodeIsEmbeddable :: ParentType -> SyntaxNode -> Maybe Port -> Bool
+syntaxNodeIsEmbeddable :: ParentType
-syntaxNodeIsEmbeddable parentType n mParentPort = case (parentType, n) of
+                       -> SyntaxNode
-  (ApplyParent, LikeApplyNode _ _) -> notResultPort
+                       -> Maybe Port
-  (ApplyParent, LiteralNode _) -> notResultPort
+                       -> Maybe Port
+                       -> Bool
+syntaxNodeIsEmbeddable parentType n mParentPort _mChildPort
+  = case (parentType, n) of
+      (ApplyParent, LikeApplyNode _ _) -> parentPortNotResult
+      (ApplyParent, LiteralNode _) -> parentPortNotResult
+      -- TODO Embedded FunctionDefNodes are missing their enclosures.
+      -- (ApplyParent, FunctionDefNode _ _)
+      --   -> isInput mParentPort && isResult mChildPort
 
-  (CaseParent, LiteralNode _) -> notResultPort
+      (CaseParent, LiteralNode _) -> parentPortNotResult
-  (CaseParent, LikeApplyNode _ _) -> notResultPort && notInputPort
+      (CaseParent, LikeApplyNode _ _)
-  (CaseParent, NestedPatternApplyNode _ _) -> notResultPort && notInputPort
+        -> parentPortNotResult && parentPortNotInput
+      (CaseParent, NestedPatternApplyNode _ _)
+        -> parentPortNotResult && parentPortNotInput
 
-  (MultiIfParent, LiteralNode _) -> notResultPort
+      (MultiIfParent, LiteralNode _) -> parentPortNotResult
-  (MultiIfParent, LikeApplyNode _ _) -> notResultPort && notInputPort
+      (MultiIfParent, LikeApplyNode _ _)
+        -> parentPortNotResult && parentPortNotInput
 
-  _ -> False
+      _ -> False
   where
-    notInputPort = case mParentPort of
+    isInput mPort = case mPort of
-      Just (Port 0) -> False
+      Just (Port 0) -> True
-      _ -> True
+      _ -> False
-    notResultPort = case mParentPort of
+
-      -- TODO Don't use hardcoded port number
+    isResult mPort = case mPort of
-      Just (Port 1) -> False
+      Just (Port 1) -> True
+      Just _ -> False
       _ -> True
 
-
+    parentPortNotInput = not $ isInput mParentPort
--- | A syntaxNodeCanEmbed if it can contain other nodes
+    parentPortNotResult = not $ isResult mParentPort
-syntaxNodeCanEmbed :: SyntaxNode -> Bool
-syntaxNodeCanEmbed = (NotAParent /=) . parentTypeForNode
 
 parentTypeForNode :: SyntaxNode -> ParentType
 parentTypeForNode n = case n of
@@ -69,40 +81,80 @@ parentTypeForNode n = case n of
   MultiIfNode _ -> MultiIfParent
   NestedCaseOrMultiIfNode CaseTag _ _ -> CaseParent
   NestedCaseOrMultiIfNode MultiIfTag _ _ -> MultiIfParent
-  -- The NotAParent case should never occur.
   _ -> NotAParent
 
-findNeighbors :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> [ING.Node]
-findNeighbors graph node = filter parentFilter $  ING.neighbors graph node where
-  parentFilter parentNode = parentNode /= node
-
-findParentsWithEdges :: ING.Graph gr =>
-  IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
-findParentsWithEdges graph node = filter parentFilter adjacencies where
-  parentFilter (_, parentNode) = parentNode /= node
-  (incomingEdges, _, _, outgoingEdges) = ING.context graph node
-  mappedIncomingEdges = fmap (Arrow.first ParentToChild) incomingEdges
-  mappedOutgoingEdges = fmap (Arrow.first ChildToParent) outgoingEdges
-  adjacencies = mappedIncomingEdges ++ mappedOutgoingEdges
-
--- | graphNodeCanEmbed returns true if the label (SyntaxNode) associated with
--- the node can be embedded in other SyntaxNodes (i.e. nodeCanEmbed is True)
-graphNodeCanEmbed :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
-graphNodeCanEmbed graph node
-  = maybeBoolToBool $ fmap syntaxNodeCanEmbed (lookupSyntaxNode graph node)
-
 lookupSyntaxNode :: ING.Graph gr =>
   IngSyntaxGraph gr -> ING.Node -> Maybe SyntaxNode
 lookupSyntaxNode gr node = sgNamedNodeToSyntaxNode <$> ING.lab gr node
 
 lookupParentType :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> ParentType
 lookupParentType graph node
-  = fromMaybe NotAParent $ parentTypeForNode <$> lookupSyntaxNode graph node
+  = maybe NotAParent parentTypeForNode $ lookupSyntaxNode graph node
 
--- | filterNodes returns a list of the nodes in the graph
+{-# ANN edgeIsSingular "HLint: ignore Redundant bracket" #-}
--- where the filter function is true.
+edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
-filterNodes :: ING.DynGraph gr => (ING.Node -> Bool) -> gr a b -> [ING.Node]
+edgeIsSingular graph node edge = numEdges <= 1 where
-filterNodes condition gr = ING.nodes $ ING.nfilter condition gr
+  (childNamePort, _) = edgeConnection edge
+  edgeLabels = filter
+               (childNamePort ==)
+               ((fst . edgeConnection . snd) <$> ING.lsuc graph node)
+  numEdges = length edgeLabels
+
+parentCanEmbedChild :: ING.Graph gr =>
+  IngSyntaxGraph gr -> ING.Node -> ING.Node -> Edge -> EmbedDirection -> Bool
+parentCanEmbedChild graph parent child edge embedDirection
+  = case lookupSyntaxNode graph child of
+      Nothing -> False
+      Just childSyntaxNode ->
+        edgeIsSingular graph child edge
+        && syntaxNodeIsEmbeddable
+        parentType
+        childSyntaxNode
+        parentPort
+        childPort
+        where
+          parentType = lookupParentType graph parent
+          (NameAndPort _ fromPort, NameAndPort _ toPort) = edgeConnection edge
+          (parentPort, childPort)
+            = parentAndChild embedDirection (fromPort, toPort)
+
+findEmbedDir :: ING.Graph gr
+             => IngSyntaxGraph gr
+             -> ING.Node
+             -> ING.Node
+             -> Edge
+             -> Maybe EmbedDirection
+findEmbedDir gr fromNode toNode e = if
+  | parentCanEmbedChild gr fromNode toNode e EdEmbedTo
+    -> Just EdEmbedTo
+  | parentCanEmbedChild gr toNode fromNode e EdEmbedFrom
+    -> Just EdEmbedFrom
+  | otherwise -> Nothing
+
+annotateGraph :: ING.DynGraph gr => IngSyntaxGraph gr -> AnnotatedGraph gr
+annotateGraph gr = ING.gmap edgeMapper gr
+  where
+    edgeMapper :: ING.Context SgNamedNode Edge
+               -> ING.Context SgNamedNode (EmbedInfo Edge)
+    edgeMapper (inEdges, node, nodeLabel, outEdges)
+      = (getInEmbedInfo node inEdges
+        , node
+        , nodeLabel
+        , getOutEmbedInfo node outEdges)
+    getInEmbedInfo toNode
+      = fmap (\(e, fromNode)
+               -> (EmbedInfo (findEmbedDir gr fromNode toNode e) e, fromNode))
+    getOutEmbedInfo fromNode
+     = fmap (\(e, toNode)
+              -> (EmbedInfo (findEmbedDir gr fromNode toNode e) e, toNode))
+
+-- END annotateGraph --
+-- START collapseAnnotatedGraph --
+
+findEdgeLabel :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
+findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
+  labelledEdges = ING.lneighbors graph node1
+  matchingEdges = find ((== node2) . snd) labelledEdges
 
 -- | Replace the a node's label
 changeNodeLabel :: ING.DynGraph gr => gr a b -> ING.Node -> a -> gr a b
@@ -111,194 +163,18 @@ changeNodeLabel graph node newLabel = case ING.match node graph of
     -> (inEdges, node, newLabel, outEdges) ING.& restOfTheGraph
   (Nothing, _) -> graph
 
-findEdgeLabel :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
-findEdgeLabel graph node1 node2 = fmap fst matchingEdges where
-  labelledEdges = ING.lneighbors graph node1
-  matchingEdges = find ((== node2) . snd) labelledEdges
-
-parentCanEmbedChild :: ING.Graph gr =>
-  IngSyntaxGraph gr -> ING.Node -> ING.Node -> DirectionalEdge Edge -> Bool
-parentCanEmbedChild graph parent child directionalEdge
-  = case lookupSyntaxNode graph child of
-      Nothing -> False
-      Just childSyntaxNode
-        -> syntaxNodeIsEmbeddable parentType childSyntaxNode parentPort
-        where
-          parentType = lookupParentType graph parent
-          parentPort = case directionalEdge of
-            ParentToChild edge -> port where
-              (NameAndPort _ port, _) = edgeConnection edge
-            ChildToParent edge -> port where
-              (_, NameAndPort _ port) = edgeConnection edge
-
-findParentsThatCanEmbed :: ING.Graph gr =>
-  IngSyntaxGraph gr -> ING.Node -> ING.Adj (DirectionalEdge Edge)
-findParentsThatCanEmbed graph child
-  = filter parentFilter (findParentsWithEdges graph child)
-  where
-    parentFilter (directionalEdge, parentNode)
-      = graphNodeCanEmbed graph parentNode
-        && parentCanEmbedChild graph parentNode child directionalEdge
-
--- | Finds the first edge from the first node to the second node
-findEdge :: ING.Graph gr => gr a b -> ING.Node -> ING.Node -> Maybe b
-findEdge graph fromNode toNode = lookup toNode $ ING.lsuc graph fromNode
-
-edgeIsSingular :: ING.Graph gr => gr a Edge -> ING.Node -> Edge -> Bool
-edgeIsSingular graph node edge = numEdges == 1 where
-  (childNamePort, _) = edgeConnection edge
-  edgeLabels = filter
-               (childNamePort ==)
-               ((fst . edgeConnection . snd) <$> ING.lsuc graph node)
-  numEdges = length edgeLabels
-
-parentIsOnlyEdge :: ING.Graph gr =>
-  IngSyntaxGraph gr -> ING.Node -> ING.Node -> Bool
-parentIsOnlyEdge graph parent child = case findEdge graph child parent of
-  Just edge -> edgeIsSingular graph child edge
-  Nothing -> case findEdge graph parent child of
-    Just edge -> edgeIsSingular graph parent edge
-    Nothing
-      -> error
-         "parentIsOnlyEdge: There is no edge from the child to the parent."
-
-findParentThatWillEmbed :: ING.Graph gr =>
-  IngSyntaxGraph gr -> ING.Node -> Maybe (DirectionalEdge Edge, ING.Node)
-findParentThatWillEmbed graph child =
-  case findParentsThatCanEmbed graph child of
-    [parent] -> if parentIsOnlyEdge graph (snd parent) child
-      then Just parent
-      else Nothing
-    _ -> Nothing
-
--- END helper functions --
-
-collapseNodes :: (ING.DynGraph gr) => IngSyntaxGraph gr -> IngSyntaxGraph gr
-collapseNodes originalGraph = finalGraph where
-  -- findTreeRoots returns a list of nodes that will embed other nodes, but are
-  -- not embedded themselves.
-  -- These nodes are thus each a root of a collapsed node tree.
-  treeRoots = findTreeRoots originalGraph
-  -- Now collapse each tree of nodes
-  finalGraph = collapseRoots originalGraph originalGraph treeRoots
-
--- START findTreeRoots functions --
-
--- | findTreeRoots returns a list of nodes that might embed other nodes, but are
--- not embedded themselves.
--- These nodes are thus each a root of a collapsed node tree.
--- A node is a treeRoot if all of these conditions are true:
--- 1. The SyntaxNode can embed other nodes (i.e. syntaxNodeCanEmbed is true)
--- 2. The node will not be embedded.
--- Note: A treeRoot may not actually have any embeddable children, since
--- collapseTree will do nothing in that case.
-findTreeRoots :: ING.DynGraph gr => IngSyntaxGraph gr -> [ING.Node]
-findTreeRoots graph = filterNodes isTreeRoot graph where
-  isTreeRoot node
-    = graphNodeCanEmbed graph node && not (nodeWillBeEmbedded graph node)
-
-nodeWillBeEmbedded :: ING.Graph gr => IngSyntaxGraph gr -> ING.Node -> Bool
-nodeWillBeEmbedded graph node = isJust $ findParentThatWillEmbed graph node
-
--- END findTreeRoots functions
--- START collapseRoots functions
-
-collapseRoots :: ING.DynGraph gr =>
-  IngSyntaxGraph gr -> IngSyntaxGraph gr -> [ING.Node] -> IngSyntaxGraph gr
-collapseRoots originalGraph = foldl' (collapseTree originalGraph)
-
-collapseTree :: ING.DynGraph gr =>
-  IngSyntaxGraph gr -> IngSyntaxGraph gr -> ING.Node -> IngSyntaxGraph gr
-collapseTree originalGraph oldGraph rootNode = case childrenToEmbed of
-  [] -> oldGraph
-  _ -> finalGraph
-  where
-    -- Need to use the original graph for finding children, otherwise a node can
-    -- be embedded when it is used twice in what will be a single embedding
-    -- node.
-    -- Examples:
-    --  "y = foo (3 + bazOf2) bazOf2 where bazOf2 = baz 2",
-    --  "y = foo (3 + bazOf2) (8 * bazOf2) where bazOf2 = baz 2"
-    childrenToEmbedWithEdges = findChildrenToEmbed rootNode originalGraph
-    childrenToEmbed = fmap snd childrenToEmbedWithEdges
-    -- Recursively collapse the children nodes
-    graphWithCollapsedChildren
-      = collapseRoots originalGraph oldGraph childrenToEmbed
-    -- Modify the rootNode label (i.e. SyntaxNode) to incorporate the children
-    -- it is embedding.
-    graphWithEmbeddedChildren = embedChildSyntaxNodes
-                                rootNode
-                                childrenToEmbed
-                                graphWithCollapsedChildren
-    -- Transfer the edges of the children to rootNode.
-    childEdgesToTransfer = findChildEdgesToTransfer
-                           rootNode
-                           childrenToEmbedWithEdges
-                           graphWithEmbeddedChildren
-    graphWithEdgesTransferred
-      = ING.insEdges childEdgesToTransfer graphWithEmbeddedChildren
-    -- Delete the children that have been embedded (and any or their remaining
-    -- edges).
-    finalGraph = deleteChildren childrenToEmbed graphWithEdgesTransferred
-
--- | findChildrenToEmbed returns a list of the node's children that can be
--- embedded.
--- A child can be embedded iff all of these conditions are true:
--- 1. The node is not a treeRoot (otherwise a cycle of embedding could occur).
--- 2. The SyntaxNode is embeddable (i.e. syntaxNodeIsEmbeddable is True).
--- 3. The node has exactly one parent that can embed (i.e. nodeCanEmbed is True
--- for one parent).
-findChildrenToEmbed :: ING.Graph gr =>
-  ING.Node -> IngSyntaxGraph gr -> ING.Adj (DirectionalEdge Edge)
-findChildrenToEmbed node graph = if graphNodeCanEmbed graph node
-  then childrenToEmbed
-  else []
-  where
-    childrenToEmbed =
-      catMaybes
-      $ fmap (childCanBeEmbedded node graph) (findNeighbors graph node)
-
-childCanBeEmbedded :: ING.Graph gr =>
-  ING.Node
-  -> IngSyntaxGraph gr
-  -> ING.Node
-  -> Maybe (DirectionalEdge Edge, ING.Node)
-childCanBeEmbedded parentNode graph child = case
-  findParentThatWillEmbed graph child of
-    Nothing -> Nothing
-    Just (edge, childsParent) -> if childsParent == parentNode
-      then Just (edge, child)
-      else Nothing
-
-edgesNotEqual :: Eq b => DirectionalEdge b -> ING.LEdge b -> Bool
-edgesNotEqual dirEdge (_, _, e) = e /= unwrapDirectionalEdge dirEdge
-
-findChildEdgesToTransfer :: (Eq b, ING.Graph gr) =>
-  ING.Node -> ING.Adj (DirectionalEdge b) -> gr a b-> [ING.LEdge b]
-findChildEdgesToTransfer parentNode childrenToEmbed graph
-  = concatMap makeLabelledGraphEdges childrenToEmbed
-  where
-    makeLabelledGraphEdges (directionalParentToChildEdge, childNode)
-      = changeEdgeToParent parentNode childNode
-        <$> filter
-        (edgesNotEqual directionalParentToChildEdge)
-        (ING.inn graph childNode ++ ING.out graph childNode)
-
-changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
-changeEdgeToParent parentNode childNode lEdge@(fromNode, toNode, edgeLabel)
-  | childNode == fromNode = (parentNode, toNode, edgeLabel)
-  | childNode == toNode = (fromNode, parentNode, edgeLabel)
-  | otherwise = lEdge
-
 -- | Change the node label of the parent to be nested.
-embedChildSyntaxNodes :: ING.DynGraph gr =>
+embedChildSyntaxNode :: ING.DynGraph gr =>
-  ING.Node -> [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
+  ING.Node -> ING.Node -> AnnotatedGraph gr -> AnnotatedGraph gr
-embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
+embedChildSyntaxNode parentNode childNode oldGraph = newGraph
-  [] -> oldGraph
-  _ -> newGraph
   where
-    maybeOldNodeLabel = ING.lab oldGraph parentNode
+    mChildAndEdge =
-    newGraph = case maybeOldNodeLabel of
+      (,) <$> ING.lab oldGraph childNode
+      <*> findEdgeLabel oldGraph parentNode childNode
+    childrenAndEdgesToParent = case mChildAndEdge of
+      Nothing -> []
+      Just childAndEdge -> [Arrow.second eiVal childAndEdge]
+    newGraph = case ING.lab oldGraph parentNode of
       Nothing -> oldGraph
       Just oldNodeLabel -> changeNodeLabel oldGraph parentNode newNodeLabel
         where
@@ -307,19 +183,50 @@ embedChildSyntaxNodes parentNode childrenNodes oldGraph = case childrenNodes of
           newSyntaxNode = case oldSyntaxNode of
             LikeApplyNode flavor x
               -> NestedApplyNode flavor x childrenAndEdgesToParent
+            NestedApplyNode flavor x existingNodes
+              -> NestedApplyNode flavor x
+                 (childrenAndEdgesToParent <> existingNodes)
             CaseNode x
               -> NestedCaseOrMultiIfNode CaseTag x childrenAndEdgesToParent
+            NestedCaseOrMultiIfNode tag x existingNodes
+              -> NestedCaseOrMultiIfNode tag x
+                 (childrenAndEdgesToParent <> existingNodes)
             MultiIfNode x
               -> NestedCaseOrMultiIfNode MultiIfTag x childrenAndEdgesToParent
             _ -> oldSyntaxNode
-    childrenAndEdgesToParent = catMaybes $ fmap findChildAndEdge childrenNodes
+
-    findChildAndEdge childNode =
+changeEdgeToParent :: ING.Node -> ING.Node -> ING.LEdge b -> ING.LEdge b
-      (,) <$> ING.lab oldGraph childNode
+changeEdgeToParent parentNode childNode (fromNode, toNode, lab)
-      <*> findEdgeLabel oldGraph parentNode childNode
+  = (toParent fromNode, toParent toNode, lab)
+  where
+    toParent node = if node == childNode then parentNode else node
+
+collapseEdge :: ING.DynGraph gr
+             => AnnotatedGraph gr
+             -> ING.LEdge (EmbedInfo Edge)
+             -> AnnotatedGraph gr
+collapseEdge oldGraph (fromNode, toNode, e@(EmbedInfo mEmbedDir _))
+  = case mEmbedDir of
+      Nothing -> oldGraph
+      Just embedDir -> childDeletedGraph
+        where
+          (parentNode, childNode) = parentAndChild embedDir (fromNode, toNode)
+          childEmbeddedGraph
+            = embedChildSyntaxNode parentNode childNode oldGraph
+          childEdgesToTransfer
+            = changeEdgeToParent parentNode childNode
+              <$> filter
+              (\(_, _, edge) -> edge /= e)
+              (ING.inn oldGraph childNode <> ING.out oldGraph childNode)
+          graphWithEdgesTransferred
+            = ING.insEdges childEdgesToTransfer childEmbeddedGraph
+          childDeletedGraph = ING.delNode childNode graphWithEdgesTransferred
 
 
-deleteChildren :: ING.Graph gr =>
+collapseAnnotatedGraph :: ING.DynGraph gr
-  [ING.Node] -> IngSyntaxGraph gr -> IngSyntaxGraph gr
+                       => AnnotatedGraph gr
-deleteChildren = ING.delNodes
+                       -> AnnotatedGraph gr
-
+collapseAnnotatedGraph origGraph = newGraph
--- END collapseRoots functions
+  where
+   -- TODO Check that there are no embedded edges left.
+    newGraph = foldl' collapseEdge origGraph (ING.labEdges origGraph)

app/Icons.hs

@@ -36,6 +36,7 @@ import Types(Icon(..), SpecialQDiagram, SpecialBackend, SpecialNum
 import DrawingColors(colorScheme, ColorStyle(..))
 
 {-# ANN module "HLint: ignore Use record patterns" #-}
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
 
 -- TYPES --
 
@@ -646,7 +647,7 @@ nestedCaseDia = generalNestedMultiIf (patternC colorScheme) caseC caseResult
 -- 2,3.. : The parameters
 flatLambda :: SpecialBackend b n => [String] -> TransformableDia b n
 flatLambda paramNames (TransformParams name _ reflect angle)
-  = named name finalDia
+  = centerXY $ named name finalDia
   where
   lambdaCircle
     = lwG defaultLineWidth

app/Main.hs

@@ -23,6 +23,8 @@ import Rendering(renderIngSyntaxGraph)
 import Translate(translateModuleToCollapsedGraphs)
 import Util(customRenderSVG)
 
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
+
 data CmdLineOptions = CmdLineOptions {
   cmdInputFilename :: String,
   cmdOutputFilename :: String,
@@ -60,7 +62,7 @@ renderFile (CmdLineOptions
   --print "\n\n"
   --print drawings
 
-  diagrams <- traverse renderIngSyntaxGraph drawings
+  diagrams <- traverse (renderIngSyntaxGraph "") drawings
   let
     commentsInBoxes
       = fmap

app/Rendering.hs

@@ -7,7 +7,7 @@ module Rendering (
 ) where
 
 import Diagrams.Prelude(toName, shaftStyle, global, arrowShaft, noTail
-                       , arrowTail, noHead, arrowHead, scale, r2, bezier3
+                       , arrowTail, arrowHead, scale, r2, bezier3
                        , fromSegments, Angle, P2, V2, Point, Name, ArrowOpts, N
                        , TrailLike, V, height, width, (*^), reflectX, rotate
                        , centerXY, place
@@ -27,19 +27,19 @@ import Data.Function(on)
 import qualified Data.Graph.Inductive as ING
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.List(find, minimumBy)
-import Data.Maybe(fromMaybe)
+import Data.Maybe(isNothing, fromMaybe)
 import Data.Typeable(Typeable)
 
 --import qualified Data.GraphViz.Types
 --import Data.GraphViz.Commands
---import qualified Debug.Trace
 
 import Icons(colorScheme, iconToDiagram, defaultLineWidth, ColorStyle(..)
             , getPortAngles, TransformParams(..), circleRadius)
 import TranslateCore(nodeToIcon)
-import Types(Edge(..), EdgeOption(..), Drawing(..), EdgeEnd(..), NameAndPort(..)
+import Types(EmbedInfo(..), AnnotatedGraph, Edge(..)
+            , Drawing(..), NameAndPort(..)
             , SpecialQDiagram, SpecialBackend, SpecialNum, NodeName(..)
-            , Port(..), SgNamedNode, NamedIcon(..), Icon(..))
+            , Port(..), NamedIcon(..), Icon(..))
 
 import Util(fromMaybeError, mapNodeInNamedNode, namedIconToTuple)
 
@@ -66,12 +66,16 @@ drawingToGraphvizScaleFactor = 0.15
 
 -- TODO Refactor with syntaxGraphToFglGraph in TranslateCore
 -- TODO Make this work with nested icons now that names are not qualified.
-drawingToIconGraph :: Drawing -> Gr NamedIcon Edge
+drawingToIconGraph :: Drawing -> Gr NamedIcon (EmbedInfo Edge)
 drawingToIconGraph (Drawing nodes edges) =
   mkGraph nodes labeledEdges where
     labeledEdges = fmap makeLabeledEdge edges
-    makeLabeledEdge e@(Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) =
+
-      (NamedIcon n1 (lookupInNodes n1), NamedIcon n2 (lookupInNodes n2), e)
+    makeLabeledEdge :: Edge -> (NamedIcon, NamedIcon, EmbedInfo Edge)
+    makeLabeledEdge e@(Edge _ (NameAndPort n1 _, NameAndPort n2 _))
+      = (NamedIcon n1 (lookupInNodes n1)
+        , NamedIcon n2 (lookupInNodes n2)
+        , EmbedInfo Nothing e)
       where
         lookupInNodes name = fromMaybeError
                              errorString
@@ -91,47 +95,39 @@ bezierShaft angle1 angle2 = fromSegments [bezier3 c1 c2 x] where
   c2 = rotate angle2 (scale scaleFactor unitX) ^+^ x
 
 getArrowOpts :: (RealFloat n, Typeable n) =>
-  (EdgeEnd, EdgeEnd)
+  (Angle n, Angle n)
-  -> [EdgeOption]
-  -> (Angle n, Angle n)
   -> NameAndPort
   -> (ArrowOpts n, DIA.Colour Double)
-getArrowOpts (t, h)
+getArrowOpts
-  _
   (fromAngle, toAngle)
   (NameAndPort (NodeName nodeNum) mPort)
   = (arrowOptions, shaftColor)
   where
-    -- shaftColor = if EdgeInPattern `elem` opts
-    --              then patternC colorScheme
-    --              else hashedColor
-    shaftColor = hashedColor
-
     edgeColors = edgeListC colorScheme
-    numEdgeColors = length edgeColors
-    hashedColor = edgeColors !! namePortHash
-    namePortHash = mod (portNum + (503 * nodeNum)) numEdgeColors
     Port portNum = fromMaybe (Port 0) mPort
-
+    namePortHash = mod (portNum + (503 * nodeNum)) (length edgeColors)
-    lookupTail EndNone = id
+    shaftColor = edgeColors !! namePortHash
-
-    lookupHead EndNone = id
-
     arrowOptions =
-      arrowHead .~ noHead $
+      arrowHead .~ DIA.noHead
-      arrowTail .~ noTail $
+      -- arrowHead .~ DIA.tri
-      arrowShaft .~ bezierShaft fromAngle toAngle $
+      $ DIA.headStyle %~ DIA.fc shaftColor
-      lengths .~ global 0.75 $
+      $ arrowTail .~ noTail
-      lookupHead h $ lookupTail t with
+      $ arrowShaft .~ bezierShaft fromAngle toAngle
+      -- TODO Don't use a magic number for lengths (headLength and tailLength)
+      $ lengths .~ global 0.5
+      $ with
 
 -- | Given an Edge, return a transformation on Diagrams that will draw a line.
 connectMaybePorts :: SpecialBackend b n =>
-  (Angle n, Angle n)-> Edge -> SpecialQDiagram b n -> SpecialQDiagram b n
+  (Angle n, Angle n)
+  -> EmbedInfo Edge
+  -> SpecialQDiagram b n
+  -> SpecialQDiagram b n
 connectMaybePorts portAngles
-  (Edge
+  (EmbedInfo embedDir
-    opts
+    (Edge
-    ends
+     _
-    (fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2))
+     (fromNamePort@(NameAndPort name0 mPort1), NameAndPort name1 mPort2)))
   -- In order to give arrows a "shadow" effect, draw a thicker semi-transparent
   -- line shaft the same color as the background underneath the normal line
   -- shaft.
@@ -139,8 +135,10 @@ connectMaybePorts portAngles
     . connectFunc arrOptsShadow qPort0 qPort1
   where
     lineWidth = 2 * defaultLineWidth
-    (baseArrOpts, shaftCol) = getArrowOpts ends opts portAngles fromNamePort
+    (baseArrOpts, shaftCol) = getArrowOpts portAngles fromNamePort
-    normalOpts = (shaftStyle %~ (lwG lineWidth . lc shaftCol))
+    -- TODO Use a color from the color scheme for un-embedded shafts.
+    shaftCol' = if isNothing embedDir then shaftCol else DIA.lime
+    normalOpts = (shaftStyle %~ (lwG lineWidth . lc shaftCol'))
                  baseArrOpts
     arrOptsShadow = (shaftStyle
                      %~ (lwG (1.9 * lineWidth)
@@ -218,14 +216,15 @@ lookupNodeAngle rotationMap key
   $ lookup key rotationMap
 
 makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
-  gr NamedIcon Edge
+  String  -- ^ Debugging information
+  -> gr NamedIcon (EmbedInfo Edge)
   -> SpecialQDiagram b n
   -> [(NamedIcon, (Bool, Angle n))]
-  -> ING.LEdge Edge
+  -> ING.LEdge (EmbedInfo Edge)
   -> SpecialQDiagram b n
   -> SpecialQDiagram b n
-makeEdge graph dia rotationMap
+makeEdge debugInfo graph dia rotationMap
-  (node0, node1, edge@(Edge _ _ (namePort0, namePort1)))
+  (node0, node1, edge@(EmbedInfo _ (Edge _ (namePort0, namePort1))))
   = connectMaybePorts portAngles edge
   where
     node0label = fromMaybeError
@@ -257,10 +256,12 @@ makeEdge graph dia rotationMap
 
     getPortPoint n = case foundPoints of
       [point] -> point
-      _ -> error $ "Multiple points with named: " <> show n
+      _ -> error $ "Multiple points. Debug info: " <> debugInfo
+                     <> "\nn: " <> show n
       where
         foundPoints = fromMaybeError
-          ( "makeEdge: port not found. Port: " ++ show n ++ ". Valid ports: "
+          ( "makeEdge: port not found. Debug info: " <> debugInfo
+            <> "\nPort: " ++ show n ++ "\nValid ports: "
             ++ show diaNodeNamePointMap)
           (lookup n diaNodeNamePointMap)
 
@@ -268,13 +269,14 @@ makeEdge graph dia rotationMap
 
 -- | addEdges draws the edges underneath the nodes.
 addEdges :: (SpecialBackend b n, ING.Graph gr) =>
-  gr NamedIcon Edge
+  String  -- ^ Debugging information
+  -> gr NamedIcon (EmbedInfo Edge)
   -> SpecialQDiagram b n
   -> [(NamedIcon, (Bool, Angle n))]
   -> SpecialQDiagram b n
-addEdges graph dia rotationMap = applyAll connections dia
+addEdges debugInfo graph dia rotationMap = applyAll connections dia
   where
-    connections = makeEdge graph dia rotationMap <$> ING.labEdges graph
+    connections = makeEdge debugInfo graph dia rotationMap <$> ING.labEdges graph
 
 -- BEGIN rotateNodes --
 
@@ -296,7 +298,7 @@ scoreAngle iconPosition edges reflected angle
 
 bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
-  -> gr NamedIcon Edge
+  -> gr NamedIcon (EmbedInfo Edge)
   -> NamedIcon
   -> Bool
   -> (Angle n, n)
@@ -322,16 +324,16 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
         portAngles = findPortAngles key nameAndPort
 
   -- Edge points from id to otherNode
-    getSucEdge (otherNode, edge) = (otherNode, nameAndPort) where
+    getSucEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
       (nameAndPort, _) = edgeConnection edge
 
   -- Edge points from otherNode to id
-    getPreEdge (otherNode, edge) = (otherNode, nameAndPort) where
+    getPreEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
       (_, nameAndPort) = edgeConnection edge
 
 findIconRotation :: (SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
-  -> gr NamedIcon Edge
+  -> gr NamedIcon (EmbedInfo Edge)
   -> NamedIcon
   -> (NamedIcon, (Bool, Angle n))
 findIconRotation positionMap graph key = (key, (reflected, angle)) where
@@ -344,7 +346,7 @@ findIconRotation positionMap graph key = (key, (reflected, angle)) where
 
 rotateNodes :: (SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
-  -> gr NamedIcon Edge
+  -> gr NamedIcon (EmbedInfo Edge)
   -> [(NamedIcon, (Bool, Angle n))]
 rotateNodes positionMap graph
   = findIconRotation positionMap graph <$> Map.keys positionMap
@@ -362,8 +364,8 @@ drawLambdaRegions placedNodes
       where
         enclosedDias = fmap findDia enclosedNames
         findDia n1
-          = fromMaybe mempty
+          = maybe mempty snd
-            $ snd <$> find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes
+            (find (\(NamedIcon n2 _, _) -> n1 == n2) placedNodes)
     drawRegion _ = mempty
 
     -- TODO Use something better than a rectangle
@@ -414,11 +416,12 @@ customLayoutParams = GV.defaultParams{
   GV.fmtEdge = const [GV.arrowTo GV.noArrow]
   }
 
-doGraphLayout :: forall b.
+renderIconGraph :: forall b.
   SpecialBackend b Double =>
-  Gr NamedIcon Edge
+  String  -- ^ Debugging information
+  -> Gr NamedIcon (EmbedInfo Edge)
   -> IO (SpecialQDiagram b Double)
-doGraphLayout graph = do
+renderIconGraph debugInfo graph = do
   layoutResult <- layoutGraph' layoutParams GVA.Neato graph
   --  layoutResult <- layoutGraph' layoutParams GVA.Fdp graph
   let
@@ -426,7 +429,7 @@ doGraphLayout graph = do
     rotationMap = rotateNodes positionMap graph
     placedNodeList = placeNodes positionMap rotationMap
     placedNodes = mconcat $ fmap snd placedNodeList
-    edges = addEdges graph placedNodes rotationMap
+    edges = addEdges debugInfo graph placedNodes rotationMap
     placedRegions = drawLambdaRegions placedNodeList
   pure (placedNodes <> edges <> placedRegions)
   where
@@ -459,17 +462,14 @@ doGraphLayout graph = do
 
 -- | Given a Drawing, produce a Diagram complete with rotated/flipped icons and
 -- lines connecting ports and icons. IO is needed for the GraphViz layout.
-renderDrawing ::
+renderDrawing :: SpecialBackend b Double
-  SpecialBackend b Double =>
+  => String  -- ^ Debugging information
-  Drawing -> IO (SpecialQDiagram b Double)
+  -> Drawing
-renderDrawing = renderIconGraph . drawingToIconGraph
+  -> IO (SpecialQDiagram b Double)
+renderDrawing debugInfo = renderIconGraph debugInfo . drawingToIconGraph
 
 renderIngSyntaxGraph ::
   SpecialBackend b Double =>
-  Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
+  String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
-renderIngSyntaxGraph
+renderIngSyntaxGraph debugInfo gr
-  = renderIconGraph . ING.nmap (mapNodeInNamedNode nodeToIcon)
+  = renderIconGraph debugInfo $ ING.nmap (mapNodeInNamedNode nodeToIcon) gr
-
-renderIconGraph :: SpecialBackend b Double
-                => Gr NamedIcon Edge -> IO (SpecialQDiagram b Double)
-renderIconGraph = doGraphLayout

app/Translate.hs

@@ -18,7 +18,7 @@ import Data.Maybe(catMaybes, fromMaybe)
 import qualified Language.Haskell.Exts as Exts
 import qualified Language.Haskell.Exts.Pretty as PExts
 
-import GraphAlgorithms(collapseNodes)
+import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
 import Icons(inputPort, resultPort, argumentPorts, caseRhsPorts,
              casePatternPorts)
 import SimplifySyntax(SimpAlt(..), stringToSimpDecl, SimpExp(..), SimpPat(..)
@@ -32,8 +32,8 @@ import TranslateCore(Reference, SyntaxGraph(..), EvalContext, GraphAndRef(..)
                     , deleteBindings, makeEdges, makeBox, syntaxGraphToFglGraph
                     , getUniqueString, bindsToSyntaxGraph, SgBind(..)
                     , graphAndRefToGraph, initialIdState)
-import Types(Labeled(..), NameAndPort(..), IDState,
+import Types(AnnotatedGraph, Labeled(..), NameAndPort(..), IDState,
-  Edge, SyntaxNode(..), IngSyntaxGraph, NodeName, SgNamedNode(..),
+  Edge, SyntaxNode(..), NodeName, SgNamedNode(..),
   LikeApplyFlavor(..))
 import Util(makeSimpleEdge, nameAndPort, justName)
 
@@ -643,22 +643,24 @@ translateDeclToSyntaxGraph d = graph where
 translateStringToSyntaxGraph :: String -> SyntaxGraph
 translateStringToSyntaxGraph = translateDeclToSyntaxGraph . stringToSimpDecl
 
-syntaxGraphToCollapsedGraph :: SyntaxGraph -> IngSyntaxGraph FGR.Gr
+syntaxGraphToCollapsedGraph :: SyntaxGraph -> AnnotatedGraph FGR.Gr
-syntaxGraphToCollapsedGraph = collapseNodes . syntaxGraphToFglGraph
+syntaxGraphToCollapsedGraph
+  = collapseAnnotatedGraph . annotateGraph . syntaxGraphToFglGraph
+  -- = annotateGraph . syntaxGraphToFglGraph  
 
-translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> IngSyntaxGraph FGR.Gr
+translateDeclToCollapsedGraph :: Show l => Exts.Decl l -> AnnotatedGraph FGR.Gr
 translateDeclToCollapsedGraph
   = syntaxGraphToCollapsedGraph . translateDeclToSyntaxGraph . hsDeclToSimpDecl
 
 -- Profiling: At one point, this was about 1.5% of total time.
 translateStringToCollapsedGraphAndDecl ::
-  String -> (IngSyntaxGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
+  String -> (AnnotatedGraph FGR.Gr, Exts.Decl Exts.SrcSpanInfo)
 translateStringToCollapsedGraphAndDecl s = (drawing, decl) where
   decl = customParseDecl s -- :: ParseResult Module
   drawing = translateDeclToCollapsedGraph decl
 
 translateModuleToCollapsedGraphs :: Show l =>
-  Exts.Module l -> [IngSyntaxGraph FGR.Gr]
+  Exts.Module l -> [AnnotatedGraph FGR.Gr]
 translateModuleToCollapsedGraphs (Exts.Module _ _ _ _ decls)
   = fmap translateDeclToCollapsedGraph decls
 translateModuleToCollapsedGraphs moduleSyntax

app/TranslateCore.hs

@@ -41,7 +41,7 @@ import Types(Labeled(..), Icon(..), SyntaxNode(..), Edge(..), EdgeOption(..)
             , NameAndPort(..), IDState, SgNamedNode(..), NodeName(..), Port
             , LikeApplyFlavor(..), CaseOrMultiIfTag(..), IDState(..)
             , NamedIcon(..))
-import Util(noEnds, nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
+import Util(nameAndPort, makeSimpleEdge, justName, maybeBoolToBool
            , mapNodeInNamedNode, nodeNameToInt)
 
 {-# ANN module "HLint: ignore Use list comprehension" #-}
@@ -150,7 +150,7 @@ edgesForRefPortList inPattern portExpPairs
       Left str -> if inPattern
         then bindsToSyntaxGraph [SgBind str (Right port)]
         else sinksToSyntaxGraph [SgSink str port]
-      Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds connection]
+      Right resPort -> edgesToSyntaxGraph [Edge edgeOpts connection]
         where
           connection = if inPattern
                           -- If in a pattern, then the port on the case icon is
@@ -167,7 +167,7 @@ combineExpressions inPattern portExpPairs
       Left str -> if inPattern
         then bindsToSyntaxGraph [SgBind str (Right port)]
         else sinksToSyntaxGraph [SgSink str port]
-      Right resPort -> edgesToSyntaxGraph [Edge edgeOpts noEnds (resPort, port)]
+      Right resPort -> edgesToSyntaxGraph [Edge edgeOpts (resPort, port)]
 
 makeApplyGraph ::
   Int
@@ -335,7 +335,7 @@ nestedPatternNodeToIcon str children = NestedPApp
 findArg :: Port -> (SgNamedNode, Edge) -> Bool
 findArg currentPort
   (SgNamedNode argName _
-  , Edge _ _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
+  , Edge _ (NameAndPort fromName fromPort, NameAndPort toName toPort))
   | argName == fromName = maybeBoolToBool $ fmap (== currentPort) toPort
   | argName == toName = maybeBoolToBool $ fmap (== currentPort) fromPort
   | otherwise = False -- This case should never happen
@@ -357,7 +357,7 @@ syntaxGraphToFglGraph (SyntaxGraph nodes edges _ _ eMap) =
   ING.mkGraph (fmap makeLNode nodes) labeledEdges where
     labeledEdges = fmap makeLabeledEdge edges
 
-    makeLabeledEdge e@(Edge _ _ (NameAndPort name1 _, NameAndPort name2 _)) =
+    makeLabeledEdge e@(Edge _ (NameAndPort name1 _, NameAndPort name2 _)) =
       (nodeNameToInt $ lookupInEmbeddingMap name1 eMap
       , nodeNameToInt $ lookupInEmbeddingMap name2 eMap
       , e)

app/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts, ConstraintKinds #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module Types (
   NamedIcon(..),
@@ -10,7 +11,6 @@ module Types (
   Connection,
   Edge(..),
   EdgeOption(..),
-  EdgeEnd(..),
   Drawing(..),
   IDState(..),
   SpecialQDiagram,
@@ -20,7 +20,10 @@ module Types (
   IngSyntaxGraph,
   LikeApplyFlavor(..),
   CaseOrMultiIfTag(..),
-  Labeled(..)
+  Labeled(..),
+  EmbedDirection(..),
+  EmbedInfo(..),
+  AnnotatedGraph,
 ) where
 
 import Diagrams.Prelude(QDiagram, V2, Any, Renderable, Path, IsName)
@@ -84,6 +87,7 @@ data SyntaxNode =
  -- Function application, composition, and applying to a composition
   LikeApplyNode LikeApplyFlavor Int
   -- NestedApplyNode is only created in GraphAlgorithms, not during translation.
+  -- The list of nodes is unordered (replace with a map?)
   | NestedApplyNode LikeApplyFlavor Int [(SgNamedNode, Edge)]
   | NestedPatternApplyNode String [Labeled (Maybe SgNamedNode)]
   | NameNode String -- Identifiers or symbols
@@ -106,15 +110,13 @@ data NameAndPort = NameAndPort NodeName (Maybe Port) deriving (Show, Eq, Ord)
 
 type Connection = (NameAndPort, NameAndPort)
 
--- TODO Consider removing EdgeOption and EdgeEnd since they are unused.
+-- TODO Consider removing EdgeOption since it's unused.
 data EdgeOption = EdgeInPattern deriving (Show, Eq, Ord)
 
-data EdgeEnd = EndNone deriving (Show, Eq, Ord)
-
 -- | An Edge has an name of the source icon, and its optional port number,
 -- and the name of the destination icon, and its optional port number.
 data Edge = Edge { edgeOptions :: [EdgeOption]
-                 , edgeEnds :: (EdgeEnd, EdgeEnd), edgeConnection :: Connection}
+                 , edgeConnection :: Connection}
   deriving (Show, Eq, Ord)
 
 -- | A drawing is a map from names to Icons, a list of edges,
@@ -135,3 +137,14 @@ type SpecialBackend b n
 type SpecialQDiagram b n = QDiagram b V2 n Any
 
 type IngSyntaxGraph gr = gr SgNamedNode Edge
+
+data EmbedDirection =
+  EdEmbedFrom -- The tail
+  | EdEmbedTo -- The head
+  deriving (Show, Eq)
+
+-- A Nothing eiEmbedDir means the edge is not embedded.
+data EmbedInfo a = EmbedInfo {eiEmbedDir :: Maybe EmbedDirection, eiVal :: a}
+  deriving (Show, Eq, Functor)
+
+type AnnotatedGraph gr = gr SgNamedNode (EmbedInfo Edge)

app/Util.hs

@@ -4,7 +4,6 @@ module Util (
   printSelf,
   iconToPort,
   makeSimpleEdge,
-  noEnds,
   nameAndPort,
   justName,
   fromMaybeError,
@@ -26,14 +25,11 @@ import Data.Text(pack)
 import Data.Typeable(Typeable)
 import qualified Debug.Trace
 
-import Types(EdgeEnd(..), Edge(..), NameAndPort(..), Connection, NodeName(..)
+import Types(Edge(..), NameAndPort(..), Connection, NodeName(..)
             , Port, SyntaxNode, SgNamedNode(..), NamedIcon(..), Icon(..))
 
-noEnds :: (EdgeEnd, EdgeEnd)
-noEnds = (EndNone, EndNone)
-
 makeSimpleEdge :: Connection -> Edge
-makeSimpleEdge = Edge [] noEnds
+makeSimpleEdge = Edge []
 
 nameAndPort :: NodeName -> Port -> NameAndPort
 nameAndPort n p = NameAndPort n (Just p)

test/AllTests.hs

@@ -14,6 +14,7 @@ import VisualGraphAlgorithmTests(visualCollapseTests)
 import VisualRenderingTests(renderTests)
 import VisualTranslateTests(visualTranslateTests)
 
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
 
 drawingsAndNames :: [(String, IO (Diagram B))]
 drawingsAndNames = [

test/UnitTests.hs

@@ -4,16 +4,12 @@ module UnitTests(
 
 import Test.HUnit
 
-import qualified Data.Graph.Inductive.Graph as ING
-import qualified Data.Graph.Inductive.PatriciaTree as FGR
-
 import Data.List(foldl', sort, sortOn)
 
 import Translate(translateStringToSyntaxGraph)
-import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..), SgBind(..))
+import TranslateCore(SyntaxGraph(..), SgBind(..))
 import Types(Labeled(..), SgNamedNode(..), Edge(..), SyntaxNode(..),
-             IngSyntaxGraph, NodeName(..), LikeApplyFlavor(..), NameAndPort(..))
+             NodeName(..), NameAndPort(..))
-import qualified GraphAlgorithms
 import Util(fromMaybeError)
 
 -- Unit Test Helpers --
@@ -75,8 +71,8 @@ renameNamePort nameMap nameAndPort@(NameAndPort name port) = NameAndPort newName
   errorStr = "renameNamePort: name not found. name = " ++ show name ++ "\nNameAndPort = " ++ show nameAndPort ++ "\nNameMap = " ++ show nameMap
 
 renameEdge :: NameMap -> Edge -> Edge
-renameEdge nameMap (Edge options ends (np1, np2)) =
+renameEdge nameMap (Edge options (np1, np2)) =
-  Edge options ends (renameNamePort nameMap np1, renameNamePort nameMap np2)
+  Edge options (renameNamePort nameMap np1, renameNamePort nameMap np2)
 
 renameSource :: NameMap -> SgBind -> SgBind
 renameSource nameMap (SgBind str ref) = SgBind str newRef where
@@ -107,55 +103,6 @@ renameGraph (SyntaxGraph nodes edges sinks sources embedMap) =
 -- END renameGraph
 
 -- END Unit Test Helpers --
-
-
--- 0:(toName "app02",ApplyNode 1)->[]
--- 1:(toName "f0",LiteralNode "f")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "f0") Nothing,NameAndPort (toName "app02") (Just 0))},0)]
--- 2:(toName "x1",LiteralNode "x")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "x1") Nothing,NameAndPort (toName "app02") (Just 2))},0)]
--- 3:(toName "y3",NameNode "y")->[(Edge {edgeOptions = [], edgeEnds = (EndNone,EndNone), edgeConnection = (NameAndPort (toName "y3") Nothing,NameAndPort (toName "app02") (Just 1))},0)]
-singleApplyGraph :: FGR.Gr SgNamedNode Edge
-singleApplyGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph "y = f x"
-
-makeTreeRootTest :: (String, [Maybe SgNamedNode], String) -> Test
-makeTreeRootTest (testName, expected, haskellString) = TestCase $ assertEqual testName expected actual where
-  actual = fmap (ING.lab graph) treeRoots
-  graph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph haskellString
-  treeRoots = GraphAlgorithms.findTreeRoots graph
-
-treeRootTests :: Test
-treeRootTests = TestList $ fmap makeTreeRootTest treeRootTestList where
-  treeRootTestList = [
-    ("single apply", [Just $ SgNamedNode (NodeName 2) (LikeApplyNode ApplyNodeFlavor 1)], "y = f x"),
-    -- TODO Fix test below
-    ("double apply", [Just $ SgNamedNode (NodeName 3) (LikeApplyNode ComposeNodeFlavor 2)], "y = f (g x)"),
-    ("recursive apply", [Just $ SgNamedNode (NodeName 3) (LikeApplyNode ComposeNodeFlavor 2)], "y = f (g y)")
-    ]
-
-makeChildCanBeEmbeddedTest ::
-  ING.Graph gr =>
-  (String, IngSyntaxGraph gr, ING.Node, Bool) -> Test
-makeChildCanBeEmbeddedTest (testName, graph, node, expected) =TestCase $ assertEqual testName expected canBeEmbedded where
-  canBeEmbedded = GraphAlgorithms.nodeWillBeEmbedded graph node
-
--- TODO Add more cases for childCanBeEmbeddedTests
--- TODO Fix these tests
-childCanBeEmbeddedTests :: Test
-childCanBeEmbeddedTests
-  = TestList $ fmap makeChildCanBeEmbeddedTest childCanBeEmbeddedList
-  where
-    childCanBeEmbeddedList = [
-      -- ("single apply, ap", singleApplyGraph, 0, False),
-      ("single apply, f", singleApplyGraph, 1, True),
-      -- ("single apply, x", singleApplyGraph, 2, True),
-      ("single apply, y", singleApplyGraph, 3, False)
-      ]
-
-collapseUnitTests :: Test
-collapseUnitTests = TestList[
-  TestLabel "findTreeRoots" treeRootTests
-  , TestLabel "childCanBeEmbedded" childCanBeEmbeddedTests
-  ]
-
 -- Translate unit tests
 
 applyTests :: Test
@@ -402,6 +349,5 @@ translateUnitTests = TestList [
 
 allUnitTests :: Test
 allUnitTests = TestList[
-  TestLabel "collapseUnitTests" collapseUnitTests,
   TestLabel "translateTests" translateUnitTests
   ]

test/VisualGraphAlgorithmTests.hs

@@ -12,22 +12,30 @@ import qualified Data.GraphViz.Attributes.Complete as GVA
 
 import qualified Data.Graph.Inductive.PatriciaTree as FGR
 
-import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), NameAndPort(..), SgNamedNode(..), Edge(..))
+import Types(SpecialQDiagram, SpecialBackend, SyntaxNode(..), NameAndPort(..)
+            , SgNamedNode(..), Edge(..))
 import Translate(translateStringToSyntaxGraph)
 import TranslateCore(syntaxGraphToFglGraph)
-import GraphAlgorithms(collapseNodes)
+import GraphAlgorithms(annotateGraph, collapseAnnotatedGraph)
 import Rendering(customLayoutParams)
 import Icons(coloredTextBox)
 
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
+
 prettyPrintSyntaxNode :: SyntaxNode -> String
-prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges) = concatMap printNameAndEdge namedNodesAndEdges
+prettyPrintSyntaxNode (NestedApplyNode _ _ namedNodesAndEdges)
+  = concatMap printNameAndEdge namedNodesAndEdges
   where
-    printNameAndEdge (namedNode, edge) = "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
+    printNameAndEdge (namedNode, edge)
-    prettyPrintNamedNode (SgNamedNode name _) = show name --  "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
+      = "(" ++ prettyPrintNamedNode namedNode ++ "," ++ printEdge edge ++ ")"
-    printEdge (Edge _ _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
+    prettyPrintNamedNode (SgNamedNode name _)
+      = show name --  "(" ++ show name ++ "," ++ prettyPrintSyntaxNode syntaxNode ++ ")"
+    printEdge (Edge _ (NameAndPort n1 _, NameAndPort n2 _)) = show (n1, n2)
 prettyPrintSyntaxNode x = show x
 
-renderFglGraph :: SpecialBackend b Double => FGR.Gr SgNamedNode Edge -> IO (SpecialQDiagram b Double)
+renderFglGraph :: SpecialBackend b Double
+               => FGR.Gr SgNamedNode e
+               -> IO (SpecialQDiagram b Double)
 renderFglGraph fglGraph = do
   layedOutGraph <- DiaGV.layoutGraph' layoutParams GVA.Neato fglGraph
   pure $ DiaGV.drawGraph
@@ -36,12 +44,20 @@ renderFglGraph fglGraph = do
     -- TODO Draw some type of arrow if point1 == point2
     (\_ point1 _ point2 _ _ ->  if point1 == point2
       then mempty
-      else lcA (withOpacity white 0.5) $ arrowBetween (scaleFactor *^ point1) (scaleFactor *^ point2))
+      else lcA (withOpacity white 0.7)
+           $ arrowBetween'
+           (shaftStyle %~ lwG 0.5 $ headLength .~ global 1.5 $ with)
+           (scaleFactor *^ point1)
+           (scaleFactor *^ point2))
     layedOutGraph
   where
-    scaleFactor = 0.12
+    scaleFactor = 0.3
-    nodeFunc (SgNamedNode name syntaxNode) point =
+    nodeFunc (SgNamedNode name syntaxNode) point
-      place (coloredTextBox white (opaque white) (show name ++ prettyPrintSyntaxNode syntaxNode) {- :: Diagram B -})
+      = place (coloredTextBox
+                white
+                (opaque white)
+                (show name ++ prettyPrintSyntaxNode syntaxNode)
+                {- :: Diagram B -})
       (scaleFactor *^ point)
     layoutParams :: GV.GraphvizParams Int v e () v
     layoutParams = customLayoutParams{
@@ -82,7 +98,7 @@ makeCollapseTest str = do
     afterCollapse]
   where
     fglGraph = syntaxGraphToFglGraph $ translateStringToSyntaxGraph str
-    collapsedGraph = collapseNodes fglGraph
+    collapsedGraph = collapseAnnotatedGraph $ annotateGraph fglGraph
     customTextBox = coloredTextBox white (opaque lime)
     expressionText = alignL $ coloredTextBox white (opaque yellow) str -- :: Diagram B
     beforeText = alignL $ customTextBox "Before:" -- :: Diagram B

test/VisualRenderingTests.hs

@@ -116,7 +116,7 @@ lambdaDia = Drawing icons []
 --renderTests :: IO (Diagram B)
 renderTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
 renderTests = do
-  renderedDiagrams <- traverse renderDrawing allDrawings
+  renderedDiagrams <- traverse (renderDrawing "") allDrawings
   let vCattedDrawings = Dia.vsep 0.5 renderedDiagrams
   pure vCattedDrawings
   where

test/VisualTranslateTests.hs

@@ -16,6 +16,7 @@ import TranslateCore(syntaxGraphToFglGraph, SyntaxGraph(..))
 import Rendering(renderIngSyntaxGraph)
 import Icons(textBox, TransformParams(..))
 
+{-# ANN module "HLint: ignore Unnecessary hiding" #-}
 
 prettyShowList :: Show a => [a] -> String
 prettyShowList ls = intercalate "\n" $ fmap show ls
@@ -45,6 +46,8 @@ composeTests = [
 -- | nestedTests / collapseTest
 nestedTests :: [String]
 nestedTests = [
+  "y = (\\x -> x) 0",
+  "y = f (\\x -> x)",
   "y = f x",
   "y = let x = 1 in f (g x)",
   "y = f []",
@@ -333,10 +336,10 @@ translateStringToDrawing s = do
       print collapsedGraph
       putStr "\n\n"
   if False then printAction else pure ()  -- Supress unused printAction warning
-  renderIngSyntaxGraph collapsedGraph
+  renderIngSyntaxGraph s collapsedGraph
-  -- renderIngSyntaxGraph fglGraph
 
-visualTranslateTests :: SpecialBackend b Double => IO (SpecialQDiagram b Double)
+visualTranslateTests :: SpecialBackend b Double
+                     => IO (SpecialQDiagram b Double)
 visualTranslateTests = do
   drawings <- traverse translateStringToDrawing testDecls
   let

todo.md

@@ -1,6 +1,10 @@
 # Todo
 
 ## Todo Now
+* Remove port number magic numbers in GraphAlgorithms.hs.
+* Consider removing LikeApplyNode and CaseNode, or their embedded versions.
+* Fix embedded lambdas missing their enclosures.
+* 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..
 
 ## Todo Later