From c1e1682b1d7d3d1ff184e06d205b3e1599a34234 Mon Sep 17 00:00:00 2001 From: Robbie Gleichman Date: Sun, 16 Jun 2019 13:02:42 -0700 Subject: [PATCH] Undo embed literal lambda bodies since collapseAnnotatedGraph is buggy. --- app/GraphAlgorithms.hs | 9 +++++---- app/Rendering.hs | 16 ++++++++-------- test/AllTests.hs | 5 +++-- test/VisualTranslateTests.hs | 10 ++++++++-- 4 files changed, 24 insertions(+), 16 deletions(-) diff --git a/app/GraphAlgorithms.hs b/app/GraphAlgorithms.hs index 9260f6c..2c3a18c 100644 --- a/app/GraphAlgorithms.hs +++ b/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 diff --git a/app/Rendering.hs b/app/Rendering.hs index de4fbc9..ba7f798 100644 --- a/app/Rendering.hs +++ b/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 diff --git a/test/AllTests.hs b/test/AllTests.hs index d56200b..6684f28 100644 --- a/test/AllTests.hs +++ b/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 diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs index 012cb5d..777cb2e 100644 --- a/test/VisualTranslateTests.hs +++ b/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