sandwich (empty) → 0.1.0.0

raw patch · 69 files changed

+6846/−0 lines, 69 filesdep +aesondep +ansi-terminaldep +asyncsetup-changed

Dependencies added: aeson, ansi-terminal, async, base, brick, bytestring, colour, containers, directory, exceptions, filepath, free, haskell-src-exts, lens, lifted-async, microlens, microlens-th, monad-control, monad-logger, mtl, optparse-applicative, pretty-show, process, safe, safe-exceptions, sandwich, stm, string-interpolate, template-haskell, text, time, transformers, transformers-base, unix, unliftio-core, vector, vty

Files

• ChangeLog.md +3/−0
• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• app/Main.hs +221/−0
• discover/Main.hs +61/−0
• sandwich.cabal +327/−0
• src/Test/Sandwich.hs +224/−0
• src/Test/Sandwich/ArgParsing.hs +159/−0
• src/Test/Sandwich/Contexts.hs +34/−0
• src/Test/Sandwich/Expectations.hs +112/−0
• src/Test/Sandwich/Formatters/Common/Count.hs +45/−0
• src/Test/Sandwich/Formatters/Common/Util.hs +36/−0
• src/Test/Sandwich/Formatters/FailureReport.hs +107/−0
• src/Test/Sandwich/Formatters/LogSaver.hs +87/−0
• src/Test/Sandwich/Formatters/Print.hs +115/−0
• src/Test/Sandwich/Formatters/Print/CallStacks.hs +35/−0
• src/Test/Sandwich/Formatters/Print/Color.hs +49/−0
• src/Test/Sandwich/Formatters/Print/Common.hs +32/−0
• src/Test/Sandwich/Formatters/Print/FailureReason.hs +73/−0
• src/Test/Sandwich/Formatters/Print/Logs.hs +70/−0
• src/Test/Sandwich/Formatters/Print/PrintPretty.hs +86/−0
• src/Test/Sandwich/Formatters/Print/Printing.hs +42/−0
• src/Test/Sandwich/Formatters/Print/Types.hs +21/−0
• src/Test/Sandwich/Formatters/Print/Util.hs +37/−0
• src/Test/Sandwich/Formatters/TerminalUI.hs +392/−0
• src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +201/−0
• src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +12/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +154/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +104/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +171/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +181/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +35/−0
• src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +94/−0
• src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +56/−0
• src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs +48/−0
• src/Test/Sandwich/Formatters/TerminalUI/Types.hs +120/−0
• src/Test/Sandwich/Internal.hs +33/−0
• src/Test/Sandwich/Internal/Formatters.hs +8/−0
• src/Test/Sandwich/Internal/Running.hs +188/−0
• src/Test/Sandwich/Interpreters/FilterTree.hs +38/−0
• src/Test/Sandwich/Interpreters/FilterTreeModule.hs +40/−0
• src/Test/Sandwich/Interpreters/PrettyShow.hs +35/−0
• src/Test/Sandwich/Interpreters/RunTree.hs +135/−0
• src/Test/Sandwich/Interpreters/RunTree/Logging.hs +39/−0
• src/Test/Sandwich/Interpreters/RunTree/Util.hs +101/−0
• src/Test/Sandwich/Interpreters/StartTree.hs +323/−0
• src/Test/Sandwich/Logging.hs +98/−0
• src/Test/Sandwich/Misc.hs +51/−0
• src/Test/Sandwich/Nodes.hs +29/−0
• src/Test/Sandwich/Options.hs +48/−0
• src/Test/Sandwich/RunTree.hs +144/−0
• src/Test/Sandwich/Shutdown.hs +15/−0
• src/Test/Sandwich/TH.hs +146/−0
• src/Test/Sandwich/TH/HasMainFunction.hs +62/−0
• src/Test/Sandwich/TH/ModuleMap.hs +50/−0
• src/Test/Sandwich/TestTimer.hs +127/−0
• src/Test/Sandwich/Types/ArgParsing.hs +99/−0
• src/Test/Sandwich/Types/General.hs +5/−0
• src/Test/Sandwich/Types/RunTree.hs +253/−0
• src/Test/Sandwich/Types/Spec.hs +697/−0
• src/Test/Sandwich/Types/TestTimer.hs +139/−0
• src/Test/Sandwich/Util.hs +13/−0
• test/Around.hs +53/−0
• test/Before.hs +48/−0
• test/Describe.hs +39/−0
• test/Introduce.hs +88/−0
• test/Main.hs +18/−0
• test/TestUtil.hs +107/−0

@@ -0,0 +1,3 @@+# Changelog for sandwich++## Unreleased changes

@@ -0,0 +1,30 @@+Copyright Tom McLaughlin (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Tom McLaughlin nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# sandwich

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,221 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}++module Main where++import Control.Concurrent+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger (LogLevel(..))+import Data.String.Interpolate+import Data.Time.Clock+import Test.Sandwich+import Test.Sandwich.Formatters.FailureReport+import Test.Sandwich.Formatters.LogSaver+import Test.Sandwich.Formatters.Print+import Test.Sandwich.Formatters.TerminalUI++data Database = Database String+  deriving Show++data Foo = Foo { fooInt :: Int, fooString :: String, fooBar :: Bar } deriving (Show, Eq)+data Bar = Bar { barInt :: Int, barString :: String } deriving (Show, Eq)+data Baz = Baz Int String Bar deriving (Show, Eq)+data Simple = Simple { simpleInt :: Int } deriving (Show, Eq)++database = Label :: Label "database" Database+otherDatabase = Label :: Label "otherDatabase" Database++documentation :: TopSpec+documentation = describe "arithmetic" $ do+  it "tests addition" $ do+    (2 + 2) `shouldBe` 4++  it "tests subtraction" $ do+    warn "Having some trouble getting this test to pass..."+    (2 - 2) `shouldBe` 1++++verySimple :: TopSpec+verySimple = do+  it "succeeds" (return ())+  it "tries shouldBe" (2 `shouldBe` 3)+  it "tries shouldBe with Foo" (Foo 2 "asdf" (Bar 2 "asdf") `shouldBe` Foo 3 "fdsa" (Bar 3 "fdsa"))+  it "tries shouldBe with Baz" (Baz 2 "asdf" (Bar 2 "asdf") `shouldBe` Baz 3 "fdsa" (Bar 3 "fdsa"))+  it "tries shouldBe with list" ([1, 2, 3] `shouldBe` [4, 5, 6])+  it "tries shouldBe with tuple" ((1, 2, 3) `shouldBe` (4, 5, 6))+  it "tries shouldBe with list of constructors" ([Simple 1, Simple 2] `shouldBe` [Simple 3, Simple 4])+  it "tries shouldNotBe" (2 `shouldNotBe` 2)+  it "is pending" $ pending+  it "is pending with message" $ pendingWith "Not implemented yet..."+  it "throws an exception" $ do+    2 `shouldBe` 2+    throwIO $ userError "Want a stacktrace here"+    -- 3 `shouldBe` 4+    3 `shouldBe` 3+  it "does some logging" $ do+    debug "debug message"+    info "info message"+    warn "warn message"+    logError "error message"++cancelling :: TopSpec+cancelling = do+  before "succeeds" (debug "before called") $ do+    it "sleeps forever" $ do+      forever $ liftIO $ threadDelay 1+    it "succeeds after 1 second" $ do+      liftIO $ threadDelay 1000000+      return ()++cancellingIntroduce :: TopSpec+cancellingIntroduce = do+  introduce "alloc sleeps forever" database ((forever $ liftIO $ threadDelay 1000000) >> return (Database "foo")) (const $ return ()) $ do+    it "sleeps forever" $ do+      forever $ liftIO $ threadDelay 1+    it "succeeds after 1 second" $ do+      liftIO $ threadDelay 1000000+      return ()++manyRows :: TopSpec+manyRows = do+  forM_ [(0 :: Int)..100] $ \n ->+    it [i|does the thing #{n}|] (2 `shouldBe` 2)++simple :: TopSpec+simple = do+  it "does the thing 1" sleepThenSucceed+  it "does the thing 2" sleepThenSucceed+  it "does the thing 3" sleepThenFail+  describe "should happen sequentially" $ do+    it "sequential 1" sleepThenSucceed+    it "sequential 2" sleepThenFail+    it "sequential 3" sleepThenSucceed+  it "does the thing 4" sleepThenFail+  it "does the thing 5" sleepThenSucceed+  it "does the thing 6" sleepThenSucceed++medium :: TopSpec+medium = do+  it "does the first thing" sleepThenSucceed+  it "does the 1.5 thing" sleepThenFail+  it "does the 1.8 thing" sleepThenFail++  describe "should happen sequentially" $ do+    it "sequential 1" sleepThenSucceed+    it "sequential 2" sleepThenFail+    it "sequential 3" sleepThenSucceed++  describe "should happen in parallel" $ parallel $ do+    it "sequential 1" sleepThenSucceed+    it "sequential 2" sleepThenSucceed+    it "sequential 3" sleepThenSucceed++  around "some around" (\action -> debug "around1" >> action >> debug "around2") $ do+    it "does 1" sleepThenSucceed -- pending+    it "does 2" sleepThenSucceed -- pending++  introduceWith "Database around" database (\action -> void $ action (Database "foo")) $ do+    it "uses the DB" $ do+      db <- getContext database+      debug [i|Got db: #{db}|]+      liftIO $ threadDelay (3 * 10^6)++  introduce "Database" database (debug "making DB" >> (return $ Database "outer")) (const $ return ()) $ do+    it "uses the DB 1" $ do+      db <- getContext database+      debug [i|Got db: #{db}|]++    introduce "Database again" database (return $ Database "shadowing") (const $ return ()) $ do+      introduce "Database again" otherDatabase (return $ Database "other") (const $ return ()) $ do+        it "uses the DB 2" $ do+          db <- getContext database+          debug [i|Got db: #{db}|]+          otherDb <- getContext otherDatabase+          debug [i|Got otherDb: #{otherDb}|]++    it "does a thing sequentially" $ sleepThenFail+    it "does a thing sequentially 2" $ sleepThenSucceed+    it "does a thing sequentially 3" $ sleepThenSucceed+    it "does a thing sequentially 4" $ sleepThenSucceed++  afterEach "after each" (return ()) $ do+    beforeEach "before each" (return ()) $ do+      it "does the first thing" sleepThenSucceed+      it "does the second thing" sleepThenSucceed+      it "does the third thing" sleepThenSucceed+      describe "nested stuff" $ do+        it "does a nested thing" sleepThenSucceed++  it "does foo" sleepThenFail+  it "does bar" sleepThenSucceed++  after "after" (debug "doing after") $ do+    it "has a thing after it" $ sleepThenSucceed++introduceFailure :: TopSpec+introduceFailure = do+  introduceWith "Database around" database (\action -> liftIO $ throwIO $ userError "Failed to get DB") $ do+    introduce "Database" database (debug "making DB" >> (return $ Database "outer")) (const $ return ()) $ do+      it "uses the DB 1" $ do+        db <- getContext database+        debug [i|Got db: #{db}|]++introduceWithInterrupt :: TopSpec+introduceWithInterrupt = do+  introduceWith "Database around" database (\action -> liftIO $ threadDelay 999999999999999) $ do+    it "uses the DB 1" $ do+      db <- getContext database+      debug [i|Got db: #{db}|]++beforeExceptionSafetyNested :: TopSpec+beforeExceptionSafetyNested = before "before label" (liftIO $ throwIO $ userError "OH NO") $ do+  it "does thing 1" $ return ()+  it "does thing 2" $ return ()+  describe "nested things" $ do+    it "does nested thing 1" $ return ()+    it "does nested thing 2" $ return ()++longLogs :: TopSpec+longLogs = do+  it "does thing 1" $+    shouldFail (2 `shouldBe` 3)+  it "does thing 2" $+    shouldFailPredicate (\case+                            Reason {} -> True+                            _ -> False) (2 `shouldBe` 3)+  it "does thing 3" $ do+    forM_ [(0 :: Int)..200] $ \n -> debug [i|Log entry #{n}|]+  it "does thing 4" $ return ()+  it "does thing 5" $ return ()++main :: IO ()+main = runSandwichWithCommandLineArgs options documentation+  where+    options = defaultOptions {+      optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+      , optionsFormatters = [SomeFormatter defaultLogSaverFormatter, SomeFormatter defaultFailureReportFormatter]+      , optionsProjectRoot = Just "sandwich"+      }+++-- * Util++sleepThenSucceed :: ExampleM context ()+sleepThenSucceed = do+  liftIO $ threadDelay (2 * 10^1)+  -- liftIO $ threadDelay (2 * 10^5)+  -- liftIO $ threadDelay (1 * 10^6)++sleepThenFail :: ExampleM context ()+sleepThenFail = do+  liftIO $ threadDelay (2 * 10^1)+  -- liftIO $ threadDelay (2 * 10^5)+  -- liftIO $ threadDelay (1 * 10^6)+  2 `shouldBe` 3

@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Exception+import Data.Function+import qualified Data.List as L+import qualified Data.Map as M+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import System.Directory+import System.Environment+import System.FilePath+import Test.Sandwich.TH+++data SandwichDiscoverOptions = SandwichDiscoverOptions {+  sandwichDiscoverModulePrefix :: String -- TODO: don't use this, instead detect the module some other way (haskell-src-exts? fancy regex?)+  }++defaultSandwichDiscoverOptions :: SandwichDiscoverOptions+defaultSandwichDiscoverOptions = SandwichDiscoverOptions {+  sandwichDiscoverModulePrefix = ""+  }++tryParseArg :: SandwichDiscoverOptions -> String -> SandwichDiscoverOptions+tryParseArg options x+  | ("--module-prefix=" `L.isPrefixOf` x) = options { sandwichDiscoverModulePrefix = L.drop (L.length ("--module-prefix=" :: String)) x }+  | otherwise = options++main :: IO ()+main = do+  (originalFileName, inputFileName, outputFileName, SandwichDiscoverOptions {..}) <- getArgs >>= \case+    (w:x:y:remainingArgs) -> do+      let sandwichDiscoverOptions = L.foldl' tryParseArg defaultSandwichDiscoverOptions remainingArgs+      return (w, x, y, sandwichDiscoverOptions)+    xs -> throwIO $ userError ([i|sandwich-discover: expected 3+ args but got '#{xs}'|])++  let baseDir' = dropExtension originalFileName+  doesDirectoryExist baseDir' >>= \case+    False -> throwIO $ userError ([i|sandwich-discover: expected directory to exist (#{baseDir'})|])+    True -> return ()+  baseDir <- canonicalizePath baseDir'++  -- Build a map from imported name (possibly dedupped by adding numbers) to full module name+  moduleMap <- buildModuleMap baseDir sandwichDiscoverModulePrefix++  let testImports = [[i|import qualified #{y} as #{x}|] | (x, y) <- M.toList moduleMap]+  let testImportsList = [[i|#{x}.tests|] | (x, _) <- M.toList moduleMap]++  contents <- T.readFile inputFileName+  let finalContents = contents+        & T.replace "#insert_test_imports" (T.unlines testImports)+        & T.replace "#test_imports_list" ("[" <> T.intercalate ", " testImportsList <> "]")++  T.writeFile outputFileName finalContents

@@ -0,0 +1,327 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 78968b6d4bdd1e6b70424abcc479acf0dc1dc5a0a48d56bb86e2abf685e19fa5++name:           sandwich+version:        0.1.0.0+description:    Please see the README on GitHub at <https://github.com/githubuser/sandwich#readme>+homepage:       https://github.com/codedownio/sandwich#readme+bug-reports:    https://github.com/codedownio/sandwich/issues+author:         Tom McLaughlin+maintainer:     tom@codedown.io+copyright:      2021 Tom McLaughlin+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/codedownio/sandwich++library+  exposed-modules:+      Test.Sandwich+      Test.Sandwich.Contexts+      Test.Sandwich.Expectations+      Test.Sandwich.Logging+      Test.Sandwich.Misc+      Test.Sandwich.Nodes+      Test.Sandwich.Options+      Test.Sandwich.Formatters.FailureReport+      Test.Sandwich.Formatters.LogSaver+      Test.Sandwich.Formatters.Print+      Test.Sandwich.Formatters.TerminalUI+      Test.Sandwich.Internal+      Test.Sandwich.Internal.Formatters+      Test.Sandwich.Internal.Running+      Test.Sandwich.TH+  other-modules:+      Test.Sandwich.ArgParsing+      Test.Sandwich.Formatters.Common.Count+      Test.Sandwich.Formatters.Common.Util+      Test.Sandwich.Formatters.Print.CallStacks+      Test.Sandwich.Formatters.Print.Color+      Test.Sandwich.Formatters.Print.Common+      Test.Sandwich.Formatters.Print.FailureReason+      Test.Sandwich.Formatters.Print.Logs+      Test.Sandwich.Formatters.Print.Printing+      Test.Sandwich.Formatters.Print.PrintPretty+      Test.Sandwich.Formatters.Print.Types+      Test.Sandwich.Formatters.Print.Util+      Test.Sandwich.Formatters.TerminalUI.AttrMap+      Test.Sandwich.Formatters.TerminalUI.CrossPlatform+      Test.Sandwich.Formatters.TerminalUI.Draw+      Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar+      Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget+      Test.Sandwich.Formatters.TerminalUI.Draw.TopBox+      Test.Sandwich.Formatters.TerminalUI.Draw.Util+      Test.Sandwich.Formatters.TerminalUI.Filter+      Test.Sandwich.Formatters.TerminalUI.Keys+      Test.Sandwich.Formatters.TerminalUI.OpenInEditor+      Test.Sandwich.Formatters.TerminalUI.Types+      Test.Sandwich.Interpreters.FilterTree+      Test.Sandwich.Interpreters.FilterTreeModule+      Test.Sandwich.Interpreters.PrettyShow+      Test.Sandwich.Interpreters.RunTree+      Test.Sandwich.Interpreters.RunTree.Logging+      Test.Sandwich.Interpreters.RunTree.Util+      Test.Sandwich.Interpreters.StartTree+      Test.Sandwich.RunTree+      Test.Sandwich.Shutdown+      Test.Sandwich.TestTimer+      Test.Sandwich.TH.HasMainFunction+      Test.Sandwich.TH.ModuleMap+      Test.Sandwich.Types.ArgParsing+      Test.Sandwich.Types.General+      Test.Sandwich.Types.RunTree+      Test.Sandwich.Types.Spec+      Test.Sandwich.Types.TestTimer+      Test.Sandwich.Util+      Paths_sandwich+  hs-source-dirs:+      src+  ghc-options: -W+  build-depends:+      aeson+    , ansi-terminal+    , async+    , base <=4.14+    , brick+    , bytestring+    , colour+    , containers+    , directory+    , exceptions+    , filepath+    , free+    , haskell-src-exts+    , lens+    , lifted-async+    , microlens+    , microlens-th+    , monad-control+    , monad-logger+    , mtl+    , optparse-applicative+    , pretty-show+    , process+    , safe+    , safe-exceptions+    , stm+    , string-interpolate+    , template-haskell+    , text+    , time+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , vector+    , vty+  default-language: Haskell2010++executable sandwich-discover+  main-is: Main.hs+  other-modules:+      Paths_sandwich+  hs-source-dirs:+      discover+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , ansi-terminal+    , async+    , base <=4.14+    , brick+    , bytestring+    , colour+    , containers+    , directory+    , exceptions+    , filepath+    , free+    , haskell-src-exts+    , lens+    , lifted-async+    , microlens+    , microlens-th+    , monad-control+    , monad-logger+    , mtl+    , optparse-applicative+    , pretty-show+    , process+    , safe+    , safe-exceptions+    , sandwich+    , stm+    , string-interpolate+    , template-haskell+    , text+    , time+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , vector+    , vty+  default-language: Haskell2010++executable sandwich-exe+  main-is: Main.hs+  other-modules:+      Paths_sandwich+  hs-source-dirs:+      app+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , ansi-terminal+    , async+    , base <=4.14+    , brick+    , bytestring+    , colour+    , containers+    , directory+    , exceptions+    , filepath+    , free+    , haskell-src-exts+    , lens+    , lifted-async+    , microlens+    , microlens-th+    , monad-control+    , monad-logger+    , mtl+    , optparse-applicative+    , pretty-show+    , process+    , safe+    , safe-exceptions+    , sandwich+    , stm+    , string-interpolate+    , template-haskell+    , text+    , time+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , vector+    , vty+  default-language: Haskell2010++executable sandwich-test+  main-is: Main.hs+  other-modules:+      Around+      Before+      Describe+      Introduce+      TestUtil+      Paths_sandwich+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , ansi-terminal+    , async+    , base <=4.14+    , brick+    , bytestring+    , colour+    , containers+    , directory+    , exceptions+    , filepath+    , free+    , haskell-src-exts+    , lens+    , lifted-async+    , microlens+    , microlens-th+    , monad-control+    , monad-logger+    , mtl+    , optparse-applicative+    , pretty-show+    , process+    , safe+    , safe-exceptions+    , sandwich+    , stm+    , string-interpolate+    , template-haskell+    , text+    , time+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , vector+    , vty+  default-language: Haskell2010++test-suite sandwich-test-suite+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Around+      Before+      Describe+      Introduce+      TestUtil+      Paths_sandwich+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , ansi-terminal+    , async+    , base <=4.14+    , brick+    , bytestring+    , colour+    , containers+    , directory+    , exceptions+    , filepath+    , free+    , haskell-src-exts+    , lens+    , lifted-async+    , microlens+    , microlens-th+    , monad-control+    , monad-logger+    , mtl+    , optparse-applicative+    , pretty-show+    , process+    , safe+    , safe-exceptions+    , sandwich+    , stm+    , string-interpolate+    , template-haskell+    , text+    , time+    , transformers+    , transformers-base+    , unix+    , unliftio-core+    , vector+    , vty+  default-language: Haskell2010

@@ -0,0 +1,224 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleContexts #-}++module Test.Sandwich (+  -- | Sandwich is a test framework for Haskell. See the <https://codedownio.github.io/sandwich/docs/ documentation> for details and usage examples.++  -- * Running tests with command line args+  --+  -- | These functions will read command line arguments when setting up your tests.+  -- These flags allow you filter the test tree, configure formatters, and pass your own custom options.+  --+  -- @+  -- # Run using the terminal UI formatter, webdriver headless mode, filtering to nodes matching \"Login\"+  -- stack run my-tests -- --tui --headless -f Login+  -- @+  --+  runSandwichWithCommandLineArgs+  , runSandwichWithCommandLineArgs'++  -- * Running tests+  , runSandwich+  , runSandwich'++  -- * Basic nodes+  --+  -- | The basic building blocks of tests.+  , it+  , describe+  , parallel++  -- * Context manager nodes+  --+  -- | For introducing new contexts into tests and doing setup/teardown.+  , introduce+  , introduceWith+  , before+  , beforeEach+  , after+  , afterEach+  , around+  , aroundEach++  -- * Timing+  --+  -- | For timing actions within your tests. Test tree nodes are timed by default.+  , timeActionByProfile+  , timeAction+  , withTimingProfile+  , withTimingProfile'++  -- * Exports+  , module Test.Sandwich.Contexts+  , module Test.Sandwich.Expectations+  , module Test.Sandwich.Logging+  , module Test.Sandwich.Misc+  , module Test.Sandwich.Nodes+  , module Test.Sandwich.Options+  , module Test.Sandwich.TH+  ) where++import Control.Concurrent.Async+import Control.Concurrent.STM+import qualified Control.Exception as E+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Either+import Data.Function+import Data.IORef+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import Options.Applicative+import qualified Options.Applicative as OA+import System.Environment+import System.FilePath+import System.Posix.Signals+import Test.Sandwich.ArgParsing+import Test.Sandwich.Contexts+import Test.Sandwich.Expectations+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Internal.Running+import Test.Sandwich.Interpreters.FilterTreeModule+import Test.Sandwich.Interpreters.RunTree+import Test.Sandwich.Logging+import Test.Sandwich.Misc+import Test.Sandwich.Nodes+import Test.Sandwich.Options+import Test.Sandwich.RunTree+import Test.Sandwich.Shutdown+import Test.Sandwich.TH+import Test.Sandwich.TestTimer+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer+++-- | Run the spec with the given 'Options'.+runSandwich :: Options -> CoreSpec -> IO ()+runSandwich options spec = void $ runSandwich' Nothing options spec++-- | Run the spec, configuring the options from the command line.+runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()+runSandwichWithCommandLineArgs baseOptions = runSandwichWithCommandLineArgs' baseOptions (pure ())++-- | Run the spec, configuring the options from the command line and adding user-configured command line options.+-- The options will become available as a test context, which you can access by calling 'getCommandLineOptions'.+runSandwichWithCommandLineArgs' :: forall a. (Typeable a) => Options -> Parser a -> TopSpecWithOptions' a -> IO ()+runSandwichWithCommandLineArgs' baseOptions userOptionsParser spec = do+  let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())+                           & L.sortOn nodeModuleInfoModuleName+                           & gatherShorthands+  let individualTestFlags maybeInternal =+        [[ Just $ flag' (Just $ IndividualTestModuleName nodeModuleInfoModuleName)+                        (long (T.unpack shorthand)+                          <> help (nodeModuleInfoModuleName+                          <> (if isJust nodeModuleInfoFn then "*" else ""))+                          <> maybeInternal)+         , case nodeModuleInfoFn of+             Nothing -> Nothing+             Just fn -> Just $ flag' (Just $ IndividualTestMainFn fn)+                                     (long (T.unpack (shorthand <> "-main"))+                                       <> help nodeModuleInfoModuleName+                                       <> internal+                                     )+         ]+        | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]+  let individualTestParser maybeInternal = foldr (<|>) (pure Nothing) (catMaybes $ mconcat $ individualTestFlags maybeInternal)++  clo <- OA.execParser (commandLineOptionsWithInfo userOptionsParser (individualTestParser internal))+  (options, repeatCount) <- liftIO $ addOptionsFromArgs baseOptions clo++  if | optPrintSlackFlags clo == Just True -> do+         void $ withArgs ["--help"] $+           OA.execParser slackOptionsWithInfo+     | optPrintWebDriverFlags clo == Just True -> do+         void $ withArgs ["--help"] $+           OA.execParser webDriverOptionsWithInfo+     | optListAvailableTests clo == Just True -> do+         void $ withArgs ["--help"] $+           OA.execParser $ OA.info (individualTestParser mempty <**> helper) $+             fullDesc <> header "Pass one of these flags to run an individual test module."+                      <> progDesc "If a module has a \"*\" next to its name, then we detected that it has its own main function. If you pass the option name suffixed by -main then we'll just directly invoke the main function."+     | otherwise ->+         runWithRepeat repeatCount $+           case optIndividualTestModule clo of+             Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $+               introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec+             Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $+               introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec+             Just (IndividualTestMainFn x) -> do+               let individualTestFlagStrings = [[ Just ("--" <> shorthand), const ("--" <> shorthand <> "-main") <$> nodeModuleInfoFn ]+                                               | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]+                                             & mconcat+                                             & catMaybes+               baseArgs <- getArgs+               withArgs (baseArgs L.\\ (fmap T.unpack individualTestFlagStrings)) $+                 tryAny x >>= \case+                   Left _ -> return (NormalExit, 1)+                   Right _ -> return (NormalExit, 0)++-- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason and number of failures.+runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int)+runSandwich' maybeCommandLineOptions options spec' = do+  baseContext <- baseContextFromOptions options++  -- Wrap the spec in a finalizer for the test timer, when one is present+  let spec = case baseContextTestTimer baseContext of+        NullTestTimer -> spec'+        _ -> after' (defaultNodeOptions { nodeOptionsRecordTime = False+                                        , nodeOptionsVisibilityThreshold = systemVisibilityThreshold+                                        , nodeOptionsCreateFolder = False }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec'++  rts <- startSandwichTree' baseContext options spec++  formatterAsyncs <- forM (optionsFormatters options) $ \(SomeFormatter f) -> async $ do+    let loggingFn = case baseContextRunRoot baseContext of+          Nothing -> flip runLoggingT (\_ _ _ _ -> return ())+          Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")++    loggingFn $+      runFormatter f rts maybeCommandLineOptions baseContext++  exitReasonRef <- newIORef NormalExit++  let shutdown = do+        putStrLn "Shutting down..."+        writeIORef exitReasonRef InterruptExit+        forM_ rts cancelNode++  _ <- installHandler sigINT (Catch shutdown) Nothing++  -- Wait for all formatters to finish+  finalResults :: [Either E.SomeException ()] <- forM formatterAsyncs $ E.try . wait+  let failures = lefts finalResults+  unless (null failures) $+    putStrLn [i|Some formatters failed: '#{failures}'|]++  -- Run finalizeFormatter method on formatters+  forM_ (optionsFormatters options) $ \(SomeFormatter f) -> do+    let loggingFn = case baseContextRunRoot baseContext of+          Nothing -> flip runLoggingT (\_ _ _ _ -> return ())+          Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")++    loggingFn $ finalizeFormatter f rts baseContext++  fixedTree <- atomically $ mapM fixRunTree rts+  let failed = countWhere isFailedItBlock fixedTree+  exitReason <- readIORef exitReasonRef+  return (exitReason, failed)

@@ -0,0 +1,159 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Sandwich.ArgParsing where++import Control.Monad.Logger+import Data.Function+import Data.Maybe+import qualified Data.Text as T+import Data.Time.Clock.POSIX+import Data.Typeable+import Options.Applicative+import qualified Options.Applicative as OA+import System.IO+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.TerminalUI+import Test.Sandwich.Options+import Test.Sandwich.Types.ArgParsing++#if MIN_VERSION_time(1,9,0)+import Data.Time.Format.ISO8601+formatTime = T.unpack . T.replace ":" "_" . T.pack . iso8601Show+#else+formatTime = show+#endif+++commandLineOptionsWithInfo :: Parser a -> Parser (Maybe IndividualTestModule) -> ParserInfo (CommandLineOptions a)+commandLineOptionsWithInfo userOptionsParser individualTestParser = OA.info (mainCommandLineOptions userOptionsParser individualTestParser <**> helper)+  (+    fullDesc+    <> progDesc "Run tests with Sandwich"+    <> header "Sandwich test runner"+  )++slackOptionsWithInfo :: ParserInfo CommandLineSlackOptions+slackOptionsWithInfo = OA.info (commandLineSlackOptions mempty <**> helper)+  (+    briefDesc+    <> header "Special options passed to the Slack formatter.\n\nIf a flag is passed, it will override the value in the SlackFormatter configured in the code."+  )++webDriverOptionsWithInfo :: ParserInfo CommandLineWebdriverOptions+webDriverOptionsWithInfo = OA.info (commandLineWebdriverOptions mempty <**> helper)+  (+    fullDesc+    <> progDesc "Special options passed to the WebDriver formatter, if present.\n\nIf a flag is passed, it will override the value in the WdOptions configured in the code."+    <> header "WebDriver flags"+  )++mainCommandLineOptions :: Parser a -> Parser (Maybe IndividualTestModule) -> Parser (CommandLineOptions a)+mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptions+  -- sandwich+  <$> formatter+  <*> logLevel+  <*> optional (strOption (long "filter" <> short 'f' <> help "Filter test tree by string matching text example labels" <> metavar "STRING"))+  <*> option auto (long "repeat" <> short 'r' <> showDefault <> help "Repeat the test N times and report how many failures occur" <> value 1 <> metavar "INT")+  <*> optional (strOption (long "fixed-root" <> help "Store test artifacts at a fixed path" <> metavar "STRING"))++  <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))+  <*> optional (flag False True (long "print-slack-flags" <> help "Print the additional Slack flags"))+  <*> optional (flag False True (long "print-webdriver-flags" <> help "Print the additional Slack flags"))++  <*> individualTestParser++  <*> commandLineWebdriverOptions internal+  <*> commandLineSlackOptions internal++  <*> userOptionsParser++formatter :: Parser FormatterType+formatter =+  flag' Print (long "print" <> help "Print to stdout")+  <|> flag' TUI (long "tui" <> help "Open terminal UI app")+  <|> flag' Silent (long "silent" <> help "Run silently (no main formatter)")+  <|> flag Auto Auto (long "auto" <> help "Automatically decide which formatter to use")++logLevel :: Parser (Maybe LogLevel)+logLevel =+  flag' (Just LevelDebug) (long "debug" <> help "Log level DEBUG")+  <|> flag' (Just LevelInfo) (long "info" <> help "Log level INFO")+  <|> flag' (Just LevelWarn) (long "warn" <> help "Log level WARN")+  <|> flag (Just LevelWarn) (Just LevelError) (long "error" <> help "Log level ERROR")++commandLineWebdriverOptions :: (forall f a. Mod f a) -> Parser CommandLineWebdriverOptions+commandLineWebdriverOptions maybeInternal = CommandLineWebdriverOptions+  <$> optional (browserToUse maybeInternal)+  <*> optional (display maybeInternal)+  <*> flag False True (long "fluxbox" <> help "Launch fluxbox as window manager when using Xvfb" <> maybeInternal)+  <*> flag False True (long "individual-videos" <> help "Record individual videos of each test (requires ffmpeg and Xvfb)" <> maybeInternal)+  <*> flag False True (long "error-videos" <> help "Record videos of each test but delete them unless there was an exception" <> maybeInternal)++browserToUse :: (forall f a. Mod f a) -> Parser BrowserToUse+browserToUse maybeInternal =+  flag' UseFirefox (long "firefox" <> help "Use Firefox" <> maybeInternal)+  <|> flag UseChrome UseChrome (long "chrome" <> help "Use Chrome (default)" <> maybeInternal)++display :: (forall f a. Mod f a) -> Parser DisplayType+display maybeInternal =+  flag' Current (long "current" <> help "Open browser in current display (default)" <> maybeInternal)+  <|> flag' Headless (long "headless" <> help "Open browser in headless mode" <> maybeInternal)+  <|> flag Current Xvfb (long "xvfb" <> help "Open browser in Xvfb session" <> maybeInternal)++commandLineSlackOptions :: (forall f a. Mod f a) -> Parser CommandLineSlackOptions+commandLineSlackOptions maybeInternal = CommandLineSlackOptions+  <$> optional (strOption (long "slack-token" <> help "Slack token to use with the Slack formatter" <> metavar "STRING" <> maybeInternal))+  <*> optional (strOption (long "slack-channel" <> help "Slack channel to use with the Slack formatter" <> metavar "STRING" <> maybeInternal))++  <*> optional (strOption (long "slack-top-message" <> help "Top message to display on Slack progress bars" <> metavar "STRING" <> maybeInternal))++  <*> optional (option auto (long "slack-max-failures" <> help "Maximum number of failures to include in a message" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "slack-max-failure-reason-lines" <> help "Maximum number of lines for the failure reason underneath a failure" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "slack-max-callstack-lines" <> help "Maximum number of lines for the callstack reason underneath a failure" <> metavar "INT" <> maybeInternal))++  <*> optional (option auto (long "slack-visibility-threshold" <> help "Filter the headings on failures by visibility threshold" <> metavar "INT" <> maybeInternal))++  <*> optional (option auto (long "slack-max-message-size" <> help "Maximum message size in bytes (default: 8192)" <> metavar "INT" <> maybeInternal))++-- * Main parsing function++addOptionsFromArgs :: Options -> CommandLineOptions a -> IO (Options, Int)+addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do+  let printFormatter = SomeFormatter $ defaultPrintFormatter { printFormatterLogLevel = optLogLevel }+  let tuiFormatter = SomeFormatter $ defaultTerminalUIFormatter { terminalUILogLevel = optLogLevel }++  maybeMainFormatter <- case (optRepeatCount, optFormatter) of+    (x, _) | x /= 1 -> return $ Just printFormatter+    (_, Auto) -> hIsTerminalDevice stdout >>= \case+      True -> return $ Just printFormatter+      False -> return $ Just tuiFormatter+    (_, TUI) -> return $ Just tuiFormatter+    (_, Print) -> return $ Just printFormatter+    (_, Silent) -> return Nothing++  -- Strip out any "main" formatters since the options control that+  let baseFormatters = optionsFormatters baseOptions+                     & filter (not . isMainFormatter)++  let options = baseOptions {+    optionsTestArtifactsDirectory = case optFixedRoot of+      Nothing -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime)+      Just path -> TestArtifactsFixedDirectory path+    , optionsFilterTree = TreeFilter <$> optTreeFilter+    , optionsFormatters = baseFormatters <> catMaybes [maybeMainFormatter]+    }++  return (options, optRepeatCount)++  where+    isMainFormatter :: SomeFormatter -> Bool+    isMainFormatter (SomeFormatter x) = case cast x of+      Just (_ :: PrintFormatter) -> True+      Nothing -> case cast x of+        Just (_ :: TerminalUIFormatter) -> True+        Nothing -> False

@@ -0,0 +1,34 @@+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Functions for retrieving context information from within tests.++module Test.Sandwich.Contexts where++import Control.Monad.Reader+import GHC.Stack+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++-- | Get a context by its label.+getContext :: (Monad m, HasLabel context l a, HasCallStack, MonadReader context m) => Label l a -> m a+getContext = asks . getLabelValue++-- | Get the root folder of the on-disk test tree for the current run.+-- Will be 'Nothing' if the run isn't configured to use the disk.+getRunRoot :: (Monad m, HasBaseContext context, MonadReader context m) => m (Maybe FilePath)+getRunRoot = asks (baseContextRunRoot . getBaseContext)++-- | Get the on-disk folder corresponding to the current node.+-- Will be 'Nothing' if the run isn't configured to use the disk, or if the current node is configured+-- not to create a folder.+getCurrentFolder :: (HasBaseContext context, MonadReader context m, MonadIO m) => m (Maybe FilePath)+getCurrentFolder = asks (baseContextPath . getBaseContext)++-- | Get the command line options, if configured.+-- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can+-- introduce them manually+getCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m (CommandLineOptions a)+getCommandLineOptions = getContext commandLineOptions

@@ -0,0 +1,112 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Functions for making assertions about test behavior.++module Test.Sandwich.Expectations where++import Control.Exception.Safe+import Control.Monad.IO.Class+import qualified Data.List as L+import Data.String.Interpolate+import qualified Data.Text as T+import GHC.Stack+import Test.Sandwich.Types.Spec++-- * Manually fail a test or mark as pending++-- | General-purpose function to throw a test exception with a 'String'.+expectationFailure :: (HasCallStack, MonadThrow m) => String -> m a+expectationFailure = throwIO . Reason (Just callStack)++-- | Throws a 'Pending' exception, which will cause the test to be marked as pending.+pending :: (HasCallStack, MonadThrow m) => m ()+pending = throwIO $ Pending (Just callStack) Nothing++-- | Throws a 'Pending' exception with a message to add additional details.+pendingWith :: (HasCallStack, MonadThrow m) => String -> m ()+pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)++-- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.+xit :: (HasCallStack, Monad m, MonadThrow m) => String -> ExampleT context m1 () -> SpecFree context m ()+xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)++-- * Expecting failures++-- | Assert that a given action should fail with some 'FailureReason'.+shouldFail :: (HasCallStack, MonadCatch m, MonadThrow m) => m () -> m ()+shouldFail action = do+  try action >>= \case+    Left (_ :: FailureReason) -> return ()+    Right () -> expectationFailure [i|Expected test to fail|]++-- | Assert that a given action should fail with some 'FailureReason' matching a predicate.+shouldFailPredicate :: (HasCallStack, MonadCatch m, MonadThrow m) => (FailureReason -> Bool) -> m () -> m ()+shouldFailPredicate pred action = do+  try action >>= \case+    Left (err :: FailureReason) -> case pred err of+      True -> return ()+      False -> expectationFailure [i|Expected test to fail with a failure matching the predicate, but got a different failure: '#{err}'|]+    Right () -> expectationFailure [i|Expected test to fail, but it succeeded|]++-- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.+shouldThrow :: (HasCallStack, MonadThrow m, MonadCatch m, MonadIO m, Exception e) =>+  m a+  -- ^ The action to run.+  -> (e -> Bool)+  -- ^ A predicate on the exception to determine if it's as expected.+  -> m ()+shouldThrow action f = do+  try action >>= \case+    Right _ -> expectationFailure [i|Expected exception to be thrown.|]+    Left e | f e -> return ()+    Left e -> expectationFailure [i|Exception didn't match predicate: '#{show e}'|]++-- * Assertions++-- | Asserts that two things are equal.+shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()+shouldBe x y+  | x == y = return ()+  | otherwise = throwIO (ExpectedButGot (Just callStack) (SEB y) (SEB x))++-- | Asserts that two things are not equal.+shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()+shouldNotBe x y+  | x /= y = return ()+  | otherwise = throwIO (DidNotExpectButGot (Just callStack) (SEB y))++-- | Asserts that the given list contains a subsequence.+shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()+shouldContain haystack needle = case needle `L.isInfixOf` haystack of+  True -> return ()+  False -> expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type++-- | Asserts that the given list contains an item matching a predicate.+shouldContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()+shouldContainPredicate haystack pred = case L.find pred haystack of+  Just _ -> return ()+  Nothing -> expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]++-- | Asserts that the given list does not contain a subsequence.+shouldNotContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()+shouldNotContain haystack needle = case needle `L.isInfixOf` haystack of+  True -> expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]+  False -> return ()++-- | Asserts that the given list contains an item matching a predicate.+shouldNotContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()+shouldNotContainPredicate haystack pred = case L.find pred haystack of+  Nothing -> return ()+  Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]++-- | Asserts that the given text contains a substring.+textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()+t `textShouldContain` txt = ((T.unpack t) :: String) `shouldContain` (T.unpack txt)++-- | Asserts that the given text does not contain a substring.+textShouldNotContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()+t `textShouldNotContain` txt = ((T.unpack t) :: String) `shouldNotContain` (T.unpack txt)

