diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,9 @@ -## [_Unreleased_](https://github.com/freckle/hspec-junit-formatter/compare/v1.1.0.2...main) +## [_Unreleased_](https://github.com/freckle/hspec-junit-formatter/compare/v1.1.1.0...main) -None +## [v1.1.1.0](https://github.com/freckle/hspec-junit-formatter/compare/v1.1.0.2...v1.1.1.0) + +- Add `Test.Hspec.JUnit.Formatter{,Env}`, for use as a [spec hook](https://hspec.github.io/hspec-discover.html#spec-hooks) +- Drop support for `hspec < 0.10` ## [v1.1.0.2](https://github.com/freckle/hspec-junit-formatter/compare/v1.1.0.1...v1.1.0.2) diff --git a/README.lhs b/README.lhs --- a/README.lhs +++ b/README.lhs @@ -1,36 +1,124 @@ # hspec-junit-formatter +[![Hackage](https://img.shields.io/hackage/v/hspec-junit-formatter.svg?style=flat)](https://hackage.haskell.org/package/hspec-junit-formatter) +[![Stackage Nightly](http://stackage.org/package/hspec-junit-formatter/badge/nightly)](http://stackage.org/nightly/package/hspec-junit-formatter) +[![Stackage LTS](http://stackage.org/package/hspec-junit-formatter/badge/lts)](http://stackage.org/lts/package/hspec-junit-formatter) +[![CI](https://github.com/freckle/hspec-junit-formatter/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/hspec-junit-formatter/actions/workflows/ci.yml) + A `JUnit` XML runner/formatter for [`hspec`](http://hspec.github.io/). -## Usage +## Usage (with `hspec-discover`) +Place the following in `test/SpecHook.hs`: + ```haskell import Test.Hspec -import Test.Hspec.JUnit -import System.Environment (setEnv) +import Test.Hspec.JUnit.Config +import qualified Test.Hspec.JUnit.Formatter as Formatter -main :: IO () -main = do - -- Most likely done in your CI setup - setEnv "JUNIT_ENABLED" "1" - setEnv "JUNIT_OUTPUT_DIRECTORY" "/tmp" - setEnv "JUNIT_SUITE_NAME" "my-tests" +hook :: Spec -> Spec +hook = Formatter.use $ defaultJUnitConfig "test-suite" +``` - hspecJUnit spec +This _replaces_ the usual formatter, so only a JUnit report is generated and no +other output is visible. +### Registering instead of using + +To make the JUnit formatter available for use with `--format`, but not used by +default, use `register`: + +```haskell +hook2 :: Spec -> Spec +hook2 = Formatter.register $ defaultJUnitConfig "test-suite" +``` + + +### Adding a JUnit report + +To produce a JUnit report _in addition to normal output_, use `add`: + +```haskell +hook3 :: Spec -> Spec +hook3 = Formatter.add $ defaultJUnitConfig "test-suite" +``` + +### Environment Configuration + +To configure things via @JUNIT_@-prefixed environment variables, import +`Formatter.Env` instead. It exports all the same functions: + +```hs +import qualified Test.Hspec.JUnit.Formatter.Env as FormatterEnv +``` + +And set the necessary variables, + +``` +JUNIT_OUTPUT_DIRECTORY=/tmp +JUNIT_SUITE_NAME=my-tests +``` + +```haskell +hook4 :: Spec -> Spec +hook4 = FormatterEnv.add +``` + +### Environment Enabling + +To only apply a hook if `JUNIT_ENABLED=1`, wrap it in `whenEnabled`: + +``` +JUNIT_ENABLED=1 +``` + +```haskell +hook5 :: Spec -> Spec +hook5 = FormatterEnv.whenEnabled FormatterEnv.add +``` + +### Without `hspec-discover` + +Hooks are just functions of type `Spec -> Spec`, so you can apply them right +before calling `hspec` in `main`: + +```haskell +main :: IO () +main = hspec $ FormatterEnv.whenEnabled FormatterEnv.add spec + spec :: Spec spec = describe "Addition" $ do it "adds" $ do 2 + 2 `shouldBe` (4 :: Int) ``` + +## Golden Testing + +This project's test suite uses [hspec-golden][] to generate an XML report for +[`ExampleSpec.hs`](./tests/ExampleSpec.hs) and then compare that with golden XML +files checked into the repository. If your work changes things in a +functionally-correct way, but that diverges from the golden XML files, you need +to regenerate them. + +1. Run `rm tests/golden*.xml` +2. Run the specs again + +We maintain specific golden XML files for GHC 8.x vs 9.x, so you will need to +re-run the test suite with at least one of each series to regenerate all the +necessary files. --- diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,36 +1,124 @@ # hspec-junit-formatter +[![Hackage](https://img.shields.io/hackage/v/hspec-junit-formatter.svg?style=flat)](https://hackage.haskell.org/package/hspec-junit-formatter) +[![Stackage Nightly](http://stackage.org/package/hspec-junit-formatter/badge/nightly)](http://stackage.org/nightly/package/hspec-junit-formatter) +[![Stackage LTS](http://stackage.org/package/hspec-junit-formatter/badge/lts)](http://stackage.org/lts/package/hspec-junit-formatter) +[![CI](https://github.com/freckle/hspec-junit-formatter/actions/workflows/ci.yml/badge.svg)](https://github.com/freckle/hspec-junit-formatter/actions/workflows/ci.yml) + A `JUnit` XML runner/formatter for [`hspec`](http://hspec.github.io/). -## Usage +## Usage (with `hspec-discover`) +Place the following in `test/SpecHook.hs`: + ```haskell import Test.Hspec -import Test.Hspec.JUnit -import System.Environment (setEnv) +import Test.Hspec.JUnit.Config +import qualified Test.Hspec.JUnit.Formatter as Formatter -main :: IO () -main = do - -- Most likely done in your CI setup - setEnv "JUNIT_ENABLED" "1" - setEnv "JUNIT_OUTPUT_DIRECTORY" "/tmp" - setEnv "JUNIT_SUITE_NAME" "my-tests" +hook :: Spec -> Spec +hook = Formatter.use $ defaultJUnitConfig "test-suite" +``` - hspecJUnit spec +This _replaces_ the usual formatter, so only a JUnit report is generated and no +other output is visible. +### Registering instead of using + +To make the JUnit formatter available for use with `--format`, but not used by +default, use `register`: + +```haskell +hook2 :: Spec -> Spec +hook2 = Formatter.register $ defaultJUnitConfig "test-suite" +``` + + +### Adding a JUnit report + +To produce a JUnit report _in addition to normal output_, use `add`: + +```haskell +hook3 :: Spec -> Spec +hook3 = Formatter.add $ defaultJUnitConfig "test-suite" +``` + +### Environment Configuration + +To configure things via @JUNIT_@-prefixed environment variables, import +`Formatter.Env` instead. It exports all the same functions: + +```hs +import qualified Test.Hspec.JUnit.Formatter.Env as FormatterEnv +``` + +And set the necessary variables, + +``` +JUNIT_OUTPUT_DIRECTORY=/tmp +JUNIT_SUITE_NAME=my-tests +``` + +```haskell +hook4 :: Spec -> Spec +hook4 = FormatterEnv.add +``` + +### Environment Enabling + +To only apply a hook if `JUNIT_ENABLED=1`, wrap it in `whenEnabled`: + +``` +JUNIT_ENABLED=1 +``` + +```haskell +hook5 :: Spec -> Spec +hook5 = FormatterEnv.whenEnabled FormatterEnv.add +``` + +### Without `hspec-discover` + +Hooks are just functions of type `Spec -> Spec`, so you can apply them right +before calling `hspec` in `main`: + +```haskell +main :: IO () +main = hspec $ FormatterEnv.whenEnabled FormatterEnv.add spec + spec :: Spec spec = describe "Addition" $ do it "adds" $ do 2 + 2 `shouldBe` (4 :: Int) ``` + +## Golden Testing + +This project's test suite uses [hspec-golden][] to generate an XML report for +[`ExampleSpec.hs`](./tests/ExampleSpec.hs) and then compare that with golden XML +files checked into the repository. If your work changes things in a +functionally-correct way, but that diverges from the golden XML files, you need +to regenerate them. + +1. Run `rm tests/golden*.xml` +2. Run the specs again + +We maintain specific golden XML files for GHC 8.x vs 9.x, so you will need to +re-run the test suite with at least one of each series to regenerate all the +necessary files. --- diff --git a/hspec-junit-formatter.cabal b/hspec-junit-formatter.cabal --- a/hspec-junit-formatter.cabal +++ b/hspec-junit-formatter.cabal @@ -1,6 +1,6 @@ -cabal-version: 1.12 +cabal-version: 1.18 name: hspec-junit-formatter -version: 1.1.0.2 +version: 1.1.1.0 license: MIT license-file: LICENSE copyright: 2021 Renaissance Learning Inc @@ -15,10 +15,14 @@ category: Testing build-type: Simple extra-source-files: + tests/golden/default-ghc-8.xml + tests/golden/default-ghc-9.xml + tests/golden/prefixed-ghc-8.xml + tests/golden/prefixed-ghc-9.xml + +extra-doc-files: README.md CHANGELOG.md - tests/golden.xml - tests/golden-prefixed.xml source-repository head type: git @@ -26,10 +30,12 @@ library exposed-modules: - Test.Hspec.Core.Runner.Ext Test.Hspec.JUnit Test.Hspec.JUnit.Config Test.Hspec.JUnit.Config.Env + Test.Hspec.JUnit.Format + Test.Hspec.JUnit.Formatter + Test.Hspec.JUnit.Formatter.Env Test.Hspec.JUnit.Render Test.Hspec.JUnit.Schema @@ -45,20 +51,40 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies + ghc-options: + -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Wno-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe + build-depends: - base >=4.11.1.0 && <5, - conduit >=1.3.1, - containers >=0.5.11.0, - directory >=1.3.1.5, - exceptions >=0.10.0, - filepath >=1.4.2, - hspec-core >=2.8.1, + array >=0.5.4.0, + base >=4.16.4.0 && <5, + conduit >=1.3.5, + containers >=0.6.5.1, + directory >=1.3.6.2, + exceptions >=0.10.4, + filepath >=1.4.2.2, + hspec-api >=2.10.0, + hspec-core >=2.10.0, iso8601-time >=0.1.5, - text >=1.2.3.1, - time >=1.8.0.2, - xml-conduit >=1.8.0.1, - xml-types >=0.3.6 + regex-base >=0.94.0.2, + regex-tdfa >=1.3.2.1, + text >=1.2.5.0, + time >=1.11.1.1, + xml-conduit >=1.9.1.2, + xml-types >=0.3.8 + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + + if impl(ghc >=8.8) + ghc-options: -fwrite-ide-info + test-suite readme type: exitcode-stdio-1.0 main-is: README.lhs @@ -73,13 +99,29 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies - ghc-options: -pgmL markdown-unlit + ghc-options: + -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Wno-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -pgmL + markdown-unlit + build-depends: - base >=4.11.1.0 && <5, - hspec >=2.8.1, - hspec-junit-formatter -any, - markdown-unlit >=0.5.0 + base >=4.16.4.0 && <5, + hspec >=2.10.0, + hspec-junit-formatter, + markdown-unlit >=0.5.1 + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + + if impl(ghc >=8.8) + ghc-options: -fwrite-ide-info + test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs @@ -98,13 +140,30 @@ RecordWildCards ScopedTypeVariables StandaloneDeriving TypeApplications TypeFamilies - ghc-options: -threaded -rtsopts -O0 -with-rtsopts=-N + ghc-options: + -fignore-optim-changes -Weverything -Wno-all-missed-specialisations + -Wno-missed-specialisations -Wno-missing-exported-signatures + -Wno-missing-import-lists -Wno-missing-local-signatures + -Wno-monomorphism-restriction -Wno-safe -Wno-unsafe -threaded + -rtsopts -O0 -with-rtsopts=-N + build-depends: - base >=4.11.1.0 && <5, - containers >=0.5.11.0, - filepath >=1.4.2, - hspec >=2.8.1, - hspec-junit-formatter -any, + base >=4.16.4.0 && <5, + containers >=0.6.5.1, + filepath >=1.4.2.2, + hspec >=2.10.0, + hspec-golden >=0.2.1.0, + hspec-junit-formatter, temporary >=1.3, - text >=1.2.3.1, - xml-conduit >=1.8.0.1 + text >=1.2.5.0, + xml-conduit >=1.9.1.2 + + if impl(ghc >=9.2) + ghc-options: -Wno-missing-kind-signatures + + if impl(ghc >=8.10) + ghc-options: + -Wno-missing-safe-haskell-mode -Wno-prepositive-qualified-module + + if impl(ghc >=8.8) + ghc-options: -fwrite-ide-info diff --git a/library/Test/Hspec/Core/Runner/Ext.hs b/library/Test/Hspec/Core/Runner/Ext.hs deleted file mode 100644 --- a/library/Test/Hspec/Core/Runner/Ext.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE CPP #-} - --- | Compatibility module for 'configAvailableFormatters' --- --- This feature is only available in hspec >= 2.9. Note that this module doesn't --- do anything to backport the feature; it just supplies a function that will --- use it when possible and safely no-op when not. --- -module Test.Hspec.Core.Runner.Ext - ( configAddAvailableFormatter - ) where - -import Prelude - -import Test.Hspec.Core.Format (Format, FormatConfig) -import Test.Hspec.Core.Runner (Config(..)) - -configAddAvailableFormatter - :: String -> (FormatConfig -> IO Format) -> Config -> Config -#if MIN_VERSION_hspec_core(2,9,0) -configAddAvailableFormatter name format config = config - { configAvailableFormatters = - configAvailableFormatters config <> [(name, format)] - } -#else -configAddAvailableFormatter _ _ = id -#endif diff --git a/library/Test/Hspec/JUnit.hs b/library/Test/Hspec/JUnit.hs --- a/library/Test/Hspec/JUnit.hs +++ b/library/Test/Hspec/JUnit.hs @@ -1,17 +1,19 @@ +{-# LANGUAGE CPP #-} + module Test.Hspec.JUnit - ( - -- * Runners + {-# DEPRECATED "Use Test.Hspec.JUnit.Formatter" #-} + ( -- * Runners hspecJUnit , hspecJUnitWith - -- * Directly modifying 'Config' + -- * Directly modifying 'Config' , configWithJUnit , configWithJUnitAvailable - -- * Actual format function + -- * Actual format function , junitFormat - -- * Configuration + -- * Configuration , module Test.Hspec.JUnit.Config ) where @@ -30,8 +32,17 @@ import System.Directory (createDirectoryIfMissing) import System.FilePath (splitFileName) import Test.Hspec.Core.Format -import Test.Hspec.Core.Runner -import Test.Hspec.Core.Runner.Ext + ( Event (..) + , FailureReason (..) + , Format + , FormatConfig + , Item (..) + , Location (..) + , Path + , Result (..) + , Seconds (..) + ) +import Test.Hspec.Core.Runner (Config (..), defaultConfig, hspecWith) import Test.Hspec.Core.Spec (Spec) import Test.Hspec.JUnit.Config import Test.Hspec.JUnit.Config.Env @@ -44,13 +55,11 @@ -- To actually /use/ the JUnit format, you must set @JUNIT_ENABLED=1@ in the -- environment; by default, this function just behaves like 'hspec'. -- --- (If using hspec >= 2.9, running tests with @--test-arguments="-f junit"@ also --- works.) +-- Running tests with @--test-arguments="-f junit"@ also works. -- -- All configuration of the JUnit report occurs through environment variables. -- -- See "Test.Hspec.JUnit.Config" and "Test.Hspec.JUnit.Config.Env". --- hspecJUnit :: Spec -> IO () hspecJUnit = hspecJUnitWith defaultConfig @@ -69,16 +78,17 @@ -- | Modify an Hspec 'Config' to use 'junitFormat' configWithJUnit :: JUnitConfig -> Config -> Config configWithJUnit junitConfig config = - config { configFormat = Just $ junitFormat junitConfig } + config {configFormat = Just $ junitFormat junitConfig} -- | Modify an Hspec 'Config' to have the 'junitFormat' /available/ -- -- Adds @junit@ to the list of available options for @-f, --format@. --- --- __NOTE__: This only works with hspec >= 2.9, otherwise it is a no-op. --- configWithJUnitAvailable :: JUnitConfig -> Config -> Config -configWithJUnitAvailable = configAddAvailableFormatter "junit" . junitFormat +configWithJUnitAvailable junitConfig config = + config + { configAvailableFormatters = + configAvailableFormatters config <> [("junit", junitFormat junitConfig)] + } -- | Hspec 'configFormat' that generates a JUnit report junitFormat :: JUnitConfig -> FormatConfig -> IO Format @@ -97,27 +107,30 @@ let groups = groupItems paths - output = Schema.Suites - { suitesName = suiteName - , suitesSuites = groups <&> \(group, items) -> do - let - suite xs = Schema.Suite - { suiteName = group - , suiteTimestamp = time - , suiteCases = xs - } - suite $ uncurry (itemToTestCase applyPrefix group) <$> items - } + output = + Schema.Suites + { suitesName = suiteName + , suitesSuites = + groups <&> \(group, items) -> do + let suite xs = + Schema.Suite + { suiteName = group + , suiteTimestamp = time + , suiteCases = xs + } + suite $ uncurry (itemToTestCase applyPrefix group) <$> items + } - runConduitRes - $ sourceList [output] - .| renderJUnit - .| renderBytes def - .| sinkFile file + runConduitRes $ + sourceList [output] + .| renderJUnit dropConsoleFormatting + .| renderBytes def + .| sinkFile file where file = getJUnitConfigOutputFile junitConfig suiteName = getJUnitConfigSuiteName junitConfig applyPrefix = getJUnitPrefixSourcePath junitConfig + dropConsoleFormatting = getJUnitConfigDropConsoleFormatting junitConfig groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])] groupItems = Map.toList . Map.fromListWith (<>) . fmap group @@ -127,50 +140,44 @@ itemToTestCase :: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase -itemToTestCase applyPrefix group name item = Schema.TestCase - { testCaseLocation = - toSchemaLocation applyPrefix - <$> (itemResultLocation item <|> itemLocation item) - , testCaseClassName = group - , testCaseName = name - , testCaseDuration = unSeconds $ itemDuration item - , testCaseResult = case itemResult item of - Success -> Nothing - Pending mLocation mMessage -> - Just $ Schema.Skipped $ prefixLocation mLocation $ prefixInfo $ maybe - "" - pack - mMessage - Failure mLocation reason -> - Just - $ Schema.Failure "error" - $ prefixLocation mLocation - $ prefixInfo - $ case reason of - Error _ err -> pack $ show err - NoReason -> "no reason" - Reason err -> pack err - ExpectedButGot preface expected actual -> - prefixInfo - $ T.unlines - $ pack - <$> fromMaybe "" preface - : (foundLines "expected" expected - <> foundLines " but got" actual - ) - } +itemToTestCase applyPrefix group name item = + Schema.TestCase + { testCaseLocation = + toSchemaLocation applyPrefix + <$> (itemResultLocation item <|> itemLocation item) + , testCaseClassName = group + , testCaseName = name + , testCaseDuration = unSeconds $ itemDuration item + , testCaseResult = case itemResult item of + Success -> Nothing + Pending mLocation mMessage -> + Just $ + Schema.Skipped $ + prefixLocation mLocation $ + prefixInfo $ + maybe + "" + pack + mMessage + Failure mLocation reason -> + Just $ + Schema.Failure "error" $ + prefixLocation mLocation $ + prefixInfo $ + reasonToText reason + } where prefixLocation mLocation str = case mLocation of Nothing -> str Just Location {..} -> mconcat - [ pack $ applyPrefix locationFile - , ":" - , pack $ show locationLine - , ":" - , pack $ show locationColumn - , "\n" - ] + [ pack $ applyPrefix locationFile + , ":" + , pack $ show locationLine + , ":" + , pack $ show locationColumn + , "\n" + ] <> str prefixInfo str | T.null $ T.strip $ pack $ itemInfo item = str @@ -183,10 +190,11 @@ Failure mLocation _ -> mLocation toSchemaLocation :: (FilePath -> FilePath) -> Location -> Schema.Location -toSchemaLocation applyPrefix Location {..} = Schema.Location - { Schema.locationFile = applyPrefix locationFile - , Schema.locationLine = fromIntegral $ max 0 locationLine - } +toSchemaLocation applyPrefix Location {..} = + Schema.Location + { Schema.locationFile = applyPrefix locationFile + , Schema.locationLine = fromIntegral $ max 0 locationLine + } unSeconds :: Seconds -> Double unSeconds (Seconds x) = x @@ -196,4 +204,23 @@ [] -> [] first : rest -> unpack (msg <> ": " <> first) : (unpack . (T.replicate 9 " " <>) <$> rest) - where lines' = T.lines . pack $ show found + where + lines' = T.lines . pack $ show found + +{- FOURMOLU_DISABLE -} +reasonToText :: FailureReason -> Text +reasonToText = \case + Error _ err -> pack $ show err + NoReason -> "no reason" + Reason err -> pack err +#if MIN_VERSION_hspec_core(2,11,0) + ColorizedReason err -> pack err +#endif + ExpectedButGot preface expected actual -> + T.unlines + $ pack + <$> fromMaybe "" preface + : (foundLines "expected" expected + <> foundLines " but got" actual + ) +{- FOURMOLU_ENABLE -} diff --git a/library/Test/Hspec/JUnit/Config.hs b/library/Test/Hspec/JUnit/Config.hs --- a/library/Test/Hspec/JUnit/Config.hs +++ b/library/Test/Hspec/JUnit/Config.hs @@ -1,18 +1,20 @@ module Test.Hspec.JUnit.Config ( JUnitConfig - -- * Construction + -- * Construction , defaultJUnitConfig , setJUnitConfigOutputDirectory , setJUnitConfigOutputName , setJUnitConfigOutputFile , setJUnitConfigSuiteName , setJUnitConfigSourcePathPrefix + , setJUnitConfigDropConsoleFormatting - -- * Use + -- * Use , getJUnitConfigOutputFile , getJUnitConfigSuiteName , getJUnitPrefixSourcePath + , getJUnitConfigDropConsoleFormatting ) where import Prelude @@ -27,61 +29,68 @@ , junitConfigOutputFile :: Maybe FilePath , junitConfigSuiteName :: Text , junitConfigSourcePathPrefix :: Maybe FilePath + , junitConfigDropConsoleFormatting :: Bool } -- | Construct a 'JUnitConfig' given a suite name -- -- See individual set functions for defaults. --- defaultJUnitConfig :: Text -> JUnitConfig -defaultJUnitConfig name = JUnitConfig - { junitConfigOutputDirectory = "." - , junitConfigOutputName = "junit.xml" - , junitConfigOutputFile = Nothing - , junitConfigSuiteName = name - , junitConfigSourcePathPrefix = Nothing - } +defaultJUnitConfig name = + JUnitConfig + { junitConfigOutputDirectory = "." + , junitConfigOutputName = "junit.xml" + , junitConfigOutputFile = Nothing + , junitConfigSuiteName = name + , junitConfigSourcePathPrefix = Nothing + , junitConfigDropConsoleFormatting = False + } -- | Set the directory within which to generate the report -- -- Default is current working directory. --- setJUnitConfigOutputDirectory :: FilePath -> JUnitConfig -> JUnitConfig setJUnitConfigOutputDirectory x config = - config { junitConfigOutputDirectory = x } + config {junitConfigOutputDirectory = x} -- | Set the name for the generated report -- -- Default is @junit.xml@. --- setJUnitConfigOutputName :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigOutputName x config = config { junitConfigOutputName = x } +setJUnitConfigOutputName x config = config {junitConfigOutputName = x} -- | Set the full path to the generated report -- -- If given, the directory and name configurations are ignored. --- setJUnitConfigOutputFile :: FilePath -> JUnitConfig -> JUnitConfig -setJUnitConfigOutputFile x config = config { junitConfigOutputFile = Just x } +setJUnitConfigOutputFile x config = config {junitConfigOutputFile = Just x} setJUnitConfigSuiteName :: Text -> JUnitConfig -> JUnitConfig -setJUnitConfigSuiteName x config = config { junitConfigSuiteName = x } +setJUnitConfigSuiteName x config = config {junitConfigSuiteName = x} -- | Set a prefix to apply to source paths in the report -- -- Default is none. This can be required if you run specs from a sub-directory -- in a monorepository, and you need reported paths to be from the repository -- root. --- setJUnitConfigSourcePathPrefix :: FilePath -> JUnitConfig -> JUnitConfig setJUnitConfigSourcePathPrefix x config = - config { junitConfigSourcePathPrefix = Just x } + config {junitConfigSourcePathPrefix = Just x} +-- | Set whether console formatting characters should be dropped from failure +-- reports. +-- +-- Default is False. Most XML processors will fail to parse the XML if it +-- contains the ANSI control characters used by console formatting. +setJUnitConfigDropConsoleFormatting :: Bool -> JUnitConfig -> JUnitConfig +setJUnitConfigDropConsoleFormatting x config = config {junitConfigDropConsoleFormatting = x} + -- | Retrieve the full path to the generated report getJUnitConfigOutputFile :: JUnitConfig -> FilePath -getJUnitConfigOutputFile JUnitConfig {..} = fromMaybe - (junitConfigOutputDirectory junitConfigOutputName) - junitConfigOutputFile +getJUnitConfigOutputFile JUnitConfig {..} = + fromMaybe + (junitConfigOutputDirectory junitConfigOutputName) + junitConfigOutputFile -- | Retrieve the suite name given on construction getJUnitConfigSuiteName :: JUnitConfig -> Text @@ -90,7 +99,11 @@ -- | Retrieve the function to apply to reported source paths -- -- Will be 'id' if no prefix configured. --- getJUnitPrefixSourcePath :: JUnitConfig -> FilePath -> FilePath getJUnitPrefixSourcePath JUnitConfig {..} = maybe id () junitConfigSourcePathPrefix + +-- | Retrieve whether console formatting characters should be dropped from +-- failure reports. +getJUnitConfigDropConsoleFormatting :: JUnitConfig -> Bool +getJUnitConfigDropConsoleFormatting JUnitConfig {..} = junitConfigDropConsoleFormatting diff --git a/library/Test/Hspec/JUnit/Config/Env.hs b/library/Test/Hspec/JUnit/Config/Env.hs --- a/library/Test/Hspec/JUnit/Config/Env.hs +++ b/library/Test/Hspec/JUnit/Config/Env.hs @@ -1,12 +1,12 @@ -- | Load a 'JUnitConfig' using environment variables module Test.Hspec.JUnit.Config.Env - ( envJUnitEnabled - , envJUnitConfig - ) where + ( envJUnitEnabled + , envJUnitConfig + ) where import Prelude -import Data.Semigroup (Endo(..)) +import Data.Semigroup (Endo (..)) import Data.Text (pack) import System.Directory (getCurrentDirectory) import System.Environment (lookupEnv) @@ -24,16 +24,19 @@ -- * @JUNIT_OUTPUT_DIRECTORY@ 'setJUnitConfigOutputDirectory' -- * @JUNIT_OUTPUT_NAME@ 'setJUnitConfigOutputName -- * and so on --- envJUnitConfig :: IO JUnitConfig envJUnitConfig = do - modify <- appEndo . foldMap Endo <$> sequence - [ lookupEnvOverride "OUTPUT_DIRECTORY" setJUnitConfigOutputDirectory - , lookupEnvOverride "OUTPUT_NAME" setJUnitConfigOutputName - , lookupEnvOverride "OUTPUT_FILE" setJUnitConfigOutputFile - , lookupEnvOverride "SUITE_NAME" $ setJUnitConfigSuiteName . pack - , lookupEnvOverride "SOURCE_PATH_PREFIX" setJUnitConfigSourcePathPrefix - ] + modify <- + appEndo . foldMap Endo + <$> sequence + [ lookupEnvOverride "OUTPUT_DIRECTORY" setJUnitConfigOutputDirectory + , lookupEnvOverride "OUTPUT_NAME" setJUnitConfigOutputName + , lookupEnvOverride "OUTPUT_FILE" setJUnitConfigOutputFile + , lookupEnvOverride "SUITE_NAME" $ setJUnitConfigSuiteName . pack + , lookupEnvOverride "SOURCE_PATH_PREFIX" setJUnitConfigSourcePathPrefix + , lookupEnvOverride "DROP_CONSOLE_FORMATTING" $ + setJUnitConfigDropConsoleFormatting . (== "1") + ] modify . defaultJUnitConfig . pack . takeBaseName <$> getCurrentDirectory diff --git a/library/Test/Hspec/JUnit/Format.hs b/library/Test/Hspec/JUnit/Format.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Format.hs @@ -0,0 +1,152 @@ +module Test.Hspec.JUnit.Format + ( junit + ) where + +import Prelude + +import Control.Applicative ((<|>)) +import Data.Conduit (runConduitRes, (.|)) +import Data.Conduit.Combinators (sinkFile) +import Data.Conduit.List (sourceList) +import Data.Functor ((<&>)) +import qualified Data.Map.Strict as Map +import Data.Maybe (fromMaybe) +import Data.Text (Text, pack, unpack) +import qualified Data.Text as T +import Data.Time (getCurrentTime) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (splitFileName) +import Test.Hspec.Api.Format.V1 +import Test.Hspec.JUnit.Config as Config +import Test.Hspec.JUnit.Render (renderJUnit) +import qualified Test.Hspec.JUnit.Schema as Schema +import Text.XML.Stream.Render (def, renderBytes) + +junit :: JUnitConfig -> FormatConfig -> IO Format +junit junitConfig _config = pure $ \case + Started -> pure () + GroupStarted _ -> pure () + GroupDone _ -> pure () + Progress _ _ -> pure () + ItemStarted _ -> pure () + ItemDone _ _ -> pure () + Done paths -> do + time <- getCurrentTime + + let (directory, _) = splitFileName file + createDirectoryIfMissing True directory + + let + groups = groupItems paths + output = + Schema.Suites + { suitesName = suiteName + , suitesSuites = + groups <&> \(group, items) -> do + let suite xs = + Schema.Suite + { suiteName = group + , suiteTimestamp = time + , suiteCases = xs + } + suite $ uncurry (itemToTestCase applyPrefix group) <$> items + } + + runConduitRes $ + sourceList [output] + .| renderJUnit dropConsoleFormatting + .| renderBytes def + .| sinkFile file + where + file = getJUnitConfigOutputFile junitConfig + suiteName = getJUnitConfigSuiteName junitConfig + applyPrefix = getJUnitPrefixSourcePath junitConfig + dropConsoleFormatting = getJUnitConfigDropConsoleFormatting junitConfig + +groupItems :: [(Path, Item)] -> [(Text, [(Text, Item)])] +groupItems = Map.toList . Map.fromListWith (<>) . fmap group + where + group ((path, name), item) = + (T.intercalate "/" $ pack <$> path, [(pack name, item)]) + +itemToTestCase + :: (FilePath -> FilePath) -> Text -> Text -> Item -> Schema.TestCase +itemToTestCase applyPrefix group name item = + Schema.TestCase + { testCaseLocation = + toSchemaLocation applyPrefix + <$> (itemResultLocation item <|> itemLocation item) + , testCaseClassName = group + , testCaseName = name + , testCaseDuration = unSeconds $ itemDuration item + , testCaseResult = case itemResult item of + Success -> Nothing + Pending mLocation mMessage -> + Just $ + Schema.Skipped $ + prefixLocation mLocation $ + prefixInfo $ + maybe + "" + pack + mMessage + Failure mLocation reason -> + Just $ + Schema.Failure "error" $ + prefixLocation mLocation $ + prefixInfo $ + reasonToText reason + } + where + prefixLocation mLocation str = case mLocation of + Nothing -> str + Just Location {..} -> + mconcat + [ pack $ applyPrefix locationFile + , ":" + , pack $ show locationLine + , ":" + , pack $ show locationColumn + , "\n" + ] + <> str + prefixInfo str + | T.null $ T.strip $ pack $ itemInfo item = str + | otherwise = pack (itemInfo item) <> "\n\n" <> str + +itemResultLocation :: Item -> Maybe Location +itemResultLocation item = case itemResult item of + Success -> Nothing + Pending mLocation _ -> mLocation + Failure mLocation _ -> mLocation + +toSchemaLocation :: (FilePath -> FilePath) -> Location -> Schema.Location +toSchemaLocation applyPrefix Location {..} = + Schema.Location + { Schema.locationFile = applyPrefix locationFile + , Schema.locationLine = fromIntegral $ max 0 locationLine + } + +unSeconds :: Seconds -> Double +unSeconds (Seconds x) = x + +reasonToText :: FailureReason -> Text +reasonToText = \case + Error _ err -> pack $ show err + NoReason -> "no reason" + Reason err -> pack err + ExpectedButGot preface expected actual -> + T.unlines $ + pack + <$> fromMaybe "" preface + : ( foundLines "expected" expected + <> foundLines " but got" actual + ) + +foundLines :: Show a => Text -> a -> [String] +foundLines msg found = case lines' of + [] -> [] + first : rest -> + unpack (msg <> ": " <> first) : (unpack . (T.replicate 9 " " <>) <$> rest) + where + lines' = T.lines . pack $ show found diff --git a/library/Test/Hspec/JUnit/Formatter.hs b/library/Test/Hspec/JUnit/Formatter.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Formatter.hs @@ -0,0 +1,93 @@ +-- | An Hspec formatter that produces a JUnit XML file of results +-- +-- @ +-- -- file test/SpecHook.hs +-- module SpecHook where +-- +-- import Test.Hspec +-- import Test.Hspec.JUnit.Config +-- import Test.Hspec.JUnit.Formatter qualified as Formatter +-- +-- -- | To only produce a JUnit file, silencing other output +-- hook :: Spec -> Spec +-- hook = Formatter.use defaultJUnitConfig +-- +-- -- | To produce a JUnit file /in addition/ to the normal output +-- hook :: Spec -> Spec +-- hook = Formatter.add defaultJUnitConfig +-- +-- -- | To only produce, but only when @--format=junit@ is used +-- hook :: Spec -> Spec +-- hook = Formatter.register defaultJUnitConfig +-- @ +-- +-- See also, +-- +-- - https://hspec.github.io/hspec-discover.html#spec-hooks +-- - https://hspec.github.io/extending-hspec-formatter.html#packaging-a-formatter-for-distribution-and-reuse +-- +-- For a version that reads configuration from @JUNIT_@ environment variables, +-- see "Test.Hspec.JUnit.Formatter.Env". +module Test.Hspec.JUnit.Formatter + ( use + , add + , register + , formatter + , module Test.Hspec.JUnit.Config + , module Api + ) where + +import Prelude + +import Data.Maybe (fromMaybe) + +import Test.Hspec.Api.Format.V1 as Api +import qualified Test.Hspec.Core.Format as Core +import qualified Test.Hspec.Core.Formatters.V2 as V2 +import Test.Hspec.Core.Runner as Core (Config (..)) +import Test.Hspec.JUnit.Config +import Test.Hspec.JUnit.Format + +-- | Register 'junit' as an available formatter and use it by default +use :: JUnitConfig -> SpecWith a -> SpecWith a +use config = (modifyConfig (useFormatter $ formatter config) >>) + +-- | Register 'junit', and use it /in addition/ to the default +add :: JUnitConfig -> SpecWith a -> SpecWith a +add config = (modifyConfig (addFormatter $ formatter config) >>) + +-- | Register 'junit', but do not change the default +register :: JUnitConfig -> SpecWith a -> SpecWith a +register config = (modifyConfig (registerFormatter $ formatter config) >>) + +formatter :: JUnitConfig -> (String, FormatConfig -> IO Format) +formatter config = ("junit", junit config) + +addFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config +addFormatter f = go . registerFormatter f + where + go config = + config + { configFormat = + Just + . (`addFormat` format) + . fromMaybe defaultFormat + $ configFormat config + } + + format = snd $ liftFormatter f + +defaultFormat :: Core.FormatConfig -> IO Core.Format +defaultFormat = V2.formatterToFormat V2.checks + +addFormat + :: (Core.FormatConfig -> IO Core.Format) + -> (Core.FormatConfig -> IO Core.Format) + -> Core.FormatConfig + -> IO Core.Format +addFormat f1 f2 fc = do + formatEvent1 <- f1 fc + formatEvent2 <- f2 fc + pure $ \event -> do + formatEvent1 event + formatEvent2 event diff --git a/library/Test/Hspec/JUnit/Formatter/Env.hs b/library/Test/Hspec/JUnit/Formatter/Env.hs new file mode 100644 --- /dev/null +++ b/library/Test/Hspec/JUnit/Formatter/Env.hs @@ -0,0 +1,56 @@ +-- | Version of "Test.Hspec.JUnit.Formatter" that reads config from ENV +-- +-- @ +-- -- file test/SpecHook.hs +-- module SpecHook where +-- +-- import Test.Hspec +-- import Test.Hspec.JUnit.Formatter.Env qualified as Formatter +-- +-- -- | To always produce a JUnit file, taking all config from the environment +-- hook :: Spec -> Spec +-- hook = Formatter.add +-- +-- -- | Same, but only if @JUNIT_ENABLED=1@ +-- hook :: Spec -> Spec +-- hook = Formatter.whenEnabled Formatter.add +-- @ +module Test.Hspec.JUnit.Formatter.Env + ( whenEnabled + , use + , add + , register + , formatter + , module Api + ) where + +import Prelude + +import Test.Hspec.Api.Format.V1 as Api +import Test.Hspec.Core.Spec (runIO) +import Test.Hspec.JUnit.Config +import Test.Hspec.JUnit.Config.Env +import qualified Test.Hspec.JUnit.Formatter as JUnit + +whenEnabled :: (SpecWith a -> SpecWith a) -> SpecWith a -> SpecWith a +whenEnabled hook spec = do + enabled <- runIO envJUnitEnabled + if enabled then hook spec else spec + +withConfig + :: (JUnitConfig -> SpecWith a -> SpecWith a) -> SpecWith a -> SpecWith a +withConfig toHook spec = do + config <- runIO envJUnitConfig + toHook config spec + +use :: SpecWith a -> SpecWith a +use = withConfig JUnit.use + +add :: SpecWith a -> SpecWith a +add = withConfig JUnit.add + +register :: SpecWith a -> SpecWith a +register = withConfig JUnit.register + +formatter :: IO (String, FormatConfig -> IO Format) +formatter = JUnit.formatter <$> envJUnitConfig diff --git a/library/Test/Hspec/JUnit/Render.hs b/library/Test/Hspec/JUnit/Render.hs --- a/library/Test/Hspec/JUnit/Render.hs +++ b/library/Test/Hspec/JUnit/Render.hs @@ -5,31 +5,41 @@ import Prelude import Control.Monad.Catch (MonadThrow) +import qualified Data.Array as Array import Data.Conduit (ConduitT, awaitForever, mergeSource, yield, (.|)) import qualified Data.Conduit.List as CL import Data.Foldable (traverse_) import Data.Text (Text, pack) +import qualified Data.Text as Text import Data.Time.ISO8601 (formatISO8601) import Data.XML.Types (Event) import Test.Hspec.JUnit.Schema - (Location(..), Result(..), Suite(..), Suites(..), TestCase(..)) + ( Location (..) + , Result (..) + , Suite (..) + , Suites (..) + , TestCase (..) + ) import Text.Printf +import qualified Text.Regex.Base as Regex +import qualified Text.Regex.TDFA.Text as Regex import Text.XML.Stream.Render (attr, content, tag) -renderJUnit :: MonadThrow m => ConduitT Suites Event m () -renderJUnit = awaitForever $ \Suites {..} -> - tag "testsuites" (attr "name" suitesName) - $ CL.sourceList suitesSuites - .| mergeSource idStream - .| suite - where idStream = CL.iterate (+ 1) 0 +renderJUnit :: MonadThrow m => Bool -> ConduitT Suites Event m () +renderJUnit shouldDropConsoleFormatting = awaitForever $ \Suites {..} -> + tag "testsuites" (attr "name" suitesName) $ + CL.sourceList suitesSuites + .| mergeSource idStream + .| suite shouldDropConsoleFormatting + where + idStream = CL.iterate (+ 1) 0 -suite :: MonadThrow m => ConduitT (Int, Suite) Event m () -suite = awaitForever $ \(i, theSuite@Suite {..}) -> +suite :: MonadThrow m => Bool -> ConduitT (Int, Suite) Event m () +suite shouldDropConsoleFormatting = awaitForever $ \(i, theSuite@Suite {..}) -> tag "testsuite" (attributes i theSuite) $ do tag "properties" mempty mempty CL.sourceList suiteCases .| do - awaitForever $ \x -> yield x .| testCase + awaitForever $ \x -> yield x .| testCase shouldDropConsoleFormatting where -- TODO these need to be made real values attributes i Suite {..} = @@ -41,26 +51,26 @@ <> attr "hostname" "localhost" <> attr "tests" (tshow $ length suiteCases) <> attr - "failures" - (tshow - $ length [ () | Just Failure{} <- testCaseResult <$> suiteCases ] - ) + "failures" + ( tshow $ + length [() | Just Failure {} <- testCaseResult <$> suiteCases] + ) <> attr "errors" "0" <> attr - "skipped" - (tshow - $ length [ () | Just Skipped{} <- testCaseResult <$> suiteCases ] - ) + "skipped" + ( tshow $ + length [() | Just Skipped {} <- testCaseResult <$> suiteCases] + ) tshow :: Show a => a -> Text tshow = pack . show -testCase :: MonadThrow m => ConduitT TestCase Event m () -testCase = +testCase :: MonadThrow m => Bool -> ConduitT TestCase Event m () +testCase shouldDropConsoleFormatting = awaitForever $ \(TestCase mLocation className name duration mResult) -> - tag "testcase" (attributes mLocation className name duration) - $ traverse_ yield mResult - .| result + tag "testcase" (attributes mLocation className name duration) $ + traverse_ yield mResult + .| result shouldDropConsoleFormatting where attributes mLocation className name duration = maybe mempty (attr "file" . pack . locationFile) mLocation @@ -69,15 +79,34 @@ <> attr "classname" className <> attr "time" (roundToStr duration) -result :: MonadThrow m => ConduitT Result Event m () -result = awaitForever go +result :: MonadThrow m => Bool -> ConduitT Result Event m () +result shouldDropConsoleFormatting = awaitForever go where go (Failure fType contents) = - tag "failure" (attr "type" fType) $ content contents - go (Skipped contents) = tag "skipped" mempty $ content contents + tag "failure" (attr "type" fType) $ content $ dropConsoleFormatting contents + go (Skipped contents) = tag "skipped" mempty $ content $ dropConsoleFormatting contents + -- Drops ANSI control characters which might be used to set colors. + -- Including these breaks XML, there is not much point encoding them. + dropConsoleFormatting :: Text -> Text + dropConsoleFormatting input + | shouldDropConsoleFormatting = + let + regex = Regex.makeRegex (pack "\x1b\\[[0-9;]*[mGKHF]") :: Regex.Regex + matches = Regex.matchAll regex input + dropMatch (offset, len) input' = + let + (begining, rest) = Text.splitAt offset input' + (_, end) = Text.splitAt len rest + in + begining <> end + matchTuples = map (Array.! 0) matches + in + foldr dropMatch input matchTuples + | otherwise = input + sumDurations :: [TestCase] -> Double sumDurations cases = sum $ testCaseDuration <$> cases -roundToStr :: (PrintfArg a) => a -> Text +roundToStr :: PrintfArg a => a -> Text roundToStr = pack . printf "%0.9f" diff --git a/library/Test/Hspec/JUnit/Schema.hs b/library/Test/Hspec/JUnit/Schema.hs --- a/library/Test/Hspec/JUnit/Schema.hs +++ b/library/Test/Hspec/JUnit/Schema.hs @@ -1,9 +1,9 @@ module Test.Hspec.JUnit.Schema - ( Suites(..) - , Suite(..) - , TestCase(..) - , Location(..) - , Result(..) + ( Suites (..) + , Suite (..) + , TestCase (..) + , Location (..) + , Result (..) ) where import Prelude @@ -16,14 +16,14 @@ { suitesName :: Text , suitesSuites :: [Suite] } - deriving stock Show + deriving stock (Show) data Suite = Suite { suiteName :: Text , suiteTimestamp :: UTCTime , suiteCases :: [TestCase] } - deriving stock Show + deriving stock (Show) data TestCase = TestCase { testCaseLocation :: Maybe Location @@ -32,13 +32,13 @@ , testCaseDuration :: Double , testCaseResult :: Maybe Result } - deriving stock Show + deriving stock (Show) data Location = Location { locationFile :: FilePath , locationLine :: Natural } - deriving stock Show + deriving stock (Show) data Result = Failure Text Text | Skipped Text - deriving stock Show + deriving stock (Show) diff --git a/tests/ExampleSpec.hs b/tests/ExampleSpec.hs --- a/tests/ExampleSpec.hs +++ b/tests/ExampleSpec.hs @@ -2,9 +2,10 @@ -- -- The path name and line numbers of this file are part of the golden report -- being tested with. So if this file changes, they will need to be regenerated. --- +-- In fact, this sentence was added to retain them across a formatting change. module ExampleSpec (spec) where +import Control.Exception import Prelude import Test.Hspec @@ -24,3 +25,11 @@ True `shouldBe` True it "gets skipped" $ do pendingWith "some reason" + it "throws a colourful exception" $ do + throwIO ColourfulException :: IO () + +data ColourfulException = ColourfulException + deriving stock (Show) + +instance Exception ColourfulException where + displayException _ = "\x1b[32mColour\x1b[31mful\x1b[0mException" diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,56 +12,74 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import qualified ExampleSpec -import System.FilePath (()) +import System.FilePath ((<.>), ()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Test.Hspec.JUnit +import Test.Hspec.Golden +import Test.Hspec.JUnit.Config +import qualified Test.Hspec.JUnit.Formatter as Formatter import Test.Hspec.Runner import qualified Text.XML as XML main :: IO () main = hspec $ do describe "XML output" $ do - it "matches golden file" $ do - withJUnitReport ExampleSpec.spec $ \doc -> do - golden <- XML.readFile XML.def goldenPath - normalizeDoc doc `shouldBe` normalizeDoc golden + it "matches golden file" $ + junitGolden "default" id - it "matches golden file with prefixing" $ do - let modify = setJUnitConfigSourcePathPrefix "lol/monorepo" + it "matches golden file with prefixing" $ + junitGolden "prefixed" $ + setJUnitConfigSourcePathPrefix "lol/monorepo" - withJUnitReportConfig modify ExampleSpec.spec $ \doc -> do - golden <- XML.readFile XML.def goldenPrefixedPath - normalizeDoc doc `shouldBe` normalizeDoc golden +-- | Run @ExampleSpec.spec@ and compare XML to a golden file +junitGolden + :: String + -- ^ Unique name + -> (JUnitConfig -> JUnitConfig) + -- ^ Any modification to make to the 'JUnitConfig' before running + -> IO (Golden XML.Document) +junitGolden name modifyConfig = do + actual <- withSystemTempDirectory "" $ \tmp -> do + let junitConfig = + modifyConfig $ + setJUnitConfigOutputDirectory tmp $ + setJUnitConfigOutputName "test.xml" $ + defaultJUnitConfig "hspec-junit-format" -withJUnitReport :: Spec -> (XML.Document -> IO ()) -> IO () -withJUnitReport = withJUnitReportConfig id + void $ runSpec' $ Formatter.use junitConfig ExampleSpec.spec + readNormalizedXML $ tmp "test.xml" -withJUnitReportConfig - :: (JUnitConfig -> JUnitConfig) -> Spec -> (XML.Document -> IO ()) -> IO () -withJUnitReportConfig modifyConfig spec f = - withSystemTempDirectory "" $ \tmp -> do - let - path = tmp "test.xml" - junitConfig = - modifyConfig - $ setJUnitConfigOutputDirectory tmp - $ setJUnitConfigOutputName "test.xml" - $ defaultJUnitConfig "hspec-junit-format" - hspecConfig = configWithJUnit junitConfig defaultConfig - void $ runSpec spec hspecConfig - f =<< XML.readFile XML.def path + pure + Golden + { output = actual + , encodePretty = show + , writeToFile = XML.writeFile XML.def + , readFromFile = readNormalizedXML + , goldenFile = + "tests" "golden" name <> "-" <> ghcSuffix <.> "xml" + , actualFile = Nothing + , failFirstTime = False + } +runSpec' :: Spec -> IO () +runSpec' spec = do + (config, forest) <- evalSpec defaultConfig spec + void $ runSpecForest forest config + +readNormalizedXML :: FilePath -> IO XML.Document +readNormalizedXML = fmap normalizeDoc . XML.readFile XML.def + normalizeDoc :: XML.Document -> XML.Document normalizeDoc = removeWhitespaceNodes . removeTimeAttributes removeWhitespaceNodes :: XML.Document -> XML.Document -removeWhitespaceNodes doc = doc - { XML.documentRoot = go $ XML.documentRoot doc - } +removeWhitespaceNodes doc = + doc + { XML.documentRoot = go $ XML.documentRoot doc + } where go el = - el { XML.elementNodes = concatMap filterWhitespace $ XML.elementNodes el } + el {XML.elementNodes = concatMap filterWhitespace $ XML.elementNodes el} filterWhitespace :: XML.Node -> [XML.Node] filterWhitespace = \case @@ -75,36 +93,28 @@ removeAttributesByName "time" . removeAttributesByName "timestamp" removeAttributesByName :: XML.Name -> XML.Document -> XML.Document -removeAttributesByName name doc = doc - { XML.documentRoot = go $ XML.documentRoot doc - } - where - go el = el - { XML.elementAttributes = Map.delete name $ XML.elementAttributes el - , XML.elementNodes = map (onNodeElement go) $ XML.elementNodes el +removeAttributesByName name doc = + doc + { XML.documentRoot = go $ XML.documentRoot doc } + where + go el = + el + { XML.elementAttributes = Map.delete name $ XML.elementAttributes el + , XML.elementNodes = map (onNodeElement go) $ XML.elementNodes el + } onNodeElement f = \case XML.NodeElement el -> XML.NodeElement $ f el n -> n --- GHC 9 changes the bounds of the SrcLoc from HasCallStack, which changes the --- line numbers reported by Hspec. Fun. --- --- True `shouldBe` False --- ^ -- Before GHC 9 reports from here (18:7 in golden.xml) --- --- True `shouldBe` False --- ^-- GHC 9 reports from here (18:12 in golden-ghc-9.xml) --- --- We should really re-consider the golden testing approach. If we were instead --- asserting on parsed XML, we'd have a lot more options here. --- -goldenPath, goldenPrefixedPath :: FilePath +-- GHC can change certain aspects, mainly about source-location, so we can +-- incorpate that by tracking separate Golden files as necessary +ghcSuffix :: String #if __GLASGOW_HASKELL__ >= 900 -goldenPath = "tests/golden-ghc-9.xml" -goldenPrefixedPath = "tests/golden-prefixed-ghc-9.xml" +ghcSuffix = "ghc-9" +#elif __GLASGOW_HASKELL__ >= 800 +ghcSuffix = "ghc-8" #else -goldenPath = "tests/golden.xml" -goldenPrefixedPath = "tests/golden-prefixed.xml" +-- Fail to compile on other GHCs #endif diff --git a/tests/golden-prefixed.xml b/tests/golden-prefixed.xml deleted file mode 100644 --- a/tests/golden-prefixed.xml +++ /dev/null @@ -1,61 +0,0 @@ - - - - - lol/monorepo/tests/ExampleSpec.hs:18:7 - -expected: "False" - but got: "True" - - - - - - - - lol/monorepo/tests/ExampleSpec.hs:26:9 -some reason - - - - - diff --git a/tests/golden.xml b/tests/golden.xml deleted file mode 100644 --- a/tests/golden.xml +++ /dev/null @@ -1,61 +0,0 @@ - - - - - tests/ExampleSpec.hs:18:7 - -expected: "False" - but got: "True" - - - - - - - - tests/ExampleSpec.hs:26:9 -some reason - - - - - diff --git a/tests/golden/default-ghc-8.xml b/tests/golden/default-ghc-8.xml new file mode 100644 --- /dev/null +++ b/tests/golden/default-ghc-8.xml @@ -0,0 +1,69 @@ + + + + + tests/ExampleSpec.hs:19:7 + +expected: "False" + but got: "True" + + + + + + + + ColourfulException + + + tests/ExampleSpec.hs:27:9 +some reason + + + + + diff --git a/tests/golden/default-ghc-9.xml b/tests/golden/default-ghc-9.xml new file mode 100644 --- /dev/null +++ b/tests/golden/default-ghc-9.xml @@ -0,0 +1,6 @@ +tests/ExampleSpec.hs:19:12 + +expected: "False" + but got: "True" +ColourfulExceptiontests/ExampleSpec.hs:27:9 +some reason diff --git a/tests/golden/prefixed-ghc-8.xml b/tests/golden/prefixed-ghc-8.xml new file mode 100644 --- /dev/null +++ b/tests/golden/prefixed-ghc-8.xml @@ -0,0 +1,69 @@ + + + + + lol/monorepo/tests/ExampleSpec.hs:19:7 + +expected: "False" + but got: "True" + + + + + + + + ColourfulException + + + lol/monorepo/tests/ExampleSpec.hs:27:9 +some reason + + + + + diff --git a/tests/golden/prefixed-ghc-9.xml b/tests/golden/prefixed-ghc-9.xml new file mode 100644 --- /dev/null +++ b/tests/golden/prefixed-ghc-9.xml @@ -0,0 +1,69 @@ + + + + + lol/monorepo/tests/ExampleSpec.hs:19:12 + +expected: "False" + but got: "True" + + + + + + + + ColourfulException + + + lol/monorepo/tests/ExampleSpec.hs:27:9 +some reason + + + + +