diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history for tasty-sugar +## 1.0.0.0 -- 2021-01-14 + + * Allow multiple CUBE inputs for a single test session; Sweets are a semigroup. + + * Run the withSugarGroups mkSweets in MonadIO instead of pure. + + * Remove blank lines in --showsearch output. + ## 0.2.0.0 -- 2021-01-12 * Renamed CUBE "source" to "rootName" diff --git a/README.org b/README.org --- a/README.org +++ b/README.org @@ -9,7 +9,7 @@ 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 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. @@ -81,14 +81,14 @@ , 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 + tests <- withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> return $ + testCase (rootMatchName sweets <> " #" <> show expIdx) $ do + let Just binaryName = lookup "binary" $ associated expectation + r <- runTestOn binaryName + e <- readFile $ expectedFile expectation + r @?= e + defaultMain $ testGroup "elf" tests runTestOn :: FilePath -> IO String runTestOn f = ... @@ -206,25 +206,25 @@ } ingredients = includingOptions sugarOptions : - sugarIngredients cube <> defaultIngredients + sugarIngredients [cube] <> defaultIngredients main = do testSweets <- findSugar cube + tests <- withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> return $ + 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 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 + testGroup "elf" tests runCTestOn :: FilePath -> IO String runCTestOn f = ... @@ -313,25 +313,24 @@ } ingredients = includingOptions sugarOptions : - sugarIngredients cube <> defaultIngredients + sugarIngredients [cube] <> defaultIngredients main = do testSweets <- findSugar cube + tests <- withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> return $ + 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 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 + testGroup "elf" tests runCTestOn :: FilePath -> String runCTestOn f = ... @@ -409,12 +408,11 @@ * 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). - + + The tasty-sugar package does not actually read or write any of + the files identified, it simply provides the names of the files + to the test generator function. The user's test code is + responsible for all file processing. + ** tasty-silver Similar to tasty-golden in functionality. diff --git a/examples/example1/test-passthru-ascii.hs b/examples/example1/test-passthru-ascii.hs --- a/examples/example1/test-passthru-ascii.hs +++ b/examples/example1/test-passthru-ascii.hs @@ -11,13 +11,13 @@ main = do sweets <- findSugar cube - defaultMain $ testGroup "passthru ascii tests" $ + defaultMain . testGroup "passthru ascii tests" =<< withSugarGroups sweets testGroup test_passthru_ascii -test_passthru_ascii sweet cnt exp = - testCase ("checking #" <> show cnt <> ": " <> expectedFile exp) $ do +test_passthru_ascii sweet cnt exp = do inp <- readFile $ rootFile sweet - let testout = NiftyText.processText "passthru" "ascii" inp - out <- readFile $ expectedFile exp - out @=? testout + return $ testCase ("checking #" <> show cnt <> ": " <> expectedFile exp) $ do + let testout = NiftyText.processText "passthru" "ascii" inp + out <- readFile $ expectedFile exp + out @=? testout diff --git a/examples/params/test-params.hs b/examples/params/test-params.hs --- a/examples/params/test-params.hs +++ b/examples/params/test-params.hs @@ -22,15 +22,13 @@ } ingredients = includingOptions sugarOptions : - sugarIngredients cube <> defaultIngredients + sugarIngredients [cube] <> defaultIngredients main :: IO () main = do testSweets <- findSugar cube - defaultMainWithIngredients ingredients $ - testGroup "elf" $ - withSugarGroups testSweets testGroup $ - \sweets expIdx expectation -> + elfTests <- withSugarGroups testSweets testGroup $ + \sweets expIdx expectation -> return $ testCase (rootMatchName sweets <> " #" <> show expIdx) $ do e <- readFile $ expectedFile expectation let assoc = associated expectation @@ -54,6 +52,7 @@ else runUnexpTestOn sweets expectation f putStrLn $ ppShow sweets r @?= e + defaultMainWithIngredients ingredients $ testGroup "elf" elfTests runCTestOn :: FilePath -> IO String runCTestOn _ = return $ "Simple C file expected output" diff --git a/src/Test/Tasty/Sugar.hs b/src/Test/Tasty/Sugar.hs --- a/src/Test/Tasty/Sugar.hs +++ b/src/Test/Tasty/Sugar.hs @@ -125,8 +125,8 @@ -- | Provides the Tasty Ingredients that can be used to inform the -- testing process. -sugarIngredients :: CUBE -> [Ingredient] -sugarIngredients pat = [ searchResultsSugarReport pat ] +sugarIngredients :: [CUBE] -> [Ingredient] +sugarIngredients pats = [ searchResultsSugarReport pats ] -- | This is a Tasty "Ingredient" (aka test runner) that can be used @@ -134,17 +134,18 @@ -- This output can be requested by the "--showsearch" argument to the -- test executable. -searchResultsSugarReport :: CUBE -> Ingredient -searchResultsSugarReport pat = TestManager [] $ \opts _tests -> +searchResultsSugarReport :: [CUBE] -> Ingredient +searchResultsSugarReport pats = TestManager [] $ \opts _tests -> if lookupOption opts == ShowSugarSearch True - then Just $ do searchinfo <- findSugar' pat - let (inps, expl) = searchinfo - putStrLn $ show $ pretty pat + then Just $ do searchinfo <- mapM findSugar' pats + mapM_ (putStrLn . show . pretty) pats putStrLn "" - putStrLn $ show expl + mapM_ (putStrLn . show . snd) searchinfo putStrLn "" - putStrLn $ "Final set of tests [" ++ show (length inps) ++ "]:" - putStrLn $ show $ vsep $ map (("•" <+>) . align . pretty) inps + putStrLn ("Final set of tests [" ++ + show (sum $ fmap (length . fst) searchinfo) ++ + "]:") + putStrLn $ show $ vsep $ concatMap (map (("•" <+>) . align . pretty) . fst) searchinfo return True else Nothing @@ -298,32 +299,34 @@ -- relationship to elements of the 'Sweets' (such as parameters or -- associated sets). -- -withSugarGroups :: [Sweets] +withSugarGroups :: MonadIO m + => [Sweets] -> (String -> [a] -> a) -- Given a name and list of tests (aka -- 'TestTree'), group them (usually 'testGroup') - -> (Sweets -> Natural -> Expectation -> a) + -> (Sweets -> Natural -> Expectation -> m a) -- Generate a test for this 'Expectation' (usually -- @a ~ TestTree@) - -> [a] + -> m [a] withSugarGroups sweets mkGroup mkLeaf = let mkSweetTests sweet = - mkGroup (rootMatchName sweet) $ - mkParams sweet (expected sweet) $ cubeParams 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 [] = mapM (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 + Nothing -> do ts <- mkParams sweet exp ps + return [mkGroup name ts] + Just vs -> let f v = mkGroup v <$> mkParams sweet (subExp v) ps subExp v = expMatching name v exp - in f <$> L.sort vs + in sequence $ 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 + in mapM mkSweetTests $ L.sortBy (compare `on` rootMatchName) sweets diff --git a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs --- a/src/internal/Test/Tasty/Sugar/ExpectCheck.hs +++ b/src/internal/Test/Tasty/Sugar/ExpectCheck.hs @@ -37,7 +37,7 @@ expSuffix = expectedSuffix pat candidates = filter possible allNames possible f = and [ matchPrefix `L.isPrefixOf` f - , rootN /= f + , rootN /= f -- expected file cannot be the rootName file ] mkSweet e = Just $ Sweets { rootMatchName = rootN , rootBaseName = matchPrefix diff --git a/src/internal/Test/Tasty/Sugar/Types.hs b/src/internal/Test/Tasty/Sugar/Types.hs --- a/src/internal/Test/Tasty/Sugar/Types.hs +++ b/src/internal/Test/Tasty/Sugar/Types.hs @@ -192,20 +192,20 @@ brackets (pretty $ separators cube) <> pretty (expectedSuffix cube) ] - in "Sugar.CUBE" <> (indent 1 $ vsep $ hdrs <> [assoc, parms]) + in "Sugar.CUBE" <> (indent 1 $ vsep $ hdrs <> catMaybes [assoc, parms]) -- | Pretty printing for a set of associated names -prettyAssocNames :: [(String, String)] -> Doc ann +prettyAssocNames :: [(String, String)] -> Maybe (Doc ann) prettyAssocNames = \case - [] -> mempty - nms -> "associated:" <> (indent 1 $ vsep $ map (pretty . fmap show) nms) + [] -> Nothing + nms -> Just $ "associated:" <> (indent 1 $ vsep $ map (pretty . fmap show) nms) -- | Pretty printing for a list of parameter patterns -prettyParamPatterns :: [ParameterPattern] -> Doc ann +prettyParamPatterns :: [ParameterPattern] -> Maybe (Doc ann) prettyParamPatterns = \case - [] -> mempty - prms -> "params:" <> + [] -> Nothing + prms -> Just $ "params:" <> (let pp (pn,mpv) = pretty pn <+> equals <+> case mpv of @@ -229,14 +229,14 @@ instance Pretty Sweets where pretty inp = "Sweet" <+> - (align $ vsep - [ pretty (rootMatchName inp) - , "root:" <+> + (align $ vsep $ catMaybes + [ Just $ pretty (rootMatchName inp) + , Just $ "root:" <+> align (vsep [ pretty (rootBaseName inp) , pretty (rootFile inp) ]) , prettyParamPatterns $ cubeParams inp - , vsep $ map pretty $ expected inp + , Just $ vsep $ map pretty $ expected inp ]) -- | The 'Association' specifies the name of the associated file entry diff --git a/tasty-sugar.cabal b/tasty-sugar.cabal --- a/tasty-sugar.cabal +++ b/tasty-sugar.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: tasty-sugar -version: 0.2.0.0 +version: 1.0.0.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -24,6 +24,8 @@ copyright: Kevin Quick, 2019-2021 category: Testing build-type: Simple + +tested-with: GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.1 extra-source-files: CHANGELOG.md README.org diff --git a/test/TestMain.hs b/test/TestMain.hs --- a/test/TestMain.hs +++ b/test/TestMain.hs @@ -114,5 +114,3 @@ -- , testGroup "samples tests" $ samplesTests -- , testGroup "expected matching" $ expectedTests - --- need tests for assicatedNames = [ ("binary", "") ]