tasty-checklist (empty) → 1.0.0.0

raw patch · 4 files changed

+498/−0 lines, 4 filesdep +basedep +exceptionsdep +parameterized-utils

Dependencies added: base, exceptions, parameterized-utils, tasty, tasty-checklist, tasty-expected-failure, tasty-hunit, text

Files

• CHANGELOG.md +5/−0
• src/Test/Tasty/Checklist.hs +278/−0
• tasty-checklist.cabal +63/−0
• test/TestChecklist.hs +152/−0

@@ -0,0 +1,5 @@+# Revision history for tasty-checklist++## 1.0.0.0 -- 2021-04-20++* Initial version.

@@ -0,0 +1,278 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | This package provides the ability to run a Checklist of several+-- "checks" during a single test.  A "bad" check does not immediately+-- result in a test failure; at the end of the test (passed or failed+-- due to primary testing), all failed checks are reported (and any+-- failed checks will result in an overall test failure at the end.+--+-- This type of checking can be very useful when needing to test+-- various aspects of an operation that is complex to setup, has+-- multiple effects, or where the checks are related such that knowing+-- about the multiple failures makes debugging easier.+--+-- An alternative approach is to have some sort of common preparation+-- code and use a separate test for each item.  This module simply+-- provides a convenient method to collate related items under the+-- aegis of a single test.+--+-- This package also provides the 'checkValues' function which can be+-- used to check a number of derived values from a single input value+-- via a checklist.  This can be used to independently verify a number+-- of record fields of a data structure or to validate related+-- operations performed from a single input.+--+-- See the documentation for 'check' and 'checkValues' for examples of+-- using this library.  The tests in the source package also provide+-- additional examples of usage.++module Test.Tasty.Checklist+  (+    withChecklist+  , CanCheck+  , check+  , discardCheck+  , checkValues+  , DerivedVal(Val)+  -- * Error reporting+  , ChecklistFailures+  -- * Displaying tested values+  , TestShow(testShow)+  , testShowList+  )+where++import           Control.Exception ( evaluate )+import           Control.Monad ( join, unless )+import           Control.Monad.Catch+import           Control.Monad.IO.Class ( MonadIO, liftIO )+import           Data.IORef+import qualified Data.List as List+import qualified Data.Parameterized.Context as Ctx+import           Data.Text ( Text )+import qualified Data.Text as T+import           System.IO ( hFlush, hPutStrLn, stdout, stderr )+++-- | The ChecklistFailures exception is thrown if any checks have+-- failed during testing.++data ChecklistFailures = ChecklistFailures Text [CheckResult]++-- | The 'CheckResult' captures the failure information for a check++data CheckResult = CheckFailed Text Text++instance Exception ChecklistFailures++instance Show CheckResult where+  show (CheckFailed what val) =+    "Failed check of " <> T.unpack what <> " against " <> show val++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)++-- | A convenient Constraint to apply to functions that will perform+-- checks (i.e. call 'check' one or more times)++type CanCheck = (?checker :: IORef [CheckResult])+++-- | This should be used to wrap the test that contains checks.  This+-- initializes the environment needed for the checks to run, and on+-- exit from the test, reports any (and all) failed checks as a test+-- failure.++withChecklist :: (MonadIO m, MonadMask m)+              => Text -> (CanCheck => m a) -> m a+              -- KWQ: if used TestTree instead of `m a`, could wrap the test like expected failure does, then update the Result with the check failures to get better output integration.+withChecklist topMsg t = do+  checks <- liftIO $ newIORef mempty+  r <- (let ?checker = checks in t)+       `onException` (liftIO $+                       do cs <- List.reverse <$> readIORef checks+                          unless (null cs) $ do+                            hFlush stdout+                            hPutStrLn stderr ""+                            let pfx = "        ⚠ "+                            mapM_ (hPutStrLn stderr . (pfx <>) . show) cs+                            hFlush stderr+                     )++  -- If t failed, never get here:+  liftIO $ do+    collected <- List.reverse <$> readIORef checks+    unless (null collected) $+      throwM (ChecklistFailures topMsg collected)+  return r++-- | This is used to run a check within the code.  The first argument+-- is the "name" of this check, the second is a function that takes a+-- value and returns 'True' if the value is OK, or 'False' if the+-- value fails the check.  The last argument is the value to check.+--+-- >>> :set -XOverloadedStrings+-- >>> :{+-- >>> defaultMain $ testCase "odd numbers" $ withChecklist "odds" $ do+-- >>>  let three = 3 :: Int+-- >>>  check "three is odd" odd three+-- >>>  check "two is odd" odd (2 :: Int)+-- >>>  check "7 + 3 is odd" odd $ 7 + three+-- >>>  check "7 is odd" odd (7 :: Int)+-- >>> :}+-- tst1: FAIL+--   Exception: ERROR: numbers+--     2 checks failed in this checklist:+--     ↪Failed check of "two is odd" with "2"+--     ↪Failed check of "7 + 3 is odd" with "10"+--+-- Any check failures are also printed to stdout (and omitted from the+-- above for clarity).  This is so that those failures are reported+-- even if a more standard test assertion is used that prevents+-- completion of the checklist.  Thus, if an `assertEqual "values"+-- three 7` had been added to the above, that would have been the only+-- actual (and immediate) fail for the test, but any failing 'check's+-- appearing before that 'assertEqual' would still have printed.++check :: (CanCheck, TestShow a, MonadIO m)+      => Text -> (a -> Bool) -> a -> m ()+check what eval val = do+  r <- liftIO $ evaluate (eval val)+  unless r $ do+    let chk = CheckFailed what $ T.pack $ testShow val+    liftIO $ modifyIORef ?checker (chk:)+++-- | Sometimes checks are provided in common testing code, often in+-- setup/preparation for the main tests.  In some cases, the check is+-- not applicable for that particular test.  This function can be used+-- to discard any pending failures for the associated named check.+--+-- This is especially useful when a common code block is used to+-- perform a set of checks: if a few of the common checks are not+-- appropriate for the current situation, 'discardCheck' can be used+-- to throw away the results of those checks by matching on the check+-- name.++discardCheck :: (CanCheck, MonadIO m) => Text -> m ()+discardCheck what = do+  let isCheck n (CheckFailed n' _) = n == n'+  liftIO $ modifyIORef ?checker (filter (not . isCheck what))++----------------------------------------------------------------------++-- | The 'checkValues' is a checklist that tests various values that+-- can be derived from the input value.  The input value is provided,+-- along with an 'Data.Parameterized.Context.Assignment' list of+-- extraction functions and the expected result value (and name) of+-- that extraction.  Each extraction is performed as a check within+-- the checklist.+--+-- This is convenient to gather together a number of validations on a+-- single datatype and represent them economically.+--+-- One example is testing the fields of a record structure:+--+-- > {-# LANGUAGE PatternSynonyms, OverloadedStrings #-}+-- >+-- > import Data.Parameterized.Context ( pattern Empty, pattern (:>) )+-- > import Test.Tasty.Checklist+-- >+-- > data Struct = MyStruct { foo :: Int, bar :: Char, baz :: String }+-- >+-- > instance Show Struct where+-- >    show s = baz s <> " is " <> foo s <> bar s+-- >+-- > someFun :: Int -> Struct+-- > someFun n = MyStruct (n * 6)+-- >               (if n * 6 == 42 then '!' else '?')+-- >               "The answer to the universe"+-- >+-- > oddAnswer :: Struct -> Bool+-- > oddAnswer = odd . foo+-- >+-- > test = testCase "someFun result" $+-- >    someFun 3 `checkValues`+-- >         (Empty+-- >         :> Val "foo" foo 42+-- >         :> Val "baz field" baz "The answer to the universe"+-- >         :> Val "shown" show "The answer to the universe is 42!"+-- >         :> Val "odd answer" oddAnswer False+-- >         :> Val "double-checking foo" foo 42+-- >         )+--+-- Running this test:+--+-- >>> defaultMain test+-- ERROR: on input "The answer to the universe is 18?"+--   2 checks failed:+--   ↪Failed check of "foo" with "42"+--   ↪Failed check of "shown" with "The answer to the universe is 42!"+--+-- In this case, several of the values checked were correct, but more+-- than one was wrong.  Helpfully, this test output lists /all/ the+-- wrong answers for the single input provided.++checkValues :: CanCheck+            => TestShow dType+            => dType -> Ctx.Assignment (DerivedVal dType) idx ->  IO ()+checkValues got expF =+  join $ evaluate <$> Ctx.traverseWithIndex_ (chkValue got) expF+++chkValue :: CanCheck+         => TestShow dType+         => dType -> Ctx.Index idx valType -> DerivedVal dType valType -> IO ()+chkValue got _idx (Val txt fld v) =+  check (txt <> " on input «" <> T.pack (testShow got) <> "»") (fld got ==) v+++-- | Each entry in the 'Data.Parameterized.Context.Assignment' list+-- for 'checkValues' should be one of these 'DerivedVal' values.++data DerivedVal i d where+  Val :: (TestShow d, Eq d) => Text -> (i -> d) -> d -> DerivedVal i d++----------------------------------------------------------------------++-- | The 'TestShow' class is defined to provide a way for the various+-- data objects tested by this module to be displayed when tests fail.+-- The default 'testShow' will use a 'Show' instance, but this can be+-- overridden if there are alternate ways t o display a particular+-- object (e.g. pretty-printing, etc.)++class TestShow v where+  testShow :: v -> String+  default testShow :: Show v => v -> String+  testShow = show++-- Some TestShow instances using Show for regular datatypes+instance TestShow ()+instance TestShow Bool+instance TestShow Int+instance TestShow Integer+instance TestShow Float+instance TestShow Char+instance TestShow String++instance (TestShow a, TestShow b) => TestShow (a,b) where+  testShow (a,b) = "(" <> testShow a <> ", " <> testShow b <> ")"+instance (TestShow a, TestShow b, TestShow c) => TestShow (a,b,c) where+  testShow (a,b,c) = "(" <> testShow a <> ", " <> testShow b <> ", " <> testShow c <> ")"++-- | A helper function for defining a testShow for lists of items.+--+-- > instance TestShow [Int] where testShow = testShowList++testShowList :: TestShow v => [v] -> String+testShowList  l = "[ " <> (List.intercalate ", " (testShow <$> l)) <> " ]"

@@ -0,0 +1,63 @@+cabal-version:      2.2+name:               tasty-checklist+version:            1.0.0.0+synopsis:           Check multiple items during a tasty test+description:+   Allows the test to check a number of items during a test and+   only signal pass or fail when the end if the checklist is reached.+   .+   Also provides an easy method to check multiple derived values from+   a single input value.+-- bug-reports:+license:            ISC+author:             Kevin Quick+maintainer:         kquick@galois.com+copyright:          Kevin Quick, 2021+category:           Testing+extra-source-files: CHANGELOG.md++source-repository head+   type: git+   location: https://github.com/kquick/tasty-checklist++common bldspec+  ghc-options:      -Wall+                    -Wcompat+                    -Wincomplete-patterns+                    -Wincomplete-uni-patterns+                    -Wincomplete-record-updates+                    -Wpartial-fields+                    -Widentities+                    -Wmissing-exported-signatures+                    -Wmissing-home-modules+                    -Wmissing-methods+                    -Woverlapping-patterns+                    -Wunused-imports+                    -fhide-source-paths+++library+  import:           bldspec+  hs-source-dirs:   src+  default-language: Haskell2010+  exposed-modules:  Test.Tasty.Checklist+  build-depends:    base >= 4.10 && < 5+                  , exceptions >= 0.10 && < 0.11+                  , parameterized-utils >= 2.1.0 && < 2.2+                  , text >= 1.2 && < 1.3++  +test-suite checklistTests+  import:           bldspec+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  hs-source-dirs:   test+  main-is:          TestChecklist.hs+  build-depends: base+               , parameterized-utils+               , tasty+               , tasty-checklist+               , tasty-hunit+               , tasty-expected-failure+               , text+  

@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}++module Main where++import Data.Parameterized.Context ( pattern Empty, pattern (:>) )+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.HUnit+import Test.Tasty.Checklist+++main :: IO ()+main = defaultMain $ testGroup "Checklist testing"+       [+         expectFailBecause "3 failed checks" $+         testCase "simple checklist" $+         withChecklist "simple" $ do+           let tst :: Int -> Bool+               tst = (> 3)+           check "one" tst 1+           check "two" tst 2+           check "five" tst 5+           check "three" tst 3+           check "four" tst 4++       , expectFailBecause "2 failed checks" $+         testCase "simple checklist with retraction" $+         withChecklist "simple retracted" $ do+           let tst :: Int -> Bool+               tst = (> 3)+           check "one" tst 1+           check "two" tst 2+           check "five" tst 5+           check "three" tst 3+           check "four" tst 4+           discardCheck "two"++       , expectFailBecause "3 failed checks and assert" $+         testCase "simple checklist and assert" $+         withChecklist "simple" $ do+           let tst :: Int -> Bool+               tst = (> 3)+           check "one" tst 1+           check "two" tst 2+           check "five" tst 5+           check "three" tst 3+           check "four" tst 4+           3 @=? (4 :: Int)++       , testCase "someFun 7 result is good" $+         -- everything should pass, no check failures+         withChecklist "someFun 7" $+         someFun 7 `checkValues`+         (Empty+          :> Val "foo" foo 42+          :> Val "baz" baz "The answer to the universe"+          :> Val "shown" show "The answer to the universe is 42!"+          :> Val "odd answer" oddAnswer False+         )++       , expectFailBecause "2 values don't match" $+         testCase "someFun 3 result" $+         withChecklist "someFun" $+         someFun 3 `checkValues`+         (Empty+          :> Val "foo" foo 42+          :> Val "baz" baz "The answer to the universe"+          :> Val "shown" show "The answer to the universe is 42!"+          :> Val "odd answer" oddAnswer False+         )++       , expectFailBecause "assertion" $+         testCase "normal assert failure" $+         withChecklist "asserts" $ do+           3 @=? (5 :: Int)++       , expectFailBecause "2 values don't match and assertion" $+         testCase "someFun 3 result and assert" $+         withChecklist "someFun" $ do+           someFun 3 `checkValues`+             (Empty+              :> Val "foo" foo 42+              :> Val "baz" baz "The answer to the universe"+              :> Val "shown" show "The answer to the universe is 42!"+              :> Val "odd answer" oddAnswer False+             )+           3 @=? (5 :: Int)++       , testCase "object w/o Show is OK" $+         -- The test object has a TestShow instance but no Show+         -- instance.  The test should pass, no checks or failures+         withChecklist "opaque object" $+         genOpaque `checkValues`+         (Empty+          :> Val "displayed" display "[[19]]"+          :> Val "answer" answer 19+          :> Val "revealed" reveal 19+          :> Val "the answer" answer 19+         )++       , expectFailBecause "revealed test check fails" $+         -- The test object has a TestShow but no Show+         testCase "object w/o Show bad comparison" $+         withChecklist "opaque object bad expected" $+         genOpaque `checkValues`+         (Empty+          :> Val "displayed" display "[[19]]"+          :> Val "answer" answer 19+          :> Val "revealed" reveal 18+          :> Val "the answer" answer 19+         )++       ]++----------------------------------------------------------------------++data Struct = MyStruct { foo :: Int+                       , bar :: Char+                       , baz :: String }++instance Show Struct where+   show s = baz s <> " is " <> (show $ foo s) <> (bar s : [])++instance TestShow Struct  -- uses the Show instance++someFun :: Int -> Struct+someFun n = MyStruct (n * 6)+              (if n * 6 == 42 then '!' else '?')+              "The answer to the universe"++oddAnswer :: Struct -> Bool+oddAnswer = odd . foo++----------------------------------------------------------------------++data Opaque = Hidden { answer :: Int }++genOpaque :: Opaque+genOpaque = Hidden 19++reveal :: Opaque -> Int+reveal = answer++display :: Opaque -> String+display o = "[[" <> show (answer o) <> "]]"++-- Note that Opaque doesn't have a standard Show instance, but a+-- TestShow can be provided to suffice for testing.++instance TestShow Opaque where+  testShow = display