diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,18 @@ +# 0.4.0.0 + +Breraking 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: + +- 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. +- Tests now write to a log file that can be inspected using a new `log-explorer` tool. +- Added `Platform.writeSpanToDevLog` to write to `log-explorer` from your own code. + # 0.3.1.0 Enhancements: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,16 @@ A Prelude inspired by the Elm programming language. +enable ghc option + +``` +-fplugin=NriPrelude.Plugin +``` + +to get default imports (List, Maybe, Debug, etc) + +For tests you're recommended to enable the `ExtendedDefaultRules` language extension, and `-fno-warn-type-defaults` compiler option. + This package re-implements API's and re-uses documentation from [elm-core][] ([license](./licenses/ELM_CORE_LICENSE)) and [elm-test][] ([license](./licenses/ELM_TEST_LICENSE)). [elm-core]: https://github.com/elm/core diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -1,13 +1,13 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.2. -- -- see: https://github.com/sol/hpack -- --- hash: 289dd9fd1e47c8a3adb825dd181635cdff04f29f8f3744acb5e426d735d2c8ab +-- hash: 9de151f00a54609abe9dc131919b9b3ee60e55d86f4b08a01e852b2a62b118f5 name: nri-prelude -version: 0.3.1.0 +version: 0.4.0.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -40,12 +40,12 @@ Debug Dict Expect - Expect.Task Fuzz List Log Maybe NriPrelude + NriPrelude.Plugin Platform Process Result @@ -57,6 +57,7 @@ other-modules: Internal.Shortcut Internal.Terminal + NriPrelude.Plugin.GhcVersionDependent Platform.DevLog Platform.DoAnything Platform.Internal @@ -82,9 +83,10 @@ , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 , filepath >=1.4.2.1 && <1.5 + , 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.1.0.0 && <0.3 + , pretty-diff >=0.4.0.0 && <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 @@ -113,7 +115,6 @@ Debug Dict Expect - Expect.Task Fuzz Internal.Shortcut Internal.Terminal @@ -121,6 +122,8 @@ Log Maybe NriPrelude + NriPrelude.Plugin + NriPrelude.Plugin.GhcVersionDependent Platform Platform.DevLog Platform.DoAnything @@ -141,8 +144,8 @@ hs-source-dirs: tests src - default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators - ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -threaded -rtsopts "-with-rtsopts=-N -T" + default-extensions: DataKinds DeriveGeneric FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving MultiParamTypeClasses NamedFieldPuns NoImplicitPrelude OverloadedStrings PartialTypeSignatures ScopedTypeVariables Strict TypeOperators ExtendedDefaultRules + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -threaded -rtsopts "-with-rtsopts=-N -T" -fno-warn-type-defaults build-depends: aeson >=1.4.6.0 && <1.6 , aeson-pretty >=0.8.0 && <0.9 @@ -155,9 +158,10 @@ , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 , filepath >=1.4.2.1 && <1.5 + , 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.1.0.0 && <0.3 + , pretty-diff >=0.4.0.0 && <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/Array.hs b/src/Array.hs --- a/src/Array.hs +++ b/src/Array.hs @@ -34,20 +34,20 @@ where import Basics - ( (&&), + ( Bool, + Int, + clamp, + (&&), (+), (-), (<), (<=), (<|), (>>), - Bool, - Int, - clamp, ) import qualified Data.Foldable -import qualified Data.Vector import Data.Vector ((!?), (++), (//)) +import qualified Data.Vector import List (List) import qualified List import Maybe (Maybe (..)) diff --git a/src/Char.hs b/src/Char.hs --- a/src/Char.hs +++ b/src/Char.hs @@ -30,11 +30,11 @@ where import Basics - ( (&&), + ( Bool (..), + Int, + (&&), (<<), (<=), - Bool (..), - Int, ) import qualified Data.Char import Prelude (Char, otherwise) diff --git a/src/Debug.hs b/src/Debug.hs --- a/src/Debug.hs +++ b/src/Debug.hs @@ -1,4 +1,4 @@ --- | This module can be useful while _developing_ an application. It should not +-- | This module can be useful while /developing/ an application. It should not -- be used in production. module Debug ( -- * Debugging @@ -24,8 +24,8 @@ -- -- Notice that with strings, this is not the @identity@ function. Ultimately it's -- down to the value's @Show@ instance, but for strings this typically escapes --- characters. If you say @toString "he said, \"hi\""@ it will show @"he said, --- \"hi\""@ rather than @he said, "hi"@. +-- characters. If you say @toString "he said, \\"hi\\""@ it will show @"he said, +-- \\"hi\\""@ rather than @he said, "hi"@. toString :: Show a => a -> Text toString = Text.Show.Pretty.ppShow >> pack diff --git a/src/Dict.hs b/src/Dict.hs --- a/src/Dict.hs +++ b/src/Dict.hs @@ -2,7 +2,7 @@ -- type. This includes @Int@, @Float@, @Time@, @Char@, @String@, and tuples or -- lists of comparable types. -- --- Insert, remove, and query operations all take _O(log n)_ time. +-- Insert, remove, and query operations all take /O(log n)/ time. module Dict ( -- * Dictionaries Dict, @@ -43,10 +43,10 @@ import Basics import qualified Data.Map.Strict -import qualified List import List (List) +import qualified List import Maybe (Maybe (..)) -import Prelude (Ord, fromIntegral, otherwise) +import Prelude (fromIntegral, otherwise) -- DICTIONARIES diff --git a/src/Expect.hs b/src/Expect.hs --- a/src/Expect.hs +++ b/src/Expect.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RankNTypes #-} + -- | A library to create @Expectation@s, which describe a claim to be tested. -- -- = Quick Reference @@ -16,7 +18,7 @@ equal, notEqual, all, - concat, + equalToContentsOf, -- * Numeric Comparisons lessThan, @@ -33,23 +35,28 @@ err, -- * Customizing - - -- | These functions will let you build your own expectations. pass, fail, onFail, + fromResult, + -- * Testing tasks + succeeds, + fails, + andCheck, + -- * Fancy Expectations - equalToContentsOf, - withIO, + fromIO, + Internal.Expectation', + around, ) where import qualified Data.Text import qualified Data.Text.IO import qualified Debug +import qualified GHC.Stack as Stack import qualified List -import List (List) import NriPrelude import qualified Platform.Internal import qualified Pretty.Diff as Diff @@ -57,19 +64,10 @@ import qualified System.Directory as Directory import qualified System.FilePath as FilePath import qualified Task -import qualified Test.Internal as Internal import Test.Internal (Expectation) +import qualified Test.Internal as Internal import qualified Text.Show.Pretty -import Prelude (Eq, IO, Ord, Show, show) - --- | Run some IO and assert the value it produces. --- --- If the IO throws an exception the test will fail. -withIO :: (a -> Expectation) -> IO a -> Expectation -withIO fn io = - fromIO io - |> andThen (Internal.unExpectation << fn) - |> Internal.Expectation +import qualified Prelude -- | Always passes. -- @@ -86,8 +84,8 @@ -- > -- > Err err -> -- > Expect.fail err -pass :: Expectation -pass = Internal.Expectation (Task.succeed Internal.Succeeded) +pass :: Stack.HasCallStack => Expectation +pass = Stack.withFrozenCallStack Internal.pass "Expect.pass" () -- | Fails with the given message. -- @@ -104,27 +102,22 @@ -- > -- > Err err -> -- > Expect.fail err -fail :: Text -> Expectation +fail :: Stack.HasCallStack => Text -> Expectation fail msg = - msg - |> Internal.FailedAssertion - |> Internal.Failed - |> Task.succeed - |> Internal.Expectation + Stack.withFrozenCallStack Internal.failAssertion "Expect.fail" msg -- | If the given expectation fails, replace its failure message with a custom one. -- -- > "something" -- > |> Expect.equal "something else" -- > |> Expect.onFail "thought those two strings would be the same" -onFail :: Text -> Expectation -> Expectation +onFail :: Stack.HasCallStack => Text -> Expectation -> Expectation onFail msg (Internal.Expectation task) = task - |> Task.map - ( \res -> - case res of - Internal.Succeeded -> Internal.Succeeded - Internal.Failed _ -> Internal.Failed (Internal.FailedAssertion msg) + |> Task.onError + ( \_ -> + Stack.withFrozenCallStack Internal.failAssertion "Expect.onFail" msg + |> Internal.unExpectation ) |> Internal.Expectation @@ -149,8 +142,8 @@ -- > [ "Betty Botter", "bought", "some", "butter" ] -- > -- > -} -equal :: (Show a, Eq a) => a -> a -> Expectation -equal = assert (==) "Expect.equal" +equal :: (Stack.HasCallStack, Show a, Eq a) => a -> a -> Expectation +equal = Stack.withFrozenCallStack assert (==) "Expect.equal" -- | Passes if the arguments are not equal. -- @@ -172,8 +165,8 @@ -- > 100 -- > -- > -} -notEqual :: (Show a, Eq a) => a -> a -> Expectation -notEqual = assert (/=) "Expect.notEqual" +notEqual :: (Stack.HasCallStack, Show a, Eq a) => a -> a -> Expectation +notEqual = Stack.withFrozenCallStack assert (/=) "Expect.notEqual" -- | Passes if the second argument is less than the first. -- @@ -197,8 +190,8 @@ -- > -1 -- > -- > -} -lessThan :: (Show a, Ord a) => a -> a -> Expectation -lessThan = assert (>) "Expect.lessThan" +lessThan :: (Stack.HasCallStack, Show a, Ord a) => a -> a -> Expectation +lessThan = Stack.withFrozenCallStack assert (>) "Expect.lessThan" -- | Passes if the second argument is less than or equal to the first. -- @@ -221,8 +214,8 @@ -- > -3 -- > -- > -} -atMost :: (Show a, Ord a) => a -> a -> Expectation -atMost = assert (>=) "Expect.atMost" +atMost :: (Stack.HasCallStack, Show a, Ord a) => a -> a -> Expectation +atMost = Stack.withFrozenCallStack assert (>=) "Expect.atMost" -- | Passes if the second argument is greater than the first. -- @@ -245,8 +238,8 @@ -- > 1 -- > -- > -} -greaterThan :: (Show a, Ord a) => a -> a -> Expectation -greaterThan = assert (<) "Expect.greaterThan" +greaterThan :: (Stack.HasCallStack, Show a, Ord a) => a -> a -> Expectation +greaterThan = Stack.withFrozenCallStack assert (<) "Expect.greaterThan" -- | Passes if the second argument is greater than or equal to the first. -- @@ -269,8 +262,8 @@ -- > 3 -- > -- > -} -atLeast :: (Show a, Ord a) => a -> a -> Expectation -atLeast = assert (<=) "Expect.atLeast" +atLeast :: (Stack.HasCallStack, Show a, Ord a) => a -> a -> Expectation +atLeast = Stack.withFrozenCallStack assert (<=) "Expect.atLeast" -- | Passes if the argument is 'True', and otherwise fails with the given message. -- @@ -289,8 +282,8 @@ -- > Expected the list to be empty. -- > -- > -} -true :: Bool -> Expectation -true x = assert (&&) "Expect.true" x True +true :: Stack.HasCallStack => Bool -> Expectation +true x = Stack.withFrozenCallStack assert (&&) "Expect.true" x True -- | Passes if the argument is 'False', and otherwise fails with the given message. -- @@ -309,8 +302,8 @@ -- > Expected the list not to be empty. -- > -- > -} -false :: Bool -> Expectation -false x = assert xor "Expect.false" x True +false :: Stack.HasCallStack => Bool -> Expectation +false x = Stack.withFrozenCallStack assert xor "Expect.false" x True -- | Passes if each of the given functions passes when applied to the subject. -- @@ -339,26 +332,13 @@ -- > ╵ -- > -10 -- > -} -all :: List (subject -> Expectation) -> subject -> Expectation +all :: Stack.HasCallStack => List (subject -> Expectation) -> subject -> Expectation all expectations subject = List.foldl ( \expectation acc -> Internal.append acc - (expectation subject) - ) - pass - expectations - --- | Combine multiple expectations into one. The resulting expectation is a --- failure if any of the original expectations are a failure. -concat :: List Expectation -> Expectation -concat expectations = - List.foldl - ( \expectation acc -> - Internal.append - acc - expectation + (Stack.withFrozenCallStack expectation subject) ) pass expectations @@ -386,11 +366,19 @@ -- > Err _ -- > -- > -} -ok :: Show b => Result b a -> Expectation +ok :: (Stack.HasCallStack, Show b) => Result b a -> Expectation ok res = case res of - Ok _ -> pass - Err message -> fail ("I expected a Ok but got Err (" ++ Debug.toString message ++ ")") + Ok _ -> + Stack.withFrozenCallStack + Internal.pass + "Expect.ok" + () + Err message -> + Stack.withFrozenCallStack + Internal.failAssertion + "Expect.ok" + ("I expected a Ok but got Err (" ++ Debug.toString message ++ ")") -- | Passes if the Result is an Err rather than Ok. This is useful for tests where you expect to get an error but you don't care what the actual error is. -- @@ -415,11 +403,19 @@ -- > Err _ -- > -- > -} -err :: Show a => Result b a -> Expectation +err :: (Stack.HasCallStack, Show a) => Result b a -> Expectation err res = case res of - Ok value -> fail ("I expected a Err but got Ok (" ++ Debug.toString value ++ ")") - Err _ -> pass + Ok value -> + Stack.withFrozenCallStack + Internal.failAssertion + "Expect.err" + ("I expected a Err but got Ok (" ++ Debug.toString value ++ ")") + Err _ -> + Stack.withFrozenCallStack + Internal.pass + "Expect.err" + () -- | Check if a string is equal to the contents of a file. -- @@ -434,24 +430,27 @@ -- use @git diff golden-results/complicated-object.txt@ to check whether the -- changes are acceptable. equalToContentsOf :: Text -> Text -> Expectation -equalToContentsOf filepath' actual = - Internal.Expectation <| do - let filepath = Data.Text.unpack filepath' - exists <- fromIO <| do +equalToContentsOf filepath' actual = do + let filepath = Data.Text.unpack filepath' + exists <- + fromIO <| do Directory.createDirectoryIfMissing True (FilePath.takeDirectory filepath) Directory.doesFileExist filepath - if exists - then do - expected <- fromIO (Data.Text.IO.readFile filepath) + if exists + then do + expected <- fromIO (Data.Text.IO.readFile filepath) + Stack.withFrozenCallStack assert - (==) - "Expect.equalToContentsOf" - (UnescapedShow expected) - (UnescapedShow actual) - |> Internal.unExpectation - else do - fromIO (Data.Text.IO.writeFile filepath actual) - Internal.unExpectation pass + (==) + "Expect.equalToContentsOf" + (UnescapedShow expected) + (UnescapedShow actual) + else do + fromIO (Data.Text.IO.writeFile filepath actual) + Stack.withFrozenCallStack + Internal.pass + "Expect.equalToContentsOf" + () -- By default we will compare values with each other after they have been -- passed to @show@. Unfortunately @show@ for the @Text@ type escapes special @@ -473,29 +472,149 @@ instance Show UnescapedShow where show (UnescapedShow text) = Data.Text.unpack text -assert :: Show a => (a -> a -> Bool) -> Text -> a -> a -> Expectation +assert :: (Stack.HasCallStack, Show a) => (a -> a -> Bool) -> Text -> a -> a -> Expectation assert pred funcName actual expected = if pred actual expected - then pass - else Internal.Expectation <| do + 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 - Diff.pretty - Diff.Config - { Diff.separatorText = Just funcName, - Diff.wrapping = Diff.Wrap terminalWidth - } - (PrettyShow expected) - (PrettyShow actual) - |> fail - |> Internal.unExpectation + let expectedText = Data.Text.pack (Text.Show.Pretty.ppShow expected) + let actualText = Data.Text.pack (Text.Show.Pretty.ppShow actual) + let numLines text = List.length (Data.Text.lines text) + Stack.withFrozenCallStack Internal.failAssertion funcName + <| Diff.pretty + Diff.Config + { Diff.separatorText = Just funcName, + Diff.wrapping = Diff.Wrap terminalWidth, + Diff.multilineContext = + if numLines expectedText < 6 && numLines actualText < 6 + then Diff.FullContext + else Diff.Surrounding 2 "..." + } + expectedText + actualText -fromIO :: Prelude.IO a -> Task e a -fromIO io = Platform.Internal.Task (\_ -> map Ok io) +-- | Convert an IO type to an expectation. Useful if you need to call a function +-- in Haskell's base library or an external library in a test. +fromIO :: Prelude.IO a -> Internal.Expectation' a +fromIO io = + Platform.Internal.Task (\_ -> map Ok io) + |> Internal.Expectation -newtype PrettyShow a = PrettyShow a +-- | Used for making matchers +-- expectOneItem :: Expectation' [a] -> Expectation' a +-- expectOneItem t = do +-- xs <- t +-- case xs of +-- [x] -> Ok x +-- _ -> Err ("Expected one item, but got " ++ Debug.toString (List.length xs) ++ ".") +-- |> Expect.fromResult +fromResult :: (Stack.HasCallStack, Show b) => Result b a -> Internal.Expectation' a +fromResult (Ok a) = + Stack.withFrozenCallStack + Internal.pass + "Expect.fromResult" + a +fromResult (Err msg) = + Stack.withFrozenCallStack + Internal.failAssertion + "Expect.fromResult" + (Debug.toString msg) -instance Show a => Show (PrettyShow a) where - show (PrettyShow x) = Text.Show.Pretty.ppShow x +-- | Check a task returns an expected value. +-- +-- > test "Greetings are friendly" <| \_ -> do +-- > getGreeting +-- > |> andCheck (Expect.equal "Hi!") +andCheck :: (Stack.HasCallStack, Show err) => (a -> Expectation) -> Task err a -> Internal.Expectation +andCheck expectation task = do + x <- succeeds task + Stack.withFrozenCallStack expectation x + +-- | Check a task succeeds. +-- +-- > test "solve rubicskube" <| \_ -> do +-- > solveRubicsKube +-- > |> succeeds +succeeds :: (Stack.HasCallStack, Show err) => Task err a -> Internal.Expectation' a +succeeds task = + task + |> Task.onError + ( \message -> + Stack.withFrozenCallStack + Internal.failAssertion + "Expect.succeeds" + (Debug.toString message) + |> Internal.unExpectation + ) + |> Task.andThen + ( \a -> + Stack.withFrozenCallStack + Internal.pass + "Expect.succeeds" + a + |> Internal.unExpectation + ) + |> Internal.Expectation + +-- | Check a task fails. +-- +-- > test "chemistry experiment" <| \_ -> do +-- > mixRedAndGreenLiquids +-- > |> fails +fails :: (Stack.HasCallStack, Show a) => Task err a -> Internal.Expectation' err +fails task = + task + |> Task.map (\succ -> Err ("Expected failure but succeeded with " ++ Debug.toString succ)) + |> Task.onError (\err' -> Task.succeed (Ok err')) + |> Task.andThen + ( \res -> + Internal.unExpectation + <| case res of + Ok a -> + Stack.withFrozenCallStack + Internal.pass + "Expect.fails" + a + Err msg -> + Stack.withFrozenCallStack + Internal.failAssertion + "Expect.fails" + (Debug.toString msg) + ) + |> Internal.Expectation + +-- | This can be used to create custom test functions that contain some setup +-- and teardown logic, for example to make tests run in a database transaction +-- that gets rolled back afterwards. +-- +-- > dbTest :: +-- > Stack.HasCallStack => +-- > Text -> +-- > (Db.Connection -> Expect.Expectation) -> +-- > Test.Test +-- > dbTest description body = +-- > Stack.withFrozenCallStack Test.test description <| \_ -> do +-- > Expect.around +-- > ( \task' -> do +-- > conn <- Db.getConnection +-- > Platform.finally +-- > (task' conn) +-- > (Db.rollback conn) +-- > ) +-- > body +around :: + (forall e a. (arg -> Task e a) -> Task e a) -> + (arg -> Expectation) -> + Expectation +around runTask runExpectation = + Internal.Expectation + ( runTask + ( \arg -> + runExpectation arg + |> Internal.unExpectation + ) + ) diff --git a/src/Expect/Task.hs b/src/Expect/Task.hs deleted file mode 100644 --- a/src/Expect/Task.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | A library to create @Expecation@s for @Task@s. -module Expect.Task - ( check, - andCheck, - succeeds, - fails, - Failure, - ) -where - -import qualified Debug -import qualified Expect -import NriPrelude -import qualified Task -import qualified Test.Internal as Internal - --- | Error generated when a test expectation is not met. -type Failure = Internal.Failure - --- | Check a task returns an expected value, than pass that value on. --- --- > task "Greetings are friendly" <| do --- > getGreeting --- > |> andCheck (Expect.equal "Hi!") -andCheck :: (a -> Expect.Expectation) -> Task Failure a -> Task Failure a -andCheck expectation task = do - x <- task - res <- - expectation x - |> Internal.unExpectation - |> Task.mapError never - case res of - Internal.Succeeded -> task - Internal.Failed failure -> Task.fail failure - --- | Check an expectation in the middle of a @do@ block. --- --- > task "Laundry gets done" <| do --- > weightInKgs <- clothesInWasher --- > check (weightInKgs |> Expect.atMost 8) --- > soapInWasher --- > startMachine -check :: Expect.Expectation -> Task Failure () -check expectation = - Task.succeed () - |> andCheck (\() -> expectation) - --- | Check a task succeeds. --- --- > task "solve rubicskube" <| do --- > solveRubicsKube --- > |> succeeds -succeeds :: Show err => Task err a -> Task Failure a -succeeds task = - Task.mapError - ( \message -> - Internal.FailedAssertion (Debug.toString message) - ) - task - --- | Check a task fails. --- --- > task "chemistry experiment" <| do --- > mixRedAndGreenLiquids --- > |> fails -fails :: Text -> Task Failure a -fails msg = - msg - |> Internal.FailedAssertion - |> Task.fail diff --git a/src/Internal/Shortcut.hs b/src/Internal/Shortcut.hs --- a/src/Internal/Shortcut.hs +++ b/src/Internal/Shortcut.hs @@ -17,7 +17,7 @@ ) where -import Prelude ((<*>), (>>=), Applicative, Functor, Monad, Monad, fmap, pure) +import Prelude (Applicative, Functor, Monad, fmap, pure, (<*>), (>>=)) -- | andThen :: Monad m => (a -> m b) -> m a -> m b diff --git a/src/List.hs b/src/List.hs --- a/src/List.hs +++ b/src/List.hs @@ -52,7 +52,7 @@ ) where -import Basics ((-), (>>), Bool (..), Int, Num, Ord, Ordering (..)) +import Basics (Bool (..), Int, Num, Ord, Ordering (..), (-), (>>)) import qualified Data.Foldable import qualified Data.List import qualified Data.Maybe @@ -290,25 +290,25 @@ -- > -- pairs ["alice","bob","chuck"] [2,5,7,8] -- > -- == [("alice",2),("bob",5),("chuck",7)] -- --- __NOTE:__ This behaves differently than @NriPrelude.Internal.map2@, which produces +-- __Note:__ This behaves differently than 'NriPrelude.map2', which produces -- all combinations of elements from both lists. map2 :: (a -> b -> result) -> List a -> List b -> List result map2 = Data.List.zipWith --- | __NOTE:__ This behaves differently than @NriPrelude.Internal.map3@, which produces +-- | __Note:__ This behaves differently than 'NriPrelude.map3', which produces -- all combinations of elements from all lists. map3 :: (a -> b -> c -> result) -> List a -> List b -> List c -> List result map3 = Data.List.zipWith3 --- | __NOTE:__ This behaves differently than @NriPrelude.Internal.map4@, which produces +-- | __Note:__ This behaves differently than 'NriPrelude.map4', which produces -- all combinations of elements from all lists. map4 :: (a -> b -> c -> d -> result) -> List a -> List b -> List c -> List d -> List result map4 = Data.List.zipWith4 --- | __NOTE:__ This behaves differently than @NriPrelude.Internal.map5@, which produces +-- | __Note:__ This behaves differently than 'NriPrelude.map5', which produces -- all combinations of elements from all lists. map5 :: (a -> b -> c -> d -> e -> result) -> List a -> List b -> List c -> List d -> List e -> List result map5 = @@ -358,7 +358,7 @@ -- -- > isEmpty [] == True -- --- **Note:** It is usually preferable to use a @case@ to test this so you do not +-- __Note:__ It is usually preferable to use a @case@ to test this so you do not -- forget to handle the @(x :: xs)@ case as well! isEmpty :: List a -> Bool isEmpty = @@ -369,7 +369,7 @@ -- > head [1,2,3] == Just 1 -- > head [] == Nothing -- --- **Note:** It is usually preferable to use a @case@ to deconstruct a @List@ +-- __Note:__ It is usually preferable to use a @case@ to deconstruct a @List@ -- because it gives you @(x :: xs)@ and you can work with both subparts. head :: List a -> Maybe a head xs = @@ -384,7 +384,7 @@ -- > tail [1,2,3] == Just [2,3] -- > tail [] == Nothing -- --- **Note:** It is usually preferable to use a @case@ to deconstruct a @List@ +-- __Note:__ It is usually preferable to use a @case@ to deconstruct a @List@ -- because it gives you @(x :: xs)@ and you can work with both subparts. tail :: List a -> Maybe (List a) tail list = diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -33,7 +33,6 @@ import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson -import GHC.Generics (Generic) import qualified GHC.Stack as Stack import NriPrelude import qualified Platform @@ -49,16 +48,16 @@ -- In addition to a log message you can pass additional key-value pairs with -- information that might be relevant for debugging. -- --- info "I added 1 and 1" [context "answer" 2] +-- > 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 -- | A log message when the user is annoyed, but not blocked. -- --- Log.userIsAnnoyed --- "We poked the user unnecessarily." --- "Try to stop poking the user." --- [ Log.context "The type of poking stick" poker ] +-- > 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 @@ -68,7 +67,7 @@ ReportAsFailed (Context "triage" triage : contexts) --- | Like @userIsAnnoyed@, but when the user is userIsConfused. +-- | 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 @@ -78,7 +77,7 @@ ReportAsFailed (Context "triage" triage : contexts) --- | Like @userIsAnnoyed@, but when the user is in pain. +-- | 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 @@ -88,7 +87,7 @@ ReportAsFailed (Context "triage" triage : contexts) --- | Like @userIsAnnoyed@, but when the user is blocked. +-- | 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 @@ -108,8 +107,8 @@ -- -- Example usage: -- --- withContext "play-music" [context "artist" "The Beatles"] <| do --- -- your code here! +-- > withContext "play-music" [context "artist" "The Beatles"] <| do +-- > -- your code here! -- -- Additionally, this function adds an entry to our homemade stack trace for if something errors. -- Why not use the built-in stack trace? Well, the built-in stack trace only records a frame if you @@ -172,8 +171,8 @@ -- | Wrap a value in a secret to prevent it from being accidentally logged. -- --- Debug.log "Logging a secret" (mkSecret "My PIN is 1234") --- --> Logging a secret: Secret ***** +-- > Debug.log "Logging a secret" (mkSecret "My PIN is 1234") +-- > --> Logging a secret: Secret ***** mkSecret :: a -> Secret a mkSecret = Secret @@ -220,11 +219,10 @@ -- | 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 TriageInfo = TriageInfo + { impact :: Impact, + advisory :: Text + } deriving (Generic) instance Aeson.ToJSON TriageInfo diff --git a/src/NriPrelude.hs b/src/NriPrelude.hs --- a/src/NriPrelude.hs +++ b/src/NriPrelude.hs @@ -4,7 +4,7 @@ -- needing to import anything. In Haskell we refer to such imports as a -- "Prelude". module NriPrelude - ( -- * Elm Prelude + ( -- * Elm-like Prelude Platform.Internal.Task, module Basics, module Internal.Shortcut, @@ -14,31 +14,15 @@ Text.Text, Char.Char, - -- * The following exports are Non-Elm, but we can't really do without them. + -- * Other essentials Prelude.Show, GHC.Generics.Generic, - - -- * We're exposing these so users can define custom Functor, Applicative, and - -- Monad instances. If you use them outside of type class instance definitions - -- hlint should ask you to replace them with Elm-ish functions instead. fmap, (<*>), (>>=), ) where --- Elm implicitly imports a variety of names into each module. There isn't a --- formal "prelude" like in Haskell; it's defined in the language. See --- https://package.elm-lang.org/packages/elm/core/latest/ for the full list. --- --- import Basics exposing (..) --- import List exposing (List, (::)) --- import Maybe exposing (Maybe(..)) --- import Result exposing (Result(..)) --- import String exposing (String) --- import Char exposing (Char) --- import Tuple --- import Debug import Basics import qualified Char import qualified GHC.Generics @@ -49,8 +33,8 @@ import qualified Result import qualified Text import Prelude - ( (<*>), + ( fmap, + (<*>), (>>=), - fmap, ) import qualified Prelude diff --git a/src/NriPrelude/Plugin.hs b/src/NriPrelude/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/NriPrelude/Plugin.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-incomplete-record-updates #-} + +-- | A GHC plugin for a more Elm-like Haskell experience. It automatically +-- adds an unqualified import of the NriPrelude module, and qualified imports of +-- other base modules such as List and Maybe. +-- +-- To use it make sure your project has @nri-prelude@ listed as a dependency, +-- then add the follwing ghc option to your cabal or package yaml file: +-- +-- > -fplugin=NriPrelude.Plugin +module NriPrelude.Plugin + ( plugin, + ) +where + +-- Useful documentation +-- - Elm's default imports: https://package.elm-lang.org/packages/elm/core/latest/ +-- - GHC user guide on compiler plugins: https://ghc.gitlab.haskell.org/ghc/doc/users_guide/extending_ghc.html#compiler-plugins +-- - Module providing API for creating plugins: https://www.stackage.org/haddock/lts-17.4/ghc-lib-8.10.4.20210206/GhcPlugins.html + +import Data.Function ((&)) +import qualified Data.List +import qualified GhcPlugins +import NriPrelude.Plugin.GhcVersionDependent + ( hsmodImports, + hsmodName, + ideclImplicit, + ideclName, + ideclQualified, + isQualified, + mkQualified, + simpleImportDecl, + ) +import qualified Set +import Prelude + +plugin :: GhcPlugins.Plugin +plugin = + GhcPlugins.defaultPlugin + { GhcPlugins.parsedResultAction = addImplicitImports, + -- Let GHC know this plugin doesn't perform arbitrary IO. Given the same + -- input file it will make the same changes. Without this GHC will + -- recompile modules using this plugin every time which is expensive. + GhcPlugins.pluginRecompile = GhcPlugins.purePlugin + } + +addImplicitImports :: + [GhcPlugins.CommandLineOption] -> + GhcPlugins.ModSummary -> + GhcPlugins.HsParsedModule -> + GhcPlugins.Hsc GhcPlugins.HsParsedModule +addImplicitImports _ _ parsed = + Prelude.pure + parsed + { GhcPlugins.hpm_module = + fmap addImportsWhenNotPath (GhcPlugins.hpm_module parsed) + } + where + addImportsWhenNotPath hsModule = + case fmap unLocate (hsmodName hsModule) of + Nothing -> addImports hsModule + Just modName -> + if Data.List.isPrefixOf "Paths_" modName + then hsModule + else addImports hsModule + + addImports hsModule = + hsModule + { hsmodImports = + -- Add default Elm-like imports when the user hasn't imported them + -- explicitly yet, in order to avoid duplicate import warnings. + hsmodImports hsModule + ++ ( Set.diff extraImports (existingImports hsModule) + & Set.toList + & fmap + ( \imp -> + case imp of + Unqualified name -> unqualified name + Qualified name -> qualified name + ) + ) + } + + existingImports hsModule = + hsmodImports hsModule + & fmap + ( \(GhcPlugins.L _ imp) -> + case (isQualified imp, unLocate (ideclName imp)) of + (True, name) -> Qualified name + (False, name) -> Unqualified name + ) + & Set.fromList + + unLocate (GhcPlugins.L _ x) = GhcPlugins.moduleNameString x + + unqualified name = + GhcPlugins.noLoc (simpleImportDecl (GhcPlugins.mkModuleName name)) + & fmap (\qual -> qual {ideclImplicit = True}) + qualified name = + fmap (\qual -> qual {ideclQualified = mkQualified}) (unqualified name) + +data Import + = Unqualified String + | Qualified String + deriving (Eq, Ord) + +-- taken from https://package.elm-lang.org/packages/elm/core/latest/ +extraImports :: Set.Set Import +extraImports = + Set.fromList + [ Unqualified "NriPrelude", -- Elm exports types from withi these modules. We re-export them from NriPrelude. Same effect. + Qualified "Basics", + Qualified "Char", + Qualified "Debug", + Qualified "List", + Qualified "Maybe", + Qualified "Platform", + Qualified "Result", + Qualified "Text", -- equivalent to Elm's String + Qualified "Tuple", + -- Additionally Task and Log because we use them everywhere + Qualified "Log", + Qualified "Task" + ] diff --git a/src/NriPrelude/Plugin/GhcVersionDependent.hs b/src/NriPrelude/Plugin/GhcVersionDependent.hs new file mode 100644 --- /dev/null +++ b/src/NriPrelude/Plugin/GhcVersionDependent.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE CPP #-} + +-- A couple of imports we need to write this module have been moved in GHC +-- version 8.10. This module uses the CPP extension to import the right values +-- dependent on the version of GHC. + +#if __GLASGOW_HASKELL__ >= 810 + +module NriPrelude.Plugin.GhcVersionDependent ( + module GHC.Hs, + isQualified, + mkQualified, +) where + +import GHC.Hs +import Prelude + +-- There's more than one way to do a qualified import. See: +-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/import_qualified_post.html + +isQualified :: ImportDecl pass -> Bool +isQualified imp = + case ideclQualified imp of + QualifiedPre -> True + QualifiedPost -> True + NotQualified -> False + +mkQualified :: ImportDeclQualifiedStyle +mkQualified = QualifiedPre + +#else + +module NriPrelude.Plugin.GhcVersionDependent ( + module HsSyn, + isQualified, + mkQualified, +) where + +import HsSyn +import Prelude + +isQualified :: ImportDecl pass -> Bool +isQualified = ideclQualified + +mkQualified :: Bool +mkQualified = True + +#endif diff --git a/src/Platform/Internal.hs b/src/Platform/Internal.hs --- a/src/Platform/Internal.hs +++ b/src/Platform/Internal.hs @@ -18,8 +18,8 @@ import GHC.Generics (Generic) import qualified GHC.Stack as Stack import qualified GHC.Word -import qualified Internal.Shortcut as Shortcut import Internal.Shortcut (andThen, map) +import qualified Internal.Shortcut as Shortcut import qualified List import Maybe (Maybe (..)) import Result (Result (Err, Ok)) @@ -27,7 +27,7 @@ import Text (Text) import qualified Tuple import Prelude - ( Applicative ((<*>), pure), + ( Applicative (pure, (<*>)), Functor, IO, Monad ((>>=)), @@ -39,7 +39,7 @@ -- -- | Here are some common tasks: - +-- -- - @now : Task x Posix@ -- - @query : String -> Task Error ()@ -- - @sleep : Float -> Task x ()@ @@ -54,8 +54,7 @@ -- list. Or like a grocery list. Or like GitHub issues. So saying "the task is -- to tell me the current POSIX time" does not complete the task! You need -- 'perform' tasks or 'attempt' tasks. -newtype Task x a - = Task {_run :: LogHandler -> IO (Result x a)} +newtype Task x a = Task {_run :: LogHandler -> IO (Result x a)} deriving (Functor) instance Applicative (Task a) where @@ -106,57 +105,56 @@ -- - Logs are tracingSpans flattened into a series of events ordered by time. For -- example, consider the following tracingSpans: -- --- do the laundry 11:00-12:15 --- wash clothes 11:00-12:00 --- hang clothes to dry 12:00-12:15 +-- > do the laundry 11:00-12:15 +-- > wash clothes 11:00-12:00 +-- > hang clothes to dry 12:00-12:15 -- -- we could recover the following logs from this: -- --- 11:00 starting do the laundry --- 11:00 wash clothes --- 12:00 hang clothes to dry --- 12:15 finishing do the laundry +-- > 11:00 starting do the laundry +-- > 11:00 wash clothes +-- > 12:00 hang clothes to dry +-- > 12:15 finishing do the laundry -- -- - Metrics are rolling statistics on tracingSpans. For example, we can -- increment a counter every time we see a particular tracingSpan pass by. -- -- So whether we're looking for tracing data, logs, or metrics, tracingSpans -- got us covered. -data TracingSpan - = TracingSpan - { -- | A description of this tracingSpan. This should not contain any - -- dynamically generated strings to make grouping tracingSpans easy. - -- Any contextual info should go into 'details'. - name :: Text, - -- | The time this tracingSpan started. - started :: MonotonicTime, - -- | The time this tracingSpan finished. - finished :: MonotonicTime, - -- | The source code location of this tracingSpan. The first @Text@ is - -- the name of the function getting called. - frame :: Maybe (Text, Stack.SrcLoc), - -- | Unique information for this tracingSpan. - details :: Maybe SomeTracingSpanDetails, - -- | A short blurb describing the details of this span, for use in - -- tooling for inspecting these spans. - summary :: Maybe Text, - -- | Whether this tracingSpan succeeded. If any of the children of this - -- tracingSpan failed, so will this tracingSpan. This will create a - -- path to the tracingSpan closest to the failure from the root - -- tracingSpan. - succeeded :: Succeeded, - -- | The amount of bytes were allocated on the current thread while this - -- span was running. This is a proxy for the amount of work done. If - -- this number is low but the span took a long time to complete this - -- indicates the thread was blocked for some time, or that work was done - -- on other threads. - allocated :: Int, - -- | Any subtracingSpans nested inside this tracingSpan. These are - -- ordered in reverse chronological order, so most recent tracingSpan - -- first, because it's cheaper to append new tracingSpans onto the left - -- of the list. - children :: [TracingSpan] - } +data TracingSpan = TracingSpan + { -- | A description of this tracingSpan. This should not contain any + -- dynamically generated strings to make grouping tracingSpans easy. + -- Any contextual info should go into 'details'. + name :: Text, + -- | The time this tracingSpan started. + started :: MonotonicTime, + -- | The time this tracingSpan finished. + finished :: MonotonicTime, + -- | The source code location of this tracingSpan. The first @Text@ is + -- the name of the function getting called. + frame :: Maybe (Text, Stack.SrcLoc), + -- | Unique information for this tracingSpan. + details :: Maybe SomeTracingSpanDetails, + -- | A short blurb describing the details of this span, for use in + -- tooling for inspecting these spans. + summary :: Maybe Text, + -- | Whether this tracingSpan succeeded. If any of the children of this + -- tracingSpan failed, so will this tracingSpan. This will create a + -- path to the tracingSpan closest to the failure from the root + -- tracingSpan. + succeeded :: Succeeded, + -- | The amount of bytes were allocated on the current thread while this + -- span was running. This is a proxy for the amount of work done. If + -- this number is low but the span took a long time to complete this + -- indicates the thread was blocked for some time, or that work was done + -- on other threads. + allocated :: Int, + -- | Any subtracingSpans nested inside this tracingSpan. These are + -- ordered in reverse chronological order, so most recent tracingSpan + -- first, because it's cheaper to append new tracingSpans onto the left + -- of the list. + children :: [TracingSpan] + } deriving (Prelude.Show, Generic) instance Aeson.ToJSON TracingSpan where @@ -376,10 +374,10 @@ -- We could define a single @SomeTracingSpanDetails@ type that can represent all -- of these different types of details. One way would be to write a union: -- --- data SomeTracingSpanDetails --- = Sql SqlDetails --- | Http HttpDetails --- | ... +-- > data SomeTracingSpanDetails +-- > = Sql SqlDetails +-- > | Http HttpDetails +-- > | ... -- -- The disadvantage of this is that nri-prelude will have to know about every -- possible type of tracingSpan. If a library wanted to log new information it @@ -388,7 +386,7 @@ -- -- Another approach is to have the details field take arbitrary JSON: -- --- type SomeTracingSpanDetails = Data.Aeson.Value +-- > type SomeTracingSpanDetails = Data.Aeson.Value -- -- This allows any library to log what it wants without requiring any changes in -- nri-prelude. However, unless we parse that JSON back into the original types @@ -516,47 +514,46 @@ -- without loosing important signal. We'll only know whether a request succeeds -- after it completes though, so we have to hold off on any reporting for a -- request until it's done. -data LogHandler - = LogHandler - { -- | We're making the assumption that every task we run is ran because - -- of some sort of request, and that this request has a unique - -- identifier. We take this identifier from the incoming request and - -- pass it on when we call external services. If something goes wrong - -- we'll be able to collect all information related to a single request - -- from all the components in our architecture that did work for it. - requestId :: Text, - -- | Every tracingSpan gets its own handler. That way if we record - -- debugging information using a handler we'll know which tracingSpan - -- the information belongs to. This function creates a new handler for - -- a child tracingSpan of the current handler. - startChildTracingSpan :: Stack.HasCallStack => Text -> IO LogHandler, - -- | There's common fields all tracingSpans have such as a name and - -- start and finish times. On top of that each tracingSpan can define a - -- custom type containing useful custom data. This function allows us - -- to set this custom data for the current tracingSpan. We could design - -- it so this data is passed in as an extra argument when we create the - -- tracingSpan, but then we'd miss out on useful details that only - -- become known as the tracingSpan runs, for example the response code - -- of an HTTP request. - setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO (), - -- | Set a summary for the current tracingSpan. This is shown in tools - -- used to inspect spans as a stand-in for the full tracingSpan details - -- in places where we only have room to show a little text. - setTracingSpanSummaryIO :: Text -> IO (), - -- | Mark the current tracingSpan as failed. Some reporting backends - -- will use this to decide whether a particular request is worth - -- reporting on. - markTracingSpanFailedIO :: IO (), - -- | Mark the current tracingSpan as finished, which will set the - -- @finished@ timestamp. What this function does depends on the - -- tracingSpan. Once we're done collecting data for the root - -- tracingSpan we'll want to pass the tracingSpan "out", to some code - -- that will report the debugging data to whatever observability - -- platform(s) are used. Once we're done collecting data for child - -- tracingSpans we'll want to add the "completed" child tracingSpan to - -- its parent. - finishTracingSpan :: Maybe Exception.SomeException -> IO () - } +data LogHandler = LogHandler + { -- | We're making the assumption that every task we run is ran because + -- of some sort of request, and that this request has a unique + -- identifier. We take this identifier from the incoming request and + -- pass it on when we call external services. If something goes wrong + -- we'll be able to collect all information related to a single request + -- from all the components in our architecture that did work for it. + requestId :: Text, + -- | Every tracingSpan gets its own handler. That way if we record + -- debugging information using a handler we'll know which tracingSpan + -- the information belongs to. This function creates a new handler for + -- a child tracingSpan of the current handler. + startChildTracingSpan :: Stack.HasCallStack => Text -> IO LogHandler, + -- | There's common fields all tracingSpans have such as a name and + -- start and finish times. On top of that each tracingSpan can define a + -- custom type containing useful custom data. This function allows us + -- to set this custom data for the current tracingSpan. We could design + -- it so this data is passed in as an extra argument when we create the + -- tracingSpan, but then we'd miss out on useful details that only + -- become known as the tracingSpan runs, for example the response code + -- of an HTTP request. + setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO (), + -- | Set a summary for the current tracingSpan. This is shown in tools + -- used to inspect spans as a stand-in for the full tracingSpan details + -- in places where we only have room to show a little text. + setTracingSpanSummaryIO :: Text -> IO (), + -- | Mark the current tracingSpan as failed. Some reporting backends + -- will use this to decide whether a particular request is worth + -- reporting on. + markTracingSpanFailedIO :: IO (), + -- | Mark the current tracingSpan as finished, which will set the + -- @finished@ timestamp. What this function does depends on the + -- tracingSpan. Once we're done collecting data for the root + -- tracingSpan we'll want to pass the tracingSpan "out", to some code + -- that will report the debugging data to whatever observability + -- platform(s) are used. Once we're done collecting data for child + -- tracingSpans we'll want to add the "completed" child tracingSpan to + -- its parent. + finishTracingSpan :: Maybe Exception.SomeException -> IO () + } -- | Helper that creates one of the handler's above. This is intended for -- internal use in this library only and not for exposing. Outside of this @@ -602,16 +599,16 @@ -- @Platform.bracketWithError@, to ensure we record tracingSpan details even in -- the event of an exception cutting the execution of our tracingSpan short. -- --- tracingSpan "holiday" do --- let bookPick = BookPick "The Stone Sky" --- Platform.finally --- (readBook bookPick) --- (setTracingSpanDetails bookPick) --- --- newtype BookPick = BookPick Text --- deriving (Aeson.ToJSON) --- --- instance TracingSpanDetails BookPick +-- > tracingSpan "holiday" do +-- > let bookPick = BookPick "The Stone Sky" +-- > Platform.finally +-- > (readBook bookPick) +-- > (setTracingSpanDetails bookPick) +-- > +-- > newtype BookPick = BookPick Text +-- > deriving (Aeson.ToJSON) +-- > +-- > instance TracingSpanDetails BookPick setTracingSpanDetails :: TracingSpanDetails d => d -> Task e () setTracingSpanDetails details = Task @@ -639,10 +636,10 @@ -- @tracingSpan@ this is intended for use in writing libraries that define -- custom types of effects, such as database queries or http requests. -- --- tracingSpan "holiday" do --- Platform.finally --- (readBook bookPick) --- (setTracingSpanSummary "The Stone Sky") +-- > tracingSpan "holiday" do +-- > Platform.finally +-- > (readBook bookPick) +-- > (setTracingSpanSummary "The Stone Sky") markTracingSpanFailed :: Task e () markTracingSpanFailed = Task (map Ok << markTracingSpanFailedIO) @@ -706,12 +703,13 @@ -- to see if any errors occurred), and to make it easy to trace the -- source of a problem from the root tracingSpan upward by following -- the failing child tracingSpans. - succeeded = succeeded tracingSpan' - ++ case maybeException of - Just exception -> FailedWith exception - Nothing -> - map Platform.Internal.succeeded (children tracingSpan') - |> Prelude.mconcat, + succeeded = + succeeded tracingSpan' + ++ case maybeException of + Just exception -> FailedWith exception + Nothing -> + map Platform.Internal.succeeded (children tracingSpan') + |> Prelude.mconcat, -- The allocation counter counts down as it allocations bytest. We -- subtract in this order to get a positive number. allocated = allocationCounterStartVal - allocationCounterEndVal @@ -733,9 +731,9 @@ -- | Run a task in a tracingSpan. -- --- tracingSpan "code dance" <| do --- waltzPassLeft --- clockwiseTurn 60 +-- > tracingSpan "code dance" <| do +-- > waltzPassLeft +-- > clockwiseTurn 60 -- -- This will help provide better debugging information if something goes wrong -- inside the wrapped task. @@ -754,9 +752,9 @@ -- sometimes need this in libraries. @Task@ has the concept of a @LogHandler@ -- built in but @IO@ does not, so we'll have to pass it around ourselves. -- --- tracingSpanIO handler "code dance" <| \childHandler -> do --- waltzPassLeft childHandler --- clockwiseTurn childHandler 60 +-- > tracingSpanIO handler "code dance" <| \childHandler -> do +-- > waltzPassLeft childHandler +-- > clockwiseTurn childHandler 60 tracingSpanIO :: Stack.HasCallStack => LogHandler -> Text -> (LogHandler -> IO a) -> IO a tracingSpanIO handler name run = Exception.bracketWithError @@ -768,9 +766,9 @@ -- Instead of taking a parent handler it takes a continuation that will be -- called with this root tracingSpan after it has run. -- --- rootTracingSpanIO "request-23" Prelude.print "incoming request" <| \handler -> --- handleRequest --- |> Task.perform handler +-- > rootTracingSpanIO "request-23" Prelude.print "incoming request" <| \handler -> +-- > handleRequest +-- > |> Task.perform handler rootTracingSpanIO :: Stack.HasCallStack => Text -> (TracingSpan -> IO ()) -> Text -> (LogHandler -> IO a) -> IO a rootTracingSpanIO requestId onFinish name runIO = do clock' <- mkClock @@ -816,10 +814,9 @@ -- here though, we just store these monotonic times and let code that reporters -- that use these tracingSpans convert the monotonic times into whatever format -- they need. -newtype MonotonicTime - = MonotonicTime - { -- | The number of microseconds that have passed since an arbitrary but - -- constant moment in the past. - inMicroseconds :: GHC.Word.Word64 - } +newtype MonotonicTime = MonotonicTime + { -- | The number of microseconds that have passed since an arbitrary but + -- constant moment in the past. + inMicroseconds :: GHC.Word.Word64 + } deriving (Prelude.Show, Prelude.Num, Prelude.Eq, Prelude.Ord, Aeson.ToJSON, Aeson.FromJSON) diff --git a/src/Result.hs b/src/Result.hs --- a/src/Result.hs +++ b/src/Result.hs @@ -1,5 +1,6 @@ -- | A @Result@ is the result of a computation that may fail. This is a great --- way to manage errors in Elm. +-- way to manage errors in Elm, but we when using this package in Haskell we +-- tend to rely on 'Task.Task' a lot too for error handling. module Result ( -- * Type and Constructors Result (..), diff --git a/src/Set.hs b/src/Set.hs --- a/src/Set.hs +++ b/src/Set.hs @@ -2,7 +2,7 @@ -- includes @Int@, @Float@, @Time@, @Char@, @String@, and tuples or lists -- of comparable types. -- --- Insert, remove, and query operations all take *O(log n)* time. +-- Insert, remove, and query operations all take /O(log n)/ time. module Set ( -- * Sets Set, @@ -36,7 +36,7 @@ ) where -import Basics ((>>), Bool, Int, Ord) +import Basics (Bool, Int, Ord, (>>)) import qualified Data.Set import List (List) import qualified Prelude diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -1,3 +1,9 @@ +-- GHC wants us to remove `Err never` branches from case statements, because it +-- knows we'll never end up in those branches. We like them though, because +-- missing such a branch in a case statement looks like a problem and so is +-- distracting. +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} + -- | Tasks make it easy to describe asynchronous operations that may fail, like -- HTTP requests or writing to a database. module Task @@ -36,8 +42,8 @@ import List (List) import qualified List import Maybe (Maybe (..)) -import qualified Platform.Internal as Internal import Platform.Internal (Task) +import qualified Platform.Internal as Internal import Result (Result (..)) import qualified System.Timeout import Prelude (IO) @@ -57,6 +63,8 @@ perform output task = let onResult result = case result of + -- If you remove this branch, consider also removing the + -- -fno-warn-overlapping-patterns warning above. Err err -> never err Ok x -> x in attempt output task diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -13,9 +13,6 @@ Internal.fuzz2, Internal.fuzz3, - -- * Task Testing - Internal.task, - -- * Running test run, ) diff --git a/src/Test/Internal.hs b/src/Test/Internal.hs --- a/src/Test/Internal.hs +++ b/src/Test/Internal.hs @@ -1,6 +1,11 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NumericUnderscores #-} +-- GHC wants us to remove `Err never` branches from case statements, because it +-- knows we'll never end up in those branches. We like them though, because +-- missing such a branch in a case statement looks like a problem and so is +-- distracting. +{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} module Test.Internal where @@ -20,19 +25,19 @@ import qualified Maybe import NriPrelude import Platform (TracingSpan) +import qualified Platform import qualified Platform.Internal import qualified Task import qualified Tuple import qualified Prelude -data SingleTest a - = SingleTest - { describes :: [Text], - name :: Text, - label :: Label, - loc :: Maybe Stack.SrcLoc, - body :: a - } +data SingleTest a = SingleTest + { describes :: [Text], + name :: Text, + label :: Label, + loc :: Maybe Stack.SrcLoc, + body :: a + } deriving (Prelude.Functor) data Label = None | Skip | Only | Todo @@ -43,7 +48,7 @@ | Failed Failure data Failure - = FailedAssertion Text + = FailedAssertion Text (Maybe Stack.SrcLoc) | ThrewException Exception.SomeException | TookTooLong | TestRunnerMessedUp Text @@ -65,9 +70,14 @@ -- See 'test' and 'fuzz' for some ways to create a @Test@. newtype Test = Test {unTest :: [SingleTest Expectation]} --- | The result of a single test run: either a 'pass' or a 'fail'. -newtype Expectation = Expectation {unExpectation :: Task Never TestResult} +-- | The result of a single test run: either a 'pass' or a 'fail'. +type Expectation = Expectation' () +-- | The type of a test that runs some script with multiple expectations in +-- between. +newtype Expectation' a = Expectation {unExpectation :: Task Failure a} + deriving (Prelude.Functor, Prelude.Applicative, Prelude.Monad) + -- | A @Fuzzer a@ knows how to produce random values of @a@ and how to "shrink" -- a value of @a@, that is turn a value into another that is slightly simpler. newtype Fuzzer a = Fuzzer {unFuzzer :: Hedgehog.Gen a} @@ -126,7 +136,7 @@ name = name, loc = Stack.withFrozenCallStack getFrame, label = Todo, - body = Expectation (Task.succeed Succeeded) + body = Expectation (Task.succeed ()) } ] @@ -205,10 +215,17 @@ ] fuzzBody :: Show a => Fuzzer a -> (a -> Expectation) -> Expectation -fuzzBody (Fuzzer gen) expectation = +fuzzBody (Fuzzer gen) expectation = do Expectation <| Platform.Internal.Task - ( \log -> do + ( \_log -> do + -- For the moment we're not recording traces in fuzz tests. Because + -- the test body runs a great many times, we'd record a ton of data + -- that's not all that useful. + -- + -- Ideally we'd only keep the recording of the most significant run, + -- but we have to figure out how to do that first. + silentLog <- Platform.silentHandler seed <- Hedgehog.Internal.Seed.random failureRef <- IORef.newIORef Nothing hedgehogResult <- @@ -222,11 +239,13 @@ expectation generated |> handleUnexpectedErrors |> unExpectation - |> Task.perform log + |> Task.map Ok + |> Task.onError (Task.succeed << Err) + |> Task.perform silentLog |> Control.Monad.IO.Class.liftIO case result of - Succeeded -> Prelude.pure () - Failed failure -> do + Ok () -> Prelude.pure () + Err failure -> do IORef.writeIORef failureRef (Just failure) |> Control.Monad.IO.Class.liftIO Hedgehog.failure @@ -238,20 +257,17 @@ case maybeFailure of Nothing -> TestRunnerMessedUp "I lost the error report of a failed fuzz test test." - |> Failed - |> Ok + |> Err |> Prelude.pure Just failure -> - Failed failure - |> Ok + Err failure |> Prelude.pure Hedgehog.Internal.Report.GaveUp -> TestRunnerMessedUp "I couldn't generate any values for a fuzz test." - |> Failed - |> Ok + |> Err |> Prelude.pure Hedgehog.Internal.Report.OK -> - Ok Succeeded + Ok () |> Prelude.pure ) @@ -323,25 +339,6 @@ only (Test tests) = Test <| List.map (\test' -> test' {label = Only}) tests --- | Run a test that executes a task. The test passes if the task returns a --- success value. -task :: Stack.HasCallStack => Text -> Task Failure a -> Test -task name expectation = - Test - [ SingleTest - { describes = [], - name = name, - loc = Stack.withFrozenCallStack getFrame, - label = None, - body = - expectation - |> Task.map (\_ -> Succeeded) - |> Task.onError (Task.succeed << Failed) - |> Expectation - |> handleUnexpectedErrors - } - ] - run :: Test -> Task e SuiteResult run (Test all) = do let grouped = groupBy label all @@ -386,21 +383,19 @@ Summary {noneSkipped = False} -> PassedWithSkipped passed notToRun Summary {} -> AllPassed passed -data Summary - = Summary - { noTests :: Bool, - allPassed :: Bool, - anyOnlys :: Bool, - noneSkipped :: Bool - } +data Summary = Summary + { noTests :: Bool, + allPassed :: Bool, + anyOnlys :: Bool, + noneSkipped :: Bool + } handleUnexpectedErrors :: Expectation -> Expectation handleUnexpectedErrors (Expectation task') = task' - |> Task.mapError never - |> onException (Task.succeed << Failed << ThrewException) + |> onException (Task.fail << ThrewException) |> Task.timeout 10_000 TookTooLong - |> Task.onError (Task.succeed << Failed) + |> Task.onError Task.fail |> Expectation runSingle :: SingleTest Expectation -> Task e (SingleTest (TracingSpan, TestResult)) @@ -416,14 +411,16 @@ ( \log -> body test' |> unExpectation - |> Task.mapError never - |> map Ok + |> Task.map Ok + |> Task.onError (Task.succeed << Err) |> Task.perform log ) let testRest = case res of - Ok x -> x - Err err -> never err + Ok () -> Succeeded + -- If you remove this branch, consider also removing the + -- -fno-warn-overlapping-patterns warning above. + Err err -> Failed err span' <- MVar.takeMVar spanVar let span = span' @@ -479,11 +476,28 @@ append :: Expectation -> Expectation -> Expectation append (Expectation task1) (Expectation task2) = - task1 - |> andThen - ( \result1 -> - case result1 of - Succeeded -> task2 - Failed _ -> task1 - ) + Expectation <| do + task1 + task2 + +-- Assertion constructors +-- All exposed assertion functions should call these functions internally and +-- never each other, to ensure a single unnested 'expectation' entry from +-- appearing in log-explorer traces. + +pass :: Stack.HasCallStack => Text -> a -> Expectation' a +pass name a = Stack.withFrozenCallStack traceExpectation name (Task.succeed a) + +failAssertion :: Stack.HasCallStack => Text -> Text -> Expectation' a +failAssertion name err = + FailedAssertion err (Stack.withFrozenCallStack getFrame) + |> Task.fail + |> Stack.withFrozenCallStack traceExpectation name + +traceExpectation :: Stack.HasCallStack => Text -> Task Failure a -> Expectation' a +traceExpectation name task = + Stack.withFrozenCallStack + Platform.tracingSpan + name + task |> Expectation 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 @@ -57,7 +57,7 @@ renderFailed :: Internal.SingleTest (Platform.TracingSpan, Internal.Failure) -> JUnit.TestSuite renderFailed test = case Internal.body test of - (tracingSpan, Internal.FailedAssertion msg) -> + (tracingSpan, Internal.FailedAssertion msg _) -> JUnit.failed (Internal.name test) |> JUnit.stderr msg |> ( case stackFrame test of 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 @@ -7,12 +7,15 @@ where import qualified Control.Exception as Exception +import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as Builder import qualified Data.Text.Encoding as TE 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 System.IO import qualified Test.Internal as Internal import qualified Tuple @@ -25,73 +28,83 @@ if color then (\styles builder -> sgr styles ++ builder ++ sgr [ANSI.Reset]) else (\_ builder -> builder) - let reportByteString = renderReport styled results + reportByteString <- renderReport styled results Builder.hPutBuilder handle reportByteString System.IO.hFlush handle renderReport :: ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> Internal.SuiteResult -> - Builder.Builder + Prelude.IO Builder.Builder renderReport styled results = case results of Internal.AllPassed passed -> let amountPassed = List.length passed - in styled [green, underlined] "TEST RUN PASSED" - ++ "\n\n" - ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) - ++ "\n" + in Prelude.pure + ( styled [green, underlined] "TEST RUN PASSED" + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ) Internal.OnlysPassed passed skipped -> let amountPassed = List.length passed amountSkipped = List.length skipped - in Prelude.foldMap - ( \only -> - prettyPath styled [yellow] only - ++ "This test passed, but there is a `Test.only` in your test.\n" - ++ "I failed the test, because it's easy to forget to remove `Test.only`.\n" - ++ "\n\n" + in Prelude.pure + ( Prelude.foldMap + ( \only -> + prettyPath styled [yellow] only + ++ "This test passed, but there is a `Test.only` in your test.\n" + ++ "I failed the test, because it's easy to forget to remove `Test.only`.\n" + ++ "\n\n" + ) + passed + ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled [yellow] " because there is an `only` in your tests." + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) + ++ "\n" ) - passed - ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" - ++ styled [yellow] " because there is an `only` in your tests." - ++ "\n\n" - ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) - ++ "\n" - ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) - ++ "\n" Internal.PassedWithSkipped passed skipped -> let amountPassed = List.length passed amountSkipped = List.length skipped - in Prelude.foldMap - ( \only -> - prettyPath styled [yellow] only - ++ "This test was skipped." - ++ "\n\n" + in Prelude.pure + ( Prelude.foldMap + ( \only -> + prettyPath styled [yellow] only + ++ "This test was skipped." + ++ "\n\n" + ) + skipped + ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled + [yellow] + ( case List.length skipped of + 1 -> " because 1 test was skipped" + n -> " because " ++ Builder.int64Dec n ++ " tests were skipped" + ) + ++ "\n\n" + ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) + ++ "\n" + ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) + ++ "\n" ) - skipped - ++ styled [yellow, underlined] "TEST RUN INCOMPLETE" - ++ styled - [yellow] - ( case List.length skipped of - 1 -> " because 1 test was skipped" - n -> " because " ++ Builder.int64Dec n ++ " tests were skipped" - ) - ++ "\n\n" - ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) - ++ "\n" - ++ styled [black] ("Skipped: " ++ Builder.int64Dec amountSkipped) - ++ "\n" - Internal.TestsFailed passed skipped failed -> + Internal.TestsFailed passed skipped failed -> do let amountPassed = List.length passed - amountFailed = List.length failed - amountSkipped = List.length skipped - in Prelude.foldMap - ( \test -> + let amountFailed = List.length failed + let amountSkipped = List.length skipped + let failures = List.map (map Tuple.second) failed + failuresSrcs <- Prelude.traverse (renderFailureInFile styled) failures + Prelude.pure + ( Prelude.foldMap + ( \(srcLines, test) -> prettyPath styled [red] test + ++ srcLines ++ testFailure test ++ "\n\n" ) - (List.map (map Tuple.second) failed) + (List.map2 (,) failuresSrcs failures) ++ styled [red, underlined] "TEST RUN FAILED" ++ "\n\n" ++ styled [black] ("Passed: " ++ Builder.int64Dec amountPassed) @@ -104,11 +117,65 @@ ) ++ styled [black] ("Failed: " ++ Builder.int64Dec amountFailed) ++ "\n" + ) Internal.NoTestsInSuite -> - styled [yellow, underlined] "TEST RUN INCOMPLETE" - ++ styled [yellow] (" because the test suite is empty.") - ++ "\n" + Prelude.pure + ( styled [yellow, underlined] "TEST RUN INCOMPLETE" + ++ styled [yellow] (" because the test suite is empty.") + ++ "\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 "" + prettyPath :: ([ANSI.SGR] -> Builder.Builder -> Builder.Builder) -> [ANSI.SGR] -> @@ -136,7 +203,7 @@ testFailure :: Internal.SingleTest Internal.Failure -> Builder.Builder testFailure test = case Internal.body test of - Internal.FailedAssertion msg -> + Internal.FailedAssertion msg _ -> TE.encodeUtf8Builder msg Internal.ThrewException exception -> "Test threw an exception\n" @@ -165,6 +232,9 @@ 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 diff --git a/src/Text.hs b/src/Text.hs --- a/src/Text.hs +++ b/src/Text.hs @@ -71,22 +71,22 @@ where import Basics - ( (+), + ( Bool, + Float, + Int, + clamp, + (+), (-), (<), (<<), (<=), (>>), - Bool, - Float, - Int, - clamp, (|>), ) import Char (Char) import qualified Data.Text -import qualified List import List (List) +import qualified List import Maybe (Maybe) import qualified Text.Read import Prelude (otherwise) diff --git a/tests/DebugSpec.hs b/tests/DebugSpec.hs --- a/tests/DebugSpec.hs +++ b/tests/DebugSpec.hs @@ -1,6 +1,5 @@ module DebugSpec (tests) where -import Control.Exception.Safe (SomeException) import Control.Exception.Safe as Exception import qualified Debug import qualified Expect @@ -8,7 +7,7 @@ import NriPrelude import Test (Test, describe, test) import qualified Text -import Prelude (Either (Left, Right), Show) +import Prelude (Either (Left, Right)) tests :: Test tests = @@ -35,14 +34,11 @@ todoTests :: List Test todoTests = - [ test "that an exception is raised with the given message" - <| \() -> - Expect.withIO - ( \result -> case result of - Left (exception :: SomeException) -> Expect.equal (Just "Not yet!") (firstLine exception) - Right _home -> Expect.fail "No exception raised" - ) - (Exception.try (Debug.todo ("Not yet!" :: Text))) + [ test "that an exception is raised with the given message" <| \() -> do + result <- Expect.fromIO (Exception.try (Debug.todo ("Not yet!" :: Text))) + case result of + Left (exception :: SomeException) -> Expect.equal (Just "Not yet!") (firstLine exception) + Right _home -> Expect.fail "No exception raised" ] -- | Extracts the first line of a given text string if it exists. Otherwise returns Nothing. diff --git a/tests/LogSpec.hs b/tests/LogSpec.hs --- a/tests/LogSpec.hs +++ b/tests/LogSpec.hs @@ -22,76 +22,73 @@ tests = describe "Log" - [ test "`info` produces expected debugging info" <| \_ -> - Expect.withIO identity <| do - (recordedTracingSpans, handler) <- newHandler - _ <- info "logging a message!" [context "a number" (12 :: Int)] |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-info" - |> Prelude.pure, - test "`userIsAnnoyed` produces expected debugging info" <| \_ -> - Expect.withIO identity <| do - (recordedTracingSpans, handler) <- newHandler - _ <- - userIsAnnoyed - "the button didn't work" - "fix the button" - [context "button" ("PRESS" :: Text)] - |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-annoyed" - |> Prelude.pure, - test "`userIsPained` produces expected debugging info" <| \_ -> - Expect.withIO identity <| do - (recordedTracingSpans, handler) <- newHandler - _ <- - userIsPained - "user cut themselves on the modal" - "file modal's sharp edges" - [context "modal" ("SURPRISE!" :: Text)] - |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-pained" - |> Prelude.pure, - test "`userIsBlocked` produces expected debugging info" <| \_ -> - Expect.withIO identity <| do - (recordedTracingSpans, handler) <- newHandler - _ <- - userIsBlocked - "door is blocked" - "find key" - [context "house number" (5 :: Int)] - |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-user-is-blocked" - |> Prelude.pure, - test "nested spans pruduce expected debugging info" <| \_ -> - Expect.withIO - identity - <| do + [ test "`info` produces expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler + _ <- info "logging a message!" [context "a number" (12 :: Int)] |> Task.attempt handler + recordedTracingSpans + spans + |> Debug.toString + |> Expect.equalToContentsOf "tests/golden-results/log-info", + test "`userIsAnnoyed` produces expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler _ <- + userIsAnnoyed + "the button didn't work" + "fix 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 + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler + _ <- + userIsPained + "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 + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler + _ <- + userIsBlocked + "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", + test "nested spans pruduce expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler + _ <- info "log!" [] |> withContext "inner span" [context "word" ("sabbatical" :: Text)] |> withContext "outer span" [context "number" (825 :: Int)] |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-nested-spans" - |> Prelude.pure, - test "unexpected exceptions produce expected debugging info" <| \_ -> - Expect.withIO - identity - <| do + recordedTracingSpans + spans + |> Debug.toString + |> Expect.equalToContentsOf "tests/golden-results/log-nested-spans", + test "unexpected exceptions produce expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler _ <- Internal.Task (\_ -> Exception.throwIO TestException) @@ -99,15 +96,13 @@ |> withContext "outer span" [context "number" (825 :: Int)] |> Task.attempt handler |> Exception.handle (\TestException -> Prelude.pure (Ok ())) - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-unexpected-exceptions" - |> Prelude.pure, - test "async exceptions produce expected debugging info" <| \_ -> - Expect.withIO - identity - <| do + recordedTracingSpans + spans + |> Debug.toString + |> Expect.equalToContentsOf "tests/golden-results/log-unexpected-exceptions", + test "async exceptions produce expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do (recordedTracingSpans, handler) <- newHandler threadId <- Control.Concurrent.myThreadId _ <- @@ -120,25 +115,24 @@ |> withContext "outer span" [context "number" (825 :: Int)] |> Task.attempt handler |> Exception.handleAsync (\(Exception.AsyncExceptionWrapper _) -> Prelude.pure (Ok ())) - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-async-exceptions" - |> Prelude.pure, - test "secrets do not appear in debugging info" <| \_ -> - Expect.withIO identity <| do - (recordedTracingSpans, handler) <- newHandler - _ <- - info - "logging a message!" - [context "secret" (Log.mkSecret ("Mango's are delicious" :: Text))] - |> Task.attempt handler - spans <- recordedTracingSpans - spans - |> Debug.toString - |> Text.contains "Mango" - |> Expect.equal False - |> Prelude.pure, + recordedTracingSpans + spans + |> Debug.toString + |> Expect.equalToContentsOf "tests/golden-results/log-async-exceptions", + test "secrets do not appear in debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler + _ <- + info + "logging a message!" + [context "secret" (Log.mkSecret ("Mango's are delicious" :: Text))] + |> Task.attempt handler + recordedTracingSpans + spans + |> Debug.toString + |> Text.contains "Mango" + |> Expect.equal False, -- Haskell's default @show@ instance prints the shown Haskell value on a -- single line. This isn't great when using @show@ to debug larger Haskell -- values. That's why our @Debug.toString@ implementation uses the diff --git a/tests/SetSpec.hs b/tests/SetSpec.hs --- a/tests/SetSpec.hs +++ b/tests/SetSpec.hs @@ -1,7 +1,6 @@ module SetSpec (tests) where import qualified Expect -import List (List) import qualified List import NriPrelude import Set (Set) diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs --- a/tests/TestSpec.hs +++ b/tests/TestSpec.hs @@ -6,14 +6,15 @@ import qualified Data.Text import qualified Data.Text.IO import qualified Expect -import qualified Expect.Task import qualified Fuzz import qualified GHC.Exts import qualified GHC.Stack as Stack import NriPrelude +import qualified Platform import qualified Platform.Internal import qualified System.IO -import Test (Test, describe, fuzz, fuzz2, fuzz3, only, skip, task, test, todo) +import qualified Task +import Test (Test, describe, fuzz, fuzz2, fuzz3, only, skip, test, todo) import qualified Test.Internal as Internal import qualified Test.Reporter.Logfile import qualified Test.Reporter.Stdout @@ -32,62 +33,57 @@ api = describe "Api" - [ task "suite result is 'AllPassed' when all tests passed" <| do + [ test "suite result is 'AllPassed' when all tests passed" <| \_ -> do let suite = describe "suite" [ test "test 1" (\_ -> Expect.pass), test "test 2" (\_ -> Expect.pass) ] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal (AllPassed ["test 1", "test 2"]) - |> Expect.Task.check, - task "suite result is 'OnlysPassed' when containing an `only`" <| do + |> Expect.equal (AllPassed ["test 1", "test 2"]), + test "suite result is 'OnlysPassed' when containing an `only`" <| \_ -> do let suite = describe "suite" [ test "test 1" (\_ -> Expect.pass), only <| test "test 2" (\_ -> Expect.pass) ] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal (OnlysPassed ["test 2"] ["test 1"]) - |> Expect.Task.check, - task "suite result is 'PassedWithSkipped' when containing skipped test" <| do + |> Expect.equal (OnlysPassed ["test 2"] ["test 1"]), + test "suite result is 'PassedWithSkipped' when containing skipped test" <| \_ -> do let suite = describe "suite" [ test "test 1" (\_ -> Expect.pass), skip <| test "test 2" (\_ -> Expect.pass) ] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]) - |> Expect.Task.check, - task "suite result is 'PassedWithSkipped' when containing a todo test" <| do + |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]), + test "suite result is 'PassedWithSkipped' when containing a todo test" <| \_ -> do let suite = describe "suite" [ test "test 1" (\_ -> Expect.pass), todo "test 2" ] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]) - |> Expect.Task.check, - task "suite result is 'NoTestsInSuite' when it contains no tests" <| do + |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]), + test "suite result is 'NoTestsInSuite' when it contains no tests" <| \_ -> do let suite = describe "suite" [] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal NoTestsInSuite - |> Expect.Task.check, - task "suite result is 'TestsFailed' when it contains a failing test" <| do + |> Expect.equal NoTestsInSuite, + test "suite result is 'TestsFailed' when it contains a failing test" <| \_ -> do let suite = describe "suite" @@ -95,11 +91,10 @@ skip <| test "test 2" (\_ -> Expect.pass), test "test 3" (\_ -> Expect.fail "oops") ] - result <- Internal.run suite + result <- Expect.succeeds <| Internal.run suite result |> simplify - |> Expect.equal (TestsFailed ["test 1"] ["test 2"] ["test 3"]) - |> Expect.Task.check, + |> Expect.equal (TestsFailed ["test 1"] ["test 2"] ["test 3"]), test "nested describes are exposed on each test" <| \_ -> let suite = describe @@ -121,9 +116,6 @@ test "source location of `todo` are the file in which the test is defined" <| \_ -> todo "test 1" |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), - test "source location of `task` are the file in which the test is defined" <| \_ -> - task "test 1" (Expect.Task.check Expect.pass) - |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), test "source location of `fuzz` are the file in which the test is defined" <| \_ -> fuzz Fuzz.int "test 1" (\_ -> Expect.pass) |> expectSingleTest (expectSrcFile "tests/TestSpec.hs"), @@ -189,7 +181,7 @@ stdoutReporter = describe "Stdout Reporter" - [ task "all passed" <| do + [ test "all passed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -200,9 +192,8 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-all-passed" - |> Expect.Task.check, - task "onlys passed" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-all-passed", + test "onlys passed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -216,9 +207,8 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-onlys-passed" - |> Expect.Task.check, - task "passed with skipped" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-onlys-passed", + test "passed with skipped" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -232,9 +222,8 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-passed-with-skipped" - |> Expect.Task.check, - task "no tests in suite" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-passed-with-skipped", + test "no tests in suite" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -242,9 +231,8 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-no-tests-in-suite" - |> Expect.Task.check, - task "tests failed" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-no-tests-in-suite", + test "tests failed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -255,7 +243,7 @@ [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan ] - [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error"), + [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error" Nothing), mockTest "test 6" (mockTracingSpan, Internal.ThrewException mockException), mockTest "test 7" (mockTracingSpan, Internal.TookTooLong), mockTest "test 7" (mockTracingSpan, Internal.TestRunnerMessedUp "sorry") @@ -263,15 +251,53 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed" - |> Expect.Task.check + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed", + test "tests failed (actually running)" <| \_ -> do + 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 4" + ( \_ -> + 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 (\_ -> ())) + ] + contents <- + withTempFile + ( \_ handle -> do + log <- Platform.silentHandler + result <- + Internal.run suite + |> Task.perform log + Test.Reporter.Stdout.report handle result + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed-loc" ] logfileReporter :: Test logfileReporter = describe "Logfile Reporter" - [ task "all passed" <| do + [ test "all passed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -282,9 +308,8 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-all-passed" - |> Expect.Task.check, - task "onlys passed" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-all-passed", + test "onlys passed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -298,9 +323,8 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-onlys-passed" - |> Expect.Task.check, - task "passed with skipped" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-onlys-passed", + test "passed with skipped" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -314,9 +338,8 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-passed-with-skipped" - |> Expect.Task.check, - task "no tests in suite" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-passed-with-skipped", + test "no tests in suite" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -324,9 +347,8 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-no-tests-in-suite" - |> Expect.Task.check, - task "tests failed" <| do + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-no-tests-in-suite", + test "tests failed" <| \_ -> do contents <- withTempFile ( \_ handle -> @@ -337,7 +359,7 @@ [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan ] - [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error"), + [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error" Nothing), mockTest "test 6" (mockTracingSpan, Internal.ThrewException mockException), mockTest "test 7" (mockTracingSpan, Internal.TookTooLong), mockTest "test 7" (mockTracingSpan, Internal.TestRunnerMessedUp "sorry") @@ -346,7 +368,6 @@ ) contents |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-tests-failed" - |> Expect.Task.check ] writeSpan :: System.IO.Handle -> Platform.Internal.TracingSpan -> Prelude.IO () @@ -357,7 +378,7 @@ -- | Provide a temporary file for a test to do some work in, then return the -- contents of the file when the test is done with it. -withTempFile :: (System.IO.FilePath -> System.IO.Handle -> Prelude.IO ()) -> Task e Text +withTempFile :: (System.IO.FilePath -> System.IO.Handle -> Prelude.IO ()) -> Expect.Expectation' Text withTempFile go = do Platform.Internal.Task ( \_ -> do @@ -368,6 +389,7 @@ Data.Text.IO.readFile path |> map Ok ) + |> Expect.succeeds mockTest :: Text -> body -> Internal.SingleTest body mockTest name body =