diff --git a/test/UnitTests.hs b/test/UnitTests.hs index 29b85b4..9d10a62 100644 --- a/test/UnitTests.hs +++ b/test/UnitTests.hs @@ -27,48 +27,71 @@ assertEqualSyntaxGraphs :: [String] -> Test assertEqualSyntaxGraphs ls = assertAllEqual $ fmap (renameGraph . stringToSyntaxGraph) ls -- BEGIN renameGraph -- +type NameMap = [(NodeName, NodeName)] --- TODO Implement renameSyntaxNode -renameSyntaxNode :: [(NodeName, NodeName)] -> SyntaxNode -> Int -> (SyntaxNode, Int) -renameSyntaxNode nameMap node counter = (node, counter) +renameNode + :: NameMap -> Int -> SgNamedNode -> (SgNamedNode, NameMap, Int) +renameNode nameMap counter (nodeName, syntaxNode) = (newNamedNode, nameMap3, newCounter) where + newNodeName = NodeName counter + nameMap2 = (nodeName, newNodeName) : nameMap + (newSyntaxNode, nameMap3, newCounter) = renameSyntaxNode nameMap2 syntaxNode (counter + 1) + newNamedNode = (newNodeName, newSyntaxNode) -renameNode :: ([SgNamedNode], [(NodeName, NodeName)], Int) -> SgNamedNode -> ([SgNamedNode], [(NodeName, NodeName)], Int) -renameNode state@(renamedNodes, nameMap, counter) node@(nodeName, syntaxNode) = case lookup nodeName nameMap of +maybeRenameNodeFolder :: + ([Maybe SgNamedNode], NameMap, Int) -> Maybe SgNamedNode -> ([Maybe SgNamedNode], NameMap, Int) +maybeRenameNodeFolder (renamedNodes, nameMap, counter) mNode = case mNode of + Nothing -> (Nothing:renamedNodes, nameMap, counter) + Just node -> (Just newNamedNode:renamedNodes, newNameMap, newCounter) where + (newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node + +renameSyntaxNode :: NameMap -> SyntaxNode -> Int -> (SyntaxNode, NameMap, Int) +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 + _ -> (node, nameMap, counter) + +renameNodeFolder :: ([SgNamedNode], NameMap, Int) -> SgNamedNode -> ([SgNamedNode], NameMap, Int) +renameNodeFolder state@(renamedNodes, nameMap, counter) node@(nodeName, _) = case lookup nodeName nameMap of Nothing -> (newNamedNode:renamedNodes, newNameMap, newCounter) where - newNodeName = NodeName counter - newNameMap = (nodeName, newNodeName) : nameMap - (newSyntaxNode, newCounter) = renameSyntaxNode newNameMap syntaxNode (counter + 1) - newNamedNode = (newNodeName, newSyntaxNode) + (newNamedNode, newNameMap, newCounter) = renameNode nameMap counter node Just _ -> error $ "renameNode: node already in name map. State = " ++ show state ++ " Node = " ++ show node -renameNamePort :: [(NodeName, NodeName)] -> NameAndPort -> NameAndPort +renameNamePort :: NameMap -> NameAndPort -> NameAndPort renameNamePort nameMap nameAndPort@(NameAndPort name port) = NameAndPort newName port where newName = fromMaybeError errorStr $ lookup name nameMap errorStr = "renameNamePort: name not found. name = " ++ show name ++ "\nNameAndPort = " ++ show nameAndPort ++ "\nNameMap = " ++ show nameMap -renameEdge :: [(NodeName, NodeName)] -> Edge -> Edge +renameEdge :: NameMap -> Edge -> Edge renameEdge nameMap (Edge options ends (np1, np2)) = Edge options ends (renameNamePort nameMap np1, renameNamePort nameMap np2) -renameSource :: [(NodeName, NodeName)] -> (String, Reference) -> (String, Reference) +renameSource :: NameMap -> (String, Reference) -> (String, Reference) renameSource nameMap (str, ref) = (str, newRef) where newRef = case ref of Left _ -> ref Right namePort@(NameAndPort _ _) -> Right $ renameNamePort nameMap namePort +renameEmbed :: NameMap -> (NodeName, NodeName) -> (NodeName, NodeName) +renameEmbed nameMap (leftName, rightName) = (newLeftName, newRightName) where + newLeftName = fromMaybeError "renameEmbed: leftName not found" (lookup leftName nameMap) + newRightName = fromMaybeError "renameEmbed: RightName not found" (lookup rightName nameMap) + -- TODO May want to remove names for sub-nodes removeNames :: SgNamedNode -> SyntaxNode removeNames (_, syntaxNode) = syntaxNode --- TODO Rename sinks and embedMap +-- TODO Rename sinks -- TODO Add unit tests for renameGraph renameGraph :: SyntaxGraph -> SyntaxGraph renameGraph (SyntaxGraph nodes edges sinks sources embedMap) = - SyntaxGraph renamedNodes renamedEdges sinks renamedSources embedMap + SyntaxGraph renamedNodes renamedEdges sinks renamedSources renamedEmbedMap where - (renamedNodes, nameMap, _) = foldl' renameNode ([], [], 0) $ sortOn removeNames nodes + (renamedNodes, nameMap, _) = foldl' renameNodeFolder ([], [], 0) $ sortOn removeNames nodes renamedEdges = sort $ fmap (renameEdge nameMap) edges renamedSources = sort $ fmap (renameSource nameMap) sources + renamedEmbedMap = sort $ fmap (renameEmbed nameMap) embedMap -- END renameGraph @@ -290,7 +313,7 @@ enumTests = TestList [ ] patternTests :: Test -patternTests = TestList[ +patternTests = TestList [ -- TODO Remove branch icon assertEqualSyntaxGraphs [ "y (F x) = x", @@ -303,6 +326,35 @@ patternTests = TestList[ ] ] +lambdaTests :: Test +lambdaTests = TestList [ + assertEqualSyntaxGraphs [ + "y x = (\\z -> x)", + "y = (\\x -> (\\z -> x))" + ] + , + assertEqualSyntaxGraphs [ + "y x = case x of {0 -> 1; 3 -> 5}", + "{y 0 = 1; y 3 = 5}" + ] + , + assertEqualSyntaxGraphs [ + "y p = case p of {F x -> x; G x -> x}", + "{y (F x) = x; y (G x) = x}" + ] + , + assertEqualSyntaxGraphs [ + -- TODO Since there are no patterns for z, this should just be "case p of" + "y p z = case (p, z) of {((F x), z') -> x z'; ((G x), z') -> z' x}", + "{y (F x) z = x z; y (G x) z = z x}" + ] + , + assertEqualSyntaxGraphs [ + "y x = f x y", + "y x = z where z = f x y" + ] + ] + -- Yes, the commas get their own line translateUnitTests :: Test translateUnitTests = TestList [ @@ -320,6 +372,7 @@ translateUnitTests = TestList [ , TestLabel "negateTests" negateTests , TestLabel "enumTests" enumTests , TestLabel "patternTests" patternTests + , TestLabel "lambdaTests" lambdaTests ] allUnitTests :: Test diff --git a/test/VisualTranslateTests.hs b/test/VisualTranslateTests.hs index 1585a06..4ad5636 100644 --- a/test/VisualTranslateTests.hs +++ b/test/VisualTranslateTests.hs @@ -161,7 +161,6 @@ lambdaTests = [ "y = (\\y -> y)", "y = (\\x1 -> (\\x2 -> (\\x3 -> x1 x2 x3)))", "y x = (\\z -> x)", - "y = (\\x -> (\\z -> x))", "y x = x", "y x = y x", "y x = g y y", @@ -170,13 +169,9 @@ lambdaTests = [ "y x1 x2 = f x1 x3 x2", "y x1 x2 = f x1 x2", "y x = f x1 x2", - "{y 0 = 1; y 1= 0}", "y (-1) = 2", "y 1 = 0", - "{y (F x) = x; y (G x) = x}", - "{y (F x) z = x z; y (G x) z = z x}", - "y x = z 3 where z = f x y", - "y x = z where z = f x y" + "y x = z 3 where z = f x y" ] letTests :: [String] @@ -204,7 +199,6 @@ otherTests :: [String] otherTests = [ "y = f 1 'c' 2.3 \"foobar\"", "fact x = if (x == 0) then 1 else (x * fact (x - 1))", - "fact x = if ((==) 0 x) then 1 else (x * fact ((-) x 1))", "fibs = cons 0 (cons 1 (zipWith (+) fibs (tail fibs)))", "y x = if x then (if z then q else x) else w", "y x1 x2 x3 = if f x1 then g x2 else h x3", @@ -215,7 +209,6 @@ otherTests = [ "y x = y x", "y = f 3 y", "y = f x", - "y = f (g x)", "y = f (g x1 x2) x3", "y = (f x1 x2) (g x1 x2)", "y = Foo.bar"