hspec-junit-formatter-1.0.2.1: tests/Main.hs

module Main
  ( main
  )
where

import Prelude

import Control.Monad (void)
import qualified Data.Map.Strict as Map
import Data.Text (Text)
import qualified Data.Text as T
import qualified ExampleSpec
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import Test.Hspec
import Test.Hspec.JUnit
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 "tests/golden.xml"
        removeTimeAttributes doc `shouldBe` removeTimeAttributes golden

    it "can prefix source paths" $ do
      let modify = setJUnitConfigSourcePathPrefix "lol/monorepo"

      withJUnitReportConfig modify ExampleSpec.spec $ \doc -> do
        let
          root = XML.documentRoot doc
          hasPrefix = ("lol/monorepo/tests/ExampleSpec.hs" `T.isPrefixOf`)

        elementInnerTexts root `shouldSatisfy` all hasPrefix

withJUnitReport :: Spec -> (XML.Document -> IO ()) -> IO ()
withJUnitReport = withJUnitReportConfig id

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

-- | Remove volatile attributes so they don't invalidate comparison
removeTimeAttributes :: XML.Document -> XML.Document
removeTimeAttributes =
  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
    }

  onNodeElement f = \case
    XML.NodeElement el -> XML.NodeElement $ f el
    n -> n

elementInnerTexts :: XML.Element -> [Text]
elementInnerTexts = concatMap go . XML.elementNodes
 where
  go :: XML.Node -> [Text]
  go = \case
    XML.NodeElement el -> elementInnerTexts el
    XML.NodeContent x -> [x]
    _ -> []