mirror of
https://github.com/rgleichman/glance.git
synced 2024-10-26 16:51:29 +03:00
Turn some lambda tests into unit tests.
This commit is contained in:
parent
ec0bf8adf7
commit
00f6d4bd31
@ -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 :: ([SgNamedNode], [(NodeName, NodeName)], Int) -> SgNamedNode -> ([SgNamedNode], [(NodeName, NodeName)], Int)
|
||||
renameNode state@(renamedNodes, nameMap, counter) node@(nodeName, syntaxNode) = case lookup nodeName nameMap of
|
||||
Nothing -> (newNamedNode:renamedNodes, newNameMap, newCounter) where
|
||||
renameNode
|
||||
:: NameMap -> Int -> SgNamedNode -> (SgNamedNode, NameMap, Int)
|
||||
renameNode nameMap counter (nodeName, syntaxNode) = (newNamedNode, nameMap3, newCounter) where
|
||||
newNodeName = NodeName counter
|
||||
newNameMap = (nodeName, newNodeName) : nameMap
|
||||
(newSyntaxNode, newCounter) = renameSyntaxNode newNameMap syntaxNode (counter + 1)
|
||||
nameMap2 = (nodeName, newNodeName) : nameMap
|
||||
(newSyntaxNode, nameMap3, newCounter) = renameSyntaxNode nameMap2 syntaxNode (counter + 1)
|
||||
newNamedNode = (newNodeName, newSyntaxNode)
|
||||
|
||||
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
|
||||
(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
|
||||
|
@ -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"
|
||||
|
Loading…
Reference in New Issue
Block a user