tree-features: ae4a85503b765f0d5fedfa280e76942d07d971a7
1: module SexprTests (tests, sanitise, exampleAsts) where
2:
3: import Test.Tasty (testGroup)
4: import Test.Tasty.QuickCheck (testProperty)
5: import Test.QuickCheck
6: import Text.Parsec
7: import SexprHelper
8: import Features
9: import FeatureTest (sizedTreeOf)
10: import System.IO.Unsafe
11: import System.Directory
12:
13: -- | Strip potentially unparsable characters from a string
14: sanitise :: String -> String
15: sanitise s = let keep c = c /= '"' && c /= '\\'
16: in filter keep (show s)
17:
18: quote x = concat ["\"", x, "\""]
19:
20: canParseLeaf s' = let s = sanitise s'
21: t = parseSexpr (quote s)
22: in t == Leaf s
23:
24: canParseFlatNode :: [String] -> Bool
25: canParseFlatNode ss' = let ss = map sanitise ss'
26: t = parseSexpr (concat ["(",
27: unwords (map quote ss),
28: ")"])
29: in t == Node (map Leaf ss)
30:
31: -- NOTE: Parsed trees might not equal the incoming trees!
32: canParseRenderedTrees :: Int -> Property
33: canParseRenderedTrees n = forAll (sizedTreeOf n :: Gen (TreeOf String))
34: parses
35: where parses t' = let t = fmap sanitise t'
36: in forceTree (parseSexpr (treeToSexpr t))
37:
38: parsedTreesEqualRendered :: Int -> Property
39: parsedTreesEqualRendered n = forAll (sizedTreeOf n :: Gen (TreeOf String))
40: parses
41: where parses t' = let t = fmap sanitise t'
42: t2 = parseSexpr (treeToSexpr t)
43: in t2 == t
44:
45: {-# NOINLINE exampleAsts #-}
46: exampleAsts = unsafePerformIO $ do files <- getDirectoryContents dir
47: let asts = filter isAst files
48: mapM (readFile . (dir ++)) asts
49: where dir = "test/data/good/"
50: isAst f = reverse (take 4 (reverse f)) == ".ast"
51:
52: forceTree :: TreeOf a -> Bool
53: forceTree (Leaf _) = True
54: forceTree (Node xs) = all forceTree xs
55:
56: canParseHS2ASTOutput :: Bool
57: canParseHS2ASTOutput = all parser exampleAsts
58: where parser ast = forceTree (parseSexpr ast)
59:
60: tests = testGroup "S-expression tests"
61: [
62: testProperty "canParseLeaf" canParseLeaf
63: , testProperty "canParseFlatNode" canParseFlatNode
64: , testProperty "canParseRenderedTrees" canParseRenderedTrees
65: , testProperty "canParseHS2ASTOutput" canParseHS2ASTOutput
66: , testProperty "parsedTreesEqualRendered" parsedTreesEqualRendered
67: ]
Generated by git2html.