diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history for tasty-sugar +## 1.1.1.0 -- 2021-04-19 + + * Use 'kvitable' to render `--showsearch` output. + * Update build warnings and refactor code to remove potential partial + results. + * Fix tasty ingredients option double-defaulting. + * Add dependency constraint bounds. + * Update haddock usage for usage changes. + ## 1.1.0.0 -- 2021-01-31 * Allow multiple tests to be generated for each `Expectation` via 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 @@ -23,6 +23,7 @@ -- > import Test.Tasty as T -- > import Test.Tasty.Options -- > import Test.Tasty.Sugar +-- > import Numeric.Natural -- > -- > sugarCube = mkCUBE { inputDir = "test/samples" -- > , rootName = "*.c" @@ -31,22 +32,24 @@ -- > } -- > -- > ingredients = T.includingOptions sugarOptions : --- > sugarIngredients sugarCube <> +-- > sugarIngredients [sugarCube] <> -- > T.defaultIngredients -- > -- > main = -- > do testSweets <- findSugar sugarCube --- > T.defaultMainWithIngredients ingredients $ --- > T.testGroup "sweet tests" $ --- > withSugarGroups testSweets T.testGroup mkTest +-- > 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 +-- > mkTest :: Sweets -> Natural -> Expectation -> IO [T.TestTree] +-- > mkTest s n e = do +-- > inp <- readFile inpF +-- > exp <- reads <$> readFile $ expectedFile e +-- > return [ testCase (rootMatchName s <> " #" <> show n) $ do +-- > Just inpF <- lookup "inputs" $ associated e +-- > result <- testSomething inp +-- > result @?= exp +-- > ] -- -- See the README for more information. @@ -76,6 +79,9 @@ , NamedParamMatch , ParamMatch(..) , paramMatchVal + -- ** Reporting + , sweetsKVITable + , sweetsTextTable ) where @@ -83,11 +89,13 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logic +import qualified Data.Foldable as F import Data.Function import qualified Data.List as L import Data.Maybe ( isJust, isNothing, fromJust ) import Data.Proxy import Data.Tagged +import qualified Data.Text as T import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Options.Applicative @@ -97,6 +105,7 @@ import Test.Tasty.Options import Test.Tasty.Sugar.Analysis +import Test.Tasty.Sugar.Report import Test.Tasty.Sugar.Types import Prelude hiding ( exp ) @@ -111,12 +120,9 @@ 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)) - ) + \ sample-file driven tests that would be\n\ + \ performed based on the search." + optionCLParser = flagCLParser Nothing (ShowSugarSearch True) -- | Specify the Sugar-specific Tasty command-line options @@ -147,6 +153,9 @@ show (sum $ fmap (length . fst) searchinfo) ++ "]:") putStrLn $ show $ vsep $ concatMap (map (("•" <+>) . align . pretty) . fst) searchinfo + putStrLn "" + putStrLn $ T.unpack $ sweetsTextTable pats $ + F.fold (fst <$> searchinfo) return True else Nothing diff --git a/src/internal/Test/Tasty/Sugar/ParamCheck.hs b/src/internal/Test/Tasty/Sugar/ParamCheck.hs --- a/src/internal/Test/Tasty/Sugar/ParamCheck.hs +++ b/src/internal/Test/Tasty/Sugar/ParamCheck.hs @@ -95,6 +95,6 @@ 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) + from_rset n = let v = maybe NotSpecified id $ L.lookup n rset in (n,v) pvstr <- genPVStr orderedRset return (rset, length orderedRset, pvstr) diff --git a/src/internal/Test/Tasty/Sugar/Report.hs b/src/internal/Test/Tasty/Sugar/Report.hs new file mode 100644 --- /dev/null +++ b/src/internal/Test/Tasty/Sugar/Report.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Tasty.Sugar.Report + ( + sweetsKVITable + , sweetsTextTable + ) + where + +import Data.KVITable +import Data.KVITable.Render.ASCII ( render + , defaultRenderConfig + , RenderConfig(..) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import Lens.Micro ( (&), (.~) ) +import qualified Prettyprinter as PP +import System.FilePath ( takeFileName ) + +import Test.Tasty.Sugar.Types + + +sweetsKVITable :: [Sweets] -> KVITable FilePath +sweetsKVITable [] = mempty +sweetsKVITable sweets = + let t = fromList $ concatMap + (\s -> + [ + ( ("base", T.pack $ rootBaseName s) + : [ (T.pack pn, T.pack $ show $ PP.pretty pv) + | (pn,pv) <- expParamsMatch e ] + <> [ (T.pack an, T.pack $ takeFileName af) + | (an,af) <- associated e ] + , takeFileName (expectedFile e) + ) + | e <- expected s + ]) + sweets + in t & valueColName .~ "Expected File" + +sweetsTextTable :: [CUBE] -> [Sweets] -> Text +sweetsTextTable [] _ = "No CUBE provided for report" +sweetsTextTable _ [] = "No Sweets provided for report" +sweetsTextTable c s = + let cfg = defaultRenderConfig + { rowGroup = "base" + : (T.pack . fst <$> take 1 (validParams $ head c)) + } + in render cfg $ sweetsKVITable s diff --git a/src/internal/Test/Tasty/Sugar/RootCheck.hs b/src/internal/Test/Tasty/Sugar/RootCheck.hs --- a/src/internal/Test/Tasty/Sugar/RootCheck.hs +++ b/src/internal/Test/Tasty/Sugar/RootCheck.hs @@ -43,10 +43,6 @@ isRootSep (RootSep _) = True isRootSep _ = False -isRootSuffix :: RootPart -> Bool -isRootSuffix (RootSuffix _) = True -isRootSuffix _ = False - rpStr :: [RootPart] -> String rpStr = let s = \case RootSep x -> x @@ -143,13 +139,14 @@ 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 ) + case drop idx allRP of + (RootText idxv:_) -> do + let free = RootParNm (fst p) idxv + start = take (idx - 1) allRP + return ( rpNPM [free] + , rpStr $ start + , rpStr $ drop (idx + 2) allRP ) + _ -> mzero freeFirst (Just (Left (pfx, pl1, sfx))) = if length pfx < 3 then mzero @@ -161,13 +158,12 @@ 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 ) + case reverse pfx of + (_:RootText lpv:_) -> + return ( rpNPM $ RootParNm (fst p) lpv : pl1 + , rpStr $ reverse $ drop 3 $ reverse pfx + , rpStr sfx ) + _ -> mzero freeLast Nothing = mzero freeLast (Just (Right _)) = mzero @@ -180,12 +176,12 @@ 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 + case sfx of + (RootText fsv:_) -> + return ( rpNPM $ parms1 <> [RootParNm (fst p) fsv] , rpStr pfx , rpStr $ tail sfx ) + _ -> mzero freeMid Nothing = mzero freeMid (Just (Left _)) = mzero @@ -198,11 +194,13 @@ 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 ) + case mid of + (ms1:RootText mv:ms2:[]) -> + return ( rpNPM ( parms1 <> [RootParNm (fst p) mv] <> + parms2 ) + , rpStr $ pfx <> [ms1] + , rpStr $ ms2 : sfx ) + _ -> mzero (freeFirst rnChunks) `mplus` (freeLast rnChunks) @@ -225,14 +223,16 @@ , 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) + let l1 = length rootNm + l2 = length pvstr + bslen = l1 - l2 + matches n = pvstr `L.isPrefixOf` (drop n rootNm) + case L.find matches $ reverse [1..bslen] of + Just pfxlen -> + let basename = take pfxlen rootNm + suffix = drop (pfxlen + l2) rootNm + in return (explicit, basename, suffix) + _ -> mzero -- Return origRootName up to each sep-indicated point. noRootParamMatch :: FilePath -> Separators 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: 1.1.0.0 +version: 1.1.1.0 synopsis: Tests defined by Search Using Golden Answer References description: . @@ -25,7 +25,7 @@ category: Testing build-type: Simple -tested-with: GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.1 +tested-with: GHC ==8.6.5 GHC ==8.8.4 GHC ==8.10.1 GHC ==9.0.1 extra-source-files: CHANGELOG.md README.org @@ -58,18 +58,22 @@ library exposed-modules: Test.Tasty.Sugar build-depends: base >=4.10 && < 5 - , directory - , filepath - , filemanip - , logict - , optparse-applicative - , prettyprinter >= 1.7.0 - , tagged - , tasty + , directory >= 1.3 && < 1.4 + , filepath >= 1.4 && < 1.5 + , filemanip >= 0.3 && < 0.4 + , logict >= 0.7.0.3 && < 0.9 + , optparse-applicative >= 0.15 && < 0.17 + , prettyprinter >= 1.7.0 && < 1.8 + , tagged >= 0.8 && < 0.9 + , tasty >= 1.2 && < 1.5 , tasty-sugar-internal + , text >= 1.2 && < 1.3 hs-source-dirs: src default-language: Haskell2010 - GHC-options: -Wall -Wcompat -fhide-source-paths + GHC-options: -Wall -Wcompat + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths -- other-modules: -- other-extensions: @@ -79,16 +83,23 @@ , Test.Tasty.Sugar.AssocCheck , Test.Tasty.Sugar.ExpectCheck , Test.Tasty.Sugar.ParamCheck + , Test.Tasty.Sugar.Report , Test.Tasty.Sugar.RootCheck , Test.Tasty.Sugar.Types build-depends: base >= 4.10 , filepath , filemanip + , kvitable >= 1.0 && < 1.1 , logict - , prettyprinter + , microlens >= 0.4 && < 0.5 + , prettyprinter >= 1.7 && < 1.8 + , text >= 1.2 && < 1.3 hs-source-dirs: src/internal - default-language: Haskell2010 - GHC-options: -Wall -Wcompat -fhide-source-paths + default-language: Haskell2010 + GHC-options: -Wall -Wcompat + -Wincomplete-uni-patterns + -Wpartial-fields + -fhide-source-paths test-suite test-sugar @@ -117,7 +128,7 @@ , tasty-hedgehog , tasty-hunit , tasty-sugar - + , text test-suite test-passthru-ascii type: exitcode-stdio-1.0 diff --git a/test/TestGCD.hs b/test/TestGCD.hs --- a/test/TestGCD.hs +++ b/test/TestGCD.hs @@ -3,7 +3,7 @@ module TestGCD ( gcdSampleTests ) where -import Data.List +import qualified Data.Text as T import System.FilePath ( () ) import qualified Test.Tasty as TT import Test.Tasty.HUnit @@ -34,6 +34,12 @@ let (sugar,sdesc) = findSugarIn sugarCube gcdSamples in [ testCase "valid sample" $ 20 @=? length gcdSamples , sugarTestEq "correct found count" sugarCube gcdSamples 1 length + + , testCase "sweets rendering" $ + let actual = sweetsTextTable [sugarCube] sugar + in do putStrLn "Table" -- try to start table on its own line + putStrLn $ T.unpack actual + T.length actual > 0 @? "change this to see the table" , testCaseSteps "sweets info" $ \step -> do step "rootMatchName" diff --git a/test/TestMultiAssoc.hs b/test/TestMultiAssoc.hs --- a/test/TestMultiAssoc.hs +++ b/test/TestMultiAssoc.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module TestMultiAssoc ( multiAssocTests ) where +import qualified Data.Text as T import System.FilePath ( () ) import qualified Test.Tasty as TT import Test.Tasty.HUnit @@ -30,15 +32,21 @@ ] } + multiAssocTests :: [TT.TestTree] multiAssocTests = let (sugar1,_s1desc) = findSugarIn sugarCube sample1 in [ - -- This is simply the number of entries in sample1; if this -- fails in means that sample1 has been changed and the other -- tests here are likely to need updating. testCase "valid sample" $ 58 @=? length sample1 + + , testCase "sweets rendering" $ + let actual = sweetsTextTable [sugarCube] sugar1 + in do putStrLn "Table" -- try to start table on its own line + putStrLn $ T.unpack actual + T.length actual > 0 @? "change this to see the table" , sugarTestEq "correct found count" sugarCube sample1 6 length