diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,29 @@ -# Unreleased next version +# Unreleased + +# 0.7.0.0 + +- **Breaking:** `Platform.rootTracingSpanIO` and the internal `mkHandler` now take an additional `Aeson.Value -> Task Never ()` callback for analytics event delivery. Existing callers should pass `Platform.silentTrack` to preserve previous behavior. +- New: `Platform.Analytics.Internal.trackEvent`. The `.Internal` suffix is intentional — wrap it in your own typed `track` API. This module is NOT re-exported from `Platform`. +- New: `Platform.silentTrack` (a no-op `Aeson.Value -> Task Never ()`). The `Task`-shaped callback gives wire-layer implementations access to the surrounding `LogHandler` for logging and tracing, so delivery errors flow through the normal observability pipeline. +- New: `LogHandler.trackAnalyticsEvent` field. `nullHandler` defaults this to `silentTrack`. +- Drop support for GHC 8.10.7, GHC 9.2.x, GHC 9.4.x, `aeson-1.x` +- Support GHC 9.6.7, GHC 9.8.4, GHC 9.10.2, GHC 9.12.2, `bytestring-0.12.x.x`, `text-2.1.x`, `aeson-2.2.x.x`, `safe-coloured-text-0.3.x.x`, `safe-coloured-text-terminfo-0.3.x.x`, `lens-5.3.x`, `hedgehog-1.5.x`, `auto-update-0.2.x`, `containers-0.7.x`, `filepath-1.5.x` +- Allow specifying where devlogs for log-explorer go through `NRI_DEV_LOG` environment variable. +- Added `putText` and `putTextLn` functions for thread-safe console printing. +- Add `Fuzz.shuffle`. + +# 0.6.1.2 + +- Support GHC 9.4.7, `aeson-2.1.x`, `lens-5.2.x`, `hedgehog-1.3`, `vector-0.13.x` + +# 0.6.1.1 + +- Support GHC 9.2.6. + +# 0.6.1.0 + +- Fix support for `aeson-2.x` +- Permit `hedgehog-1.1.x`, `lens-5.1.x`, `safe-coloured-text-0.2.x`, and `safe-coloured-text-terminfo-0.1.x` # 0.6.0.6 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2022, NoRedInk +Copyright (c) 2026, NoRedInk All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,8 @@ A Prelude inspired by the Elm programming language. +For those interested in learning more about our reasons for developing these libraries, we invite you to check out our blog post titled "Haskell for the Elm Enthusiast" available at https://blog.noredink.com/post/658510851000713216/haskell-for-the-elm-enthusiast. This post provides insights into the motivations behind our efforts. + enable ghc option ``` diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 --- This file has been generated from package.yaml by hpack version 0.34.5. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: nri-prelude -version: 0.6.0.6 +version: 0.7.0.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -13,7 +13,7 @@ bug-reports: https://github.com/NoRedInk/haskell-libraries/issues author: NoRedInk maintainer: haskell-open-source@noredink.com -copyright: 2022 NoRedInk Corp. +copyright: 2026 NoRedInk Corp. license: BSD3 license-file: LICENSE build-type: Simple @@ -45,6 +45,7 @@ NriPrelude NriPrelude.Plugin Platform + Platform.Analytics.Internal Process Result Set @@ -53,12 +54,14 @@ Text Tuple other-modules: + Internal.IO Internal.Shortcut Internal.Terminal NriPrelude.Plugin.GhcVersionDependent Platform.DevLog Platform.DoAnything Platform.Internal + Test.CliParser Test.Internal Test.Reporter.ExitCode Test.Reporter.Internal @@ -84,30 +87,31 @@ TypeOperators ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns build-depends: - aeson >=1.4.6.0 && <2.1 + aeson >=2.0 && <2.3 , aeson-pretty >=0.8.0 && <0.9 , async >=2.2.2 && <2.3 - , auto-update >=0.1.6 && <0.2 - , base >=4.12.0.0 && <4.17 - , bytestring >=0.10.8.2 && <0.12 - , containers >=0.6.0.1 && <0.7 + , attoparsec >=0.13.0.0 && <0.15 + , auto-update >=0.1.6 && <0.3 + , base >=4.18 && <4.22 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.6.0.1 && <0.8 , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 - , filepath >=1.4.2.1 && <1.5 - , ghc >=8.6.1 && <9.3 - , hedgehog >=1.0.2 && <1.1 + , filepath >=1.4.2.1 && <1.6 + , ghc >=9.6 && <9.14 + , hedgehog >=1.0.2 && <1.6 , junit-xml >=0.1.0.0 && <0.2.0.0 - , lens >=4.16.1 && <5.1 + , lens >=4.16.1 && <5.4 , pretty-diff >=0.4.0.2 && <0.5 , pretty-show >=1.9.5 && <1.11 - , safe-coloured-text >=0.1.0.0 && <0.2 - , safe-coloured-text-terminfo >=0.0.0.0 && <0.1 + , safe-coloured-text >=0.1.0.0 && <0.4 + , safe-coloured-text-terminfo >=0.0.0.0 && <0.4 , safe-exceptions >=0.1.7.0 && <1.3 , terminal-size >=0.3.2.1 && <0.4 - , text >=1.2.3.1 && <2.1 + , text >=1.2.3.1 && <2.2 , time >=1.8.0.2 && <2 - , unix >=2.7.2.2 && <2.8.0.0 - , vector >=0.12.1.2 && <0.13 + , unix >=2.7.2.2 && <2.9 + , vector >=0.12.1.2 && <0.14 default-language: Haskell2010 test-suite tests @@ -118,9 +122,11 @@ BitwiseSpec DebugSpec DictSpec + GoldenHelpers LogSpec PlatformSpec SetSpec + TaskSpec TestSpec TextSpec Array @@ -131,6 +137,7 @@ Dict Expect Fuzz + Internal.IO Internal.Shortcut Internal.Terminal List @@ -140,6 +147,7 @@ NriPrelude.Plugin NriPrelude.Plugin.GhcVersionDependent Platform + Platform.Analytics.Internal Platform.DevLog Platform.DoAnything Platform.Internal @@ -148,6 +156,7 @@ Set Task Test + Test.CliParser Test.Internal Test.Reporter.ExitCode Test.Reporter.Internal @@ -177,28 +186,29 @@ 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 && <2.1 + aeson >=2.0 && <2.3 , aeson-pretty >=0.8.0 && <0.9 , async >=2.2.2 && <2.3 - , auto-update >=0.1.6 && <0.2 - , base >=4.12.0.0 && <4.17 - , bytestring >=0.10.8.2 && <0.12 - , containers >=0.6.0.1 && <0.7 + , attoparsec >=0.13.0.0 && <0.15 + , auto-update >=0.1.6 && <0.3 + , base >=4.18 && <4.22 + , bytestring >=0.10.8.2 && <0.13 + , containers >=0.6.0.1 && <0.8 , directory >=1.3.3.0 && <1.4 , exceptions >=0.10.4 && <0.11 - , filepath >=1.4.2.1 && <1.5 - , ghc >=8.6.1 && <9.3 - , hedgehog >=1.0.2 && <1.1 + , filepath >=1.4.2.1 && <1.6 + , ghc >=9.6 && <9.14 + , hedgehog >=1.0.2 && <1.6 , junit-xml >=0.1.0.0 && <0.2.0.0 - , lens >=4.16.1 && <5.1 + , lens >=4.16.1 && <5.4 , pretty-diff >=0.4.0.2 && <0.5 , pretty-show >=1.9.5 && <1.11 - , safe-coloured-text >=0.1.0.0 && <0.2 - , safe-coloured-text-terminfo >=0.0.0.0 && <0.1 + , safe-coloured-text >=0.1.0.0 && <0.4 + , safe-coloured-text-terminfo >=0.0.0.0 && <0.4 , safe-exceptions >=0.1.7.0 && <1.3 , terminal-size >=0.3.2.1 && <0.4 - , text >=1.2.3.1 && <2.1 + , text >=1.2.3.1 && <2.2 , time >=1.8.0.2 && <2 - , unix >=2.7.2.2 && <2.8.0.0 - , vector >=0.12.1.2 && <0.13 + , unix >=2.7.2.2 && <2.9 + , vector >=0.12.1.2 && <0.14 default-language: Haskell2010 diff --git a/src/Array.hs b/src/Array.hs --- a/src/Array.hs +++ b/src/Array.hs @@ -95,8 +95,8 @@ -- > initialize 4 (always 0) == fromList [0,0,0,0] initialize :: Int -> (Int -> a) -> Array a initialize n f = - Array - <| Data.Vector.generate + Array <| + Data.Vector.generate (Prelude.fromIntegral n) (Prelude.fromIntegral >> f) @@ -108,8 +108,8 @@ -- Notice that @repeat 3 x@ is the same as @initialize 3 (always x)@. repeat :: Int -> a -> Array a repeat n e = - Array - <| Data.Vector.replicate (Prelude.fromIntegral n) e + Array <| + Data.Vector.replicate (Prelude.fromIntegral n) e -- | Create an array from a 'List'. fromList :: List a -> Array a diff --git a/src/Basics.hs b/src/Basics.hs --- a/src/Basics.hs +++ b/src/Basics.hs @@ -196,21 +196,21 @@ -- to be sure exactly what type of number you are dealing with. When you try to -- /infer/ these conversions (as Scala does) it can be even more confusing. Elm -- has opted for a design that makes all conversions explicit. -(+) :: Prelude.Num number => number -> number -> number +(+) :: (Prelude.Num number) => number -> number -> number (+) = (Prelude.+) -- | Subtract numbers like @4 - 3 == 1@. -- -- See @'(+)'@ for docs on the @number@ type variable. -(-) :: Prelude.Num number => number -> number -> number +(-) :: (Prelude.Num number) => number -> number -> number (-) = (Prelude.-) -- | Multiply numbers like @2 * 3 == 6@. -- -- See @'(+)'@ for docs on the @number@ type variable. -(*) :: Prelude.Num number => number -> number -> number +(*) :: (Prelude.Num number) => number -> number -> number (*) = (Prelude.*) @@ -317,7 +317,7 @@ -- Breaking from Elm, this relies on Haskell's @Eq@ typeclass. For example: -- -- > data Foo = Bar | Baz deriving (Eq) -(==) :: Prelude.Eq a => a -> a -> Bool +(==) :: (Prelude.Eq a) => a -> a -> Bool (==) = (Prelude.==) @@ -326,27 +326,23 @@ -- Like with @(==)@, this relies on Haskell's @Eq@ typeclass. -- -- So @(a /= b)@ is the same as @(not (a == b))@. -(/=) :: Prelude.Eq a => a -> a -> Bool +(/=) :: (Prelude.Eq a) => a -> a -> Bool (/=) = (Prelude./=) --- | -(<) :: Prelude.Ord comparable => comparable -> comparable -> Bool +(<) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool (<) = (Prelude.<) --- | -(>) :: Prelude.Ord comparable => comparable -> comparable -> Bool +(>) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool (>) = (Prelude.>) --- | -(<=) :: Prelude.Ord comparable => comparable -> comparable -> Bool +(<=) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool (<=) = (Prelude.<=) --- | -(>=) :: Prelude.Ord comparable => comparable -> comparable -> Bool +(>=) :: (Prelude.Ord comparable) => comparable -> comparable -> Bool (>=) = (Prelude.>=) @@ -354,7 +350,7 @@ -- -- > max 42 12345678 == 12345678 -- > max "abc" "xyz" == "xyz" -max :: Prelude.Ord comparable => comparable -> comparable -> comparable +max :: (Prelude.Ord comparable) => comparable -> comparable -> comparable max = Prelude.max @@ -362,7 +358,7 @@ -- -- > min 42 12345678 == 42 -- > min "abc" "xyz" == "abc" -min :: Prelude.Ord comparable => comparable -> comparable -> comparable +min :: (Prelude.Ord comparable) => comparable -> comparable -> comparable min = Prelude.min @@ -373,7 +369,7 @@ -- > compare 3 4 == LT -- > compare 4 4 == EQ -- > compare 5 4 == GT -compare :: Prelude.Ord comparable => comparable -> comparable -> Order +compare :: (Prelude.Ord comparable) => comparable -> comparable -> Order compare = Prelude.compare @@ -428,7 +424,7 @@ -- -- > "hello" ++ "world" == "helloworld" -- > [1,1,2] ++ [3,5,8] == [1,1,2,3,5,8] -(++) :: Prelude.Semigroup appendable => appendable -> appendable -> appendable +(++) :: (Prelude.Semigroup appendable) => appendable -> appendable -> appendable (++) = (Prelude.<>) @@ -466,7 +462,7 @@ -- negate 42 == -42 -- negate -42 == 42 -- negate 0 == 0 -negate :: Prelude.Num number => number -> number +negate :: (Prelude.Num number) => number -> number negate = Prelude.negate @@ -477,7 +473,7 @@ -- > abs -4 == 4 -- > abs -8.5 == 8.5 -- > abs 3.14 == 3.14 -abs :: Prelude.Num number => number -> number +abs :: (Prelude.Num number) => number -> number abs = Prelude.abs @@ -487,7 +483,7 @@ -- > 100 if x < 100 -- > x if 100 <= x < 200 -- > 200 if 200 <= x -clamp :: Prelude.Ord number => number -> number -> number -> number +clamp :: (Prelude.Ord number) => number -> number -> number -> number clamp low high number | number < low = low | number > high = high diff --git a/src/Debug.hs b/src/Debug.hs --- a/src/Debug.hs +++ b/src/Debug.hs @@ -27,7 +27,7 @@ -- 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"@. -toString :: Show a => a -> Text +toString :: (Show a) => a -> Text toString = Text.Show.Pretty.ppShow >> pack @@ -38,7 +38,7 @@ -- -- It is often possible to sprinkle this around to see if values are what you -- expect. It is kind of old-school to do it this way, but it works! -log :: Show a => Text -> a -> a +log :: (Show a) => Text -> a -> a log message value = Debug.Trace.trace (unpack (concat [message, ": ", toString value])) value @@ -62,6 +62,6 @@ -- -- When you call this it throws an exception with the message you give. That -- exception is catchable... but don't. -todo :: Stack.HasCallStack => Text -> a +todo :: (Stack.HasCallStack) => Text -> a todo = Stack.withFrozenCallStack (unpack >> error) diff --git a/src/Dict.hs b/src/Dict.hs --- a/src/Dict.hs +++ b/src/Dict.hs @@ -86,12 +86,12 @@ -- > get "Tom" animals == Just Cat -- > get "Jerry" animals == Just Mouse -- > get "Spike" animals == Nothing -get :: Ord comparable => comparable -> Dict comparable v -> Maybe v +get :: (Ord comparable) => comparable -> Dict comparable v -> Maybe v get = Data.Map.Strict.lookup -- | Determine if a key is in a dictionary. -member :: Ord comparable => comparable -> Dict comparable v -> Bool +member :: (Ord comparable) => comparable -> Dict comparable v -> Bool member = Data.Map.Strict.member @@ -109,18 +109,18 @@ -- | Insert a key-value pair into a dictionary. Replaces value when there is -- a collision. -insert :: Ord comparable => comparable -> v -> Dict comparable v -> Dict comparable v +insert :: (Ord comparable) => comparable -> v -> Dict comparable v -> Dict comparable v insert = Data.Map.Strict.insert -- | Remove a key-value pair from a dictionary. If the key is not found, -- no changes are made. -remove :: Ord comparable => comparable -> Dict comparable v -> Dict comparable v +remove :: (Ord comparable) => comparable -> Dict comparable v -> Dict comparable v remove = Data.Map.Strict.delete -- | Update the value of a dictionary for a specific key with a given function. -update :: Ord comparable => comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v +update :: (Ord comparable) => comparable -> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v update targetKey alter dictionary = let maybeItemToSet = Data.Map.Strict.lookup targetKey dictionary |> alter @@ -139,18 +139,18 @@ -- | Combine two dictionaries. If there is a collision, preference is given -- to the first dictionary. -union :: Ord comparable => Dict comparable v -> Dict comparable v -> Dict comparable v +union :: (Ord comparable) => Dict comparable v -> Dict comparable v -> Dict comparable v union = Data.Map.Strict.union -- | Keep a key-value pair when its key appears in the second dictionary. -- Preference is given to values in the first dictionary. -intersect :: Ord comparable => Dict comparable v -> Dict comparable v -> Dict comparable v +intersect :: (Ord comparable) => Dict comparable v -> Dict comparable v -> Dict comparable v intersect = Data.Map.Strict.intersection -- | Keep a key-value pair when its key does not appear in the second dictionary. -diff :: Ord comparable => Dict comparable a -> Dict comparable b -> Dict comparable a +diff :: (Ord comparable) => Dict comparable a -> Dict comparable b -> Dict comparable a diff = Data.Map.Strict.difference @@ -164,7 +164,7 @@ -- You then traverse all the keys from lowest to highest, building up whatever -- you want. merge :: - Ord comparable => + (Ord comparable) => (comparable -> a -> result -> result) -> (comparable -> a -> b -> result -> result) -> (comparable -> b -> result -> result) -> @@ -255,5 +255,5 @@ toList = Data.Map.Strict.toList -- | Convert an association list into a dictionary. -fromList :: Ord comparable => List (comparable, v) -> Dict comparable v +fromList :: (Ord comparable) => List (comparable, v) -> Dict comparable v fromList = Data.Map.Strict.fromList diff --git a/src/Expect.hs b/src/Expect.hs --- a/src/Expect.hs +++ b/src/Expect.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} -- | A library to create @Expectation@s, which describe a claim to be tested. @@ -20,6 +21,9 @@ all, equalToContentsOf, + -- * Heterogeneous Expectations + equalH, + -- * Floating Point Comparisons FloatingPointTolerance (..), within, @@ -51,8 +55,11 @@ andCheck, -- * Fancy Expectations - fromIO, + Internal.fromIO, + Internal.runExpectation, + Internal.fromIOResult, Internal.Expectation', + Internal.Failure, around, ) where @@ -63,7 +70,6 @@ import qualified GHC.Stack as Stack import qualified List import NriPrelude -import qualified Platform.Internal import qualified Pretty.Diff as Diff import qualified System.Console.Terminal.Size as Terminal import qualified System.Directory as Directory @@ -72,6 +78,7 @@ import Test.Internal (Expectation) import qualified Test.Internal as Internal import qualified Text.Show.Pretty +import Type.Reflection (Typeable, eqTypeRep, typeOf, (:~~:) (HRefl)) import qualified Prelude -- | Always passes. @@ -89,7 +96,7 @@ -- > -- > Err err -> -- > Expect.fail err -pass :: Stack.HasCallStack => Expectation +pass :: (Stack.HasCallStack) => Expectation pass = Stack.withFrozenCallStack Internal.pass "Expect.pass" () -- | Fails with the given message. @@ -107,7 +114,7 @@ -- > -- > Err err -> -- > Expect.fail err -fail :: Stack.HasCallStack => Text -> Expectation +fail :: (Stack.HasCallStack) => Text -> Expectation fail msg = Stack.withFrozenCallStack Internal.failAssertion "Expect.fail" msg @@ -116,7 +123,7 @@ -- > "something" -- > |> Expect.equal "something else" -- > |> Expect.onFail "thought those two strings would be the same" -onFail :: Stack.HasCallStack => Text -> Expectation -> Expectation +onFail :: (Stack.HasCallStack) => Text -> Expectation -> Expectation onFail msg (Internal.Expectation task) = task |> Task.onError @@ -150,6 +157,23 @@ equal :: (Stack.HasCallStack, Show a, Eq a) => a -> a -> Expectation equal = Stack.withFrozenCallStack assert (==) "Expect.equal" +-- | Passes if the arguments are equal and of the same type +-- useful for usage with GADTs, existential quantification and +-- type applications. +-- Prefer the usage of Expect.equal! +-- +-- > Expect.equalH 0 "" +-- > +-- > -- Fails because 0 is not the same type as "" +equalH :: (Stack.HasCallStack, Show a, Show b, Eq a, Typeable a, Typeable b) => a -> b -> Expectation +equalH = Stack.withFrozenCallStack assert equalHPredicate "Expect.equalH" + +equalHPredicate :: (Eq a, Typeable a, Typeable b) => a -> b -> Bool +equalHPredicate x y = + case eqTypeRep (typeOf x) (typeOf y) of + Nothing -> False + Just HRefl -> x == y + -- | Passes if the arguments are not equal. -- -- > -- Passes because (11 /= 100) is True @@ -348,7 +372,7 @@ -- > Expected the list to be empty. -- > -- > -} -true :: Stack.HasCallStack => Bool -> Expectation +true :: (Stack.HasCallStack) => Bool -> Expectation true x = if x then Stack.withFrozenCallStack Internal.pass "Expect.true" () @@ -371,7 +395,7 @@ -- > Expected the list not to be empty. -- > -- > -} -false :: Stack.HasCallStack => Bool -> Expectation +false :: (Stack.HasCallStack) => Bool -> Expectation false x = if x then Stack.withFrozenCallStack Internal.failAssertion "Expect.false" "I expected a False but got True" @@ -404,7 +428,7 @@ -- > ╵ -- > -10 -- > -} -all :: Stack.HasCallStack => List (subject -> Expectation) -> subject -> Expectation +all :: (Stack.HasCallStack) => List (subject -> Expectation) -> subject -> Expectation all expectations subject = List.foldl ( \expectation acc -> @@ -501,16 +525,16 @@ -- 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 :: Stack.HasCallStack => Text -> Text -> Expectation +equalToContentsOf :: (Stack.HasCallStack) => Text -> Text -> Expectation equalToContentsOf filepath' actual = do let filepath = Data.Text.unpack filepath' exists <- - fromIO <| do + Internal.fromIO <| do Directory.createDirectoryIfMissing True (FilePath.takeDirectory filepath) Directory.doesFileExist filepath if exists then do - expected <- fromIO (Data.Text.IO.readFile filepath) + expected <- Internal.fromIO (Data.Text.IO.readFile filepath) Stack.withFrozenCallStack assert (==) @@ -518,7 +542,7 @@ (UnescapedShow expected) (UnescapedShow actual) else do - fromIO (Data.Text.IO.writeFile filepath actual) + Internal.fromIO (Data.Text.IO.writeFile filepath actual) Stack.withFrozenCallStack Internal.pass ("Expect.equalToContentsOf " ++ filepath') @@ -544,20 +568,20 @@ instance Show UnescapedShow where show (UnescapedShow text) = Data.Text.unpack text -assert :: (Stack.HasCallStack, Show a) => (a -> a -> Bool) -> Text -> a -> a -> Expectation +assert :: (Stack.HasCallStack, Show a, Show b) => (a -> b -> Bool) -> Text -> a -> b -> Expectation assert pred funcName expected actual = if pred expected actual then Stack.withFrozenCallStack Internal.pass funcName () else do - window <- fromIO Terminal.size + window <- Internal.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 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 + Stack.withFrozenCallStack Internal.failAssertion funcName <| + Diff.pretty Diff.Config { Diff.separatorText = Just funcName, Diff.wrapping = Diff.Wrap terminalWidth, @@ -569,13 +593,6 @@ expectedText actualText --- | 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 - -- | Used for making matchers -- expectOneItem :: Expectation' [a] -> Expectation' a -- expectOneItem t = do @@ -644,8 +661,8 @@ |> Task.onError (\err' -> Task.succeed (Ok err')) |> Task.andThen ( \res -> - Internal.unExpectation - <| case res of + Internal.unExpectation <| + case res of Ok a -> Stack.withFrozenCallStack Internal.pass diff --git a/src/Fuzz.hs b/src/Fuzz.hs --- a/src/Fuzz.hs +++ b/src/Fuzz.hs @@ -22,6 +22,7 @@ result, list, array, + shuffle, -- * Working with Fuzzers Fuzzer, @@ -132,6 +133,12 @@ array itemFuzzer = list itemFuzzer |> map Array.fromList + +-- | Given a list of a type, create a fuzzer of random permutation of that list. +shuffle :: List a -> Fuzzer (List a) +shuffle list = + Gen.shuffle list + |> Fuzzer -- | Choose one of the given fuzzers at random. Each fuzzer has an equal chance -- of being chosen; to customize the probabilities, use 'frequency'. diff --git a/src/Internal/IO.hs b/src/Internal/IO.hs new file mode 100644 --- /dev/null +++ b/src/Internal/IO.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE BlockArguments #-} + +module Internal.IO + ( putText, + putTextLn, + ) +where + +import Control.Concurrent.MVar +import System.IO.Unsafe (unsafePerformIO) +import Text +import qualified Prelude + +{-# NOINLINE stdoutLock #-} +stdoutLock :: MVar () +stdoutLock = unsafePerformIO (newMVar ()) + +-- Output functions + +-- | Write text to stdout. +-- +-- This function is similar to `Prelude.putStr` but receives a `Text` instead of a `Prelude.String`. +-- Also this function is thread-safe, using a lock to prevent interleaved output. +putText :: Text -> Prelude.IO () +putText text = do + withMVar stdoutLock \_ -> + Prelude.putStr (Text.toList text) + +-- | Write text to stdout followed by a newline. +-- +-- This function is similar to `Prelude.putStrLn` but receives a `Text` instead of a `Prelude.String`. +-- Also this function is thread-safe, using a lock to prevent interleaved output. +putTextLn :: Text -> Prelude.IO () +putTextLn text = do + withMVar stdoutLock \_ -> + Prelude.putStrLn (Text.toList text) diff --git a/src/Internal/Shortcut.hs b/src/Internal/Shortcut.hs --- a/src/Internal/Shortcut.hs +++ b/src/Internal/Shortcut.hs @@ -19,67 +19,54 @@ import Prelude (Applicative, Functor, Monad, fmap, pure, (<*>), (>>=)) --- | -andThen :: Monad m => (a -> m b) -> m a -> m b +andThen :: (Monad m) => (a -> m b) -> m a -> m b andThen b a = a >>= b --- | -afterwards :: Monad m => m b -> m a -> m b +afterwards :: (Monad m) => m b -> m a -> m b afterwards b a = a >>= (\_ -> b) --- | -map :: Functor m => (a -> value) -> m a -> m value +map :: (Functor m) => (a -> value) -> m a -> m value map = fmap --- | -map2 :: Applicative m => (a -> b -> value) -> m a -> m b -> m value +map2 :: (Applicative m) => (a -> b -> value) -> m a -> m b -> m value map2 func a b = pure func <*> a <*> b --- | -map3 :: Applicative m => (a -> b -> c -> value) -> m a -> m b -> m c -> m value +map3 :: (Applicative m) => (a -> b -> c -> value) -> m a -> m b -> m c -> m value map3 func a b c = pure func <*> a <*> b <*> c --- | -map4 :: Applicative m => (a -> b -> c -> d -> value) -> m a -> m b -> m c -> m d -> m value +map4 :: (Applicative m) => (a -> b -> c -> d -> value) -> m a -> m b -> m c -> m d -> m value map4 func a b c d = pure func <*> a <*> b <*> c <*> d --- | -map5 :: Applicative m => (a -> b -> c -> d -> e -> value) -> m a -> m b -> m c -> m d -> m e -> m value +map5 :: (Applicative m) => (a -> b -> c -> d -> e -> value) -> m a -> m b -> m c -> m d -> m e -> m value map5 func a b c d e = pure func <*> a <*> b <*> c <*> d <*> e --- | -map6 :: Applicative m => (a -> b -> c -> d -> e -> f -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m value +map6 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m value map6 func a b c d e f = pure func <*> a <*> b <*> c <*> d <*> e <*> f --- | -map7 :: Applicative m => (a -> b -> c -> d -> e -> f -> g -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m value +map7 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m value map7 func a b c d e f g = pure func <*> a <*> b <*> c <*> d <*> e <*> f <*> g --- | -map8 :: Applicative m => (a -> b -> c -> d -> e -> f -> g -> h -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m value +map8 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> h -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m value map8 func a b c d e f g h = pure func <*> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h --- | -map9 :: Applicative m => (a -> b -> c -> d -> e -> f -> g -> h -> i -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m i -> m value +map9 :: (Applicative m) => (a -> b -> c -> d -> e -> f -> g -> h -> i -> value) -> m a -> m b -> m c -> m d -> m e -> m f -> m g -> m h -> m i -> m value map9 func a b c d e f g h i = pure func <*> a <*> b <*> c <*> d <*> e <*> f <*> g <*> h <*> i --- | -andMap :: Applicative m => m a -> m (a -> b) -> m b +andMap :: (Applicative m) => m a -> m (a -> b) -> m b andMap m mf = mf <*> m --- | -blank :: Monad m => m () +blank :: (Monad m) => m () blank = pure () diff --git a/src/Internal/Terminal.hs b/src/Internal/Terminal.hs --- a/src/Internal/Terminal.hs +++ b/src/Internal/Terminal.hs @@ -6,12 +6,10 @@ import qualified Text import qualified Prelude as P --- | write :: Text.Text -> P.IO () write string = P.putStr (Data.Text.unpack string) --- | read :: P.IO Text.Text read = P.getLine diff --git a/src/List.hs b/src/List.hs --- a/src/List.hs +++ b/src/List.hs @@ -181,7 +181,7 @@ -- -- > member 9 [1,2,3,4] == False -- > member 4 [1,2,3,4] == True -member :: Prelude.Eq a => a -> List a -> Bool +member :: (Prelude.Eq a) => a -> List a -> Bool member = Data.List.elem @@ -207,7 +207,7 @@ -- -- > maximum [1,4,2] == Just 4 -- > maximum [] == Nothing -maximum :: Ord a => List a -> Maybe a +maximum :: (Ord a) => List a -> Maybe a maximum list = case list of [] -> @@ -219,7 +219,7 @@ -- -- > minimum [3,2,1] == Just 1 -- > minimum [] == Nothing -minimum :: Ord a => List a -> Maybe a +minimum :: (Ord a) => List a -> Maybe a minimum list = case list of [] -> @@ -230,14 +230,14 @@ -- | Get the sum of the list elements. -- -- > sum [1,2,3,4] == 10 -sum :: Num a => List a -> a +sum :: (Num a) => List a -> a sum = Data.Foldable.sum -- | Get the product of the list elements. -- -- > product [1,2,3,4] == 24 -product :: Num a => List a -> a +product :: (Num a) => List a -> a product = Data.Foldable.product @@ -319,7 +319,7 @@ -- | Sort values from lowest to highest -- -- > sort [3,1,5] == [1,3,5] -sort :: Ord a => List a -> List a +sort :: (Ord a) => List a -> List a sort = Data.List.sort @@ -333,7 +333,7 @@ -- > sortBy .height [chuck,alice,bob] == [alice,chuck,bob] -- > -- > sortBy String.length ["mouse","cat"] == ["cat","mouse"] -sortBy :: Ord b => (a -> b) -> List a -> List a +sortBy :: (Ord b) => (a -> b) -> List a -> List a sortBy = Data.List.sortOn diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -31,6 +31,7 @@ import Data.Aeson ((.=)) import qualified Data.Aeson as Aeson +import Data.Aeson.Key (fromText) import qualified GHC.Stack as Stack import NriPrelude import qualified Platform @@ -46,7 +47,7 @@ -- information that might be relevant for debugging. -- -- > debug "Computation partially succeeded" [context "answer" 2] -debug :: Stack.HasCallStack => Text -> [Context] -> Task e () +debug :: (Stack.HasCallStack) => Text -> [Context] -> Task e () debug message contexts = Stack.withFrozenCallStack log @@ -62,7 +63,7 @@ -- information that might be relevant for debugging. -- -- > info "I added 1 and 1" [context "answer" 2] -info :: Stack.HasCallStack => Text -> [Context] -> Task e () +info :: (Stack.HasCallStack) => Text -> [Context] -> Task e () info message contexts = Stack.withFrozenCallStack log @@ -78,7 +79,7 @@ -- 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 :: (Stack.HasCallStack) => Text -> [Context] -> Task e () warn message contexts = Stack.withFrozenCallStack log @@ -93,7 +94,7 @@ -- 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 :: (Stack.HasCallStack) => Text -> [Context] -> Task e () error message contexts = Stack.withFrozenCallStack log @@ -121,7 +122,7 @@ -- the stack trace, since it is used fairly often already. It will not be complete either, but -- it's the best we can do without too much trouble. withContext :: - Stack.HasCallStack => + (Stack.HasCallStack) => Text -> [Context] -> Task e b -> @@ -161,12 +162,12 @@ instance Aeson.ToJSON LogContexts where toJSON (LogContexts contexts) = contexts - |> map (\(Context key val) -> key .= val) + |> map (\(Context key val) -> (fromText key) .= val) |> Aeson.object toEncoding (LogContexts contexts) = contexts - |> Prelude.foldMap (\(Context key val) -> key .= val) + |> Prelude.foldMap (\(Context key val) -> (fromText key) .= val) |> Aeson.pairs instance Internal.TracingSpanDetails LogContexts @@ -234,7 +235,7 @@ -- 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 -log :: Stack.HasCallStack => Text -> ReportStatus -> [Context] -> Task e () +log :: (Stack.HasCallStack) => Text -> ReportStatus -> [Context] -> Task e () log msg reportStatus contexts = Internal.tracingSpan msg <| do Platform.setTracingSpanDetails (LogContexts contexts) diff --git a/src/Maybe.hs b/src/Maybe.hs --- a/src/Maybe.hs +++ b/src/Maybe.hs @@ -70,17 +70,14 @@ map2 = Shortcut.map2 --- | map3 :: (a -> b -> c -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe value map3 = Shortcut.map3 --- | map4 :: (a -> b -> c -> d -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe value map4 = Shortcut.map4 --- | map5 :: (a -> b -> c -> d -> e -> value) -> Maybe a -> Maybe b -> Maybe c -> Maybe d -> Maybe e -> Maybe value map5 = Shortcut.map5 diff --git a/src/NriPrelude.hs b/src/NriPrelude.hs --- a/src/NriPrelude.hs +++ b/src/NriPrelude.hs @@ -20,12 +20,16 @@ fmap, (<*>), (>>=), + + -- * Simple I/O operations + module Internal.IO, ) where import Basics import qualified Char import qualified GHC.Generics +import Internal.IO import Internal.Shortcut import qualified List import qualified Maybe diff --git a/src/NriPrelude/Plugin.hs b/src/NriPrelude/Plugin.hs --- a/src/NriPrelude/Plugin.hs +++ b/src/NriPrelude/Plugin.hs @@ -18,25 +18,14 @@ -- 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 +-- - Module providing API for creating plugins: https://hackage.haskell.org/package/ghc-lib-9.6.5.20240423/docs/GHC-Plugins.html import Data.Function ((&)) import qualified Data.List -#if __GLASGOW_HASKELL__ >= 900 -import qualified GHC.Plugins as GhcPlugins -#else -import GhcPlugins -#endif -import NriPrelude.Plugin.GhcVersionDependent - ( hsmodImports, - hsmodName, - ideclImplicit, - ideclName, - ideclQualified, - isQualified, - mkQualified, - simpleImportDecl, - ) +import qualified GHC.Hs +import qualified GHC.Parser.Annotation +import qualified GHC.Plugins +import NriPrelude.Plugin.GhcVersionDependent (setIDeclImplicit, withParsedResult) import qualified Set import Prelude @@ -47,30 +36,31 @@ -- then add the follwing ghc option to your cabal or package yaml file: -- -- > -fplugin=NriPrelude.Plugin -plugin :: GhcPlugins.Plugin +plugin :: GHC.Plugins.Plugin plugin = - GhcPlugins.defaultPlugin - { GhcPlugins.parsedResultAction = addImplicitImports, + GHC.Plugins.defaultPlugin + { GHC.Plugins.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 + GHC.Plugins.pluginRecompile = GHC.Plugins.purePlugin } addImplicitImports :: - [GhcPlugins.CommandLineOption] -> - GhcPlugins.ModSummary -> - GhcPlugins.HsParsedModule -> - GhcPlugins.Hsc GhcPlugins.HsParsedModule + [GHC.Plugins.CommandLineOption] -> + GHC.Plugins.ModSummary -> + GHC.Plugins.ParsedResult -> + GHC.Plugins.Hsc GHC.Plugins.ParsedResult addImplicitImports _ _ parsed = - Prelude.pure - parsed - { GhcPlugins.hpm_module = - fmap addImportsWhenNotPath (GhcPlugins.hpm_module parsed) - } + Prelude.pure $ + withParsedResult parsed $ \parsed' -> + parsed' + { GHC.Hs.hpm_module = + fmap addImportsWhenNotPath (GHC.Hs.hpm_module parsed') + } where addImportsWhenNotPath hsModule = - case fmap unLocate (hsmodName hsModule) of + case fmap unLocate (GHC.Hs.hsmodName hsModule) of Nothing -> addImports hsModule Just modName -> if Data.List.isPrefixOf "Paths_" modName @@ -79,10 +69,10 @@ addImports hsModule = hsModule - { hsmodImports = + { GHC.Hs.hsmodImports = -- Add default Elm-like imports when the user hasn't imported them -- explicitly yet, in order to avoid duplicate import warnings. - hsmodImports hsModule + GHC.Hs.hsmodImports hsModule ++ ( Set.diff extraImports (existingImports hsModule) & Set.toList & fmap @@ -95,22 +85,32 @@ } existingImports hsModule = - hsmodImports hsModule + GHC.Hs.hsmodImports hsModule & fmap - ( \(GhcPlugins.L _ imp) -> - case (isQualified imp, unLocate (ideclName imp)) of + ( \(GHC.Plugins.L _ imp) -> + case (isQualified imp, unLocate (GHC.Hs.ideclName imp)) of (True, name) -> Qualified name (False, name) -> Unqualified name ) & Set.fromList - unLocate (GhcPlugins.L _ x) = GhcPlugins.moduleNameString x + unLocate (GHC.Plugins.L _ x) = GHC.Plugins.moduleNameString x unqualified name = - GhcPlugins.noLoc (simpleImportDecl (GhcPlugins.mkModuleName name)) - & fmap (\qual -> qual {ideclImplicit = True}) + GHC.Parser.Annotation.noLocA (GHC.Hs.simpleImportDecl (GHC.Plugins.mkModuleName name)) + & fmap (setIDeclImplicit True) qualified name = - fmap (\qual -> qual {ideclQualified = mkQualified}) (unqualified name) + fmap (\qual -> qual {GHC.Hs.ideclQualified = GHC.Hs.QualifiedPre}) (unqualified name) + +-- 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 :: GHC.Hs.ImportDecl pass -> Bool +isQualified imp = + case GHC.Hs.ideclQualified imp of + GHC.Hs.QualifiedPre -> True + GHC.Hs.QualifiedPost -> True + GHC.Hs.NotQualified -> False data Import = Unqualified String diff --git a/src/NriPrelude/Plugin/GhcVersionDependent.hs b/src/NriPrelude/Plugin/GhcVersionDependent.hs --- a/src/NriPrelude/Plugin/GhcVersionDependent.hs +++ b/src/NriPrelude/Plugin/GhcVersionDependent.hs @@ -1,48 +1,34 @@ {-# 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 +-- Imports we need to write this module tend to move around in later +-- versions of GHC. This module uses the CPP extension to import the +-- right values dependent on the version of GHC. -module NriPrelude.Plugin.GhcVersionDependent ( - module HsSyn, - isQualified, - mkQualified, -) where +module NriPrelude.Plugin.GhcVersionDependent + ( setIDeclImplicit, + withParsedResult, + ) +where -import HsSyn +import qualified GHC.Driver.Plugins +import qualified GHC.Hs +import qualified GHC.Hs.ImpExp import Prelude -isQualified :: ImportDecl pass -> Bool -isQualified = ideclQualified - -mkQualified :: Bool -mkQualified = True +withParsedResult :: GHC.Driver.Plugins.ParsedResult -> (GHC.Hs.HsParsedModule -> GHC.Hs.HsParsedModule) -> GHC.Driver.Plugins.ParsedResult +withParsedResult parsed f = + parsed + { GHC.Driver.Plugins.parsedResultModule = f (GHC.Driver.Plugins.parsedResultModule parsed) + } -#endif +setIDeclImplicit :: Bool -> GHC.Hs.ImpExp.ImportDecl GHC.Hs.GhcPs -> GHC.Hs.ImpExp.ImportDecl GHC.Hs.GhcPs +setIDeclImplicit isImplicit importDecl = + -- no idea what `XImportDeclPass` _is_, btw. just following types + -- ref: https://hackage.haskell.org/package/ghc-9.6.5/docs/Language-Haskell-Syntax-ImpExp.html#t:ImportDecl + -- https://hackage.haskell.org/package/ghc-9.6.5/docs/Language-Haskell-Syntax-Extension.html#t:XCImportDecl + -- https://hackage.haskell.org/package/ghc-9.6.5/docs/GHC-Hs-ImpExp.html#t:XImportDeclPass + let xImportDeclPass = GHC.Hs.ImpExp.ideclExt importDecl + in importDecl + { GHC.Hs.ImpExp.ideclExt = + xImportDeclPass {GHC.Hs.ImpExp.ideclImplicit = isImplicit} + } diff --git a/src/Platform.hs b/src/Platform.hs --- a/src/Platform.hs +++ b/src/Platform.hs @@ -13,6 +13,7 @@ logHandler, requestId, silentHandler, + Internal.silentTrack, -- * Creating custom tracingSpans in libraries Internal.tracingSpan, @@ -24,6 +25,8 @@ Internal.setTracingSpanSummaryIO, Internal.markTracingSpanFailed, Internal.markTracingSpanFailedIO, + Internal.newRoot, + Internal.newRootIO, -- * Interpreting tracingSpans for reporting to monitoring platforms Internal.TracingSpan, @@ -35,6 +38,7 @@ Internal.details, Internal.summary, Internal.succeeded, + Internal.containsFailures, Internal.allocated, Internal.children, Internal.Succeeded (Succeeded, Failed, FailedWith), @@ -168,7 +172,7 @@ -- | A log handler that doesn't log anything. silentHandler :: IO Internal.LogHandler -silentHandler = Internal.mkHandler "" (Internal.Clock (pure 0)) (\_ -> pure ()) "" +silentHandler = pure Internal.nullHandler -- | Throw a runtime exception that cannot be caught. This function, like -- @Debug.todo@, breaks type level guarantees and should be avoided. Where @@ -179,10 +183,10 @@ -- throw an exception in @Control.Exception@, because it results in better logs -- for those who'll need to investigate these problems. unsafeThrowException :: - Stack.HasCallStack => + (Stack.HasCallStack) => Text -> Task e a unsafeThrowException title = - Internal.Task - <| \_ -> + Internal.Task <| + \_ -> Exception.throwString (Data.Text.unpack title) diff --git a/src/Platform/Analytics/Internal.hs b/src/Platform/Analytics/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Platform/Analytics/Internal.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE FlexibleInstances #-} + +-- | Internal entry point for emitting analytics events from `Task` code. +-- +-- This module is intentionally `.Internal`. It is NOT re-exported from +-- the prelude's public `Platform` module. Higher layers (NoRedInk's +-- `Analytics.track`) wrap this and own the user-facing API; downstream +-- code that imports `Platform.Analytics.Internal` directly is bypassing +-- the closed event dictionary and should be flagged in review. +module Platform.Analytics.Internal + ( trackEvent, + AnalyticsEventDetails, + ) +where + +import qualified Data.Aeson as Aeson +import NriPrelude +import qualified Platform +import qualified Platform.Internal as Internal +import qualified Prelude + +-- | Send an analytics event. Opens a child tracing span named +-- @analytics.track@, attaches the JSON payload as the span's details, +-- and invokes the `LogHandler`'s analytics callback. The callback runs +-- as a `Task` with the current `LogHandler`, so any errors it logs flow +-- through the normal observability pipeline. +trackEvent :: (Aeson.ToJSON e) => e -> Task err () +trackEvent event = + let value = Aeson.toJSON event + in Platform.tracingSpan "analytics.track" <| do + Platform.setTracingSpanDetails (AnalyticsEventDetails value) + Internal.Task + ( \handler -> do + let Internal.Task runCallback = Internal.trackAnalyticsEvent handler value + _ <- runCallback handler + Prelude.pure (Ok ()) + ) + +-- | A `TracingSpanDetails` wrapper around the analytics event payload, so +-- that the JSON we send to the analytics backend is also attached to the +-- @analytics.track@ span and visible in the existing observability +-- reporters. +newtype AnalyticsEventDetails = AnalyticsEventDetails Aeson.Value + deriving (Aeson.ToJSON) + +instance Internal.TracingSpanDetails AnalyticsEventDetails diff --git a/src/Platform/DevLog.hs b/src/Platform/DevLog.hs --- a/src/Platform/DevLog.hs +++ b/src/Platform/DevLog.hs @@ -12,6 +12,7 @@ import qualified Data.Time as Time import NriPrelude import qualified Platform.Internal +import qualified System.Environment.Blank as Environment import qualified System.IO import qualified System.IO.Unsafe import qualified System.Posix.Files as Files @@ -22,7 +23,7 @@ writeSpanToDevLog :: Platform.Internal.TracingSpan -> Prelude.IO () writeSpanToDevLog span = do now <- Time.getCurrentTime - let logFile = "/tmp/nri-prelude-logs" + logFile <- Environment.getEnvDefault "NRI_DEV_LOG" "/tmp/nri-prelude-logs" MVar.withMVar writeLock <| \_ -> System.IO.withFile logFile diff --git a/src/Platform/Internal.hs b/src/Platform/Internal.hs --- a/src/Platform/Internal.hs +++ b/src/Platform/Internal.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE RankNTypes #-} module Platform.Internal where @@ -8,8 +7,8 @@ import Basics import Control.Applicative ((<|>)) import qualified Control.AutoUpdate as AutoUpdate -import qualified Control.Concurrent.Async as Async import qualified Control.Exception.Safe as Exception +import qualified Control.Monad import Data.Aeson ((.:), (.:?), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Aeson.Encoding as Aeson.Encoding @@ -24,10 +23,9 @@ import qualified Internal.Shortcut as Shortcut import qualified List import Maybe (Maybe (..)) +import qualified Maybe import Result (Result (Err, Ok)) import qualified System.Mem -import qualified System.Mem as Mem -import qualified System.Timeout as Timeout import Text (Text) import qualified Tuple import Prelude @@ -65,20 +63,7 @@ pure a = Task (\_ -> Prelude.pure (Ok a)) - (<*>) func task = - Task <| \key -> - let onResult resultFunc resultTask = - case (resultFunc, resultTask) of - (Ok func_, Ok task_) -> - Ok (func_ task_) - (Err x, _) -> - Err x - (_, Err x) -> - Err x - in do - func_ <- _run func key - task_ <- _run task key - pure (onResult func_ task_) + (<*>) func task = Control.Monad.ap func task instance Monad (Task a) where task >>= func = @@ -142,11 +127,13 @@ -- | 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 + -- | Whether this tracingSpan succeeded. + succeeded :: Succeeded, + -- | Whether this tracingSpan or any of the children of this + -- tracingSpan failed. This will create a -- path to the tracingSpan closest to the failure from the root -- tracingSpan. - succeeded :: Succeeded, + containsFailures :: Bool, -- | 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 @@ -171,20 +158,32 @@ "details" .= details span, "summary" .= summary span, "succeeded" .= succeeded span, + "containsFailures" .= containsFailures span, "allocated" .= allocated span, "children" .= children span ] toEncoding span = Aeson.pairs - ( "name" .= name span - ++ "started" .= started span - ++ "finished" .= finished span - ++ "frame" .= map SrcLocForEncoding (frame span) - ++ "details" .= details span - ++ "summary" .= summary span - ++ "succeeded" .= succeeded span - ++ "allocated" .= allocated span - ++ "children" .= children span + ( "name" + .= name span + ++ "started" + .= started span + ++ "finished" + .= finished span + ++ "frame" + .= map SrcLocForEncoding (frame span) + ++ "details" + .= details span + ++ "summary" + .= summary span + ++ "succeeded" + .= succeeded span + ++ "containsFailures" + .= containsFailures span + ++ "allocated" + .= allocated span + ++ "children" + .= children span ) instance Aeson.FromJSON TracingSpan where @@ -199,6 +198,7 @@ details <- object .:? "details" summary <- object .:? "summary" succeeded <- object .: "succeeded" + containsFailures <- object .: "containsFailures" allocated <- object .: "allocated" children <- object .: "children" Prelude.pure @@ -210,6 +210,7 @@ details, summary, succeeded, + containsFailures, allocated, children } @@ -231,14 +232,22 @@ ] toEncoding (SrcLocForEncoding (name, loc)) = Aeson.pairs - ( "name" .= name - ++ "package" .= Stack.srcLocPackage loc - ++ "module" .= Stack.srcLocModule loc - ++ "file" .= Stack.srcLocFile loc - ++ "startLine" .= Stack.srcLocStartLine loc - ++ "startCol" .= Stack.srcLocStartCol loc - ++ "endLine" .= Stack.srcLocEndLine loc - ++ "endCol" .= Stack.srcLocEndCol loc + ( "name" + .= name + ++ "package" + .= Stack.srcLocPackage loc + ++ "module" + .= Stack.srcLocModule loc + ++ "file" + .= Stack.srcLocFile loc + ++ "startLine" + .= Stack.srcLocStartLine loc + ++ "startCol" + .= Stack.srcLocStartCol loc + ++ "endLine" + .= Stack.srcLocEndLine loc + ++ "endCol" + .= Stack.srcLocEndCol loc ) instance Aeson.FromJSON SrcLocForEncoding where @@ -284,6 +293,7 @@ details = Nothing, summary = Nothing, succeeded = Succeeded, + containsFailures = False, allocated = 0, children = [] } @@ -471,7 +481,7 @@ -- | A helper type used for @renderTracingSpanDetails@. Used to wrap rendering -- functions so they have the same type and can be put in a list together. data Renderer a where - Renderer :: TracingSpanDetails s => (s -> a) -> Renderer a + Renderer :: (TracingSpanDetails s) => (s -> a) -> Renderer a -- | In reporting logic we'd like to case on the different types a -- 'SomeTracingSpanDetails' can contain and write logic for each one. This @@ -530,7 +540,14 @@ -- 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, + startChildTracingSpan :: (Stack.HasCallStack) => Text -> IO LogHandler, + -- | This allows creating a new `LogHandler` with the same behaviour as + -- the root of this LogHandler. Remember that every tracingSpan gets its + -- own handler, and that tracingSpans form a tree. Allowing a tracingSpan + -- which copies the behaviour of the root allows long-lived constructs to + -- treat its children as a new root. For example, a webserver could use + -- this to create a new tracingSpan for each request. + startNewRoot :: (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 @@ -539,7 +556,7 @@ -- 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 (), + 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. @@ -556,21 +573,47 @@ -- 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 () + finishTracingSpan :: Maybe Exception.SomeException -> IO (), + -- | Deliver an analytics event payload to the configured analytics + -- backend. The prelude knows nothing about the backend; it only + -- threads this opaque callback from `rootTracingSpanIO` through + -- every child `LogHandler`. See `Platform.Analytics.Internal.trackEvent` + -- for the user-facing wrapper. + -- + -- The callback is `Task`-shaped (not `IO`) so the wire-layer + -- implementation can use the surrounding `LogHandler` for logging + -- and tracing — delivery errors flow through the same observability + -- pipeline as everything else. The `Never` error guarantees the + -- callback can't fail the outer `track` call; the wire layer is + -- expected to swallow and log its own failures. + -- + -- Default: `silentTrack`. + trackAnalyticsEvent :: Aeson.Value -> Task Never () } +-- | A no-op analytics callback. Used as the default for `nullHandler` +-- and for platforms that have not opted in to analytics tracking yet. +silentTrack :: Aeson.Value -> Task Never () +silentTrack _ = Task (\_ -> pure (Ok ())) + -- | 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 -- library the @rootTracingSpanIO@ is the more user-friendly way to get hands -- on a @LogHandler@. mkHandler :: - Stack.HasCallStack => + (Stack.HasCallStack) => Text -> Clock -> + -- | Analytics callback, propagated to every descendant `LogHandler`. + (Aeson.Value -> Task Never ()) -> + -- Finalizer for this loghandler (TracingSpan -> IO ()) -> + -- Root finalizer + Maybe (TracingSpan -> IO ()) -> Text -> IO LogHandler -mkHandler requestId clock onFinish name' = do +mkHandler requestId clock trackEvent' onFinish onFinishRoot' name' = do + let onFinishRoot = Maybe.withDefault onFinish onFinishRoot' tracingSpanRef <- Stack.withFrozenCallStack startTracingSpan clock name' |> andThen IORef.newIORef @@ -578,7 +621,8 @@ pure LogHandler { requestId, - startChildTracingSpan = mkHandler requestId clock (appendTracingSpanToParent tracingSpanRef), + startChildTracingSpan = mkHandler requestId clock trackEvent' (appendTracingSpanToParent tracingSpanRef) (Just onFinishRoot), + startNewRoot = mkHandler requestId clock trackEvent' onFinishRoot Nothing, setTracingSpanDetailsIO = \details' -> updateIORef tracingSpanRef @@ -590,10 +634,31 @@ markTracingSpanFailedIO = updateIORef tracingSpanRef - (\tracingSpan' -> tracingSpan' {succeeded = succeeded tracingSpan' ++ Failed}), - finishTracingSpan = finalizeTracingSpan clock allocationCounterStartVal tracingSpanRef >> andThen onFinish + (\tracingSpan' -> tracingSpan' {succeeded = succeeded tracingSpan' ++ Failed, containsFailures = True}), + finishTracingSpan = finalizeTracingSpan clock allocationCounterStartVal tracingSpanRef >> andThen onFinish, + trackAnalyticsEvent = trackEvent' } +-- | Helper that creates a handler that does nothing. This is intended to power +-- basically @Platform.silentHandler@ and nothing else. We provide this to make +-- @Platform.silentHandler@ as efficient as possible, skipping all side effects. +-- +-- The underlying desire for an IO-free `silentHandler`, aside from principles, +-- is we saw space leaks carrying @TracingSpan@ and @TracingSpanDetails@ we +-- couldn't understand, which went away when we switched to this no-op handler. +nullHandler :: LogHandler +nullHandler = do + LogHandler + { requestId = "", + startChildTracingSpan = \_ -> pure nullHandler, + startNewRoot = \_ -> pure nullHandler, + setTracingSpanDetailsIO = \_ -> pure (), + setTracingSpanSummaryIO = \_ -> pure (), + markTracingSpanFailedIO = pure (), + finishTracingSpan = \_ -> pure (), + trackAnalyticsEvent = silentTrack + } + -- | Set the details for a tracingSpan created using the @tracingSpan@ -- function. Like @tracingSpan@ this is intended for use in writing libraries -- that define custom types of effects, such as database queries or http @@ -613,7 +678,7 @@ -- > deriving (Aeson.ToJSON) -- > -- > instance TracingSpanDetails BookPick -setTracingSpanDetails :: TracingSpanDetails d => d -> Task e () +setTracingSpanDetails :: (TracingSpanDetails d) => d -> Task e () setTracingSpanDetails details = Task ( \handler -> @@ -649,7 +714,7 @@ Task (map Ok << markTracingSpanFailedIO) -- | Create an initial @TracingSpan@ with some initial values. -startTracingSpan :: Stack.HasCallStack => Clock -> Text -> IO TracingSpan +startTracingSpan :: (Stack.HasCallStack) => Clock -> Text -> IO TracingSpan startTracingSpan clock name = do started <- monotonicTimeInMsec clock pure @@ -687,6 +752,7 @@ details = Nothing, summary = Nothing, succeeded = Succeeded, + containsFailures = False, allocated = 0, children = [] } @@ -700,20 +766,17 @@ pure tracingSpan' { finished, - -- Below we implement the rule that if any of the children of a - -- tracingSpan failed, that tracingSpan itself failed too. The reason - -- we have this rule is to make it easy to see if a request as a whole - -- failed (just check the 'succeeded' property of the root tracingSpan - -- 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 -> Succeeded, + containsFailures = + containsFailures tracingSpan' + || case maybeException of + Just _ -> True Nothing -> - map Platform.Internal.succeeded (children tracingSpan') - |> Prelude.mconcat, + List.any Platform.Internal.containsFailures (children tracingSpan'), -- The allocation counter counts down as it allocations bytest. We -- subtract in this order to get a positive number. allocated = allocationCounterStartVal - allocationCounterEndVal @@ -741,7 +804,7 @@ -- -- This will help provide better debugging information if something goes wrong -- inside the wrapped task. -tracingSpan :: Stack.HasCallStack => Text -> Task e a -> Task e a +tracingSpan :: (Stack.HasCallStack) => Text -> Task e a -> Task e a tracingSpan name (Task run) = Task ( \handler -> @@ -752,6 +815,25 @@ run ) +-- | Run a task in a tracingSpan forking the root tracingSpan +-- +-- > newRoot "No need for my parent" <| do +-- > whateverHappensInHere +-- > itWillHappen asIfMyParentDid it +-- +-- This can help in flushing logs; by replacing the parent span, we also +-- "inherit" its finalization point +newRoot :: (Stack.HasCallStack) => Text -> Task e a -> Task e a +newRoot name (Task run) = + Task + ( \handler -> + Stack.withFrozenCallStack + newRootIO + handler + name + run + ) + -- | Like @tracingSpan@, but this one runs in @IO@ instead of @Task@. We -- 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. @@ -759,76 +841,51 @@ -- > tracingSpanIO handler "code dance" <| \childHandler -> do -- > waltzPassLeft childHandler -- > clockwiseTurn childHandler 60 -tracingSpanIO :: Stack.HasCallStack => LogHandler -> Text -> (LogHandler -> IO a) -> IO a +tracingSpanIO :: (Stack.HasCallStack) => LogHandler -> Text -> (LogHandler -> IO a) -> IO a tracingSpanIO handler name run = Exception.bracketWithError (Stack.withFrozenCallStack (startChildTracingSpan handler name)) (Prelude.flip finishTracingSpan) run +-- | Like @newRoot@, but this one runs in @IO@ instead of @Task@. We +-- 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. +-- +-- > newRootIO handler "code dance" <| \childHandler -> do +-- > waltzPassLeft childHandler +-- > clockwiseTurn childHandler 60 +newRootIO :: (Stack.HasCallStack) => LogHandler -> Text -> (LogHandler -> IO a) -> IO a +newRootIO handler name run = do + Exception.bracketWithError + (Stack.withFrozenCallStack (startNewRoot handler name)) + (Prelude.flip finishTracingSpan) + run + -- | Special version of @tracingSpanIO@ to call in the root of your application. -- 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 -> +-- > rootTracingSpanIO "request-23" silentTrack 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 +rootTracingSpanIO :: + (Stack.HasCallStack) => + Text -> + -- | Analytics callback. Pass `silentTrack` for platforms that don't track. + (Aeson.Value -> Task Never ()) -> + (TracingSpan -> IO ()) -> + Text -> + (LogHandler -> IO a) -> + IO a +rootTracingSpanIO requestId trackEvent' onFinish name runIO = do clock' <- mkClock Exception.bracketWithError - (Stack.withFrozenCallStack mkHandler requestId clock' (onFinish >> reportSafely) name) + (Stack.withFrozenCallStack mkHandler requestId clock' trackEvent' onFinish Nothing name) (Prelude.flip finishTracingSpan) runIO --- After a root action (HTTP request, perform a job from a queue, etc) is done --- we run our reporting logic, which sends debugging information to platforms --- like Bugsnag and NewRelic. -- --- This information is important when helping us debug our applications, but it --- shouldn't be able to cause problems for the non-reporting logic, i.e. the --- parts responsible for sending a response back to the user. --- --- This function might kill the reporting thread if it thinks it's misbehaving. --- It's up to the reporting logic to implement cleanup logic or notifications --- of failed reporting using functions like `bracket`. -reportSafely :: IO () -> IO () -reportSafely report = do - -- Spawning a separate thread for the reporting logic ensures the main request - -- thread doesn't need to wait with responding to the user until reporting - -- logic finishes. It also ensures exceptions thrown in reporting logic won't - -- result in failure responses to requests. - _ <- - Async.async <| do - -- Setting an allocation limit helps protect us from reporting logic using - -- lots of CPU time and negatively affecting application performance. - Mem.setAllocationCounter reportingAllocationLimitInBytes - Mem.enableAllocationLimit - -- This thread is spawned without anybody watching how it does. We set a - -- maximum running time here to ensure it eventually completes. - Timeout.timeout reportingTimeoutInMicroSeconds report - Prelude.pure () - --- | The maximum amount of bytes the reporting logic is allowed to allocate. --- Note that this is more of a limit on CPU time then maximum live memory. See --- the documentation on `setAllocationCounter` for more details: --- --- https://hackage.haskell.org/package/base-4.14.0.0/docs/System-Mem.html#v:enableAllocationLimit --- --- The current value is a somewhat arbitrary initial value, intentionally not --- very strict. The hope is experience will help us tighten this value a bit. -reportingAllocationLimitInBytes :: Int -reportingAllocationLimitInBytes = 1024 * 1024 * 1024 - --- | The maximum amount of time reporting logic is allowed to run for a single --- request. --- --- The current value is a somewhat arbitrary initial value, intentionally not --- very strict. The hope is experience will help us tighten this value a bit. -reportingTimeoutInMicroSeconds :: Prelude.Int -reportingTimeoutInMicroSeconds = 5_000_000 - --- -- CLOCK -- @@ -870,4 +927,4 @@ -- constant moment in the past. inMicroseconds :: GHC.Word.Word64 } - deriving (Prelude.Show, Prelude.Num, Prelude.Eq, Prelude.Ord, Aeson.ToJSON, Aeson.FromJSON) + deriving (Prelude.Show, Prelude.Enum, Prelude.Real, Prelude.Integral, Prelude.Num, Prelude.Eq, Prelude.Ord, Aeson.ToJSON, Aeson.FromJSON) diff --git a/src/Process.hs b/src/Process.hs --- a/src/Process.hs +++ b/src/Process.hs @@ -1,4 +1,3 @@ --- | module Process ( Id, spawn, diff --git a/src/Result.hs b/src/Result.hs --- a/src/Result.hs +++ b/src/Result.hs @@ -24,6 +24,7 @@ where import Basics +import GHC.Generics (Generic) import qualified Internal.Shortcut as Shortcut import Maybe (Maybe (..)) import Prelude (fmap) @@ -34,7 +35,7 @@ data Result error value = Ok value | Err error - deriving (Prelude.Show, Eq) + deriving (Prelude.Show, Eq, Generic) instance Prelude.Functor (Result error) where fmap func result = @@ -91,17 +92,14 @@ map2 = Shortcut.map2 --- | map3 :: (a -> b -> c -> value) -> Result x a -> Result x b -> Result x c -> Result x value map3 = Shortcut.map3 --- | map4 :: (a -> b -> c -> d -> value) -> Result x a -> Result x b -> Result x c -> Result x d -> Result x value map4 = Shortcut.map4 --- | map5 :: (a -> b -> c -> d -> e -> value) -> Result x a -> Result x b -> Result x c -> Result x d -> Result x e -> Result x value map5 = Shortcut.map5 diff --git a/src/Set.hs b/src/Set.hs --- a/src/Set.hs +++ b/src/Set.hs @@ -57,12 +57,12 @@ Data.Set.singleton -- | Insert a value into a set. -insert :: Ord comparable => comparable -> Set comparable -> Set comparable +insert :: (Ord comparable) => comparable -> Set comparable -> Set comparable insert = Data.Set.insert -- | Remove a value from a set. If the value is not found, no changes are made. -remove :: Ord comparable => comparable -> Set comparable -> Set comparable +remove :: (Ord comparable) => comparable -> Set comparable -> Set comparable remove = Data.Set.delete @@ -72,7 +72,7 @@ Data.Set.null -- | Determine if a value is in a set. -member :: Ord comparable => comparable -> Set comparable -> Bool +member :: (Ord comparable) => comparable -> Set comparable -> Bool member = Data.Set.member @@ -86,7 +86,7 @@ -- -- In Elm it's not possible to have two comparable elements that are not equal, but -- it is possible in Haskell. -union :: Ord comparable => Set comparable -> Set comparable -> Set comparable +union :: (Ord comparable) => Set comparable -> Set comparable -> Set comparable union = Data.Set.union @@ -95,13 +95,13 @@ -- -- In Elm it's not possible to have two comparable elements that are not equal, but -- it is possible in Haskell. -intersect :: Ord comparable => Set comparable -> Set comparable -> Set comparable +intersect :: (Ord comparable) => Set comparable -> Set comparable -> Set comparable intersect = Data.Set.intersection -- | Get the difference between the first set and the second. Keeps values -- that do not appear in the second set. -diff :: Ord comparable => Set comparable -> Set comparable -> Set comparable +diff :: (Ord comparable) => Set comparable -> Set comparable -> Set comparable diff = Data.Set.difference @@ -111,7 +111,7 @@ Data.Set.toAscList -- | Convert a list into a set, removing any duplicates. -fromList :: Ord comparable => List comparable -> Set comparable +fromList :: (Ord comparable) => List comparable -> Set comparable fromList = Data.Set.fromList @@ -126,7 +126,7 @@ Data.Set.foldr' -- | Map a function onto a set, creating a new set with no duplicates. -map :: Ord comparable2 => (comparable -> comparable2) -> Set comparable -> Set comparable2 +map :: (Ord comparable2) => (comparable -> comparable2) -> Set comparable -> Set comparable2 map = Data.Set.map diff --git a/src/Task.hs b/src/Task.hs --- a/src/Task.hs +++ b/src/Task.hs @@ -32,7 +32,9 @@ -- * Special (custom helpers not found in Elm) timeout, + concurrently, parallel, + background, ) where @@ -40,7 +42,6 @@ import qualified Control.Concurrent.Async as Async import qualified Internal.Shortcut as Shortcut import List (List) -import qualified List import Maybe (Maybe (..)) import Platform.Internal (Task) import qualified Platform.Internal as Internal @@ -138,22 +139,18 @@ map2 = Shortcut.map2 --- | map3 :: (a -> b -> c -> result) -> Task x a -> Task x b -> Task x c -> Task x result map3 = Shortcut.map3 --- | map4 :: (a -> b -> c -> d -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x result map4 = Shortcut.map4 --- | map5 :: (a -> b -> c -> d -> e -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x e -> Task x result map5 = Shortcut.map5 --- | map6 :: (a -> b -> c -> d -> e -> f -> result) -> Task x a -> Task x b -> Task x c -> Task x d -> Task x e -> Task x f -> Task x result map6 = Shortcut.map6 @@ -182,8 +179,7 @@ -- -- > sequence [ succeed 1, succeed 2 ] == succeed [ 1, 2 ] sequence :: List (Task x a) -> Task x (List a) -sequence tasks = - List.foldr (Shortcut.map2 (:)) (succeed []) tasks +sequence = Prelude.sequence -- | Start with a list of tasks, and turn them into a single task that returns a -- list. The tasks will be run in parallel and if any task fails the whole @@ -196,6 +192,28 @@ ( \handler -> Async.forConcurrently tasks (\task -> Internal._run task handler) |> Shortcut.map Prelude.sequence + ) + +-- | Given two tasks, turn them into a single task that returns a tuple. +-- The tasks will be run concurrently and if either task fails the combined +-- task also fails. +-- +-- > concurrently (succeed 1) (succeed "Expecto Patronum!") == succeed (1, "Expecto Patronum!") +concurrently :: Task x a -> Task x b -> Task x (a, b) +concurrently taskA taskB = + Internal.Task + ( \handler -> do + (resultA, resultB) <- Async.concurrently (Internal._run taskA handler) (Internal._run taskB handler) + Prelude.pure <| Shortcut.map2 (,) resultA resultB + ) + +-- | Given a task, execute the task in a greenthread. +background :: Task Never a -> Task x () +background task = + Internal.Task + ( \handler -> do + _ <- Async.async (Internal._run task handler) + Prelude.pure <| Ok () ) -- | Recover from a failure in a task. If the given task fails, we use the diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -13,12 +13,17 @@ Internal.fuzz2, Internal.fuzz3, + -- * Serialize test execution + Internal.serialize, + -- * Running test run, + runWithSettings, + TestSettings (..), + defaultTestSettings, ) where -import qualified Control.Concurrent.Async as Async import qualified GHC.IO.Encoding import qualified GHC.Stack as Stack import NriPrelude @@ -26,8 +31,11 @@ import qualified Platform.DevLog import qualified System.Directory import qualified System.Environment +import qualified System.Exit +import System.IO (hPutStrLn, stderr) import qualified System.IO import qualified Task +import qualified Test.CliParser as CliParser import qualified Test.Internal as Internal import qualified Test.Reporter.ExitCode import qualified Test.Reporter.Junit @@ -35,6 +43,20 @@ import qualified Test.Reporter.Stdout import qualified Prelude +data TestSettings = TestSettings + { output :: Maybe System.IO.Handle, + junitPath :: Maybe Prelude.String, + writeDevLog :: Bool + } + +defaultTestSettings :: TestSettings +defaultTestSettings = + TestSettings + { output = Just System.IO.stdout, + junitPath = Nothing, + writeDevLog = True + } + -- | Turn a test suite into a program that can be executed in Haskell. Use like -- this: -- @@ -43,53 +65,71 @@ -- > import qualified Test -- > -- > main :: IO () --- > main = Test.run (Test.todo "write your tests here!") -run :: Stack.HasCallStack => Internal.Test -> Prelude.IO () +-- > main = Test.run (Test.todo "write your tests here!") +run :: (Stack.HasCallStack) => Internal.Test -> Prelude.IO () run suite = do + args <- System.Environment.getArgs + let settings = defaultTestSettings {junitPath = getJunitPath args} + runWithSettings settings suite + +runWithSettings :: (Stack.HasCallStack) => TestSettings -> Internal.Test -> Prelude.IO () +runWithSettings settings 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 - (Task.perform log (Internal.run suite)) - isLogExplorerAvailable - Async.mapConcurrently_ - identity - [ reportStdout results, - Stack.withFrozenCallStack reportLogfile results, - reportJunit results - ] - if logExplorerAvailable - then Prelude.putStrLn "\nRun log-explorer in your shell to inspect logs collected during this test run." - else Prelude.putStrLn "\nInstall the log-explorer tool to inspect logs collected during test runs. Find it at github.com/NoRedInk/haskell-libraries." + args <- System.Environment.getArgs + let requestOrError = CliParser.parseArgs args + request <- case requestOrError of + Err errs -> do + let error = ("Invalid arguments:\n" ++ errs) + hPutStrLn stderr error + System.Exit.exitFailure + Ok request -> + Prelude.pure request + + results <- Task.perform log (Internal.run request suite) + + case output settings of + Just outputHandle -> reportConsole outputHandle results + Nothing -> Prelude.pure () + + case junitPath settings of + Nothing -> Prelude.pure () + Just path -> reportJunit path results + + if writeDevLog settings + then do + logExplorerAvailable <- isLogExplorerAvailable + if logExplorerAvailable + then putTextLn "\nRun log-explorer in your shell to inspect logs collected during this test run." + else putTextLn "\nInstall the log-explorer tool to inspect logs collected during test runs. Find it at github.com/NoRedInk/haskell-libraries." + Stack.withFrozenCallStack reportLogfile results + else Prelude.pure () + Test.Reporter.ExitCode.report results -reportStdout :: Internal.SuiteResult -> Prelude.IO () -reportStdout results = - Test.Reporter.Stdout.report System.IO.stdout results +reportConsole :: System.IO.Handle -> Internal.SuiteResult -> Prelude.IO () +reportConsole outputHandle results = + Test.Reporter.Stdout.report outputHandle results -reportLogfile :: Stack.HasCallStack => Internal.SuiteResult -> Prelude.IO () +reportLogfile :: (Stack.HasCallStack) => Internal.SuiteResult -> Prelude.IO () reportLogfile results = Stack.withFrozenCallStack Test.Reporter.Logfile.report Platform.DevLog.writeSpanToDevLog results -reportJunit :: Internal.SuiteResult -> Prelude.IO () -reportJunit results = - do - args <- System.Environment.getArgs - case getPath args of - Nothing -> Prelude.pure () - Just path -> Test.Reporter.Junit.report path results +reportJunit :: Prelude.String -> Internal.SuiteResult -> Prelude.IO () +reportJunit path results = + Test.Reporter.Junit.report path results -getPath :: [Prelude.String] -> Maybe Prelude.String -getPath args = +getJunitPath :: [Prelude.String] -> Maybe Prelude.String +getJunitPath args = case args of [] -> Nothing "--xml" : path : _ -> Just path - _ : rest -> getPath rest + _ : rest -> getJunitPath rest isLogExplorerAvailable :: Prelude.IO Bool isLogExplorerAvailable = do diff --git a/src/Test/CliParser.hs b/src/Test/CliParser.hs new file mode 100644 --- /dev/null +++ b/src/Test/CliParser.hs @@ -0,0 +1,49 @@ +module Test.CliParser where + +import Control.Applicative (optional, some, (*>), (<*), (<|>)) +import Data.Attoparsec.Text (Parser, ()) +import qualified Data.Attoparsec.Text as Attoparsec +import Data.Functor (void) +import NriPrelude +import qualified Result +import qualified Test.Internal as Internal +import qualified Text +import qualified Prelude + +parseArgs :: List Prelude.String -> Result Prelude.String Internal.Request +parseArgs args = + case args of + [] -> Ok Internal.All + ["--files"] -> Err "must inform at least one file: not enough input" + ["--files", files] -> + parse files + |> Result.andThen + ( \lists -> case lists of + [] -> Err "must inform at least one file: not enough input" + subsetOfTests -> Ok (Internal.Some subsetOfTests) + ) + _ : rest -> parseArgs rest + +parse :: Prelude.String -> Result Prelude.String (List Internal.SubsetOfTests) +parse input = + input + |> Text.fromList + |> Attoparsec.parseOnly (argParser <* endParser) + |> Prelude.either Err Ok + +endParser :: Parser () +endParser = Attoparsec.endOfInput <|> void (Attoparsec.char ',') <|> unexpectedInput + +argParser :: Parser (List Internal.SubsetOfTests) +argParser = Attoparsec.sepBy1' (fileParser <|> unexpectedInput) (Attoparsec.char ',') "must inform at least one file" + +fileParser :: Parser Internal.SubsetOfTests +fileParser = do + requestedPath <- some (Attoparsec.satisfy (\c -> c /= ':' && c /= ',')) + lineOfCode <- optional (Attoparsec.char ':' *> Attoparsec.decimal) + Prelude.pure Internal.SubsetOfTests {Internal.requestedPath, Internal.lineOfCode} + +unexpectedInput :: Parser a +unexpectedInput = do + rest <- some Attoparsec.anyChar + Prelude.fail ("expected format: --files=bla.hs or --files bla.hs: \"" ++ rest ++ "\"") diff --git a/src/Test/Internal.hs b/src/Test/Internal.hs --- a/src/Test/Internal.hs +++ b/src/Test/Internal.hs @@ -11,9 +11,11 @@ import qualified Control.Concurrent.MVar as MVar import qualified Control.Exception.Safe as Exception +import Control.Monad (when) import qualified Control.Monad.IO.Class import qualified Data.Either import qualified Data.IORef as IORef +import Data.List (isSuffixOf) import qualified Dict import qualified GHC.Stack as Stack import qualified Hedgehog @@ -27,28 +29,47 @@ import Platform (TracingSpan) import qualified Platform import qualified Platform.Internal +import qualified Set +import qualified System.Environment +import System.FilePath (FilePath) import qualified Task +import qualified Text +import Text.Read (readMaybe) import qualified Tuple import qualified Prelude +data Request = All | Some [SubsetOfTests] + deriving (Eq, Show) + +data SubsetOfTests = SubsetOfTests {requestedPath :: FilePath, lineOfCode :: Maybe Int} + deriving (Eq, Show) + data SingleTest a = SingleTest { describes :: [Text], name :: Text, label :: Label, - loc :: Maybe Stack.SrcLoc, + -- This is used for serializing execution of grouped tests (e.g. database tests) + group :: Group, + loc :: Stack.SrcLoc, body :: a } - deriving (Prelude.Functor) + deriving (Show, Prelude.Functor) data Label = None | Skip | Only | Todo - deriving (Eq, Ord) + deriving (Show, Eq, Ord) +data Group = Grouped (Set.Set GroupKey) | Ungrouped + deriving (Show, Eq, Ord) + +newtype GroupKey = GroupKey {unGroupkey :: Text} + deriving (Show, Eq, Ord) + data TestResult = Succeeded | Failed Failure data Failure - = FailedAssertion Text (Maybe Stack.SrcLoc) + = FailedAssertion Text Stack.SrcLoc | ThrewException Exception.SomeException | TookTooLong | TestRunnerMessedUp Text @@ -60,11 +81,18 @@ = AllPassed [SingleTest TracingSpan] | OnlysPassed [SingleTest TracingSpan] [SingleTest NotRan] | PassedWithSkipped [SingleTest TracingSpan] [SingleTest NotRan] - | TestsFailed [SingleTest TracingSpan] [SingleTest NotRan] [SingleTest (TracingSpan, Failure)] + | TestsFailed [SingleTest TracingSpan] [SingleTest NotRan] [SingleTest FailedSpan] | NoTestsInSuite + deriving (Show) data NotRan = NotRan + deriving (Show) +data FailedSpan = FailedSpan TracingSpan Failure + +instance Show FailedSpan where + show (FailedSpan span failure) = Prelude.show failure ++ ": " ++ Prelude.show span + -- | A test which has yet to be evaluated. When evaluated, it produces one -- or more 'Expect.Expectation's. -- See 'test' and 'fuzz' for some ways to create a @Test@. @@ -128,13 +156,14 @@ -- -- This functionality is similar to "pending" tests in other frameworks, except -- that a todo test is considered failing but a pending test often is not. -todo :: Stack.HasCallStack => Text -> Test +todo :: (Stack.HasCallStack) => Text -> Test todo name = Test [ SingleTest { describes = [], name = name, - loc = Stack.withFrozenCallStack getFrame, + loc = Stack.withFrozenCallStack getFrame name, + group = Ungrouped, label = Todo, body = Expectation (Task.succeed ()) } @@ -149,18 +178,34 @@ -- > \_ -> -- > List.length [] -- > |> Expect.equal 0 -test :: Stack.HasCallStack => Text -> (() -> Expectation) -> Test +test :: (Stack.HasCallStack) => Text -> (() -> Expectation) -> Test test name expectation = Test [ SingleTest { describes = [], name = name, - loc = Stack.withFrozenCallStack getFrame, + loc = Stack.withFrozenCallStack getFrame name, + group = Ungrouped, label = None, body = handleUnexpectedErrors (expectation ()) } ] +-- | Serializes the execution of 'Test' based on a certain grouping +-- +-- > serialize "mysql" <| todo "some db stuff!" +serialize :: Text -> Test -> Test +serialize groupKey (Test tests) = + tests + |> List.map + ( \singleTest -> + let groupKeys = case group singleTest of + Ungrouped -> Set.empty + Grouped keys -> keys + in singleTest {group = Grouped (Set.insert (GroupKey groupKey) groupKeys)} + ) + |> Test + -- | Take a function that produces a test, and calls it several (usually 100) -- times, using a randomly-generated input from a 'Fuzzer' each time. This -- allows you to test that a property that should always be true is indeed true @@ -176,7 +221,8 @@ [ SingleTest { describes = [], name = name, - loc = Stack.withFrozenCallStack getFrame, + loc = Stack.withFrozenCallStack getFrame name, + group = Ungrouped, label = None, body = fuzzBody fuzzer expectation } @@ -189,7 +235,8 @@ [ SingleTest { describes = [], name = name, - loc = Stack.withFrozenCallStack getFrame, + loc = Stack.withFrozenCallStack getFrame name, + group = Ungrouped, label = None, body = fuzzBody @@ -205,7 +252,8 @@ [ SingleTest { describes = [], name = name, - loc = Stack.withFrozenCallStack getFrame, + loc = Stack.withFrozenCallStack getFrame name, + group = Ungrouped, label = None, body = fuzzBody @@ -214,10 +262,10 @@ } ] -fuzzBody :: Show a => Fuzzer a -> (a -> Expectation) -> Expectation +fuzzBody :: (Show a) => Fuzzer a -> (a -> Expectation) -> Expectation fuzzBody (Fuzzer gen) expectation = do - Expectation - <| Platform.Internal.Task + Expectation <| + Platform.Internal.Task ( \_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 @@ -339,8 +387,33 @@ only (Test tests) = Test <| List.map (\test' -> test' {label = Only}) tests -run :: Test -> Task e SuiteResult -run (Test all) = do +-- | 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 -> Expectation' a +fromIO io = + Platform.Internal.Task (\_ -> map Ok io) + |> Expectation + +-- | Run an expectation directly in IO. +-- Some external testing libraries required using a resource in an IO continution like `(\resource -> IO a) -> IO a`. +-- For example see warp's `testWithApplication`. +-- +-- This function allows you to convert an expectation to IO inside of such a continuation. You will likely want to +-- transform the result back to an expectation with `fromIOResult`. +runExpectation :: Platform.LogHandler -> Expectation' a -> Prelude.IO (Result Failure a) +runExpectation log expectation = do + unExpectation expectation + |> Task.attempt log + +-- | Convert an IO action that returns a Result into an expectation. +-- Useful in combination with 'runExpectation'. +fromIOResult :: Prelude.IO (Result Failure a) -> Expectation' a +fromIOResult io = + Platform.Internal.Task (\_ -> io) + |> Expectation + +run :: Request -> Test -> Task e SuiteResult +run request (Test all) = do let grouped = groupBy label all let skipped = Dict.get Skip grouped |> Maybe.withDefault [] let todos = Dict.get Todo grouped |> Maybe.withDefault [] @@ -357,14 +430,23 @@ |> List.partition (doRun << Tuple.first) |> Tuple.mapBoth (List.concatMap Tuple.second) (List.concatMap Tuple.second) let notToRun = List.map (\test' -> test' {body = NotRan}) notToRun' - results <- Task.parallel (List.map runSingle toRun) + results <- + ( case request of + All -> toRun + Some tests -> List.filter (subset tests) toRun + ) + |> groupBy runStrategy + |> Dict.toList + |> List.map runGroup + |> Task.parallel + |> Task.map List.concat let (failed, passed) = results |> List.map ( \test' -> case body test' of (tracingSpan, Failed failure) -> - Prelude.Left test' {body = (tracingSpan, failure)} + Prelude.Left test' {body = FailedSpan tracingSpan failure} (tracingSpan, Succeeded) -> Prelude.Right test' {body = tracingSpan} ) @@ -383,6 +465,30 @@ Summary {noneSkipped = False} -> PassedWithSkipped passed notToRun Summary {} -> AllPassed passed +data RunStrategy = Parallel | Sequence deriving (Eq, Ord) + +runStrategy :: SingleTest exp -> RunStrategy +runStrategy singleTest = + case group singleTest of + Grouped _ -> Sequence + Ungrouped -> Parallel + +subset :: List SubsetOfTests -> SingleTest expectation -> Bool +subset subsets singleTest = + case (subsets, loc singleTest) of + ([], _) -> False -- Should never happen, we should have a NonEmpty SubsetOfTests tbh + (SubsetOfTests {requestedPath, lineOfCode} : rest, Stack.SrcLoc {Stack.srcLocFile, Stack.srcLocStartLine, Stack.srcLocEndLine}) -> + -- isSuffixOf allows us to write --files=quiz-engine-http/spec/Smth/DerpSpec.hs + if srcLocFile `isSuffixOf` requestedPath + then case lineOfCode of + Nothing -> True + Just requestedLoc' -> + let requestedLoc = Prelude.fromIntegral requestedLoc' + in if srcLocStartLine <= requestedLoc && requestedLoc <= srcLocEndLine + then True + else subset rest singleTest + else subset rest singleTest + data Summary = Summary { noTests :: Bool, allPassed :: Bool, @@ -391,23 +497,48 @@ } handleUnexpectedErrors :: Expectation -> Expectation -handleUnexpectedErrors (Expectation task') = +handleUnexpectedErrors (Expectation task') = do + timeout <- timeoutFromEnvOrDefault 10_000 task' |> onException (Task.fail << ThrewException) - |> Task.timeout 10_000 TookTooLong + |> Task.timeout timeout TookTooLong |> Task.onError Task.fail |> Expectation +timeoutFromEnvOrDefault :: Prelude.Double -> Expectation' Prelude.Double +timeoutFromEnvOrDefault defaultTimeout = do + timeoutFromEnv <- fromIO <| System.Environment.lookupEnv "NRI_TEST_TIMEOUT" + case Maybe.andThen readMaybe timeoutFromEnv of + Just timeout -> Prelude.pure timeout + Nothing -> Prelude.pure defaultTimeout + +runGroup :: (RunStrategy, List (SingleTest Expectation)) -> Task e (List (SingleTest (TracingSpan, TestResult))) +runGroup (groupped, tests) = + List.map runSingle tests + |> ( case groupped of + Sequence -> Task.sequence + Parallel -> Task.parallel + ) + runSingle :: SingleTest Expectation -> Task e (SingleTest (TracingSpan, TestResult)) runSingle test' = Platform.Internal.Task ( \_ -> do spanVar <- MVar.newEmptyMVar + -- Here we use the source location as the span name so that we can + -- easily wait for the correct span to be reported. + -- Other spans might be reported, for example, if the test uses `Platform.newRoot`, + -- but those spans should be ignored. + let spanName = Text.fromList <| Stack.prettySrcLoc (loc test') res <- Platform.Internal.rootTracingSpanIO "" - (MVar.putMVar spanVar) - "test" + Platform.Internal.silentTrack + ( \span -> do + when (Platform.Internal.name span == spanName) <| + MVar.putMVar spanVar span + ) + spanName ( \log -> body test' |> unExpectation @@ -424,8 +555,9 @@ span' <- MVar.takeMVar spanVar let span = span' - { Platform.Internal.summary = Just (name test'), - Platform.Internal.frame = map (\loc -> ("", loc)) (loc test'), + { Platform.Internal.name = "test", + Platform.Internal.summary = Just (name test'), + Platform.Internal.frame = Just ("", loc test'), Platform.Internal.succeeded = case testRest of Succeeded -> Platform.Internal.Succeeded Failed failure -> @@ -450,22 +582,29 @@ |> Exception.handleAny (Task.attempt log << f) ) -getFrame :: Stack.HasCallStack => Maybe Stack.SrcLoc -getFrame = - Stack.callStack - |> Stack.getCallStack - |> List.head - |> map Tuple.second +getFrame :: (Stack.HasCallStack) => Text -> Stack.SrcLoc +getFrame testName = + case Stack.callStack |> Stack.getCallStack |> List.head of + Just (_, srcLoc) -> + srcLoc + Nothing -> + ( "Oops! We can't find the source location for this test: " + ++ testName + ++ "\n" + ++ "This indicates a bug in our Test module in nri-prelude.\n" + ) + |> TestRunnerMessedUp + |> Exception.impureThrow -groupBy :: Ord key => (a -> key) -> [a] -> Dict.Dict key [a] +groupBy :: (Ord key) => (a -> key) -> [a] -> Dict.Dict key [a] groupBy key xs = List.foldr ( \x acc -> Dict.update (key x) ( \val -> - Just - <| case val of + Just <| + case val of Nothing -> [x] Just ys -> x : ys ) @@ -485,16 +624,16 @@ -- never each other, to ensure a single unnested 'expectation' entry from -- appearing in log-explorer traces. -pass :: Stack.HasCallStack => Text -> a -> Expectation' a +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 :: (Stack.HasCallStack) => Text -> Text -> Expectation' a failAssertion name err = - FailedAssertion err (Stack.withFrozenCallStack getFrame) + FailedAssertion err (Stack.withFrozenCallStack getFrame name) |> Task.fail |> Stack.withFrozenCallStack traceExpectation name -traceExpectation :: Stack.HasCallStack => Text -> Task Failure a -> Expectation' a +traceExpectation :: (Stack.HasCallStack) => Text -> Task Failure a -> Expectation' a traceExpectation name task = Stack.withFrozenCallStack Platform.tracingSpan diff --git a/src/Test/Reporter/Internal.hs b/src/Test/Reporter/Internal.hs --- a/src/Test/Reporter/Internal.hs +++ b/src/Test/Reporter/Internal.hs @@ -19,7 +19,7 @@ readSrcLoc :: Internal.SingleTest Internal.Failure -> Prelude.IO (Maybe (Stack.SrcLoc, BS.ByteString)) readSrcLoc test = case Internal.body test of - Internal.FailedAssertion _ (Just loc) -> do + Internal.FailedAssertion _ loc -> do cwd <- System.Directory.getCurrentDirectory let path = cwd Stack.srcLocFile loc exists <- System.Directory.doesFileExist path 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 @@ -23,7 +23,6 @@ import qualified Text import qualified Text.Colour import qualified Text.XML.JUnit as JUnit -import qualified Tuple import qualified Prelude report :: FilePath.FilePath -> Internal.SuiteResult -> Prelude.IO () @@ -50,7 +49,7 @@ ) Internal.TestsFailed passed skipped failed -> do srcLocs <- - List.map (map Tuple.second) failed + List.map (map (\(Internal.FailedSpan _ failure) -> failure)) failed |> Prelude.traverse Test.Reporter.Internal.readSrcLoc let renderedFailed = List.map2 renderFailed failed srcLocs Prelude.pure @@ -72,47 +71,38 @@ |> JUnit.inSuite (suiteName test) renderFailed :: - Internal.SingleTest (Platform.TracingSpan, Internal.Failure) -> + Internal.SingleTest Internal.FailedSpan -> Maybe (Stack.SrcLoc, BS.ByteString) -> JUnit.TestSuite renderFailed test maybeSrcLoc = case Internal.body test of - (tracingSpan, Internal.FailedAssertion msg _) -> + Internal.FailedSpan tracingSpan (Internal.FailedAssertion msg _) -> let msg' = case maybeSrcLoc of Nothing -> msg Just (loc, src) -> Test.Reporter.Internal.renderSrcLoc loc src - |> Text.Colour.renderChunksBS Text.Colour.WithoutColours + |> Text.Colour.renderChunksUtf8BS Text.Colour.WithoutColours |> TE.decodeUtf8 |> (\srcStr -> srcStr ++ "\n" ++ msg) in JUnit.failed (Internal.name test) |> JUnit.stderr msg' - |> ( case stackFrame test of - Nothing -> identity - Just frame -> JUnit.failureStackTrace [frame] - ) + |> JUnit.failureStackTrace [stackFrame test] |> JUnit.time (duration tracingSpan) |> JUnit.inSuite (suiteName test) - (tracingSpan, Internal.ThrewException err) -> + Internal.FailedSpan tracingSpan (Internal.ThrewException err) -> JUnit.errored (Internal.name test) |> JUnit.errorMessage "This test threw an exception." |> JUnit.stderr (Data.Text.pack (Exception.displayException err)) - |> ( case stackFrame test of - Nothing -> identity - Just frame -> JUnit.errorStackTrace [frame] - ) + |> JUnit.errorStackTrace [stackFrame test] |> JUnit.time (duration tracingSpan) |> JUnit.inSuite (suiteName test) - (tracingSpan, Internal.TookTooLong) -> + Internal.FailedSpan tracingSpan (Internal.TookTooLong) -> JUnit.errored (Internal.name test) |> JUnit.errorMessage "This test timed out." - |> ( case stackFrame test of - Nothing -> identity - Just frame -> JUnit.errorStackTrace [frame] - ) + |> JUnit.errorStackTrace [stackFrame test] |> JUnit.time (duration tracingSpan) |> JUnit.inSuite (suiteName test) - (tracingSpan, Internal.TestRunnerMessedUp msg) -> + Internal.FailedSpan tracingSpan (Internal.TestRunnerMessedUp msg) -> JUnit.errored (Internal.name test) |> JUnit.errorMessage ( Text.join @@ -125,10 +115,7 @@ "You can do so here: https://github.com/NoRedInk/haskell-libraries/issues" ] ) - |> ( case stackFrame test of - Nothing -> identity - Just frame -> JUnit.errorStackTrace [frame] - ) + |> JUnit.errorStackTrace [stackFrame test] |> JUnit.time (duration tracingSpan) |> JUnit.inSuite (suiteName test) @@ -137,17 +124,14 @@ Internal.describes test |> Text.join " - " -stackFrame :: Internal.SingleTest a -> Maybe Text +stackFrame :: Internal.SingleTest a -> Text stackFrame test = - Internal.loc test - |> map - ( \loc -> - Data.Text.pack - ( Stack.srcLocFile loc - ++ ":" - ++ Prelude.show (Stack.srcLocStartLine loc) - ) - ) + let loc = Internal.loc test + in Data.Text.pack + ( Stack.srcLocFile loc + ++ ":" + ++ Prelude.show (Stack.srcLocStartLine loc) + ) duration :: Platform.TracingSpan -> Float duration test = diff --git a/src/Test/Reporter/Logfile.hs b/src/Test/Reporter/Logfile.hs --- a/src/Test/Reporter/Logfile.hs +++ b/src/Test/Reporter/Logfile.hs @@ -17,7 +17,7 @@ import qualified Prelude report :: - Stack.HasCallStack => + (Stack.HasCallStack) => (Platform.TracingSpan -> Prelude.IO ()) -> Internal.SuiteResult -> Prelude.IO () @@ -44,6 +44,9 @@ Platform.succeeded = case results of Internal.AllPassed _ -> Platform.Succeeded _ -> Platform.Failed, + Platform.containsFailures = case results of + Internal.AllPassed _ -> False + _ -> True, Platform.allocated = 0, Platform.children = testSpans } @@ -62,11 +65,13 @@ Internal.PassedWithSkipped tests _ -> List.map bodyAndDescribes tests Internal.TestsFailed passed _ failed -> List.map bodyAndDescribes passed - ++ List.map (Tuple.mapSecond Tuple.first << bodyAndDescribes) failed + ++ List.map (bodyAndDescribes >> failedSpan) failed Internal.NoTestsInSuite -> [] where bodyAndDescribes :: Internal.SingleTest body -> ([Text], body) bodyAndDescribes test = (Internal.describes test, Internal.body test) + failedSpan :: ([Text], Internal.FailedSpan) -> ([Text], Platform.TracingSpan) + failedSpan (text, (Internal.FailedSpan span _)) = (text, span) groupIntoNamespaces :: [([Text], Platform.TracingSpan)] -> [Platform.TracingSpan] groupIntoNamespaces namespacedSpans = @@ -92,6 +97,8 @@ Platform.summary = Just namespace, Platform.succeeded = Prelude.mconcat (List.map Platform.succeeded spans'), + Platform.containsFailures = + List.any Platform.containsFailures spans', Platform.allocated = 0, Platform.children = namespacedSpanGroup @@ -106,7 +113,7 @@ ] ) -groupBy :: Ord b => (a -> b) -> List a -> Dict.Dict b (List a) +groupBy :: (Ord b) => (a -> b) -> List a -> Dict.Dict b (List a) groupBy f list = List.foldr ( \x -> 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 @@ -10,7 +10,10 @@ import qualified Data.ByteString as BS import qualified GHC.Stack as Stack import qualified List +import qualified Maybe import NriPrelude +import qualified Numeric +import qualified Platform.Internal import qualified System.IO import qualified Test.Internal as Internal import Test.Reporter.Internal (black, green, grey, red, yellow) @@ -19,113 +22,121 @@ import Text.Colour (chunk) import qualified Text.Colour import qualified Text.Colour.Capabilities.FromEnv -import qualified Tuple import qualified Prelude report :: System.IO.Handle -> Internal.SuiteResult -> Prelude.IO () report handle results = do terminalCapabilities <- Text.Colour.Capabilities.FromEnv.getTerminalCapabilitiesFromHandle handle reportChunks <- renderReport results - Text.Colour.hPutChunksWith terminalCapabilities handle reportChunks + Text.Colour.hPutChunksUtf8With terminalCapabilities handle reportChunks System.IO.hFlush handle renderReport :: Internal.SuiteResult -> Prelude.IO (List (Text.Colour.Chunk)) renderReport results = - case results of - Internal.AllPassed passed -> - let amountPassed = List.length passed - in Prelude.pure - [ green (Text.Colour.underline "TEST RUN PASSED"), - "\n\n", - black (chunk <| "Passed: " ++ Text.fromInt amountPassed), - "\n" - ] - Internal.OnlysPassed passed skipped -> - let amountPassed = List.length passed - amountSkipped = List.length skipped - in Prelude.pure - <| List.concat - [ List.concatMap - ( \only -> - prettyPath 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, - [ yellow (Text.Colour.underline ("TEST RUN INCOMPLETE")), - yellow " because there is an `only` in your tests.", + let elapsed = formatElapsedDuration results + in case results of + Internal.AllPassed passed -> + let amountPassed = List.length passed + in Prelude.pure + [ green (Text.Colour.underline "TEST RUN PASSED"), "\n\n", - black (chunk <| "Passed: " ++ Text.fromInt amountPassed), + black <| chunk <| "Duration: " ++ elapsed, "\n", - black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), + black (chunk <| "Passed: " ++ Text.fromInt amountPassed), "\n" ] - ] - Internal.PassedWithSkipped passed skipped -> - let amountPassed = List.length passed - amountSkipped = List.length skipped - in Prelude.pure - <| List.concat - [ List.concatMap - ( \only -> - prettyPath yellow only - ++ [ "This test was skipped.", - "\n\n" - ] - ) - skipped, - [ yellow (Text.Colour.underline "TEST RUN INCOMPLETE"), - yellow - ( chunk <| case List.length skipped of - 1 -> " because 1 test was skipped" - n -> " because " ++ Text.fromInt n ++ " tests were skipped" - ), + Internal.OnlysPassed passed skipped -> + let amountPassed = List.length passed + amountSkipped = List.length skipped + in Prelude.pure <| + List.concat + [ List.concatMap + ( \only -> + prettyPath 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, + [ yellow (Text.Colour.underline ("TEST RUN INCOMPLETE")), + yellow " because there is an `only` in your tests.", + "\n\n", + black <| chunk <| "Duration: " ++ elapsed, + "\n", + black (chunk <| "Passed: " ++ Text.fromInt amountPassed), + "\n", + black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), + "\n" + ] + ] + Internal.PassedWithSkipped passed skipped -> + let amountPassed = List.length passed + amountSkipped = List.length skipped + in Prelude.pure <| + List.concat + [ List.concatMap + ( \only -> + prettyPath yellow only + ++ [ "This test was skipped.", + "\n\n" + ] + ) + skipped, + [ yellow (Text.Colour.underline "TEST RUN INCOMPLETE"), + yellow + ( chunk <| case List.length skipped of + 1 -> " because 1 test was skipped" + n -> " because " ++ Text.fromInt n ++ " tests were skipped" + ), + "\n\n", + black <| chunk <| "Duration: " ++ elapsed, + "\n", + black (chunk <| "Passed: " ++ Text.fromInt amountPassed), + "\n", + black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), + "\n" + ] + ] + Internal.TestsFailed passed skipped failed -> do + let amountPassed = List.length passed + let amountFailed = List.length failed + let amountSkipped = List.length skipped + let failures = List.map (map (\(Internal.FailedSpan _ failure) -> failure)) failed + srcLocs <- Prelude.traverse Test.Reporter.Internal.readSrcLoc failures + let failuresSrcs = List.map renderFailureInFile srcLocs + Prelude.pure <| + List.concat + [ List.concat <| + List.map2 + ( \srcLines test -> + prettyPath red test + ++ srcLines + ++ [testFailure test, "\n\n"] + ) + failuresSrcs + failures, + [ red (Text.Colour.underline "TEST RUN FAILED"), "\n\n", - black (chunk <| "Passed: " ++ Text.fromInt amountPassed), + black <| chunk <| "Duration: " ++ elapsed, "\n", - black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), + black (chunk <| "Passed: " ++ Text.fromInt amountPassed), "\n" - ] + ], + if amountSkipped == 0 + then [] + else + [ black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), + "\n" + ], + [black (chunk <| "Failed: " ++ Text.fromInt amountFailed), "\n"] ] - Internal.TestsFailed passed skipped failed -> do - let amountPassed = List.length passed - let amountFailed = List.length failed - let amountSkipped = List.length skipped - let failures = List.map (map Tuple.second) failed - srcLocs <- Prelude.traverse Test.Reporter.Internal.readSrcLoc failures - let failuresSrcs = List.map renderFailureInFile srcLocs - Prelude.pure - <| List.concat - [ List.concat - <| List.map2 - ( \srcLines test -> - prettyPath red test - ++ srcLines - ++ [testFailure test, "\n\n"] - ) - failuresSrcs - failures, - [ red (Text.Colour.underline "TEST RUN FAILED"), - "\n\n", - black (chunk <| "Passed: " ++ Text.fromInt amountPassed), + Internal.NoTestsInSuite -> + Prelude.pure + [ yellow (Text.Colour.underline "TEST RUN INCOMPLETE"), + yellow " because the test suite is empty.", "\n" - ], - if amountSkipped == 0 - then [] - else - [ black (chunk <| "Skipped: " ++ Text.fromInt amountSkipped), - "\n" - ], - [black (chunk <| "Failed: " ++ Text.fromInt amountFailed), "\n"] - ] - Internal.NoTestsInSuite -> - Prelude.pure - [ yellow (Text.Colour.underline "TEST RUN INCOMPLETE"), - yellow " because the test suite is empty.", - "\n" - ] + ] renderFailureInFile :: Maybe (Stack.SrcLoc, BS.ByteString) -> List Text.Colour.Chunk renderFailureInFile maybeSrcLoc = @@ -135,12 +146,10 @@ prettyPath :: (Text.Colour.Chunk -> Text.Colour.Chunk) -> Internal.SingleTest a -> List Text.Colour.Chunk prettyPath style test = - List.concat - [ case Internal.loc test of - Nothing -> [] - Just loc -> - [ grey - <| chunk + let loc = Internal.loc test + in List.concat + [ [ grey <| + chunk ( "↓ " ++ Text.fromList (Stack.srcLocFile loc) ++ ":" @@ -148,21 +157,21 @@ ++ "\n" ) ], - [ grey - ( chunk - <| Prelude.foldMap - (\text -> "↓ " ++ text ++ "\n") - (Internal.describes test) - ), - style (chunk ("✗ " ++ Internal.name test)), - "\n" - ] - ] + [ grey + ( chunk <| + Prelude.foldMap + (\text -> "↓ " ++ text ++ "\n") + (Internal.describes test) + ), + style (chunk ("✗ " ++ Internal.name test)), + "\n" + ] + ] testFailure :: Internal.SingleTest Internal.Failure -> Text.Colour.Chunk testFailure test = - chunk - <| case Internal.body test of + chunk <| + case Internal.body test of Internal.FailedAssertion msg _ -> msg Internal.ThrewException exception -> "Test threw an exception\n" @@ -175,3 +184,44 @@ ++ "This is a bug.\n\n" ++ "If you have some time to report the bug it would be much appreciated!\n" ++ "You can do so here: https://github.com/NoRedInk/haskell-libraries/issues" + +formatElapsedDuration :: Internal.SuiteResult -> Text +formatElapsedDuration result = + result |> resultSpans |> elapsedMilliseconds |> formatElapsedMilliseconds + +elapsedMilliseconds :: List Platform.Internal.TracingSpan -> Float +elapsedMilliseconds spans = + let startTime = + spans + |> List.map Platform.Internal.started + |> List.minimum + |> Maybe.withDefault 0 + finishTime = + spans + |> List.map Platform.Internal.finished + |> List.maximum + |> Maybe.withDefault 0 + in finishTime - startTime |> Prelude.fromIntegral |> (/ 1000) + +resultSpans :: Internal.SuiteResult -> List Platform.Internal.TracingSpan +resultSpans result = + case result of + Internal.AllPassed passed -> + List.map Internal.body passed + Internal.OnlysPassed passed _skipped -> + List.map Internal.body passed + Internal.PassedWithSkipped passed _skipped -> + List.map Internal.body passed + Internal.TestsFailed passed _skipped failed -> do + List.map Internal.body passed + ++ (failed |> List.map Internal.body |> List.map (\(Internal.FailedSpan span _) -> span)) + Internal.NoTestsInSuite -> + [] + +-- and maybe add something like +-- for rendering the elapsed time into a human readable format not only to ms +formatElapsedMilliseconds :: Float -> Text +formatElapsedMilliseconds ms = + if ms < 1000 + then Text.fromInt (round ms) ++ " ms" + else Text.fromList (Numeric.showFFloat (Just 2) (ms / 1000) " s") diff --git a/src/Text.hs b/src/Text.hs --- a/src/Text.hs +++ b/src/Text.hs @@ -48,6 +48,9 @@ toList, fromList, + -- * Random stuff to Text + tshow, + -- * Formatting -- | Cosmetic operations such as padding with extra characters or trimming whitespace. @@ -194,7 +197,7 @@ slice from to text | to' - from' <= 0 = Data.Text.empty | otherwise = - Data.Text.drop from' (Data.Text.take to' text) + Data.Text.drop from' (Data.Text.take to' text) where len = Data.Text.length text handleNegative value @@ -484,3 +487,10 @@ -- > all isDigit "heart" == False all :: (Char -> Bool) -> Text -> Bool all = Data.Text.all + +-- | Get a Text representation of something Show-able. +-- +-- > newtype MyType = MyType deriving (Show) +-- > myTypeText = tshow MyType +tshow :: (Prelude.Show a) => a -> Text +tshow = Data.Text.pack << Prelude.show diff --git a/tests/ArraySpec.hs b/tests/ArraySpec.hs --- a/tests/ArraySpec.hs +++ b/tests/ArraySpec.hs @@ -38,7 +38,8 @@ |> toList |> Expect.equal (List.range 0 (size_ - 1)), fuzz size "push" <| \size_ -> - size_ - 1 + size_ + - 1 |> List.range 0 |> List.foldl push empty |> Expect.equal (initialize size_ identity), diff --git a/tests/BitwiseSpec.hs b/tests/BitwiseSpec.hs --- a/tests/BitwiseSpec.hs +++ b/tests/BitwiseSpec.hs @@ -75,34 +75,42 @@ describe "shiftLeftBy" [ test "8 |> shiftLeftBy 1 == 16" <| \() -> - 8 |> Bitwise.shiftLeftBy 1 + 8 + |> Bitwise.shiftLeftBy 1 |> Expect.equal 16, test "8 |> shiftLeftby 2 == 32" <| \() -> - 8 |> Bitwise.shiftLeftBy 2 + 8 + |> Bitwise.shiftLeftBy 2 |> Expect.equal 32 ], describe "shiftRightBy" [ test "32 |> shiftRight 1 == 16" <| \() -> - 32 |> Bitwise.shiftRightBy 1 + 32 + |> Bitwise.shiftRightBy 1 |> Expect.equal 16, test "32 |> shiftRight 2 == 8" <| \() -> - 32 |> Bitwise.shiftRightBy 2 + 32 + |> Bitwise.shiftRightBy 2 |> Expect.equal 8, test "-32 |> shiftRight 1 == -16" <| \() -> - -32 |> Bitwise.shiftRightBy 1 + -32 + |> Bitwise.shiftRightBy 1 |> Expect.equal (-16) ], describe "shiftRightZfBy" [ test "32 |> shiftRightZfBy 1 == 16" <| \() -> - 32 |> Bitwise.shiftRightZfBy 1 + 32 + |> Bitwise.shiftRightZfBy 1 |> Expect.equal 16, test "32 |> shiftRightZfBy 2 == 8" <| \() -> - 32 |> Bitwise.shiftRightZfBy 2 + 32 + |> Bitwise.shiftRightZfBy 2 |> Expect.equal 8, test "-32 |> shiftRightZfBy 1 == 9223372036854775792" <| \() -> - -32 |> Bitwise.shiftRightZfBy 1 + -32 + |> Bitwise.shiftRightZfBy 1 |> Expect.equal 9223372036854775792 ] ] diff --git a/tests/DebugSpec.hs b/tests/DebugSpec.hs --- a/tests/DebugSpec.hs +++ b/tests/DebugSpec.hs @@ -20,16 +20,16 @@ toStringTests :: List Test toStringTests = - [ test "returns the show form of an empty String" - <| \() -> Expect.equal "\"\"" (Debug.toString ("" :: Text)), - test "returns the show form of an Int" - <| \() -> Expect.equal "0" (Debug.toString (0 :: Int)) + [ test "returns the show form of an empty String" <| \() -> + Expect.equal "\"\"" (Debug.toString ("" :: Text)), + test "returns the show form of an Int" <| \() -> + Expect.equal "0" (Debug.toString (0 :: Int)) ] logTests :: List Test logTests = - [ test "returns passed value" - <| \() -> Expect.equal 3.14 (3.14 :: Float) + [ test "returns passed value" <| \() -> + Expect.equal 3.14 (3.14 :: Float) ] todoTests :: List Test @@ -42,6 +42,6 @@ ] -- | Extracts the first line of a given text string if it exists. Otherwise returns Nothing. -firstLine :: Show a => a -> Maybe Text +firstLine :: (Show a) => a -> Maybe Text firstLine = Debug.toString >> Text.lines >> head diff --git a/tests/GoldenHelpers.hs b/tests/GoldenHelpers.hs new file mode 100644 --- /dev/null +++ b/tests/GoldenHelpers.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module GoldenHelpers (goldenResultsDir) where + +import Data.Text (Text) + +-- | Historical context: +-- Golden results are slightly different between GHC 9.2.x and 8.10.x due +-- to apparent differences in internal handling of stack frame source locations. +-- In particular, the end of a function call now does not extend to the end of +-- the line but instead to the end of the function name. E.g. for the following: +-- +-- > foo +-- > bar +-- > baz +-- +-- In GHC 8.10.x (and possibly GHC 9.0.x?) `srcLocEndLine` and `srcLocEndCol` +-- would correspond to the `z` at the end of `baz`. Unfortunately, in GHC 9.2.x +-- it corresponds to the second `o` at the end of `foo`. +-- +-- In GHC 9.10.x, stack trace output formatting is a little different, and it changed +-- slightly again in GHC 9.12.x +-- +-- We keep this helper around so that if this happens again for future GHC versions +-- we can have different golden results for different GHC versions as necessary. +goldenResultsDir :: Text + +# if __GLASGOW_HASKELL__ >= 912 +goldenResultsDir = "tests/golden-results-9.12" +# elif __GLASGOW_HASKELL__ >= 910 +goldenResultsDir = "tests/golden-results-9.10" +# else +goldenResultsDir = "tests/golden-results-9.8" +# endif diff --git a/tests/LogSpec.hs b/tests/LogSpec.hs --- a/tests/LogSpec.hs +++ b/tests/LogSpec.hs @@ -6,6 +6,7 @@ import qualified Debug import qualified Expect import qualified GHC.Stack as Stack +import GoldenHelpers (goldenResultsDir) import Log import NriPrelude import qualified Platform.Internal as Internal @@ -30,7 +31,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-info", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-info"), test "`debug` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -43,7 +44,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/debug", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/debug"), test "`warn` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -56,7 +57,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/warn", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/warn"), test "`error` produces expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -69,7 +70,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/error", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/error"), test "nested spans pruduce expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -82,7 +83,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-nested-spans", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-nested-spans"), test "unexpected exceptions produce expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -96,7 +97,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-unexpected-exceptions", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-unexpected-exceptions"), test "async exceptions produce expected debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -115,7 +116,7 @@ recordedTracingSpans spans |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-async-exceptions", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-async-exceptions"), test "secrets do not appear in debugging info" <| \_ -> do spans <- Expect.fromIO <| do @@ -162,14 +163,31 @@ test "`Log.Context` can be shown" <| \_ -> Log.context "hello" "world" |> Debug.toString - |> Expect.equalToContentsOf "tests/golden-results/log-context-show" + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-context-show"), + test "`info` with `newRoot` produces expected debugging info" <| \_ -> do + spans <- + Expect.fromIO <| do + (recordedTracingSpans, handler) <- newHandler + _ <- + do + withContext "foo" [] <| info "logging a message!" [context "a number" (12 :: Int)] + Internal.newRoot "inner" <| info "logging a first 'inner' message" [] + Internal.newRoot "inner" <| do + info "logging a second 'inner' message" [] + info "logging a third 'inner' message" [] + Task.succeed () + |> Task.attempt handler + recordedTracingSpans + spans + |> Debug.toString + |> Expect.equalToContentsOf (goldenResultsDir ++ "/log-new-root") ] data TestException = TestException deriving (Show) instance Exception.Exception TestException -newHandler :: Stack.HasCallStack => Prelude.IO (Prelude.IO [Internal.TracingSpan], Internal.LogHandler) +newHandler :: (Stack.HasCallStack) => Prelude.IO (Prelude.IO [Internal.TracingSpan], Internal.LogHandler) newHandler = do recordedTracingSpans <- IORef.newIORef [] handler <- @@ -177,7 +195,9 @@ Internal.mkHandler "" (Internal.Clock (Prelude.pure 0)) - (IORef.writeIORef recordedTracingSpans << Internal.children) + Internal.silentTrack + (\span -> IORef.modifyIORef recordedTracingSpans (\cs -> cs ++ Internal.children span)) + Nothing "" Prelude.pure ( do diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -12,6 +12,7 @@ import qualified PlatformSpec import qualified SetSpec import qualified System.IO +import qualified TaskSpec import Test (Test, describe, run) import qualified TestSpec import qualified TextSpec @@ -30,6 +31,7 @@ BitwiseSpec.tests, DictSpec.tests, SetSpec.tests, + TaskSpec.tests, TestSpec.tests, TextSpec.tests, LogSpec.tests, diff --git a/tests/PlatformSpec.hs b/tests/PlatformSpec.hs --- a/tests/PlatformSpec.hs +++ b/tests/PlatformSpec.hs @@ -1,10 +1,18 @@ module PlatformSpec (tests) where +import qualified Control.Concurrent.MVar as MVar +import Control.Monad.Catch (catchAll) import Data.Aeson as Aeson +import qualified Data.IORef as IORef import qualified Expect +import qualified Log import NriPrelude import qualified Platform +import qualified Platform.Analytics.Internal +import qualified Platform.Internal +import Task import Test (Test, describe, test) +import qualified Prelude tests :: Test tests = @@ -14,10 +22,101 @@ CustomTracingSpanDetails "Hi!" |> Platform.toTracingSpanDetails |> Platform.fromTracingSpanDetails - |> Expect.equal (Just (CustomTracingSpanDetails "Hi!")) + |> Expect.equal (Just (CustomTracingSpanDetails "Hi!")), + test "parent span marked as failed when exception is thrown" <| \_ -> do + span <- + runTaskAndExpectTacingSpan <| Platform.tracingSpan "throw" <| Platform.unsafeThrowException "error" + + Expect.false (isSucceeded span) + Expect.true (Platform.containsFailures span), + test "parent span not marked as failed when error is logged" <| \_ -> do + span <- + runTaskAndExpectTacingSpan <| Log.error "error" [] + + Expect.true (isSucceeded span) + Expect.true (Platform.containsFailures span), + test "trackAnalyticsEvent threaded by rootTracingSpanIO is invoked from a child span" <| \_ -> do + ref <- Expect.fromIO (IORef.newIORef []) + let track v = + Platform.Internal.Task + ( \_ -> do + IORef.atomicModifyIORef' ref (\xs -> (v : xs, ())) + Prelude.pure (Ok ()) + ) + Expect.fromIO + <| Platform.rootTracingSpanIO "test-req" track (\_ -> Prelude.pure ()) "root" + <| \log -> do + child <- Platform.Internal.startChildTracingSpan log "child-span" + let Platform.Internal.Task runTrack = + Platform.Internal.trackAnalyticsEvent child (Aeson.toJSON ("hello" :: Text)) + _ <- runTrack child + Prelude.pure () + observed <- Expect.fromIO (IORef.readIORef ref) + observed |> Expect.equal [Aeson.toJSON ("hello" :: Text)], + test "nullHandler.trackAnalyticsEvent is a silent no-op" <| \_ -> do + let Platform.Internal.Task runTrack = + Platform.Internal.trackAnalyticsEvent Platform.Internal.nullHandler Aeson.Null + _ <- Expect.fromIO (runTrack Platform.Internal.nullHandler) + Expect.pass, + test "Platform.Analytics.Internal.trackEvent invokes the current LogHandler's analytics callback with toJSON of the event" <| \_ -> do + ref <- Expect.fromIO (IORef.newIORef []) + let track v = + Platform.Internal.Task + ( \_ -> do + IORef.atomicModifyIORef' ref (\xs -> (v : xs, ())) + Prelude.pure (Ok ()) + ) + let event = Aeson.object ["kind" Aeson..= ("LessonStarted" :: Text)] + result <- + Expect.fromIO + <| Platform.rootTracingSpanIO "test-req" track (\_ -> Prelude.pure ()) "root" + <| \log -> Task.attempt log (Platform.Analytics.Internal.trackEvent event) + case result of + Ok () -> Expect.pass + Err _ -> Expect.fail "trackEvent task failed" + observed <- Expect.fromIO (IORef.readIORef ref) + observed |> Expect.equal [event], + test "Platform.Analytics.Internal.trackEvent opens an analytics.track child span carrying the JSON payload as details" <| \_ -> do + spanVar <- Expect.fromIO MVar.newEmptyMVar + let event = Aeson.object ["kind" Aeson..= ("LessonStarted" :: Text)] + _ <- + Expect.fromIO + <| Platform.rootTracingSpanIO "test-req" Platform.silentTrack (MVar.putMVar spanVar) "root" + <| \log -> Task.attempt log (Platform.Analytics.Internal.trackEvent event) + root <- Expect.fromIO (MVar.takeMVar spanVar) + case Prelude.filter (\s -> Platform.Internal.name s == "analytics.track") (Platform.Internal.children root) of + [child] -> do + Platform.Internal.name child |> Expect.equal "analytics.track" + NriPrelude.map Aeson.toJSON (Platform.Internal.details child) |> Expect.equal (Just event) + [] -> Expect.fail "expected an analytics.track child span; found none" + _ -> Expect.fail "expected exactly one analytics.track child span" ] newtype CustomTracingSpanDetails = CustomTracingSpanDetails Text deriving (Aeson.ToJSON, Show, Eq) instance Platform.TracingSpanDetails CustomTracingSpanDetails + +runTaskAndExpectTacingSpan :: Task e () -> Expect.Expectation' Platform.TracingSpan +runTaskAndExpectTacingSpan task = + Expect.fromIO <| do + spanVar <- MVar.newEmptyMVar + + _ <- + catchAll + ( Platform.rootTracingSpanIO + "" + Platform.silentTrack + (MVar.putMVar spanVar) + "test" + (\log -> Task.attempt log task) + ) + (\_ -> Prelude.pure <| NriPrelude.Ok ()) + + MVar.takeMVar spanVar + +isSucceeded :: Platform.TracingSpan -> Bool +isSucceeded span = + case Platform.succeeded span of + Platform.Succeeded -> True + _ -> False diff --git a/tests/TaskSpec.hs b/tests/TaskSpec.hs new file mode 100644 --- /dev/null +++ b/tests/TaskSpec.hs @@ -0,0 +1,92 @@ +module TaskSpec (tests) where + +import qualified Control.Exception.Safe as Exception +import qualified Expect +import qualified List +import NriPrelude +import qualified Platform +import qualified Process +import qualified Task +import Test (Test, describe, test) +import Test.Internal (Failure) +import qualified Tuple +import Prelude ((*>)) +import qualified Prelude + +tests :: Test +tests = + describe + "Task" + [ describe + "sequence" + [ test "actually runs in sequence" <| \() -> do + doAnything <- Expect.fromIO Platform.doAnythingHandler + let shouldNeverRun = \x -> Platform.doAnything doAnything (Exception.throwString x) + failure <- + [Task.succeed 1, Task.fail "a", shouldNeverRun "b"] + |> Task.sequence + |> Expect.fails + Expect.equal "a" failure + -- Prelude.sequence also runs things in sequence. + failure2 <- + [Task.succeed 1, Task.fail "a", shouldNeverRun "b"] + |> Prelude.sequence + |> Expect.fails + Expect.equal "a" failure2 + ], + describe + "map2" + [ test "only runs first task if that fails" <| \() -> do + doAnything <- Expect.fromIO Platform.doAnythingHandler + let shouldNeverRun = \x -> Platform.doAnything doAnything (Exception.throwString x) + failure <- + Task.map2 + Tuple.pair + (Task.fail "a") + (shouldNeverRun "b") + |> Expect.fails + Expect.equal "a" failure + ], + describe + "map3" + [ test "only runs until the first task fails" <| \() -> do + doAnything <- Expect.fromIO Platform.doAnythingHandler + let shouldNeverRun = \x -> Platform.doAnything doAnything (Exception.throwString x) + failure <- + Task.map3 + (\a b c -> (a, b, c)) + (Task.succeed 1) + (Task.fail "c") + (shouldNeverRun "d") + |> Expect.fails + Expect.equal "c" failure + ], + describe + "parallel" + [ test "returns the right values" <| \() -> do + let results = [1, 2, 3] + let tasks = List.map afterDelay results + + parallelResults <- Expect.succeeds <| Task.parallel tasks + + Expect.equal results parallelResults + ], + describe + "concurrently" + [ test "returns the right values" <| \() -> do + let results = (1, ("two", 3.0 :: Float)) + let (taskA, (taskB, taskC)) = Tuple.mapBoth afterDelay (Tuple.mapBoth afterDelay afterDelay) results + + concurrentResults <- + Expect.succeeds <| Task.concurrently taskA <| Task.concurrently taskB taskC + + Expect.equal results concurrentResults + ] + ] + +afterDelay :: a -> Task Failure a +afterDelay a = + Process.sleep waitMilliseconds *> Task.succeed a + +waitMilliseconds :: Float +waitMilliseconds = 100 diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs --- a/tests/TestSpec.hs +++ b/tests/TestSpec.hs @@ -1,5 +1,7 @@ module TestSpec (tests) where +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.MVar as MVar import qualified Control.Exception.Safe as Exception import qualified Data.Aeson.Encode.Pretty import qualified Data.ByteString.Lazy @@ -10,12 +12,15 @@ import qualified Fuzz import qualified GHC.Exts import qualified GHC.Stack as Stack +import GoldenHelpers (goldenResultsDir) +import qualified List import NriPrelude import qualified Platform import qualified Platform.Internal import qualified System.IO import qualified Task -import Test (Test, describe, fuzz, fuzz2, fuzz3, only, skip, test, todo) +import Test (Test, describe, fuzz, fuzz2, fuzz3, only, serialize, skip, test, todo) +import qualified Test.CliParser as CliParser import qualified Test.Internal as Internal import qualified Test.Reporter.Logfile import qualified Test.Reporter.Stdout @@ -29,7 +34,10 @@ [ api, floatComparison, stdoutReporter, - logfileReporter + logfileReporter, + cliParser, + deadlockPrevention, + runExpectationTests ] api :: Test @@ -43,7 +51,7 @@ [ test "test 1" (\_ -> Expect.pass), test "test 2" (\_ -> Expect.pass) ] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal (AllPassed ["test 1", "test 2"]), @@ -54,10 +62,39 @@ [ test "test 1" (\_ -> Expect.pass), only <| test "test 2" (\_ -> Expect.pass) ] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal (OnlysPassed ["test 2"] ["test 1"]), + test "suite result is 'AllPassed' with only the one test when passed a filepath" <| \_ -> do + let srcLoc = + Internal.getFrame "subset test" + |> Stack.srcLocStartLine + |> Prelude.fromIntegral + suite = + describe + "suite" + [ test "test 1" (\_ -> Expect.pass), + test "test 2" (\_ -> Expect.pass), + test + "test 3" + ( \_ -> + Expect.pass + ) + ] + result <- + suite + |> Internal.run + ( Internal.Some + [ Internal.SubsetOfTests "tests/TestSpec.hs" (Just (srcLoc + 6)), + Internal.SubsetOfTests "tests/TestSpec.hs" (Just (srcLoc + 8)) + ] + ) + |> Expect.succeeds + + result + |> simplify + |> Expect.equal (AllPassed ["test 1", "test 3"]), test "suite result is 'PassedWithSkipped' when containing skipped test" <| \_ -> do let suite = describe @@ -65,7 +102,7 @@ [ test "test 1" (\_ -> Expect.pass), skip <| test "test 2" (\_ -> Expect.pass) ] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]), @@ -76,13 +113,13 @@ [ test "test 1" (\_ -> Expect.pass), todo "test 2" ] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal (PassedWithSkipped ["test 1"] ["test 2"]), test "suite result is 'NoTestsInSuite' when it contains no tests" <| \_ -> do let suite = describe "suite" [] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal NoTestsInSuite, @@ -94,7 +131,7 @@ skip <| test "test 2" (\_ -> Expect.pass), test "test 3" (\_ -> Expect.fail "oops") ] - result <- Expect.succeeds <| Internal.run suite + result <- Expect.succeeds <| Internal.run Internal.All suite result |> simplify |> Expect.equal (TestsFailed ["test 1"] ["test 2"] ["test 3"]), @@ -140,7 +177,7 @@ ) (Debug.todo "foo" :: Prelude.IO Text) ) - Expect.equalToContentsOf "tests/golden-results/debug-todo-stacktrace" contents + Expect.equalToContentsOf (goldenResultsDir ++ "/debug-todo-stacktrace") contents ] floatComparison :: Test @@ -169,13 +206,11 @@ expectSrcFile :: Text -> Internal.SingleTest a -> Expect.Expectation expectSrcFile expected test' = - case Internal.loc test' of - Nothing -> - Expect.fail "Expected source file location for test, but none was set." - Just loc -> - Stack.srcLocFile loc - |> Data.Text.pack - |> Expect.equal expected + test' + |> Internal.loc + |> Stack.srcLocFile + |> Data.Text.pack + |> Expect.equal expected -- | A type mirroring `Internal.SuiteResult`, simplified to allow easy -- comparisons in tests. @@ -217,20 +252,20 @@ withTempFile ( \_ handle -> Internal.AllPassed - [ mockTest "test 1" mockTracingSpan, - mockTest "test 2" mockTracingSpan + [ mockTest "test 1" (mockTracingSpanWithTimes 0 10), + mockTest "test 2" (mockTracingSpanWithTimes 1 1234) ] |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-all-passed", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-all-passed"), test "onlys passed" <| \_ -> do contents <- withTempFile ( \_ handle -> Internal.OnlysPassed - [ mockTest "test 1" mockTracingSpan, - mockTest "test 2" mockTracingSpan + [ mockTest "test 1" (mockTracingSpanWithTimes 0 10), + mockTest "test 2" (mockTracingSpanWithTimes 1 13) ] [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan @@ -238,14 +273,14 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-onlys-passed", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-onlys-passed"), test "passed with skipped" <| \_ -> do contents <- withTempFile ( \_ handle -> Internal.PassedWithSkipped - [ mockTest "test 1" mockTracingSpan, - mockTest "test 2" mockTracingSpan + [ mockTest "test 1" (mockTracingSpanWithTimes 0 10), + mockTest "test 2" (mockTracingSpanWithTimes 1 9) ] [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan @@ -253,7 +288,7 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-passed-with-skipped", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-passed-with-skipped"), test "no tests in suite" <| \_ -> do contents <- withTempFile @@ -262,27 +297,27 @@ |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-no-tests-in-suite", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-no-tests-in-suite"), test "tests failed" <| \_ -> do contents <- withTempFile ( \_ handle -> Internal.TestsFailed - [ mockTest "test 1" mockTracingSpan, - mockTest "test 2" mockTracingSpan + [ mockTest "test 1" (mockTracingSpanWithTimes 1 2), + mockTest "test 2" (mockTracingSpanWithTimes 3 6) ] [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan ] - [ 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") + [ mockTest "test 5" (Internal.FailedSpan (mockTracingSpanWithTimes 1 12) (Internal.FailedAssertion "assertion error" mockSrcLoc)), + mockTest "test 6" (Internal.FailedSpan (mockTracingSpanWithTimes 1 13) (Internal.ThrewException mockException)), + mockTest "test 7" (Internal.FailedSpan (mockTracingSpanWithTimes 1 14) Internal.TookTooLong), + mockTest "test 7" (Internal.FailedSpan (mockTracingSpanWithTimes 1 18) (Internal.TestRunnerMessedUp "sorry")) ] |> Test.Reporter.Stdout.report handle ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-tests-failed"), test "tests failed (actually running)" <| \_ -> do let suite = describe @@ -317,12 +352,67 @@ ( \_ handle -> do log <- Platform.silentHandler result <- - Internal.run suite + Internal.run Internal.All suite |> Task.perform log Test.Reporter.Stdout.report handle result ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-stdout-tests-failed-loc" + |> withoutDurationLine + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-tests-failed-loc"), + test "tests failed (actually running) only run subset" <| \_ -> do + let srcLoc = + Internal.getFrame "subset test" + |> Stack.srcLocStartLine + |> Prelude.fromIntegral + suite = + describe + "suite loc" + [ test "test fail" (\_ -> Expect.fail "fail"), + test "test equal" (\_ -> Expect.equal True True), + test "test notEqual" (\_ -> Expect.notEqual True False) + ] + contents <- + withTempFile + ( \_ handle -> do + log <- Platform.silentHandler + result <- + suite + |> Internal.run + ( Internal.Some + [ Internal.SubsetOfTests "tests/TestSpec.hs" (Just (srcLoc + 6)), + Internal.SubsetOfTests "tests/TestSpec.hs" (Just (srcLoc + 8)) + ] + ) + |> Task.perform log + Test.Reporter.Stdout.report handle result + ) + Expect.true (Text.contains "Passed: 1" contents) + Expect.true (Text.contains "Failed: 1" contents) + contents + |> withoutDurationLine + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-tests-failed-loc-subset"), + test "tests failed (actually running) only run onefile" <| \_ -> do + let suite = + describe + "suite loc" + [ test "test fail" (\_ -> Expect.fail "fail"), + test "test equal" (\_ -> Expect.equal True True), + test "test notEqual" (\_ -> Expect.notEqual True False) + ] + contents <- + withTempFile + ( \_ handle -> do + log <- Platform.silentHandler + result <- + suite + |> Internal.run + (Internal.Some [Internal.SubsetOfTests "tests/TestSpec.hs" Nothing]) + |> Task.perform log + Test.Reporter.Stdout.report handle result + ) + contents + |> withoutDurationLine + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-stdout-tests-failed-loc-one-file") ] logfileReporter :: Test @@ -340,7 +430,7 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-all-passed", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-logfile-all-passed"), test "onlys passed" <| \_ -> do contents <- withTempFile @@ -355,7 +445,7 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-onlys-passed", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-logfile-onlys-passed"), test "passed with skipped" <| \_ -> do contents <- withTempFile @@ -370,7 +460,7 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-passed-with-skipped", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-logfile-passed-with-skipped"), test "no tests in suite" <| \_ -> do contents <- withTempFile @@ -379,7 +469,7 @@ |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-no-tests-in-suite", + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-logfile-no-tests-in-suite"), test "tests failed" <| \_ -> do contents <- withTempFile @@ -391,15 +481,15 @@ [ mockTest "test 3" Internal.NotRan, mockTest "test 4" Internal.NotRan ] - [ 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") + [ mockTest "test 5" (Internal.FailedSpan mockTracingSpan (Internal.FailedAssertion "assertion error" mockSrcLoc)), + mockTest "test 6" (Internal.FailedSpan mockTracingSpan (Internal.ThrewException mockException)), + mockTest "test 7" (Internal.FailedSpan mockTracingSpan Internal.TookTooLong), + mockTest "test 7" (Internal.FailedSpan mockTracingSpan (Internal.TestRunnerMessedUp "sorry")) ] |> Test.Reporter.Logfile.report (writeSpan handle) ) contents - |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-tests-failed" + |> Expect.equalToContentsOf (goldenResultsDir ++ "/test-report-logfile-tests-failed") ] writeSpan :: System.IO.Handle -> Platform.Internal.TracingSpan -> Prelude.IO () @@ -429,20 +519,26 @@ { Internal.describes = ["suite", "sub suite"], Internal.name = name, Internal.label = Internal.None, - Internal.loc = Just mockSrcLoc, + Internal.loc = mockSrcLoc, + Internal.group = Internal.Ungrouped, Internal.body = body } mockTracingSpan :: Platform.Internal.TracingSpan mockTracingSpan = + mockTracingSpanWithTimes 0 0 + +mockTracingSpanWithTimes :: Int -> Int -> Platform.Internal.TracingSpan +mockTracingSpanWithTimes startedMs finishedMs = Platform.Internal.TracingSpan { Platform.Internal.name = "name", - Platform.Internal.started = Platform.Internal.MonotonicTime 0, - Platform.Internal.finished = Platform.Internal.MonotonicTime 0, + Platform.Internal.started = Platform.Internal.MonotonicTime (1000 * Prelude.fromIntegral startedMs), + Platform.Internal.finished = Platform.Internal.MonotonicTime (1000 * Prelude.fromIntegral finishedMs), Platform.Internal.frame = Nothing, Platform.Internal.details = Nothing, Platform.Internal.summary = Nothing, Platform.Internal.succeeded = Platform.Internal.Succeeded, + Platform.Internal.containsFailures = False, Platform.Internal.allocated = 1, Platform.Internal.children = [] } @@ -463,3 +559,131 @@ mockException = Exception.StringException "exception" (GHC.Exts.fromList []) |> Exception.toException + +cliParser :: Test +cliParser = + describe + "CLI Parser" + [ test "All tests" <| \_ -> + CliParser.parseArgs + [] + |> Expect.equal (Ok Internal.All), + test "Missing separator" <| \_ -> + CliParser.parseArgs + ["--files"] + |> Expect.equal (Err "must inform at least one file: not enough input"), + test "trailing comma" <| \_ -> + CliParser.parseArgs + ["--files", "a.hs,"] + |> Expect.equal (Ok (Internal.Some [Internal.SubsetOfTests "a.hs" Nothing])), + test "1 file" <| \_ -> + CliParser.parseArgs + ["--files", "a.hs"] + |> Expect.equal (Ok (Internal.Some [Internal.SubsetOfTests "a.hs" Nothing])), + test "2 files" <| \_ -> + CliParser.parseArgs + ["--files", "a.hs,b.hs"] + |> Expect.equal + ( Ok + ( Internal.Some + [Internal.SubsetOfTests "a.hs" Nothing, Internal.SubsetOfTests "b.hs" Nothing] + ) + ), + test "Doesn't really parse file paths" <| \_ -> + CliParser.parseArgs + ["--files", "bla.hs\nble.hs"] + |> Expect.equal + ( Ok + (Internal.Some [Internal.SubsetOfTests "bla.hs\nble.hs" Nothing]) + ), + test "File with LoC" <| \_ -> + CliParser.parseArgs + ["--files", "bla.hs:123"] + |> Expect.equal + ( Ok + (Internal.Some [Internal.SubsetOfTests "bla.hs" (Just 123)]) + ), + test "File with bad LoC" <| \_ -> + CliParser.parseArgs + ["--files", "bla.hs:1asd"] + |> Expect.equal + (Err "Failed reading: expected format: --files=bla.hs or --files bla.hs: \"asd\""), + test "File with bad LoC in first file" <| \_ -> + CliParser.parseArgs + ["--files", "bla.hs:1asd,b.hs"] + |> Expect.equal + (Err "Failed reading: expected format: --files=bla.hs or --files bla.hs: \"asd,b.hs\"") + ] + +deadlockPrevention :: Test +deadlockPrevention = + describe + "Prevent deadlocks in tests" + [ test "a test that deadlocks" <| \_ -> do + mvar1 <- Expect.fromIO MVar.newEmptyMVar + mvar2 <- Expect.fromIO MVar.newEmptyMVar + + _ <- + deadlockSuite mvar1 mvar2 + |> Internal.run Internal.All + |> Task.timeout 1000 Internal.TookTooLong + |> Expect.fails + Expect.pass, + test "serial tests don't deadlock" <| \_ -> do + mvar1 <- Expect.fromIO MVar.newEmptyMVar + mvar2 <- Expect.fromIO MVar.newEmptyMVar + + _ <- + deadlockSuite mvar1 mvar2 + |> serialize "groupKey" + |> Internal.run Internal.All + |> Expect.succeeds + Expect.pass + ] + +deadlockSuite :: MVar.MVar () -> MVar.MVar () -> Test +deadlockSuite mvar1 mvar2 = + describe + "two deadlocking tests" + [ test "test 1" <| \_ -> do + Expect.fromIO (MVar.putMVar mvar1 ()) + Expect.fromIO <| threadDelay 100 + Expect.fromIO (MVar.putMVar mvar2 ()) + _ <- Expect.fromIO (MVar.takeMVar mvar2) + _ <- Expect.fromIO (MVar.takeMVar mvar1) + Expect.pass, + test "test 2" <| \_ -> do + Expect.fromIO (MVar.putMVar mvar2 ()) + Expect.fromIO <| threadDelay 100 + Expect.fromIO (MVar.putMVar mvar1 ()) + _ <- Expect.fromIO (MVar.takeMVar mvar1) + _ <- Expect.fromIO (MVar.takeMVar mvar2) + Expect.pass + ] + +withoutDurationLine :: Text -> Text +withoutDurationLine text = + text + |> Text.lines + |> List.filter (\line -> line |> Text.startsWith "Duration: " |> not) + |> Text.join "\n" + +runExpectationTests :: Test +runExpectationTests = + describe + "runExpectation" + [ test "returns the value on success" <| \_ -> do + log <- Expect.fromIO Platform.silentHandler + result <- + Expect.fromIO + ( Internal.runExpectation log (Expect.succeeds (Task.succeed 42)) + ) + Expect.ok result, + test "throws Failure exception on assertion failure" <| \_ -> do + log <- Expect.fromIO Platform.silentHandler + result <- + Expect.fromIO + ( Internal.runExpectation log (Expect.fail "test failure") + ) + Expect.err result + ]