diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for tasty-checklist +## 1.0.6.0 -- 2023-04-14 + * Update output formatting to show common input trigger only once for a group + of check failures rather than on each failure. + * Small formatting updates to check failure messages. + * The API is compatible, but any operation checking the text of the output + messages will need to be updated. + ## 1.0.5.1 -- 2023-03-31 * Remove constraint bounds for GHC builtin libraries. diff --git a/src/Test/Tasty/Checklist.hs b/src/Test/Tasty/Checklist.hs --- a/src/Test/Tasty/Checklist.hs +++ b/src/Test/Tasty/Checklist.hs @@ -63,6 +63,7 @@ import Control.Monad.IO.Class ( MonadIO, liftIO ) import Data.IORef import qualified Data.List as List +import qualified Data.Map as Map import qualified Data.Parameterized.Context as Ctx import Data.Text ( Text ) import qualified Data.Text as T @@ -76,19 +77,39 @@ -- | The internal 'CheckResult' captures the failure information for a check -data CheckResult = CheckFailed Text Text -- check name from user, fail message +data CheckResult = CheckFailed CheckName (Maybe InputAsText) FailureMessage + | CheckMessage Text +newtype CheckName = CheckName { checkName :: Text } +newtype InputAsText = InputAsText { inputAsText :: Text } deriving (Eq, Ord) +newtype FailureMessage = FailureMessage { failureMessage :: Text } + instance Exception ChecklistFailures instance Show CheckResult where - show (CheckFailed what msg) = - "Failed check of " <> T.unpack what <> " with: " <> T.unpack msg + show (CheckFailed what onValue msg) = + let chknm = if length (T.lines (checkName what)) > 1 + then "check: " <> T.unpack (checkName what) + else "check '" <> T.unpack (checkName what) <> "'" + chkmsg = if T.null (failureMessage msg) + then "" + else " with: " <> T.unpack (failureMessage msg) + -- n.b. msg might be carefully crafted to preceed chkval + chkval = case onValue of + Nothing -> "" + Just i -> "\n using: " <> T.unpack (inputAsText i) + in "Failed " <> chknm <> chkmsg <> chkval + show (CheckMessage txt) = "-- " <> T.unpack txt instance Show ChecklistFailures where show (ChecklistFailures topMsg fails) = - "ERROR: " <> T.unpack topMsg <> "\n " <> - show (length fails) <> " checks failed in this checklist:\n -" <> - List.intercalate "\n -" (show <$> fails) + let isMessage = \case + CheckMessage _ -> True + _ -> False + checkCnt = length $ filter (not . isMessage) fails + in "ERROR: " <> T.unpack topMsg <> "\n " + <> show checkCnt <> " checks failed in this checklist:\n -" + <> List.intercalate "\n -" (show <$> fails) -- | A convenient Constraint to apply to functions that will perform -- checks (i.e. call 'check' one or more times) @@ -142,8 +163,8 @@ -- odd numbers: FAIL -- Exception: ERROR: odds -- 2 checks failed in this checklist: --- -Failed check of two is odd with: 2 --- -Failed check of 7 + 3 is odd with: 10 +-- -Failed check 'two is odd' with: 2 +-- -Failed check '7 + 3 is odd' with: 10 -- -- 1 out of 1 tests failed (...s) -- *** Exception: ExitFailure 1 @@ -158,14 +179,17 @@ check :: (CanCheck, TestShow a, MonadIO m) => Text -> (a -> Bool) -> a -> m () -check = checkShow testShow +check = checkShow testShow Nothing checkShow :: (CanCheck, MonadIO m) - => (a -> String) -> Text -> (a -> Bool) -> a -> m () -checkShow showit what eval val = do + => (a -> String) + -> Maybe InputAsText + -> Text -> (a -> Bool) -> a -> m () +checkShow showit failInput what eval val = do r <- liftIO $ evaluate (eval val) unless r $ do - let chk = CheckFailed what $ T.pack $ showit val + let failtxt = FailureMessage $ T.pack $ showit val + let chk = CheckFailed (CheckName what) failInput failtxt liftIO $ modifyIORef ?checker (chk:) @@ -182,7 +206,8 @@ discardCheck :: (CanCheck, MonadIO m) => Text -> m () discardCheck what = do - let isCheck n (CheckFailed n' _) = n == n' + let isCheck n (CheckFailed n' _ _) = n == checkName n' + isCheck _ (CheckMessage _) = False liftIO $ modifyIORef ?checker (filter (not . isCheck what)) ---------------------------------------------------------------------- @@ -255,13 +280,14 @@ -- someFun result: FAIL -- Exception: ERROR: results for someFun -- 3 checks failed in this checklist: --- -Failed check of foo on input <> +-- --- Input for below: The answer to the universe is 18? +-- -Failed check: foo -- expected: 42 -- failed with: 18 --- -Failed check of shown on input <> +-- -Failed check: shown -- expected: "The answer to the universe is 42!" -- failed with: "The answer to the universe is 18?" --- -Failed check of double-checking foo on input <> +-- -Failed check: double-checking foo -- expected: 42 -- failed with: 18 -- @@ -275,31 +301,52 @@ checkValues :: CanCheck => TestShow dType => dType -> Ctx.Assignment (DerivedVal dType) idx -> IO () -checkValues got expF = +checkValues got expF = do join $ evaluate <$> Ctx.traverseWithIndex_ (chkValue got) expF + -- All the checks are evaluating against the same 'got' value; normally a check + -- reports the value that caused it to fail but that could get repetitious. + -- This groups check failures by their input and removes the input from each + -- checkfailure, instead starting the group with a CheckMessage describing the + -- input for that entire group. + let groupByInp chks = + let gmap = foldr insByInp mempty chks + insByInp = \case + c@(CheckFailed _ mbi _) -> Map.insertWith (<>) mbi [c] + CheckMessage _ -> id -- regrouping, ignore any previous groups + addGroup (mbi,gchks) = + let newChks = dropInput <$> gchks + dropInput (CheckFailed nm _ fmsg) = + if Just (failureMessage fmsg) == (inputAsText <$> mbi) + then CheckFailed nm Nothing + $ FailureMessage "<< ^^ above input ^^ >>" + else CheckFailed nm Nothing fmsg + dropInput i@(CheckMessage _) = i + grpTitle = maybe "" + (("Input for below: " <>) . inputAsText) + mbi + in (<> (newChks <> [CheckMessage grpTitle])) + in foldr addGroup mempty $ Map.toList gmap + liftIO $ modifyIORef ?checker groupByInp + chkValue :: CanCheck => TestShow dType => dType -> Ctx.Index idx valType -> DerivedVal dType valType -> IO () -chkValue got _idx = \case - (Val txt fld v) -> - let r = fld got - msg = txt <> " on input <<" <> ti <> ">>\n" - <> " " <> "expected: " <> tv <> "\n" - <> " " <> "failed" - ti = T.pack (testShow got) - tv = T.pack (testShow v) - in check msg (v ==) r - (Observe txt fld v observationReport) -> - let r = fld got - msg = txt <> " observation failure" - in checkShow (observationReport v) msg (v ==) r - (Got txt fld) -> - let r = fld got - msg = txt <> " on input <<" <> ti <> ">>" - ti = T.pack (testShow got) - in check msg (True ==) r +chkValue got _idx = + let ti = Just $ InputAsText $ T.pack $ testShow got + in \case + (Val txt fld v) -> + let msg = txt + <> "\n" + <> " " <> "expected: " <> tv <> "\n" + <> " " <> "failed" + tv = T.pack (testShow v) + in checkShow testShow ti msg (v ==) $ fld got + (Observe txt fld v observationReport) -> + let msg = txt <> " observation failure" + in checkShow (observationReport v) ti msg (v ==) $ fld got + (Got txt fld) -> checkShow testShow ti txt id $ fld got -- | Each entry in the 'Data.Parameterized.Context.Assignment' list -- for 'checkValues' should be one of these 'DerivedVal' values. diff --git a/tasty-checklist.cabal b/tasty-checklist.cabal --- a/tasty-checklist.cabal +++ b/tasty-checklist.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: tasty-checklist -version: 1.0.5.1 +version: 1.0.6.0 synopsis: Check multiple items during a tasty test description: Allows the test to check a number of items during a test and @@ -13,7 +13,7 @@ license-file: LICENSE author: Kevin Quick maintainer: kquick@galois.com -copyright: Kevin Quick, 2021-2023 +copyright: Kevin Quick category: Testing extra-source-files: CHANGELOG.md @@ -43,6 +43,7 @@ default-language: Haskell2010 exposed-modules: Test.Tasty.Checklist build-depends: base >= 4.10 && < 5 + , containers , exceptions , parameterized-utils >= 2.1.0 && < 2.2 , text