Undo embed literal lambda bodies since collapseAnnotatedGraph is buggy.

app/GraphAlgorithms.hs

@@ -10,6 +10,7 @@ import qualified Control.Arrow as Arrow
 import qualified Data.Graph.Inductive as ING
 import Data.List(foldl', find)
 import Data.Tuple(swap)
+import GHC.Stack(HasCallStack)
 
 import Constants(pattern ResultPortConst, pattern InputPortConst)
 import Types(SyntaxNode(..), IngSyntaxGraph, Edge(..),
@@ -53,7 +54,7 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
         -> isInput mParentPort && isResult mChildPort
 
       -- (LambdaParent, ApplyNode _ _ _) -> parentPortIsInput
-      (LambdaParent, LiteralNode _) -> parentPortIsInput
+      -- (LambdaParent, LiteralNode _) -> parentPortIsInput
       -- (LambdaParent, FunctionDefNode _ _)
       --   -> parentPortIsInput
 
@@ -78,7 +79,7 @@ syntaxNodeIsEmbeddable parentType syntaxNode mParentPort mChildPort
       Just ResultPortConst -> True
       Just _ -> False
 
-    parentPortIsInput = isInput mParentPort
+    -- parentPortIsInput = isInput mParentPort
 
     parentPortNotInput = not $ isInput mParentPort
     parentPortNotResult = not $ isResult mParentPort
@@ -208,7 +209,7 @@ changeEdgeToParent parentNode childNode (fromNode, toNode, lab)
   where
     toParent node = if node == childNode then parentNode else node
 
-collapseEdge :: ING.DynGraph gr
+collapseEdge :: (HasCallStack, ING.DynGraph gr)
              => AnnotatedGraph gr
              -> ING.LEdge (EmbedInfo Edge)
              -> AnnotatedGraph gr
@@ -230,7 +231,7 @@ collapseEdge oldGraph (fromNode, toNode, e@(EmbedInfo mEmbedDir _))
           childDeletedGraph = ING.delNode childNode graphWithEdgesTransferred
 
 
-collapseAnnotatedGraph :: ING.DynGraph gr
+collapseAnnotatedGraph :: (HasCallStack, ING.DynGraph gr)
                        => AnnotatedGraph gr
                        -> AnnotatedGraph gr
 collapseAnnotatedGraph origGraph = newGraph

app/Rendering.hs

@@ -29,6 +29,7 @@ import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.List(find, minimumBy)
 import Data.Maybe(catMaybes, isNothing, fromMaybe)
 import Data.Typeable(Typeable)
+import GHC.Stack(HasCallStack)
 
 --import qualified Data.GraphViz.Types
 --import Data.GraphViz.Commands
@@ -215,7 +216,7 @@ lookupNodeAngle rotationMap key
     ++ "\n\n rotationMap = " ++ show rotationMap)
   $ lookup key rotationMap
 
-makeEdge :: (SpecialBackend b n, ING.Graph gr) =>
+makeEdge :: (HasCallStack, SpecialBackend b n, ING.Graph gr) =>
   String  -- ^ Debugging information
   -> gr NamedIcon (EmbedInfo Edge)
   -> SpecialQDiagram b n
@@ -268,7 +269,7 @@ makeEdge debugInfo graph dia rotationMap
     portAngles = (icon0PortAngle, icon1PortAngle)
 
 -- | addEdges draws the edges underneath the nodes.
-addEdges :: (SpecialBackend b n, ING.Graph gr) =>
+addEdges :: (HasCallStack, SpecialBackend b n, ING.Graph gr) =>
   String  -- ^ Debugging information
   -> gr NamedIcon (EmbedInfo Edge)
   -> SpecialQDiagram b n
@@ -296,7 +297,7 @@ scoreAngle iconPosition edges reflected angle
         shaftAngle = signedAngleBetween shaftVector unitX
         angleDiff = smallestAngleDiff (reflected, angle) shaftAngle portAngles
 
-bestAngleForIcon :: (SpecialNum n, ING.Graph gr) =>
+bestAngleForIcon :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
   -> gr NamedIcon (EmbedInfo Edge)
   -> NamedIcon
@@ -331,7 +332,7 @@ bestAngleForIcon positionMap graph key@(NamedIcon (NodeName nodeId) _) reflected
     getPreEdge (otherNode, EmbedInfo _ edge) = (otherNode, nameAndPort) where
       (_, nameAndPort) = edgeConnection edge
 
-findIconRotation :: (SpecialNum n, ING.Graph gr) =>
+findIconRotation :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
   -> gr NamedIcon (EmbedInfo Edge)
   -> NamedIcon
@@ -344,7 +345,7 @@ findIconRotation positionMap graph key = (key, (reflected, angle)) where
   reflected = reflectedScore < nonReflectedScore
   angle = if reflected then reflectedAngle else nonReflectedAngle
 
-rotateNodes :: (SpecialNum n, ING.Graph gr) =>
+rotateNodes :: (HasCallStack, SpecialNum n, ING.Graph gr) =>
   Map.Map NamedIcon (Point V2 n)
   -> gr NamedIcon (EmbedInfo Edge)
   -> [(NamedIcon, (Bool, Angle n))]
@@ -474,8 +475,7 @@ renderDrawing :: SpecialBackend b Double
   -> IO (SpecialQDiagram b Double)
 renderDrawing debugInfo = renderIconGraph debugInfo . drawingToIconGraph
 
-renderIngSyntaxGraph ::
-  SpecialBackend b Double =>
-  String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
+renderIngSyntaxGraph :: (HasCallStack, SpecialBackend b Double)
+  => String -> AnnotatedGraph Gr -> IO (SpecialQDiagram b Double)
 renderIngSyntaxGraph debugInfo gr
   = renderIconGraph debugInfo $ ING.nmap (mapNodeInNamedNode nodeToIcon) gr

test/AllTests.hs

@@ -4,6 +4,7 @@ import Prelude hiding (return)
 import Diagrams.Backend.SVG.CmdLine(B)
 import Diagrams.Prelude hiding ((#), (&))
 
+import GHC.Stack(HasCallStack)
 import Test.HUnit
 
 import Icons(colorScheme, ColorStyle(..))
@@ -23,14 +24,14 @@ drawingsAndNames = [
   ("collapse-tests", visualCollapseTests)
   ]
 
-renderDrawings :: [(String, IO (Diagram B))] -> IO ()
+renderDrawings :: HasCallStack => [(String, IO (Diagram B))] -> IO ()
 renderDrawings = mapM_ saveDrawing where
   saveDrawing (name, drawingMaker) = do
     dia <- drawingMaker
     -- TODO Replace string concatenation with proper path manipulation functions.
     customRenderSVG ("test/test-output/" ++ name ++ ".svg") (mkWidth 700) (bgFrame 1 (backgroundC colorScheme) dia)
 
-main :: IO ()
+main :: HasCallStack => IO ()
 --main = print "Hello world"
 main = do
   --  ING.prettyPrint singleApplyGraph

test/VisualTranslateTests.hs

@@ -8,6 +8,7 @@ import Diagrams.Prelude hiding ((#), (&))
 
 import qualified Data.Graph.Inductive.Graph as ING
 import Data.List(intercalate)
+import GHC.Stack(HasCallStack)
 
 import Types(SpecialQDiagram, SpecialBackend, NodeName(..))
 import Translate(translateStringToCollapsedGraphAndDecl
@@ -188,6 +189,11 @@ patternTests = [
 
 lambdaTests :: [String]
 lambdaTests = [
+  "y = (\\x -> if True then 0 else 1) 3",
+  "y = (\\x -> 99) x",
+  "y = (\\x -> (\\x -> 2) x)",
+  "y = (\\x -> (\\x -> f 2) x)",
+  "y = (\\x -> (\\x -> x) x)",
   "y = (\\x -> (\\x -> (\\x -> x) x) x)",
   "y = (\\x -> (\\x -> (\\x -> x)))",
   "y = (\\y -> y)",
@@ -333,12 +339,12 @@ translateStringToDrawing s = do
       putStr "\nFGL Graph:\n"
       ING.prettyPrint fglGraph
       putStr "\nCollapsed Graph:\n"
-      print collapsedGraph
+      ING.prettyPrint collapsedGraph
       putStr "\n\n"
   if False then printAction else pure ()  -- Supress unused printAction warning
   renderIngSyntaxGraph s collapsedGraph
 
-visualTranslateTests :: SpecialBackend b Double
+visualTranslateTests :: (HasCallStack, SpecialBackend b Double)
                      => IO (SpecialQDiagram b Double)
 visualTranslateTests = do
   drawings <- traverse translateStringToDrawing testDecls