@@ -0,0 +1,45 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+-- |++module Test.Sandwich.Formatters.Common.Count where++import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec++countWhere :: (forall context. RunNodeWithStatus context s l t -> Bool) -> [RunNodeWithStatus context s l t] -> Int+countWhere p rts = sum $ fmap (countWhere' p) rts+  where+    countWhere' :: (forall context. RunNodeWithStatus context s l t -> Bool) -> RunNodeWithStatus context s l t -> Int+    countWhere' p rt@(RunNodeIt {..}) = if p rt then 1 else 0+    countWhere' p rt@(RunNodeIntroduce {..}) = (if p rt then 1 else 0) + countWhere p runNodeChildrenAugmented+    countWhere' p rt@(RunNodeIntroduceWith {..}) = (if p rt then 1 else 0) + countWhere p runNodeChildrenAugmented+    countWhere' p rt = (if p rt then 1 else 0) + countWhere p (runNodeChildren rt)++isItBlock (RunNodeIt {}) = True+isItBlock _ = False++isRunningItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Running {})})}) = True+isRunningItBlock _ = False++isSuccessItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=Success})})}) = True+isSuccessItBlock _ = False++isPendingItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure (Pending {}))})})}) = True+isPendingItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})}) = False+isPendingItBlock _ = False++isFailedItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure (Pending {}))})})}) = False+isFailedItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})}) = True+isFailedItBlock _ = False++isFailedBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure (Pending {}))})})) = False+isFailedBlock (runNodeCommon -> (RunNodeCommonWithStatus {runTreeStatus=(Done {statusResult=(Failure {})})})) = True+isFailedBlock _ = False++isDoneItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(Done {})})}) = True+isDoneItBlock _ = False++isNotStartedItBlock (RunNodeIt {runNodeCommon=(RunNodeCommonWithStatus {runTreeStatus=(NotStarted {})})}) = True+isNotStartedItBlock _ = False

@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+-- |++module Test.Sandwich.Formatters.Common.Util (+  formatNominalDiffTime+  ) where++import Data.Fixed+import Data.Time.Clock+import Text.Printf++formatNominalDiffTime :: NominalDiffTime -> String+formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^15)) <> " ps"+formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^12)) <> " ns"+formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^9)) <> " ns"+formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^6)) <> " us"+formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^3)) <> " ms"+formatNominalDiffTime diff = (roundFixed (nominalDiffTimeToSeconds diff)) <> " s"++second = secondsToNominalDiffTime 1+ms = secondsToNominalDiffTime 0.001+us = secondsToNominalDiffTime 0.000001+ns = secondsToNominalDiffTime 0.000000001+ps = secondsToNominalDiffTime 0.000000000001++roundFixed :: Fixed E12 -> String+roundFixed f = printf "%.1f" ((realToFrac f) :: Double)+++#if !MIN_VERSION_time(1,9,1)+secondsToNominalDiffTime :: Pico -> NominalDiffTime+secondsToNominalDiffTime = realToFrac++nominalDiffTimeToSeconds :: NominalDiffTime -> Pico+nominalDiffTimeToSeconds = realToFrac+#endif

@@ -0,0 +1,107 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.Formatters.FailureReport (+  defaultFailureReportFormatter+  , failureReportUseColor+  , failureReportLogLevel+  , failureReportIncludeCallStacks+  , failureReportIndentSize+  ) where++import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Foldable+import qualified Data.Map as M+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import System.IO+import Test.Sandwich.Formatters.Print.Common+import Test.Sandwich.Formatters.Print.FailureReason+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++data FailureReportFormatter = FailureReportFormatter {+  failureReportUseColor :: Bool+  , failureReportLogLevel :: Maybe LogLevel+  , failureReportIncludeCallStacks :: Bool+  , failureReportIndentSize :: Int+  }++defaultFailureReportFormatter :: FailureReportFormatter+defaultFailureReportFormatter = FailureReportFormatter {+  failureReportUseColor = True+  , failureReportLogLevel = Just LevelWarn+  , failureReportIncludeCallStacks = True+  , failureReportIndentSize = 4+  }++instance Formatter FailureReportFormatter where+  formatterName _ = "failure-report-formatter"+  runFormatter _ _ _ _ = return ()+  finalizeFormatter = printFailureReport++printFailureReport :: (MonadIO m, MonadLogger m, MonadCatch m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m ()+printFailureReport (FailureReportFormatter {..}) rts _bc = do+  liftIO $ putStrLn [i|\n\nFailure report:|]++  let pf = PrintFormatter {+        printFormatterUseColor = failureReportUseColor+        , printFormatterLogLevel = failureReportLogLevel+        , printFormatterVisibilityThreshold = maxBound+        , printFormatterIncludeCallStacks = failureReportIncludeCallStacks+        , printFormatterIndentSize = failureReportIndentSize+        }++  let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, T.pack runTreeLabel)+  let idToLabel = M.fromList $ mconcat [extractValues extractFromNode node | node <- rts]++  liftIO $ runReaderT (mapM_ (runWithIndentation idToLabel) rts) (pf, 0, stdout)++runWithIndentation :: M.Map Int T.Text -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()+runWithIndentation idToLabel node = do+  let common@(RunNodeCommonWithStatus {..}) = runNodeCommon node++  case node of+    RunNodeIt {} -> return ()+    RunNodeIntroduce {..} -> forM_ runNodeChildrenAugmented (runWithIndentation idToLabel)+    RunNodeIntroduceWith {..} -> forM_ runNodeChildrenAugmented (runWithIndentation idToLabel)+    _ -> forM_ (runNodeChildren node) (runWithIndentation idToLabel)++  result <- liftIO $ waitForTree node++  -- Print the failure reason+  case result of+    Success -> return ()+    Failure reason -> do+      p "\n"++      let ancestorIds = runTreeAncestors+      let ancestorNames = fmap (\k -> fromMaybe "?" $ M.lookup k idToLabel) ancestorIds+      let label = T.unpack $ T.intercalate ", " (toList ancestorNames)++      case reason of+        Pending {} -> do+          pYellowLn label+        _ -> do+          -- TODO: get full list of ancestor labels joined on ", "+          pRedLn label+          withBumpIndent $ printFailureReason reason+          finishPrinting common result

