diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,12 +1,27 @@ +# Unreleased next version + +# 0.5.0.0 + +### Breaking changes: + +- replace Log.userIs\* functions with more standard debug, info, warn, error (#48) + +### Enhancements: + +- Improved diff representation in failing tests. (#40, #41, #43, #44) +- Ported floating point comparison expectations from elm-test. (#41, #42) + - FloatingPointTolerance (..), within, notWithin +- Expect.equalToContentsOf now includes proper stack traces (is this a bugfix? Let's call it an enhancement.) (#40) + # 0.4.0.0 -Breraking changes: +### Breaking changes: - `Expect.Task` has been removed. Most of it's functionality has been moved into `Expect`. - `Test.task` has been removed. Regular `Test.test` now supports monadic-style test writing. - `Expect.concat` has been removed. `do`-notation can now be used to run multiple expectations. -Enhancements: +### Enhancements: - Test failure diffs now look much nicer if they contain multi-line output. - Test failures now show a snippet of the source code around the location of the failure. @@ -15,21 +30,21 @@ # 0.3.1.0 -Enhancements: +### Enhancements: - `Platform.summary` can be used to decorate tracing spans with a text summary for use in dev tooling. - `Platform.writeSpanToDevLog` can be used to write a span for consumption by the new `log-explorer` tool. # 0.3.0.0 -Breaking changs: +### Breaking changes: - `Test.fromTestTree` has been removed. - `Fuzz.Fuzzer` is now an opague type and no a synonomy for `Hedgehog.Gen`. - `Expect.Task.TestFailure` renamed to `Expect.Task.failure`. - `Test.Runner.Tasy.main` renamed to `Test.run`. -Enhancements: +### Enhancements: - Test reports now show source locations of failing tests. - `Fuzz` module has been extended and now covers almost the entire API of its Elm counterpart. diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack --- --- hash: 9de151f00a54609abe9dc131919b9b3ee60e55d86f4b08a01e852b2a62b118f5 name: nri-prelude -version: 0.4.0.0 +version: 0.5.0.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -86,7 +84,7 @@ , ghc >=8.6.1 && <8.11 , hedgehog >=1.0.2 && <1.1 , junit-xml >=0.1.0.0 && <0.2.0.0 - , pretty-diff >=0.4.0.0 && <0.5 + , pretty-diff >=0.4.0.2 && <0.5 , pretty-show >=1.9.5 && <1.11 , safe-exceptions >=0.1.7.0 && <1.3 , terminal-size >=0.3.2.1 && <0.4 @@ -161,7 +159,7 @@ , ghc >=8.6.1 && <8.11 , hedgehog >=1.0.2 && <1.1 , junit-xml >=0.1.0.0 && <0.2.0.0 - , pretty-diff >=0.4.0.0 && <0.5 + , pretty-diff >=0.4.0.2 && <0.5 , pretty-show >=1.9.5 && <1.11 , safe-exceptions >=0.1.7.0 && <1.3 , terminal-size >=0.3.2.1 && <0.4 diff --git a/src/Expect.hs b/src/Expect.hs --- a/src/Expect.hs +++ b/src/Expect.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RankNTypes #-} --- | A library to create @Expectation@s, which describe a claim to be tested. +-- | A library to create @Expectation@s, which describe a claim to be tested. -- -- = Quick Reference -- @@ -20,6 +20,11 @@ all, equalToContentsOf, + -- * Floating Point Comparisons + FloatingPointTolerance (..), + within, + notWithin, + -- * Numeric Comparisons lessThan, atMost, @@ -265,6 +270,67 @@ atLeast :: (Stack.HasCallStack, Show a, Ord a) => a -> a -> Expectation atLeast = Stack.withFrozenCallStack assert (<=) "Expect.atLeast" +-- | A type to describe how close a floating point number must be to the +-- expected value for the test to pass. This may be specified as absolute or +-- relative. +-- +-- 'AbsoluteOrRelative' tolerance uses a logical OR between the absolute +-- (specified first) and relative tolerance. If you want a logical AND, use +-- 'Expect.all'. +data FloatingPointTolerance + = Absolute Float + | Relative Float + | AbsoluteOrRelative Float Float + deriving (Show) + +-- | Passes if the second and third arguments are equal within a tolerance +-- specified by the first argument. This is intended to avoid failing because +-- of minor inaccuracies introduced by floating point arithmetic. +-- +-- > -- Fails because 0.1 + 0.2 == 0.30000000000000004 (0.1 is non-terminating in base 2) +-- > 0.1 + 0.2 |> Expect.equal 0.3 +-- > +-- > -- So instead write this test, which passes +-- > 0.1 + 0.2 |> Expect.within (Absolute 0.000000001) 0.3 +-- +-- Failures resemble code written in pipeline style, so you can tell which argument is which: +-- +-- > -- Fails because 3.14 is not close enough to pi +-- > 3.14 |> Expect.within (Absolute 0.0001) pi +-- > +-- > {- +-- > +-- > 3.14 +-- > ╷ +-- > │ Expect.within Absolute 0.0001 +-- > ╵ +-- > 3.141592653589793 +-- > +-- > -} +within :: (Stack.HasCallStack) => FloatingPointTolerance -> Float -> Float -> Expectation +within tolerance = + Stack.withFrozenCallStack + assert + (withinHelper tolerance) + ("Expect.within " ++ Data.Text.pack (Prelude.show tolerance)) + +-- | Passes if (and only if) a call to within with the same arguments would have failed. +notWithin :: (Stack.HasCallStack) => FloatingPointTolerance -> Float -> Float -> Expectation +notWithin tolerance = + Stack.withFrozenCallStack + assert + (\expected actual -> not (withinHelper tolerance expected actual)) + ("Expect.notWithin " ++ Data.Text.pack (Prelude.show tolerance)) + +withinHelper :: FloatingPointTolerance -> Float -> Float -> Bool +withinHelper tolerance expected actual = + case tolerance of + Absolute absTolerance -> abs (actual - expected) <= absTolerance + Relative relTolerance -> abs (actual - expected) / expected <= relTolerance + AbsoluteOrRelative absTolerance relTolerance -> + withinHelper (Absolute absTolerance) expected actual + || withinHelper (Relative relTolerance) expected actual + -- | Passes if the argument is 'True', and otherwise fails with the given message. -- -- > Expect.true "Expected the list to be empty." (List.isEmpty []) @@ -283,7 +349,10 @@ -- > -- > -} true :: Stack.HasCallStack => Bool -> Expectation -true x = Stack.withFrozenCallStack assert (&&) "Expect.true" x True +true x = + if x + then Stack.withFrozenCallStack Internal.pass "Expect.true" () + else Stack.withFrozenCallStack Internal.failAssertion "Expect.true" "I expected a True but got False" -- | Passes if the argument is 'False', and otherwise fails with the given message. -- @@ -303,7 +372,10 @@ -- > -- > -} false :: Stack.HasCallStack => Bool -> Expectation -false x = Stack.withFrozenCallStack assert xor "Expect.false" x True +false x = + if x + then Stack.withFrozenCallStack Internal.failAssertion "Expect.false" "I expected a False but got True" + else Stack.withFrozenCallStack Internal.pass "Expect.false" () -- | Passes if each of the given functions passes when applied to the subject. -- @@ -429,7 +501,7 @@ -- encodings. When a test fails we can throw away the file, rerun the test, and -- use @git diff golden-results/complicated-object.txt@ to check whether the -- changes are acceptable. -equalToContentsOf :: Text -> Text -> Expectation +equalToContentsOf :: Stack.HasCallStack => Text -> Text -> Expectation equalToContentsOf filepath' actual = do let filepath = Data.Text.unpack filepath' exists <- @@ -442,14 +514,14 @@ Stack.withFrozenCallStack assert (==) - "Expect.equalToContentsOf" + ("Expect.equalToContentsOf " ++ filepath') (UnescapedShow expected) (UnescapedShow actual) else do fromIO (Data.Text.IO.writeFile filepath actual) Stack.withFrozenCallStack Internal.pass - "Expect.equalToContentsOf" + ("Expect.equalToContentsOf " ++ filepath') () -- By default we will compare values with each other after they have been @@ -473,16 +545,16 @@ show (UnescapedShow text) = Data.Text.unpack text assert :: (Stack.HasCallStack, Show a) => (a -> a -> Bool) -> Text -> a -> a -> Expectation -assert pred funcName actual expected = - if pred actual expected +assert pred funcName expected actual = + if pred expected actual then Stack.withFrozenCallStack Internal.pass funcName () else do window <- fromIO Terminal.size let terminalWidth = case window of Just Terminal.Window {Terminal.width} -> width - 4 -- indentation Nothing -> 80 - let expectedText = Data.Text.pack (Text.Show.Pretty.ppShow expected) - let actualText = Data.Text.pack (Text.Show.Pretty.ppShow actual) + let expectedText = Data.Text.pack (Text.Show.Pretty.ppShow actual) + let actualText = Data.Text.pack (Text.Show.Pretty.ppShow expected) let numLines text = List.length (Data.Text.lines text) Stack.withFrozenCallStack Internal.failAssertion funcName <| Diff.pretty diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -10,11 +10,10 @@ -- This module does not have an Elm counterpart. module Log ( -- * Logging + debug, info, - userIsAnnoyed, - userIsConfused, - userIsPained, - userIsBlocked, + warn, + error, withContext, context, @@ -26,8 +25,6 @@ -- * For use in observability modules Context (..), LogContexts (..), - TriageInfo (..), - Impact (..), ) where @@ -41,6 +38,21 @@ import qualified Text.Show import qualified Prelude +-- | A log message that is probably only useful in development, or when we're +-- really confused about something and need ALL THE CONTEXT. +-- +-- In addition to a log message you can pass additional key-value pairs with +-- information that might be relevant for debugging. +-- +-- > debug "Computation partially succeeded" [context "answer" 2] +debug :: Stack.HasCallStack => Text -> [Context] -> Task e () +debug message contexts = + Stack.withFrozenCallStack + log + message + ReportAsSucceeded + (Context "level" Debug : contexts) + -- | A log message useful for when things have gone off the rails. -- We should have a ton of messages at this level. -- It should help us out when we're dealing with something hard. @@ -50,52 +62,43 @@ -- -- > info "I added 1 and 1" [context "answer" 2] info :: Stack.HasCallStack => Text -> [Context] -> Task e () -info message contexts = Stack.withFrozenCallStack log message ReportAsSucceeded contexts +info message contexts = + Stack.withFrozenCallStack + log + message + ReportAsSucceeded + (Context "level" Info : contexts) --- | A log message when the user is annoyed, but not blocked. +-- | A log message when something went wrong, but it did not go wrong in a way +-- to totally break the thing we're doing. These should be triaged and fixed +-- soon, but aren't show-stoppers. -- --- > Log.userIsAnnoyed --- > "We poked the user unnecessarily." --- > "Try to stop poking the user." --- > [ Log.context "The type of poking stick" poker ] -userIsAnnoyed :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e () -userIsAnnoyed message advisory contexts = - let triage = TriageInfo UserAnnoyed advisory - in Stack.withFrozenCallStack - log - message - ReportAsFailed - (Context "triage" triage : contexts) - --- | Like 'userIsAnnoyed', but when the user is userIsConfused. -userIsConfused :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e () -userIsConfused message advisory contexts = - let triage = TriageInfo UserConfused advisory - in Stack.withFrozenCallStack - log - message - ReportAsFailed - (Context "triage" triage : contexts) - --- | Like 'userIsAnnoyed', but when the user is in pain. -userIsPained :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e () -userIsPained message advisory contexts = - let triage = TriageInfo UserInPain advisory - in Stack.withFrozenCallStack - log - message - ReportAsFailed - (Context "triage" triage : contexts) +-- In addition to a log message you can pass additional key-value pairs with +-- information that might be relevant for debugging. +-- +-- > warn "This field was sent, but we're gonna deprecate it!" [] +warn :: Stack.HasCallStack => Text -> [Context] -> Task e () +warn message contexts = + Stack.withFrozenCallStack + log + message + ReportAsFailed + (Context "level" Warn : contexts) --- | Like 'userIsAnnoyed', but when the user is blocked. -userIsBlocked :: Stack.HasCallStack => Text -> Text -> [Context] -> Task e () -userIsBlocked message advisory contexts = - let triage = TriageInfo UserBlocked advisory - in Stack.withFrozenCallStack - log - message - ReportAsFailed - (Context "triage" triage : contexts) +-- | A log message when we can't continue with what we were trying to do +-- because of a problem. +-- +-- In addition to a log message you can pass additional key-value pairs with +-- information that might be relevant for debugging. +-- +-- > error "The user tried to request this thing, but they aren't allowed!" [] +error :: Stack.HasCallStack => Text -> [Context] -> Task e () +error message contexts = + Stack.withFrozenCallStack + log + message + ReportAsFailed + (Context "level" Error : contexts) -- | Mark a block of code as a logical unit by giving it a name. This name will -- be used in logs and monitoring dashboards, so use this function to help @@ -216,37 +219,14 @@ -- TRIAGE -- --- | A logged message for log levels warning and above. Because these levels --- indicate a (potential) problem we want to provide some additional data that --- would help a triager figure out what next steps to take. -data TriageInfo = TriageInfo - { impact :: Impact, - advisory :: Text - } +data LogLevel + = Debug + | Info + | Warn + | Error deriving (Generic) -instance Aeson.ToJSON TriageInfo - --- | Classification of the levels of impact an issue might have on end-users. -data Impact - = UserAnnoyed - | UserConfused - | UserInPain - | UserBlocked - deriving (Show) - -instance Aeson.ToJSON Impact where - toJSON = Aeson.toJSON << impactToText - - toEncoding = Aeson.toEncoding << impactToText - -impactToText :: Impact -> Text -impactToText kind = - case kind of - UserAnnoyed -> "This is causing inconveniences to users but they will be able to achieve want they want." - UserBlocked -> "User is blocked from performing an action." - UserConfused -> "The UI did something unexpected and it's unclear why." - UserInPain -> "This is causing pain to users and workaround is not obvious." +instance Aeson.ToJSON LogLevel -- ReportAsFailed marks the request as a failure in logging, but has no impact on the resulting Task. E.g. will not trigger a 500 error but will report an error to, e.g. BugSnag. data ReportStatus = ReportAsFailed | ReportAsSucceeded diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -19,6 +19,7 @@ where import qualified Control.Concurrent.Async as Async +import qualified GHC.IO.Encoding import qualified GHC.Stack as Stack import NriPrelude import qualified Platform @@ -45,6 +46,9 @@ -- > main = Test.run (Test.todo "write your tests here!") run :: Stack.HasCallStack => Internal.Test -> Prelude.IO () run suite = do + -- Work around `hGetContents: invalid argument (invalid byte sequence)` bug on + -- Nix: https://github.com/dhall-lang/dhall-haskell/issues/865 + GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 log <- Platform.silentHandler (results, logExplorerAvailable) <- Async.concurrently diff --git a/tests/LogSpec.hs b/tests/LogSpec.hs --- a/tests/LogSpec.hs +++ b/tests/LogSpec.hs @@ -31,48 +31,45 @@ spans |> Debug.toString |> Expect.equalToContentsOf "tests/golden-results/log-info", - test "`userIsAnnoyed` produces expected debugging info" <| \_ -> do + test "`debug` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler _ <- - userIsAnnoyed - "the button didn't work" - "fix the button" + debug + "pressed the button" [context "button" ("PRESS" :: Text)] |> Task.attempt handler recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-annoyed", - test "`userIsPained` produces expected debugging info" <| \_ -> do + |> Expect.equalToContentsOf "tests/golden-results/debug", + test "`warn` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler _ <- - userIsPained + warn "user cut themselves on the modal" - "file modal's sharp edges" [context "modal" ("SURPRISE!" :: Text)] |> Task.attempt handler recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-pained", - test "`userIsBlocked` produces expected debugging info" <| \_ -> do + |> Expect.equalToContentsOf "tests/golden-results/warn", + test "`error` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler _ <- - userIsBlocked + error "door is blocked" - "find key" [context "house number" (5 :: Int)] |> Task.attempt handler recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-blocked", + |> Expect.equalToContentsOf "tests/golden-results/error", test "nested spans pruduce expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs --- a/tests/TestSpec.hs +++ b/tests/TestSpec.hs @@ -25,6 +25,7 @@ describe "Test" [ api, + floatComparison, stdoutReporter, logfileReporter ] @@ -127,6 +128,21 @@ |> expectSingleTest (expectSrcFile "tests/TestSpec.hs") ] +floatComparison :: Test +floatComparison = + describe + "Float comparison expectations" + [ test "Expect.within" <| \_ -> do + Expect.within (Expect.Absolute 1) 0.1 0.5 + Expect.within (Expect.Relative 1) 3 5 + Expect.within (Expect.AbsoluteOrRelative 1 1) 0.1 0.5 + Expect.within (Expect.AbsoluteOrRelative 1 1) 3 5, + test "Expect.notWithin" <| \_ -> do + Expect.notWithin (Expect.Absolute 1) 3 5 + Expect.notWithin (Expect.Relative 1) 0.1 0.5 + Expect.notWithin (Expect.AbsoluteOrRelative 1 1) 3 10 + ] + expectSingleTest :: (Internal.SingleTest Internal.Expectation -> Expect.Expectation) -> Test -> @@ -256,29 +272,30 @@ let suite = describe "suite loc" - [ test "test 1" (\_ -> Expect.fail "fail"), - test "test 2" (\_ -> Expect.equal True False), - test "test 3" (\_ -> Expect.notEqual True True), + [ test "test fail" (\_ -> Expect.fail "fail"), + test "test equal" (\_ -> Expect.equal True False), + test "test notEqual" (\_ -> Expect.notEqual True True), test - "test 4" + "test all" ( \_ -> True |> Expect.all [ Expect.equal False ] ), - test "test 5" (\_ -> Expect.lessThan 1 (2 :: Int)), - test "test 6" (\_ -> Expect.atMost 1 (2 :: Int)), - test "test 7" (\_ -> Expect.greaterThan 2 (1 :: Int)), - test "test 8" (\_ -> Expect.atLeast 2 (1 :: Int)), - test "test 9" (\_ -> Expect.atLeast 2 (1 :: Int)), - test "test 10" (\_ -> Expect.true False), - test "test 11" (\_ -> Expect.false True), - test "test 12" (\_ -> Expect.ok (Err ())), - test "test 13" (\_ -> Expect.err (Ok ())), - test "test 14" (\_ -> Expect.succeeds (Task.fail "oops")), - test "test 15" (\_ -> Expect.fails (Task.succeed "oops")), - test "test 16" (\_ -> Task.succeed (1 :: Int) |> Expect.andCheck (Expect.equal 2) |> map (\_ -> ())) + test "test lessThan" (\_ -> Expect.lessThan 1 (2 :: Int)), + test "test astMost" (\_ -> Expect.atMost 1 (2 :: Int)), + test "test greatherThan" (\_ -> Expect.greaterThan 2 (1 :: Int)), + test "test atLeast" (\_ -> Expect.atLeast 2 (1 :: Int)), + test "test within" (\_ -> Expect.within (Expect.Absolute 0.1) 1 2), + test "test notWithin" (\_ -> Expect.notWithin (Expect.Relative 0.1) 1 1), + test "test true" (\_ -> Expect.true False), + test "test false" (\_ -> Expect.false True), + test "test ok" (\_ -> Expect.ok (Err ())), + test "test err" (\_ -> Expect.err (Ok ())), + test "test succeeds" (\_ -> Expect.succeeds (Task.fail "oops")), + test "test fails" (\_ -> Expect.fails (Task.succeed "oops")), + test "test andCheck" (\_ -> Task.succeed (1 :: Int) |> Expect.andCheck (Expect.equal 2) |> map (\_ -> ())) ] contents <- withTempFile