{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE StandaloneDeriving #-}

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
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 { Status -> UTCTime
statusStartTime :: UTCTime
                      , Status -> Async Result
statusAsync :: Async Result }
            | Done { statusStartTime :: UTCTime
                   , Status -> UTCTime
statusEndTime :: UTCTime
                   , Status -> Result
statusResult :: Result }
            deriving (Int -> Status -> ShowS
[Status] -> ShowS
Status -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Status] -> ShowS
$cshowList :: [Status] -> ShowS
show :: Status -> String
$cshow :: Status -> String
showsPrec :: Int -> Status -> ShowS
$cshowsPrec :: Int -> Status -> ShowS
Show, Status -> Status -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq)

instance Show (Async Result) where
  show :: Async Result -> String
show Async Result
_ = String
"AsyncResult"


data RunNodeWithStatus context s l t where
  RunNodeBefore :: {
    forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon :: RunNodeCommonWithStatus s l t
    , forall s l t context.
RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeChildren :: [RunNodeWithStatus context s l t]
    , forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
runNodeBefore :: ExampleT context IO ()
    } -> RunNodeWithStatus context s l t
  RunNodeAfter :: {
    runNodeCommon :: RunNodeCommonWithStatus s l t
    , runNodeChildren :: [RunNodeWithStatus context s l t]
    , forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
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]
    , forall s l t context.
RunNodeWithStatus context s l t
-> ExampleT context IO [Result] -> ExampleT context IO ()
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
    , forall s l t context.
RunNodeWithStatus context s l t -> ExampleT context IO ()
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 {
  forall s l t. RunNodeCommonWithStatus s l t -> String
runTreeLabel :: String
  , forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeId :: Int
  , forall s l t. RunNodeCommonWithStatus s l t -> Seq Int
runTreeAncestors :: Seq Int
  , forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeToggled :: t
  , forall s l t. RunNodeCommonWithStatus s l t -> t
runTreeOpen :: t
  , forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus :: s
  , forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeVisible :: Bool
  , forall s l t. RunNodeCommonWithStatus s l t -> Maybe String
runTreeFolder :: Maybe FilePath
  , forall s l t. RunNodeCommonWithStatus s l t -> Int
runTreeVisibilityLevel :: Int
  , forall s l t. RunNodeCommonWithStatus s l t -> Bool
runTreeRecordTime :: Bool
  , forall s l t. RunNodeCommonWithStatus s l t -> l
runTreeLogs :: l
  , forall s l t. RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLoc :: Maybe SrcLoc
  } deriving (Int -> RunNodeCommonWithStatus s l t -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s l t.
(Show t, Show s, Show l) =>
Int -> RunNodeCommonWithStatus s l t -> ShowS
forall s l t.
(Show t, Show s, Show l) =>
[RunNodeCommonWithStatus s l t] -> ShowS
forall s l t.
(Show t, Show s, Show l) =>
RunNodeCommonWithStatus s l t -> String
showList :: [RunNodeCommonWithStatus s l t] -> ShowS
$cshowList :: forall s l t.
(Show t, Show s, Show l) =>
[RunNodeCommonWithStatus s l t] -> ShowS
show :: RunNodeCommonWithStatus s l t -> String
$cshow :: forall s l t.
(Show t, Show s, Show l) =>
RunNodeCommonWithStatus s l t -> String
showsPrec :: Int -> RunNodeCommonWithStatus s l t -> ShowS
$cshowsPrec :: forall s l t.
(Show t, Show s, Show l) =>
Int -> RunNodeCommonWithStatus s l t -> ShowS
Show, RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s l t.
(Eq t, Eq s, Eq l) =>
RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
/= :: RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
$c/= :: forall s l t.
(Eq t, Eq s, Eq l) =>
RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
== :: RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
$c== :: forall s l t.
(Eq t, Eq s, Eq l) =>
RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool
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 {
  LogEntry -> UTCTime
logEntryTime :: UTCTime
  , LogEntry -> Loc
logEntryLoc :: Loc
  , LogEntry -> Text
logEntrySource :: LogSource
  , LogEntry -> LogLevel
logEntryLevel :: LogLevel
  , LogEntry -> LogStr
logEntryStr :: LogStr
  } deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogEntry] -> ShowS
