tasty-checklist 1.0.5.1 → 1.0.6.0

raw patch · 3 files changed

+92/−37 lines, 3 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• src/Test/Tasty/Checklist.hs +82/−35
• tasty-checklist.cabal +3/−2

@@ -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.

@@ -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 -- <BLANKLINE> -- 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 <<The answer to the universe is 18?>>+--     --- Input for below: The answer to the universe is 18?+--     -Failed check: foo --           expected:    42 --           failed with: 18---     -Failed check of shown on input <<The answer to the universe is 18?>>+--     -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 <<The answer to the universe is 18?>>+--     -Failed check: double-checking foo --           expected:    42 --           failed with: 18 -- <BLANKLINE>@@ -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 "<no input identified>"+                             (("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.

@@ -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