@@ -0,0 +1,87 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+-- | A simple formatter that saves all logs from the test to a file.++module Test.Sandwich.Formatters.LogSaver (+  defaultLogSaverFormatter+  , logSaverPath+  , logSaverLogLevel++  , LogPath(..)+  ) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import qualified Data.ByteString.Char8 as BS8+import System.FilePath+import System.IO+import Test.Sandwich.Interpreters.RunTree.Logging+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Util+++-- | Used to save test all logs from the tests to a given path.+data LogSaverFormatter = LogSaverFormatter {+  logSaverPath :: LogPath+  -- ^ Path where logs will be saved.+  , logSaverLogLevel :: LogLevel+  -- ^ Minimum log level to save.+  , logSaverFormatter :: LogEntryFormatter+  -- ^ Formatter function for log entries.+  }++-- | A path under which to save logs.+data LogPath =+  LogPathRelativeToRunRoot FilePath+  -- ^ Interpret the path as relative to the test's run root. (If there is no run root, the logs won't be saved.)+  | LogPathAbsolute FilePath+  -- ^ Interpret the path as an absolute path.++defaultLogSaverFormatter :: LogSaverFormatter+defaultLogSaverFormatter = LogSaverFormatter {+  logSaverPath = LogPathRelativeToRunRoot "logs.txt"+  , logSaverLogLevel = LevelWarn+  , logSaverFormatter = defaultLogEntryFormatter+  }++instance Formatter LogSaverFormatter where+  formatterName _ = "log-saver-formatter"+  runFormatter = runApp+  finalizeFormatter _ _ _ = return ()++runApp :: (MonadIO m, MonadLogger m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp lsf@(LogSaverFormatter {..}) rts _maybeCommandLineOptions bc = do+  let maybePath = case logSaverPath of+        LogPathAbsolute p -> Just p+        LogPathRelativeToRunRoot p -> case baseContextRunRoot bc of+          Nothing -> Nothing+          Just rr -> Just (rr </> p)++  whenJust maybePath $ \path ->+    liftIO $ withFile path AppendMode $ \h ->+      runReaderT (mapM_ run rts) (lsf, h)++run :: RunNode context -> ReaderT (LogSaverFormatter, Handle) IO ()+run node@(RunNodeIt {..}) = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  _ <- liftIO $ waitForTree node+  printLogs runTreeLogs+run node = do+  let RunNodeCommonWithStatus {..} = runNodeCommon node+  _ <- liftIO $ waitForTree node+  printLogs runTreeLogs++printLogs :: (MonadIO m, MonadReader (LogSaverFormatter, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()+printLogs runTreeLogs = do+  (LogSaverFormatter {..}, h) <- ask+  logEntries <- liftIO $ readTVarIO runTreeLogs+  forM_ logEntries $ \(LogEntry {..}) ->+    when (logEntryLevel >= logSaverLogLevel) $+      liftIO $ BS8.hPutStr h $+        logSaverFormatter logEntryTime logEntryLoc logEntrySource logEntryLevel logEntryStr

@@ -0,0 +1,115 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf #-}++module Test.Sandwich.Formatters.Print (+  defaultPrintFormatter+  , printFormatterUseColor+  , printFormatterLogLevel+  , printFormatterIncludeCallStacks+  , printFormatterIndentSize+  ) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import Data.Time.Clock+import System.IO+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Formatters.Print.Common+import Test.Sandwich.Formatters.Print.FailureReason+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.RunTree+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Util+++instance Formatter PrintFormatter where+  formatterName _ = "print-formatter"+  runFormatter = runApp+  finalizeFormatter _ _ _ = return ()++runApp :: (MonadIO m, MonadLogger m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp pf@(PrintFormatter {..}) rts _maybeCommandLineOptions bc = liftIO $ do+  let total = countWhere isItBlock rts++  startTime <- getCurrentTime++  putStrLn "\n"+  putStrLn [i|Beginning suite of #{total} tests\n|]++  whenJust (baseContextRunRoot bc) $ \runRoot ->+    putStrLn [i|Run root: #{runRoot}\n|]++  runReaderT (mapM_ runWithIndentation rts) (pf, 2, stdout)+  putStrLn "\n"++  fixedTree <- atomically $ mapM fixRunTree rts+  let failed = countWhere isFailedItBlock fixedTree+  let pending = countWhere isPendingItBlock fixedTree++  endTime <- getCurrentTime+  let timeDiff = formatNominalDiffTime $ diffUTCTime endTime startTime++  if | failed == 0 -> putStr [i|All tests passed in #{timeDiff}.|]+     | otherwise -> putStr [i|#{failed} failed of #{total} in #{timeDiff}.|]+  case pending of+    0 -> putStrLn ""+    _ -> putStrLn [i| (#{pending} pending)|]+++runWithIndentation :: RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO ()+runWithIndentation node@(RunNodeIt {..}) = do+  let common@(RunNodeCommonWithStatus {..}) = runNodeCommon++  result <- liftIO $ waitForTree node++  -- Print the main header+  case result of+    Success -> pGreenLn runTreeLabel+    (Failure (Pending _ _)) -> pYellowLn runTreeLabel+    (Failure reason) -> do+      pRedLn runTreeLabel+      withBumpIndent $ printFailureReason reason++  finishPrinting common result+runWithIndentation node = do+  let common@(RunNodeCommonWithStatus {..}) = runNodeCommon node++  (PrintFormatter {..}, _, _) <- ask++  childPrintFn <- case runTreeVisibilityLevel <= printFormatterVisibilityThreshold of+    True -> do+      pin runTreeLabel+      return withBumpIndent+    False -> return id++  case node of+    RunNodeIntroduce {..} -> childPrintFn $ forM_ runNodeChildrenAugmented runWithIndentation+    RunNodeIntroduceWith {..} -> childPrintFn $ forM_ runNodeChildrenAugmented runWithIndentation+    _ -> childPrintFn $ forM_ (runNodeChildren node) runWithIndentation++  result <- liftIO $ waitForTree node++  -- Print the failure reason+  case runTreeVisibilityLevel <= printFormatterVisibilityThreshold of+    True -> do+      case result of+        Failure r -> withBumpIndent $ printFailureReason r+        Success -> return ()+      finishPrinting common result+    False -> return () -- TODO: print failure info even though node should be hidden?

@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+-- |++module Test.Sandwich.Formatters.Print.CallStacks where++import Control.Monad+import GHC.Stack+import Test.Sandwich.Formatters.Print.Color+import Test.Sandwich.Formatters.Print.Printing+++printCallStack cs = forM_ (getCallStack cs) printCallStackLine++printCallStackLine (f, (SrcLoc {..})) = do+  pic logFunctionColor f++  p " called at "+  pc logFilenameColor srcLocFile+  p ":"+  pc logLineColor (show srcLocStartLine)+  p ":"+  pc logChColor (show srcLocStartCol)+  p " in "+  pc logPackageColor srcLocPackage+  p ":"+  pc logModuleColor srcLocModule+  p "\n"++logFunctionColor = solarizedMagenta+logFilenameColor = solarizedViolet+logModuleColor = solarizedMagenta+logPackageColor = solarizedGreen+logLineColor = solarizedCyan+logChColor = solarizedOrange

@@ -0,0 +1,49 @@+-- |++module Test.Sandwich.Formatters.Print.Color where++import Data.Colour.RGBSpace+import Data.Colour.SRGB++expectedColor = midWhite+sawColor = midWhite+integerColor = solarizedMagenta+floatColor = solarizedMagenta+charColor = solarizedCyan+stringColor = solarizedYellow+dateColor = solarizedBase2+timeColor = solarizedBase3+quoteColor = solarizedBase1+slashColor = solarizedViolet+negColor = solarizedViolet+listBracketColor = solarizedOrange -- TODO: make green?+tupleBracketColor = solarizedGreen+braceColor = solarizedGreen+ellipsesColor = solarizedBase0+recordNameColor = solarizedRed+fieldNameColor = solarizedYellow+constructorNameColor = solarizedViolet+++midWhite = sRGB24 c c c :: Colour Float+  where c = 0xc0++midGray = sRGB24 c c c :: Colour Float+  where c = 0x70++solarizedBase03 = sRGB24 0x00 0x2b 0x36 :: Colour Float+solarizedBase02 = sRGB24 0x07 0x36 0x42 :: Colour Float+solarizedBase01 = sRGB24 0x58 0x6e 0x75 :: Colour Float+solarizedbase00 = sRGB24 0x65 0x7b 0x83 :: Colour Float+solarizedBase0 = sRGB24 0x83 0x94 0x96 :: Colour Float+solarizedBase1 = sRGB24 0x93 0xa1 0xa1 :: Colour Float+solarizedBase2 = sRGB24 0xee 0xe8 0xd5 :: Colour Float+solarizedBase3 = sRGB24 0xfd 0xf6 0xe3 :: Colour Float+solarizedYellow = sRGB24 0xb5 0x89 0x00 :: Colour Float+solarizedOrange = sRGB24 0xcb 0x4b 0x16 :: Colour Float+solarizedRed = sRGB24 0xdc 0x32 0x2f :: Colour Float+solarizedMagenta = sRGB24 0xd3 0x36 0x82 :: Colour Float+solarizedViolet = sRGB24 0x6c 0x71 0xc4 :: Colour Float+solarizedBlue = sRGB24 0x26 0x8b 0xd2 :: Colour Float+solarizedCyan = sRGB24 0x2a 0xa1 0x98 :: Colour Float+solarizedGreen = sRGB24 0x85 0x99 0x00 :: Colour Float

@@ -0,0 +1,32 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.Formatters.Print.Common where++import Control.Monad.Reader+import System.IO+import Test.Sandwich.Formatters.Print.CallStacks+import Test.Sandwich.Formatters.Print.Logs+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++finishPrinting :: RunNodeCommon -> Result -> ReaderT (PrintFormatter, Int, Handle) IO ()+finishPrinting (RunNodeCommonWithStatus {..}) result = do+  includeCallStacks <- asks (printFormatterIncludeCallStacks . fst3)++  -- Print the callstack, if configured and present+  when includeCallStacks $ do+    case result of+      Failure (failureCallStack -> Just cs) -> do+        p "\n"+        withBumpIndent $ printCallStack cs+      _ -> return ()++  -- Print the logs, if configured+  printLogs runTreeLogs

@@ -0,0 +1,73 @@+-- | Pretty printing failure reasons++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Sandwich.Formatters.Print.FailureReason (+  printFailureReason+  ) where++import Control.Exception.Safe+import Control.Monad.Reader+import qualified Data.List as L+import Data.String.Interpolate+import System.IO+import Test.Sandwich.Formatters.Print.Color+import Test.Sandwich.Formatters.Print.PrintPretty+import Test.Sandwich.Formatters.Print.Printing as P+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Test.Sandwich.Types.Spec+import Text.Show.Pretty as P+++printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO ()+printFailureReason (Reason _ s) = do+  printShowBoxPrettyWithTitle "Reason: " (SEB s)+printFailureReason (ExpectedButGot _ seb1 seb2) = do+  printShowBoxPrettyWithTitle "Expected: " seb1+  printShowBoxPrettyWithTitle "But got: " seb2+printFailureReason (DidNotExpectButGot _ seb) = do+  printShowBoxPrettyWithTitle "Did not expect: " seb+printFailureReason (GotException _ maybeMessage e@(SomeExceptionWithEq baseException)) =+  case fromException baseException of+    Just (fr :: FailureReason) -> do+      picn midWhite "Got exception:"+      printFailureReason fr+    _ -> case maybeMessage of+      Nothing -> printShowBoxPrettyWithTitle "Got exception: " (SEB e)+      Just s -> printShowBoxPrettyWithTitle [i|Got exception (#{s})|] (SEB e)+printFailureReason (Pending _ maybeMessage) = case maybeMessage of+  Nothing -> return () -- Just allow the yellow heading to show the pending state+  Just s -> printShowBoxPrettyWithTitle "Pending reason: " (SEB s)+printFailureReason (GetContextException _ e@(SomeExceptionWithEq baseException)) = do+  case fromException baseException of+    Just (fr :: FailureReason) -> do+      picn midWhite "Context exception:"+      printFailureReason fr+    _ -> printShowBoxPrettyWithTitle "Context exception: " (SEB e)+printFailureReason (GotAsyncException _ maybeMessage e) = case maybeMessage of+  Nothing -> printShowBoxPrettyWithTitle "Async exception" (SEB e)+  Just s -> printShowBoxPrettyWithTitle [i|Async exception (#{e}) |] (SEB s)++-- * Pretty printing++printShowBoxPrettyWithTitle :: String -> ShowEqBox -> ReaderT (PrintFormatter, Int, Handle) IO ()+printShowBoxPrettyWithTitle title (SEB v) = case P.reify v of+  Nothing -> do+    picn midWhite title+    withBumpIndent $ do+      forM_ (L.lines $ show v) pin+    p "\n"+  Just x+    | isSingleLine x -> do+        pic midWhite title+        printPretty False x >> p "\n"+    | otherwise -> do+        picn midWhite title+        printPretty True x >> p "\n"++-- printShowBoxPretty (SEB v) = case P.reify v of+--   Nothing -> forM_ (L.lines $ show v) pin+--   Just x -> printPretty True x >> p "\n"

@@ -0,0 +1,70 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+-- |++module Test.Sandwich.Formatters.Print.Logs where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Reader+import Data.String.Interpolate+import System.IO+import Test.Sandwich.Formatters.Print.Color+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Test.Sandwich.Types.RunTree+++printLogs :: (MonadIO m, MonadReader (PrintFormatter, Int, Handle) m, Foldable t) => TVar (t LogEntry) -> m ()+printLogs runTreeLogs = do+  (asks (printFormatterLogLevel . fst3)) >>= \case+    Nothing -> return ()+    Just logLevel -> do+      logEntries <- liftIO $ readTVarIO runTreeLogs+      withBumpIndent $+        forM_ logEntries $ \entry ->+          when (logEntryLevel entry >= logLevel) $ printLogEntry entry+++printLogEntry (LogEntry {..}) = do+  pic logTimestampColor (show logEntryTime)++  case logEntryLevel of+    LevelDebug -> pc debugColor " (DEBUG) "+    LevelInfo -> pc infoColor " (INFO) "+    LevelWarn -> pc warnColor " (WARN) "+    LevelError -> pc errorColor " (ERROR) "+    LevelOther x -> pc infoColor [i| #{x} |]++  let Loc {loc_start=(line, ch), ..} = logEntryLoc+  p "["+  pc logFilenameColor loc_filename+  p ":"+  pc logLineColor (show line)+  p ":"+  pc logChColor (show ch)+  p "] "++  p (show logEntryStr)++  p "\n"+++debugColor = solarizedBlue+infoColor = solarizedYellow+warnColor = solarizedRed+errorColor = solarizedRed+otherColor = solarizedYellow++logFilenameColor = solarizedViolet+logModuleColor = solarizedMagenta+logPackageColor = solarizedGreen+logLineColor = solarizedCyan+logChColor = solarizedOrange+logFunctionColor = solarizedBlue++logTimestampColor = midGray

@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.Formatters.Print.PrintPretty (+  printPretty+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import qualified Data.List as L+import System.IO+import Test.Sandwich.Formatters.Print.Color+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Formatters.Print.Util+import Text.Show.Pretty as P+++printPretty :: (MonadReader (PrintFormatter, Int, Handle) m, MonadIO m) => Bool -> Value -> m ()+#if MIN_VERSION_pretty_show(1,10,0)+printPretty (getPrintFn -> f) (Quote s) = f quoteColor s+printPretty (getPrintFn -> f) (Time s) = f timeColor s+printPretty (getPrintFn -> f) (Date s) = f dateColor s+printPretty indentFirst (InfixCons v pairs) = do+  -- TODO: make sure this looks good+  printPretty indentFirst v+  withBumpIndent' 4 $+    forM_ pairs $ \(name, val) -> do+      pic constructorNameColor name+      p " "+      printPretty False val+      p "\n"+#endif+printPretty (getPrintFn -> f) (String s) = f stringColor s+printPretty (getPrintFn -> f) (Char s) = f charColor s+printPretty (getPrintFn -> f) (Float s) = f floatColor s+printPretty (getPrintFn -> f) (Integer s) = f integerColor s+printPretty indentFirst (Rec name tuples) = do+  (if indentFirst then pic else pc) recordNameColor name+  pcn braceColor " {"+  withBumpIndent $+    forM_ tuples $ \(name, val) -> do+      pic fieldNameColor name+      p " = "+      withBumpIndent' (L.length name + L.length (" = " :: String)) $ do+        printPretty False val+        p "\n"+  pic braceColor "}"+printPretty indentFirst (Con name values) = do+  (if indentFirst then pic else pc) constructorNameColor (name <> " ")+  case values of+    [] -> return ()+    (x:xs) -> do+      printPretty False x+      p "\n"+      withBumpIndent' (L.length name + L.length (" " :: String)) $ do+        sequence_ (L.intercalate [p "\n"] [[printPretty True v] | v <- xs])+printPretty indentFirst (List values) = printListWrappedIn ("[", "]") indentFirst values+printPretty indentFirst (Tuple values) = printListWrappedIn ("(", ")") indentFirst values+printPretty indentFirst (Ratio v1 v2) = do+  printPretty indentFirst v1+  picn slashColor "/"+  printPretty True v2+printPretty (getPrintFn -> f) (Neg s) = do+  f negColor "-"+  withBumpIndent' 1 $+    printPretty False s+++printListWrappedIn (begin, end) (getPrintFn -> f) values | all isSingleLine values = do+  f listBracketColor begin+  sequence_ (L.intercalate [p ", "] [[printPretty False v] | v <- values])+  pc listBracketColor end+printListWrappedIn (begin, end) (getPrintFn -> f) values = do+  f listBracketColor begin+  p "\n"+  withBumpIndent $ do+    forM_ values $ \v -> do+      printPretty True v+      p "\n"+  pic listBracketColor end++getPrintFn True = pic+getPrintFn False = pc

@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+-- | Utility functions for printing++module Test.Sandwich.Formatters.Print.Printing where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader+import qualified Data.List as L+import System.Console.ANSI+import System.IO+import Test.Sandwich.Formatters.Print.Types+import Test.Sandwich.Util+++-- * Printing functions for indented, colored, and with newline++pi msg = printIndentedWithColor Nothing msg+pic color msg = printIndentedWithColor (Just (SetRGBColor Foreground color)) msg+pin msg = printIndentedWithColor Nothing (msg <> "\n")+picn color msg = printIndentedWithColor (Just (SetRGBColor Foreground color)) (msg <> "\n")++p msg = printWithColor Nothing msg+pc color msg = printWithColor (Just (SetRGBColor Foreground color)) msg+pn msg = printWithColor Nothing (msg <> "\n")+pcn color msg = printWithColor (Just (SetRGBColor Foreground color)) (msg <> "\n")++pGreenLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Green)) (msg <> "\n")+pYellowLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Yellow)) (msg <> "\n")+pRedLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Red)) (msg <> "\n") -- Tried solarizedRed here but it was too orange++printIndentedWithColor maybeColor msg = do+  (PrintFormatter {..}, indent, h) <- ask+  liftIO $ hPutStr h $ L.replicate indent ' '+  printWithColor maybeColor msg++printWithColor maybeColor msg = do+  (PrintFormatter {..}, _, h) <- ask+  when (printFormatterUseColor) $ whenJust maybeColor $ \color -> liftIO $ setSGR [color]+  liftIO $ hPutStr h msg+  when (printFormatterUseColor) $ whenJust maybeColor $ \_ -> liftIO $ setSGR [Reset]

@@ -0,0 +1,21 @@++module Test.Sandwich.Formatters.Print.Types where++import Control.Monad.Logger++data PrintFormatter = PrintFormatter {+  printFormatterUseColor :: Bool+  , printFormatterLogLevel :: Maybe LogLevel+  , printFormatterVisibilityThreshold :: Int+  , printFormatterIncludeCallStacks :: Bool+  , printFormatterIndentSize :: Int+  }++defaultPrintFormatter :: PrintFormatter+defaultPrintFormatter = PrintFormatter {+  printFormatterUseColor = True+  , printFormatterLogLevel = Just LevelWarn+  , printFormatterVisibilityThreshold = 50+  , printFormatterIncludeCallStacks = True+  , printFormatterIndentSize = 4+  }

@@ -0,0 +1,37 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+-- |++module Test.Sandwich.Formatters.Print.Util where++import Control.Monad.Reader+import qualified Data.List as L+import Test.Sandwich.Formatters.Print.Types+import Text.Show.Pretty as P+++isSingleLine :: P.Value -> Bool+isSingleLine (Con {}) = False+isSingleLine (InfixCons op tuples) = isSingleLine op && (all isSingleLine (fmap snd tuples))+isSingleLine (Rec {}) = False+isSingleLine (Tuple values) = all isSingleLine values+isSingleLine (List values) = all isSingleLine values+isSingleLine (Neg value) = isSingleLine value+isSingleLine (Ratio v1 v2) = all isSingleLine [v1, v2]+isSingleLine (String s) = '\n' `L.notElem` s++#if MIN_VERSION_pretty_show(1,10,0)+isSingleLine (Quote s) = '\n' `L.notElem` s+#endif++isSingleLine _ = True++withBumpIndent action = do+  (PrintFormatter {..}, _, _) <- ask+  withBumpIndent' printFormatterIndentSize action++withBumpIndent' n = local (\(pf, indent, h) -> (pf, indent + n, h))+++fst3 (x, _, _) = x

@@ -0,0 +1,392 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.Formatters.TerminalUI (+  defaultTerminalUIFormatter+  , terminalUIVisibilityThreshold+  , terminalUIShowRunTimes+  , terminalUIShowVisibilityThresholds+  , terminalUILogLevel+  , terminalUIInitialFolding+  , terminalUIDefaultEditor+  , terminalUIOpenInEditor+  , InitialFolding(..)+  , TerminalUIFormatter+  ) where++import Brick as B+import Brick.BChan+import Brick.Widgets.List+import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.Foldable+import qualified Data.List as L+import Data.Maybe+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import Data.String.Interpolate+import Data.Time+import qualified Data.Vector as Vec+import GHC.Stack+import qualified Graphics.Vty as V+import Lens.Micro+import Safe+import System.FilePath+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.CrossPlatform+import Test.Sandwich.Formatters.TerminalUI.Draw+import Test.Sandwich.Formatters.TerminalUI.Filter+import Test.Sandwich.Formatters.TerminalUI.Keys+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.Interpreters.StartTree+import Test.Sandwich.RunTree+import Test.Sandwich.Shutdown+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Util+++instance Formatter TerminalUIFormatter where+  formatterName _ = "terminal-ui-formatter"+  runFormatter = runApp+  finalizeFormatter _ _ _ = return ()++runApp :: (MonadIO m, MonadLogger m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = liftIO $ do+  startTime <- getCurrentTime++  liftIO $ setInitialFolding terminalUIInitialFolding rts++  rtsFixed <- atomically $ mapM fixRunTree rts++  let initialState = updateFilteredTree $+        AppState {+          _appRunTreeBase = rts+          , _appRunTree = rtsFixed+          , _appMainList = list MainList mempty 1+          , _appBaseContext = baseContext++          , _appStartTime = startTime+          , _appTimeSinceStart = 0++          , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : (fmap runTreeVisibilityLevel $ concatMap getCommons rts)+          , _appVisibilityThreshold = terminalUIVisibilityThreshold++          , _appLogLevel = terminalUILogLevel+          , _appShowRunTimes = terminalUIShowRunTimes+          , _appShowFileLocations = terminalUIShowFileLocations+          , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds++          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())+          , _appDebug = (const $ return ())+        }++  eventChan <- newBChan 10++  currentFixedTree <- newTVarIO rtsFixed+  eventAsync <- async $ forever $ do+    newFixedTree <- atomically $ do+      currentFixed <- readTVar currentFixedTree+      newFixed <- mapM fixRunTree rts+      when (fmap getCommons newFixed == fmap getCommons currentFixed) retry+      writeTVar currentFixedTree newFixed+      return newFixed+    writeBChan eventChan (RunTreeUpdated newFixedTree)+    threadDelay 100000 -- Sleep 100ms++  let buildVty = do+        v <- V.mkVty V.defaultConfig+        let output = V.outputIface v+        when (V.supportsMode output V.Mouse) $+          liftIO $ V.setMode output V.Mouse True+        return v+  initialVty <- buildVty+  flip onException (cancel eventAsync) $+    void $ customMain initialVty buildVty (Just eventChan) app initialState++app :: App AppState AppEvent ClickableName+app = App {+  appDraw = drawUI+  , appChooseCursor = showFirstCursor+  , appHandleEvent = appEvent+  , appStartEvent = return+  , appAttrMap = const mainAttrMap+  }++appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName (Next AppState)+appEvent s (AppEvent (RunTreeUpdated newTree)) = do+  now <- liftIO getCurrentTime+  continue $ s+    & appRunTree .~ newTree+    & appTimeSinceStart .~ (diffUTCTime now (s ^. appStartTime))+    & updateFilteredTree++appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do+  lookupExtent ColorBar >>= \case+    Nothing -> continue s+    Just (Extent {extentSize=(w, _), extentUpperLeft=(B.Location (l, _))}) -> do+      let percent :: Double = (fromIntegral (x - l)) / (fromIntegral w)+      let allCommons = concatMap getCommons $ s ^. appRunTree+      let index = max 0 $ min (length allCommons - 1) $ round $ percent * (fromIntegral $ (length allCommons - 1))+      -- A subsequent RunTreeUpdated will pick up the new open nodes+      liftIO $ openIndices (s ^. appRunTreeBase) (runTreeAncestors $ allCommons !! index)+      continue $ s+        & appMainList %~ (listMoveTo index)+        & updateFilteredTree++appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do+  vScrollBy (viewportScroll MainList) (-1)+  continue s+appEvent s (MouseDown (ListRow _i) V.BScrollDown _ _) = do+  vScrollBy (viewportScroll MainList) 1+  continue s+appEvent s (MouseDown (ListRow i) V.BLeft _ _) = do+  continue (s & appMainList %~ (listMoveTo i))+appEvent s (VtyEvent e) =+  case e of+    -- Column 1+    V.EvKey c [] | c == nextKey -> continue (s & appMainList %~ (listMoveBy 1))+    V.EvKey c [] | c == previousKey -> continue (s & appMainList %~ (listMoveBy (-1)))+    V.EvKey c [] | c == nextFailureKey -> do+      let ls = Vec.toList $ listElements (s ^. appMainList)+      let listToSearch = case listSelectedElement (s ^. appMainList) of+            Just (i, MainListElem {}) -> let (front, back) = L.splitAt (i + 1) (zip [0..] ls) in back <> front+            Nothing -> zip [0..] ls+      case L.find (isFailureStatus . status . snd) listToSearch of+        Nothing -> continue s+        Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))+    V.EvKey c [] | c == previousFailureKey -> do+      let ls = Vec.toList $ listElements (s ^. appMainList)+      let listToSearch = case listSelectedElement (s ^. appMainList) of+            Just (i, MainListElem {}) -> let (front, back) = L.splitAt i (zip [0..] ls) in (L.reverse front) <> (L.reverse back)+            Nothing -> L.reverse (zip [0..] ls)+      case L.find (isFailureStatus . status . snd) listToSearch of+        Nothing -> continue s+        Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))+    V.EvKey c [] | c == closeNodeKey -> modifyOpen s (const False)+    V.EvKey c [] | c == openNodeKey -> modifyOpen s (const True)+    V.EvKey c@(V.KChar ch) [V.MMeta] | c `elem` (fmap V.KChar ['0'..'9']) -> do+      let num :: Int = read [ch]+      liftIO $ openToDepth (s ^. (appMainList . listElementsL)) num+      continue s+    V.EvKey c [] | c `elem` toggleKeys -> modifyToggled s not++    -- Scrolling in toggled items+    -- Wanted to make these uniformly Ctrl+whatever, but Ctrl+PageUp/PageDown was causing it to get KEsc and exit (?)+    V.EvKey V.KUp [V.MCtrl] -> withScroll s $ flip vScrollBy (-1)+    V.EvKey (V.KChar 'p') [V.MCtrl] -> withScroll s $ flip vScrollBy (-1)+    V.EvKey V.KDown [V.MCtrl] -> withScroll s $ flip vScrollBy 1+    V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ flip vScrollBy 1+    V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ flip vScrollPage Up+    V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ flip vScrollPage Down+    V.EvKey V.KHome [V.MCtrl] -> withScroll s vScrollToBeginning+    V.EvKey V.KEnd [V.MCtrl] -> withScroll s vScrollToEnd++    -- Column 2+    V.EvKey c [] | c == cancelAllKey -> do+      liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)+      continue s+    V.EvKey c [] | c == cancelSelectedKey -> withContinueS $ do+      whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> liftIO $+        (readTVarIO $ runTreeStatus node) >>= \case+          Running {..} -> cancel statusAsync+          _ -> return ()+    V.EvKey c [] | c == runAllKey -> withContinueS $ do+      when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do+        mapM_ clearRecursively (s ^. appRunTreeBase)+        void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)+    V.EvKey c [] | c == runSelectedKey -> withContinueS $+      whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of+        Running {} -> return ()+        _ -> do+          -- Get the set of IDs for only this node's ancestors and children+          let ancestorIds = S.fromList $ toList $ runTreeAncestors node+          case findRunNodeChildrenById ident (s ^. appRunTree) of+            Nothing -> return ()+            Just childIds -> do+              let allIds = ancestorIds <> childIds+              -- Clear the status of all affected nodes+              liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` allIds)) (s ^. appRunTreeBase)+              -- Start a run for all affected nodes+              let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }+              void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc+    V.EvKey c [] | c == clearSelectedKey -> withContinueS $ do+      whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of+        Running {} -> return ()+        _ -> case findRunNodeChildrenById ident (s ^. appRunTree) of+          Nothing -> return ()+          Just childIds -> liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` childIds)) (s ^. appRunTreeBase)+    V.EvKey c [] | c == clearAllKey -> withContinueS $ do+      liftIO $ mapM_ clearRecursively (s ^. appRunTreeBase)+    V.EvKey c [] | c == openSelectedFolderInFileExplorer -> withContinueS $ do+      whenJust (listSelectedElement (s ^. appMainList)) $ \(_i, MainListElem {folderPath}) ->+        whenJust folderPath $ liftIO . openFileExplorerFolderPortable+    V.EvKey c [] | c == openTestRootKey -> withContinueS $+      whenJust (baseContextRunRoot (s ^. appBaseContext)) $ liftIO . openFileExplorerFolderPortable+    V.EvKey c [] | c == openTestInEditorKey -> case listSelectedElement (s ^. appMainList) of+      Just (_i, MainListElem {node=(runTreeLoc -> Just loc)}) -> openSrcLoc s loc+      _ -> continue s+    V.EvKey c [] | c == openLogsInEditorKey -> case listSelectedElement (s ^. appMainList) of+      Just (_i, MainListElem {node=(runTreeFolder -> Just dir)}) -> do+        let srcLoc = SrcLoc {+          srcLocPackage = ""+          , srcLocModule = ""+          , srcLocFile = dir </> "test_logs.txt"+          , srcLocStartLine = 0+          , srcLocStartCol = 0+          , srcLocEndLine = 0+          , srcLocEndCol = 0+          }+        suspendAndResume ((s ^. appOpenInEditor) srcLoc >> return s)+      _ -> continue s+    V.EvKey c [] | c == openFailureInEditorKey -> do+      case (listSelectedElement (s ^. appMainList)) of+        Nothing -> continue s+        Just (_i, MainListElem {status}) -> case status of+          Done _ _ (Failure (failureCallStack -> Just (getCallStack -> ((_, loc):_)))) -> openSrcLoc s loc+          _ -> continue s++    -- Column 3+    V.EvKey c [] | c == cycleVisibilityThresholdKey -> do+      let newVisibilityThreshold =  case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps), x > s ^. appVisibilityThreshold] of+            [] -> 0+            xs -> minimum $ fmap snd xs+      continue $ s+        & appVisibilityThreshold .~ newVisibilityThreshold+        & updateFilteredTree+    V.EvKey c [] | c == toggleShowRunTimesKey -> continue $ s+      & appShowRunTimes %~ not+    V.EvKey c [] | c == toggleFileLocationsKey -> continue $ s+      & appShowFileLocations %~ not+    V.EvKey c [] | c == toggleVisibilityThresholdsKey -> continue $ s+      & appShowVisibilityThresholds %~ not+    V.EvKey c [] | c `elem` [V.KEsc, exitKey]-> do+      -- Cancel everything and wait for cleanups+      liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)+      forM_ (s ^. appRunTreeBase) (liftIO . waitForTree)+      halt s+    V.EvKey c [] | c == debugKey -> continue (s & appLogLevel ?~ LevelDebug)+    V.EvKey c [] | c == infoKey -> continue (s & appLogLevel ?~ LevelInfo)+    V.EvKey c [] | c == warnKey -> continue (s & appLogLevel ?~ LevelWarn)+    V.EvKey c [] | c == errorKey -> continue (s & appLogLevel ?~ LevelError)++    ev -> handleEventLensed s appMainList handleListEvent ev >>= continue++  where withContinueS action = action >> continue s+appEvent s _ = continue s++modifyToggled s f = case listSelectedElement (s ^. appMainList) of+  Nothing -> continue s+  Just (_i, MainListElem {..}) -> do+    liftIO $ atomically $ modifyTVar (runTreeToggled node) f+    continue s++modifyOpen s f = case listSelectedElement (s ^. appMainList) of+  Nothing -> continue s+  Just (_i, MainListElem {..}) -> do+    liftIO $ atomically $ modifyTVar (runTreeOpen node) f+    continue s++openIndices :: [RunNode context] -> Seq.Seq Int -> IO ()+openIndices nodes openSet =+  atomically $ forM_ (concatMap getCommons nodes) $ \node ->+    when ((runTreeId node) `elem` (toList openSet)) $+      modifyTVar (runTreeOpen node) (const True)++openToDepth :: (Foldable t) => t MainListElem -> Int -> IO ()+openToDepth elems thresh =+  atomically $ forM_ elems $ \(MainListElem {..}) ->+    if | (depth < thresh) -> modifyTVar (runTreeOpen node) (const True)+       | otherwise -> modifyTVar (runTreeOpen node) (const False)++setInitialFolding :: InitialFolding -> [RunNode BaseContext] -> IO ()+setInitialFolding InitialFoldingAllOpen _rts = return ()+setInitialFolding InitialFoldingAllClosed rts =+  atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->+    modifyTVar runTreeOpen (const False)+setInitialFolding (InitialFoldingTopNOpen n) rts =+  atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->+    when (Seq.length runTreeAncestors > n) $+      modifyTVar runTreeOpen (const False)++updateFilteredTree :: AppState -> AppState+updateFilteredTree s = s+  & appMainList %~ listReplace elems (listSelected $ s ^. appMainList)+  where filteredTree = filterRunTree (s ^. appVisibilityThreshold) (s ^. appRunTree)+        elems :: Vec.Vector MainListElem = Vec.fromList $ concatMap treeToList (zip filteredTree (s ^. appRunTreeBase))++-- * Clearing++clearRecursively :: RunNode context -> IO ()+clearRecursively = mapM_ clearCommon . getCommons++clearRecursivelyWhere :: (RunNodeCommon -> Bool) -> RunNode context -> IO ()+clearRecursivelyWhere f = mapM_ clearCommon . filter f . getCommons++clearCommon :: RunNodeCommon -> IO ()+clearCommon (RunNodeCommonWithStatus {..}) = do+  atomically $ do+    writeTVar runTreeStatus NotStarted+    writeTVar runTreeLogs mempty++  -- TODO: clearing the folders might be better for reproducibility, but it might be more surprising than not doing it.+  -- Also, we'd want to be a little judicious about which folders get cleared -- clearing entire "describe" folders would+  -- blow away unrelated test results. So maybe it's better to not clear, and for tests to just do idempotent things in+  -- their folders.+  -- whenJust runTreeFolder $ \folder -> do+  --   doesDirectoryExist folder >>= \case+  --     False -> return ()+  --     True -> clearDirectoryContents folder+  -- where+  --   clearDirectoryContents :: FilePath -> IO ()+  --   clearDirectoryContents path = do+  --     paths <- listDirectory path+  --     forM_ paths removePathForcibly++findRunNodeChildrenById :: Int -> [RunNodeFixed context] -> Maybe (S.Set Int)+findRunNodeChildrenById ident rts = headMay $ mapMaybe (findRunNodeChildrenById' ident) rts++findRunNodeChildrenById' :: Int -> RunNodeFixed context -> Maybe (S.Set Int)+findRunNodeChildrenById' ident node | ident == runTreeId (runNodeCommon node) = Just $ S.fromList $ extractValues (runTreeId . runNodeCommon) node+findRunNodeChildrenById' _ident (RunNodeIt {}) = Nothing+findRunNodeChildrenById' ident (RunNodeIntroduce {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented+findRunNodeChildrenById' ident (RunNodeIntroduceWith {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented+findRunNodeChildrenById' ident node = findRunNodeChildrenById ident (runNodeChildren node)++withScroll s action = do+  case listSelectedElement (s ^. appMainList) of+    Nothing -> return ()+    Just (_, MainListElem {..}) -> do+      let scroll = viewportScroll (InnerViewport [i|viewport_#{ident}|])+      action scroll++  continue s++openSrcLoc s loc' = do+  -- Try to make the file path in the SrcLoc absolute+  loc <- case isRelative (srcLocFile loc') of+    False -> return loc'+    True -> do+      case optionsProjectRoot (baseContextOptions (s ^. appBaseContext)) of+        Just d -> return $ loc' { srcLocFile = d </> (srcLocFile loc') }+        Nothing -> return loc'++  -- TODO: check if the path exists and show a warning message if not+  -- Maybe choose the first callstack location we can find?+  suspendAndResume (((s ^. appOpenInEditor) loc) >> return s)

@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.AttrMap where++import Brick+import Brick.Widgets.ProgressBar+import qualified Graphics.Vty as V+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++mainAttrMap :: AttrMap+mainAttrMap = attrMap V.defAttr [+  -- (listAttr, V.white `on` V.blue)+   -- (listSelectedAttr, V.blue `on` V.white)+  -- (listSelectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))+  -- (selectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))++  -- Top bar+  (visibilityThresholdNotSelectedAttr, fg midGray)+  , (visibilityThresholdSelectedAttr, fg solarizedBase2)++  -- Statuses+  -- , (notStartedAttr, fg V.)+  , (runningAttr, fg V.blue)+  , (pendingAttr, fg V.yellow)+  , (successAttr, fg V.green)+  , (failureAttr, fg V.red)+  , (totalAttr, fg solarizedCyan)++  -- Logging+  , (debugAttr, fg V.blue), (infoAttr, fg V.yellow), (warnAttr, fg V.red), (errorAttr, fg V.red), (otherAttr, V.defAttr)+  , (logTimestampAttr, fg midGray)+  , (logFilenameAttr, fg solarizedViolet)+  , (logModuleAttr, fg solarizedMagenta)+  , (logPackageAttr, fg solarizedGreen)+  , (logLineAttr, fg solarizedCyan)+  , (logChAttr, fg solarizedOrange)+  , (logFunctionAttr, fg solarizedMagenta)++  -- Progress bar+  , (progressCompleteAttr, bg (V.Color240 235))+  , (progressIncompleteAttr, bg (V.Color240 225))++  -- Main list+  , (toggleMarkerAttr, fg midGray)+  , (openMarkerAttr, fg midGray)+  , (visibilityThresholdIndicatorMutedAttr, fg $ grayAt 50)+  , (visibilityThresholdIndicatorAttr, fg $ grayAt 150)++  -- Hotkey stuff+  , (hotkeyAttr, fg V.blue)+  , (disabledHotkeyAttr, fg midGray)+  , (hotkeyMessageAttr, fg brightWhite)+  , (disabledHotkeyMessageAttr, fg brightGray)++  -- Exceptions and pretty printing+  , (expectedAttr, fg midWhite)+  , (sawAttr, fg midWhite)+  , (integerAttr, fg solarizedMagenta)+  , (floatAttr, fg solarizedMagenta)+  , (charAttr, fg solarizedCyan)+  , (stringAttr, fg solarizedYellow)+  , (dateAttr, fg solarizedBase2)+  , (timeAttr, fg solarizedBase1)+  , (quoteAttr, fg solarizedBase1)+  , (slashAttr, fg solarizedViolet)+  , (negAttr, fg solarizedViolet)+  , (listBracketAttr, fg solarizedOrange) -- TODO: make green?+  , (tupleBracketAttr, fg solarizedGreen)+  , (braceAttr, fg solarizedGreen)+  , (ellipsesAttr, fg solarizedBase0)+  , (recordNameAttr, fg solarizedRed)+  , (fieldNameAttr, fg solarizedYellow)+  , (constructorNameAttr, fg solarizedViolet)+  ]++-- selectedAttr :: AttrName+-- selectedAttr = "list_line_selected"++visibilityThresholdNotSelectedAttr :: AttrName+visibilityThresholdNotSelectedAttr = "visibility_threshold_not_selected"++visibilityThresholdSelectedAttr :: AttrName+visibilityThresholdSelectedAttr = "visibility_threshold_selected"++runningAttr :: AttrName+runningAttr = "running"++notStartedAttr :: AttrName+notStartedAttr = "not_started"++pendingAttr :: AttrName+pendingAttr = "pending"++totalAttr :: AttrName+totalAttr = "total"++successAttr :: AttrName+successAttr = "success"++failureAttr :: AttrName+failureAttr = "failure"++toggleMarkerAttr :: AttrName+toggleMarkerAttr = "toggleMarker"++openMarkerAttr :: AttrName+openMarkerAttr = "openMarker"++visibilityThresholdIndicatorAttr :: AttrName+visibilityThresholdIndicatorAttr = "visibilityThresholdIndicator"++visibilityThresholdIndicatorMutedAttr :: AttrName+visibilityThresholdIndicatorMutedAttr = "visibilityThresholdMutedIndicator"++hotkeyAttr, disabledHotkeyAttr, hotkeyMessageAttr, disabledHotkeyMessageAttr :: AttrName+hotkeyAttr = "hotkey"+disabledHotkeyAttr = "disableHotkey"+hotkeyMessageAttr = "hotkeyMessage"+disabledHotkeyMessageAttr = "disabledHotkeyMessage"++chooseAttr :: Status -> AttrName+chooseAttr NotStarted = notStartedAttr+chooseAttr (Running {}) = runningAttr+chooseAttr (Done _ _ (Success {})) = successAttr+chooseAttr (Done _ _ (Failure (Pending {}))) = pendingAttr+chooseAttr (Done _ _ (Failure {})) = failureAttr++-- * Logging and callstacks++debugAttr, infoAttr, warnAttr, errorAttr, otherAttr :: AttrName+debugAttr = "log_debug"+infoAttr = "log_info"+warnAttr = "log_warn"+errorAttr = "log_error"+otherAttr = "log_other"++logTimestampAttr :: AttrName+logTimestampAttr = "log_timestamp"++logFilenameAttr, logModuleAttr, logPackageAttr, logLineAttr, logChAttr :: AttrName+logFilenameAttr = "logFilename"+logModuleAttr = "logModule"+logPackageAttr = "logPackage"+logLineAttr = "logLine"+logChAttr = "logCh"+logFunctionAttr = "logFunction"++-- * Exceptions and pretty printing++expectedAttr, sawAttr :: AttrName+expectedAttr = "expected"+sawAttr = "saw"++integerAttr, timeAttr, dateAttr, stringAttr, charAttr, floatAttr, quoteAttr, slashAttr, negAttr :: AttrName+listBracketAttr, tupleBracketAttr, braceAttr, ellipsesAttr, recordNameAttr, fieldNameAttr, constructorNameAttr :: AttrName+integerAttr = "integer"+floatAttr = "float"+charAttr = "char"+stringAttr = "string"+dateAttr = "date"+timeAttr = "time"+quoteAttr = "quote"+slashAttr = "slash"+negAttr = "neg"+listBracketAttr = "listBracket"+tupleBracketAttr = "tupleBracket"+braceAttr = "brace"+ellipsesAttr = "ellipses"+recordNameAttr = "recordName"+fieldNameAttr = "fieldName"+constructorNameAttr = "fieldName"++-- * Colors++solarizedBase03 = V.rgbColor 0x00 0x2b 0x36+solarizedBase02 = V.rgbColor 0x07 0x36 0x42+solarizedBase01 = V.rgbColor 0x58 0x6e 0x75+solarizedbase00 = V.rgbColor 0x65 0x7b 0x83+solarizedBase0 = V.rgbColor 0x83 0x94 0x96+solarizedBase1 = V.rgbColor 0x93 0xa1 0xa1+solarizedBase2 = V.rgbColor 0xee 0xe8 0xd5+solarizedBase3 = V.rgbColor 0xfd 0xf6 0xe3+solarizedYellow = V.rgbColor 0xb5 0x89 0x00+solarizedOrange = V.rgbColor 0xcb 0x4b 0x16+solarizedRed = V.rgbColor 0xdc 0x32 0x2f+solarizedMagenta = V.rgbColor 0xd3 0x36 0x82+solarizedViolet = V.rgbColor 0x6c 0x71 0xc4+solarizedBlue = V.rgbColor 0x26 0x8b 0xd2+solarizedCyan = V.rgbColor 0x2a 0xa1 0x98+solarizedGreen = V.rgbColor 0x85 0x99 0x00++midGray = grayAt 50+brightGray = grayAt 80+midWhite = grayAt 140+brightWhite = grayAt 200++grayAt level = V.rgbColor level level level+-- grayAt level = V.Color240 $ V.rgbColorToColor240 level level level

@@ -0,0 +1,12 @@+-- |++module Test.Sandwich.Formatters.TerminalUI.CrossPlatform (+  openFileExplorerFolderPortable+  ) where++import Control.Monad+import System.Process++-- | TODO: report exceptions here+openFileExplorerFolderPortable folder = do+  void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""

@@ -0,0 +1,154 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}++module Test.Sandwich.Formatters.TerminalUI.Draw where++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import qualified Brick.Widgets.List as L+import Control.Monad+import Control.Monad.Logger+import Data.Foldable+import qualified Data.List as L+import Data.Maybe+import qualified Data.Sequence as Seq+import Data.String.Interpolate+import qualified Data.Text.Encoding as E+import Data.Time.Clock+import GHC.Stack+import qualified Graphics.Vty as V+import Lens.Micro+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar+import Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget+import Test.Sandwich.Formatters.TerminalUI.Draw.TopBox+import Test.Sandwich.Formatters.TerminalUI.Draw.Util+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+++drawUI :: AppState -> [Widget ClickableName]+drawUI app = [ui]+  where+    ui = vBox [+      topBox app+      , borderWithCounts app+      , mainList app+      , clickable ColorBar $ bottomProgressBarColored app+      ]++mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (app ^. appMainList)+  where+    listDrawElement ix isSelected x@(MainListElem {..}) = clickable (ListRow ix) $ padLeft (Pad (4 * depth)) $ (if isSelected then border else id) $ vBox $ catMaybes [+      Just $ renderLine isSelected x+      , do+          guard toggled+          let infoWidgets = getInfoWidgets x+          guard (not $ L.null infoWidgets)+          return $ padLeft (Pad 4) $+            fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 30 $+              vBox infoWidgets+      ]++    renderLine _isSelected (MainListElem {..}) = hBox $ catMaybes [+      Just $ withAttr openMarkerAttr $ str (if open then "[-] " else "[+] ")+      , Just $ withAttr (chooseAttr status) (str label)+      , if not (app ^. appShowFileLocations) then Nothing else+          case runTreeLoc node of+            Nothing -> Nothing+            Just loc ->+              Just $ hBox [str " ["+                          , withAttr logFilenameAttr $ str $ srcLocFile loc+                          , str ":"+                          , withAttr logLineAttr $ str $ show $ srcLocStartLine loc+                          , str "]"]+      , if not (app ^. appShowVisibilityThresholds) then Nothing else+          Just $ hBox [str " ["+                      , withAttr visibilityThresholdIndicatorMutedAttr $ str "V="+                      , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel+                      , str "]"]+      , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]")+      , if not (app ^. appShowRunTimes) then Nothing else case status of+          Running {..} -> Just $ str $ show statusStartTime+          Done {..} -> Just $ raw $ V.string attr $ formatNominalDiffTime (diffUTCTime statusEndTime statusStartTime)+            where totalElapsed = realToFrac (max (app ^. appTimeSinceStart) (diffUTCTime statusEndTime (app ^. appStartTime)))+                  duration = realToFrac (diffUTCTime statusEndTime statusStartTime)+                  intensity :: Double = logBase (totalElapsed + 1) (duration + 1)+                  minGray :: Int = 50+                  maxGray :: Int = 255+                  level :: Int = min maxGray $ max minGray $ round (fromIntegral minGray + (intensity * (fromIntegral (maxGray - minGray))))+                  attr = V.Attr {+                    V.attrStyle = V.Default+                    , V.attrForeColor = V.SetTo (grayAt level)+                    , V.attrBackColor = V.Default+                    , V.attrURL = V.Default+                    }+          _ -> Nothing+      ]++    getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ toBrickWidget status, callStackWidget mle, logWidget mle]++    callStackWidget (MainListElem {..}) = do+      cs <- getCallStackFromStatus status+      return $ borderWithLabel (padLeftRight 1 $ str "Callstack") $ toBrickWidget cs++    logWidget (MainListElem {..}) = do+      let filteredLogs = case app ^. appLogLevel of+            Nothing -> mempty+            Just logLevel -> Seq.filter (\x -> logEntryLevel x >= logLevel) logs+      guard (not $ Seq.null filteredLogs)+      return $ borderWithLabel (padLeftRight 1 $ str "Logs") $ vBox $+        toList $ fmap logEntryWidget filteredLogs++    logEntryWidget (LogEntry {..}) = hBox [+      withAttr logTimestampAttr $ str (show logEntryTime)+      , str " "+      , logLevelWidget logEntryLevel+      , str " "+      , logLocWidget logEntryLoc+      , str " "+      , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr)+      ]++    logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [+      str "["+      , withAttr logFilenameAttr $ str loc_filename+      , str ":"+      , withAttr logLineAttr $ str (show line)+      , str ":"+      , withAttr logChAttr $ str (show ch)+      , str "]"+      ]++    logLevelWidget LevelDebug = withAttr debugAttr $ str "(DEBUG)"+    logLevelWidget LevelInfo = withAttr infoAttr $ str "(INFO)"+    logLevelWidget LevelWarn = withAttr infoAttr $ str "(WARN)"+    logLevelWidget LevelError = withAttr infoAttr $ str "(ERROR)"+    logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|]+++borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |]+                                                                                                          , withAttr totalAttr $ str $ show totalNumTests+                                                                                                          , str [i| in |]+                                                                                                          , withAttr timeAttr $ str $ formatNominalDiffTime (app ^. appTimeSinceStart)])+  where+    countWidgets =+      (if totalSucceededTests > 0 then [[withAttr successAttr $ str $ show totalSucceededTests, str " succeeded"]] else mempty)+      <> (if totalFailedTests > 0 then [[withAttr failureAttr $ str $ show totalFailedTests, str " failed"]] else mempty)+      <> (if totalPendingTests > 0 then [[withAttr pendingAttr $ str $ show totalPendingTests, str " pending"]] else mempty)+      <> (if totalRunningTests > 0 then [[withAttr runningAttr $ str $ show totalRunningTests, str " running"]] else mempty)+      <> (if totalNotStartedTests > 0 then [[str $ show totalNotStartedTests, str " not started"]] else mempty)++    totalNumTests = countWhere isItBlock (app ^. appRunTree)+    totalSucceededTests = countWhere isSuccessItBlock (app ^. appRunTree)+    totalPendingTests = countWhere isPendingItBlock (app ^. appRunTree)+    totalFailedTests = countWhere isFailedItBlock (app ^. appRunTree)+    totalRunningTests = countWhere isRunningItBlock (app ^. appRunTree)+    totalNotStartedTests = countWhere isNotStartedItBlock (app ^. appRunTree)

@@ -0,0 +1,104 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar (+  bottomProgressBarColored+  ) where++import Brick+import Data.Foldable+import Data.Ord (comparing)+import Data.String.Interpolate+import GHC.Stack+import Lens.Micro+import Lens.Micro.TH+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec++type Chunk a = [(Rational, a)]++data ChunkSum = ChunkSum { _running :: Rational+                         , _notStarted :: Rational+                         , _pending :: Rational+                         , _success :: Rational+                         , _failure :: Rational }++zeroChunkSum :: ChunkSum+zeroChunkSum = ChunkSum 0 0 0 0 0++makeLenses ''ChunkSum++splitIntoChunks :: forall a. (Show a) => Rational -> [(Rational, a)] -> [[(Rational, a)]]+splitIntoChunks _ [] = []+splitIntoChunks chunkSize remaining = chunk : (splitIntoChunks chunkSize remaining')+  where+    (chunk, remaining') = go [] chunkSize remaining++    go :: Chunk a -> Rational -> [(Rational, a)] -> (Chunk a, [(Rational, a)])+    go chunkSoFar needed ((amount, val):xs) =+      if | amount == needed -> (chunkSoFar <> [(amount, val)], xs)+         | amount < needed -> go (chunkSoFar <> [(amount, val)]) (needed - amount) xs+         | amount > needed -> (chunkSoFar <> [(needed, val)], (amount - needed, val):xs)+         | otherwise -> error "impossible"+    go chunkSoFar needed [] = error [i|Bottomed out in go: #{chunkSoFar}, #{needed}|]++-- TODO: improve this to use block chars+getCharForChunk :: [(Rational, Status)] -> Widget n+getCharForChunk chunk = withAttr attrToUse (str full_five_eighth_height)+  where ChunkSum {..} = sumChunk chunk+        (_, attrToUse) = maxBy fst [(_running, runningAttr)+                                   , (_notStarted, notStartedAttr)+                                   , (_pending, pendingAttr)+                                   , (_success, successAttr)+                                   , (_failure, failureAttr)+                                   ]++sumChunk :: Chunk Status -> ChunkSum+sumChunk = foldl combine zeroChunkSum+  where combine chunkSum (amount, status) = chunkSum & (lensForStatus status) %~ (+ amount)++        lensForStatus NotStarted = notStarted+        lensForStatus (Running {}) = running+        lensForStatus (Done {statusResult=Success}) = success+        lensForStatus (Done {statusResult=(Failure (Pending {}))}) = pending+        lensForStatus (Done {statusResult=(Failure _)}) = failure++maxBy :: (Foldable t, Ord a) => (b -> a) -> t b -> b+maxBy = maximumBy . comparing++-- * Block elems++-- full = "█"+-- seven_eighth = "▉"+-- six_eighth = "▊"+-- five_eighth = "▋"+-- four_eighth = "▌"+-- three_eighth = "▍"+-- two_eighth = "▎"+-- one_eighth = "▏"++full_five_eighth_height = "▆"++-- * Exports++bottomProgressBarColored app = Widget Greedy Fixed $ do+  c <- getContext+  render $ bottomProgressBarColoredWidth app (c ^. availWidthL)++bottomProgressBarColoredWidth app width = hBox [getCharForChunk chunk | chunk <- chunks]+  where+    statuses = concatMap getStatuses (app ^. appRunTree)+    statusesWithAmounts = [(testsPerChar, x) | x <- statuses]++    chunks = splitIntoChunks 1 statusesWithAmounts++    testsPerChar :: Rational = fromIntegral width / fromIntegral (length statuses)++    getStatuses :: (HasCallStack) => RunNodeWithStatus context a l t -> [a]+    getStatuses = extractValues (runTreeStatus . runNodeCommon)

@@ -0,0 +1,171 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget where++import Brick+import Brick.Widgets.Border+import Control.Exception.Safe+import qualified Data.List as L+import Data.String.Interpolate+import Data.Time.Clock+import GHC.Stack+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Text.Show.Pretty as P++class ToBrickWidget a where+  toBrickWidget :: a -> Widget n++instance ToBrickWidget Status where+  toBrickWidget (NotStarted {}) = strWrap "Not started"+  toBrickWidget (Running {statusStartTime}) = strWrap [i|Started at #{statusStartTime}|]+  toBrickWidget (Done startTime endTime Success) = strWrap [i|Succeeded in #{formatNominalDiffTime (diffUTCTime endTime startTime)}|]+  toBrickWidget (Done {statusResult=(Failure failureReason)}) = toBrickWidget failureReason++instance ToBrickWidget FailureReason where+  toBrickWidget (ExpectedButGot _ (SEB x1) (SEB x2)) = hBox [+    hLimitPercent 50 $+      border $+        padAll 1 $+          (padBottom (Pad 1) (withAttr expectedAttr $ str "Expected:"))+          <=>+          widget1+    , padLeft (Pad 1) $+        hLimitPercent 50 $+          border $+            padAll 1 $+              (padBottom (Pad 1) (withAttr sawAttr $ str "Saw:"))+              <=>+              widget2+    ]+    where+      (widget1, widget2) = case (P.reify x1, P.reify x2) of+        (Just v1, Just v2) -> (toBrickWidget v1, toBrickWidget v2)+        _ -> (str (show x1), str (show x2))+  toBrickWidget (DidNotExpectButGot _ x) = boxWithTitle "Did not expect:" (reifyWidget x)+  toBrickWidget (Pending _ maybeMessage) = case maybeMessage of+    Nothing -> withAttr pendingAttr $ str "Pending"+    Just msg -> hBox [withAttr pendingAttr $ str "Pending"+                     , str (": " <> msg)]+  toBrickWidget (Reason _ msg) = boxWithTitle "Failure reason:" (strWrap msg)+  toBrickWidget (GotException _ maybeMessage e@(SomeExceptionWithEq baseException)) = case fromException baseException of+    Just (fr :: FailureReason) -> boxWithTitle heading (toBrickWidget fr)+    _ -> boxWithTitle heading (reifyWidget e)+    where heading = case maybeMessage of+            Nothing -> "Got exception: "+            Just msg -> [i|Got exception (#{msg}):|]+  toBrickWidget (GotAsyncException _ maybeMessage e) = boxWithTitle heading (reifyWidget e)+    where heading = case maybeMessage of+            Nothing -> "Got async exception: "+            Just msg -> [i|Got async exception (#{msg}):|]+  toBrickWidget (GetContextException _ e@(SomeExceptionWithEq baseException)) = case fromException baseException of+    Just (fr :: FailureReason) -> boxWithTitle "Get context exception:" (toBrickWidget fr)+    _ -> boxWithTitle "Get context exception:" (reifyWidget e)+++boxWithTitle heading inside = hBox [+  border $+    padAll 1 $+      (padBottom (Pad 1) (withAttr expectedAttr $ strWrap heading))+      <=>+      inside+  ]++reifyWidget x = case P.reify x of+  Just v -> toBrickWidget v+  _ -> strWrap (show x)++instance ToBrickWidget P.Value where+  toBrickWidget (Integer s) = withAttr integerAttr $ strWrap s+  toBrickWidget (Float s) = withAttr floatAttr $ strWrap s+  toBrickWidget (Char s) = withAttr charAttr $ strWrap s+  toBrickWidget (String s) = withAttr stringAttr $ strWrap s+#if MIN_VERSION_pretty_show(1,10,0)+  toBrickWidget (Date s) = withAttr dateAttr $ strWrap s+  toBrickWidget (Time s) = withAttr timeAttr $ strWrap s+  toBrickWidget (Quote s) = withAttr quoteAttr $ strWrap s+#endif+  toBrickWidget (Ratio v1 v2) = hBox [toBrickWidget v1, withAttr slashAttr $ str "/", toBrickWidget v2]+  toBrickWidget (Neg v) = hBox [withAttr negAttr $ str "-"+                               , toBrickWidget v]+  toBrickWidget (List vs) = vBox ((withAttr listBracketAttr $ str "[")+                                  : (fmap (padLeft (Pad 4)) listRows)+                                  <> [withAttr listBracketAttr $ str "]"])+    where listRows+            | length vs < 10 = fmap toBrickWidget vs+            | otherwise = (fmap toBrickWidget (L.take 3 vs))+                          <> [withAttr ellipsesAttr $ str "..."]+                          <> (fmap toBrickWidget (takeEnd 3 vs))+  toBrickWidget (Tuple vs) = vBox ((withAttr tupleBracketAttr $ str "(")+                                   : (fmap (padLeft (Pad 4)) tupleRows)+                                   <> [withAttr tupleBracketAttr $ str ")"])+    where tupleRows+            | length vs < 10 = fmap toBrickWidget vs+            | otherwise = (fmap toBrickWidget (L.take 3 vs))+                          <> [withAttr ellipsesAttr $ str "..."]+                          <> (fmap toBrickWidget (takeEnd 3 vs))+  toBrickWidget (Rec recordName tuples) = vBox (hBox [withAttr recordNameAttr $ str recordName, withAttr braceAttr $ str " {"]+                                                 : (fmap (padLeft (Pad 4)) recordRows)+                                                 <> [withAttr braceAttr $ str "}"])+    where recordRows+            | length tuples < 10 = fmap tupleToWidget tuples+            | otherwise = (fmap tupleToWidget (L.take 3 tuples))+                          <> [withAttr ellipsesAttr $ str "..."]+                          <> (fmap tupleToWidget (takeEnd 3 tuples))++          tupleToWidget (name, v) = hBox [withAttr fieldNameAttr $ str name+                                         , str " = "+                                         , toBrickWidget v]+  toBrickWidget (Con conName vs) = vBox ((withAttr constructorNameAttr $ str conName)+                                          : (fmap (padLeft (Pad 4)) constructorRows))+    where constructorRows+            | length vs < 10 = fmap toBrickWidget vs+            | otherwise = (fmap toBrickWidget (L.take 3 vs))+                          <> [withAttr ellipsesAttr $ str "..."]+                          <> (fmap toBrickWidget (takeEnd 3 vs))++  toBrickWidget (InfixCons opValue tuples) = vBox (L.intercalate [toBrickWidget opValue] [[x] | x <- rows])+    where rows+            | length tuples < 10 = fmap tupleToWidget tuples+            | otherwise = (fmap tupleToWidget (L.take 3 tuples))+                          <> [withAttr ellipsesAttr $ str "..."]+                          <> (fmap tupleToWidget (takeEnd 3 tuples))++          tupleToWidget (name, v) = hBox [withAttr fieldNameAttr $ str name+                                         , str " = "+                                         , toBrickWidget v]++instance ToBrickWidget CallStack where+  toBrickWidget cs = vBox (fmap renderLine $ getCallStack cs)+    where+      renderLine (f, srcLoc) = hBox [+        withAttr logFunctionAttr $ str f+        , str " called at "+        , toBrickWidget srcLoc+        ]++instance ToBrickWidget SrcLoc where+  toBrickWidget (SrcLoc {..}) = hBox [+    withAttr logFilenameAttr $ str srcLocFile+    , str ":"+    , withAttr logLineAttr $ str $ show srcLocStartLine+    , str ":"+    , withAttr logChAttr $ str $ show srcLocStartCol+    , str " in "+    , withAttr logPackageAttr $ str srcLocPackage+    , str ":"+    , str srcLocModule+    ]++-- * Util++takeEnd :: Int -> [a] -> [a]+takeEnd j xs = f xs (drop j xs)+  where f (_:zs) (_:ys) = f zs ys+        f zs _ = zs

@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.Draw.TopBox (+  topBox+  ) where++import Brick+import qualified Brick.Widgets.List as L+import Control.Monad.Logger+import qualified Data.List as L+import Data.Maybe+import Lens.Micro+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Keys+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++topBox app = hBox [columnPadding settingsColumn+                  , columnPadding actionsColumn+                  , columnPadding otherActionsColumn]+  where+    settingsColumn = keybindingBox [keyIndicator (L.intersperse '/' [unKChar nextKey, unKChar previousKey, '↑', '↓']) "Navigate"+                                   , keyIndicatorHasSelected app (showKeys toggleKeys) "Open/close node"+                                   , keyIndicatorHasSelectedOpen app "Control-v/Meta-v" "Scroll node"+                                   , keyIndicatorHasSelected app (unKChar closeNodeKey : '/' : [unKChar openNodeKey]) "Fold/unfold node"+                                   , keyIndicator "Meta + [0-9]" "Unfold top # nodes"+                                   , keyIndicator (unKChar nextFailureKey : '/' : [unKChar previousFailureKey]) "Next/previous failure"+                                   ]++    actionsColumn = keybindingBox [hBox [str "["+                                         , highlightKeyIfPredicate selectedTestRunning app (str $ showKey cancelSelectedKey)+                                         , str "/"+                                         , highlightKeyIfPredicate someTestRunning app (str $ showKey cancelAllKey)+                                         , str "] "+                                         , withAttr hotkeyMessageAttr $ str "Cancel "+                                         , highlightMessageIfPredicate selectedTestRunning app (str "selected")+                                         , str "/"+                                         , highlightMessageIfPredicate someTestRunning app (str "all")+                                         ]+                                  , hBox [str "["+                                         , highlightKeyIfPredicate selectedTestDone app (str $ showKey runSelectedKey)+                                         , str "/"+                                         , highlightKeyIfPredicate noTestsRunning app (str $ showKey runAllKey)+                                         , str "] "+                                         , withAttr hotkeyMessageAttr $ str "Run "+                                         , highlightMessageIfPredicate selectedTestDone app (str "selected")+                                         , str "/"+                                         , highlightMessageIfPredicate noTestsRunning app (str "all")+                                         ]+                                  , hBox [str "["+                                         , highlightKeyIfPredicate selectedTestDone app (str $ showKey clearSelectedKey)+                                         , str "/"+                                         , highlightKeyIfPredicate allTestsDone app (str $ showKey clearAllKey)+                                         , str "] "+                                         , withAttr hotkeyMessageAttr $ str "Clear "+                                         , highlightMessageIfPredicate selectedTestDone app (str "selected")+                                         , str "/"+                                         , highlightMessageIfPredicate allTestsDone app (str "all")+                                         ]+                                  , hBox [str "["+                                         , highlightKeyIfPredicate someTestSelected app (str $ showKey openSelectedFolderInFileExplorer)+                                         , str "/"+                                         , highlightKeyIfPredicate (const True) app (str $ showKey openTestRootKey)+                                         , str "] "+                                         , withAttr hotkeyMessageAttr $ str "Open "+                                         , highlightMessageIfPredicate someTestSelected app (str "selected")+                                         , str "/"+                                         , highlightMessageIfPredicate (const True) app (str "root")+                                         , withAttr hotkeyMessageAttr $ str " folder"+                                         ]+                                  , hBox [str "["+                                         , highlightKeyIfPredicate someTestSelected app (str $ showKey openTestInEditorKey)+                                         , str "/"+                                         , highlightKeyIfPredicate someTestSelected app (str $ showKey openLogsInEditorKey)+                                         , str "/"+                                         , highlightKeyIfPredicate someTestSelected app (str $ showKey openFailureInEditorKey)+                                         , str "] "+                                         , withAttr hotkeyMessageAttr $ str "Edit "+                                         , highlightMessageIfPredicate someTestSelected app (str "test")+                                         , str "/"+                                         , highlightMessageIfPredicate someTestSelected app (str "logs")+                                         , str "/"+                                         , highlightMessageIfPredicate selectedTestHasCallStack app (str "failure")+                                         ]+                                  ]++    otherActionsColumn = keybindingBox [keyIndicator' (showKey cycleVisibilityThresholdKey) (visibilityThresholdWidget app)+                                       , hBox [str "["+                                              , str $ showKey toggleShowRunTimesKey+                                              , str "/"+                                              , str $ showKey toggleFileLocationsKey+                                              , str "/"+                                              , str $ showKey toggleVisibilityThresholdsKey+                                              , str "] "+                                              , highlightMessageIfPredicate (^. appShowRunTimes) app (str "Times")+                                              , str "/"+                                              , highlightMessageIfPredicate (^. appShowFileLocations) app (str "locations")+                                              , str "/"+                                              , highlightMessageIfPredicate (^. appShowVisibilityThresholds) app (str "thresholds")+                                         ]+                                       , hBox [str "["+                                              , highlightIfLogLevel app LevelDebug [unKChar debugKey]+                                              , str "/"+                                              , highlightIfLogLevel app LevelInfo [unKChar infoKey]+                                              , str "/"+                                              , highlightIfLogLevel app LevelWarn [unKChar warnKey]+                                              , str "/"+                                              , highlightIfLogLevel app LevelError [unKChar errorKey]+                                              , str "] "+                                              , str "Log level"]++                                       , keyIndicator "q" "Exit"]++visibilityThresholdWidget app = hBox $+  [withAttr hotkeyMessageAttr $ str "Visibility threshold ("]+  <> L.intersperse (str ", ") [withAttr (if x == app ^. appVisibilityThreshold then visibilityThresholdSelectedAttr else visibilityThresholdNotSelectedAttr) $ str $ show x | x <- (app ^. appVisibilityThresholdSteps)]+  <> [(str ")")]++columnPadding = padLeft (Pad 1) . padRight (Pad 3) -- . padTop (Pad 1)++keybindingBox = vBox++highlightIfLogLevel app desiredLevel thing =+  if | app ^. appLogLevel == Just desiredLevel -> withAttr visibilityThresholdSelectedAttr $ str thing+     | otherwise -> withAttr hotkeyAttr $ str thing++highlightKeyIfPredicate p app x = case p app of+  True -> withAttr hotkeyAttr x+  False -> withAttr disabledHotkeyAttr x++highlightMessageIfPredicate p app x = case p app of+  True -> withAttr hotkeyMessageAttr x+  False -> withAttr disabledHotkeyMessageAttr x++keyIndicator key msg = keyIndicator' key (withAttr hotkeyMessageAttr $ str msg)++keyIndicator' key label = hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", label]++keyIndicatorHasSelected app = keyIndicatorContextual app someTestSelected++keyIndicatorHasSelectedOpen app = keyIndicatorContextual app selectedTestToggled++keyIndicatorContextual app p key msg = case p app of+  True -> hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", withAttr hotkeyMessageAttr $ str msg]+  False -> hBox [str "[", withAttr disabledHotkeyAttr $ str key, str "] ", withAttr disabledHotkeyMessageAttr $ str msg]+++-- * Predicates++selectedTestRunning s = case L.listSelectedElement (s ^. appMainList) of+  Nothing -> False+  Just (_, MainListElem {..}) -> isRunning status++selectedTestDone s = case L.listSelectedElement (s ^. appMainList) of+  Nothing -> False+  Just (_, MainListElem {..}) -> isDone status++selectedTestHasCallStack s = case L.listSelectedElement (s ^. appMainList) of+  Nothing -> False+  Just (_, MainListElem {..}) -> case status of+    (Done _ _ (Failure failureReason)) -> isJust $ failureCallStack failureReason+    _ -> False++selectedTestToggled s = case L.listSelectedElement (s ^. appMainList) of+  Nothing -> False+  Just (_, MainListElem {..}) -> toggled++noTestsRunning s = all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)++someTestRunning s = any (isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)++allTestsDone s = all (isDone . runTreeStatus . runNodeCommon) (s ^. appRunTree)++someTestSelected s = isJust $ L.listSelectedElement (s ^. appMainList)

@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.Draw.Util where++import Brick+import Graphics.Vty.Image+import Lens.Micro+++fixedHeightOrViewportPercent :: (Ord n, Show n) => n -> Int -> Widget n -> Widget n+fixedHeightOrViewportPercent vpName maxHeightPercent w =+  Widget Fixed Fixed $ do+    -- Render the viewport contents in advance+    result <- render w+    -- If the contents will fit in the maximum allowed rows,+    -- just return the content without putting it in a viewport.++    ctx <- getContext++#if MIN_VERSION_brick(0,56,0)+    let usableHeight = ctx ^. windowHeightL+#else+    let usableHeight = min 80 (ctx ^. availHeightL) -- Bound this so it looks okay inside a viewport+#endif++    let maxHeight = round (toRational usableHeight * (toRational maxHeightPercent / 100))++    if imageHeight (image result) <= maxHeight+      then return result+      -- Otherwise put the contents (pre-rendered) in a viewport+      -- and limit the height to the maximum allowable height.+      else render (vLimit maxHeight $+                   viewport vpName Vertical $+                   Widget Fixed Fixed $ return result)

@@ -0,0 +1,94 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.Filter (+  filterRunTree+  , treeToList+  ) where++import Control.Monad+import Control.Monad.Trans.Reader+import Data.Function+import qualified Data.List as L+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree++filterRunTree :: Int -> [RunNodeFixed context] -> [RunNodeFixed context]+filterRunTree visibilityThreshold rtsFixed = rtsFixed+  & fmap (mapCommon (hideIfThresholdAbove visibilityThreshold))+  & fmap hideClosed++mapCommon :: (RunNodeCommonWithStatus s l t -> RunNodeCommonWithStatus s l t) -> RunNodeWithStatus context s l t -> RunNodeWithStatus context s l t+mapCommon f node@(RunNodeIt {}) = node { runNodeCommon = f (runNodeCommon node) }+mapCommon f (RunNodeIntroduce {..}) = RunNodeIntroduce { runNodeCommon = f runNodeCommon+                                                       , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented+                                                       , .. }+mapCommon f (RunNodeIntroduceWith {..}) = RunNodeIntroduceWith { runNodeCommon = f runNodeCommon+                                                               , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented+                                                               , .. }+mapCommon f node = node { runNodeCommon = f (runNodeCommon node)+                        , runNodeChildren = fmap (mapCommon f) (runNodeChildren node) }+++hideIfThresholdAbove :: Int -> RunNodeCommonFixed -> RunNodeCommonFixed+hideIfThresholdAbove visibilityThreshold node@(RunNodeCommonWithStatus {..}) =+  if | runTreeVisibilityLevel <= visibilityThreshold -> node { runTreeVisible = True }+     | otherwise -> node { runTreeVisible = False+                         , runTreeOpen = True -- Must be open so children have a chance to be seen+                         }++markClosed :: RunNodeCommonWithStatus s l Bool -> RunNodeCommonWithStatus s l Bool+markClosed node@(RunNodeCommonWithStatus {..}) = node { runTreeVisible = False }++hideClosed :: RunNodeWithStatus context s l Bool -> RunNodeWithStatus context s l Bool+hideClosed node@(RunNodeIt {}) = node+hideClosed (RunNodeIntroduce {..})+  | runTreeOpen runNodeCommon = RunNodeIntroduce { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }+  | otherwise = RunNodeIntroduce { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }+hideClosed (RunNodeIntroduceWith {..})+  | runTreeOpen runNodeCommon = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }+  | otherwise = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }+hideClosed node+  | runTreeOpen (runNodeCommon node) = node { runNodeChildren = fmap hideClosed (runNodeChildren node) }+  | otherwise = node { runNodeChildren = fmap (mapCommon markClosed) (runNodeChildren node) }+++treeToList :: (RunNodeFixed context, RunNode context) -> [MainListElem]+treeToList (nodeFixed, node) = L.zip (runReader (getCommonsWithVisibleDepth' nodeFixed) 0) (getCommons node)+  & L.filter (isVisible . fst . fst)+  & fmap commonToMainListElem+  where++    isVisible :: RunNodeCommonFixed -> Bool+    isVisible (RunNodeCommonWithStatus {..}) = runTreeVisible++    commonToMainListElem :: ((RunNodeCommonFixed, Int), RunNodeCommon) -> MainListElem+    commonToMainListElem ((RunNodeCommonWithStatus {..}, depth), common) = MainListElem {+      label = runTreeLabel+      , depth = depth+      , toggled = runTreeToggled+      , open = runTreeOpen+      , status = runTreeStatus+      , logs = runTreeLogs+      , visibilityLevel = runTreeVisibilityLevel+      , folderPath = runTreeFolder+      , node = common+      , ident = runTreeId+      }++getCommonsWithVisibleDepth' :: RunNodeWithStatus context s l t -> Reader Int [(RunNodeCommonWithStatus s l t, Int)]+getCommonsWithVisibleDepth' node@(RunNodeIt {}) = ask >>= \vd -> return [(runNodeCommon node, vd)]+getCommonsWithVisibleDepth' (RunNodeIntroduce {..}) = do+  let context = if runTreeVisible runNodeCommon then (local (+1)) else id+  rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'+  ask >>= \vd -> return ((runNodeCommon, vd) : rest)+getCommonsWithVisibleDepth' (RunNodeIntroduceWith {..}) = do+  let context = if runTreeVisible runNodeCommon then (local (+1)) else id+  rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'+  ask >>= \vd -> return ((runNodeCommon, vd) : rest)+getCommonsWithVisibleDepth' node = do+  let context = if runTreeVisible (runNodeCommon node) then (local (+1)) else id+  rest <- context $ (mconcat <$>) $ forM (runNodeChildren node) getCommonsWithVisibleDepth'+  ask >>= \vd -> return ((runNodeCommon node, vd) : rest)

@@ -0,0 +1,56 @@+-- |++module Test.Sandwich.Formatters.TerminalUI.Keys where++import qualified Data.List as L+import qualified Graphics.Vty as V++-- Column 1+nextKey = V.KChar 'n'+previousKey = V.KChar 'p'+nextFailureKey = V.KChar 'N'+previousFailureKey = V.KChar 'P'+closeNodeKey = V.KLeft+openNodeKey = V.KRight+toggleKeys = [V.KEnter, V.KChar '\t']++-- Column 2+cancelAllKey = V.KChar 'C'+cancelSelectedKey = V.KChar 'c'+runAllKey = V.KChar 'R'+runSelectedKey = V.KChar 'r'+clearAllKey = V.KChar 'K'+clearSelectedKey = V.KChar 'k'+openSelectedFolderInFileExplorer = V.KChar 'o'+openTestRootKey = V.KChar 'O'+openTestInEditorKey = V.KChar 't'+openFailureInEditorKey = V.KChar 'f'+openLogsInEditorKey = V.KChar 'l'++-- Column 3+cycleVisibilityThresholdKey = V.KChar 'v'+toggleShowRunTimesKey = V.KChar 'T'+toggleFileLocationsKey = V.KChar 'F'+toggleVisibilityThresholdsKey = V.KChar 'V'+debugKey = V.KChar 'd'+infoKey = V.KChar 'i'+warnKey = V.KChar 'w'+errorKey = V.KChar 'e'+exitKey = V.KChar 'q'++++-- Other++showKey (V.KChar '\t') = "Tab"+showKey (V.KChar c) = [c]+showKey V.KEnter = "Enter"+showKey _ = "?"++showKeys = L.intercalate "/" . fmap showKey++unKChar :: V.Key -> Char+unKChar (V.KChar c) = c+unKChar V.KLeft = '←'+unKChar V.KRight = '→'+unKChar _ = '?'

@@ -0,0 +1,48 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.Formatters.TerminalUI.OpenInEditor where++import Control.Applicative+import Data.Function+import qualified Data.Text as T+import GHC.Stack+import System.Environment+import System.Exit+import System.Process+++autoOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()+autoOpenInEditor terminalUIDefaultEditor debugFn (SrcLoc {..}) = do+  maybeEditor' <- lookupEnv "EDITOR"+  let maybeEditor = maybeEditor' <|> terminalUIDefaultEditor++  case maybeEditor of+    Nothing -> return ()+    Just editorString -> do+      let editor = editorString+                 & T.pack+                 & T.replace "LINE" (T.pack $ show srcLocStartLine)+                 & T.replace "COLUMN" (T.pack $ show srcLocStartCol)+                 & fillInFile+                 & T.unpack++      debugFn ("Opening editor with command: " <> T.pack editor)++      (_, _, _, p) <- createProcess ((shell editor) { delegate_ctlc = True })+      waitForProcess p >>= \case+        ExitSuccess -> return ()+        ExitFailure n -> debugFn ("Editor failed with exit code " <> T.pack (show n))++  where+    fillInFile cmd+      | "FILE" `T.isInfixOf` cmd = T.replace "FILE" (T.pack $ show srcLocFile) cmd+      | otherwise = cmd <> " '" <> T.pack srcLocFile <> "'"++-- elisp = [i|(progn+--              (x-focus-frame (selected-frame))+--              (raise-frame)+--              (recenter)+--              )|]

@@ -0,0 +1,120 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}++module Test.Sandwich.Formatters.TerminalUI.Types where++import qualified Brick.Widgets.List as L+import Control.Monad.Logger+import Data.Sequence+import qualified Data.Text as T+import Data.Time+import GHC.Stack+import Lens.Micro.TH+import Test.Sandwich.Formatters.TerminalUI.OpenInEditor+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+++-- | Initial settings for the TUI interface. All of these settings can be changed interactively.+data TerminalUIFormatter = TerminalUIFormatter {+  terminalUIVisibilityThreshold :: Int+  -- ^ The initial visibility threshold to use when the formatter starts.+  , terminalUIInitialFolding :: InitialFolding+  -- ^ The initial folding settings to use when the formatter starts.+  , terminalUIShowRunTimes :: Bool+  -- ^ Whether to show or hide run times.+  , terminalUIShowFileLocations :: Bool+  -- ^ Whether to show or hide the files in which tests are defined.+  , terminalUIShowVisibilityThresholds :: Bool+  -- ^ Whether to show or hide visibility thresholds next to nodes.+  , terminalUILogLevel :: Maybe LogLevel+  -- ^ Log level for test log displays.+  , terminalUIDefaultEditor :: Maybe String+  -- ^ Default value to use for the EDITOR environment variable when one is not provided.+  -- If 'Nothing' and EDITOR can't be found, edit commands will do nothing.+  --+  -- Here are some recommended values, depending on your preferred editor:+  --+  -- * Emacs: @export EDITOR="emacsclient --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@+  -- * Terminal Emacs: @export EDITOR="emacsclient -nw --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@+  -- * Vim: @export EDITOR="vim +LINE"@+  , terminalUIOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()+  -- ^ Callback to open a source location in your editor. By default, finds the command in the EDITOR environment variable+  -- and invokes it with the strings LINE, COLUMN, and FILE replaced with the line number, column, and file path.+  -- If FILE is not found in the string, it will be appended to the command after a space.+  -- It's also passed a debug callback that accepts a 'T.Text'; messages logged with this function will go into the formatter logs.+  }++data InitialFolding =+  InitialFoldingAllOpen+  | InitialFoldingAllClosed+  | InitialFoldingTopNOpen Int+  deriving (Show, Eq)++-- | Default settings for the terminal UI formatter.+defaultTerminalUIFormatter :: TerminalUIFormatter+defaultTerminalUIFormatter = TerminalUIFormatter {+  terminalUIVisibilityThreshold = 50+  , terminalUIInitialFolding = InitialFoldingAllOpen+  , terminalUIShowRunTimes = True+  , terminalUIShowFileLocations = False+  , terminalUIShowVisibilityThresholds = False+  , terminalUILogLevel = Just LevelWarn+  , terminalUIDefaultEditor = Just "emacsclient +LINE:COLUMN --no-wait"+  , terminalUIOpenInEditor = autoOpenInEditor+  }++data AppEvent = RunTreeUpdated [RunNodeFixed BaseContext]++instance Show AppEvent where+  show (RunTreeUpdated {}) = "<RunTreeUpdated>"++data MainListElem = MainListElem {+  label :: String+  , depth :: Int+  , toggled :: Bool+  , open :: Bool+  , status :: Status+  , logs :: Seq LogEntry+  , visibilityLevel :: Int+  , folderPath :: Maybe FilePath+  , node :: RunNodeCommon+  , ident :: Int+  }++data SomeRunNode = forall context s l t. SomeRunNode { unSomeRunNode :: RunNodeWithStatus context s l t }++data ClickableName = ColorBar | ListRow Int | MainList | InnerViewport T.Text+  deriving (Show, Ord, Eq)++data AppState = AppState {+  _appRunTreeBase :: [RunNode BaseContext]+  , _appRunTree :: [RunNodeFixed BaseContext]+  , _appMainList :: L.List ClickableName MainListElem+  , _appBaseContext :: BaseContext++  , _appStartTime :: UTCTime+  , _appTimeSinceStart :: NominalDiffTime++  , _appVisibilityThresholdSteps :: [Int]+  , _appVisibilityThreshold :: Int++  , _appLogLevel :: Maybe LogLevel+  , _appShowRunTimes :: Bool+  , _appShowFileLocations :: Bool+  , _appShowVisibilityThresholds :: Bool++  , _appOpenInEditor :: SrcLoc -> IO ()+  , _appDebug :: T.Text -> IO ()+  }++makeLenses ''AppState+++extractValues' :: (forall context s l t. RunNodeWithStatus context s l t -> a) -> SomeRunNode -> [a]+extractValues' f (SomeRunNode n@(RunNodeIt {})) = [f n]+extractValues' f (SomeRunNode n@(RunNodeIntroduce {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues' f (SomeRunNode n@(RunNodeIntroduceWith {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues' f (SomeRunNode n) = (f n) : (concatMap (extractValues f) (runNodeChildren n))

@@ -0,0 +1,33 @@+-- | Internal functionality exposed for sibling libraries such as sandwich-webdriver to use. Should not be used otherwise.++module Test.Sandwich.Internal (+  Spec+  , SpecFree+  , HasBaseContext+  , HasLabel+  , LabelValue(..)+  , (:>)(..)+  , ExampleM+  , ExampleT(..)++  -- For tests+  , RunNodeWithStatus(..)+  , RunNodeFixed+  , RunNode+  , RunNodeCommonWithStatus(..)+  , extractValues+  , extractValuesControlRecurse+  , getCommons+  , cancelNode+  , Status(..)+  , fixRunTree+  , waitForTree+  , SomeAsyncExceptionWithEq(..)+  , logEntryStr+  ) where++import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.RunTree+import Test.Sandwich.Shutdown+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec

@@ -0,0 +1,8 @@++module Test.Sandwich.Internal.Formatters (+  module Test.Sandwich.Formatters.Common.Count+  , module Test.Sandwich.Formatters.Common.Util+  ) where++import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util

@@ -0,0 +1,188 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}++module Test.Sandwich.Internal.Running where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Free+import Control.Monad.State+import Data.Char+import Data.Function+import qualified Data.List as L+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import System.Directory+import System.Exit+import System.FilePath+import Test.Sandwich.Interpreters.FilterTree+import Test.Sandwich.Interpreters.RunTree+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.Interpreters.StartTree+import Test.Sandwich.Options+import Test.Sandwich.TestTimer+import Test.Sandwich.Types.General+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer+import Test.Sandwich.Util+++startSandwichTree :: Options -> CoreSpec -> IO [RunNode BaseContext]+startSandwichTree options spec = do+  baseContext <- baseContextFromOptions options+  startSandwichTree' baseContext options spec++startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]+startSandwichTree' baseContext (Options {..}) spec' = do+  let spec = case optionsFilterTree of+        Nothing -> spec'+        Just (TreeFilter match) -> filterTree match spec'++  runTree <- atomically $ specToRunTreeVariable baseContext spec++  unless optionsDryRun $ do+    void $ async $ void $ runNodesSequentially runTree baseContext++  return runTree++runSandwichTree :: Options -> CoreSpec -> IO [RunNode BaseContext]+runSandwichTree options spec = do+  rts <- startSandwichTree options spec+  mapM_ waitForTree rts+  return rts++-- | For 0 repeats, repeat until a failure+runWithRepeat :: Int -> IO (ExitReason, Int) -> IO ()+runWithRepeat 0 action = do+  (_, numFailures) <- action+  if | numFailures == 0 -> runWithRepeat 0 action+     | otherwise -> exitFailure+-- | For 1 repeat, run once and return+runWithRepeat n action = do+  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n -> do+    (exitReason, numFailures) <- liftIO action++    modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1)++    if | exitReason == InterruptExit -> return ()+       | n > 0 -> loop (n - 1)+       | otherwise -> return ()++  putStrLn [i|#{successes} runs succeeded out of #{total} repeats|]++  when (successes /= total) $ exitFailure++baseContextFromOptions :: Options -> IO BaseContext+baseContextFromOptions options@(Options {..}) = do+  runRoot <- case optionsTestArtifactsDirectory of+    TestArtifactsNone -> return Nothing+    TestArtifactsFixedDirectory dir' -> do+      dir <- case isAbsolute dir' of+        True -> return dir'+        False -> do+          here <- getCurrentDirectory+          return $ here </> dir'++      createDirectoryIfMissing True dir+      return $ Just dir+    TestArtifactsGeneratedDirectory base' f -> do+      base <- case isAbsolute base' of+        True -> return base'+        False -> do+          here <- getCurrentDirectory+          return $ here </> base'++      name <- f+      let dir = base </> name+      createDirectoryIfMissing True dir+      return $ Just dir++  testTimer <- case (optionsTestTimerType, runRoot) of+    (SpeedScopeTestTimerType {..}, Just rr) -> liftIO $ newSpeedScopeTestTimer rr speedScopeTestTimerWriteRawTimings+    _ -> return NullTestTimer++  let errorSymlinksDir = (</> "errors") <$> runRoot+  whenJust errorSymlinksDir $ createDirectoryIfMissing True+  return $ BaseContext {+    baseContextPath = mempty+    , baseContextOptions = options+    , baseContextRunRoot = runRoot+    , baseContextErrorSymlinksDir = errorSymlinksDir+    , baseContextOnlyRunIds = Nothing+    , baseContextTestTimerProfile = defaultProfileName+    , baseContextTestTimer = testTimer+    }+++-- | Gather all node options from a spec+gatherNodeOptions :: Free (SpecCommand context m) r -> [NodeOptions]+gatherNodeOptions (Free x@(It'' {})) = (nodeOptions x) : gatherNodeOptions (next x)+gatherNodeOptions (Free (IntroduceWith'' {..})) = nodeOptions : (gatherNodeOptions next <> gatherNodeOptions subspecAugmented)+gatherNodeOptions (Free (Introduce'' {..})) = nodeOptions : (gatherNodeOptions next <> gatherNodeOptions subspecAugmented)+gatherNodeOptions (Free x) = (nodeOptions x) : (gatherNodeOptions (next x) <> gatherNodeOptions (subspec x))+gatherNodeOptions (Pure _) = []++gatherMainFunctions :: Free (SpecCommand context m) r -> [NodeModuleInfo]+gatherMainFunctions tests = gatherNodeOptions tests+                          & fmap nodeOptionsModuleInfo+                          & catMaybes++-- | TODO: get these automatically from mainCommandLineOptions+takenMainOptions :: [T.Text]+takenMainOptions = [+  "print", "tui", "silent", "auto"+  , "debug", "info", "warn", "error"+  , "filter"+  , "repeat"+  , "fixed-root"+  , "list-tests"++  , "print-slack-flags"++  , "print-webdriver-flags"+  , "headless"+  ]++gatherShorthands :: [NodeModuleInfo] -> [(NodeModuleInfo, T.Text)]+gatherShorthands = gatherShorthands' []+  where+    gatherShorthands' :: [T.Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, T.Text)]+    gatherShorthands' _ [] = []+    gatherShorthands' taken (x:xs) = (x, newShorthand) : (gatherShorthands' (newShorthand : taken) xs)+      where newShorthand = getShorthand taken x++    getShorthand :: [T.Text] -> NodeModuleInfo -> T.Text+    getShorthand taken nmi = head $ filter (\x -> x `notElem` taken && x `notElem` takenMainOptions) $ getCandidates nmi++    getCandidates :: NodeModuleInfo -> [T.Text]+    getCandidates (NodeModuleInfo {nodeModuleInfoModuleName=modName}) = candidates+      where parts = T.splitOn "." (T.pack modName)+            lastPart = last parts+            candidates = (toDashed lastPart) : [toDashed [i|#{lastPart}#{n}|] | n <- [(2 :: Integer)..]]++    toDashed :: T.Text -> T.Text+    toDashed t = t & T.unpack+                   & splitR isUpper+                   & fmap (T.toLower . T.pack)+                   & T.intercalate "-"++    splitR :: (Char -> Bool) -> String -> [String]+    splitR _ [] = []+    splitR p s =+      let+        go :: Char -> String -> [String]+        go m s' = case L.break p s' of+          (b', [])     -> [ m:b' ]+          (b', x:xs) -> ( m:b' ) : go x xs+      in case L.break p s of+        (b,  [])    -> [ b ]+        ([], h:t) -> go h t+        (b,  h:t) -> b : go h t

@@ -0,0 +1,38 @@++-- | Filter a spec tree using a string match++module Test.Sandwich.Interpreters.FilterTree (filterTree) where++import Control.Monad.Free+import qualified Data.List as L+import Test.Sandwich.Types.Spec++filterTree :: String -> Free (SpecCommand context m) () -> Free (SpecCommand context m) ()+filterTree match (Free (It'' loc no l ex next))+  | l `matches` match = Free (It'' loc no l ex (filterTree match next))+  | otherwise = filterTree match (filterTree match next)+filterTree match (Free (Introduce'' loc no l cl alloc cleanup subspec next))+  | l `matches` match = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTree match next))+  | otherwise = case filterTree match subspec of+      (Pure _) -> filterTree match next+      x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTree match next))+filterTree match (Free (IntroduceWith'' loc no l cl action subspec next))+  | l `matches` match = Free (IntroduceWith'' loc no l cl action subspec (filterTree match next))+  | otherwise = case filterTree match subspec of+      (Pure _) -> filterTree match next+      x -> Free (IntroduceWith'' loc no l cl action x (filterTree match next))+filterTree match (Free (Parallel'' loc no subspec next))+  | otherwise = case filterTree match subspec of+      (Pure _) -> filterTree match next+      x -> Free (Parallel'' loc no x (filterTree match next))+filterTree match (Free x)+  | label x `matches` match = Free (x { next = (filterTree match (next x)) })+  | otherwise = case filterTree match (subspec x) of+      (Pure _) -> filterTree match (next x)+      subspec' -> Free (x { subspec = subspec'+                          , next = (filterTree match (next x)) })+filterTree _ (Pure x) = Pure x+++matches :: String -> String -> Bool+matches l match = match `L.isInfixOf` l