$cshowList :: [LogEntry] -> ShowS
show :: LogEntry -> String
$cshow :: LogEntry -> String
showsPrec :: Int -> LogEntry -> ShowS
$cshowsPrec :: Int -> LogEntry -> ShowS
Show, LogEntry -> LogEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogEntry -> LogEntry -> Bool
$c/= :: LogEntry -> LogEntry -> Bool
== :: LogEntry -> LogEntry -> Bool
$c== :: LogEntry -> LogEntry -> Bool
Eq)

-- | Context passed around through the evaluation of a RunTree
data RunTreeContext = RunTreeContext {
  RunTreeContext -> Maybe String
runTreeCurrentFolder :: Maybe FilePath
  , RunTreeContext -> Seq Int
runTreeCurrentAncestors :: Seq Int
  , RunTreeContext -> Int
runTreeIndexInParent :: Int
  , RunTreeContext -> Int
runTreeNumSiblings :: Int
  }

-- * Base context

-- | The base context available to every test node.
-- Contains various paths and timing information.
data BaseContext = BaseContext {
  BaseContext -> Maybe String
baseContextPath :: Maybe FilePath
  , BaseContext -> Maybe String
baseContextRunRoot :: Maybe FilePath
  , BaseContext -> Maybe String
baseContextErrorSymlinksDir :: Maybe FilePath
  , BaseContext -> Options
baseContextOptions :: Options
  , BaseContext -> Maybe (Set Int)
baseContextOnlyRunIds :: Maybe (S.Set Int)
  , BaseContext -> Text
baseContextTestTimerProfile :: T.Text
  , BaseContext -> TestTimer
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 :: BaseContext -> BaseContext
getBaseContext = forall a. a -> a
id
  modifyBaseContext :: BaseContext -> (BaseContext -> BaseContext) -> BaseContext
modifyBaseContext BaseContext
x BaseContext -> BaseContext
f = BaseContext -> BaseContext
f BaseContext
x

instance HasBaseContext context => HasBaseContext (intro :> context) where
  getBaseContext :: (intro :> context) -> BaseContext
getBaseContext (intro
_ :> context
ctx) = forall a. HasBaseContext a => a -> BaseContext
getBaseContext context
ctx
  modifyBaseContext :: (intro :> context)
-> (BaseContext -> BaseContext) -> intro :> context
modifyBaseContext (intro
intro :> context
ctx) BaseContext -> BaseContext
f = intro
intro forall a b. a -> b -> a :> b
:> forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx BaseContext -> BaseContext
f

-- Timing related
instance HasBaseContext context => HasTestTimer context where
  getTestTimer :: context -> TestTimer
getTestTimer = BaseContext -> TestTimer
baseContextTestTimer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. HasBaseContext a => a -> BaseContext
getBaseContext

type CoreSpec = Spec BaseContext IO

type TopSpec = forall context. HasBaseContext context => SpecFree context IO ()

-- * Specs with command line options provided

commandLineOptions :: Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions = forall {k} (l :: Symbol) (a :: k). Label l a
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 :: (MonadLoggerIO 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, Show f, Typeable f) => SomeFormatter f

deriving instance Show SomeFormatter

-- * Options

-- | Control whether test artifacts are stored to a directory.
data TestArtifactsDirectory =
  TestArtifactsNone
  -- ^ Do not create a test artifacts directory.
  | TestArtifactsFixedDirectory {
      TestArtifactsDirectory -> String
testRootFixed :: FilePath
      }
  -- ^ Use the test artifacts directory at the given path, creating it if necessary.
  | TestArtifactsGeneratedDirectory {
      TestArtifactsDirectory -> String
runsRoot :: FilePath
      -- ^ The root folder under which test run directories will be created.
      , TestArtifactsDirectory -> IO String
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 { TreeFilter -> [String]
unTreeFilter :: [String] }

type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

-- | A callback for formatting a log entry to a 'BS8.ByteString'.
type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> BS8.ByteString

-- The defaultLogStr formatter weirdly puts information after the message. Use our own
defaultLogEntryFormatter :: LogEntryFormatter
defaultLogEntryFormatter :: LogEntryFormatter
defaultLogEntryFormatter UTCTime
ts Loc
loc Text
src LogLevel
level LogStr
msg = LogStr -> ByteString
fromLogStr forall a b. (a -> b) -> a -> b
$
  forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %X%4Q %Z" UTCTime
ts)
  forall a. Semigroup a => a -> a -> a
<> LogStr
" ["
  forall a. Semigroup a => a -> a -> a
<> LogLevel -> LogStr
defaultLogLevelStr LogLevel
level
  forall a. Semigroup a => a -> a -> a
<> LogStr
"] ("
  forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
src
  forall a. Semigroup a => a -> a -> a
<> LogStr
") "
  forall a. Semigroup a => a -> a -> a
<> (if Loc -> Bool
isDefaultLoc Loc
loc then LogStr
"" else LogStr
"@(" forall a. Semigroup a => a -> a -> a
<> forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ Loc -> String
fileLocStr Loc
loc) forall a. Semigroup a => a -> a -> a
<> LogStr
") ")
  forall a. Semigroup a => a -> a -> a
