nri-prelude 0.5.0.0 → 0.5.0.1
raw patch · 7 files changed
+182/−100 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Debug: todo :: Text -> a
+ Debug: todo :: HasCallStack => Text -> a
Files
- CHANGELOG.md +7/−0
- nri-prelude.cabal +3/−1
- src/Debug.hs +3/−2
- src/Test/Reporter/Internal.hs +92/−0
- src/Test/Reporter/Junit.hs +50/−21
- src/Test/Reporter/Stdout.hs +11/−75
- tests/TestSpec.hs +16/−1
CHANGELOG.md view
@@ -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:
nri-prelude.cabal view
@@ -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 <https://github.com/NoRedInk/haskell-libraries/tree/trunk/nri-prelude>. 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
src/Debug.hs view
@@ -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)
+ src/Test/Reporter/Internal.hs view
@@ -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
src/Test/Reporter/Junit.hs view
@@ -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."
src/Test/Reporter/Stdout.hs view
@@ -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
tests/TestSpec.hs view
@@ -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