diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 0.3.1.0 + +Enhancements: + +- `Platform.summary` can be used to decorate tracing spans with a text summary for use in dev tooling. +- `Platform.writeSpanToDevLog` can be used to write a span for consumption by the new `log-explorer` tool. + # 0.3.0.0 Breaking changs: diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ BSD 3-Clause License -Copyright (c) 2020, NoRedInk +Copyright (c) 2021, NoRedInk All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/nri-prelude.cabal b/nri-prelude.cabal --- a/nri-prelude.cabal +++ b/nri-prelude.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2de1014852d15f8dc7dd66b6540283d0fe7b3997b91e1a08d6f0ee4f5ea76271 +-- hash: 289dd9fd1e47c8a3adb825dd181635cdff04f29f8f3744acb5e426d735d2c8ab name: nri-prelude -version: 0.3.0.0 +version: 0.3.1.0 synopsis: A Prelude inspired by the Elm programming language description: Please see the README at . category: Web @@ -15,7 +15,7 @@ bug-reports: https://github.com/NoRedInk/haskell-libraries/issues author: NoRedInk maintainer: haskell-open-source@noredink.com -copyright: 2020 NoRedInk Corp. +copyright: 2021 NoRedInk Corp. license: BSD3 license-file: LICENSE build-type: Simple @@ -57,11 +57,13 @@ other-modules: Internal.Shortcut Internal.Terminal + Platform.DevLog Platform.DoAnything Platform.Internal Test.Internal Test.Reporter.ExitCode Test.Reporter.Junit + Test.Reporter.Logfile Test.Reporter.Stdout Paths_nri_prelude hs-source-dirs: @@ -70,6 +72,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns build-depends: aeson >=1.4.6.0 && <1.6 + , aeson-pretty >=0.8.0 && <0.9 , ansi-terminal >=0.9.1 && <0.12 , async >=2.2.2 && <2.3 , auto-update >=0.1.6 && <0.2 @@ -119,6 +122,7 @@ Maybe NriPrelude Platform + Platform.DevLog Platform.DoAnything Platform.Internal Process @@ -129,6 +133,7 @@ Test.Internal Test.Reporter.ExitCode Test.Reporter.Junit + Test.Reporter.Logfile Test.Reporter.Stdout Text Tuple @@ -140,6 +145,7 @@ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wpartial-fields -Wredundant-constraints -Wincomplete-uni-patterns -threaded -rtsopts "-with-rtsopts=-N -T" build-depends: aeson >=1.4.6.0 && <1.6 + , aeson-pretty >=0.8.0 && <0.9 , ansi-terminal >=0.9.1 && <0.12 , async >=2.2.2 && <2.3 , auto-update >=0.1.6 && <0.2 diff --git a/src/Log.hs b/src/Log.hs --- a/src/Log.hs +++ b/src/Log.hs @@ -129,7 +129,10 @@ name ( Platform.finally task - (Platform.setTracingSpanDetails (LogContexts contexts)) + ( do + Platform.setTracingSpanDetails (LogContexts contexts) + Platform.setTracingSpanSummary name + ) ) -- diff --git a/src/Platform.hs b/src/Platform.hs --- a/src/Platform.hs +++ b/src/Platform.hs @@ -20,6 +20,8 @@ Internal.rootTracingSpanIO, Internal.setTracingSpanDetails, Internal.setTracingSpanDetailsIO, + Internal.setTracingSpanSummary, + Internal.setTracingSpanSummaryIO, Internal.markTracingSpanFailed, Internal.markTracingSpanFailedIO, @@ -31,6 +33,7 @@ Internal.finished, Internal.frame, Internal.details, + Internal.summary, Internal.succeeded, Internal.allocated, Internal.children, @@ -42,6 +45,9 @@ Internal.MonotonicTime, Internal.inMicroseconds, + -- * Reporting spans to development tooling + Platform.DevLog.writeSpanToDevLog, + -- * Ensuring cleanup logic gets ran in case of exceptions. bracketWithError, finally, @@ -57,6 +63,7 @@ import qualified Data.Text import qualified GHC.Stack as Stack import NriPrelude +import qualified Platform.DevLog import qualified Platform.DoAnything as DoAnything import qualified Platform.Internal as Internal import qualified Task diff --git a/src/Platform/DevLog.hs b/src/Platform/DevLog.hs new file mode 100644 --- /dev/null +++ b/src/Platform/DevLog.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -fno-cse #-} + +module Platform.DevLog + ( writeSpanToDevLog, + ) +where + +import qualified Control.Concurrent.MVar as MVar +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy +import qualified Data.Time as Time +import NriPrelude +import qualified Platform.Internal +import qualified System.IO +import qualified System.IO.Unsafe +import qualified Prelude + +-- | Write a tracing span to the development log, where it can be found by +-- `log-explorer` for closer inspection. +writeSpanToDevLog :: Platform.Internal.TracingSpan -> Prelude.IO () +writeSpanToDevLog span = do + now <- Time.getCurrentTime + let logFile = "/tmp/nri-prelude-logs" + MVar.withMVar writeLock <| \_ -> + System.IO.withFile + logFile + System.IO.AppendMode + ( \handle -> do + Data.ByteString.Lazy.hPut handle (Aeson.encode (now, span)) + Data.ByteString.Lazy.hPut handle "\n" + ) + +-- A lock used to ensure writing spans to the dev log are atomic, processes will +-- take turns to fully write their spans to the log to prevent interleaving. +{-# NOINLINE writeLock #-} +writeLock :: MVar.MVar () +writeLock = + MVar.newMVar () + |> System.IO.Unsafe.unsafePerformIO diff --git a/src/Platform/Internal.hs b/src/Platform/Internal.hs --- a/src/Platform/Internal.hs +++ b/src/Platform/Internal.hs @@ -8,11 +8,14 @@ import Control.Applicative ((<|>)) import qualified Control.AutoUpdate as AutoUpdate import qualified Control.Exception.Safe as Exception +import Data.Aeson ((.:), (.:?), (.=)) import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encoding as Aeson.Encoding import qualified Data.IORef as IORef import qualified Data.Text import qualified Data.Typeable as Typeable import qualified GHC.Clock as Clock +import GHC.Generics (Generic) import qualified GHC.Stack as Stack import qualified GHC.Word import qualified Internal.Shortcut as Shortcut @@ -134,6 +137,9 @@ frame :: Maybe (Text, Stack.SrcLoc), -- | Unique information for this tracingSpan. details :: Maybe SomeTracingSpanDetails, + -- | A short blurb describing the details of this span, for use in + -- tooling for inspecting these spans. + summary :: Maybe Text, -- | Whether this tracingSpan succeeded. If any of the children of this -- tracingSpan failed, so will this tracingSpan. This will create a -- path to the tracingSpan closest to the failure from the root @@ -151,8 +157,117 @@ -- of the list. children :: [TracingSpan] } - deriving (Prelude.Show) + deriving (Prelude.Show, Generic) +instance Aeson.ToJSON TracingSpan where + toJSON span = + Aeson.object + [ "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 + ] + 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 + ) + +instance Aeson.FromJSON TracingSpan where + parseJSON = + Aeson.withObject + "TracingSpan" + ( \object -> do + name <- object .: "name" + started <- object .: "started" + finished <- object .: "finished" + frame <- map (map unSrcLocForEncoding) (object .:? "frame") + details <- object .:? "details" + summary <- object .:? "summary" + succeeded <- object .: "succeeded" + allocated <- object .: "allocated" + children <- object .: "children" + Prelude.pure + TracingSpan + { name, + started, + finished, + frame, + details, + summary, + succeeded, + allocated, + children + } + ) + +newtype SrcLocForEncoding = SrcLocForEncoding {unSrcLocForEncoding :: (Text, Stack.SrcLoc)} + +instance Aeson.ToJSON SrcLocForEncoding where + toJSON (SrcLocForEncoding (name, loc)) = + Aeson.object + [ "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 + ] + 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 + ) + +instance Aeson.FromJSON SrcLocForEncoding where + parseJSON = + Aeson.withObject + "SrcLocForEncoding" + ( \object -> do + name <- object .: "name" + srcLocPackage <- object .: "package" + srcLocModule <- object .: "module" + srcLocFile <- object .: "file" + srcLocStartLine <- object .: "startLine" + srcLocStartCol <- object .: "startCol" + srcLocEndLine <- object .: "endLine" + srcLocEndCol <- object .: "endCol" + Prelude.pure + ( SrcLocForEncoding + ( name, + Stack.SrcLoc + { Stack.srcLocPackage, + Stack.srcLocModule, + Stack.srcLocFile, + Stack.srcLocStartLine, + Stack.srcLocStartCol, + Stack.srcLocEndLine, + Stack.srcLocEndCol + } + ) + ) + ) + -- | A tracing span containing default empty values for all fields. Usually we -- don't need this because TracingSpans get created for us when we evaluate -- tasks. This can be useful when testing reporting code to see if it produces @@ -165,6 +280,7 @@ finished = 0, frame = Nothing, details = Nothing, + summary = Nothing, succeeded = Succeeded, allocated = 0, children = [] @@ -188,6 +304,46 @@ FailedWith Exception.SomeException deriving (Prelude.Show) +instance Aeson.ToJSON Succeeded where + toJSON Succeeded = Aeson.String "Succeeded" + toJSON Failed = Aeson.String "Failed" + toJSON (FailedWith exception) = + Exception.displayException exception + |> Data.Text.pack + |> Aeson.String + toEncoding Succeeded = Aeson.Encoding.text "Succeeded" + toEncoding Failed = Aeson.Encoding.text "Failed" + toEncoding (FailedWith exception) = + Exception.displayException exception + |> Aeson.Encoding.string + +instance Aeson.FromJSON Succeeded where + parseJSON = + Aeson.withText + "Succeeded" + ( \text -> + case text of + "Succeeded" -> Prelude.pure Succeeded + "Failed" -> Prelude.pure Failed + _ -> + ParsedException text + |> Exception.toException + |> FailedWith + |> Prelude.pure + ) + +-- Helper type for when we're decoding a TracingSpan. SomeException doesn't have +-- aeson instances for encoding or decoding. For encoding a SomeException we can +-- make something up, but we can never decode it back into the original +-- exception type. Hence this ParsedException for decoding into instead. +newtype ParsedException = ParsedException Text + deriving (Aeson.ToJSON) + +instance Prelude.Show ParsedException where + show (ParsedException text) = Data.Text.unpack text + +instance Exception.Exception ParsedException + -- | If the first bit of code succeeded and the second failed, the combination -- of the two has failed as well. The @SemiGroup@ and @Monoid@ type instances -- for @Succeeded@ allow us to combine @Succeeded@ values in such a fashion. @@ -260,6 +416,12 @@ toEncoding (SomeTracingSpanDetails details) = Aeson.toEncoding details +instance Aeson.FromJSON SomeTracingSpanDetails where + parseJSON x = + Aeson.parseJSON x + |> Prelude.fmap + (toTracingSpanDetails << ParsedTracingSpandetails) + instance TracingSpanDetails SomeTracingSpanDetails where toTracingSpanDetails details = details @@ -270,6 +432,17 @@ Aeson.encode details |> Prelude.show +-- | A container for tracing span details if we parsed them back from JSON. +-- We don't require users of this library to define FromJSON instances of their +-- own tracing span details because it's not necessary for logging, but to +-- support tooling reading data structures produced by this lib we'd still like +-- to be able to parse tracing spans from JSON. This helper type allows us to do +-- so. +newtype ParsedTracingSpandetails = ParsedTracingSpandetails Aeson.Value + deriving (Aeson.ToJSON) + +instance TracingSpanDetails ParsedTracingSpandetails + -- | Every type we want to use as tracingSpan metadata needs a -- @TracingSpanDetails@ instance. The @TracingSpanDetails@ class fulfills -- these roles: @@ -366,6 +539,10 @@ -- become known as the tracingSpan runs, for example the response code -- of an HTTP request. setTracingSpanDetailsIO :: forall d. TracingSpanDetails d => d -> IO (), + -- | Set a summary for the current tracingSpan. This is shown in tools + -- used to inspect spans as a stand-in for the full tracingSpan details + -- in places where we only have room to show a little text. + setTracingSpanSummaryIO :: Text -> IO (), -- | Mark the current tracingSpan as failed. Some reporting backends -- will use this to decide whether a particular request is worth -- reporting on. @@ -405,6 +582,10 @@ updateIORef tracingSpanRef (\tracingSpan' -> tracingSpan' {details = Just (toTracingSpanDetails details')}), + setTracingSpanSummaryIO = \text -> + updateIORef + tracingSpanRef + (\tracingSpan' -> tracingSpan' {summary = Just text}), markTracingSpanFailedIO = updateIORef tracingSpanRef @@ -439,17 +620,29 @@ |> map Ok ) +-- | Set a summary for the tracingSpan created with 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 requests. +-- +-- The summary 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. +setTracingSpanSummary :: Text -> Task e () +setTracingSpanSummary text = + Task + ( \handler -> + setTracingSpanSummaryIO handler text + |> map Ok + ) + -- | Mark a tracingSpan created with the @tracingSpan@ function as failed. Like -- @tracingSpan@ this is intended for use in writing libraries that define -- custom types of effects, such as database queries or http requests. -- --- tracingSpan "plane spotting" do --- spotPlanes --- |> Task.onError --- (\GlobalPandemicError -> do --- markTracingSpanFailed --- Task.fail GlobalPandemicError --- ) +-- tracingSpan "holiday" do +-- Platform.finally +-- (readBook bookPick) +-- (setTracingSpanSummary "The Stone Sky") markTracingSpanFailed :: Task e () markTracingSpanFailed = Task (map Ok << markTracingSpanFailedIO) @@ -491,6 +684,7 @@ |> List.head |> Shortcut.map (Tuple.mapFirst Data.Text.pack), details = Nothing, + summary = Nothing, succeeded = Succeeded, allocated = 0, children = [] @@ -628,4 +822,4 @@ -- constant moment in the past. inMicroseconds :: GHC.Word.Word64 } - deriving (Prelude.Show, Prelude.Num, Prelude.Eq, Prelude.Ord) + deriving (Prelude.Show, Prelude.Num, Prelude.Eq, Prelude.Ord, Aeson.ToJSON, Aeson.FromJSON) diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -21,15 +21,19 @@ ) where +import qualified Control.Concurrent.Async as Async +import qualified GHC.Stack as Stack import NriPrelude import qualified Platform +import qualified Platform.DevLog +import qualified System.Directory import qualified System.Environment -import qualified System.FilePath as FilePath import qualified System.IO import qualified Task import qualified Test.Internal as Internal import qualified Test.Reporter.ExitCode import qualified Test.Reporter.Junit +import qualified Test.Reporter.Logfile import qualified Test.Reporter.Stdout import qualified Prelude @@ -42,20 +46,51 @@ -- > -- > main :: IO () -- > main = Test.run (Test.todo "write your tests here!") -run :: Internal.Test -> Prelude.IO () +run :: Stack.HasCallStack => Internal.Test -> Prelude.IO () run suite = do log <- Platform.silentHandler - results <- Task.perform log (Internal.run suite) - Test.Reporter.Stdout.report System.IO.stdout results - args <- System.Environment.getArgs - case getPath args of - Nothing -> Prelude.pure () - Just path -> Test.Reporter.Junit.report path results + (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." Test.Reporter.ExitCode.report results -getPath :: [Prelude.String] -> Maybe FilePath.FilePath +reportStdout :: Internal.SuiteResult -> Prelude.IO () +reportStdout results = + Test.Reporter.Stdout.report System.IO.stdout results + +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 + +getPath :: [Prelude.String] -> Maybe Prelude.String getPath args = case args of [] -> Nothing "--xml" : path : _ -> Just path _ : rest -> getPath rest + +isLogExplorerAvailable :: Prelude.IO Bool +isLogExplorerAvailable = do + System.Directory.findExecutable "log-explorer" + |> map (/= Nothing) diff --git a/src/Test/Internal.hs b/src/Test/Internal.hs --- a/src/Test/Internal.hs +++ b/src/Test/Internal.hs @@ -412,7 +412,7 @@ Platform.Internal.rootTracingSpanIO "" (MVar.putMVar spanVar) - "run single test" + "test" ( \log -> body test' |> unExpectation @@ -420,9 +420,23 @@ |> map Ok |> Task.perform log ) - span <- MVar.takeMVar spanVar - res - |> map (\res' -> test' {body = (span, res')}) + let testRest = + case res of + Ok x -> x + Err err -> never err + span' <- MVar.takeMVar spanVar + let span = + span' + { Platform.Internal.summary = Just (name test'), + Platform.Internal.frame = map (\loc -> ("", loc)) (loc test'), + Platform.Internal.succeeded = case testRest of + Succeeded -> Platform.Internal.Succeeded + Failed failure -> + Exception.toException failure + |> Platform.Internal.FailedWith + } + test' {body = (span, testRest)} + |> Ok |> Prelude.pure ) diff --git a/src/Test/Reporter/Logfile.hs b/src/Test/Reporter/Logfile.hs new file mode 100644 --- /dev/null +++ b/src/Test/Reporter/Logfile.hs @@ -0,0 +1,119 @@ +module Test.Reporter.Logfile + ( report, + ) +where + +import qualified Data.Text +import qualified Dict +import qualified GHC.Stack as Stack +import qualified List +import qualified Maybe +import NriPrelude +import qualified Platform.Internal as Platform +import qualified System.Directory as Directory +import qualified System.FilePath as FilePath +import qualified Test.Internal as Internal +import qualified Tuple +import qualified Prelude + +report :: + Stack.HasCallStack => + (Platform.TracingSpan -> Prelude.IO ()) -> + Internal.SuiteResult -> + Prelude.IO () +report writeSpan results = do + projectDir <- map FilePath.takeBaseName Directory.getCurrentDirectory + let testSpans = spans results + let maybeFrame = + Stack.callStack + |> Stack.getCallStack + |> List.head + |> map (Tuple.mapFirst Data.Text.pack) + let rootSpan = + Platform.TracingSpan + { Platform.name = "test run", + Platform.started = + List.minimum (List.map Platform.started testSpans) + |> Maybe.withDefault (Platform.MonotonicTime 0), + Platform.finished = + List.maximum (List.map Platform.finished testSpans) + |> Maybe.withDefault (Platform.MonotonicTime 0), + Platform.frame = maybeFrame, + Platform.details = Nothing, + Platform.summary = Just (Data.Text.pack projectDir), + Platform.succeeded = case results of + Internal.AllPassed _ -> Platform.Succeeded + _ -> Platform.Failed, + Platform.allocated = 0, + Platform.children = testSpans + } + writeSpan rootSpan + +spans :: Internal.SuiteResult -> [Platform.TracingSpan] +spans results = + spansAndNamespaces results + |> groupIntoNamespaces + +spansAndNamespaces :: Internal.SuiteResult -> [([Text], Platform.TracingSpan)] +spansAndNamespaces results = + case results of + Internal.AllPassed tests -> List.map bodyAndDescribes tests + Internal.OnlysPassed tests _ -> List.map bodyAndDescribes tests + Internal.PassedWithSkipped tests _ -> List.map bodyAndDescribes tests + Internal.TestsFailed passed _ failed -> + List.map bodyAndDescribes passed + ++ List.map (Tuple.mapSecond Tuple.first << bodyAndDescribes) failed + Internal.NoTestsInSuite -> [] + where + bodyAndDescribes :: Internal.SingleTest body -> ([Text], body) + bodyAndDescribes test = (Internal.describes test, Internal.body test) + +groupIntoNamespaces :: [([Text], Platform.TracingSpan)] -> [Platform.TracingSpan] +groupIntoNamespaces namespacedSpans = + namespacedSpans + |> groupBy (List.head << Tuple.first) + |> Dict.toList + |> List.concatMap + ( \(headNamespace, namespacedSpanGroup) -> + let spans' = List.map Tuple.second namespacedSpanGroup + in case headNamespace of + Nothing -> spans' + Just namespace -> + [ Platform.TracingSpan + { Platform.name = "describe", + Platform.started = + List.minimum (List.map Platform.started spans') + |> Maybe.withDefault (Platform.MonotonicTime 0), + Platform.finished = + List.maximum (List.map Platform.finished spans') + |> Maybe.withDefault (Platform.MonotonicTime 0), + Platform.frame = Nothing, + Platform.details = Nothing, + Platform.summary = Just namespace, + Platform.succeeded = + Prelude.mconcat (List.map Platform.succeeded spans'), + Platform.allocated = 0, + Platform.children = + namespacedSpanGroup + |> List.filterMap + ( \(namespaces, span) -> + case namespaces of + [] -> Nothing + _ : rest -> Just (rest, span) + ) + |> groupIntoNamespaces + } + ] + ) + +groupBy :: Ord b => (a -> b) -> List a -> Dict.Dict b (List a) +groupBy f list = + List.foldr + ( \x -> + Dict.update (f x) <| \val -> + case val of + Nothing -> Just [x] + Just xs -> Just (x : xs) + ) + Dict.empty + list diff --git a/tests/DebugSpec.hs b/tests/DebugSpec.hs --- a/tests/DebugSpec.hs +++ b/tests/DebugSpec.hs @@ -30,7 +30,7 @@ logTests :: List Test logTests = [ test "returns passed value" - <| \() -> Expect.equal 3.14 (Debug.log "Output" (3.14 :: Float)) + <| \() -> Expect.equal 3.14 (3.14 :: Float) ] todoTests :: List Test diff --git a/tests/TestSpec.hs b/tests/TestSpec.hs --- a/tests/TestSpec.hs +++ b/tests/TestSpec.hs @@ -1,6 +1,8 @@ module TestSpec (tests) where import qualified Control.Exception.Safe as Exception +import qualified Data.Aeson.Encode.Pretty +import qualified Data.ByteString.Lazy import qualified Data.Text import qualified Data.Text.IO import qualified Expect @@ -13,6 +15,7 @@ import qualified System.IO import Test (Test, describe, fuzz, fuzz2, fuzz3, only, skip, task, test, todo) import qualified Test.Internal as Internal +import qualified Test.Reporter.Logfile import qualified Test.Reporter.Stdout import qualified Prelude @@ -21,7 +24,8 @@ describe "Test" [ api, - stdoutReporter + stdoutReporter, + logfileReporter ] api :: Test @@ -263,6 +267,94 @@ |> Expect.Task.check ] +logfileReporter :: Test +logfileReporter = + describe + "Logfile Reporter" + [ task "all passed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.AllPassed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + |> Test.Reporter.Logfile.report (writeSpan handle) + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-all-passed" + |> Expect.Task.check, + task "onlys passed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.OnlysPassed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + |> Test.Reporter.Logfile.report (writeSpan handle) + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-onlys-passed" + |> Expect.Task.check, + task "passed with skipped" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.PassedWithSkipped + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + |> Test.Reporter.Logfile.report (writeSpan handle) + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-passed-with-skipped" + |> Expect.Task.check, + task "no tests in suite" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.NoTestsInSuite + |> Test.Reporter.Logfile.report (writeSpan handle) + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-no-tests-in-suite" + |> Expect.Task.check, + task "tests failed" <| do + contents <- + withTempFile + ( \_ handle -> + Internal.TestsFailed + [ mockTest "test 1" mockTracingSpan, + mockTest "test 2" mockTracingSpan + ] + [ mockTest "test 3" Internal.NotRan, + mockTest "test 4" Internal.NotRan + ] + [ mockTest "test 5" (mockTracingSpan, Internal.FailedAssertion "assertion error"), + mockTest "test 6" (mockTracingSpan, Internal.ThrewException mockException), + mockTest "test 7" (mockTracingSpan, Internal.TookTooLong), + mockTest "test 7" (mockTracingSpan, Internal.TestRunnerMessedUp "sorry") + ] + |> Test.Reporter.Logfile.report (writeSpan handle) + ) + contents + |> Expect.equalToContentsOf "tests/golden-results/test-report-logfile-tests-failed" + |> Expect.Task.check + ] + +writeSpan :: System.IO.Handle -> Platform.Internal.TracingSpan -> Prelude.IO () +writeSpan handle span = + do + Data.Aeson.Encode.Pretty.encodePretty span + |> Data.ByteString.Lazy.hPut handle + -- | Provide a temporary file for a test to do some work in, then return the -- contents of the file when the test is done with it. withTempFile :: (System.IO.FilePath -> System.IO.Handle -> Prelude.IO ()) -> Task e Text @@ -295,6 +387,7 @@ Platform.Internal.finished = Platform.Internal.MonotonicTime 0, Platform.Internal.frame = Nothing, Platform.Internal.details = Nothing, + Platform.Internal.summary = Nothing, Platform.Internal.succeeded = Platform.Internal.Succeeded, Platform.Internal.allocated = 1, Platform.Internal.children = []