@@ -0,0 +1,40 @@+{-# LANGUAGE RecordWildCards #-}++-- | Filter a spec tree to match a module++module Test.Sandwich.Interpreters.FilterTreeModule (filterTreeToModule) where++import Control.Monad.Free+import Test.Sandwich.Types.Spec+++filterTreeToModule :: String -> Free (SpecCommand context m) () -> Free (SpecCommand context m) ()+filterTreeToModule match (Free (It'' loc no l ex next))+  | no `matches` match = Free (It'' loc no l ex (filterTreeToModule match next))+  | otherwise = filterTreeToModule match (filterTreeToModule match next)+filterTreeToModule match (Free (Introduce'' loc no l cl alloc cleanup subspec next))+  | no `matches` match = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTreeToModule match next))+  | otherwise = case filterTreeToModule match subspec of+      (Pure _) -> filterTreeToModule match next+      x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTreeToModule match next))+filterTreeToModule match (Free (IntroduceWith'' loc no l cl action subspec next))+  | no `matches` match = Free (IntroduceWith'' loc no l cl action subspec (filterTreeToModule match next))+  | otherwise = case filterTreeToModule match subspec of+      (Pure _) -> filterTreeToModule match next+      x -> Free (IntroduceWith'' loc no l cl action x (filterTreeToModule match next))+filterTreeToModule match (Free (Parallel'' loc no subspec next))+  | otherwise = case filterTreeToModule match subspec of+      (Pure _) -> filterTreeToModule match next+      x -> Free (Parallel'' loc no x (filterTreeToModule match next))+filterTreeToModule match (Free x)+  | nodeOptions x `matches` match = Free (x { next = (filterTreeToModule match (next x)) })+  | otherwise = case filterTreeToModule match (subspec x) of+      (Pure _) -> filterTreeToModule match (next x)+      subspec' -> Free (x { subspec = subspec'+                          , next = (filterTreeToModule match (next x)) })+filterTreeToModule _ (Pure x) = Pure x+++matches :: NodeOptions -> String -> Bool+matches (NodeOptions {nodeOptionsModuleInfo=(Just (NodeModuleInfo {..}))}) match = nodeModuleInfoModuleName == match+matches _ _ = False

@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleInstances #-}++module Test.Sandwich.Interpreters.PrettyShow (prettyShow) where++import Control.Monad.Free+import qualified Data.List as L+import Test.Sandwich.Types.Spec+++-- | Pretty show a spec tree+prettyShow :: Free (SpecCommand context m) r -> String+prettyShow = prettyShow' 0++prettyShow' :: Int -> Free (SpecCommand context m) r -> String+prettyShow' indent (Free (Before'' _loc _no l _f subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (After'' _loc _no l _f subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (Introduce'' _loc _no l _cl _alloc _cleanup subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (IntroduceWith'' _loc _no l _cl _action subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (Around'' _loc _no l _f subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (Describe'' _loc _no l subspec next)) = showNode indent l subspec next+prettyShow' indent (Free (Parallel'' _loc _no subspec next)) = showNode indent "parallel" subspec next+prettyShow' indent (Free (It'' _loc _no l _ex next)) = showNode indent l ((return ()) :: Free (SpecCommand () m) ()) next+prettyShow' _ (Pure _) = ""++-- * Util++indentSize :: Int+indentSize = 2++showNode :: Int -> String -> Free (SpecCommand c m) r -> Free (SpecCommand c' m) r' -> String+showNode indent label subspec next = L.intercalate "\n" $ filter (/= "") [+  (L.replicate indent ' ') <> label+  , prettyShow' (indent + indentSize) subspec+  , prettyShow' indent next+  ]

@@ -0,0 +1,135 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE QuasiQuotes #-}++module Test.Sandwich.Interpreters.RunTree (+  specToRunTree+  , specToRunTreeVariable+  , isEmptySpec+  ) where++import Control.Concurrent.STM+import Control.Monad.Free+import Control.Monad.Trans.RWS+import Data.Functor.Identity+import qualified Data.List as L+import Data.Sequence+import GHC.Stack+import System.FilePath+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++specToRunTree :: BaseContext -> Free (SpecCommand BaseContext IO) () -> [RunNodeFixed BaseContext]+specToRunTree baseContext spec = runIdentity $ specToRunTreeM baseContext spec++specToRunTreeVariable :: BaseContext -> Free (SpecCommand BaseContext IO) () -> STM [RunNode BaseContext]+specToRunTreeVariable bc spec = mapM unFixRunTree $ specToRunTree bc spec++isEmptySpec :: forall context. Free (SpecCommand context IO) () -> Bool+isEmptySpec spec = L.null ret+  where context = RunTreeContext {+          runTreeIndexInParent = 0+          , runTreeNumSiblings = 0+          , runTreeCurrentAncestors = mempty+          , runTreeCurrentFolder = Nothing+          }+        (ret, _, _) = runIdentity $ runRWST (specToRunTree' spec) context 0++specToRunTreeM :: (Monad m) => BaseContext -> Free (SpecCommand BaseContext IO) () -> m [RunNodeFixed BaseContext]+specToRunTreeM baseContext spec = do+  let context = RunTreeContext {+        runTreeIndexInParent = 0+        , runTreeNumSiblings = countChildren spec+        , runTreeCurrentAncestors = mempty+        , runTreeCurrentFolder = (</> "results") <$> baseContextRunRoot baseContext+        }+  (ret, _, _) <- runRWST (specToRunTree' spec) context 0+  return ret++-- | Convert a spec to a run tree+specToRunTree' :: (Monad m) => Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]+specToRunTree'  (Free (Before'' loc no l f subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeBefore common <$> recurse l no common subspec <*> pure f+specToRunTree'  (Free (After'' loc no l f subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeAfter common <$> recurse l no common subspec <*> pure f+specToRunTree'  (Free (Introduce'' loc no l _cl alloc cleanup subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeIntroduce common <$> recurse l no common subspec <*> pure alloc <*> pure cleanup+specToRunTree'  (Free (IntroduceWith'' loc no l _cl action subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeIntroduceWith common <$> recurse l no common subspec <*> pure action+specToRunTree'  (Free (Around'' loc no l actionWith subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeAround common <$> recurse l no common subspec <*> pure actionWith+specToRunTree'  (Free (Describe'' loc no l subspec next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeDescribe common <$> recurse l no common subspec+specToRunTree'  (Free (Parallel'' loc no subspec next)) = do+  common <- getCommon "Parallel" loc no+  continueWith next =<< RunNodeParallel common <$> recurse "Parallel" no common subspec+specToRunTree'  (Free (It'' loc no l example next)) = do+  common <- getCommon l loc no+  continueWith next =<< RunNodeIt common <$> pure example+specToRunTree'  (Pure _) = return []+++-- * Util++type ConvertM m = RWST RunTreeContext () Int m++getCommon :: (Monad m) => String -> Maybe SrcLoc -> NodeOptions -> ConvertM m RunNodeCommonFixed+getCommon l srcLoc (NodeOptions {..}) = do+  RunTreeContext {..} <- ask++  -- Get a unique ID for this node+  ident <- get+  modify (+1)++  return $ RunNodeCommonWithStatus {+    runTreeLabel = l+    , runTreeId = ident+    , runTreeAncestors = runTreeCurrentAncestors |> ident+    , runTreeToggled = False+    , runTreeOpen = True+    , runTreeStatus = NotStarted+    , runTreeVisible = True+    , runTreeFolder = case (nodeOptionsCreateFolder, runTreeCurrentFolder) of+        (True, Just f) -> Just (f </> (nodeToFolderName l runTreeNumSiblings runTreeIndexInParent))+        _ -> Nothing+    , runTreeVisibilityLevel = nodeOptionsVisibilityThreshold+    , runTreeRecordTime = nodeOptionsRecordTime+    , runTreeLogs = mempty+    , runTreeLoc = srcLoc+    }++continueWith :: (Monad m) => Free (SpecCommand context IO) r -> RunNodeFixed context -> ConvertM m [RunNodeFixed context]+continueWith next node = do+  rest <- local (\rtc -> rtc { runTreeIndexInParent = (runTreeIndexInParent rtc) + 1 }) $ specToRunTree' next+  return (node : rest)++recurse :: (Monad m) => String -> NodeOptions -> RunNodeCommonFixed -> Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]+recurse l (NodeOptions {..}) (RunNodeCommonWithStatus {..}) subspec = local+  (\rtc ->+     if | nodeOptionsCreateFolder ->+          rtc { runTreeCurrentFolder = case runTreeCurrentFolder rtc of+                  Nothing -> Nothing+                  Just f -> Just (f </> (nodeToFolderName l (runTreeNumSiblings rtc) (runTreeIndexInParent rtc)))+              , runTreeIndexInParent = 0+              , runTreeNumSiblings = countImmediateFolderChildren subspec+              , runTreeCurrentAncestors = runTreeAncestors+              }+        | otherwise ->+          rtc { runTreeCurrentAncestors = runTreeAncestors }+  )+  (specToRunTree' subspec)

@@ -0,0 +1,39 @@+-- |++module Test.Sandwich.Interpreters.RunTree.Logging (+  logToMemory+  , logToMemoryAndFile+  , LogFn+  , LogEntryFormatter+  ) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Logger+import qualified Data.ByteString.Char8 as BS8+import Data.Sequence+import Data.Time.Clock+import System.IO+import Test.Sandwich.Types.RunTree++logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()+logToMemory Nothing _ _ _ _ _ = return ()+logToMemory (Just minLevel) logs loc logSrc logLevel logStr =+  when (logLevel >= minLevel) $ do+    ts <- getCurrentTime+    atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)++logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()+logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do+  maybeTs <- case maybeMemLogLevel of+    Just x | x <= logLevel -> do+      ts <- getCurrentTime+      atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)+      return $ Just ts+    _ -> return Nothing++  case maybeSavedLogLevel of+    Just x | x <= logLevel -> do+      ts <- maybe getCurrentTime return maybeTs+      BS8.hPutStr h $ formatter ts loc logSrc logLevel logStr+    _ -> return ()

