katydid 0.1.0.0 → 0.1.1.0
raw patch · 5 files changed
+344/−1 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- README.md +2/−0
- katydid.cabal +4/−1
- test/ParserSpec.hs +150/−0
- test/RelapseSpec.hs +43/−0
- test/Suite.hs +145/−0
README.md view
@@ -17,6 +17,8 @@ All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes]. +[Hackage](https://hackage.haskell.org/package/katydid-0.1.0.0).+ ## Example Validating a single structure can be done using the validate function:
katydid.cabal view
@@ -1,5 +1,5 @@ name: katydid-version: 0.1.0.0+version: 0.1.1.0 synopsis: A haskell implementation of Katydid description: A haskell implementation of Katydid@@ -78,6 +78,9 @@ , mtl , tasty-hunit , tasty+ other-modules: ParserSpec+ , RelapseSpec+ , Suite ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010
+ test/ParserSpec.hs view
@@ -0,0 +1,150 @@+-- | +-- This module ParserSpec tests the Parser module.+module ParserSpec (+ tests+) where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HUnit++import Text.ParserCombinators.Parsec (CharParser, parse, eof)++import Parser+import Expr+import Patterns++success :: (Eq a, Show a) => String -> CharParser () a -> String -> a -> T.TestTree+success name p input want = HUnit.testCase name $ case parse (p <* eof) "" input of+ (Left err) -> HUnit.assertFailure $ "given input: " ++ input ++ " got error: " ++ show err+ (Right got) -> HUnit.assertEqual ("want: " ++ show want ++ " got: " ++ show got) want got++failure :: (Show a) => String -> CharParser () a -> String -> T.TestTree+failure name p input = HUnit.testCase name $ case parse (p <* eof) "" input of+ (Left _) -> return ()+ (Right got) -> HUnit.assertFailure $ "want error from input: " ++ show input ++ ", but got: " ++ show got++tests = T.testGroup "Parser" [+ success "linecomment success" ws "//bla\n" (),+ failure "linecomment failure" ws "//bla",+ success "oneline blockcomment" ws "/*bla*/" (),+ success "twoline blockcomment" ws "/*bla\nbla*/" (),+ success "embedded blockcomment" ws "/*bla//bla*/" (),+ -- TODO success "nested blockcomment" ws "/*bla/*bla*/bla*/" (),+ failure "blockcomment failure" ws "/*bla*",++ success "zero" intLit "0" 0,+ success "single decimal" intLit "1" 1,+ success "multi decimal" intLit "1230" 1230,+ failure "not an octal or a decimal" intLit "09",+ success "single octal" intLit "01" 1,+ success "multi octal" intLit "017" 15,+ failure "not an octal or an hex" intLit "01f",+ success "single hex" intLit "0xf" 15,+ success "multi hex" intLit "0Xff" 255,+ success "signed hex" intLit "-0xff" (- 255),+ success "cast oct" intLit "int(0114)" 76,+ success "cast signed int" intLit "int(-114)" (- 114),+ failure "cast error not closing" intLit "int(-114",+ failure "cast error not opening" intLit "int-114)",++ success "uint" uintCastLit "uint(114)" 114,+ success "uint oct" uintCastLit "uint(025)" 21,+ failure "uint failure" uintCastLit "uint(-12)",++ success "double" doubleCastLit "double(2.1)" 2.1,+ success "double int" doubleCastLit "double(2)" 2,+ success "double exponent" doubleCastLit "double(2E+2)" 200,+ success "double exponent without sign" doubleCastLit "double(2E2)" 200,+ success "double exponent negative sign" doubleCastLit "double(2E-2)" 0.02,+ success "double exponent and dot" doubleCastLit "double(2.1E-2)" 0.021,+ failure "double failure" doubleCastLit "double(1/2)",+ + success "interpreted string" stringLit "\"abc\"" "abc",+ success "unicode small" stringLit "\"\\u002E\"" ".",+ success "unicode big" stringLit "\"\\U0000002E\"" ".",+ success "hex char" stringLit "\"\\x2E\"" ".",+ success "octal char" stringLit "\"\\056\"" ".",+ success "escaped" stringLit "\"\\t\"" "\t",+ success "mixed interpreted string" stringLit "\"\\u002Eabc\\x2E\"" ".abc.",+ success "raw string" stringLit "`abc`" "abc",+ success "raw string with quote" stringLit "`ab\"c`" "ab\"c",+ failure "raw string failure" stringLit "`a`b`",+ failure "escaped failure" stringLit "\\/",++ success "bytes char" bytesCastLit "[]byte{'a'}" "a",+ success "bytes string" bytesCastLit "[]byte{'a', 'b', 'c'}" "abc",+ success "bytes unicode char" bytesCastLit "[]byte{'\\u002E'}" ".",+ success "bytes hex char" bytesCastLit "[]byte{'\\x2E'}" ".",+ success "bytes octal char" bytesCastLit "[]byte{'\\056'}" ".",+ success "bytes number" bytesCastLit "[]byte{46}" ".",+ failure "bytes too high number" bytesCastLit "[]byte{1000000}",+ success "bytes number with spaces" bytesCastLit "[]byte{ 46 }" ".",+ success "bytes number with more spaces" bytesCastLit "[]byte{ 46 , 46 , 46}" "...",++ success "id" idLit "abc" "abc",+ success "id with number" idLit "abc123" "abc123",+ success "id with underscore" idLit "abc_123" "abc_123",+ failure "id starts with number" idLit "123abc",++ success "expr bool var" expr "$bool" BoolVariable,+ success "expr bool const" expr "true" (Const True),+ success "expr ==" expr "== true" (BoolEqualFunc BoolVariable (Const True)),+ success "expr not" expr "not(true)" (NotFunc (Const True)),+ success "expr eq bool" expr "eq($bool, true)" (BoolEqualFunc BoolVariable (Const True)),+ success "expr eq int" expr "eq($int, 1)" (IntEqualFunc IntVariable (Const 1)),+ failure "expr eq type mismatch" expr "eq($bool, 1)",+ success "expr list" expr "eq($int, length([]int{1,2}))" (IntEqualFunc IntVariable (IntListLengthFunc [Const 1, Const 2])),+ + success "name bool" nameExpr "true" (BoolEqualFunc BoolVariable (Const True)),+ success "name id" nameExpr "a" (StringEqualFunc StringVariable (Const "a")),+ success "name string" nameExpr "\"a\"" (StringEqualFunc StringVariable (Const "a")),+ success "name not" nameExpr "!(a)" (NotFunc (StringEqualFunc StringVariable (Const "a"))),+ success "name any" nameExpr "_" (Const True),+ success "name or" nameExpr "(a|b)" (OrFunc (StringEqualFunc StringVariable (Const "a")) (StringEqualFunc StringVariable (Const "b"))),+ failure "name grouping" nameExpr "((a))",++ success "empty" pattern "<empty>" Empty,+ success "zany" pattern "*" ZAny,+ success "or" pattern "(*|*)" (Or ZAny ZAny),+ success "or list" pattern "(*|*|*)" (Or ZAny (Or ZAny ZAny)),+ success "or list longer" pattern "(*|*|*|*|*)" (Or ZAny (Or (Or (Or ZAny ZAny) ZAny) ZAny)),+ success "and" pattern "(*&*)" (And ZAny ZAny),+ success "and list" pattern "(*&*&*)" (And ZAny (And ZAny ZAny)),+ failure "mix and or" pattern "(*|*&*)",+ failure "one item in paren" pattern "(*)",+ failure "empty paren" pattern "()",+ success "zero or more" pattern "(*)*" (ZeroOrMore ZAny),+ success "optional" pattern "(*)?" (Optional ZAny),+ success "not" pattern "!(*)" (Not ZAny),+ success "reference" pattern "@name" (Reference "name"),+ success "concat" pattern "[*,*]" (Concat ZAny ZAny),+ failure "single concat" pattern "[*]",+ failure "empty concat" pattern "[]",+ success "concat list" pattern "[*,*,*]" (Concat (Concat ZAny ZAny) ZAny),+ success "interleave" pattern "{*;*}" (Interleave ZAny ZAny),+ success "interleave list" pattern "{*;*;*}" (Interleave (Interleave ZAny ZAny) ZAny),+ failure "empty interleave" pattern "{}",+ failure "single interleave" pattern "{*}",+ success "contains" pattern ".*" (Contains ZAny),+ success "leaf builtin" pattern "== 1" (Node (IntEqualFunc IntVariable (Const 1)) Empty),+ success "leaf function" pattern "->eq($int, 1)" (Node (IntEqualFunc IntVariable (Const 1)) Empty),+ success "treenode" pattern "a:*" (Node (StringEqualFunc StringVariable (Const "a")) ZAny),+ success "any treenode" pattern "_:*" (Node (Const True) ZAny),+ success "treenode no colon" pattern "_[*,*]" (Node (Const True) (Concat ZAny ZAny)),++ success "single pattern grammar" grammar "*" $ newRef "main" ZAny,+ success "single pattern decl" grammar "#main = *" $ newRef "main" ZAny,+ failure "two patterns grammar" grammar "* *",+ success "two pattern decls" grammar "#main = * #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,+ success "one pattern and one pattern decl" grammar "* #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,+ success "one pattern and two pattern decls" grammar "* #a = * #b = *" $ newRef "main" ZAny `union` newRef "a" ZAny `union` newRef "b" ZAny,++ success "not pattern, not name and != conflicts without not enough lookahead" grammar "!(A):*" (newRef "main" (Node (NotFunc (StringEqualFunc StringVariable (Const "A"))) ZAny)),+ success "->type conflicts with ->true and -1 conflicts with ->" grammar "->type($string)" (newRef "main" (Node (StringTypeFunc StringVariable) Empty)),+ success "<= conflicts with <empty>" grammar "<= 0" (newRef "main" (Node (IntLessOrEqualFunc IntVariable (Const 0)) Empty)),+ success "unexpected space builtin treenode child" grammar "A == \"F\"" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringEqualFunc StringVariable (Const "F")) Empty))),+ success "unexpected space after comment" grammar "(* & */*spaces*/ )" (newRef "main" (And ZAny ZAny)),+ success "treenode with child builtin type" grammar "A :: $string" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringTypeFunc StringVariable) Empty))),+ success "extra semicolon" grammar "{*;*;}" (newRef "main" (Interleave ZAny ZAny)),++ HUnit.testCase "" (return ())]
+ test/RelapseSpec.hs view
@@ -0,0 +1,43 @@+-- | +-- This module RelapseSpec tests the Relapse module.+module RelapseSpec (+ tests+) where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HUnit++import Control.Monad.Except (runExcept)++import Relapse+import Json++tests = T.testGroup "Relapse" [+ HUnit.testCase "parseGrammar success" $ either HUnit.assertFailure (\_ -> return ()) $+ runExcept $ Relapse.parseGrammar "a == 1"++ , HUnit.testCase "parseGrammar failure" $ either (\_ -> return ()) (\_ -> HUnit.assertFailure "expected error") $+ runExcept $ Relapse.parseGrammar "{ a : 1 }" ++ , HUnit.testCase "validate success" $ + either HUnit.assertFailure (HUnit.assertBool "expected success") $ + Relapse.validate <$> + runExcept (Relapse.parseGrammar "a == 1") <*> + Json.decodeJSON "{\"a\":1}"++ , HUnit.testCase "validate failure" $+ either HUnit.assertFailure (HUnit.assertBool "expected failure" . not) $+ Relapse.validate <$> + runExcept (Relapse.parseGrammar "a == 1") <*> + Json.decodeJSON "{\"a\":2}"++ , HUnit.testCase "filter" $ case do {+ refs <- runExcept $ Relapse.parseGrammar "a == 1";+ want <- Json.decodeJSON "{\"a\":1}";+ other <- Json.decodeJSON "{\"a\":2}";+ return (Relapse.filter refs [want, other], [want]);+ } of+ (Left err) -> HUnit.assertFailure err+ (Right (got, want)) -> HUnit.assertEqual "expected the same tree" want got++ ]
+ test/Suite.hs view
@@ -0,0 +1,145 @@+-- |+-- Suite parses the testsuite folder and creates test cases+module Suite (+ readTestCases, tests+) where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HUnit++import System.Directory (getCurrentDirectory, listDirectory, doesDirectoryExist)+import System.FilePath (FilePath, (</>), takeExtension, takeBaseName, takeDirectory)+import Text.XML.HXT.DOM.TypeDefs (XmlTree)+import Control.Monad.Except (Except(..), runExcept)++import Parsers (Tree)+import Patterns (Refs, Pattern, nullable, hasRecursion)+import Json (JsonTree, decodeJSON)+import Xml (decodeXML)+import Parser (parseGrammar)++import qualified Derive+import qualified MemDerive+import qualified VpaDerive++tests :: [TestSuiteCase] -> T.TestTree+tests testSuiteCases = + let nonRecursiveTestCases = filter (\(TestSuiteCase _ g _ _) -> not (hasRecursion g)) testSuiteCases+ derivTests = T.testGroup "derive" $ map (newTestCase AlgoDeriv) nonRecursiveTestCases+ zipTests = T.testGroup "zip" $ map (newTestCase AlgoZip) nonRecursiveTestCases+ mapTests = T.testGroup "map" $ map (newTestCase AlgoMap) nonRecursiveTestCases+ vpaTests = T.testGroup "vpa" $ map (newTestCase AlgoVpa) nonRecursiveTestCases+ in T.testGroup "Suite" [derivTests, zipTests, mapTests, vpaTests]++readTestCases :: IO [TestSuiteCase]+readTestCases = do {+ path <- testPath;+ exists <- doesDirectoryExist path;+ if exists+ then do {+ jsondirs <- ls $ path </> "json";+ xmldirs <- ls $ path </> "xml";+ xmlTestCases <- mapM readXMLTest xmldirs;+ jsonTestCases <- mapM readJsonTest jsondirs;+ return $ jsonTestCases ++ xmlTestCases+ } else return []+}++data TestSuiteCase = TestSuiteCase {+ name :: String+ , grammar :: Refs+ , input :: EncodedData+ , valid :: Bool+} deriving Show++data EncodedData + = XMLData [XmlTree]+ | JsonData [JsonTree]+ deriving Show++data Algo = AlgoDeriv+ | AlgoZip+ | AlgoMap+ | AlgoVpa+ deriving Show++newTestCase :: Algo -> TestSuiteCase -> T.TestTree+newTestCase algo c@(TestSuiteCase name g (XMLData t) want) = + HUnit.testCase (testName algo c) $ testDeriv algo name g t want+newTestCase algo c@(TestSuiteCase name g (JsonData t) want) = + HUnit.testCase (testName algo c) $ testDeriv algo name g t want++testName :: Algo -> TestSuiteCase -> String+testName algo (TestSuiteCase name g t want) = name ++ "_" ++ show algo++must :: Except String Pattern -> Pattern+must e = case runExcept e of+ (Left l) -> error l+ (Right r) -> r++testDeriv :: Tree t => Algo -> String -> Refs -> [t] -> Bool -> IO ()+testDeriv AlgoDeriv name g ts want = + let p = must $ Derive.derive g ts + got = nullable g p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got+testDeriv AlgoZip name g ts want = + let p = must $ Derive.zipderive g ts + got = nullable g p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got +testDeriv AlgoMap name g ts want = + let p = must $ MemDerive.derive g ts + got = nullable g p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got +testDeriv AlgoVpa name g ts want = + let p = must $ VpaDerive.derive g ts + got = nullable g p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got ++getRelapseJson :: [FilePath] -> FilePath+getRelapseJson paths = head $ filter (\fname -> takeExtension fname == ".json" && takeBaseName fname == "relapse") paths++getRelapse :: [FilePath] -> FilePath+getRelapse paths = head $ filter (\fname -> takeExtension fname == ".txt" && takeBaseName fname == "relapse") paths++isValidCase :: [FilePath] -> Bool+isValidCase paths = length (filter (\fname -> takeBaseName fname == "valid") paths) == 1++filepathWithExt :: [FilePath] -> String -> FilePath+filepathWithExt paths ext = head $ filter (\fname -> takeExtension fname == ext && takeBaseName fname /= "relapse") paths++fromGrammar :: String -> Refs+fromGrammar s = case parseGrammar s of+ (Left err) -> error $ "given input: <" ++ s ++ "> got parse error: " ++ show err+ (Right r) -> r++readJsonTest :: FilePath -> IO TestSuiteCase+readJsonTest path = do {+ files <- ls path;+ grammarData <- readFile $ getRelapse files;+ jsonData <- readFile $ filepathWithExt files ".json";+ let jValue = case decodeJSON jsonData of+ (Left e) -> error e+ (Right r) -> r+ ;+ return $ TestSuiteCase (takeBaseName path) (fromGrammar grammarData) (JsonData jValue) (isValidCase files)+}++readXMLTest :: FilePath -> IO TestSuiteCase+readXMLTest path = do {+ files <- ls path;+ grammarData <- readFile $ getRelapse files;+ xmlData <- readFile $ filepathWithExt files ".xml";+ return $ TestSuiteCase (takeBaseName path) (fromGrammar grammarData) (XMLData $ decodeXML xmlData) (isValidCase files)+}++ls :: FilePath -> IO [FilePath]+ls path = do {+ dirs <- listDirectory path;+ return $ map (path </>) dirs+}++testPath :: IO FilePath+testPath = do {+ path <- getCurrentDirectory;+ return $ takeDirectory path </> "testsuite" </> "relapse" </> "tests"+}