diff --git a/hedgehog-extras.cabal b/hedgehog-extras.cabal --- a/hedgehog-extras.cabal +++ b/hedgehog-extras.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hedgehog-extras -version: 0.4.2.0 +version: 0.4.3.0 synopsis: Supplemental library for hedgehog description: Supplemental library for hedgehog. category: Test @@ -16,12 +16,13 @@ type: git location: https://github.com/input-output-hk/hedgehog-extras -common base { build-depends: base >= 4.12 && < 4.17 } common aeson { build-depends: aeson >= 1.5.6.0 } common aeson-pretty { build-depends: aeson-pretty >= 0.8.5 } common async { build-depends: async } +common base { build-depends: base >= 4.12 && < 4.17 } common bytestring { build-depends: bytestring } common deepseq { build-depends: deepseq } +common Diff { build-depends: Diff } common directory { build-depends: directory } common exceptions { build-depends: exceptions } common filepath { build-depends: filepath } @@ -63,6 +64,7 @@ async, bytestring, deepseq, + Diff, directory, exceptions, filepath, @@ -108,6 +110,7 @@ Hedgehog.Extras.Test.Base Hedgehog.Extras.Test.Concurrent Hedgehog.Extras.Test.File + Hedgehog.Extras.Test.Golden Hedgehog.Extras.Test.MonadAssertion Hedgehog.Extras.Test.Network Hedgehog.Extras.Test.Process diff --git a/src/Hedgehog/Extras/Stock/String.hs b/src/Hedgehog/Extras/Stock/String.hs --- a/src/Hedgehog/Extras/Stock/String.hs +++ b/src/Hedgehog/Extras/Stock/String.hs @@ -2,13 +2,20 @@ ( strip , lastLine , firstLine + , readM ) where +import Control.Monad.Catch (MonadCatch) import Data.Function import Data.String +import GHC.Stack +import Text.Read +import Text.Show (Show) import qualified Data.List as L import qualified Data.Text as T +import qualified Hedgehog as H +import qualified Hedgehog.Extras.Test.Base as H -- | Strip whitepsace from the beginning and end of the string. strip :: String -> String @@ -21,3 +28,7 @@ -- | Get the first line in the string firstLine :: String -> String firstLine = strip . L.unlines . L.take 1 . L.lines + +-- | Trim leading and trailing whitespace and read the string into a value +readM :: (Read a, Show a, H.MonadTest m, MonadCatch m, HasCallStack) => String -> m a +readM = withFrozenCallStack . H.noteShowM . H.evalEither . readEither . strip diff --git a/src/Hedgehog/Extras/Test/Base.hs b/src/Hedgehog/Extras/Test/Base.hs --- a/src/Hedgehog/Extras/Test/Base.hs +++ b/src/Hedgehog/Extras/Test/Base.hs @@ -54,6 +54,7 @@ , assertByDeadlineIOFinally , assertM , assertIO + , assertWithinTolerance , byDeadlineM , byDeadlineIO @@ -87,13 +88,11 @@ import Data.Int (Int) import Data.Maybe (Maybe (..), listToMaybe, maybe) import Data.Monoid (Monoid (..)) -import Data.Ord (Ord ((<))) import Data.Semigroup (Semigroup (..)) import Data.String (String) import Data.Time.Clock (NominalDiffTime, UTCTime) import Data.Traversable (Traversable) import Data.Tuple (snd) -import GHC.Num (Num ((*), (+))) import GHC.Stack (CallStack, HasCallStack) import Hedgehog (MonadTest) import Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..)) @@ -102,7 +101,7 @@ import Hedgehog.Extras.Test.MonadAssertion (MonadAssertion) import Hedgehog.Internal.Property (Diff, liftTest, mkTest) import Hedgehog.Internal.Source (getCaller) -import Prelude (floor) +import Prelude (Num (..), Ord (..), floor) import System.FilePath (()) import System.IO (FilePath, IO) import Text.Show (Show (show)) @@ -461,6 +460,16 @@ -- | Run the IO action 'f' and assert the return value is 'True'. assertIO :: (MonadTest m, MonadIO m, HasCallStack) => IO Bool -> m () assertIO f = GHC.withFrozenCallStack $ H.evalIO (forceM f) >>= H.assert + +-- | Tests if @|c - v| <= r@ +assertWithinTolerance :: (Show a, Ord a, Num a, HasCallStack, H.MonadTest m) + => a -- ^ tested value @v@ + -> a -- ^ expected value @c@ + -> a -- ^ tolerance range @r@ + -> m () +assertWithinTolerance v c r = GHC.withFrozenCallStack $ do + H.diff v (>=) (c - r) + H.diff v (<=) (c + r) -- | Release the given release key. release :: (MonadTest m, MonadIO m) => ReleaseKey -> m () diff --git a/src/Hedgehog/Extras/Test/File.hs b/src/Hedgehog/Extras/Test/File.hs --- a/src/Hedgehog/Extras/Test/File.hs +++ b/src/Hedgehog/Extras/Test/File.hs @@ -54,6 +54,7 @@ import Data.Aeson (Value) import Data.Bool import Data.Either +import Data.Foldable (for_) import Data.Function import Data.Functor import Data.Int @@ -66,12 +67,12 @@ import Hedgehog (MonadTest) import Hedgehog.Extras.Stock.Monad import Hedgehog.Extras.Stock.OS +import System.FilePath (()) import System.IO (FilePath, Handle, IOMode) import Text.Show import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LBS -import Data.Foldable (for_) import qualified Data.List as L import qualified Data.Text.IO as T import qualified Data.Time.Clock as DTC @@ -80,7 +81,6 @@ import qualified Hedgehog as H import qualified Hedgehog.Extras.Test.Base as H import qualified System.Directory as IO -import System.FilePath (()) import qualified System.IO as IO -- | Create the 'directory' directory if it is missing. diff --git a/src/Hedgehog/Extras/Test/Golden.hs b/src/Hedgehog/Extras/Test/Golden.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Extras/Test/Golden.hs @@ -0,0 +1,98 @@ +module Hedgehog.Extras.Test.Golden + ( diffVsGoldenFile, + diffFileVsGoldenFile, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff) +import Data.Algorithm.DiffOutput (ppDiff) +import Data.Bool +import Data.Eq +import Data.Function +import Data.Maybe +import Data.Monoid +import Data.String +import GHC.Stack (HasCallStack, callStack) +import Hedgehog (MonadTest) +import Hedgehog.Extras.Test.Base (failMessage) +import System.FilePath (takeDirectory) +import System.IO (FilePath) + +import qualified Data.List as List +import qualified GHC.Stack as GHC +import qualified Hedgehog.Extras.Test as H +import qualified Hedgehog.Internal.Property as H +import qualified System.Directory as IO +import qualified System.Environment as IO +import qualified System.IO.Unsafe as IO + +-- | Whether the test should create the golden files if the file does ont exist. +createFiles :: Bool +createFiles = IO.unsafePerformIO $ do + value <- IO.lookupEnv "CREATE_GOLDEN_FILES" + return $ value == Just "1" + +-- | Diff contents against the golden file. If CREATE_GOLDEN_FILES environment is +-- set to "1", then should the gold file not exist it would be created. +-- +-- Set the environment variable when you intend to generate or re-generate the golden +-- file for example when running the test for the first time or if the golden file +-- genuinely needs to change. +-- +-- To re-generate a golden file you must also delete the golden file because golden +-- files are never overwritten. +-- +-- TODO: Improve the help output by saying the difference of +-- each input. +diffVsGoldenFile + :: HasCallStack + => (MonadIO m, MonadTest m) + => String -- ^ Actual content + -> FilePath -- ^ Reference file + -> m () +diffVsGoldenFile actualContent referenceFile = GHC.withFrozenCallStack $ do + fileExists <- liftIO $ IO.doesFileExist referenceFile + + if fileExists + then do + referenceLines <- List.lines <$> H.readFile referenceFile + let difference = getGroupedDiff actualLines referenceLines + case difference of + [Both{}] -> pure () + _ -> failMessage callStack $ ppDiff difference + else if createFiles + then do + -- CREATE_GOLDEN_FILES is set, so we create any golden files that don't + -- already exist. + H.note_ $ "Creating golden file " <> referenceFile + H.createDirectoryIfMissing_ (takeDirectory referenceFile) + H.writeFile referenceFile actualContent + else do + H.note_ $ mconcat + [ "Golden file " <> referenceFile + , " does not exist. To create, run with CREATE_GOLDEN_FILES=1" + ] + H.failure + where + actualLines = List.lines actualContent + +-- | Diff file against the golden file. If CREATE_GOLDEN_FILES environment is +-- set to "1", then should the gold file not exist it would be created. +-- +-- Set the environment variable when you intend to generate or re-generate the golden +-- file for example when running the test for the first time or if the golden file +-- genuinely needs to change. +-- +-- To re-generate a golden file you must also delete the golden file because golden +-- files are never overwritten. +diffFileVsGoldenFile + :: HasCallStack + => (MonadIO m, MonadTest m) + => FilePath -- ^ Actual file + -> FilePath -- ^ Reference file + -> m () +diffFileVsGoldenFile actualFile referenceFile = GHC.withFrozenCallStack $ do + contents <- H.readFile actualFile + diffVsGoldenFile contents referenceFile