diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for tasty-checklist + +## 1.0.0.0 -- 2021-04-20 + +* Initial version. diff --git a/src/Test/Tasty/Checklist.hs b/src/Test/Tasty/Checklist.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Checklist.hs @@ -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)) <> " ]" diff --git a/tasty-checklist.cabal b/tasty-checklist.cabal new file mode 100644 --- /dev/null +++ b/tasty-checklist.cabal @@ -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 + diff --git a/test/TestChecklist.hs b/test/TestChecklist.hs new file mode 100644 --- /dev/null +++ b/test/TestChecklist.hs @@ -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