<> LogStr
msg
  forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"

  where
    defaultLogLevelStr :: LogLevel -> LogStr
    defaultLogLevelStr :: LogLevel -> LogStr
defaultLogLevelStr LogLevel
level = case LogLevel
level of
      LevelOther Text
t -> forall msg. ToLogStr msg => msg -> LogStr
toLogStr Text
t
      LogLevel
_ -> forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS8.pack forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
Prelude.drop Int
5 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show LogLevel
level

    isDefaultLoc :: Loc -> Bool
    isDefaultLoc :: Loc -> Bool
isDefaultLoc (Loc String
"<unknown>" String
"<unknown>" String
"<unknown>" (Int
0,Int
0) (Int
0,Int
0)) = Bool
True
    isDefaultLoc Loc
_ = Bool
False

    fileLocStr :: Loc -> String
fileLocStr Loc
loc = (Loc -> String
loc_package Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
loc_module Loc
loc) forall a. [a] -> [a] -> [a]
++
      Char
' ' forall a. a -> [a] -> [a]
: (Loc -> String
loc_filename Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
line Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
char Loc
loc)
      where
        line :: Loc -> String
line = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start
        char :: Loc -> String
char = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start

data TestTimerType =
  NullTestTimerType
  -- ^ Don't run a test timer
  | SpeedScopeTestTimerType { TestTimerType -> Bool
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 {
  Options -> TestArtifactsDirectory
optionsTestArtifactsDirectory :: TestArtifactsDirectory
  -- ^ Where to save test artifacts (logs, screenshots, failure reports, etc.).
  , Options -> Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
  -- ^ Minimum test log level to save (has no effect if 'optionsTestArtifactsDirectory' is 'TestArtifactsNone').
  , Options -> Maybe LogLevel
optionsMemoryLogLevel :: Maybe LogLevel
  -- ^ Test log level to store in memory while tests are running. (These logs are presented in formatters, etc.).
  , Options -> LogEntryFormatter
optionsLogFormatter :: LogEntryFormatter
  -- ^ Formatter function for log entries.
  , Options -> Maybe TreeFilter
optionsFilterTree :: Maybe TreeFilter
  -- ^ Filter to apply to the text tree before running.
  , Options -> Bool
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.
  , Options -> [SomeFormatter]
optionsFormatters :: [SomeFormatter]
  -- ^ Which formatters to use to output the results of the tests.
  , Options -> Maybe String
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.
  , Options -> TestTimerType
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 :: Int -> SomeExceptionWithCallStack -> ShowS
showsPrec Int
p (SomeExceptionWithCallStack e
e CallStack
_) = forall a. Show a => Int -> a -> ShowS
showsPrec Int
p e
e
instance Exception SomeExceptionWithCallStack