diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Unreleased next version +# 0.5.0.1 + +### Enhancements: + +- JUnit report includes failure location (#60) +- Debug.todo returns callstack of where it was called, not inside of library (#65) + # 0.5.0.0 ### Breaking changes: diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: nri-prelude -version: 0.5.0.0 +version: 0.5.0.1 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -61,6 +61,7 @@ Platform.Internal Test.Internal Test.Reporter.ExitCode + Test.Reporter.Internal Test.Reporter.Junit Test.Reporter.Logfile Test.Reporter.Stdout @@ -133,6 +134,7 @@ Test Test.Internal Test.Reporter.ExitCode + Test.Reporter.Internal Test.Reporter.Junit Test.Reporter.Logfile Test.Reporter.Stdout diff --git a/src/Debug.hs b/src/Debug.hs --- a/src/Debug.hs +++ b/src/Debug.hs @@ -11,6 +11,7 @@ import Basics ((>>)) import Data.Text (pack, unpack) import qualified Debug.Trace +import qualified GHC.Stack as Stack import Text (Text, concat) import qualified Text.Show.Pretty import Prelude (Show, error) @@ -61,6 +62,6 @@ -- -- When you call this it throws an exception with the message you give. That -- exception is catchable... but don't. -todo :: Text -> a +todo :: Stack.HasCallStack => Text -> a todo = - unpack >> error + Stack.withFrozenCallStack (unpack >> error) diff --git a/src/Test/Reporter/Internal.hs b/src/Test/Reporter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reporter/Internal.hs @@ -0,0 +1,92 @@ +module Test.Reporter.Internal where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified GHC.Stack as Stack +import qualified List +import NriPrelude +import qualified System.Console.ANSI as ANSI +import qualified System.Directory +import System.FilePath (()) +import qualified Test.Internal as Internal +import qualified Prelude + +extraLinesOnFailure :: Int +extraLinesOnFailure = 2 + +readSrcLoc :: Internal.SingleTest Internal.Failure -> Prelude.IO (Maybe (Stack.SrcLoc, BS.ByteString)) +readSrcLoc test = + case Internal.body test of + Internal.FailedAssertion _ (Just loc) -> do + cwd <- System.Directory.getCurrentDirectory + let path = cwd Stack.srcLocFile loc + exists <- System.Directory.doesFileExist path + if exists + then do + contents <- BS.readFile path + Prelude.pure (Just (loc, contents)) + else Prelude.pure Nothing + _ -> Prelude.pure Nothing + +renderSrcLoc :: + ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> + Stack.SrcLoc -> + BS.ByteString -> + Builder.Builder +renderSrcLoc styled loc contents = do + let startLine = Prelude.fromIntegral (Stack.srcLocStartLine loc) + let lines = + contents + |> BS.split 10 -- splitting newlines + |> List.drop (startLine - extraLinesOnFailure - 1) + |> List.take (extraLinesOnFailure * 2 + 1) + |> List.indexedMap + ( \i l -> + Builder.intDec + ( Prelude.fromIntegral + <| startLine + i - extraLinesOnFailure + ) + ++ ": " + ++ Builder.byteString l + ) + case lines of + [] -> "" + lines' -> + "\n" + ++ "Expectation failed at " + ++ Builder.stringUtf8 (Stack.srcLocFile loc) + ++ ":" + ++ Builder.intDec (Stack.srcLocStartLine loc) + ++ "\n" + ++ Prelude.foldMap + ( \(nr, line) -> + if nr == extraLinesOnFailure + then styled [red] ("✗ " ++ line) ++ "\n" + else " " ++ styled [dullGrey] line ++ "\n" + ) + (List.indexedMap (,) lines') + ++ "\n" + +sgr :: [ANSI.SGR] -> Builder.Builder +sgr = Builder.stringUtf8 << ANSI.setSGRCode + +red :: ANSI.SGR +red = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red + +yellow :: ANSI.SGR +yellow = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Yellow + +green :: ANSI.SGR +green = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green + +grey :: ANSI.SGR +grey = ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black + +dullGrey :: ANSI.SGR +dullGrey = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Black + +black :: ANSI.SGR +black = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.White + +underlined :: ANSI.SGR +underlined = ANSI.SetUnderlining ANSI.SingleUnderline diff --git a/src/Test/Reporter/Junit.hs b/src/Test/Reporter/Junit.hs --- a/src/Test/Reporter/Junit.hs +++ b/src/Test/Reporter/Junit.hs @@ -9,7 +9,11 @@ where import qualified Control.Exception.Safe as Exception +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as Builder +import qualified Data.ByteString.Lazy import qualified Data.Text +import qualified Data.Text.Encoding as TE import qualified GHC.Stack as Stack import qualified List import NriPrelude @@ -17,31 +21,45 @@ import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Test.Internal as Internal +import qualified Test.Reporter.Internal import qualified Text import qualified Text.XML.JUnit as JUnit +import qualified Tuple import qualified Prelude report :: FilePath.FilePath -> Internal.SuiteResult -> Prelude.IO () report path result = do createPathDirIfMissing path - JUnit.writeXmlReport path (testResults result) + results <- testResults result + JUnit.writeXmlReport path results -testResults :: Internal.SuiteResult -> List JUnit.TestSuite +testResults :: Internal.SuiteResult -> Prelude.IO (List JUnit.TestSuite) testResults result = case result of Internal.AllPassed passed -> List.map renderPassed passed + |> Prelude.pure Internal.OnlysPassed passed skipped -> - List.map renderSkipped skipped - ++ List.map renderPassed passed + Prelude.pure + ( List.map renderSkipped skipped + ++ List.map renderPassed passed + ) Internal.PassedWithSkipped passed skipped -> - List.map renderSkipped skipped - ++ List.map renderPassed passed - Internal.TestsFailed passed skipped failed -> - List.map renderFailed failed - ++ List.map renderSkipped skipped - ++ List.map renderPassed passed - Internal.NoTestsInSuite -> [] + Prelude.pure + ( List.map renderSkipped skipped + ++ List.map renderPassed passed + ) + Internal.TestsFailed passed skipped failed -> do + srcLocs <- + List.map (map Tuple.second) failed + |> Prelude.traverse Test.Reporter.Internal.readSrcLoc + let renderedFailed = List.map2 renderFailed failed srcLocs + Prelude.pure + ( renderedFailed + ++ List.map renderSkipped skipped + ++ List.map renderPassed passed + ) + Internal.NoTestsInSuite -> Prelude.pure [] renderPassed :: Internal.SingleTest Platform.TracingSpan -> JUnit.TestSuite renderPassed test = @@ -54,18 +72,29 @@ JUnit.skipped (Internal.name test) |> JUnit.inSuite (suiteName test) -renderFailed :: Internal.SingleTest (Platform.TracingSpan, Internal.Failure) -> JUnit.TestSuite -renderFailed test = +renderFailed :: + Internal.SingleTest (Platform.TracingSpan, Internal.Failure) -> + Maybe (Stack.SrcLoc, BS.ByteString) -> + JUnit.TestSuite +renderFailed test maybeSrcLoc = case Internal.body test of (tracingSpan, Internal.FailedAssertion msg _) -> - JUnit.failed (Internal.name test) - |> JUnit.stderr msg - |> ( case stackFrame test of - Nothing -> identity - Just frame -> JUnit.failureStackTrace [frame] - ) - |> JUnit.time (duration tracingSpan) - |> JUnit.inSuite (suiteName test) + let msg' = case maybeSrcLoc of + Nothing -> msg + Just (loc, src) -> + Test.Reporter.Internal.renderSrcLoc (\_ -> identity) loc src + |> Builder.toLazyByteString + |> Data.ByteString.Lazy.toStrict + |> TE.decodeUtf8 + |> (\srcStr -> srcStr ++ "\n" ++ msg) + in JUnit.failed (Internal.name test) + |> JUnit.stderr msg' + |> ( case stackFrame test of + Nothing -> identity + Just frame -> JUnit.failureStackTrace [frame] + ) + |> JUnit.time (duration tracingSpan) + |> JUnit.inSuite (suiteName test) (tracingSpan, Internal.ThrewException err) -> JUnit.errored (Internal.name test) |> JUnit.errorMessage "This test threw an exception." diff --git a/src/Test/Reporter/Stdout.hs b/src/Test/Reporter/Stdout.hs --- a/src/Test/Reporter/Stdout.hs +++ b/src/Test/Reporter/Stdout.hs @@ -14,10 +14,10 @@ import qualified List import NriPrelude import qualified System.Console.ANSI as ANSI -import qualified System.Directory -import System.FilePath (()) import qualified System.IO import qualified Test.Internal as Internal +import Test.Reporter.Internal (black, green, grey, red, sgr, underlined, yellow) +import qualified Test.Reporter.Internal import qualified Tuple import qualified Prelude @@ -95,7 +95,8 @@ let amountFailed = List.length failed let amountSkipped = List.length skipped let failures = List.map (map Tuple.second) failed - failuresSrcs <- Prelude.traverse (renderFailureInFile styled) failures + srcLocs <- Prelude.traverse Test.Reporter.Internal.readSrcLoc failures + let failuresSrcs = List.map (renderFailureInFile styled) srcLocs Prelude.pure ( Prelude.foldMap ( \(srcLines, test) -> @@ -125,56 +126,15 @@ ++ "\n" ) -extraLinesOnFailure :: Int -extraLinesOnFailure = 2 - renderFailureInFile :: ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> - Internal.SingleTest Internal.Failure -> - Prelude.IO Builder.Builder -renderFailureInFile styled test = - case Internal.body test of - Internal.FailedAssertion _ (Just loc) -> do - cwd <- System.Directory.getCurrentDirectory - let path = cwd Stack.srcLocFile loc - exists <- System.Directory.doesFileExist path - if exists - then do - contents <- BS.readFile path - let startLine = Prelude.fromIntegral (Stack.srcLocStartLine loc) - let lines = - contents - |> BS.split 10 -- splitting newlines - |> List.drop (startLine - extraLinesOnFailure - 1) - |> List.take (extraLinesOnFailure * 2 + 1) - |> List.indexedMap - ( \i l -> - Builder.intDec - ( Prelude.fromIntegral - <| startLine + i - extraLinesOnFailure - ) - ++ ": " - ++ Builder.byteString l - ) - Prelude.pure <| case lines of - [] -> "" - lines' -> - "\n" - ++ "Expectation failed at " - ++ Builder.stringUtf8 (Stack.srcLocFile loc) - ++ ":" - ++ Builder.intDec (Stack.srcLocStartLine loc) - ++ "\n" - ++ Prelude.foldMap - ( \(nr, line) -> - if nr == extraLinesOnFailure - then styled [red] ("✗ " ++ line) ++ "\n" - else " " ++ styled [dullGrey] line ++ "\n" - ) - (List.indexedMap (,) lines') - ++ "\n" - else Prelude.pure "" - _ -> Prelude.pure "" + Maybe (Stack.SrcLoc, BS.ByteString) -> + Builder.Builder +renderFailureInFile styled maybeSrcLoc = + case maybeSrcLoc of + Just (loc, src) -> + Test.Reporter.Internal.renderSrcLoc styled loc src + Nothing -> "" prettyPath :: ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> @@ -217,27 +177,3 @@ ++ "This is a bug.\n\n" ++ "If you have some time to report the bug it would be much appreciated!\n" ++ "You can do so here: https://github.com/NoRedInk/haskell-libraries/issues" - -sgr :: [ANSI.SGR] -> Builder.Builder -sgr = Builder.stringUtf8 << ANSI.setSGRCode - -red :: ANSI.SGR -red = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red - -yellow :: ANSI.SGR -yellow = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Yellow - -green :: ANSI.SGR -green = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Green - -grey :: ANSI.SGR -grey = ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black - -dullGrey :: ANSI.SGR -dullGrey = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Black - -black :: ANSI.SGR -black = ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.White - -underlined :: ANSI.SGR -underlined = ANSI.SetUnderlining ANSI.SingleUnderline diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs --- a/tests/TestSpec.hs +++ b/tests/TestSpec.hs @@ -5,6 +5,7 @@ import qualified Data.ByteString.Lazy import qualified Data.Text import qualified Data.Text.IO +import qualified Debug import qualified Expect import qualified Fuzz import qualified GHC.Exts @@ -18,6 +19,7 @@ import qualified Test.Internal as Internal import qualified Test.Reporter.Logfile import qualified Test.Reporter.Stdout +import qualified Text import qualified Prelude tests :: Test @@ -125,7 +127,20 @@ |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), test "source location of `fuzz3` are the file in which the test is defined" <| \_ -> fuzz3 Fuzz.int Fuzz.int Fuzz.int "test 1" (\_ _ _ -> Expect.pass) - |> expectSingleTest (expectSrcFile "tests/TestSpec.hs") + |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), + test "Debug.todo gives reasonable stack traces" <| \_ -> do + contents <- + Expect.fromIO + ( do + Exception.handle + ( \(exception :: Exception.SomeException) -> + Exception.displayException exception + |> Text.fromList + |> Prelude.pure + ) + (Debug.todo "foo" :: Prelude.IO Text) + ) + Expect.equalToContentsOf "tests/golden-results/debug-todo-stacktrace" contents ] floatComparison :: Test