@@ -0,0 +1,101 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.Interpreters.RunTree.Util where++import Control.Concurrent.STM+import Control.Monad.Free+import Control.Monad.Logger+import qualified Data.List as L+import Data.Sequence as Seq hiding ((:>))+import Data.String.Interpolate+import Data.Time.Clock+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Text.Printf+++-- | Wait for a tree, catching any synchronous exceptions and returning them as a list+waitForTree :: RunNode context -> IO Result+waitForTree node = atomically $+  readTVar (runTreeStatus $ runNodeCommon node) >>= \case+    Done {statusResult} -> return statusResult+    NotStarted {} -> retry+    Running {} -> retry++-- | Append a log message outside of ExampleT. Only stored to in-memory logs, not disk.+-- Only for debugging the interpreter, should not be exposed.+appendLogMessage :: ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()+appendLogMessage logs msg = do+  ts <- getCurrentTime+  atomically $ modifyTVar logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg))++getImmediateChildren :: Free (SpecCommand context m) () -> [Free (SpecCommand context m) ()]+getImmediateChildren (Free (It'' loc no l ex next)) = (Free (It'' loc no l ex (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (Before'' loc no l f subspec next)) = (Free (Before'' loc no l f subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (After'' loc no l f subspec next)) = (Free (After'' loc no l f subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (Introduce'' loc no l cl alloc cleanup subspec next)) = (Free (Introduce'' loc no l cl alloc cleanup subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (IntroduceWith'' loc no l cl action subspec next)) = (Free (IntroduceWith'' loc no l cl action subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (Around'' loc no l f subspec next)) = (Free (Around'' loc no l f subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (Describe'' loc no l subspec next)) = (Free (Describe'' loc no l subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Free (Parallel'' loc no subspec next)) = (Free (Parallel'' loc no subspec (Pure ()))) : getImmediateChildren next+getImmediateChildren (Pure ()) = [Pure ()]++countChildren :: Free (SpecCommand context m) () -> Int+countChildren = L.length . getImmediateChildren++countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int+countImmediateFolderChildren (Free (It'' _loc no _l _ex next))+  | nodeOptionsCreateFolder no = 1 + countImmediateFolderChildren next+  | otherwise = countImmediateFolderChildren next+countImmediateFolderChildren (Free (Introduce'' _loc no _l _cl _alloc _cleanup subspec next))+  | nodeOptionsCreateFolder no = 1 + countImmediateFolderChildren next+  | otherwise = countImmediateFolderChildren subspec + countImmediateFolderChildren next+countImmediateFolderChildren (Free (IntroduceWith'' _loc no _l _cl _action subspec next))+  | nodeOptionsCreateFolder no = 1 + countImmediateFolderChildren next+  | otherwise = countImmediateFolderChildren subspec + countImmediateFolderChildren next+countImmediateFolderChildren (Free node)+  | nodeOptionsCreateFolder (nodeOptions node) = 1 + countImmediateFolderChildren (next node)+  | otherwise = countImmediateFolderChildren (subspec node) + countImmediateFolderChildren (next node)+countImmediateFolderChildren (Pure _) = 0++maxFileNameLength :: Int+maxFileNameLength = 150++nodeToFolderName :: String -> Int -> Int -> String+nodeToFolderName name 1 0 = truncateFileNameToLength maxFileNameLength $ fixupName name+nodeToFolderName name numSiblings indexInParent = padding <> truncateFileNameToLength (maxFileNameLength - (L.length padding)) (fixupName name)+  where+    paddingNeeded+      | numSiblings < 10 = 1+      | numSiblings < 100 = 2+      | numSiblings < 1000 = 3+      | numSiblings < 10000 = 4+      | numSiblings < 100000 = 5+      | numSiblings < 1000000 = 6+      | numSiblings < 10000000 = 7+      | numSiblings < 100000000 = 8+      | otherwise = 15++    paddedNumber = printf [i|%0#{paddingNeeded :: Int}d|] indexInParent++    padding = if | numSiblings == 1 -> ""+                 | otherwise -> paddedNumber <> "_"++fixupName = replace '/' '_'++replace :: Eq a => a -> a -> [a] -> [a]+replace a b = map $ \c -> if c == a then b else c++truncateFileNameToLength :: Int -> String -> String+truncateFileNameToLength len x | L.length x <= len = x+truncateFileNameToLength len x = "..." <> (takeEnd (len - 3) x)++takeEnd :: Int -> [a] -> [a]+takeEnd j xs = f xs (L.drop j xs)+  where f (_:zs) (_:ys) = f zs ys+        f zs _ = zs

@@ -0,0 +1,323 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Sandwich.Interpreters.StartTree (+  startTree+  , runNodesSequentially+  ) where+++import Control.Concurrent.Async+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Reader+import Data.IORef+import qualified Data.List as L+import Data.Sequence hiding ((:>))+import qualified Data.Set as S+import Data.String.Interpolate+import qualified Data.Text as T+import Data.Time.Clock+import Data.Typeable+import GHC.Stack+import System.Directory+import System.FilePath+import System.IO+import Test.Sandwich.Formatters.Print+import Test.Sandwich.Formatters.Print.CallStacks+import Test.Sandwich.Formatters.Print.FailureReason+import Test.Sandwich.Formatters.Print.Logs+import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Interpreters.RunTree.Logging+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.RunTree+import Test.Sandwich.TestTimer+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer+import Test.Sandwich.Util+++baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext+baseContextFromCommon (RunNodeCommonWithStatus {..}) bc@(BaseContext {}) =+  bc { baseContextPath = runTreeFolder }++startTree :: (MonadIO m, HasBaseContext context) => RunNode context -> context -> m (Async Result)+startTree node@(RunNodeBefore {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|])) >>= \case+      result@(Failure fr@(Pending {..})) -> do+        markAllChildrenWithResult runNodeChildren ctx (Failure fr)+        return result+      result@(Failure fr) -> do+        markAllChildrenWithResult runNodeChildren ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException fr))+        return result+      Success -> do+        void $ runNodesSequentially runNodeChildren ctx+        return Success+startTree node@(RunNodeAfter {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    result <- liftIO $ newIORef Success+    finally (void $ runNodesSequentially runNodeChildren ctx)+            ((runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|])) >>= writeIORef result)+    liftIO $ readIORef result+startTree node@(RunNodeIntroduce {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    result <- liftIO $ newIORef Success+    bracket (do+                let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e)+                flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $+                  runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]))+            (\case+                Left failureReason -> writeIORef result (Failure failureReason)+                Right intro ->+                  (runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])) >>= writeIORef result+            )+            (\case+                Left failureReason@(Pending {}) -> do+                  -- TODO: add note about failure in allocation+                  markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)+                Left failureReason -> do+                  -- TODO: add note about failure in allocation+                  markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason))+                Right intro -> do+                  -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.+                  -- It would be better to track the profile at the type level+                  let ctxFinal = case cast intro of+                        Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t })+                        Nothing -> ctx++                  void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal)+            )+    readIORef result+startTree node@(RunNodeIntroduceWith {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  didRunWrappedAction <- liftIO $ newIORef (Left ())+  runInAsync node ctx $ do+    let wrappedAction = do+          let failureResult e = case fromException e of+                Just fr@(Pending {}) -> Failure fr+                _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|]+          flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do+            runNodeIntroduceAction $ \intro -> do+              results <- liftIO $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctx)+              liftIO $ writeIORef didRunWrappedAction (Right results)+              return results++          (liftIO $ readIORef didRunWrappedAction) >>= \case+            Left () -> return $ Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|]+            Right _ -> return Success+    runExampleM'' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])+startTree node@(RunNodeAround {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  didRunWrappedAction <- liftIO $ newIORef (Left ())+  runInAsync node ctx $ do+    let wrappedAction = do+          let failureResult e = case fromException e of+                Just fr@(Pending {}) -> Failure fr+                _ -> Failure $ Reason Nothing [i|around #{runTreeLabel} handler threw exception|]+          flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildren ctx (failureResult e)) $ do+            runNodeActionWith $ do+              results <- liftIO $ runNodesSequentially runNodeChildren ctx+              liftIO $ writeIORef didRunWrappedAction (Right results)+              return results++          (liftIO $ readIORef didRunWrappedAction) >>= \case+            Left () -> return $ Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|]+            Right _ -> return Success+    runExampleM'' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])+startTree node@(RunNodeDescribe {..}) ctx' = do+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    ((L.length . L.filter isFailure) <$> runNodesSequentially runNodeChildren ctx) >>= \case+      0 -> return Success+      n -> return $ Failure (Reason Nothing [i|#{n} #{if n == 1 then ("child" :: T.Text) else "children"} failed|])+startTree node@(RunNodeParallel {..}) ctx' = do+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeChildren ctx) >>= \case+      0 -> return Success+      n -> return $ Failure (Reason Nothing [i|#{n} #{if n == 1 then ("child" :: T.Text) else "children"} failed|])+startTree node@(RunNodeIt {..}) ctx' = do+  let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon+  runInAsync node ctx $ do+    runExampleM runNodeExample ctx (runTreeLogs runNodeCommon) Nothing++-- * Util++runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context -> IO Result -> m (Async Result)+runInAsync node ctx action = do+  let RunNodeCommonWithStatus {..} = runNodeCommon node+  let bc@(BaseContext {..}) = getBaseContext ctx+  let timerFn = case runTreeRecordTime of+        True -> timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel)+        _ -> id+  startTime <- liftIO getCurrentTime+  mvar <- liftIO newEmptyMVar+  myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do+    flip withException (recordExceptionInStatus runTreeStatus) $ unmask $ do+      readMVar mvar+      result <- timerFn action+      endTime <- liftIO getCurrentTime+      liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime endTime result++      whenFailure result $ \reason -> do+        -- Make sure the folder exists, if configured+        whenJust baseContextPath $ createDirectoryIfMissing True++        -- Create error symlink when configured to+        case node of+          RunNodeDescribe {} -> return () -- These are just noisy so don't create them+          RunNodeParallel {} -> return () -- These are just noisy so don't create them+          _ -> do+            whenJust baseContextErrorSymlinksDir $ \errorsDir ->+              whenJust baseContextPath $ \dir -> do+                whenJust baseContextRunRoot $ \runRoot -> do+                  -- Get a relative path from the error dir to the results dir. System.FilePath doesn't want to+                  -- introduce ".." components, so we have to do it ourselves+                  let errorDirDepth = L.length $ splitPath $ makeRelative runRoot errorsDir+                  let relativePath = joinPath (L.replicate errorDirDepth "..") </> (makeRelative runRoot dir)++                  let symlinkBaseName = case runTreeLoc of+                        Nothing -> takeFileName dir+                        Just loc -> [i|#{srcLocFile loc}:#{srcLocStartLine loc}_#{takeFileName dir}|]+                  let symlinkPath = errorsDir </> (nodeToFolderName symlinkBaseName 9999999 runTreeId)++                  -- Delete the symlink if it's already present. This can happen when re-running+                  -- a previously failed test+                  exists <- doesPathExist symlinkPath+                  when exists $ removePathForcibly symlinkPath++                  liftIO $ createDirectoryLink relativePath symlinkPath++        -- Write failure info+        whenJust baseContextPath $ \dir -> do+          withFile (dir </> "failure.txt") AppendMode $ \h -> do+            -- Use the PrintFormatter to format failure.txt nicely+            let pf = defaultPrintFormatter {+                  printFormatterUseColor = False+                  , printFormatterLogLevel = Just LevelDebug+                  , printFormatterIncludeCallStacks = True+                  }+            flip runReaderT (pf, 0, h) $ do+              printFailureReason reason+              whenJust (failureCallStack reason) $ \cs -> do+                p "\n"+                printCallStack cs+              p "\n"+              printLogs runTreeLogs++      return result+  liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime myAsync+  liftIO $ putMVar mvar ()+  return myAsync  -- TODO: fix race condition with writing to runTreeStatus (here and above)++-- | Run a list of children sequentially, cancelling everything on async exception TODO+runNodesSequentially :: HasBaseContext context => [RunNode context] -> context -> IO [Result]+runNodesSequentially children ctx =+  flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $+    forM (L.filter (shouldRunChild ctx) children) $ \child ->+      startTree child ctx >>= wait++-- | Run a list of children sequentially, cancelling everything on async exception TODO+runNodesConcurrently :: HasBaseContext context => [RunNode context] -> context -> IO [Result]+runNodesConcurrently children ctx =+  flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $+    mapM wait =<< sequence [startTree child ctx+                           | child <- L.filter (shouldRunChild ctx) children]++markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m ()+markAllChildrenWithResult children baseContext status = do+  now <- liftIO getCurrentTime+  forM_ (L.filter (shouldRunChild' baseContext) $ concatMap getCommons children) $ \child ->+    liftIO $ atomically $ writeTVar (runTreeStatus child) (Done now now status)++cancelAllChildrenWith :: [RunNode context] -> SomeAsyncException -> IO ()+cancelAllChildrenWith children e = do+  forM_ children $ \node ->+    readTVarIO (runTreeStatus $ runNodeCommon node) >>= \case+      Running {..} -> cancelWith statusAsync e+      NotStarted -> do+        now <- getCurrentTime+        let reason = GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq e)+        atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now (Failure reason))+      _ -> return ()++shouldRunChild :: (HasBaseContext ctx) => ctx -> RunNodeWithStatus context s l t -> Bool+shouldRunChild ctx node = shouldRunChild' ctx (runNodeCommon node)++shouldRunChild' :: (HasBaseContext ctx) => ctx -> RunNodeCommonWithStatus s l t -> Bool+shouldRunChild' ctx common = case baseContextOnlyRunIds $ getBaseContext ctx of+  Nothing -> True+  Just ids -> (runTreeId common) `S.member` ids++-- * Running examples++runExampleM :: HasBaseContext r => ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result+runExampleM ex ctx logs exceptionMessage = runExampleM' ex ctx logs exceptionMessage >>= \case+  Left err -> return $ Failure err+  Right () -> return Success++runExampleM'' :: HasBaseContext r => ExampleM r Result -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result+runExampleM'' ex ctx logs exceptionMessage = runExampleM' ex ctx logs exceptionMessage >>= \case+  Left err -> return $ Failure err+  Right x -> return x++runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)+runExampleM' ex ctx logs exceptionMessage = do+  maybeTestDirectory <- getTestDirectory ctx+  let options = baseContextOptions $ getBaseContext ctx++  handleAny (wrapInFailureReasonIfNecessary exceptionMessage) $+    withLogFn maybeTestDirectory options $ \logFn ->+      (Right <$> (runLoggingT (runReaderT (unExampleT ex) ctx) logFn))++  where+    withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a+    withLogFn Nothing (Options {..}) action = action (logToMemory optionsSavedLogLevel logs)+    withLogFn (Just logPath) (Options {..}) action = withFile (logPath </> "test_logs.txt") AppendMode $ \h -> do+      hSetBuffering h LineBuffering+      action (logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)++    getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)+    getTestDirectory (getBaseContext -> (BaseContext {..})) = case baseContextPath of+      Nothing -> return Nothing+      Just dir -> do+        createDirectoryIfMissing True dir+        return $ Just dir++    wrapInFailureReasonIfNecessary :: Maybe String -> SomeException -> IO (Either FailureReason a)+    wrapInFailureReasonIfNecessary msg e = return $ Left $ case fromException e of+      Just (x :: FailureReason) -> x+      _ -> case fromException e of+        Just (SomeExceptionWithCallStack e cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e))+        _ -> GotException Nothing msg (SomeExceptionWithEq e)++recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()+recordExceptionInStatus status e = do+  endTime <- liftIO getCurrentTime+  let ret = case fromException e of+        Just (e' :: SomeAsyncException) -> Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq e'))+        _ -> case fromException e of+          Just (e' :: FailureReason) -> Failure e'+          _ -> Failure (GotException Nothing Nothing (SomeExceptionWithEq e))+  liftIO $ atomically $ modifyTVar status $ \case+    Running {statusStartTime} -> Done statusStartTime endTime ret+    _ -> Done endTime endTime ret

@@ -0,0 +1,98 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Logging functions.++module Test.Sandwich.Logging where++import Control.Concurrent.Async.Lifted+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Control (MonadBaseControl)+import Data.String.Interpolate+import Data.Text+import GHC.Stack+import System.Exit+import System.IO+import System.Process+++-- * Basic logging functions+++-- | Log a message at level 'LevelDebug'.+debug :: (HasCallStack, MonadLogger m) => Text -> m ()+debug = logDebugCS callStack++-- | Log a message at level 'LevelInfo'.+info :: (HasCallStack, MonadLogger m) => Text -> m ()+info = logInfoCS callStack++-- | Log a message at level 'LevelWarn'.+warn :: (HasCallStack, MonadLogger m) => Text -> m ()+warn = logWarnCS callStack++-- | Log a message at level 'LevelError'.+logError :: (HasCallStack, MonadLogger m) => Text -> m ()+logError = logErrorCS callStack++-- | Log with a custom 'LogLevel'.+logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Text -> m ()+logOther = logOtherCS callStack+++-- * System.Process helpers+--+-- | Functions for launching processes while capturing their output in the logs.++-- | Spawn a process with its stdout and stderr connected to the logging system. Every line output by the process+-- will be fed to a 'debug' call.+createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle+createProcessWithLogging cp = do+  (hRead, hWrite) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  _ <- async $ forever $ do+    line <- liftIO $ hGetLine hRead+    debug [i|#{name}: #{line}|]++  (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })+  return p++-- | Same as 'createProcessWithLogging', but using 'readCreateProcess'.+readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String+readCreateProcessWithLogging cp input = do+  (hRead, hWrite) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  _ <- async $ forever $ do+    line <- liftIO $ hGetLine hRead+    debug [i|#{name}: #{line}|]++  liftIO $ readCreateProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite }) input++-- | Higher level version of 'readCreateProcessWithLogging', accepting a shell command.+callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()+callCommandWithLogging cmd = do+  (hRead, hWrite) <- liftIO createPipe++  (_, _, _, p) <- liftIO $ createProcess (shell cmd) { delegate_ctlc = True+                                                     , std_out = UseHandle hWrite+                                                     , std_err = UseHandle hWrite }++  _ <- async $ forever $ do+    line <- liftIO $ hGetLine hRead+    debug [i|#{cmd}: #{line}|]++  liftIO (waitForProcess p) >>= \case+    ExitSuccess -> return ()+    ExitFailure r -> liftIO $ throw $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]

@@ -0,0 +1,51 @@++-- | Miscellaneous exports that need to be exposed, but aren't super interesting.+-- Gathered here to avoid cluttering other files.++module Test.Sandwich.Misc (+  -- * The example monad+  ExampleT+  , ExampleM++  -- * Spec types+  , Spec+  , SpecFree+  , CoreSpec+  , TopSpec+  , TopSpecWithOptions+  , TopSpecWithOptions'+  , isEmptySpec++  -- * Command line options+  , CommandLineOptions(..)+  , CommandLineSlackOptions(..)+  , CommandLineWebdriverOptions(..)+  , BrowserToUse(..)+  , DisplayType(..)+  , commandLineOptionsWithInfo++  -- * Labels+  , Label(..)+  , LabelValue(..)+  , HasLabel+  , (:>)++  -- * Context classes+  , BaseContext+  , HasBaseContext+  , HasCommandLineOptions++  -- * Result types+  , Result(..)+  , FailureReason(..)+  , SomeExceptionWithCallStack(..)+  , SomeExceptionWithEq(..)+  , ExitReason(..)+  ) where++import Test.Sandwich.ArgParsing+import Test.Sandwich.Interpreters.RunTree+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.General+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec

@@ -0,0 +1,29 @@++-- | This module exports the special "primed" versions of the test tree nodes. These primed versions accept an additional options argument, which allows you to do things like control the visibility thresholds of the nodes.++module Test.Sandwich.Nodes (+  -- * Basic nodes+  it'+  , describe'+  , parallel'++  -- * Node options+  , NodeOptions+  , defaultNodeOptions+  , nodeOptionsVisibilityThreshold+  , nodeOptionsCreateFolder+  , nodeOptionsRecordTime++  -- * Context manager nodes+  , introduce'+  , introduceWith'+  , before'+  , beforeEach'+  , after'+  , afterEach'+  , around'+  , aroundEach'++  ) where++import Test.Sandwich.Types.Spec

@@ -0,0 +1,48 @@++module Test.Sandwich.Options (+  Options+  , defaultOptions++  -- * Artifacts+  , optionsTestArtifactsDirectory+  , TestArtifactsDirectory(..)++  -- * Logging+  , optionsSavedLogLevel+  , optionsMemoryLogLevel+  , optionsLogFormatter+  , LogEntryFormatter++  -- * Formatting+  , optionsFormatters+  , SomeFormatter(..)+  , Formatter(..)++  -- * Filtering+  , optionsFilterTree+  , TreeFilter(..)++  -- * Timing+  , optionsTestTimerType++  -- * Misc+  , optionsProjectRoot+  ) where++import Control.Monad.Logger+import Test.Sandwich.Formatters.Print+import Test.Sandwich.Types.RunTree++-- | A reasonable default set of options.+defaultOptions :: Options+defaultOptions = Options {+  optionsTestArtifactsDirectory = TestArtifactsNone+  , optionsSavedLogLevel = Just LevelDebug+  , optionsMemoryLogLevel = Just LevelDebug+  , optionsLogFormatter = defaultLogEntryFormatter+  , optionsFilterTree = Nothing+  , optionsDryRun = False+  , optionsFormatters = [SomeFormatter defaultPrintFormatter]+  , optionsProjectRoot = Nothing+  , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False }+  }

@@ -0,0 +1,144 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Test.Sandwich.RunTree where++import Control.Concurrent.STM+import GHC.Stack+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++extractValues :: (forall context. RunNodeWithStatus context s l t -> a) -> RunNodeWithStatus context s l t -> [a]+extractValues f node@(RunNodeIt {}) = [f node]+extractValues f node@(RunNodeIntroduce {runNodeChildrenAugmented}) = (f node) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues f node@(RunNodeIntroduceWith {runNodeChildrenAugmented}) = (f node) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues f node = (f node) : (concatMap (extractValues f) (runNodeChildren node))++extractValuesControlRecurse :: (forall context. RunNodeWithStatus context s l t -> (Bool, a)) -> RunNodeWithStatus context s l t -> [a]+extractValuesControlRecurse f node@(RunNodeIt {}) = [snd $ f node]+extractValuesControlRecurse f node@(RunNodeIntroduce {runNodeChildrenAugmented}) = case f node of+  (True, x) -> x : (concatMap (extractValuesControlRecurse f) runNodeChildrenAugmented)+  (False, x) -> [x]+extractValuesControlRecurse f node@(RunNodeIntroduceWith {runNodeChildrenAugmented}) = case f node of+  (True, x) -> x : (concatMap (extractValuesControlRecurse f) runNodeChildrenAugmented)+  (False, x) -> [x]+extractValuesControlRecurse f node = case f node of+  (True, x) -> x : (concatMap (extractValuesControlRecurse f) (runNodeChildren node))+  (False, x) -> [x]++getCommons :: RunNodeWithStatus context s l t -> [RunNodeCommonWithStatus s l t]+getCommons = extractValues runNodeCommon++fixRunTree :: RunNode context -> STM (RunNodeFixed context)+fixRunTree node@(runNodeCommon -> (RunNodeCommonWithStatus {..})) = do+  status <- readTVar runTreeStatus+  logs <- readTVar runTreeLogs+  toggled <- readTVar runTreeToggled+  open <- readTVar runTreeOpen++  let common' = RunNodeCommonWithStatus {+        runTreeStatus = status+        , runTreeLogs = logs+        , runTreeToggled = toggled+        , runTreeOpen = open+        , ..+        }++  case node of+    RunNodeBefore {..} -> do+      children <- mapM fixRunTree runNodeChildren+      return $ RunNodeBefore { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeAfter {..} -> do+      children <- mapM fixRunTree runNodeChildren+      return $ RunNodeAfter { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeIntroduce {..} -> do+      children <- mapM fixRunTree runNodeChildrenAugmented+      return $ RunNodeIntroduce { runNodeCommon=common', runNodeChildrenAugmented=children, .. }+    RunNodeIntroduceWith {..} -> do+      children <- mapM fixRunTree runNodeChildrenAugmented+      return $ RunNodeIntroduceWith { runNodeCommon=common', runNodeChildrenAugmented=children, .. }+    RunNodeAround {..} -> do+      children <- mapM fixRunTree runNodeChildren+      return $ RunNodeAround { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeDescribe {..} -> do+      children <- mapM fixRunTree runNodeChildren+      return $ RunNodeDescribe { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeParallel {..} -> do+      children <- mapM fixRunTree runNodeChildren+      return $ RunNodeParallel { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeIt {..} -> do+      return $ RunNodeIt { runNodeCommon=common', .. }++unFixRunTree :: RunNodeFixed context -> STM (RunNode context)+unFixRunTree node@(runNodeCommon -> (RunNodeCommonWithStatus {..})) = do+  status <- newTVar runTreeStatus+  logs <- newTVar runTreeLogs+  toggled <- newTVar runTreeToggled+  open <- newTVar runTreeOpen++  let common' = RunNodeCommonWithStatus {+        runTreeStatus = status+        , runTreeLogs = logs+        , runTreeToggled = toggled+        , runTreeOpen = open+        , ..+        }++  case node of+    RunNodeBefore {..} -> do+      children <- mapM unFixRunTree runNodeChildren+      return $ RunNodeBefore { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeAfter {..} -> do+      children <- mapM unFixRunTree runNodeChildren+      return $ RunNodeAfter { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeIntroduce {..} -> do+      children <- mapM unFixRunTree runNodeChildrenAugmented+      return $ RunNodeIntroduce { runNodeCommon=common', runNodeChildrenAugmented=children, .. }+    RunNodeIntroduceWith {..} -> do+      children <- mapM unFixRunTree runNodeChildrenAugmented+      return $ RunNodeIntroduceWith { runNodeCommon=common', runNodeChildrenAugmented=children, .. }+    RunNodeAround {..} -> do+      children <- mapM unFixRunTree runNodeChildren+      return $ RunNodeAround { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeDescribe {..} -> do+      children <- mapM unFixRunTree runNodeChildren+      return $ RunNodeDescribe { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeParallel {..} -> do+      children <- mapM unFixRunTree runNodeChildren+      return $ RunNodeParallel { runNodeCommon=common', runNodeChildren=children, .. }+    RunNodeIt {..} -> do+      return $ RunNodeIt { runNodeCommon=common', .. }+++getCallStackFromStatus :: Status -> Maybe CallStack+getCallStackFromStatus Done {statusResult=(Failure reason)} = failureCallStack reason+getCallStackFromStatus _ = Nothing++isDone :: Status -> Bool+isDone (Done {}) = True+isDone _ = False++isRunning :: Status -> Bool+isRunning (Running {}) = True+isRunning _ = False++isFailureStatus :: Status -> Bool+isFailureStatus (Done _ _ stat) = isFailure stat+isFailureStatus _ = False++isFailure :: Result -> Bool+isFailure (Failure (Pending {})) = False+isFailure (Failure {}) = True+isFailure _ = False++isPending :: Result -> Bool+isPending (Failure (Pending {})) = True+isPending _ = False++whenFailure :: (Monad m) => Result -> (FailureReason -> m ()) -> m ()+whenFailure (Failure (Pending {})) _ = return ()+whenFailure (Failure reason) action = action reason+whenFailure _ _ = return ()

@@ -0,0 +1,15 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+-- |++module Test.Sandwich.Shutdown where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Test.Sandwich.Types.RunTree+++cancelNode :: RunNode context -> IO ()+cancelNode node = readTVarIO (runTreeStatus $ runNodeCommon node) >>= \case+  Running {..} -> cancel statusAsync+  _ -> return ()

@@ -0,0 +1,146 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RecordWildCards #-}++module Test.Sandwich.TH (+  getSpecFromFolder++  , defaultGetSpecFromFolderOptions+  , GetSpecFromFolderOptions+  , getSpecCombiner+  , getSpecIndividualSpecHooks+  , getSpecWarnOnParseError+  , ShouldWarnOnParseError(..)++  , buildModuleMap+  ) where++import Control.Monad+import Data.Char+import Data.Function+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe+import Data.String.Interpolate+import qualified Data.Text as T+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Safe+import System.Directory+import System.FilePath as F+import Test.Sandwich.TH.HasMainFunction+import Test.Sandwich.TH.ModuleMap+import Test.Sandwich.Types.Spec hiding (location)+++constId = const id++data GetSpecFromFolderOptions = GetSpecFromFolderOptions {+  getSpecCombiner :: Name+  , getSpecIndividualSpecHooks :: Name+  , getSpecWarnOnParseError :: ShouldWarnOnParseError+  }++defaultGetSpecFromFolderOptions :: GetSpecFromFolderOptions+defaultGetSpecFromFolderOptions = GetSpecFromFolderOptions {+  getSpecCombiner = 'describe+  , getSpecIndividualSpecHooks = 'constId+  , getSpecWarnOnParseError = WarnOnParseError+  }++getSpecFromFolder :: GetSpecFromFolderOptions -> Q Exp+getSpecFromFolder getSpecFromFolderOptions = do+  dir <- runIO getCurrentDirectory+  filename <- loc_filename <$> location+  let folder = dropExtension (dir </> filename)++  Module _ (ModName moduleName) <- thisModule++  let modulePrefix' = moduleName+                    & T.pack+                    & T.splitOn "."+                    & initMay+                    & fromMaybe []+                    & T.intercalate "."+                    & T.unpack+  let modulePrefix = if modulePrefix' == "" then "" else modulePrefix' <> "."+  moduleMap <- runIO $ buildModuleMap folder modulePrefix+  let reverseModuleMap = M.fromList [(y, x) | (x, y) <- M.toList moduleMap]++  getSpecFromFolder' folder reverseModuleMap (moduleName <> ".") getSpecFromFolderOptions++getSpecFromFolder' :: F.FilePath -> ReverseModuleMap -> String -> GetSpecFromFolderOptions -> Q Exp+getSpecFromFolder' folder reverseModuleMap modulePrefix gsfo@(GetSpecFromFolderOptions {..}) = do+  items <- qRunIO $ L.sort <$> listDirectory folder+  specs <- (catMaybes <$>) $ forM items $ \item -> do+    isDirectory <- qRunIO $ doesDirectoryExist (folder </> item)++    if | isDirectory -> do+           qRunIO (doesFileExist (folder </> item <.> "hs")) >>= \case+             False -> Just <$> getSpecFromFolder' (folder </> item) reverseModuleMap (modulePrefix <> item <> ".") gsfo+             True -> return Nothing -- Do nothing, allow the .hs file to be picked up separately+       | takeExtension item == ".hs" -> do+           let fullyQualifiedModule = modulePrefix <> takeBaseName item+           case M.lookup fullyQualifiedModule reverseModuleMap of+             Nothing -> do+               reportError [i|Couldn't find module #{fullyQualifiedModule} in #{reverseModuleMap}|]+               return Nothing+             Just importedName -> do+               maybeMainFunction <- fileHasMainFunction (folder </> item) getSpecWarnOnParseError >>= \case+                 True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]+                 False -> [e|Nothing|]++               alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) fullyQualifiedModule $(return maybeMainFunction)) })|]++               Just <$> [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)+                           $ $(varE getSpecIndividualSpecHooks) $(stringE item) $(varE $ mkName $ importedName <> ".tests")|]+       | otherwise -> return Nothing++  let currentModule = modulePrefix+                    & T.pack+                    & T.stripSuffix "."+                    & fromMaybe ""+                    & T.unpack+  maybeMainFunction <- case M.lookup currentModule reverseModuleMap of+    Nothing -> [e|Nothing|]+    Just importedName -> fileHasMainFunction (folder <> ".hs") getSpecWarnOnParseError >>= \case+      True -> [e|Just $(varE $ mkName $ importedName <> ".main")|]+      False -> [e|Nothing|]+  alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) currentModule $(return maybeMainFunction)) })|]+  [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)+     $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl1 (>>) $(listE $ fmap return specs))|]++-- * Util++mangleFolderName :: String -> String+mangleFolderName = T.unpack . wordify . T.pack . takeBaseName++-- | Convert a string like "TeamTests" to "Team tests"+wordify :: T.Text -> T.Text+wordify t = T.intercalate " " $ capitalizeFirst $ fmap (T.toLower . T.pack) parts+  where parts = splitR (\c -> isUpper c || isDigit c) $ T.unpack t++capitalizeFirst :: [T.Text] -> [T.Text]+capitalizeFirst [] = []+capitalizeFirst (x:xs) = capitalize x : xs++capitalize :: T.Text -> T.Text+capitalize t | T.length t == 1 = T.toUpper t+capitalize t = (toUpper $ T.head t) `T.cons` (T.tail t)++splitR :: (Char -> Bool) -> String -> [String]+splitR _ [] = []+splitR p s =+  let+    go :: Char -> String -> [String]+    go m s' = case L.break p s' of+      (b', [])     -> [ m:b' ]+      (b', x:xs) -> ( m:b' ) : go x xs+  in case L.break p s of+    (b,  [])    -> [ b ]+    ([], h:t) -> go h t+    (b,  h:t) -> b : go h t

@@ -0,0 +1,62 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.TH.HasMainFunction (+  fileHasMainFunction+  , ShouldWarnOnParseError(..)+  ) where++import Control.Monad+import Data.String.Interpolate+import Language.Haskell.Exts+import Language.Haskell.TH (runIO, reportWarning)++-- import Debug.Trace+++data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError+  deriving (Eq)++-- | Use haskell-src-exts to determine if a give Haskell file has an exported main function+-- Parse with all extensions enabled, which will hopefully parse anything+fileHasMainFunction path shouldWarnOnParseError = runIO (parseFileWithExts [x | x@(EnableExtension _) <- knownExtensions] path) >>= \case+  x@(ParseFailed {}) -> do+    when (shouldWarnOnParseError == WarnOnParseError) $+      reportWarning [i|Failed to parse #{path}: #{x}|]+    return False+  ParseOk (Module _ (Just moduleHead) _ _ decls) -> do+    -- traceM [i|Sucessfully parsed #{path}: #{moduleHead}|]+    case moduleHead of+      ModuleHead _ _ _ (Just (ExportSpecList _ (any isMainFunction -> True))) -> do+        -- traceM [i|FOUND MAIN FUNCTION FOR #{path}|]+        return True+      ModuleHead _ _ _ Nothing -> do+        -- traceM [i|LOOKING FOR DECLS: #{decls}|]+        return $ any isMainDecl decls+      _ -> return False+  ParseOk _ -> do+    reportWarning [i|Successfully parsed #{path} but no module head found|]+    return False++isMainFunction :: ExportSpec l -> Bool+isMainFunction (EVar _ name) = isMainFunctionQName name+isMainFunction _ = False++isMainFunctionQName :: QName l -> Bool+isMainFunctionQName (Qual _ _ name) = isMainFunctionName name+isMainFunctionQName (UnQual _ name) = isMainFunctionName name+isMainFunctionQName _ = False++isMainFunctionName :: Name l -> Bool+isMainFunctionName (Ident _ "main") = True+isMainFunctionName (Symbol _ "main") = True+isMainFunctionName _ = False++isMainDecl :: (Show l) => Decl l -> Bool+isMainDecl (PatBind _ (PVar _ (Ident _ "main")) _ _) = True+-- isMainDecl decl = trace [i|Looking at decl: #{decl}|] False+isMainDecl _ = False

@@ -0,0 +1,50 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Sandwich.TH.ModuleMap where++import Control.Monad+import qualified Data.List as L+import qualified Data.Map as M+import Data.Maybe (isNothing)+import System.Directory+import System.FilePath+++-- Map from qualified import name to path+type ModuleMap = M.Map String String+type ReverseModuleMap = M.Map String String++buildModuleMap :: FilePath -> String -> IO ModuleMap+buildModuleMap baseDir modulePrefix = traverseDir (const True) (\x y -> return $ addModuleToMap baseDir modulePrefix x y) mempty baseDir++addModuleToMap :: FilePath -> String -> ModuleMap -> FilePath -> ModuleMap+addModuleToMap relativeTo modulePrefix mm path@(takeExtension -> ".hs") = case pathParts of+  [] -> mm+  _ -> M.insert moduleName (modulePrefix <> (L.intercalate "." pathParts)) mm+  where+    relativePath = (takeFileName relativeTo) </> (makeRelative relativeTo path)+    pathParts = splitDirectories $ dropExtension relativePath+    baseModuleName = last pathParts+    moduleName = head $ filter doesNotExist (baseModuleName : [baseModuleName <> show n | n <- [1..]])+    doesNotExist x = isNothing (M.lookup x mm)+addModuleToMap _ _ mm _ = mm++-- | From https://stackoverflow.com/a/51713361/2659595+traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b+traverseDir validDir transition =+  let go state dirPath = do+        names <- listDirectory dirPath+        let paths = map (dirPath </>) names+        (dirPaths, filePaths) <- partitionM doesDirectoryExist paths+        state' <- foldM transition state filePaths+        foldM go state' (filter validDir dirPaths)+ in go++-- | From https://hackage.haskell.org/package/extra-1.7.9/docs/src/Control.Monad.Extra.html#partitionM+partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM _ [] = pure ([], [])+partitionM f (x:xs) = do+    res <- f x+    (as,bs) <- partitionM f xs+    pure ([x | res]++as, [x | not res]++bs)

@@ -0,0 +1,127 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NamedFieldPuns #-}++module Test.Sandwich.TestTimer where++import Control.Concurrent+import Control.Exception.Safe+import Control.Lens+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Trans.State+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BL+import qualified Data.List as L+import qualified Data.Sequence as S+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Time.Clock.POSIX+import System.Directory+import System.FilePath+import System.IO+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer+import Test.Sandwich.Util (whenJust)+++type EventName = T.Text+type ProfileName = T.Text++-- * User functions++-- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.+timeAction :: (MonadMask m, MonadIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a+timeAction eventName action = do+  tt <- asks getTestTimer+  BaseContext {baseContextTestTimerProfile} <- asks getBaseContext+  timeAction' tt baseContextTestTimerProfile eventName action++-- | Time a given action with a given profile name and event name. Use when you want to manually specify the profile name.+timeActionByProfile :: (MonadMask m, MonadIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a+timeActionByProfile profileName eventName action = do+  tt <- asks getTestTimer+  timeAction' tt profileName eventName action++-- | Introduce a new timing profile name.+withTimingProfile :: (Monad m) => ProfileName -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m () -> SpecFree context m ()+withTimingProfile name = introduce' timingNodeOptions [i|Switch test timer profile to '#{name}'|] testTimerProfile (pure $ TestTimerProfile name) (\_ -> return ())++-- | Introduce a new timing profile name dynamically. The given 'ExampleT' should come up with the name and return it.+withTimingProfile' :: (Monad m) => ExampleT context m ProfileName -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m () -> SpecFree context m ()+withTimingProfile' getName = introduce' timingNodeOptions [i|Switch test timer profile to dynamic value|] testTimerProfile (TestTimerProfile <$> getName) (\_ -> return ())++-- * Core++timingNodeOptions :: NodeOptions+timingNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False+                                       , nodeOptionsCreateFolder = False+                                       , nodeOptionsVisibilityThreshold = systemVisibilityThreshold }++newSpeedScopeTestTimer :: FilePath -> Bool -> IO TestTimer+newSpeedScopeTestTimer path writeRawTimings = do+  createDirectoryIfMissing True path++  maybeHandle <- case writeRawTimings of+    False -> return Nothing+    True -> do+      h <- openFile (path </> "timings_raw.txt") AppendMode+      hSetBuffering h LineBuffering+      return $ Just h++  speedScopeFile <- newMVar emptySpeedScopeFile+  return $ SpeedScopeTestTimer path maybeHandle speedScopeFile++finalizeSpeedScopeTestTimer :: TestTimer -> IO ()+finalizeSpeedScopeTestTimer NullTestTimer = return ()+finalizeSpeedScopeTestTimer (SpeedScopeTestTimer {..}) = do+  whenJust testTimerHandle hClose+  readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode++timeAction' :: (MonadMask m, MonadIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a+timeAction' NullTestTimer _ _ = id+timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_+  (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do+    now <- getPOSIXTime+    handleStartEvent file now+  )+  (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do+    now <- getPOSIXTime+    handleEndEvent file now+  )+  where+    handleStartEvent file time = do+      whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|]+      return $ handleSpeedScopeEvent file time SpeedScopeEventTypeOpen++    handleEndEvent file time = do+      whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|]+      return $ handleSpeedScopeEvent file time SpeedScopeEventTypeClose++    -- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists,+    -- so we don't have to do O(N) L.length and S.findIndexL+    handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> SpeedScopeEventType -> SpeedScopeFile+    handleSpeedScopeEvent initialFile time typ = flip execState initialFile $ do+      frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of+        Just j -> return j+        Nothing -> do+          modify' $ over (shared . frames) (S.|> (SpeedScopeFrame eventName))+          return $ S.length $ f ^. shared . frames++      profileIndex <- get >>= \f -> case L.findIndex ((== profileName) . (^. name)) (f ^. profiles) of+        Just j -> return j+        Nothing -> do+          modify' $ over profiles (\x -> x <> [newProfile profileName time])+          return $ L.length (f ^. profiles)++      modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent typ frameID time))+              . over (profiles . ix profileIndex . endValue) (max time)

@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}++module Test.Sandwich.Types.ArgParsing where++import Control.Monad.Logger+import GHC.Int+++-- * FormatterType++data FormatterType = Print | TUI | Auto | Silent++instance Show FormatterType where+  show Print = "print"+  show TUI = "tui"+  show Auto = "auto"+  show Silent = "silent"++instance Read FormatterType where+  readsPrec _ "print" = [(Print, "")]+  readsPrec _ "tui" = [(TUI, "")]+  readsPrec _ "auto" = [(Auto, "")]+  readsPrec _ "silent" = [(Silent, "")]+  readsPrec _ _ = []++-- * DisplayType++data DisplayType = Current | Headless | Xvfb++instance Show DisplayType where+  show Current = "current"+  show Headless = "headless"+  show Xvfb = "xvfb"++instance Read DisplayType where+  readsPrec _ "current" = [(Current, "")]+  readsPrec _ "headless" = [(Headless, "")]+  readsPrec _ "xvfb" = [(Xvfb, "")]+  readsPrec _ _ = []++-- * CommandLineOptions++data CommandLineOptions a = CommandLineOptions {+  optFormatter :: FormatterType+  , optLogLevel :: Maybe LogLevel+  , optTreeFilter :: Maybe String+  , optRepeatCount :: Int+  , optFixedRoot :: Maybe String++  , optListAvailableTests :: Maybe Bool+  , optPrintSlackFlags :: Maybe Bool+  , optPrintWebDriverFlags :: Maybe Bool++  , optIndividualTestModule :: Maybe IndividualTestModule++  , optWebdriverOptions :: CommandLineWebdriverOptions+  , optSlackOptions :: CommandLineSlackOptions++  , optUserOptions :: a+  } deriving Show++data IndividualTestModule = IndividualTestModuleName String+                          | IndividualTestMainFn (IO ())++instance Show IndividualTestModule where+  show (IndividualTestModuleName moduleName) = moduleName+  show (IndividualTestMainFn _) = "<main function>"++-- * sandwich-slack options++data CommandLineSlackOptions = CommandLineSlackOptions {+  optSlackToken :: Maybe String+  , optSlackChannel :: Maybe String++  , optSlackTopMessage :: Maybe String++  , optSlackMaxFailures :: Maybe Int+  , optSlackMaxFailureReasonLines :: Maybe Int+  , optSlackMaxCallStackLines :: Maybe Int++  , optSlackVisibilityThreshold :: Maybe Int++  , optSlackMaxMessageSize :: Maybe Int64+  } deriving Show++-- * sandwich-webdriver options++data BrowserToUse = UseChrome | UseFirefox+  deriving Show++data CommandLineWebdriverOptions = CommandLineWebdriverOptions {+  optFirefox :: Maybe BrowserToUse+  , optDisplay :: Maybe DisplayType+  , optFluxbox :: Bool+  , optIndividualVideos :: Bool+  , optErrorVideos :: Bool+  } deriving Show

@@ -0,0 +1,5 @@++module Test.Sandwich.Types.General where++data ExitReason = NormalExit | InterruptExit+  deriving (Show, Eq)

@@ -0,0 +1,253 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}++module Test.Sandwich.Types.RunTree where++import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import qualified Data.ByteString.Char8 as BS8+import Data.Sequence hiding ((:>))+import qualified Data.Set as S+import qualified Data.Text as T+import Data.Time.Clock+import Data.Typeable+import GHC.Stack+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.Spec+import Test.Sandwich.Types.TestTimer+++data Status = NotStarted+            | Running { statusStartTime :: UTCTime+                      , statusAsync :: Async Result }+            | Done { statusStartTime :: UTCTime+                   , statusEndTime :: UTCTime+                   , statusResult :: Result }+            deriving (Show, Eq)++instance Show (Async Result) where+  show _ = "AsyncResult"+++data RunNodeWithStatus context s l t where+  RunNodeBefore :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildren :: [RunNodeWithStatus context s l t]+    , runNodeBefore :: ExampleT context IO ()+    } -> RunNodeWithStatus context s l t+  RunNodeAfter :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildren :: [RunNodeWithStatus context s l t]+    , runNodeAfter :: ExampleT context IO ()+    } -> RunNodeWithStatus context s l t+  RunNodeIntroduce :: (Typeable intro) => {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildrenAugmented :: [RunNodeWithStatus (LabelValue lab intro :> context) s l t]+    , runNodeAlloc :: ExampleT context IO intro+    , runNodeCleanup :: intro -> ExampleT context IO ()+    } -> RunNodeWithStatus context s l t+  RunNodeIntroduceWith :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildrenAugmented :: [RunNodeWithStatus (LabelValue lab intro :> context) s l t]+    , runNodeIntroduceAction :: (intro -> ExampleT context IO [Result]) -> ExampleT context IO ()+    } -> RunNodeWithStatus context s l t+  RunNodeAround :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildren :: [RunNodeWithStatus context s l t]+    , runNodeActionWith :: ExampleT context IO [Result] -> ExampleT context IO ()+    } -> RunNodeWithStatus context s l t+  RunNodeDescribe :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildren :: [RunNodeWithStatus context s l t]+    } -> RunNodeWithStatus context s l t+  RunNodeParallel :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeChildren :: [RunNodeWithStatus context s l t]+    } -> RunNodeWithStatus context s l t+  RunNodeIt :: {+    runNodeCommon :: RunNodeCommonWithStatus s l t+    , runNodeExample :: ExampleT context IO ()+    } -> RunNodeWithStatus context s l t++type RunNodeFixed context = RunNodeWithStatus context Status (Seq LogEntry) Bool+type RunNode context = RunNodeWithStatus context (Var Status) (Var (Seq LogEntry)) (Var Bool)++-- * RunNodeCommon++data RunNodeCommonWithStatus s l t = RunNodeCommonWithStatus {+  runTreeLabel :: String+  , runTreeId :: Int+  , runTreeAncestors :: Seq Int+  , runTreeToggled :: t+  , runTreeOpen :: t+  , runTreeStatus :: s+  , runTreeVisible :: Bool+  , runTreeFolder :: Maybe FilePath+  , runTreeVisibilityLevel :: Int+  , runTreeRecordTime :: Bool+  , runTreeLogs :: l+  , runTreeLoc :: Maybe SrcLoc+  } deriving (Show, Eq)++type RunNodeCommonFixed = RunNodeCommonWithStatus Status (Seq LogEntry) Bool+type RunNodeCommon = RunNodeCommonWithStatus (Var Status) (Var (Seq LogEntry)) (Var Bool)++-- * Other++type Var = TVar+data LogEntry = LogEntry { logEntryTime :: UTCTime+                         , logEntryLoc :: Loc+                         , logEntrySource :: LogSource+                         , logEntryLevel :: LogLevel+                         , logEntryStr :: LogStr+                         } deriving (Show, Eq)++-- | Context passed around through the evaluation of a RunTree+data RunTreeContext = RunTreeContext {+  runTreeCurrentFolder :: Maybe FilePath+  , runTreeCurrentAncestors :: Seq Int+  , runTreeIndexInParent :: Int+  , runTreeNumSiblings :: Int+  }++-- * Base context++-- | The base context available to every test node.+-- Contains various paths and timing information.+data BaseContext = BaseContext {+  baseContextPath :: Maybe FilePath+  , baseContextRunRoot :: Maybe FilePath+  , baseContextErrorSymlinksDir :: Maybe FilePath+  , baseContextOptions :: Options+  , baseContextOnlyRunIds :: Maybe (S.Set Int)+  , baseContextTestTimerProfile :: T.Text+  , baseContextTestTimer :: TestTimer+  }++-- | Has-* class for asserting a 'BaseContext' is available.+class HasBaseContext a where+  getBaseContext :: a -> BaseContext+  modifyBaseContext :: a -> (BaseContext -> BaseContext) -> a++instance HasBaseContext BaseContext where+  getBaseContext = id+  modifyBaseContext x f = f x++instance HasBaseContext context => HasBaseContext (intro :> context) where+  getBaseContext (_ :> ctx) = getBaseContext ctx+  modifyBaseContext (intro :> ctx) f = intro :> modifyBaseContext ctx f++-- Timing related+instance HasBaseContext context => HasTestTimer context where+  getTestTimer = baseContextTestTimer <$> getBaseContext++type CoreSpec = Spec BaseContext IO++type TopSpec = forall context. HasBaseContext context => SpecFree context IO ()++-- * Specs with command line options provided++commandLineOptions = Label :: Label "commandLineOptions" (CommandLineOptions a)++-- | Has-* class for asserting a 'CommandLineOptions a' is available.+type HasCommandLineOptions context a = HasLabel context "commandLineOptions" (CommandLineOptions a)++type TopSpecWithOptions = forall context. (+  HasBaseContext context+  , HasCommandLineOptions context ()+  ) => SpecFree context IO ()++type TopSpecWithOptions' a = forall context. (+  HasBaseContext context+  , HasCommandLineOptions context a+  ) => SpecFree context IO ()++-- * Formatter++class Formatter f where+  formatterName :: f -> String+  -- ^ Name of the formatter+  runFormatter :: (MonadIO m, MonadLogger m, MonadUnliftIO m, MonadCatch m) => f -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+  -- ^ The main function, executed while the test tree is running+  finalizeFormatter :: (MonadIO m, MonadLogger m, MonadCatch m) => f -> [RunNode BaseContext] -> BaseContext -> m ()+  -- ^ Called after the test tree is completed, can be used to print final results++-- | An existential wrapper around 'Formatter's+data SomeFormatter = forall f. (Formatter f, Typeable f) => SomeFormatter f++-- * Options++-- | Control whether test artifacts are stored to a directory.+data TestArtifactsDirectory =+  TestArtifactsNone+  -- ^ Do not create a test artifacts directory.+  | TestArtifactsFixedDirectory {+      testRootFixed :: FilePath+      }+  -- ^ Use the test artifacts directory at the given path, creating it if necessary.+  | TestArtifactsGeneratedDirectory {+      runsRoot :: FilePath+      -- ^ The root folder under which test run directories will be created.+      , getTestRunDirectoryName :: IO FilePath+      -- ^ Action to generate the new directory name.+      }+  -- ^ Create a new test artifacts directory under '' test artifacts directory at the given path.++newtype TreeFilter = TreeFilter String++type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()+type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> BS8.ByteString++defaultLogEntryFormatter :: LogEntryFormatter+defaultLogEntryFormatter _ts a b c d = fromLogStr $ defaultLogStr a b c d++data TestTimerType =+  NullTestTimerType+  -- ^ Don't run a test timer+  | SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings :: Bool+                              -- ^ Whether to write an additional file with line-by-line timing events, which can be useful for debugging timer issues.+                            }+  -- ^ Test timer that outputs its results in <https://www.speedscope.app/ SpeedScope> JSON format. Also outputs a file with raw timing data in a simple event-based format.++-- | All the options controlling a test run.+data Options = Options {+  optionsTestArtifactsDirectory :: TestArtifactsDirectory+  -- ^ Where to save test artifacts (logs, screenshots, failure reports, etc.).+  , optionsSavedLogLevel :: Maybe LogLevel+  -- ^ Minimum test log level to save (has no effect if 'optionsTestArtifactsDirectory' is 'TestArtifactsNone').+  , optionsMemoryLogLevel :: Maybe LogLevel+  -- ^ Test log level to store in memory while tests are running. (These logs are presented in formatters, etc.).+  , optionsLogFormatter :: LogEntryFormatter+  -- ^ Formatter function for log entries.+  , optionsFilterTree :: Maybe TreeFilter+  -- ^ Filter to apply to the text tree before running.+  , optionsDryRun :: Bool+  -- ^ Whether to skip actually launching the tests. This is useful if you want to see the set of the tests that would be run, or start them manually in the terminal UI.+  , optionsFormatters :: [SomeFormatter]+  -- ^ Which formatters to use to output the results of the tests.+  , optionsProjectRoot :: Maybe FilePath+  -- ^ An optional absolute path to the root of the project being tested (i.e. the folder where the cabal file is found).+  -- This is useful to provide when the current working directory does not match the project root, for example in multi-project Stack setups.+  -- We use this hint to connect 'CallStack' paths (which are relative to the project root) to their actual path on disk.+  , optionsTestTimerType :: TestTimerType+  -- ^ Whether to enable the test timer. When the test timer is present, timing information will be emitted to the project root (if present).+  }+++-- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way+-- to reliably get a callstack from an exception, but if you can throw (or catch+rethrow) this type+-- then we'll unwrap it and present the callstack nicely.+data SomeExceptionWithCallStack = forall e. Exception e => SomeExceptionWithCallStack e CallStack+instance Show SomeExceptionWithCallStack where+  showsPrec p (SomeExceptionWithCallStack e _) = showsPrec p e+instance Exception SomeExceptionWithCallStack

