diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,18 @@ +# Revision history for tasty-sugar + +## 0.2.0.0 -- 2021-01-12 + + * Renamed CUBE "source" to "rootName" + + * Updated Sweets structure to show root match base and match name + + * Rewritten implementation using Logic capabilities. Clarified many + corner cases and fully implemented all logic. + +* Significantly enhanced testing. + + * Updated documentation. + +## 0.1.0.0 -- 2019-12-24 + +* Initial version. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +Copyright (c) 2019 Kevin Quick + +Permission to use, copy, modify, and/or distribute this software for any purpose +with or without fee is hereby granted, provided that the above copyright notice +and this permission notice appear in all copies. + +THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH +REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, +INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS +OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER +TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF +THIS SOFTWARE. diff --git a/README.org b/README.org new file mode 100644 --- /dev/null +++ b/README.org @@ -0,0 +1,571 @@ +#+TITLE: Tasty SUGAR - Search Using Golden Answer References +#+AUTHOR: Kevin Quick + +* Tasty SUGAR - Search Using Golden Answer References + + The ~tasty-sugar~ package extends the tasty testing framework with + the ability to generate tests based on golden answer files found for + specific inputs. Multiple answers may be specified with different + parameterization, and there can be associated files that are + presented to the test as well. + + The primary use of tasty-sugar is to generate test cases based on + the contents of a directory, where the presence of various files + determine which tests are generated. + +** Elements of tasty-sugar: + + * Tasty.Sugar.CUBE :: Configuration Using Base Expectations + + Describes the configuration for tasty-sugar tests, including + where they are located and what syntax the files should have. + + * Tasty.Sugar.Sweets :: Specifications With Existing Expected Testing Samples + + The tasty-sugar library uses one or more CUBE's to generate a + set of test configurations based on the existing files found, + outputting a list of Sweets representing the existing test + data. + +# * KWQ: something to generate the tests +# * KWQ: name of the test runner to show the tests +# * KWQ: a test runner or option to write new outputs + +* How to use tasty-sugar + + Full information on tasty-sugar features and capabilities will be + provided in a later [[id:de026768-f805-4d30-8299-522cdd70926b][Detailed Information]] section, but this is a + quick introduction describing various testing use cases and how + tasty-sugar can be used in those use cases. + + For these motivational use cases, the example scenario basis is that + the target to be tested is a tool to parse binary ELF files and + generate various output information about those files (e.g. similar + to objdump, but in a Haskell library form). + +** Single Expected Output per Test + + * Scenario :: When running a test, it generates output that should + be compared to the expected data maintained in a file. + There is a simple, single expected output for each + test, and no inputs other than the test name. + + For the example scenario, several actual ELF binary files were + collected and placed in the ~test/samples~ directory: + + #+BEGIN_EXAMPLE + $ ls test/samples + empty.txt + fibonacci.c + fibonacci + foo.tar + hello.c + hello + ls.c + ls + tmux.c + tmux + $ + #+END_EXAMPLE + + Note that there are a couple of non-ELF files in there as well, to + verify the errors generated by our library when given + + The actual outputs aren't known yet, but tasty-sugar can help with + that. Setup the tasty-sugar CUBE configuration as follows: + + #+BEGIN_EXAMPLE + cube = mkCUBE { inputDir = "test/samples" + , rootName = "*.c" + , expectedSuffix = "exp" + , associatedNames = [ ("binary", "") ] + } + main = do testSweets <- findSugar cube + defaultMain $ testGroup "elf" $ + withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> + testCase (rootMatchName sweets <> " #" <> show expIdx) $ do + let Just binaryName = lookup "binary" $ associated expectation + r <- runTestOn binaryName + e <- readFile $ expectedFile expectation + r @?= e + + runTestOn :: FilePath -> IO String + runTestOn f = ... + #+END_EXAMPLE + + The tasty-sugar framework does not provide the actual testing: that + is still provided by the developer. Instead, the tasty-sugar + framework reads the contents of the ~test/samples~ directory and + analyses the available files to create a list of tests that should + be run. The tasty-sugar package also provides a function that can + organize the tests and invoke the user's test function once for + each test configuration. + + If the tests are run at this point, the tasty-sugar framework will + do nothing. + + Why? + + The tasty-sugar framework will ignore any files in the target + directory that do not have an associated expected file describing + the expected output. This can be confirmed by running the tests + with the ~--showsearch~ argument, which will use an alternate tasty + ingredient that does not actually run the tests but write out the + search process and search results. + + To get actual tests to run, simply create an expected file for each + of the input candidates. The contents of the file can be empty, or + any random data. + + Running the tests now will result in a test created for each input + file that has a corresponding ~*.exp~ file. Note that tasty-sweet + doesn't actually read in any of the files, just invokes the test + creation function with the Sweets and Expectation data structures + that let the test do whatever is appropriate. + + #+BEGIN_EXAMPLE + $ ls test/samples + empty.txt + empty.txt.exp + fibonacci + finonacci.c + fibonacci.exp + foo.tar + foo.tar.exp + hello + hello.c + hello.exp + ls + ls.c + ls.exp + tmux + tmux.c + $ + #+END_EXAMPLE + + Note that ~empty.txt~ and ~foo.tar~ will be ignored, even though + there is an ~.exp~ file for them because they don't match the + source target of ~*.c~. Similarly, ~tmux~ will be ignored because + there is no ~.exp~ file for it. + + At this point, any changes to the target library that cause output + changes will be identified when running the tests. + +** Single Input and Output per Test + + * Scenario :: Similar to the previous scenario, but there is a file + containing the expected input needed by the test to + generate the output. + + To extend the previous example, let us assume that in addition to + the pre-existing binaries that we will be generating a number of + "interesting" binaries to run the target library on. These will be + kept in a different directory where a different part of the build + will compile the sources to generate the binaries for testing: + + #+BEGIN_EXAMPLE + $ ls test/src_samples + foo.c + foo + foo.expct + simple.c + simple + simple.expct + recursive.rs + recursive + recursive.expct + functional.hs + functional + functional.expct + $ + #+END_EXAMPLE + + Note that there are several different source types (C, Rust, + Haskell) involved, but each of them has an associated output binary + that the target library should be tested on. + + In an initial approach, the source files can be ignored by the + testing code: simply create a ~FILE.expct~ file for each of the + binaries and use the same ~Tasty.Sugar.CUBE~ configuration for this + directory as for the previous directory. + + However however an approach where the actual test written by the + user needs access to the source file itself for some reason. This + can be handled by specifying an "associated" file in the + ~Tasty.Sugar.CUBE~ configuration: + + #+BEGIN_EXAMPLE + cube = mkCUBE { inputDir = "test/samples" + , rootName = "*.exe" + , expectedSuffix = "expct" + , associatedNames = [ ("c-source", ".c") + , ("rust-source", ".rs") + , ("haskell", ".hs) + ] + } + + ingredients = includingOptions sugarOptions : + sugarIngredients cube <> defaultIngredients + + main = do testSweets <- findSugar cube + defaultMainWithIngredients ingredients $ + testGroup "elf" $ + withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> + testCase (rootMatchName sweets <> " #" <> show expIdx) $ do + e <- readFile $ expectedFile expectation + let assoc = associated expectation + f = rootFile sweets + r <- case lookup "c-source" assoc of + Just c -> runCTestOn f + Nothing -> + case lookup "rust-source" assoc of + Just r -> runRustTestOn f + Nothing -> + runHaskellTestOn f + r @?= e + + runCTestOn :: FilePath -> IO String + runCTestOn f = ... + + runRustTestOn :: FilePath -> IO String + runRustTestOn f = ... + + runHaskellTestOn :: FilePath -> IO String + runHaskellTestOn f = ... + #+END_EXAMPLE + + Now when tasty-sugar generates the test configurations, each test + will have a name, a source file, an expected file, and a single + associated file. The test is free to use these files in any way it + sees fit. For the configuration above, there would be 4 test + configurations provided to the test: + + | Test Name | Input File | Expected File | Associated Files | + |------------+------------+------------------+---------------------------------| + | simple | simple | simple.expct | ("c-source", "simple.c") | + | foo | foo | foo.expct | ("c-source", "foo.c") | + | recursive | recursive | recursive.expct | ("rust-source", "recursive.rs") | + | functional | functional | functional.expct | ("haskell", "functional.hs") | + + Note that if both "simple.c" and "simple.hs" files existed, then the + simple test configuration would get both as associated files. + +** Single Input with different parameters producing different outputs + + * Scenario :: For each input file, multiple tests should be run, + each with different parameters, and the expected + output may or may not depend on the parameter. + + Using the previous example scenario, let's now assume that for each + of the source sample files, two different executables were built: + one with and one without optimization. Additionally, if they were a + C source file, then there was a version built with GCC and a version + built with Clang. The output executables are now named accordingly: + + #+BEGIN_EXAMPLE + $ ls test/src_samples + foo.c + foo.noopt.clang.exe + foo.O0.gcc.exe + foo.opt.clang.exe + foo.O2.gcc.exe + foo.O3.gcc.exe + simple.c + simple.noopt.clang.exe + simple.noopt.gcc.exe + simple.opt-clang.exe + simple-opt.gcc-exe + recursive.rs + recursive.noopt.exe + recursive.opt.exe + functional.hs + functional.noopt.exe + functional.opt.exe + $ + #+END_EXAMPLE + + While the filenames are fairly regular, there are different numbers + of executables and different naming conventions for different files. + + The opt/noopt/O0/O2/O3 and gcc/clang information is known to + tasty-sugar as a "parameter". Parameters can appear in the filename + in a specific order, and each parameter may have one of a set of + valid values (e.g. gcc or clang) or it may have any (free-form) + value (as with the optimization specification). + + The ~Tasty.Sugar.CUBE~ confguration for is scenario is updated to: + + #+BEGIN_EXAMPLE + cube = mkCUBE { inputDir = "test/samples" + , rootName = "*" + , separators = "-." + , expectedSuffix = "expct" + , associatedNames = [ ("c-source", ".c") + , ("rust-source", ".rs") + , ("haskell", ".hs") + ] + , validParams = [ + ("optimization", Nothing) + ,("c-compiler", Just ["gcc", "clang"]) + ] + } + + ingredients = includingOptions sugarOptions : + sugarIngredients cube <> defaultIngredients + + main = do testSweets <- findSugar cube + defaultMainWithIngredients ingredients $ + testGroup "elf" $ + withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> + testCase (rootMatchName sweets <> " #" <> show expIdx) $ do + e <- readFile $ expectedFile expectation + let assoc = associated expectation + f = rootFile sweets + r <- case lookup "c-source" assoc of + Just c -> runCTestOn f + Nothing -> + case lookup "rust-source" assoc of + Just r -> runRustTestOn f + Nothing -> + runHaskellTestOn f + r @?= e + + runCTestOn :: FilePath -> String + runCTestOn f = ... + + runRustTestOn :: FilePath -> String + runRustTestOn f = ... + + runHaskellTestOn :: FilePath -> String + runHaskellTestOn f = ... + #+END_EXAMPLE + + Parameters are separated by designated separator characters and must + appear in the order declared. The default separators are "." and + "-" (e.g. both of the two optimized executable files for the + simple.c source above are accepted). + + Filenames may omit later parameter values: the file is assumed to + apply to all unspecified parameter values if there is no more + specific override. This can be very useful to avoid repetition and + copying when specifying test files. + + In the above example, a ~simple.expected~ file would be used for all + four executables, but if there was also a + ~simple.noopt-gcc.expected~ and a ~simple-opt.expected~ then the + former would be used only for the ~simple.noopt.gcc.exe~ and the + latter would be used for both the ~gcc~ and the ~clang~ executables, + leaving the ~sample.expected~ to be used only for the + ~simple.opt-clang.exe~ file. + +# ** Multiple Inputs with different parameters producing different outputs +# +# KWQ... + +* Comparisons + +** tasty-KAT + + * The tasty-KAT package reads both the inputs and the outputs from a + single file, instaed of allowing the inputs to be a separate file + that can be processed by the target under test. + + + The tasty-sugar package allows inputs and outputs to be in + separate files, and additional "associated" files to be provided + as inputs to the test. + + * The tasty-KAT package inputs and outputs must be specifiable in a + file with other KAT markup; this does not easily handle text + markup conflicts and binary inputs/outputs. + + + The tasty-sugar package does not attempt to interpret the + contents of the files, but simply passes them to the test + itself. + + * The tasty-KAT package does not allow auxiliary files, or different + parameterized tests. + + + As mentioned above, tasty-sugar allows multiple auxiliary files + per tests, and allows test inputs and expected outputs to be + filename parameterized (with either constrained or free-form + parameter values). + +** tasty-golden + + * The tasty-golden package requires a 1:1 association between tests + and corresponding golden expected output files; it does not + support file-provided inputs, or associated files. + + + The tasty-sugar package allows multiple associated files in + addition to the primary input file. + + + The tasty-sugar package supports parameterization of expected + results (and associated files) as part of the filenames to allow + multiple tests per input. + + * The tasty-golden package will write the expected results if the + expected file is missing. + + + The tasty-sugar package will write the actual output to a + *separate* file, but it will not overwrite or assume + expectations. This allows the user to validate the output + before declaring it to be the proper expected value (simply by + copying the actual output file to the expected output file). + +** tasty-silver + + Similar to tasty-golden in functionality. + +** Features unique to tasty-sugar + + * Multiple potential outputs, parameterized by filename elements. + + * Multiple associated input files. + + * Search analysis mode showing how tests are generated based on the + available files. + + * Automatic grouping of generated tests by parameter values. + +* Limitations + + * Huge directories + * Huge files + * Will throw any exception that the listDirectory function can throw. + +* Detailed Information + :PROPERTIES: + :ID: de026768-f805-4d30-8299-522cdd70926b + :END: + +** Requirements + + * There must be a root (input) file to feed to the test + + * There must be one or more "expected" results files for a root file + + * There may be associated files for the root file required for the test + + * All three groups of files may be parameterized by additional fields. + + * All fields are represented by a common basename with optional + parameters and required associated suffixes, separated by + allowable separators. + + All of the above may utilize globbing as provided by System.FilePath.Glob + +* Examples + +** Example: + + For example, a test which would verify that the size of a compiled + file meets the expectations would specify: + + #+BEGIN_EXAMPLE + CUBE = + { inputDir = "tests/samples" -- relative to cabal file + , separators = ".-" + , rootName = "*.c" + , associatedNames = [ ("exe", "exe") + , ("object", "o") + ] + , expectedSuffix = "expected" + , validParams = [ ("arch" : Just ["ppc", "x86_64"]) ] + } + #+END_EXAMPLE + + And given the following directory configuration: + + #+BEGIN_EXAMPLE + tests/samples/ + foo.c + bar.c + bar.exe + bar.ppc.exe + bar.expected + cow.c + cow.ppc.exe + cow.x86_64.exe + cow.expected + cow.ppc-expected + cow.x86.expected + moo.c + moo.exe + moo-expected + dog.exe + dog.expected + #+END_EXAMPLE + + The result would be: + + #+BEGIN_EXAMPLE + sweets = + [ Sweets + { rootMatchName = "bar" + , rootBaseName = "bar" + , rootFile = "tests/samples/bar.c" + , expected = + [ Expectation + { expectedFile = "tests/samples/bar.expected" + , associated = [ ("exe", "tests/samples/bar.exe") ] + , expParamsMatch = [] + } + , Expectation + { expectedFile = "tests/samples/bar.expected" + , associated = [ ("exe", "tests/samples/bar.ppc.exe") ] + , expParamsMatch = [ ("arch", "ppc") ] + } + ] + }, + , Sweets + { rootMatchName = "cow" + , rootBaseName = "cow" + , rootFile = "tests/samples/cow.c" + , expected = + [ Expectation + { expectedFile = "tests/samples/cow.ppc-expected" + , associated = [ ("exe", "tests/samples/cow.ppc.exe") ] + , expParamsMatch = [ { "arch", "ppc" } ] + } + , Expectedfile + { expectedFile = "tests/samples/cow.expected" + , associated = [ ("exe", "tests/samples/cow.x86_64.exe") ] + , expParamsMatch = [ ("arch", "x86_64") ] + } + ] + }, + , Sweets + { rootMatchName = "moo" + , rootBaseName = "moo" + , rootFile = "tests/samples/moo.c" + , expected = + [ Expectation + { expectedFile = "tests/samples/moo-expected" + , associated = [ ("exe", "tests/samples/moo.exe") ] + , expParamsMatch = [] + } + ] + }, + #+END_EXAMPLE + +* FAQ + + Why do the configurations need to be described by a ~Tasty.Sugar.CUBE~ + data object? Why can't they be passed in on the command-line? + + * Answer :: They could be, but there are a couple of issues that + would make that more awkward: + + 1. There would need to be a number of command-line + arguments to describe all of the CUBE information. + + 2. The tasty framework provides command-line parsing and + argument handling (and expects to do so). Handling + some command-line arguments prior to tasty and some + within tasty would be difficult and brittle (and also + note that the set of all tests must be known *prior* + to invoking the tasty main code; they cannot be added + dynamically after that point). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/example1/NiftyText.hs b/examples/example1/NiftyText.hs new file mode 100644 --- /dev/null +++ b/examples/example1/NiftyText.hs @@ -0,0 +1,34 @@ +-- | Fancy text processor, surely destined to replace pandoc some day! + +module NiftyText ( processText ) where + +import Data.List + +processText :: String -> String -> String -> String +processText transform outfmt inp = + let wls = words <$> lines inp + xf = case transform of + "passthru" -> id + "upper" -> upper + "lower" -> lower + outf = case outfmt of + "ascii" -> unwords + "octets" -> octets + "sizes" -> sizes + in unlines $ map (outf . map xf) wls + +upper w = + let toUpper c = if c `elem` ['a'..'z'] + then toEnum $ fromEnum c - fromEnum 'a' + fromEnum 'A' + else c + in map toUpper w + +lower w = + let toLower c = if c `elem` ['A'..'Z'] + then toEnum $ fromEnum c - fromEnum 'A' + fromEnum 'a' + else c + in map toLower w + +octets = intercalate " " . map (intercalate " " . map (show . fromEnum)) + +sizes l = show (length l) <> ": " <> intercalate " " (map (show . length) l) diff --git a/examples/example1/README.org b/examples/example1/README.org new file mode 100644 --- /dev/null +++ b/examples/example1/README.org @@ -0,0 +1,164 @@ +* Scenario + +In this example, a fancy library for processing text files has been +developed. The library will read text files and perform various +modifications to those files, then output them in one of various +forms. + +The library is implemented by the [[NiftyText.hs]] source file in this +directory. The functionality provided by the library is pretty basic +at this stage: + +#+BEGIN_EXAMPLE +$ ghci -isrc NiftyText.hs +GHCi, version 8.8.3: https://www.haskell.org/ghc/ :? for help +[1 of 1] Compiling NiftyText ( NiftyText.hs, interpreted ) +Ok, one module loaded. + +*NiftyText> processText "passthru" "ascii" "This is the TEXT I will process." +"This is the TEXT I will process.\n" + +*NiftyText> processText "upper" "ascii" "This is the TEXT I will process." +"THIS IS THE TEXT I WILL PROCESS.\n" + +*NiftyText> processText "lower" "ascii" "This is the TEXT I will process." +"this is the text i will process.\n" + +*NiftyText> processText "lower" "octets" "This is the TEXT I will process." +"116 104 105 115 105 115 116 104 101 116 101 120 116 105 119 105 108 108 112 114 111 99 101 115 115 46\n" + +*NiftyText> putStrLn $ processText "passthru" "sizes" "This is the\n TEXT\n I will process." +3: 4 2 3 +1: 4 +3: 1 4 8 + +*NiftyText> +#+END_EXAMPLE + +The first parameter to the `processText` specifies the transformation +and the second parameter specifies the output form. In order to test +this library, a set of tests should be defined that will verify +different combinations of the transformation and the output form for +multiple different inputs. + +* Testing + +As a simple beginning, a test can be developed for the "passthru" and +"ascii" parameters, with simple pairings of sample input files and +expected output files. + +Sample input files: + +#+BEGIN_EXAMPLE +$ ls testdata +hello_inp +hello_inp.exp +counting +counting.exp + +$ cat testdata/hello_inp +Hello, world. + +$ cat testdata/counting +1 +Number 2 +The number three +This is # 4 +Fifth line: here's number five. +#+END_EXAMPLE + +For each one of these, the ~passthru ascii~ configuration should +result in no change to the input, so the expected results files are +identical to the input files: + +#+BEGIN_EXAMPLE +$ cat testdata/hello_inp.exp +Hello, world. + +$ cat testdata/counting.exp +1 +Number 2 +The number three +This is # 4 +Fifth line: here's number five. +#+END_EXAMPLE + +The ~tasty-sugar~ module can be used to identify the proper pairings +of these files to use for running tests. A "cube" is setup that +defines the file configurations: + +#+BEGIN_EXAMPLE +$ ghci NiftyText.hs ../../src/Test/Tasty/Sugar.hs +GHCi, version 8.8.3: https://www.haskell.org/ghc/ :? for help +[1 of 2] Compiling NiftyText ( NiftyText.hs, interpreted ) +[2 of 2] Compiling Test.Tasty.Sugar ( ../../src/Test/Tasty/Sugar.hs, interpreted ) +Ok, two modules loaded. +*NiftyText> +*NiftyText> :module Test.Tasty.Sugar +Prelude Test.Tasty.Sugar> cube = mkCUBE { inputDir = "testdata" } +Prelude Test.Tasty.Sugar> +Prelude Test.Tasty.Sugar> findSugar cube +[Sweets + {inputName = "counting", + sourceFile = "testdata/counting", + cubeParams = [], + expected = + [Expectation + {expectedFile = "testdata/counting.exp", + expParamsMatch = [], + associated = []}]}, + Sweets + {inputName = "hello_inp", + sourceFile = "testdata/hello_inp", + cubeParams = [], + expected = + [Expectation + {expectedFile = "testdata/hello_inp.exp", + expParamsMatch = [], + associated = []}]} +] +Prelude Test.Tasty.Sugar> +#+END_EXAMPLE + +The output above was reformatted for readability, but it's clear that +~tasty-sugar~ found both input files and the corresponding expected +output file. + +The [[test-passthru-ascii.hs]] file shows how the above information is +used for operating actual tests. The test is passed a single ~Sweets~ +object like the one returned from ~findSugar~ above, and also a +specific ~Expectation~ array entry for that ~Sweets~. The ~Sweets~ +has a list of *all* the ~Expectation~ entries, but the test expects to +explicitly be given a single ~Expectation~ to validate. + +It is worth noting at this point that ~tasty-sweet~ doesn't provide or +impose any specific testing mechanisms on the testing process; the +main facility provided by ~tasty-sweet~ is to scan the ~inputDir~ +specified by the ~CUBE~ and find all pairings of inputs and outputs. +Although an explicit comparison was done above, other types of testing +could be performed, including using ~tasty-golden~ to perform the +comparison to the expected output file. + +* Results + +Running the tests shows the two expected outputs being verified: + +#+BEGIN_EXAMPLE +$ cabal v2-run test:test-passthru-ascii +passthru ascii tests + counting + checking examples/example1/testdata/counting.exp: OK + hello_inp + checking examples/example1/testdata/hello_inp.exp: OK + +All 2 tests passed (0.00s) +#+END_EXAMPLE + +_Excellent!_ This has now used ~tasty-sweet~ to help verify that the +~NiftyText~ library does the right thing when used in ~passthru~ +~ascii~ mode for a couple of different inputs. At this point however, +the test scenario is simple and ~tasty-golden~ could just as easily +have been used instead of ~tasty-sweet~. The advantage of using +~tasty-sweet~ starts to become apparent when testing is expanded to +other modes besides ~passthru~ and ~ascii~, as demonstrated in +[[../example2/README.org]]. diff --git a/examples/example1/test-passthru-ascii.hs b/examples/example1/test-passthru-ascii.hs new file mode 100644 --- /dev/null +++ b/examples/example1/test-passthru-ascii.hs @@ -0,0 +1,23 @@ +module Main where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Sugar + +import NiftyText + + +cube = mkCUBE { inputDir = "examples/example1/testdata" } + + +main = do sweets <- findSugar cube + defaultMain $ testGroup "passthru ascii tests" $ + withSugarGroups sweets testGroup test_passthru_ascii + + +test_passthru_ascii sweet cnt exp = + testCase ("checking #" <> show cnt <> ": " <> expectedFile exp) $ do + inp <- readFile $ rootFile sweet + let testout = NiftyText.processText "passthru" "ascii" inp + out <- readFile $ expectedFile exp + out @=? testout diff --git a/examples/example1/testdata/counting b/examples/example1/testdata/counting new file mode 100644 --- /dev/null +++ b/examples/example1/testdata/counting @@ -0,0 +1,5 @@ +1 +Number 2 +The number three +This is # 4 +Fifth line: here's number five. diff --git a/examples/example1/testdata/counting.exp b/examples/example1/testdata/counting.exp new file mode 100644 --- /dev/null +++ b/examples/example1/testdata/counting.exp @@ -0,0 +1,5 @@ +1 +Number 2 +The number three +This is # 4 +Fifth line: here's number five. diff --git a/examples/example1/testdata/hello_inp b/examples/example1/testdata/hello_inp new file mode 100644 --- /dev/null +++ b/examples/example1/testdata/hello_inp @@ -0,0 +1,1 @@ +Hello, world. diff --git a/examples/example1/testdata/hello_inp.exp b/examples/example1/testdata/hello_inp.exp new file mode 100644 --- /dev/null +++ b/examples/example1/testdata/hello_inp.exp @@ -0,0 +1,1 @@ +Hello, world. diff --git a/examples/params/samples/foo.c b/examples/params/samples/foo.c new file mode 100644 --- /dev/null +++ b/examples/params/samples/foo.c @@ -0,0 +1,1 @@ +Input C file diff --git a/examples/params/samples/functional.O2.expct b/examples/params/samples/functional.O2.expct new file mode 100644 --- /dev/null +++ b/examples/params/samples/functional.O2.expct @@ -0,0 +1,1 @@ +Haskell expected diff --git a/examples/params/samples/functional.hs b/examples/params/samples/functional.hs new file mode 100644 --- /dev/null +++ b/examples/params/samples/functional.hs @@ -0,0 +1,1 @@ +Input Haskell file diff --git a/examples/params/samples/recursive.fast.expct b/examples/params/samples/recursive.fast.expct new file mode 100644 --- /dev/null +++ b/examples/params/samples/recursive.fast.expct @@ -0,0 +1,1 @@ +Rust expected diff --git a/examples/params/samples/recursive.rs b/examples/params/samples/recursive.rs new file mode 100644 --- /dev/null +++ b/examples/params/samples/recursive.rs @@ -0,0 +1,1 @@ +Input RUST file diff --git a/examples/params/samples/simple-opt.expct b/examples/params/samples/simple-opt.expct new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple-opt.expct @@ -0,0 +1,1 @@ +Simple C file expected output diff --git a/examples/params/samples/simple-opt.gcc-exe b/examples/params/samples/simple-opt.gcc-exe new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple-opt.gcc-exe @@ -0,0 +1,1 @@ +This is an EXE file produced from C by GCC with OPTIMIZATION diff --git a/examples/params/samples/simple.c b/examples/params/samples/simple.c new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.c @@ -0,0 +1,1 @@ +Input C file diff --git a/examples/params/samples/simple.expct b/examples/params/samples/simple.expct new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.expct @@ -0,0 +1,1 @@ +Simple C file expected output diff --git a/examples/params/samples/simple.noopt-gcc.expct b/examples/params/samples/simple.noopt-gcc.expct new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.noopt-gcc.expct @@ -0,0 +1,1 @@ +Simple C file expected output diff --git a/examples/params/samples/simple.noopt.clang.exe b/examples/params/samples/simple.noopt.clang.exe new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.noopt.clang.exe @@ -0,0 +1,1 @@ +This is an EXE file produced from C by CLANG with NO OPTIMIZATION diff --git a/examples/params/samples/simple.noopt.gcc.exe b/examples/params/samples/simple.noopt.gcc.exe new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.noopt.gcc.exe @@ -0,0 +1,1 @@ +This is an EXE file produced from C by GCC with NO OPTIMIZATION diff --git a/examples/params/samples/simple.opt-clang.exe b/examples/params/samples/simple.opt-clang.exe new file mode 100644 --- /dev/null +++ b/examples/params/samples/simple.opt-clang.exe @@ -0,0 +1,1 @@ +This is an EXE file produced from C by CLANG with OPTIMIZATION diff --git a/examples/params/test-params.hs b/examples/params/test-params.hs new file mode 100644 --- /dev/null +++ b/examples/params/test-params.hs @@ -0,0 +1,68 @@ +module Main where + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import Text.Show.Pretty + + +cube :: CUBE +cube = mkCUBE { inputDir = "examples/params/samples" + , rootName = "*.exe" + , separators = "-." + , expectedSuffix = "expct" + , associatedNames = [ ("c-source", "c") + , ("rust-source", "rs") + , ("haskell", "hs") +] + , validParams = [ + ("optimization", Nothing) + ,("c-compiler", Just ["gcc", "clang"]) + ] + } + +ingredients = includingOptions sugarOptions : + sugarIngredients cube <> defaultIngredients + +main :: IO () +main = + do testSweets <- findSugar cube + defaultMainWithIngredients ingredients $ + testGroup "elf" $ + withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> + testCase (rootMatchName sweets <> " #" <> show expIdx) $ do + e <- readFile $ expectedFile expectation + let assoc = associated expectation + f = rootFile sweets + r <- case lookup "c-source" assoc of + Just c -> runCTestOn f + Nothing -> + case lookup "rust-source" assoc of + Just r -> runRustTestOn f + Nothing -> + case lookup "haskell" assoc of + Just r -> runHaskellTestOn f + Nothing -> + -- Since "optimization" doesn't have + -- specific values, the root *could* + -- be "simple.noopt", but if that's + -- the root, there's no associated + -- file. + if f == "examples/params/samples/simple.noopt.gcc.exe" + then runCTestOn f + else runUnexpTestOn sweets expectation f + putStrLn $ ppShow sweets + r @?= e + +runCTestOn :: FilePath -> IO String +runCTestOn _ = return $ "Simple C file expected output" + +runRustTestOn :: FilePath -> IO String +runRustTestOn _ = return "Rust expected" + +runHaskellTestOn :: FilePath -> IO String +runHaskellTestOn _ = return "Haskell expected" + +runUnexpTestOn :: Sweets -> Expectation -> FilePath -> IO String +runUnexpTestOn s e _ = return $ "unassociated " <> (ppShow s) <> " to " <> (show e) diff --git a/src/Test/Tasty/Sugar.hs b/src/Test/Tasty/Sugar.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Sugar.hs @@ -0,0 +1,329 @@ +-- | Provides test identification by Search Using Golden Answer +-- References. This is similar in principle to Tasty.KAT and +-- Tasty.Golden, but with different input selection processes. The +-- intent is that there are multiple different test scenarios, which +-- may all originate with the same input, and that all scenarios are +-- specified by the presence of an "expected" result file along with +-- optional support files. +-- +-- A 'Tasty.Sugar.CUBE' object is provided to the 'findSugar' function +-- which returns an array of 'Tasty.Sugar.Sweets' that describe test +-- configurations. +-- +-- The 'sugarOptions' should be added to the tasty Options +-- specification, and the 'sugarIngredients' provides additional +-- ingredients for the sugar testing (e.g. the ability to use +-- --showsearch and see the scan and identification of tests). +-- +-- The 'withSugarGroups' function can be used to drive the test +-- invocations and group the 'Sweets' by parameter values. +-- +-- Example: +-- +-- > import Test.Tasty as T +-- > import Test.Tasty.Options +-- > import Test.Tasty.Sugar +-- > +-- > sugarCube = mkCUBE { inputDir = "test/samples" +-- > , rootName = "*.c" +-- > , associatedNames = [ ("inputs", "inp") ] +-- > , expectedSuffix = "exp" +-- > } +-- > +-- > ingredients = T.includingOptions sugarOptions : +-- > sugarIngredients sugarCube <> +-- > T.defaultIngredients +-- > +-- > main = +-- > do testSweets <- findSugar sugarCube +-- > T.defaultMainWithIngredients ingredients $ +-- > T.testGroup "sweet tests" $ +-- > withSugarGroups testSweets T.testGroup mkTest +-- > +-- > mkTest :: Sweets -> Natural -> Expectation -> T.TestTree +-- > mkTest s n e = testCase (rootMatchName s <> " #" <> show n) $ do +-- > Just inpF <- lookup "inputs" $ associated e +-- > inp <- readFile inpF +-- > exp <- reads <$> readFile $ expectedFile e +-- > result <- testSomething inp +-- > result @?= exp +-- +-- See the README for more information. + +{-# LANGUAGE OverloadedStrings #-} + +module Test.Tasty.Sugar + ( + -- * Tasty Options and Ingredients + sugarOptions + , sugarIngredients + + -- * Test Generation Functions + , findSugar + , findSugarIn + , withSugarGroups + + -- * Types + -- ** Input + , CUBE(..) + , Separators + , ParameterPattern + , mkCUBE + -- ** Output + , Sweets(..) + , Expectation(..) + , Association + , NamedParamMatch + , ParamMatch(..) + ) +where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logic +import Data.Function +import qualified Data.List as L +import Data.Maybe ( isJust, isNothing, fromJust ) +import Data.Proxy +import Data.Tagged +import Data.Typeable ( Typeable ) +import Numeric.Natural ( Natural ) +import Options.Applicative +import Prettyprinter +import System.Directory ( listDirectory ) +import Test.Tasty.Ingredients +import Test.Tasty.Options + +import Test.Tasty.Sugar.Analysis +import Test.Tasty.Sugar.Types + +import Prelude hiding ( exp ) + + +---------------------------------------------------------------------- + +data ShowSugarSearch = ShowSugarSearch Bool deriving (Eq, Ord, Typeable) + +instance IsOption ShowSugarSearch where + defaultValue = ShowSugarSearch False + parseValue = fmap ShowSugarSearch . safeRead + optionName = pure $ "showsearch" + optionHelp = pure $ "Show details of the search for the set of\n\ + \sample-file driven tests that would be\n\ + \performed based on the search." + optionCLParser = ShowSugarSearch <$> switch + ( long (untag (optionName :: Tagged ShowSugarSearch String)) + <> help (untag (optionHelp :: Tagged ShowSugarSearch String)) + ) + + +-- | Specify the Sugar-specific Tasty command-line options +sugarOptions :: [OptionDescription] +sugarOptions = [ Option (Proxy :: Proxy ShowSugarSearch) + ] + +-- | Provides the Tasty Ingredients that can be used to inform the +-- testing process. +sugarIngredients :: CUBE -> [Ingredient] +sugarIngredients pat = [ searchResultsSugarReport pat ] + + +-- | This is a Tasty "Ingredient" (aka test runner) that can be used +-- to display the search process and results for generating the tests. +-- This output can be requested by the "--showsearch" argument to the +-- test executable. + +searchResultsSugarReport :: CUBE -> Ingredient +searchResultsSugarReport pat = TestManager [] $ \opts _tests -> + if lookupOption opts == ShowSugarSearch True + then Just $ do searchinfo <- findSugar' pat + let (inps, expl) = searchinfo + putStrLn $ show $ pretty pat + putStrLn "" + putStrLn $ show expl + putStrLn "" + putStrLn $ "Final set of tests [" ++ show (length inps) ++ "]:" + putStrLn $ show $ vsep $ map (("•" <+>) . align . pretty) inps + return True + else Nothing + + +---------------------------------------------------------------------- + +-- | Returns a list of the discovered test configurations (Sweets) +-- that should be run. This function is used to get the list of +-- possible test configurations that is passed with the +-- withSugarGroups function to generate the actual tests. + +findSugar :: MonadIO m => CUBE -> m [Sweets] +findSugar cube = fst <$> findSugar' cube + +findSugar' :: MonadIO m => CUBE -> m ([Sweets], Doc ann) +findSugar' pat = findSugarIn pat <$> liftIO (listDirectory $ inputDir pat) + + +-- | Given a list of files and a CUBE, returns the list of matching +-- test Sweets that should be run, and an explanation of the search +-- process (describing unmatched possibilities as well as valid test +-- configurations). +-- +-- This is a low-level function; the findSugar and withSugarGroups are +-- the recommended interface functions to use for writing tests. + +findSugarIn :: CUBE -> [FilePath] -> ([Sweets], Doc ann) +findSugarIn pat allFiles = + let (nCandidates, sres) = checkRoots pat allFiles + inps = concat $ fst <$> sres + expl = vsep $ + [ "Checking for test inputs in:" <+> pretty (inputDir pat) + , indent 2 $ + vsep $ [ "# files in directory =" <+> + pretty (length allFiles) + , "# root candidates matching" <+> + dquotes (pretty (rootName pat)) <+> equals <+> + pretty nCandidates + , "# valid roots" <+> equals <+> + pretty (length sres) + , "parameters = " <+> pretty (validParams pat) + ] <> ((("--?" <+>) . pretty) <$> (concatMap snd sres)) + ] + in case cubeIsValid pat of + Right _ -> (inps, expl) + Left e -> error e -- this is just testing code, so error is fine + + where + + cubeIsValid :: CUBE -> Either String CUBE + cubeIsValid cube = cube + <$ separatorsAreValid (separators cube) + <* paramsAreValid (separators cube) (validParams cube) + + separatorsAreValid :: Separators -> Either String [()] + separatorsAreValid seps = sequence $ observeAll $ + do (s1,s2) <- choose2 seps + let globChars = "[*](|)\\" :: String + return $ do when (s1 == s2) $ + Left "Duplicate separator characters" + when (s1 `elem` globChars) $ + Left "Separator contains glob wildcard" + when (s2 `elem` globChars) $ + Left "Separator contains glob wildcard" + pure () + + paramsAreValid :: Separators + -> [ParameterPattern] + -> Either String [ParameterPattern] + paramsAreValid seps p = + let existential = filter (isNothing . snd) p + blankVals = filter (or . (fmap null) . snd) p + emptyVal = filter (or . maybe [] (fmap null) . snd) $ filter (isJust . snd) p + dupVals = rmvOrderSwapped $ observeAll duplicatedValues + duplicatedValues = + do p1 <- choose p + p2 <- choose p + guard (isJust $ snd p1) + guard (isJust $ snd p2) + pv <- if (fst p1 == fst p2) + then do (p1v, p2v) <- choose2 $ fromJust $ snd p1 + guard (p1v == p2v) + return p1v + else do p1v <- choose $ fromJust $ snd p1 + p2v <- choose $ fromJust $ snd p2 + guard (p1v == p2v) + return p1v + return ((fst p1, fst p2), pv) + sepVals = observeAll $ + do (n,vl) <- choose p + guard (isJust vl) + v <- choose $ maybe [] id vl + s <- choose seps + guard (s `elem` v) + return n + rmvOrderSwapped [] = [] + rmvOrderSwapped (e@((a,b),_):es) = + let notSwapped ((a',b'),_) = not $ or [ a == a' && b == b' + , a == b' && b == a' ] + in e : rmvOrderSwapped (filter notSwapped es) + in do when (length existential > 1) $ + Left "Only one parameter can have unconstrained values (i.e. Nothing)" + unless (null blankVals) $ + Left ("Blank validParams values are not allowed (" <> + (L.intercalate ", " (fst <$> blankVals)) <> ")") + unless (null emptyVal) $ + Left ("Parameter values cannot be blank (" <> + (L.intercalate ", " (fst <$> emptyVal)) <> ")") + unless (null dupVals) $ + Left ("Parameter values cannot be duplicated " <> show dupVals) + unless (null sepVals) $ + Left ("Parameter values cannot contain separators " <> + show sepVals) + return p + + choose = foldr (mplus . return) mzero + + choose2 lst = let ll = length lst + in do guard (ll > 1) + i1 <- choose [0..ll-1] + i2 <- choose [0..ll-1] + guard (i1 /= i2) + return (lst !! i1, lst !! i2) + + +-- | The 'withSugarGroups' is the primary function used to run tests. +-- Given a list of 'Sweets' returned by 'findSugar', a function to +-- mark a group of tests (usually @Tasty.testGroup@), and a function +-- to generate a test from a 'Sweets' and a specific 'Expectation', +-- this will iterate over the supplied 'Sweets' and call the test +-- generator for each valid test configuration. +-- +-- Note that 'Sweets' contains all expectations (@[Expectation]@), but +-- the passed 'Expectation' is the only one that should be tested for +-- this generated test. +-- +-- > withSugarGroups sweets groupFun mkTestFun +-- +-- where +-- +-- * @groupFun@ is the function to group a set of tests with a +-- specific name. Typically this can just be 'tasty.testGroup' +-- +-- * @mkTestFun@ is the function to create a specific test for the +-- specified expectation. The output type is usually a +-- 'tasty.TestTree'. This is passed the general 'Sweets', the +-- specific 'Expectation' for the test that should be created, and +-- a numeric iteration indicating the test number within this +-- group. The iteration number can be used for differentiation +-- against the other tests, but there is no determinate +-- relationship to elements of the 'Sweets' (such as parameters or +-- associated sets). +-- +withSugarGroups :: [Sweets] + -> (String -> [a] -> a) + -- Given a name and list of tests (aka + -- 'TestTree'), group them (usually 'testGroup') + -> (Sweets -> Natural -> Expectation -> a) + -- Generate a test for this 'Expectation' (usually + -- @a ~ TestTree@) + -> [a] +withSugarGroups sweets mkGroup mkLeaf = + let mkSweetTests sweet = + mkGroup (rootMatchName sweet) $ + mkParams sweet (expected sweet) $ cubeParams sweet + + -- mkParams iterates through the declared expected values to + -- create a group for each actual value per expectation, calling + -- the user-supplied mkLeaf at the leaf of each path. + mkParams sweet exp [] = map (uncurry $ mkLeaf sweet) $ zip [1..] exp + mkParams sweet exp ((name,vspec):ps) = + case vspec of + Nothing -> [mkGroup name $ mkParams sweet exp ps] + Just vs -> let f v = mkGroup v $ mkParams sweet (subExp v) ps + subExp v = expMatching name v exp + in f <$> L.sort vs + + expMatching :: String -> String -> [Expectation] -> [Expectation] + expMatching p v exp = + filter (\e -> maybe False (paramMatchVal v) (lookup p (expParamsMatch e))) exp + + in map mkSweetTests $ L.sortBy (compare `on` rootMatchName) sweets diff --git a/src/internal/Test/Tasty/Sugar/Analysis.hs b/src/internal/Test/Tasty/Sugar/Analysis.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Analysis.hs @@ -0,0 +1,54 @@ +-- | Main internal entry point for determining the various test +-- configurations specified by a CUBE input. + +module Test.Tasty.Sugar.Analysis + ( + checkRoots + ) +where + +import Control.Monad.Logic +import Data.Bifunctor ( bimap ) +import Data.Maybe ( catMaybes ) +import qualified System.FilePath as FP +import qualified System.FilePath.GlobPattern as FPGP + +import Test.Tasty.Sugar.ExpectCheck +import Test.Tasty.Sugar.RootCheck +import Test.Tasty.Sugar.Types + + +-- | Given a 'CUBE' and a list of files in the target directory, +-- return all 'Sweets' matches along with an explanation of the search +-- process. This is the core implementation for the +-- 'Test.Tasty.Sugar.findSugar' API interface. +checkRoots :: CUBE -> [FilePath] + -> (Int, [([Sweets], [SweetExplanation])]) +checkRoots pat allFiles = + let isRootMatch n = n FPGP.~~ (rootName pat) + rootNames = FP.takeFileName <$> (filter isRootMatch allFiles) + in (length rootNames, fmap (checkRoot pat allFiles) rootNames) + + +-- checkRoot will attempt to split the identified root file into three +-- parts: +-- +-- basename + [param-values] + [suffix/extension] +-- +-- Once it has performed this split, the calls findExpectation to +-- check if there are any expected file that matches the basename, +-- expSuffix, and any param-values provided. A 'Sweets' will be +-- returned for each expected file matching this root configuration +checkRoot :: CUBE + -> [FilePath] -- all possible expect candidates + -> FilePath -- root name + -> ([Sweets], [SweetExplanation]) +checkRoot pat allNames rootNm = + let seps = separators pat + params = validParams pat + combineExpRes (swts, expl) = bimap (swts :) (expl :) + in foldr combineExpRes ([], []) $ + catMaybes $ + fmap (findExpectation pat rootNm allNames) $ + observeAll $ + rootMatch rootNm seps params (rootName pat) diff --git a/src/internal/Test/Tasty/Sugar/AssocCheck.hs b/src/internal/Test/Tasty/Sugar/AssocCheck.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/AssocCheck.hs @@ -0,0 +1,86 @@ +-- | Function and implementation to find association files for an +-- identified test root file. + +{-# LANGUAGE LambdaCase #-} + +module Test.Tasty.Sugar.AssocCheck + ( + getAssoc + ) + where + +import Control.Monad.Logic +import qualified Data.List as L +import Data.Maybe ( catMaybes ) + +import Test.Tasty.Sugar.ParamCheck +import Test.Tasty.Sugar.Types + + +-- | For a specific NamedParamMatch, find all associated files having +-- the rootMatch plus the named parameter values (in the same order +-- but with any combination of separators) and the specified suffix +-- match. +getAssoc :: FilePath + -> Separators + -> [NamedParamMatch] + -> [ (String, FileSuffix) ] + -> [FilePath] + -> Logic [(String, FilePath)] +getAssoc rootPrefix seps pmatch assocNames allNames = assocSet + where + assocSet = catMaybes <$> mapM fndAnAssoc assocNames + + fndAnAssoc assoc = ifte (fndAssoc assoc) + (return . Just) + (return Nothing) + + fndAssoc assoc = + do pseq <- npseq pmatch + (assocPfx, assocSfx) <- sepParams seps (fmap snd pseq) + if null assocSfx + then do let assocNm = if null (snd assoc) && + length assocPfx == 1 -- just a separator + then rootPrefix + else rootPrefix <> assocPfx <> (snd assoc) + guard (assocNm `elem` allNames) + return (fst assoc, assocNm) + else let assocStart = rootPrefix <> assocPfx + assocEnd = assocSfx <> snd assoc + aSL = length assocStart + aEL = length assocEnd + possible f = + and [ assocStart `L.isPrefixOf` f + , assocEnd `L.isSuffixOf` f + , length f > (aSL + aEL) + , let mid = drop aSL (take (length f - aEL) f) + in and $ fmap (not . flip elem mid) seps + ] + fnd = filter possible allNames + in do f <- eachFrom fnd + return (fst assoc, f) + + sepParams :: Separators -> [ParamMatch] -> Logic (String, String) + sepParams sl = \case + [] -> if null sl + then return ([], []) + else do s <- eachFrom sl + return ([s], []) + (NotSpecified:ps) -> do r <- sepParams sl ps + return ([], fst r) + ((Explicit v):ps) -> do (l,r) <- sepParams sl ps + if null sl + then return (v <> l, r) + else do s <- eachFrom sl + return ([s] <> v <> l, r) + ((Assumed v):ps) -> do (l,r) <- sepParams sl ps + if null sl + then return (v <> l, r) + else do s <- eachFrom sl + return ([s] <> v <> l, r) + + npseq = eachFrom + . ([]:) -- consider no parameters just once + . filter (not . null) -- excluding multiple blanks in + . concatMap L.inits -- any number of the + . L.permutations -- parameters in each possible order diff --git a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs @@ -0,0 +1,160 @@ +-- | Function to find expected results files for a specific root file, +-- along with any parameter values identified by the root file. + +module Test.Tasty.Sugar.ExpectCheck + ( + findExpectation + ) + where + +import Control.Monad.Logic +import System.FilePath ( () ) +import qualified Data.List as L + +import Test.Tasty.Sugar.AssocCheck +import Test.Tasty.Sugar.ParamCheck +import Test.Tasty.Sugar.Types + + + +-- | Finds the possible expected files matching the selected +-- source. There will be either one or none. +findExpectation :: CUBE + -> FilePath -- original name of source + -> [FilePath] -- all of the names to choose from + -> ([NamedParamMatch], FilePath, FilePath) -- param constraints from the root name + -> Maybe ( Sweets, SweetExplanation ) +findExpectation pat rootN allNames (rootPMatches, matchPrefix, _) = + let r = mkSweet <$> + trimExpectations $ + observeAll $ + expectedSearch d matchPrefix rootPMatches seps params expSuffix o + candidates + d = inputDir pat + o = associatedNames pat + seps = separators pat + params = validParams pat + expSuffix = expectedSuffix pat + candidates = filter possible allNames + possible f = and [ matchPrefix `L.isPrefixOf` f + , rootN /= f + ] + mkSweet e = Just $ Sweets { rootMatchName = rootN + , rootBaseName = matchPrefix + , rootFile = inputDir pat rootN + , cubeParams = validParams pat + , expected = e + } + + -- The expectedSearch tries various combinations and ordering of + -- parameter values, separators, and such to find all valid + -- expected file matches. However, the result is an + -- over-sampling, so this function trims the excess and unwanted + -- expectations. + trimExpectations :: [Expectation] -> [Expectation] + trimExpectations = + + -- If a parameter is Explicitly matched, discard any + -- Expectation with Assumed matches. + (\l -> let removeNonExplicits lst entry = + let explParams = filter (isExplicit . snd) + (expParamsMatch entry) + removeNonExpl es explParam = + filter (noNonExplicit explParam) es + noNonExplicit (pn, Explicit pv) expl= + let chkPV (pn', pv') = + pn /= pn' || case pv' of + Explicit _ -> True + Assumed v -> v /= pv + NotSpecified -> False + in all chkPV $ expParamsMatch expl + noNonExplicit _ _ = True + in foldl removeNonExpl lst explParams + in foldl removeNonExplicits l l) + + -- remove duplicates (uses the Eq instance for Expectation + -- that ignores the order of the expParamsMatch and associated + -- to ensure that different ordering with the same values + -- doesn't cause multiple Expectation. + . L.nub + + in case r of + Nothing -> Nothing + Just r' | [] <- expected r' -> Nothing + Just r' -> Just ( r' + , SweetExpl { rootPath = rootN + , base = matchPrefix + , expectedNames = + filter + (if null expSuffix then const True + else (expSuffix `L.isSuffixOf`)) + candidates + , results = [ r' ] + }) + +-- Find all Expectations matching this rootMatch +expectedSearch :: FilePath + -> FilePath + -> [NamedParamMatch] + -> Separators + -> [ParameterPattern] + -> FileSuffix + -> [ (String, FileSuffix) ] + -> [FilePath] + -> Logic Expectation +expectedSearch inpDir rootPrefix rootPVMatches seps params expSuffix assocNames allNames = + do (expFile, pmatch) <- + let bestRanked :: [(FilePath, Int, [NamedParamMatch])] + -> Logic (FilePath, [NamedParamMatch]) + bestRanked l = + if null l then mzero + else let m = maximum $ fmap rankValue l + rankValue (_,r,_) = r + rankMatching v (_,r,_) = v == r + dropRank (a,_,b) = (a,b) + in eachFrom $ fmap dropRank $ filter (rankMatching m) l + + in bestRanked $ + observeAll $ + do pseq <- eachFrom $ + ([] :) $ + filter (not . null) $ + concatMap L.inits $ + L.permutations params + pvals <- getPVals pseq + getExp rootPrefix rootPVMatches seps pvals expSuffix allNames + assocFiles <- getAssoc rootPrefix seps pmatch assocNames allNames + return $ Expectation { expectedFile = inpDir expFile + , associated = fmap (inpDir ) <$> assocFiles + , expParamsMatch = pmatch + } + +-- Get all expected files for a particular sequence of param+value. +-- Returns the expected file, the sequence of parameter values that +-- match that expect file, and a ranking (the number of those paramter +-- values that actually appear in the expect file. +getExp :: FilePath + -> [NamedParamMatch] + -> Separators + -> [(String, Maybe String)] + -> FileSuffix + -> [FilePath] + -> Logic (FilePath, Int, [NamedParamMatch]) +getExp rootPrefix rootPMatches seps pvals expSuffix allNames = + do (pm, pmcnt, pmstr) <- pvalMatch seps rootPMatches pvals + -- If the expSuffix starts with a separator then *only that* + -- separator is allowed for the suffix (other seps are still + -- allowed for parameter value separation). + let suffixSpecifiesSep = and [ not (null expSuffix) + , head expSuffix `elem` seps + ] + let suffixSepMatch = not suffixSpecifiesSep + || and [ not (null pmstr) + , last pmstr == head expSuffix + ] + guard suffixSepMatch + let expFile = if suffixSpecifiesSep + then rootPrefix <> pmstr <> tail expSuffix + else rootPrefix <> pmstr <> expSuffix + guard (expFile `elem` allNames) + return (expFile, pmcnt, pm) diff --git a/src/internal/Test/Tasty/Sugar/ParamCheck.hs b/src/internal/Test/Tasty/Sugar/ParamCheck.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/ParamCheck.hs @@ -0,0 +1,100 @@ +-- | Functions for checking different parameter/value combinations. + +module Test.Tasty.Sugar.ParamCheck + ( + eachFrom + , getPVals + , pvalMatch + ) + where + +import Control.Monad.Logic +import qualified Data.List as L +import Data.Maybe ( fromMaybe ) + +import Test.Tasty.Sugar.Types + + +-- | Core Logic function to iteratively return elements of a list via +-- backtracking. +eachFrom :: [a] -> Logic a +eachFrom = foldr (mplus . return) mzero + + +-- | Returns various combinations of parameter value selections +getPVals :: [ParameterPattern] -> Logic [(String, Maybe String)] +getPVals = mapM getPVal + where + getPVal (pn, Nothing) = return (pn, Nothing) + getPVal (pn, Just pv) = do pv' <- eachFrom pv + return (pn, Just pv') + +-- | Generate each possible combination of Explicit or non-Explicit +-- (Assumed or NotSpecified) parameter value and the corresponding +-- string with each combination of separators. The string will be +-- used to match against input files. +-- +-- Note that valid combinations require that if a parameter is +-- non-Explicit, all following parameters must also be non-Explicit. +-- +-- The preset set of parameters are any parameters *already* matched +-- against (usually in the rootName); these parameters may or may not +-- be present in the filename matched from the output of this +-- function, but if they are present, they must have the values +-- specified in the preset (instead of having any of the possible +-- values allowed for that parameter). +-- +-- It's also possible that since this returns varying combinations of +-- parameters, that there may be multiple files that will match +-- against these combinations. Therefore, the results also indicate +-- how many of the parameters are used in the associated matching +-- string since the caller will usually select the match with the +-- highest ranking (number of matched parameters) in the filename. +-- [Note that it is not possibly to simply use the length of the +-- @[NamedParamMatch]@ return component since that may contain values +-- from the preset that don't actually occur in the match string. +pvalMatch :: Separators + -> [NamedParamMatch] + -> [(String, Maybe String)] + -> Logic ([NamedParamMatch], Int, String) +pvalMatch seps preset pvals = + let (ppv, rpv) = L.partition isPreset pvals + isPreset p = fst p `elem` (fmap fst preset) + + matchesPreset = all matchPreset ppv + matchPreset (pn,mpv) = maybe False (matchPresetVal mpv) $ + lookup pn preset + matchPresetVal mpv pv = case mpv of + Just v -> paramMatchVal v pv + Nothing -> True + + pvVal :: [(String, Maybe String)] -> Logic [NamedParamMatch] + pvVal [] = return [] + pvVal ((pn, mpv):ps) = + let explicit v = do nxt <- pvVal ps + return $ (pn, Explicit v) : nxt + notExplicit = let pMatchImpl = maybe NotSpecified Assumed + remPVMS = fmap (fmap pMatchImpl) ps + in return $ (pn, pMatchImpl mpv) : remPVMS + in (maybe mzero explicit mpv) `mplus` notExplicit + + genPVStr :: [NamedParamMatch] -> Logic String + genPVStr pvs = + let vstr = fromMaybe "" . getExplicit . snd + sepJoin :: String -> NamedParamMatch -> Logic String + sepJoin r v = if isExplicit (snd v) + then do s <- eachFrom seps + return $ [s] <> vstr v <> r + else return r + in if null seps + then return $ foldr (\v r -> vstr v <> r) "" pvs + else do s <- eachFrom seps + foldM sepJoin [s] pvs + + in do guard matchesPreset + candidateVals <- pvVal rpv + let rset = preset <> candidateVals + orderedRset = fmap from_rset $ fmap fst pvals + from_rset n = let Just v = L.lookup n rset in (n,v) + pvstr <- genPVStr orderedRset + return (rset, length orderedRset, pvstr) diff --git a/src/internal/Test/Tasty/Sugar/RootCheck.hs b/src/internal/Test/Tasty/Sugar/RootCheck.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/RootCheck.hs @@ -0,0 +1,249 @@ +-- | Function and associated helpers to determine the matching root +-- name. The root name may contain zero or more parameter values. + +{-# LANGUAGE LambdaCase #-} + +module Test.Tasty.Sugar.RootCheck + ( + rootMatch + ) + where + +import Control.Monad.Logic +import qualified Data.List as L +import Data.Maybe ( catMaybes, isNothing ) + +import Test.Tasty.Sugar.ParamCheck +import Test.Tasty.Sugar.Types + + +-- | Determine which parts of the input name form the basePrefix and any +-- parameter values for searching for related files (expected and +-- associated) +rootMatch :: FilePath -> Separators -> [ParameterPattern] -> String + -> Logic ([NamedParamMatch], FilePath, FilePath) +rootMatch origRootName seps params rootCmp = + ifte + (rootParamMatch origRootName seps params rootCmp) + return + (noRootParamMatch origRootName seps) + + +data RootPart = RootSep String + | RootParNm String String + | RootText String + | RootSuffix String + deriving Show + +isRootParNm :: RootPart -> Bool +isRootParNm (RootParNm _ _) = True +isRootParNm _ = False + +isRootSep :: RootPart -> Bool +isRootSep (RootSep _) = True +isRootSep _ = False + +isRootSuffix :: RootPart -> Bool +isRootSuffix (RootSuffix _) = True +isRootSuffix _ = False + +rpStr :: [RootPart] -> String +rpStr = let s = \case + RootSep x -> x + RootParNm _ x -> x + RootText x -> x + RootSuffix x -> x + bld a b = a <> s b + in foldl bld "" + +rpNPM :: [RootPart] -> [NamedParamMatch] +rpNPM = let bld (RootParNm n v) = Just [(n, Explicit v)] + bld (RootSep _) = Nothing + bld p = error ("Invalid RootPart for NamedParamMatch: " + <> show p) + in concat . catMaybes . fmap bld + + +-- Return the prefix and suffix of the root name along with the +-- explicit parameter matches that comprise the central portion. +rootParamMatch :: FilePath -> Separators -> [ParameterPattern] -> String + -> Logic ([NamedParamMatch], FilePath, FilePath) +rootParamMatch origRootName seps params rootCmp = + if null seps + then rootParamMatchNoSeps origRootName seps params + else rootParamMatches origRootName seps params rootCmp + +rootParamMatches :: FilePath -> Separators -> [ParameterPattern] -> String + -> Logic ([NamedParamMatch], FilePath, FilePath) +rootParamMatches rootNm seps parms rMatch = do + let rnSplit = sepSplit rootNm + sepSplit = L.groupBy sepPoint + sepPoint a b = not $ or [a `elem` seps, b `elem` seps ] + rnPartIndices = [ n | n <- [0 .. length rnParts - 1] , even n ] + freeValueParm = L.find (isNothing . snd) parms + + txtRootSfx = sepSplit $ reverse $ + -- Find the concrete extension in the + -- rootName. Somewhat crude, but basically stops at + -- any charcter that could be part of a filemanip + -- GlobPattern. + takeWhile (not . flip elem "[*]\\(|)") $ reverse rMatch + + -- if a part of the rootNm matches a known parameter value, + -- that is the only way that part can be interpreted, and + -- that anchors it. + + rnParts :: [RootPart] + rnParts = + let assignPart (ptxt,pidx) = + let matchesParmValue (_, Nothing) = False + matchesParmValue (_, Just vl) = ptxt `elem` vl + in if pidx `elem` rnPartIndices + then + if length rnSplit - pidx < length txtRootSfx + then RootSuffix ptxt + else case L.find matchesParmValue parms of + Just (pn,_) -> RootParNm pn ptxt + Nothing -> RootText ptxt + else RootSep ptxt + + in fmap assignPart $ zip rnSplit [0..] + + -- want [prefix, sep, MATCHES, [suffix]] + guard (length rnSplit > 2 + length txtRootSfx) + + guard (not $ isRootParNm $ head rnParts) -- must have a prefix + + let rnChunks = + -- pfx parms1 mid parms2 sfx + -- r1------------------- + -- r2------------ + -- r3-------- + let (pfx,r1) = L.span (not . isRootParNm) rnParts + (parms1,r2) = L.span paramPart r1 + (mid,r3) = L.span (not . isRootParNm) r2 + (parms2,sfx) = L.span paramPart r3 + (_,extraprm) = L.span (not . isRootParNm) sfx + paramPart x = isRootParNm x || isRootSep x + in if null r3 + then Just $ Left (pfx, parms1, mid) + else if null extraprm + then Just $ Right (pfx, parms1, mid, parms2, sfx) + else Nothing + + freeFirst Nothing = mzero + freeFirst (Just (Right _)) = mzero + freeFirst (Just (Left (allRP, [], []))) = + -- There were no parameter value matches. If there is + -- a wildcard parameter, try it in all the possible + -- positions. + if length allRP < 3 + then mzero + else case freeValueParm of + Nothing -> mzero + Just p -> + do idx <- eachFrom [i | i <- [2..length allRP], even i] + let free = RootParNm (fst p) idxv + RootText idxv = head $ drop idx allRP + start = take (idx - 1) allRP + guard (not $ isRootSuffix $ head $ drop idx allRP) + return ( rpNPM [free] + , rpStr $ start + , rpStr $ drop (idx + 2) allRP ) + freeFirst (Just (Left (pfx, pl1, sfx))) = + if length pfx < 3 + then mzero + else case freeValueParm of + Nothing -> + -- No wildcard param, so just try the observed + -- pattern + return ( rpNPM pl1, rpStr pfx, rpStr sfx ) + Just p -> + -- There is a wildcard parameter, try it at the end + -- of pfx and before pl1 + let free = RootParNm (fst p) lpv + RootText lpv = last start + start = init pfx + in do guard (not . isRootSuffix $ last start) + return ( rpNPM $ free : pl1 + , rpStr $ reverse $ drop 3 $ reverse pfx + , rpStr sfx ) + + freeLast Nothing = mzero + freeLast (Just (Right _)) = mzero + freeLast (Just (Left (_, [], []))) = mzero -- handled by freeFirst + freeLast (Just (Left (pfx, parms1, sfx))) = + if null sfx + then mzero + else case freeValueParm of + Nothing -> mzero -- handled by freeFirst + Just p -> + -- There is a wildcard parameter, try it at the end + -- of pfx and before pl1 + let free = [RootParNm (fst p) fsv] + RootText fsv = head sfx + in do guard (not $ isRootSuffix $ head sfx) + return ( rpNPM $ parms1 <> free + , rpStr pfx + , rpStr $ tail sfx ) + + freeMid Nothing = mzero + freeMid (Just (Left _)) = mzero + freeMid (Just (Right (pfx, parms1, mid, parms2, sfx))) = + -- If there is a wildcard param and mid is a single + -- element, then try converting the mid to the + -- wildcard, otherwise this is an invalid name. + if length mid /= 3 + then mzero + else case freeValueParm of + Nothing -> mzero + Just p -> + let free = [RootParNm (fst p) mv] + (ms1:RootText mv:ms2:[]) = mid + in return ( rpNPM $ parms1 <> free <> parms2 + , rpStr $ pfx <> [ms1] + , rpStr $ ms2 : sfx ) + + (freeFirst rnChunks) + `mplus` (freeLast rnChunks) + `mplus` (freeMid rnChunks) + + +-- If no separators, there are no "rnParts" identifiable, so fall +-- back on a cruder algorithm that simply attempts to find a +-- sequence of paramvals in the middle of the string and extract +-- the prefix and suffix (if any) around those paramvals. +rootParamMatchNoSeps :: FilePath -> Separators -> [ParameterPattern] + -> Logic ([NamedParamMatch], FilePath, FilePath) +rootParamMatchNoSeps rootNm seps' parms = do + pseq <- eachFrom $ filter (not . null) $ L.permutations parms + pvals <- getPVals pseq + (pvset, _pvcnt, pvstr) <- pvalMatch seps' [] pvals + -- _pvcnt can be ignored because each is a different root + let explicit = filter (isExplicit . snd) pvset + guard (and [ not $ null explicit + , pvstr `L.isInfixOf` rootNm + , not $ pvstr `L.isPrefixOf` rootNm + ]) + let (basename, suffix) = + let l1 = length rootNm + l2 = length pvstr + bslen = l1 - l2 + matches n = pvstr `L.isPrefixOf` (drop n rootNm) + Just pfxlen = L.find matches $ reverse [1..bslen] + in (take pfxlen rootNm, drop (pfxlen + l2) rootNm) + return (explicit, basename, suffix) + +-- Return origRootName up to each sep-indicated point. +noRootParamMatch :: FilePath -> Separators + -> Logic ([NamedParamMatch], FilePath, FilePath) +noRootParamMatch origRootName seps = + return ([], origRootName, "") `mplus` + do s <- eachFrom seps + i <- eachFrom [1..length origRootName - 1] + let a = take i origRootName + let b = drop i origRootName + if null b + then do return ([], a, "") + else do guard (and [ not $ null b, head b == s ]) + return ([], a, tail b) diff --git a/src/internal/Test/Tasty/Sugar/Types.hs b/src/internal/Test/Tasty/Sugar/Types.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Types.hs @@ -0,0 +1,384 @@ +-- | Specifies the base tasty-sweet types and common class instance +-- definitions for those types. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Test.Tasty.Sugar.Types where + +import Data.Function ( on ) +import qualified Data.List as L +import Data.Maybe ( catMaybes ) +import qualified System.FilePath.GlobPattern as FPGP +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +#else +import Data.Text.Prettyprint.Doc +#endif + +import Prelude hiding ( exp ) + + +-- | This is the type used to specify file suffixes. The synonym name +-- is primarily used to indicate where this suffix specification is +-- used. +type FileSuffix = String + + +-- | Specifies the parameters and patterns to use when searching for +-- samples to build tests from. The 'mkCUBE' function should be used +-- to obtain a 'CUBE' structure initialized with overrideable +-- defaults. +-- +-- The primary elements to specify are the 'rootName' and the +-- 'expectedSuffix'. With these two specifications (and possibly the +-- 'inputDir') the 'Test.Tasty.Sugar' functionality will be similar to +-- a "golden" testing package. +-- +-- The 'validParams' is an optional feature that is useful when +-- multiple expected results files are generated from a single +-- 'rootName', differing by the specified parameters. +-- +-- The 'associatedNames' is an optional feature that is useful for +-- when there are other files to be associated with a test in addition +-- to the 'rootFile' and the 'expectedFile'. +-- +data CUBE = CUBE + { + -- | The directory in which the sample files that drive the + -- testing exist. When specified as a relative filepath + -- (suggested) then this directory is relative to the cabal file. + inputDir :: FilePath + + -- | The name of the "root" file for each test scenario. The + -- contents of this file are opaque to 'tasty-sweet' and are + -- interpreted by the tests themselves. Each "root" file is + -- the kernel for a set of test cases. + -- + -- The root file should not be specified with any path element, + -- it should exist in the 'inputDir' location and it can be + -- specified as a glob pattern. + -- + -- The corresponding expected results files will be identified by + -- finding files which match a portion of this name with a + -- "{separator}{expectedSuffix}" appended to it. + , rootName :: FPGP.GlobPattern + + -- | The expected suffix for a target pattern for running a test. + -- There may be multiple files specifying expected results for a + -- test (see the 'validParams' below), but a particular test case + -- is comprised of a source file along with a corresponding + -- "expected result" file that is the name of the source file + -- with the 'expectedSuffix' suffix. The suffix should not contain + -- any glob match characters. Note that the suffix is the text + -- that comes after one of the 'separators' below. + -- + -- The 'expectedSuffix' *may* start with one of the characters in + -- 'separators'. If this occurs, then the suffix will only be + -- considered if preceeded by that specific separator; otherwise + -- any of the 'separators' may be used prior to the + -- 'expectedSuffix'. + , expectedSuffix :: FileSuffix + + -- | The 'separators' specify the characters which separate the + -- expected suffix from the rootName, and which also separate + -- the various parameters (if any, see 'validParams' below). Any + -- one of the separators in this list can be used, and a file can + -- used a mixture of the separators in the filename. + -- + -- It is also valid to specify no separators, in which case the + -- 'rootName' and 'expectedSuffix' are directly concatenated. This + -- is not a typical usage, however. + -- + -- The default separators (returned by 'mkCUBE') are ".-" meaning + -- that extensions (and parameters) can be separated from the + -- base name by either a period or a dash. + , separators :: Separators + + -- | The 'associatedNames' specifies other files that are + -- associated with a particular test configuration. These files + -- are optional and not all of them appear, but different + -- suffixes may be associated here with a general name. When a + -- test is being generated, any associatedNames that were found + -- will be passed to the test generator for use as supplemental + -- data. + -- + -- Specified as a list of tuples, where each tuple is the + -- (arbitrary) name of the associated file type, and the file + -- type suffix (with no period or other separator). + , associatedNames :: [ (String, FileSuffix) ] + + -- | The 'validParams' can be used to specify various parameters + -- that may be present in the filename. + -- + -- For example, tests might be parameterized by which C compiler + -- (@"gcc"@ or @"clang"@) was used, which target architecture + -- (@"x86_64"@ or @"ppc"@ or @"arm"@), and which optimization + -- level. The values for these parameters appear in any order in + -- the filenames of any file (other than the 'rootName') + -- delineated by any of the separators. Not all parameter values + -- are required to appear. + -- + -- The following are valid examples: + -- + -- > foo-gcc-ppc-O3.o + -- > foo-clang.x86_64.o + -- > foo.O0-clang.o + -- + -- The sugar matching code will attempt to identify the various + -- parameter values appearing in the _expected_ filename and + -- provide that information to the test generation process to + -- allow the generated test to be customized to the available set + -- of parameters. + -- + -- The 'associatedNames' provided to the test generator will be + -- constrained to those associated names that match the parameter + -- values explicit in the expected name, and called for each + -- combination of unspecified parameter values present in + -- associated names. + -- + -- There may actually be multiple sets of parameterized files for + -- each 'rootName' file: the test generator will be called for + -- each set of parameters. + -- + -- Each entry in the 'validParams' specifies the name of the + -- parameter and the set of values; one (and only one) parameter + -- may have existential values rather than pre-determined values, + -- as indicated by a Nothing for the parameter value set. Valid + -- parameter values are *not* matched with file globbing (they + -- must be explicit and precise matches) and they cannot be blank + -- (the lack of a parameter is handled automatically rather than + -- an explicit blank value). + , validParams :: [ParameterPattern] + } + deriving (Show, Read) + + +-- | Parameters are specified by their name and a possible list of +-- valid values. If there is no list of valid values, any value is +-- accepted for that parameter position. Parameters are listed in the +-- order that they should appear in the filenames to be matched. + +type ParameterPattern = (String, Maybe [String]) + +-- | Separators for the path and suffix specifications. Any separator +-- is accepted in any position between parameters and prior to the +-- expected suffix. The synonym name is primarily used to indicate +-- where this separators specification is intended to be used. + +type Separators = String + +-- | Generates the default 'CUBE' configuration; callers should override +-- individual fields as appropriate. + +mkCUBE :: CUBE +mkCUBE = CUBE { inputDir = "test/samples" + , separators = ".-" + , rootName = "*" + , associatedNames = [] + , expectedSuffix = "exp" + , validParams = [] + } + + +instance Pretty CUBE where + pretty cube = + let assoc = prettyAssocNames $ associatedNames cube + parms = prettyParamPatterns $ validParams cube + hdrs = [ "input dir: " <+> pretty (inputDir cube) + , "rootName: " <+> pretty (rootName cube) + , "expected: " <+> + brackets (pretty $ separators cube) <> + pretty (expectedSuffix cube) + ] + in "Sugar.CUBE" <> (indent 1 $ vsep $ hdrs <> [assoc, parms]) + + +-- | Pretty printing for a set of associated names +prettyAssocNames :: [(String, String)] -> Doc ann +prettyAssocNames = \case + [] -> mempty + nms -> "associated:" <> (indent 1 $ vsep $ map (pretty . fmap show) nms) + +-- | Pretty printing for a list of parameter patterns +prettyParamPatterns :: [ParameterPattern] -> Doc ann +prettyParamPatterns = \case + [] -> mempty + prms -> "params:" <> + (let pp (pn,mpv) = + pretty pn <+> equals <+> + case mpv of + Nothing -> "*" + Just vl -> hsep $ + L.intersperse pipe $ + map pretty vl + in indent 1 $ vsep $ map pp prms) + +-- | Each identified test input set is represented as a 'Sweets' +-- object.. a Specifications With Existing Expected Testing Samples. + +data Sweets = Sweets + { rootBaseName :: String -- ^ base of root for matching to expected + , rootMatchName :: String -- ^ full name of matched root + , rootFile :: FilePath -- ^ full filepath of matched root + , cubeParams :: [ParameterPattern] -- ^ parameters for match + , expected :: [Expectation] -- ^ all expected files and associated + } + deriving (Show, Eq) + +instance Pretty Sweets where + pretty inp = "Sweet" <+> + (align $ vsep + [ pretty (rootMatchName inp) + , "root:" <+> + align (vsep [ pretty (rootBaseName inp) + , pretty (rootFile inp) + ]) + , prettyParamPatterns $ cubeParams inp + , vsep $ map pretty $ expected inp + ]) + +-- | The 'Association' specifies the name of the associated file entry +-- and the actual filepath of that associated file. + +type Association = (String, FilePath) + +-- | The 'NamedParamMatch' specifies the parameter name and the +-- corresponding value for the expected file found. These can be +-- extracted from the name of the expected file and the set of +-- 'ParameterPattern' entries, but they are presented in an associated +-- list format for easy utilization by the invoked test target. + +type NamedParamMatch = (String, ParamMatch) + +-- | The 'Expectation' represents a valid test configuration based on +-- the set of provided files. The 'Expectation' consists of an +-- expected file which matches the 'rootFile' in the containing +-- 'Sweets' data object. The 'expectedFile' field is the name of the +-- file containing expected output, the 'expParamsMatch' field +-- specifies the 'ParameterPattern' matching values for this expected +-- file, and the 'associated' field provides a list of files +-- associated with this expected file. + +data Expectation = Expectation + { expectedFile :: FilePath -- ^ file containing Expected results + , expParamsMatch :: [ NamedParamMatch ] -- ^ set of CUBE parameters + -- matched and the matched + -- values. + , associated :: [ Association ] -- ^ Associated files found + } + deriving Show + +instance Eq Expectation where + e1 == e2 = let bagCmp a b = any (a ==) $ L.permutations b + in and [ expectedFile e1 == expectedFile e2 + , (bagCmp `on` expParamsMatch) e1 e2 + , (bagCmp `on` associated) e1 e2 + ] + +instance Pretty Expectation where + pretty exp = + let p = expParamsMatch exp + pp = if null p + then Nothing + else Just $ "Matched Params:" <+> (align $ vsep $ map ppp p) + ppp (n,v) = pretty n <+> equals <+> pretty v + a = associated exp + pa = if null a + then Nothing + else Just $ "Associated:" <+> (align $ vsep $ map pretty a) + in align $ vsep $ catMaybes + [ Just $ "Expected: " <+> (align $ pretty (expectedFile exp)) + , pp + , pa + ] + +-- | Indicates the matching parameter value for this identified +-- expected test. If the parameter value is explicitly specified in +-- the expected filename, it is an 'Explicit' entry, otherwise it is +-- 'Assumed' (for each of the valid 'ParameterPattern' values) or +-- NotSpecified if there are no known 'ParameterPattern' values. + +data ParamMatch = + -- | This parameter value was explicitly specified in the filename + -- of the expected file. + Explicit String + + -- | This parameter value was not specified in the filename of the + -- expected file, so the value is being synthetically supplied. + -- This is used for parameters that have known values but none is + -- present: an 'Expectation' is created for each possible parameter + -- value, identifying each as 'Assumed'. + | Assumed String + + -- | This parameter value was not specified in the filename for the + -- expected file. In addition, the associated 'ParameterPattern' + -- specified no defined values (i.e. 'Nothing'), so it is not + -- possible to identify any actual values. Instead, the + -- 'Expectation' generated for this expected file will supply this + -- 'NotSpecified' for this type of parameter. + | NotSpecified + + deriving (Show, Eq) + +instance Pretty ParamMatch where + pretty (Explicit s) = pretty s + pretty (Assumed s) = brackets $ pretty s + pretty NotSpecified = "*" + + +-- | The 'paramMatchVal' function is used to determine if a specific +-- value matches the corresponding 'ParamMatch' +paramMatchVal :: String -> ParamMatch -> Bool +paramMatchVal v (Explicit s) = s == v +paramMatchVal v (Assumed s) = s == v +paramMatchVal _ NotSpecified = True + + +-- | Predicate test returning true for Explicit param values. +isExplicit :: ParamMatch -> Bool +isExplicit = \case + Explicit _ -> True + _ -> False + + +-- | Extracts explicit value or Nothing +getExplicit :: ParamMatch -> Maybe String +getExplicit (Explicit v) = Just v +getExplicit _ = Nothing + + +---------------------------------------------------------------------- + +-- | The 'SweetExplanation' is the data type that contains the +-- description of the 'Test.Tasty.Sugar.findSugar' process and +-- results. +data SweetExplanation = + SweetExpl { rootPath :: FilePath + , base :: String + , expectedNames :: [String] -- ^ candidates + , results :: [Sweets] -- ^ actual results + } + +instance Pretty SweetExplanation where + pretty expl = + let nms = expectedNames expl + in align $ vsep $ catMaybes [ + Just $ fillSep $ punctuate "," + [ "rootPath" <+> dquotes (pretty $ rootPath expl) + , "base" <+> dquotes (pretty $ base expl) + , if null nms + then "no matches" + else (pretty $ length nms) <+> "possible matches" + ] + , if null nms + then Nothing + else Just $ indent 8 $ vsep $ map pretty nms + , if null (results expl) + then Nothing + else Just $ indent 2 $ hang 2 $ vsep $ + "Results:" : map pretty (results expl) + ] + +------------------------------------------------------------------------ diff --git a/tasty-sugar.cabal b/tasty-sugar.cabal new file mode 100644 --- /dev/null +++ b/tasty-sugar.cabal @@ -0,0 +1,142 @@ +cabal-version: 2.0 + +name: tasty-sugar +version: 0.2.0.0 +synopsis: Tests defined by Search Using Golden Answer References +description: + . + A tasty testing framework that builds individual test configurations + from a set of input files and expected results (golden) files along + with associated files, where multiple expected results and + associated files for each input file can be parameterized by + filename. + . + Additionally a tasty ingredient is supplied that can be used to show + the search process and resulting test configurations without + actually running the tests. + +homepage: https://github.com/kquick/tasty-sugar +-- bug-reports: +license: ISC +license-file: LICENSE +author: Kevin Quick +maintainer: kquick@galois.com +copyright: Kevin Quick, 2019-2021 +category: Testing +build-type: Simple + +extra-source-files: CHANGELOG.md + README.org + examples/example1/NiftyText.hs + examples/example1/README.org + examples/example1/test-passthru-ascii.hs + examples/example1/testdata/counting + examples/example1/testdata/counting.exp + examples/example1/testdata/hello_inp + examples/example1/testdata/hello_inp.exp + examples/params/test-params.hs + examples/params/samples/foo.c + examples/params/samples/functional.O2.expct + examples/params/samples/functional.hs + examples/params/samples/recursive.fast.expct + examples/params/samples/recursive.rs + examples/params/samples/simple-opt.expct + examples/params/samples/simple-opt.gcc-exe + examples/params/samples/simple.c + examples/params/samples/simple.expct + examples/params/samples/simple.noopt-gcc.expct + examples/params/samples/simple.noopt.clang.exe + examples/params/samples/simple.noopt.gcc.exe + examples/params/samples/simple.opt-clang.exe + +source-repository head + type: git + location: git://github.com/kquick/tasty-sugar.git + +library + exposed-modules: Test.Tasty.Sugar + build-depends: base >=4.10 && < 5 + , directory + , filepath + , filemanip + , logict + , optparse-applicative + , prettyprinter >= 1.7.0 + , tagged + , tasty + , tasty-sugar-internal + hs-source-dirs: src + default-language: Haskell2010 + GHC-options: -Wall -Wcompat -fhide-source-paths + -- other-modules: + -- other-extensions: + + +library tasty-sugar-internal + exposed-modules: Test.Tasty.Sugar.Analysis + , Test.Tasty.Sugar.AssocCheck + , Test.Tasty.Sugar.ExpectCheck + , Test.Tasty.Sugar.ParamCheck + , Test.Tasty.Sugar.RootCheck + , Test.Tasty.Sugar.Types + build-depends: base >= 4.10 + , filepath + , filemanip + , logict + , prettyprinter + hs-source-dirs: src/internal + default-language: Haskell2010 + GHC-options: -Wall -Wcompat -fhide-source-paths + + +test-suite test-sugar + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + GHC-options: -fhide-source-paths + main-is: TestMain.hs + other-modules: TestMultiAssoc + TestNoAssoc + TestSingleAssoc + TestParamsAssoc + TestUtils + TestWildcard + Sample1 + -- TestExpected + -- TestSamples + build-depends: base >= 4 + , filepath + , hedgehog + , logict + , pretty-show + , prettyprinter + , raw-strings-qq + , tasty + , tasty-hedgehog + , tasty-hunit + , tasty-sugar + + +test-suite test-passthru-ascii + type: exitcode-stdio-1.0 + hs-source-dirs: examples/example1 + default-language: Haskell2010 + GHC-options: -fhide-source-paths + main-is: test-passthru-ascii.hs + other-modules: NiftyText + build-depends: base + , tasty + , tasty-hunit + , tasty-sugar + +test-suite test-params + type: exitcode-stdio-1.0 + hs-source-dirs: examples/params + default-language: Haskell2010 + GHC-options: -fhide-source-paths + main-is: test-params.hs + build-depends: base + , pretty-show + , tasty + , tasty-hunit + , tasty-sugar diff --git a/test/Sample1.hs b/test/Sample1.hs new file mode 100644 --- /dev/null +++ b/test/Sample1.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Sample1 where + +import Text.RawString.QQ + +sample1 :: [String] +sample1 = lines [r| +global-max-good.c +global-max-good.ppc.o +global-max-good.ppc.exe +global-max-good.ppc.expected +global-max-good.x86.exe +global-max-good.x86.expected +jumpfar.c +jumpfar.h +jumpfar.ppc.exe +jumpfar.ppc.expected +jumpfar.x86.exe +jumpfar.x86.expected +looping.c +looping.ppc.exe +looping.ppc.expected +looping.x86.exe +looping.x86.expected +Makefile +README.org +switching +switching_stuff +switching.c +switching.h +switching.hh +switching_llvm.c +switching_llvm.h +switching_llvm.x86.exe +switching_many.c +switching_many_llvm.c +switching_many_llvm.x86.exe +switching_many.ppc.exe +switching.ppc.base-expected +switching.ppc.o +switching.ppc.other +switching.ppc.exe +switching.x86.base-expected +switching.x86.exe +switching-refined.x86.o +switching.x86.orig +switching.x86.refined-expected +switching.x86.refined-expected-orig +switching.x86.refined-last-actual +tailrecurse.c +tailrecurse.expected +tailrecurse.expected.expected +tailrecurse.food.expected +tailrecurse.ppc.exe +tailrecurse.x86.exe +tailrecurse.x86.expected +|] diff --git a/test/TestMain.hs b/test/TestMain.hs new file mode 100644 --- /dev/null +++ b/test/TestMain.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Exception ( SomeException, try ) +import Data.Bifunctor ( bimap ) +import qualified Hedgehog as HH +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.Hedgehog +import Test.Tasty.Sugar + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +#else +import Data.Text.Prettyprint.Doc +#endif + +import TestMultiAssoc +import TestNoAssoc +import TestSingleAssoc +import TestUtils +import TestParamsAssoc +import TestWildcard + + +main :: IO () +main = defaultMain $ + testGroup "tasty-sweet tests" + [ testProperty "empty file list" $ + HH.withTests 10000 $ HH.property $ do + cube <- HH.forAll $ genCube + HH.assert $ null $ fst $ findSugarIn cube [] + + , testGroup "invalid separators" $ + [ + testCase "duplicate separators" $ + (Left "Duplicate separator characters" @=?) =<< + runTestOrErr (CUBE "." "*.foo" "e" ".-." [] []) + + , testCase "many duplicate separators" $ + (Left "Duplicate separator characters" @=?) =<< + runTestOrErr (CUBE "." "*.foo" "e" ".---....---" [] []) + + ] + + , testGroup "invalid parameters" $ + let c1 = CUBE "." "*.foo" "e" "." [] [("a", Nothing) + ,("b", Nothing) + ] + msg1 = "Only one parameter can have unconstrained values (i.e. Nothing)" + c2 = CUBE "." "*.foo" "e" "." [] [("a", Just [])] + msg2 = "Blank validParams values are not allowed (a)" + c3 = CUBE "." "*.foo" "e" "." [] [("a", Just ["hi", ""]) + ,("b", Just ["one", "two"]) + ,("c", Just [""])] + msg3 = "Parameter values cannot be blank (a, c)" + + c4 = CUBE "." "*.foo" "e" "." [] [("a", Just ["hi", "two"]) + ,("b", Just ["one", "two"]) + ,("c", Just ["end"])] + msg4 = "Parameter values cannot be duplicated " <> + show [(("a","b"), "two")] + + c5 = CUBE "." "*.foo" "e" "." [] [("a", Just ["two", "two"]) + ,("b", Just ["one", "hi"]) + ,("c", Just ["one"])] + msg5 = "Parameter values cannot be duplicated " <> + show [ (("a","a"), "two") + , (("b", "c"), "one") + ] + + c6 = CUBE "." "*.foo" "e" ".-o" [] [("a", Just ["two", "t"]) + ,("b", Just [".1", "one" + , "hi.u"]) + ,("c", Just ["o"])] + msg6 = "Parameter values cannot contain separators " <> + show ["a", "b", "b", "b", "c"] + in [ + + testCase "too many ambiguous parameters" $ + (Left msg1 @=?) =<< runTestOrErr c1 + + , testCase "empty parameter value list" $ + (Left msg2 @=?) =<< runTestOrErr c2 + + , testCase "blank parameter values" $ + (Left msg3 @=?) =<< runTestOrErr c3 + + , testCase "inter-duplicated parameter values" $ + (Left msg4 @=?) =<< runTestOrErr c4 + + , testCase "intra-duplicated parameter values" $ + (Left msg5 @=?) =<< runTestOrErr c5 + + , testCase "parameter values containing separators" $ + (Left msg6 @=?) =<< runTestOrErr c6 + + ] + + , testGroup "no associated file" $ noAssocTests + , testGroup "single associated file" $ singleAssocTests + , testGroup "multiple associated files" $ multiAssocTests + , testGroup "params association" $ paramsAssocTests + , testGroup "wildcard tests" $ wildcardAssocTests + ] + + +runTestOrErr :: CUBE -> IO (Either String String) +runTestOrErr c = bimap (head . lines . show) show <$> + (try (return $! findSugarIn c []) :: + IO (Either SomeException ([Sweets], Doc ann))) + + -- , testGroup "samples tests" $ samplesTests + -- , testGroup "expected matching" $ expectedTests + +-- need tests for assicatedNames = [ ("binary", "") ] diff --git a/test/TestMultiAssoc.hs b/test/TestMultiAssoc.hs new file mode 100644 --- /dev/null +++ b/test/TestMultiAssoc.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TestMultiAssoc ( multiAssocTests ) where + +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils + +import Sample1 ( sample1 ) + + +testInpPath :: FilePath +testInpPath = "tests/samples" + +sugarCube :: CUBE +sugarCube = mkCUBE + { rootName = "*.c" + , expectedSuffix = "expected" + , inputDir = testInpPath + , associatedNames = [ ("exe", "exe") + , ("obj", "o") + , ("include", "h") + , ("c++-include", "hh") + , ("plain", "") + ] + , validParams = [ ("arch", Just ["x86", "ppc"]) + , ("form", Just ["base", "refined"]) + ] + } + +multiAssocTests :: [TT.TestTree] +multiAssocTests = + let (sugar1,_s1desc) = findSugarIn sugarCube sample1 + in [ testCase "valid sample" $ 50 @=? length sample1 + , sugarTestEq "correct found count" sugarCube sample1 5 length + , testCase "results" $ compareBags "results" sugar1 $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "base")] + , associated = [ ("exe", p "global-max-good.x86.exe") + ] + } + , Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "refined")] + , associated = [ ("exe", p "global-max-good.x86.exe") + ] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "base")] + , associated = [ ("exe", p "global-max-good.ppc.exe") + , ("obj", p "global-max-good.ppc.o") + ] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "refined")] + , associated = [ ("exe", p "global-max-good.ppc.exe") + , ("obj", p "global-max-good.ppc.o") + ] + } + ] + } + + , Sweets { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [ ("exe", p "jumpfar.x86.exe") + , ("include", p "jumpfar.h") + ] + } + , Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [ ("exe", p "jumpfar.x86.exe") + , ("include", p "jumpfar.h") + ] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [ ("exe", p "jumpfar.ppc.exe") + , ("include", p "jumpfar.h") + ] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [ ("exe", p "jumpfar.ppc.exe") + , ("include", p "jumpfar.h") + ] + } + ] + } + , Sweets { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [ ("exe", p "looping.x86.exe") + ] + } + , Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [ ("exe", p "looping.x86.exe") + ] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [ ("exe", p "looping.ppc.exe") + ] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [ ("exe", p "looping.ppc.exe") + ] + } + ] + } + , Sweets { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "switching.x86.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "x86") + ] + , associated = [ ("exe", p "switching.x86.exe") + , ("include", p "switching.h") + , ("c++-include", p "switching.hh") + , ("plain", p "switching") + ] + } + , Expectation + { expectedFile = p "switching.ppc.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "ppc") + ] + , associated = [ ("exe", p "switching.ppc.exe") + , ("obj", p "switching.ppc.o") + , ("include", p "switching.h") + , ("c++-include", p "switching.hh") + , ("plain", p "switching") + ] + } + , Expectation + { expectedFile = p "switching.x86.refined-expected" + , expParamsMatch = [ ("form", Explicit "refined") + , ("arch", Explicit "x86") + ] + , associated = [ ("exe", p "switching.x86.exe") + , ("obj", p "switching-refined.x86.o") + , ("include", p "switching.h") + , ("c++-include", p "switching.hh") + , ("plain", p "switching") + ] + } + ] + } + , Sweets { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86"), + ("form", Assumed "base") ] + , associated = [ ("exe", p "tailrecurse.x86.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined") ] + , associated = [ ("exe", p "tailrecurse.x86.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc"), + ("form", Assumed "base") ] + , associated = [ ("exe", p "tailrecurse.ppc.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc") + , ("form", Assumed "refined") ] + , associated = [ ("exe", p "tailrecurse.ppc.exe") + ] + } + ] + } + ] + ] diff --git a/test/TestNoAssoc.hs b/test/TestNoAssoc.hs new file mode 100644 --- /dev/null +++ b/test/TestNoAssoc.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TestNoAssoc ( noAssocTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils + +import Sample1 ( sample1 ) + +testInpPath = "tests/samples" + +sugarCube = mkCUBE + { rootName = "*.c" + , expectedSuffix = "expected" + , inputDir = testInpPath + , associatedNames = [] + , validParams = [ ("arch", Just ["x86", "ppc"]) + , ("form", Just ["base", "refined"]) + ] + } + +noAssocTests :: [TT.TestTree] +noAssocTests = + let (sugar1,s1desc) = findSugarIn sugarCube sample1 + in [ testCase "valid sample" $ 50 @=? length sample1 + , sugarTestEq "correct found count" sugarCube sample1 5 length + , testCase "results" $ compareBags "results" sugar1 + $ let p = (testInpPath ) in + [ + Sweets { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "base")] + , associated = [] + } + , Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "refined")] + , associated = [] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "base")] + , associated = [] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "refined")] + , associated = [] + } + ] + } + + , Sweets { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "switching.x86.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "x86") + ] + , associated = [] + } + , Expectation + { expectedFile = p "switching.ppc.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "ppc") + ] + , associated = [] + } + , Expectation + { expectedFile = p "switching.x86.refined-expected" + , expParamsMatch = [ ("form", Explicit "refined") + , ("arch", Explicit "x86") + ] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86"), + ("form", Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined") ] + , associated = [] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc"), + ("form", Assumed "base") ] + , associated = [] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc") + , ("form", Assumed "refined") ] + , associated = [] + } + ] + } + ] + ] diff --git a/test/TestParamsAssoc.hs b/test/TestParamsAssoc.hs new file mode 100644 --- /dev/null +++ b/test/TestParamsAssoc.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module TestParamsAssoc ( paramsAssocTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.RawString.QQ + + +sample :: [String] +sample = lines [r| +recursive.rs +recursive.fast.exe +recursive.fast.expct +simple.c +simple.expct +simple.noopt.clang.exe +simple.noopt.gcc.exe +simple.noopt-gcc.expct +simple.opt-clang.exe +simple.clang-noopt-clang.exe +simple.clang-gcc.exe +simple-opt.expct +simple-opt.gcc-exe +|] + +testInpPath = "test/params/samples" + +-- Note: in addition to other differences when compared to the tests +-- here (TestNoAssoc, TestSingleAssoc, TestMultiAssoc), this test is +-- somewhat different in that the *output* is used as the rootname +-- instead of the source (e.g. a .c file), so parameter values must be +-- identified and removed from the root to match corresponding expects +-- and associated files. + +sugarCube = mkCUBE { inputDir = testInpPath + , rootName = "*.exe" + , separators = "-." + , expectedSuffix = "expct" + , associatedNames = [ ("c-source", "c") + , ("rust-source", "rs") + , ("haskell", "hs") + ] + , validParams = [ + ("optimization", Nothing) + ,("c-compiler", Just ["gcc", "clang"]) + ] + } + +paramsAssocTests :: [TT.TestTree] +paramsAssocTests = + let (sugar1,_s1desc) = findSugarIn sugarCube sample + in [ testCase "valid sample" $ 14 @=? length sample + , sugarTestEq "correct found count" sugarCube sample 6 length + , testCase "results" $ compareBags "results" sugar1 $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "recursive.fast.exe" + , rootBaseName = "recursive" + , rootFile = p "recursive.fast.exe" + , cubeParams = validParams sugarCube + , expected = + [ + Expectation + { expectedFile = p "recursive.fast.expct" + , expParamsMatch = [ ("optimization", Explicit "fast") + , ("c-compiler", Assumed "gcc") + ] + , associated = [ ("rust-source", p "recursive.rs") ] + } + , Expectation + { expectedFile = p "recursive.fast.expct" + , expParamsMatch = [ ("optimization", Explicit "fast") + , ("c-compiler", Assumed "clang") + ] + , associated = [ ("rust-source", p "recursive.rs") ] + } + + ] + } + + , Sweets { rootMatchName = "simple.noopt.clang.exe" + , rootBaseName = "simple" + , rootFile = p "simple.noopt.clang.exe" + , cubeParams = validParams sugarCube + , expected = + [ + Expectation + { expectedFile = p "simple.expct" + , expParamsMatch = [ ("optimization", Explicit "noopt") + , ("c-compiler", Explicit "clang") + ] + , associated = [ ("c-source", p "simple.c")] + } + ] + } + + , Sweets { rootMatchName = "simple.noopt.gcc.exe" + , rootBaseName = "simple" + , rootFile = p "simple.noopt.gcc.exe" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "simple.noopt-gcc.expct" + , expParamsMatch = [ ("optimization", Explicit "noopt") + , ("c-compiler", Explicit "gcc") + ] + , associated = [ ("c-source", p "simple.c")] + } + ] + } + + , Sweets { rootMatchName = "simple.opt-clang.exe" + , rootBaseName = "simple" + , rootFile = p "simple.opt-clang.exe" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "simple-opt.expct" + , expParamsMatch = [ ("optimization", Explicit "opt") + , ("c-compiler", Explicit "clang") + ] + , associated = [ ("c-source", p "simple.c")] + } + ] + } + + -- This repeats a parameter value, which nullifies any + -- parameter matching and so those elements that look like + -- parameters are just part of the base. + , Sweets { rootMatchName = "simple.clang-noopt-clang.exe" + , rootBaseName = "simple" + , rootFile = p "simple.clang-noopt-clang.exe" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "simple.expct" + , expParamsMatch = [ ("optimization", NotSpecified) + , ("c-compiler", Assumed "gcc") + ] + , associated = [ ("c-source", p "simple.c")] + } + , Expectation + { expectedFile = p "simple.expct" + , expParamsMatch = [ ("optimization", NotSpecified) + , ("c-compiler", Assumed "clang") + ] + , associated = [ ("c-source", p "simple.c")] + } + ] + } + + -- This repeats a parameter with a different value, which + -- nullifies any parameter matching and so those elements + -- that look like parameters are just part of the base. + , Sweets { rootMatchName = "simple.clang-gcc.exe" + , rootBaseName = "simple" + , rootFile = p "simple.clang-gcc.exe" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "simple.expct" + , expParamsMatch = [ ("optimization", NotSpecified) + , ("c-compiler", Assumed "gcc") + ] + , associated = [ ("c-source", p "simple.c")] + } + , Expectation + { expectedFile = p "simple.expct" + , expParamsMatch = [ ("optimization", NotSpecified) + , ("c-compiler", Assumed "clang") + ] + , associated = [ ("c-source", p "simple.c")] + } + ] + } + + -- n.b. simple-opt.gcc-exe is *not* matched: the rootname is + -- "*.exe" so the '.' separator is required. + ] + ] diff --git a/test/TestSingleAssoc.hs b/test/TestSingleAssoc.hs new file mode 100644 --- /dev/null +++ b/test/TestSingleAssoc.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module TestSingleAssoc ( singleAssocTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils + +import Sample1 ( sample1 ) + + +testInpPath = "test/samples" + +sugarCube = mkCUBE + { rootName = "*.c" + , expectedSuffix = "expected" + , inputDir = testInpPath + , associatedNames = [ ("exe", "exe") ] + , validParams = [ ("arch", Just ["x86", "ppc"]) + , ("form", Just ["base", "refined"]) + ] + } + +singleAssocTests :: [TT.TestTree] +singleAssocTests = + let (sugar1,_s1desc) = findSugarIn sugarCube sample1 + in [ testCase "valid sample" $ 50 @=? length sample1 + , sugarTestEq "correct found count" sugarCube sample1 5 length + , testCase "results" $ compareBags "results" sugar1 $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "global-max-good.c" + , rootBaseName = "global-max-good" + , rootFile = p "global-max-good.c" + , cubeParams = validParams sugarCube + , expected = + [ + Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "base")] + , associated = [ ("exe", p "global-max-good.x86.exe") + ] + } + , Expectation + { expectedFile = p "global-max-good.x86.expected" + , expParamsMatch = [("arch", Explicit "x86"), + ("form", Assumed "refined")] + , associated = [ ("exe", p "global-max-good.x86.exe") + ] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "base")] + , associated = [ ("exe", p "global-max-good.ppc.exe") + ] + } + , Expectation + { expectedFile = p "global-max-good.ppc.expected" + , expParamsMatch = [("arch", Explicit "ppc"), + ("form", Assumed "refined")] + , associated = [ ("exe", p "global-max-good.ppc.exe") + ] + } + ] + } + + , Sweets { rootMatchName = "jumpfar.c" + , rootBaseName = "jumpfar" + , rootFile = p "jumpfar.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [ ("exe", p "jumpfar.x86.exe") + ] + } + , Expectation + { expectedFile = p "jumpfar.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [ ("exe", p "jumpfar.x86.exe") + ] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [ ("exe", p "jumpfar.ppc.exe") + ] + } + , Expectation + { expectedFile = p "jumpfar.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [ ("exe", p "jumpfar.ppc.exe") + ] + } + ] + } + , Sweets { rootMatchName = "looping.c" + , rootBaseName = "looping" + , rootFile = p "looping.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "base") ] + , associated = [ ("exe", p "looping.x86.exe") + ] + } + , Expectation + { expectedFile = p "looping.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined")] + , associated = [ ("exe", p "looping.x86.exe") + ] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "base") ] + , associated = [ ("exe", p "looping.ppc.exe") + ] + } + , Expectation + { expectedFile = p "looping.ppc.expected" + , expParamsMatch = [ ("arch" , Explicit "ppc") + , ("form" , Assumed "refined") ] + , associated = [ ("exe", p "looping.ppc.exe") + ] + } + ] + } + , Sweets { rootMatchName = "switching.c" + , rootBaseName = "switching" + , rootFile = p "switching.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "switching.x86.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "x86") + ] + , associated = [ ("exe", p "switching.x86.exe") + ] + } + , Expectation + { expectedFile = p "switching.ppc.base-expected" + , expParamsMatch = [ ("form", Explicit "base") + , ("arch", Explicit "ppc") + ] + , associated = [ ("exe", p "switching.ppc.exe") + ] + } + , Expectation + { expectedFile = p "switching.x86.refined-expected" + , expParamsMatch = [ ("form", Explicit "refined") + , ("arch", Explicit "x86") + ] + , associated = [ ("exe", p "switching.x86.exe") + ] + } + ] + } + , Sweets { rootMatchName = "tailrecurse.c" + , rootBaseName = "tailrecurse" + , rootFile = p "tailrecurse.c" + , cubeParams = validParams sugarCube + , expected = + [ Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86"), + ("form", Assumed "base") ] + , associated = [ ("exe", p "tailrecurse.x86.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.x86.expected" + , expParamsMatch = [ ("arch", Explicit "x86") + , ("form", Assumed "refined") ] + , associated = [ ("exe", p "tailrecurse.x86.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc"), + ("form", Assumed "base") ] + , associated = [ ("exe", p "tailrecurse.ppc.exe") + ] + } + , Expectation + { expectedFile = p "tailrecurse.expected" + , expParamsMatch = [ ("arch", Assumed "ppc") + , ("form", Assumed "refined") ] + , associated = [ ("exe", p "tailrecurse.ppc.exe") + ] + } + ] + } + ] + ] diff --git a/test/TestUtils.hs b/test/TestUtils.hs new file mode 100644 --- /dev/null +++ b/test/TestUtils.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module TestUtils where + +import qualified Control.Exception as E +import qualified Data.List as L +import Data.Maybe ( catMaybes ) +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Text.Show.Pretty + +import Test.Tasty.Sugar + + +genCube :: MonadGen m => m CUBE +genCube = do inpDir <- someStr + srcName <- someStr + expSfx <- someStr + seps <- Gen.filterT (\s -> length s == length (L.nub s)) $ + Gen.string (Range.linear 0 3) Gen.alpha + assocs <- Gen.list (Range.linear 0 10) assoc + params <- Gen.list (Range.linear 0 5) param + return $ CUBE inpDir srcName expSfx seps [] [] + where + assoc = (,) <$> someStr <*> someStr + param = (,) <$> someStr <*> Gen.maybe (Gen.list (Range.linear 1 6) someStr) + someStr = Gen.string (Range.linear 0 10) Gen.alpha + +testWithFailInfo desc test testInp = E.catch (test testInp) (\(_e::E.SomeException) -> assertFailure (show desc)) + + +eqTestWithFailInfo desc val = assertEqual (show desc) val + + +testArray name elemTests lst = + let testElem (n,e,t) = TT.testGroup (name <> " elem#" <> show n) $ t e + testEach = map testElem $ zip3 [0..] lst elemTests + in testCase (name <> " count") (assertEqual "length" (length elemTests) (length lst)) : testEach + + +compareBags name gotBag expBag = + if gotBag `elem` L.permutations expBag + then return () + else let expCnt = length expBag + gotCnt = length gotBag + uGot = L.nub gotBag + expUCnt = length $ L.nub expBag + gotUCnt = length $ uGot + expUnique = L.filter (not . flip elem gotBag) expBag + gotUnique = L.filter (not . flip elem expBag) gotBag + nMatches = length $ L.filter (flip elem expBag) gotBag + plural n sing plu = show n <> " " <> if n == 1 then sing else plu + showEnt nm ent = Just $ unwords [ "Unmatched", nm, "entry:" + , ppShow ent + ] + in assertFailure $ + unlines $ catMaybes $ + [ if expCnt == gotCnt + then Just $ + unwords [ "One or more mismatched entries in" + , plural expCnt "total entry" "total entries" + ] + else Just $ + unwords [ "Expected", plural expCnt "entry" "entries" + , "but got", plural gotCnt "entry" "entries" + ] + , if expCnt == expUCnt + then Nothing + else Just $ + unwords [ "Expected results list has" + , plural (expCnt - expUCnt) + "duplicate entry" + "duplicate entries" + ] + , if gotCnt == gotUCnt + then Nothing + else Just $ + unwords ([ "Actual results list has" + , plural (gotCnt - gotUCnt) + "duplicate entry:" + "duplicate entries:" + ] + <> + let showDup e = unwords ([ "\n" + , show $ nCopies e + , "copies of" + , ppShow e + ]) + nCopies e = length $ filter (== e) gotBag + in fmap showDup uGot) + , if 0 == nMatches + then Just "no common matches AT ALL" + else Just $ show nMatches <> " matching common elements" + ] + <> (if null expUnique + then [Nothing] + else map (showEnt "expected") expUnique) + <> (if null gotUnique + then [Nothing] + else map (showEnt "actual") gotUnique) + +sugarTest name cube sample test = + let (r,d) = findSugarIn cube sample + in testCase name $ testWithFailInfo d test r + + +sugarTestEq name cube sample expVal test = + let (r,d) = findSugarIn cube sample + in testCase name $ eqTestWithFailInfo d expVal $ test r diff --git a/test/TestWildcard.hs b/test/TestWildcard.hs new file mode 100644 --- /dev/null +++ b/test/TestWildcard.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| This test verifies behavior when the mkCUBE rootName is a generic + wildcard ("*") which will match everything in the target directory. + Proper tasty-sugar behavior will check for the expected and + associated files and identify those as associated test files *not* + include those as input rootFiles. +-} + +module TestWildcard ( wildcardAssocTests ) where + +import Data.List +import System.FilePath ( () ) +import qualified Test.Tasty as TT +import Test.Tasty.HUnit +import Test.Tasty.Sugar +import TestUtils +import Text.RawString.QQ + + +testInpPath = "test/samples" + + +sample1 = lines [r| +foo +foo.exp +foo.ex +bar.exp +bar. +bar-ex +cow.moo +cow.mooexp +cow.mooex +cow.mooexe +readme.txt +dog.bark +dog.bark-exp +|] + + +wildcardAssocTests :: [TT.TestTree] +wildcardAssocTests = + [ testCase "valid sample" $ 14 @=? length sample1 + + -- The first CUBE uses the default set of separators, and the expected + -- suffix does not limit which separators can preceed the suffix. + , TT.testGroup "with default seps" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = "exp" + , inputDir = testInpPath + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + in [ sugarTestEq "correct found count" sugarCube sample1 5 length + + -- foo.ex is an associated name for foo, but removing its + -- extension makes it a sibling for the expected file and + -- therefore a valid root as well. + , sugarTestEq "foo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + + -- Similarly, bar.ex is an associated name, but also + -- matches the expected Suffix when its .ex suffix is + -- removed. + , sugarTestEq "bar. is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] + , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] + + , sugarTestEq "dog.bark is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "dog.bark" ] + -- n.b. cow.moo is not matched because there is no separator in cow.mooexp + , testCase "full results" $ + compareBags "default result" + (fst $ findSugarIn sugarCube sample1) $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "foo" + , rootBaseName = "foo" + , rootFile = p "foo" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "foo.exp" + , expParamsMatch = [] + , associated = [ ("extern", p "foo.ex") ] + } + ] + } + , Sweets { rootMatchName = "foo.ex" + , rootBaseName = "foo" + , rootFile = p "foo.ex" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "foo.exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "bar." + , rootBaseName = "bar" + , rootFile = p "bar." + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "bar.exp" + , expParamsMatch = [] + , associated = [ ("extern", p "bar-ex") ] + } + ] + } + , Sweets { rootMatchName = "bar-ex" + , rootBaseName = "bar" + , rootFile = p "bar-ex" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "bar.exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "dog.bark" + , rootBaseName = "dog.bark" + , rootFile = p "dog.bark" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "dog.bark-exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + ] + ] + + -- The second CUBE specifies no separators: the expected suffix + -- immediately follows the source name with no separator. + , TT.testGroup "no seps" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = "exp" + , separators = "" + , inputDir = testInpPath + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + in [ sugarTestEq "correct found count" sugarCube sample1 2 length + , sugarTestEq "bar is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "bar." ] + , sugarTestEq "cow.moo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootFile x == p "cow.moo" ] + -- n.b. neither foo nor dog.bark is matched because they + -- both have a character between the name and the + -- expectedSuffix that is not a known separator + , testCase "full results" $ + compareBags "default result" + (fst $ findSugarIn sugarCube sample1) $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "bar." + , rootBaseName = "bar." + , rootFile = p "bar." + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "bar.exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "cow.moo" + , rootBaseName = "cow.moo" + , rootFile = p "cow.moo" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "cow.mooexp" + , expParamsMatch = [] + , associated = [ ("extern", p "cow.mooex") ] + } + ] + } + ] + ] + + + -- The third CUBE specifies one of the separators as part of the + -- suffix, so only that separator is matched. + , TT.testGroup "seps with suffix sep" $ + let sugarCube = mkCUBE + { rootName = "*" + , expectedSuffix = ".exp" + , inputDir = testInpPath + , associatedNames = [ ("extern", "ex") ] + } + p = (testInpPath ) + in [ sugarTestEq "correct found count" sugarCube sample1 4 length + + -- see notes for default seps tests above + + , sugarTestEq "foo is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo" ] + , sugarTestEq "foo.ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "foo.ex" ] + + -- n.b. dog.bark is not matched because the separator in + -- dog.bark-exp is not the separator specified for the + -- expected suffix. + + , sugarTestEq "bar. is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar." ] + , sugarTestEq "bar-ex is a case" sugarCube sample1 1 $ + \sugar -> length [ x | x <- sugar, rootMatchName x == "bar-ex" ] + + -- n.b. cow.moo is not matched because there is no separator in cow.mooexp + , testCase "full results" $ + compareBags "default result" + (fst $ findSugarIn sugarCube sample1) $ + let p = (testInpPath ) in + [ + Sweets { rootMatchName = "foo" + , rootBaseName = "foo" + , rootFile = p "foo" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "foo.exp" + , expParamsMatch = [] + , associated = [ ("extern", p "foo.ex") ] + } + ] + } + , Sweets { rootMatchName = "foo.ex" + , rootBaseName = "foo" + , rootFile = p "foo.ex" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "foo.exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + , Sweets { rootMatchName = "bar." + , rootBaseName = "bar" + , rootFile = p "bar." + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "bar.exp" + , expParamsMatch = [] + , associated = [ ("extern", p "bar-ex") ] + } + ] + } + , Sweets { rootMatchName = "bar-ex" + , rootBaseName = "bar" + , rootFile = p "bar-ex" + , cubeParams = [] + , expected = + [ Expectation + { expectedFile = p "bar.exp" + , expParamsMatch = [] + , associated = [] + } + ] + } + ] + ] + + ]