@@ -0,0 +1,697 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE InstanceSigs #-}++-- | The core Spec/SpecCommand types, used to define the test free monad.++module Test.Sandwich.Types.Spec where++import Control.Exception.Safe+import Control.Monad.Base+import Control.Monad.Except+import Control.Monad.Free+import Control.Monad.Free.TH+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Functor.Classes+import Data.Maybe+import Data.String.Interpolate+import GHC.Stack+import GHC.TypeLits+import Safe++-- * ExampleM monad++newtype ExampleT context m a = ExampleT { unExampleT :: ReaderT context (LoggingT m) a }+  deriving (Functor, Applicative, Monad, MonadIO, MonadReader context, MonadLogger, MonadLoggerIO, MonadThrow, MonadCatch, MonadMask)+type ExampleM context = ExampleT context IO++instance (MonadIO m, MonadUnliftIO m) => MonadUnliftIO (ExampleT context m) where+  withRunInIO inner = ExampleT $ withRunInIO $ \run -> inner (run . unExampleT)++instance (MonadBase b m) => MonadBase b (ExampleT context m) where+  liftBase = liftBaseDefault++instance MonadTrans (ExampleT context) where+  lift x = ExampleT $ ReaderT (\_ -> (LoggingT (\_ -> x)))++instance MonadTransControl (ExampleT context) where+  type StT (ExampleT context) a = StT LoggingT (StT (ReaderT context) a)+  liftWith = defaultLiftWith2 ExampleT unExampleT+  restoreT = defaultRestoreT2 ExampleT++instance (MonadBaseControl b m) => MonadBaseControl b (ExampleT context m) where+  type StM (ExampleT context m) a = ComposeSt (ExampleT context) m a+  liftBaseWith = defaultLiftBaseWith+  restoreM = defaultRestoreM++instance (Monad m, MonadThrow m) => MonadFail (ExampleT context m) where+  fail :: (HasCallStack) => String -> ExampleT context m a+  fail = throwIO . Reason (Just callStack)++-- * Results++data Result = Success+            | Failure FailureReason+  deriving (Show, Eq)++data ShowEqBox = forall s. (Show s, Eq s) => SEB s+instance Show ShowEqBox where show (SEB x) = show x+instance Eq ShowEqBox where (SEB x1) == (SEB x2) = show x1 == show x2++data FailureReason = Reason { failureCallStack :: Maybe CallStack+                            , failureReason :: String }+                   | ExpectedButGot { failureCallStack :: Maybe CallStack+                                    , failureValue1 :: ShowEqBox+                                    , failureValue2 :: ShowEqBox }+                   | DidNotExpectButGot { failureCallStack :: Maybe CallStack+                                        , failureValue1 :: ShowEqBox }+                   | GotException { failureCallStack :: Maybe CallStack+                                  , failureMessage :: Maybe String+                                  , failureException :: SomeExceptionWithEq }+                   | Pending { failureCallStack :: Maybe CallStack+                             , failurePendingMessage :: Maybe String }+                   | GetContextException { failureCallStack :: Maybe CallStack+                                         , failureException :: SomeExceptionWithEq }+                   | GotAsyncException { failureCallStack :: Maybe CallStack+                                       , failureMessage :: Maybe String+                                       , failureAsyncException :: SomeAsyncExceptionWithEq }+  deriving (Show, Typeable, Eq)++instance Exception FailureReason++instance Eq CallStack where+  c1 == c2 = show c1 == show c2++newtype SomeExceptionWithEq = SomeExceptionWithEq SomeException+instance Show SomeExceptionWithEq where+  show (SomeExceptionWithEq e) = show e+instance Eq SomeExceptionWithEq where+  (SomeExceptionWithEq e1) == (SomeExceptionWithEq e2) = show e1 == show e2++newtype SomeAsyncExceptionWithEq = SomeAsyncExceptionWithEq SomeAsyncException+  deriving Show+instance Eq SomeAsyncExceptionWithEq where+  (SomeAsyncExceptionWithEq e1) == (SomeAsyncExceptionWithEq e2) = show e1 == show e2++-- * Label stuff++data Label (l :: Symbol) a = Label++data LabelValue (l :: Symbol) a = LabelValue a++-- TODO: get rid of overlapping instance+-- Maybe look at https://kseo.github.io/posts/2017-02-05-avoid-overlapping-instances-with-closed-type-families.html+class HasLabel context (l :: Symbol) a where+  getLabelValue :: Label l a -> context -> a+instance HasLabel (LabelValue l a) l a where+  getLabelValue _ (LabelValue x) = x+instance {-# OVERLAPPING #-} HasLabel (LabelValue l a :> context) l a where+  getLabelValue _ (LabelValue x :> _) = x+instance {-# OVERLAPPING #-} HasLabel context l a => HasLabel (intro :> context) l a where+  getLabelValue l (_ :> ctx) = getLabelValue l ctx+++-- * Free monad language++data (a :: *) :> (b :: *) = a :> b+  deriving Show+infixr :>++type ActionWith a = a -> IO ()++data NodeModuleInfo = NodeModuleInfo {+  nodeModuleInfoModuleName :: String+  , nodeModuleInfoFn :: Maybe (IO ())+  }++instance Show NodeModuleInfo where+  show (NodeModuleInfo {..}) = [i|#{nodeModuleInfoModuleName}<Has main? #{isJust nodeModuleInfoFn}>|]++-- | Options for an individual test node.+data NodeOptions = NodeOptions {+  nodeOptionsVisibilityThreshold :: Int+  -- ^ The visibility threshold of the node. See the main docs for an explanation of this.+  , nodeOptionsCreateFolder :: Bool+  -- ^ Whether to create a folder in the on-disk test results for this node.+  -- Defaults to 'True', but can be turned off to reduce extraneous folders from nodes like 'Parallel'.+  , nodeOptionsRecordTime :: Bool+  -- ^ Whether to time this node.+  , nodeOptionsModuleInfo :: Maybe NodeModuleInfo+  -- ^ A main function run this entire node in isolation.+  } deriving Show++-- | Reasonable default node options.+defaultNodeOptions :: NodeOptions+defaultNodeOptions = NodeOptions 100 True True Nothing++data SpecCommand context m next where+  Before'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , action :: ExampleT context m ()+    , subspec :: SpecFree context m ()+    , next :: next+    } -> SpecCommand context m next++  After'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , action :: ExampleT context m ()+    , subspec :: SpecFree context m ()+    , next :: next+    } -> SpecCommand context m next++  Introduce'' :: (Typeable intro) => {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , contextLabel :: Label l intro+    , allocate :: ExampleT context m intro+    , cleanup :: intro -> ExampleT context m ()+    , subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()+    , next :: next+    } -> SpecCommand context m next++  IntroduceWith'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , contextLabel :: Label l intro+    , introduceAction :: (intro -> ExampleT context m [Result]) -> ExampleT context m ()+    , subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()+    , next :: next+    } -> SpecCommand context m next++  Around'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , actionWith :: ExampleT context m [Result] -> ExampleT context m ()+    , subspec :: SpecFree context m ()+    , next :: next+    } -> SpecCommand context m next++  Describe'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , label :: String+    , subspec :: SpecFree context m ()+    , next :: next+    } -> SpecCommand context m next++  Parallel'' :: {+    location :: Maybe SrcLoc+    , nodeOptions :: NodeOptions+    , subspec :: SpecFree context m ()+    , next :: next+    } -> SpecCommand context m next++  It'' :: { location :: Maybe SrcLoc+          , nodeOptions :: NodeOptions+          , label :: String+          , example :: ExampleT context m ()+          , next :: next } -> SpecCommand context m next++deriving instance Functor (SpecCommand context m)+deriving instance Foldable (SpecCommand context m)+deriving instance Traversable (SpecCommand context m)+++type Spec context m = SpecFree context m ()+type SpecFree context m a = Free (SpecCommand context m) a++makeFree_ ''SpecCommand++instance Show1 (SpecCommand context m) where+  liftShowsPrec sp _ d (Before'' {..}) = showsUnaryWith sp [i|Before[#{label}]<#{show subspec}>|] d next+  liftShowsPrec sp _ d (After'' {..}) = showsUnaryWith sp [i|After[#{label}]<#{show subspec}>|] d next+  liftShowsPrec sp _ d (Introduce'' {..}) = showsUnaryWith sp [i|Introduce[#{label}]<#{show subspecAugmented}>|] d next+  liftShowsPrec sp _ d (IntroduceWith'' {..}) = showsUnaryWith sp [i|IntroduceWith[#{label}]<#{show subspecAugmented}>|] d next+  liftShowsPrec sp _ d (Around'' {..}) = showsUnaryWith sp [i|Around[#{label}]<#{show subspec}>|] d next+  liftShowsPrec sp _ d (Describe'' {..}) = showsUnaryWith sp [i|Describe[#{label}]<#{show subspec}>|] d next+  liftShowsPrec sp _ d (Parallel'' {..}) = showsUnaryWith sp [i|Parallel<#{show subspec}>|] d next+  liftShowsPrec sp _ d (It'' {..}) = showsUnaryWith sp [i|It[#{label}]|] d next++-- First write beforeEach/afterEach to demonstrate push down approach+-- Then think about how/whether we can to introduceEach / aroundEach++-- * ----------------------------------------------------------++-- | Perform an action before a given spec tree.+before :: (HasCallStack) =>+  String+  -- ^ Label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+before = before' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Perform an action before a given spec tree.+before' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+before' = before'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Perform an action before a given spec tree.+before'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Perform an action after a given spec tree.+after :: (HasCallStack) =>+  String+  -- ^ Label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+after = after' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Perform an action after a given spec tree.+after' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+after' = after'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Perform an action after a given spec tree.+after'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> ExampleT context m ()+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Introduce a new value and make it available to the child spec tree.+introduce :: (HasCallStack, Typeable intro) =>+  String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ExampleT context m intro+  -- ^ Action to produce the new value (of type 'intro')+  -> (intro -> ExampleT context m ())+  -- ^ Action to clean up the new value+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+introduce = introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Introduce a new value and make it available to the child spec tree.+introduce' :: (HasCallStack, Typeable intro) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ExampleT context m intro+  -- ^ Action to produce the new value (of type 'intro')+  -> (intro -> ExampleT context m ())+  -- ^ Action to clean up the new value+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+introduce' = introduce'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Introduce a new value and make it available to the child spec tree.+introduce'' :: (HasCallStack, Typeable intro) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ExampleT context m intro+  -- ^ Action to produce the new value (of type 'intro')+  -> (intro -> ExampleT context m ())+  -- ^ Action to clean up the new value+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Introduce a new value in an 'around' fashion, so it can be used with context managers like withFile or bracket.+introduceWith :: (HasCallStack) =>+  String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+  -- ^ Callback to receive the new value and the child tree.+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+introduceWith = introduceWith' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Introduce a new value in an 'around' fashion, so it can be used with context managers like withFile or bracket.+introduceWith' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+  -- ^ Callback to receive the new value and the child tree.+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+introduceWith' = introduceWith'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Introduce a new value in an 'around' fashion, so it can be used with context managers like withFile or bracket.+introduceWith'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> Label l intro+  -- ^ 'Label' under which to introduce the value+  -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+  -- ^ Callback to receive the new value and the child tree.+  -> SpecFree (LabelValue l intro :> context) m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Run an action around the given child subtree. Useful for context managers like withFile or bracket.+around :: (HasCallStack) =>+  String+  -> (ExampleT context m [Result] -> ExampleT context m ())+  -- ^ Callback to run the child tree+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+around = around' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Run an action around the given child subtree. Useful for context managers like withFile or bracket.+around' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> (ExampleT context m [Result] -> ExampleT context m ())+  -- ^ Callback to run the child tree+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+around' = around'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Run an action around the given child subtree. Useful for context managers like withFile or bracket.+around'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this node+  -> (ExampleT context m [Result] -> ExampleT context m ())+  -- ^ Callback to run the child tree+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+++-- * ----------------------------------------------------------++-- | Define a group of tests.+describe :: (HasCallStack) =>+  String+  -- ^ Label for this group+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+describe = describe' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 50 })++-- | Define a group of tests.+describe' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ Label for this group+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+describe' = describe'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Define a group of tests.+describe'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ Label for this group+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Run a group of tests in parallel.+parallel :: (HasCallStack) =>+  SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+parallel = parallel' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 })++-- | Run a group of tests in parallel.+parallel' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+parallel' = parallel'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Run a group of tests in parallel.+parallel'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()++-- * ----------------------------------------------------------++-- | Define a single test example.+it :: (HasCallStack) =>+  String+  -- ^ Label for the example.+  -> ExampleT context m ()+  -- ^ The test example+  -> Free (SpecCommand context m) ()+it = it' (defaultNodeOptions { nodeOptionsVisibilityThreshold = 0 })++-- | Define a single test example.+it' :: (HasCallStack) =>+  NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for the example.+  -> ExampleT context m ()+  -- ^ The test example+  -> Free (SpecCommand context m) ()+it' = it'' (snd <$> headMay (drop 1 $ getCallStack callStack))++-- | Define a single test example.+it'' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for the example.+  -> ExampleT context m ()+  -- ^ The test example+  -> Free (SpecCommand context m) ()++-- * ----------------------------------------------------------++-- | Same as 'before', but applied individually to every 'it' node.+beforeEach :: (HasCallStack) =>+  String+  -- ^ String label for this context manager+  -> (ExampleT context m ())+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+beforeEach = beforeEach' (snd <$> headMay (getCallStack callStack)) (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Perform an action before each example in a given spec tree.+beforeEach' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> (ExampleT context m ())+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+beforeEach' loc no l f (Free x@(Before'' {..})) = Free (x { subspec = beforeEach' loc no l f subspec, next = beforeEach' loc no l f next })+beforeEach' loc no l f (Free x@(After'' {..})) = Free (x { subspec = beforeEach' loc no l f subspec, next = beforeEach' loc no l f next })+beforeEach' loc no l f (Free x@(Around'' {..})) = Free (x { subspec = beforeEach' loc no l f subspec, next = beforeEach' loc no l f next })+beforeEach' loc no l f (Free x@(Describe'' {..})) = Free (x { subspec = beforeEach' loc no l f subspec, next = beforeEach' loc no l f next })+beforeEach' loc no l f (Free x@(Parallel'' {..})) = Free (x { subspec = beforeEach' loc no l f subspec, next = beforeEach' loc no l f next })+beforeEach' loc no l f (Free x@(It'' {..})) = Free (Before'' loc no l f (Free (x { next = Pure () })) (beforeEach' loc no l f next))+beforeEach' loc no l f (Free (Introduce'' loci noi li cl alloc clean subspec next)) = Free (Introduce'' loci noi li cl alloc clean (beforeEach' loc no l f' subspec) (beforeEach' loc no l f next))+  where f' = ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT f+beforeEach' loc no l f (Free (IntroduceWith'' loci noi li cl action subspec next)) = Free (IntroduceWith'' loci noi li cl action (beforeEach' loc no l f' subspec) (beforeEach' loc no l f next))+  where f' = ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT f+beforeEach' _ _ _ _ (Pure x) = Pure x++-- * ----------------------------------------------------------++-- | Same as 'after', but applied individually to every 'it' node.+afterEach :: (HasCallStack) =>+  String+  -- ^ String label for this context manager+  -> (ExampleT context m ())+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+afterEach = afterEach' (snd <$> headMay (getCallStack callStack)) (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++-- | Perform an action after each example in a given spec tree.+afterEach' :: (HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ Label for this context manager+  -> (ExampleT context m ())+  -- ^ Action to perform+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+afterEach' loc no l f (Free x@(Before'' {..})) = Free (x { subspec = afterEach' loc no l f subspec, next = afterEach' loc no l f next })+afterEach' loc no l f (Free x@(After'' {..})) = Free (x { subspec = afterEach' loc no l f subspec, next = afterEach' loc no l f next })+afterEach' loc no l f (Free x@(Around'' {..})) = Free (x { subspec = afterEach' loc no l f subspec, next = afterEach' loc no l f next })+afterEach' loc no l f (Free x@(Describe'' {..})) = Free (x { subspec = afterEach' loc no l f subspec, next = afterEach' loc no l f next })+afterEach' loc no l f (Free x@(Parallel'' {..})) = Free (x { subspec = afterEach' loc no l f subspec, next = afterEach' loc no l f next })+afterEach' loc no l f (Free x@(It'' {..})) = Free (After'' loc no l f (Free (x { next = Pure () })) (afterEach' loc no l f next))+afterEach' loc no l f (Free (Introduce'' loci noi li cl alloc clean subspec next)) = Free (Introduce'' loci noi li cl alloc clean (afterEach' loc no l f' subspec) (afterEach' loc no l f next))+  where f' = ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT f+afterEach' loc no l f (Free (IntroduceWith'' loci noi li cl action subspec next)) = Free (IntroduceWith'' loci noi li cl action (afterEach' loc no l f' subspec) (afterEach' loc no l f next))+  where f' = ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT f+afterEach' _ _ _ _ (Pure x) = Pure x++-- * ----------------------------------------------------------++-- | Same as 'around', but applied individually to every 'it' node.+aroundEach :: (Monad m, HasCallStack) =>+  String+  -- ^ String label for this context manager+  -> (ExampleT context m [Result] -> ExampleT context m ())+  -- ^ Callback to run the child tree+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+aroundEach = aroundEach' (snd <$> headMay (getCallStack callStack)) (defaultNodeOptions { nodeOptionsVisibilityThreshold = 100 })++aroundEach' :: (Monad m, HasCallStack) =>+  Maybe SrcLoc+  -- ^ Location of this call+  -> NodeOptions+  -- ^ Custom options for this node+  -> String+  -- ^ String label for this context manager+  -> (ExampleT context m [Result] -> ExampleT context m ())+  -- ^ Callback to run the child tree+  -> SpecFree context m ()+  -- ^ Child spec tree+  -> SpecFree context m ()+aroundEach' loc no l f (Free x@(Before'' {..})) = Free (x { subspec = aroundEach' loc no l f subspec, next = aroundEach' loc no l f next })+aroundEach' loc no l f (Free x@(After'' {..})) = Free (x { subspec = aroundEach' loc no l f subspec, next = aroundEach' loc no l f next })+aroundEach' loc no l f (Free x@(Around'' {..})) = Free (x { subspec = aroundEach' loc no l f subspec, next = aroundEach' loc no l f next })+aroundEach' loc no l f (Free x@(Describe'' {..})) = Free (x { subspec = aroundEach' loc no l f subspec, next = aroundEach' loc no l f next })+aroundEach' loc no l f (Free x@(Parallel'' {..})) = Free (x { subspec = aroundEach' loc no l f subspec, next = aroundEach' loc no l f next })+aroundEach' loc no l f (Free x@(It'' {..})) = Free (Around'' loc no l f (Free (x { next = Pure () })) (aroundEach' loc no l f next))+aroundEach' _no _ _ _ (Pure x) = Pure x+aroundEach' loc no l f (Free (IntroduceWith'' loci noi li cl action subspec next)) = Free (IntroduceWith'' loci noi li cl action (aroundEach' loc no l (unwrapContext f) subspec) (aroundEach' loc no l f next))+aroundEach' loc no l f (Free (Introduce'' loci noi li cl alloc clean subspec next)) = Free (Introduce'' loci noi li cl alloc clean (aroundEach' loc no l (unwrapContext f) subspec) (aroundEach' loc no l f next))++-- * ----------------------------------------------------------++unwrapContext :: forall m introduce context. (Monad m) => (ExampleT context m [Result] -> ExampleT context m ()) -> ExampleT (introduce :> context) m [Result] -> ExampleT (introduce :> context) m ()+unwrapContext f (ExampleT action) = do+  i :> _ <- ask+  ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT $ f $ ExampleT (withReaderT (i :>) action)+++-- | Convert a spec to a run tree+alterTopLevelNodeOptions :: (NodeOptions -> NodeOptions) -> Free (SpecCommand context IO) r -> Free (SpecCommand context IO) r+alterTopLevelNodeOptions g (Free x) = Free (x { nodeOptions = g (nodeOptions x)+                                              , next = alterTopLevelNodeOptions g (next x)})+alterTopLevelNodeOptions _ x@(Pure _) = x++systemVisibilityThreshold :: Int+systemVisibilityThreshold = 150

@@ -0,0 +1,139 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Test.Sandwich.Types.TestTimer where++import Control.Concurrent+import Control.Lens+import Data.Aeson as A+import Data.Aeson.TH as A+import qualified Data.List as L+import Data.Sequence+import qualified Data.Text as T+import Data.Time.Clock.POSIX+import System.IO+import Test.Sandwich.Types.Spec+++-- * SpeedScope types++data SpeedScopeFrame = SpeedScopeFrame {+  _name :: T.Text+  } deriving (Show, Eq)+$(deriveJSON (A.defaultOptions {+                 A.fieldLabelModifier = L.drop 1+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeFrame)+$(makeFieldsNoPrefix ''SpeedScopeFrame)++data SpeedScopeShared = SpeedScopeShared {+  _frames :: Seq SpeedScopeFrame+  } deriving Show+$(deriveJSON (A.defaultOptions {+                 A.fieldLabelModifier = L.drop 1+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeShared)+$(makeFieldsNoPrefix ''SpeedScopeShared)++data SpeedScopeEventType = SpeedScopeEventTypeOpen | SpeedScopeEventTypeClose+  deriving (Show, Eq)+$(deriveJSON (A.defaultOptions {+                 A.constructorTagModifier = L.take 1 . L.drop (L.length ("SpeedScopeEventType" :: String))+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeEventType)++data SpeedScopeEvent = SpeedScopeEvent {+  _typ :: SpeedScopeEventType+  , _frame :: Int+  , _at :: POSIXTime+  } deriving Show+$(deriveJSON (A.defaultOptions {+                 A.fieldLabelModifier = \x -> case x of+                     "_typ" -> "type"+                     _ -> L.drop 1 x+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeEvent)+$(makeFieldsNoPrefix ''SpeedScopeEvent)++data SpeedScopeProfile = SpeedScopeProfile {+  _typ :: T.Text+  , _name :: T.Text+  , _unit :: T.Text+  , _startValue :: POSIXTime+  , _endValue :: POSIXTime+  , _events :: Seq SpeedScopeEvent+  } deriving Show+$(deriveJSON (A.defaultOptions {+                 A.fieldLabelModifier = \x -> case x of+                     "_typ" -> "type"+                     _ -> L.drop 1 x+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeProfile)+$(makeFieldsNoPrefix ''SpeedScopeProfile)++data SpeedScopeFile = SpeedScopeFile {+  _exporter :: T.Text+  , _name :: T.Text+  , _activeProfileIndex :: Int+  , _schema :: T.Text+  , _shared :: SpeedScopeShared+  , _profiles :: [SpeedScopeProfile]+  } deriving Show+$(deriveJSON (A.defaultOptions {+                 A.fieldLabelModifier = \x -> case x of+                     "_schema" -> "$schema"+                     _ -> L.drop 1 x+                 , A.sumEncoding = A.UntaggedValue+                 }) ''SpeedScopeFile)+$(makeFieldsNoPrefix ''SpeedScopeFile)++emptySpeedScopeFile =+  SpeedScopeFile {+    _exporter = "sandwich-test-exporter"+    , _name = "sandwich-test"+    , _activeProfileIndex = 0+    , _schema = "https://www.speedscope.app/file-format-schema.json"+    , _shared = SpeedScopeShared {+        _frames = mempty+        }+    , _profiles = []+    }++newProfile :: T.Text -> POSIXTime -> SpeedScopeProfile+newProfile profileName startTime = SpeedScopeProfile {+  _typ = "evented"+  , _name = profileName+  , _unit = "seconds"+  , _startValue = startTime+  , _endValue = startTime+  , _events = mempty+  }++-- * Main type++data TestTimer = SpeedScopeTestTimer {+  testTimerBasePath :: FilePath+  , testTimerHandle :: Maybe Handle+  , testTimerSpeedScopeFile :: MVar SpeedScopeFile+  } | NullTestTimer++-- * Labels and classes++defaultProfileName :: T.Text+defaultProfileName = "default"++class HasTestTimer context where+  getTestTimer :: context -> TestTimer++testTimerProfile = Label :: Label "testTimerProfile" TestTimerProfile++newtype TestTimerProfile = TestTimerProfile T.Text

@@ -0,0 +1,13 @@+-- |++module Test.Sandwich.Util where++import Control.Monad++whenLeft :: (Monad m) => Either a b -> (a -> m ()) -> m ()+whenLeft (Left x) action = action x+whenLeft (Right _) _ = return ()++whenJust :: (Monad m) => Maybe a -> (a -> m b) -> m ()+whenJust Nothing _ = return ()+whenJust (Just x) action = void $ action x

@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Around where+++import Control.Concurrent+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import Data.String.Interpolate+import GHC.Stack+import Test.Sandwich++import TestUtil++tests :: MonadIO m => WriterT [SomeException] m ()+tests = do+  run aroundDoesNotFailureOnChildFailure+  run aroundReceivesSubtreeResult++main = mainWith tests++-- * Tests+++aroundDoesNotFailureOnChildFailure :: (HasCallStack) => IO ()+aroundDoesNotFailureOnChildFailure = do+  results <- runAndGetResults $ around "around label" void $ do+    it "does thing 1" $ 2 `shouldBe` 3+    it "does thing 1" $ 2 `shouldBe` 2++  case results of+    [Success, Failure {}, Success] -> return ()+    xs -> error [i|Unexpected result: '#{xs}'|]++aroundReceivesSubtreeResult :: (HasCallStack) => IO ()+aroundReceivesSubtreeResult = do+  mvar <- newEmptyMVar++  _ <- runAndGetResults $ around "around label" (>>= (liftIO . putMVar mvar)) $ do+    it "does thing 1" $ 2 `shouldBe` 3+    it "does thing 1" $ 2 `shouldBe` 2++  takeMVar mvar >>= \case+    [Failure {}, Success] -> return ()+    xs -> error [i|Expected a failure and a success, but got '#{xs}'|]

@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Before where++import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import qualified Data.List as L+import GHC.Stack+import Test.Sandwich+import TestUtil+++tests :: MonadIO m => WriterT [SomeException] m ()+tests = do+  run beforeExceptionSafety+  run beforeExceptionSafetyNested++main = mainWith tests++-- * Tests++beforeExceptionSafety :: (HasCallStack) => IO ()+beforeExceptionSafety = do+  results <- runAndGetResults $ before "before label" throwSomeUserError $ do+    it "does thing 1" $ return ()+    it "does thing 2" $ return ()++  results `mustBe` (Failure (GotException Nothing (Just "Exception in before 'before label' handler") someUserErrorWrapped)+                    : L.replicate 2 (Failure (GetContextException Nothing (SomeExceptionWithEq (toException $ GotException Nothing (Just "Exception in before 'before label' handler") someUserErrorWrapped)))))++beforeExceptionSafetyNested :: (HasCallStack) => IO ()+beforeExceptionSafetyNested = do+  results <- runAndGetResults $ before "before label" throwSomeUserError $ do+    it "does thing 1" $ return ()+    it "does thing 2" $ return ()+    describe "nested things" $ do+      it "does nested thing 1" $ return ()+      it "does nested thing 2" $ return ()++  results `mustBe` (Failure (GotException Nothing (Just "Exception in before 'before label' handler") someUserErrorWrapped)+                    : L.replicate 5 (Failure (GetContextException Nothing (SomeExceptionWithEq (toException $ GotException Nothing (Just "Exception in before 'before label' handler") someUserErrorWrapped)))))

@@ -0,0 +1,39 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Describe where++import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import Data.String.Interpolate+import GHC.Stack+import Test.Sandwich+import TestUtil+++tests :: MonadIO m => WriterT [SomeException] m ()+tests = do+  run describeFailsWhenChildFails++main = mainWith tests++-- * Tests++describeFailsWhenChildFails :: (HasCallStack) => IO ()+describeFailsWhenChildFails = do+  results <- runAndGetResults $ describe "describe label" $ do+    it "does thing 1" $ throwSomeUserError+    it "does thing 2" $ return ()++  (results !! 0) `mustBe` (Failure (Reason {failureCallStack = Nothing, failureReason = "1 child failed"}))+  case results !! 1 of+    Failure (GotException {..}) -> do+      failureException `mustBe` someUserErrorWrapped+    x -> error [i|Expected failure but got: #{x}|]+  (results !! 2) `mustBe` Success

@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Introduce where+++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Trans.Writer+import Data.Foldable+import GHC.Stack+import Test.Sandwich+import Test.Sandwich.Internal+import Test.Sandwich.Internal.Running++import TestUtil++tests :: MonadIO m => WriterT [SomeException] m ()+tests = do+  run introduceCleansUpOnTestException+  run introduceDoesNotCleanUpOnAllocateException+  run introduceFailsOnCleanUpException+  run introduceCleansUpOnCancelDuringTest++main = mainWith tests++-- * Tests++introduceCleansUpOnTestException :: (HasCallStack) => IO ()+introduceCleansUpOnTestException = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do+    it "does thing 1" $ throwSomeUserError++  msgs `mustBe` [["doing cleanup"], []]+  results `mustBe` [Success+                   , Failure (GotException Nothing Nothing someUserErrorWrapped)]++introduceDoesNotCleanUpOnAllocateException :: (HasCallStack) => IO ()+introduceDoesNotCleanUpOnAllocateException = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (throwSomeUserError >> return FakeDatabase) (\_ -> debug "doing cleanup") $ do+    it "does thing 1" $ return ()++  msgs `mustBe` [[], []]+  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped)+                   , Failure (GetContextException Nothing (SomeExceptionWithEq (SomeException (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped))))]++introduceFailsOnCleanUpException :: (HasCallStack) => IO ()+introduceFailsOnCleanUpException = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> throwSomeUserError) $ do+    it "does thing 1" $ return ()++  msgs `mustBe` [[], []]+  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' cleanup handler") someUserErrorWrapped)+                   , Success]++introduceCleansUpOnCancelDuringTest :: (HasCallStack) => IO ()+introduceCleansUpOnCancelDuringTest = do+  mvar <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do+    it "does thing 1" $ do+      liftIO $ putMVar mvar ()+      liftIO $ threadDelay 999999999999999++  let [topNode@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] = rts++  -- Wait until we get into the actual test example, then cancel the top level async+  takeMVar mvar+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  _ <- mapM waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree+  let msgs = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree++  msgs `mustBe` [["doing cleanup"], []]+  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))]

@@ -0,0 +1,18 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Around+import qualified Before+import qualified Describe+import qualified Introduce+import TestUtil+++main = mainWith $ do+  Around.tests+  Before.tests+  Describe.tests+  Introduce.tests

@@ -0,0 +1,107 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module TestUtil where++import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad.IO.Class+import Control.Monad.Logger+import Control.Monad.Trans.Writer+import Data.Foldable+import Data.String.Interpolate+import GHC.Stack+import System.Exit+import Test.Sandwich+import Test.Sandwich.Internal+import Test.Sandwich.Internal.Running++-- * Main function++mainWith :: (HasCallStack) => WriterT [SomeException] IO () -> IO ()+mainWith tests = do+  results <- execWriterT tests++  case results of+    [] -> do+      putStrLn "All tests succeeded!"+    xs -> do+      putStrLn [i|\n\n#{length xs} test(s) failed\n\n|]+      forM_ xs $ \x -> putStrLn [i|#{x}\n\n|]+      exitWith (ExitFailure 1)+++-- * Values++data FakeDatabase = FakeDatabase deriving Show+fakeDatabaseLabel = Label :: Label "fakeDatabase" FakeDatabase++someUserError = userError "Oh no"+someUserErrorWrapped = SomeExceptionWithEq $ SomeException $ userError "Oh no"++-- * Helpers++run :: MonadIO m => IO () -> WriterT [SomeException] m ()+run test = (liftIO $ tryAny test) >>= \case+  Left err -> tell [err]+  Right () -> return ()++throwSomeUserError :: (MonadIO m) => m ()+throwSomeUserError = liftIO $ throwIO someUserError++runAndGetResults :: (HasCallStack) => CoreSpec -> IO [Result]+runAndGetResults spec = do+  finalTree <- runSandwichTree defaultOptions spec+  fixedTree <- atomically $ mapM fixRunTree finalTree+  return $ fmap statusToResult $ concatMap getStatuses fixedTree++runAndGetResultsAndLogs :: CoreSpec -> IO ([Result], [[LogStr]])+runAndGetResultsAndLogs spec = do+  finalTree <- runSandwichTree defaultOptions spec+  getResultsAndMessages <$> fixTree finalTree++fixTree rts = atomically $ mapM fixRunTree rts++getResultsAndMessages fixedTree = (results, msgs)+  where+    results = fmap statusToResult $ concatMap getStatuses fixedTree+    msgs = getMessages fixedTree++getMessages fixedTree = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree++getStatuses :: (HasCallStack) => RunNodeWithStatus context s l t -> [(String, s)]+getStatuses = extractValues $ \node -> (runTreeLabel $ runNodeCommon node, runTreeStatus $ runNodeCommon node)++getLogs :: (HasCallStack) => RunNodeWithStatus context s l t -> [l]+getLogs = extractValues $ \node -> runTreeLogs $ runNodeCommon node++statusToResult :: (HasCallStack) => (String, Status) -> Result+statusToResult (label, NotStarted) = error [i|Expected status to be Done but was NotStarted for label '#{label}'|]+statusToResult (label, Running {}) = error [i|Expected status to be Done but was Running for label '#{label}'|]+statusToResult (_, Done _ _ result) = result++mustBe :: (HasCallStack, Eq a, Show a) => a -> a -> IO ()+mustBe x y+  | x == y = return ()+  | otherwise = error [i|Expected #{show y} but got #{show x}|]++waitUntilRunning status = atomically $ do+  readTVar status >>= \case+    Running {} -> return ()+    _ -> retry++-- printFixedRunTree :: RunNodeFixed -> IO ()+-- printFixedRunTree = printFixedRunTree' 0+--   where+--     printFixedRunTree' :: Int -> RunNodeFixed -> IO ()+--     printFixedRunTree' indent (RunTreeGroup {..}) = do+--       putStrLn [i|#{indentation}#{runTreeLabel} [#{statusResult runTreeStatus}]|]+--       forM_ runTreeChildren (printFixedRunTree' (indent + 1))+--       where indentation = L.replicate (indent * 4) ' '+--     printFixedRunTree' indent (RunTreeSingle {..}) = putStrLn [i|#{indentation}#{runTreeLabel} [#{statusResult runTreeStatus}]|]+--       where indentation = L.replicate (indent * 4) ' '