content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE StandaloneDeriving #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  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 Control.Monad.Reader
  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 { statusStartTime :: UTCTime
                        , statusSetupFinishTime :: Maybe UTCTime
                        , statusTeardownStartTime :: Maybe UTCTime
                        , statusAsync :: Async Result }
              | Done { statusStartTime :: UTCTime
                     , statusSetupFinishTime :: Maybe UTCTime
                     , statusTeardownStartTime :: Maybe 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 {
    runTreeCurrentAncestors :: Seq Int
    , runTreeRootFolderAndNumChildren :: Maybe (FilePath, 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, Typeable context) => SpecFree context IO ()
  
  type HasBaseContextMonad context m = (HasBaseContext context, MonadReader context m)
  
  -- * Specs with command line options provided
  
  commandLineOptions :: Label "commandLineOptions" (CommandLineOptions a)
  commandLineOptions = Label :: Label "commandLineOptions" (CommandLineOptions a)
  
  -- | Has-* class for asserting a 'CommandLineOptions a' is available.
  type HasCommandLineOptions context a = HasLabel context "commandLineOptions" (CommandLineOptions a)
  
  -- | Existential wrapper for 'CommandLineOptions a'.
  someCommandLineOptions :: Label "someCommandLineOptions" SomeCommandLineOptions
  someCommandLineOptions = Label :: Label "someCommandLineOptions" SomeCommandLineOptions
  data SomeCommandLineOptions where
    SomeCommandLineOptions :: CommandLineOptions a -> SomeCommandLineOptions
  type HasSomeCommandLineOptions context = HasLabel context "someCommandLineOptions" SomeCommandLineOptions
  
  type TopSpecWithOptions = forall context. (
    Typeable context
    , HasBaseContext context
    , HasCommandLineOptions context ()
    , HasSomeCommandLineOptions context
    ) => SpecFree context IO ()
  
  type TopSpecWithOptions' a = forall context. (
    Typeable context
    , HasBaseContext context
    , HasCommandLineOptions context a
    , HasSomeCommandLineOptions context
    ) => 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 {
        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 { 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 ts loc src level msg = fromLogStr $
    toLogStr (BS8.pack $ formatTime defaultTimeLocale "%F %X%4Q %Z" ts)
    <> " ["
    <> defaultLogLevelStr level
    <> "] ("
    <> toLogStr src
    <> ") "
    <> (if isDefaultLoc loc then "" else "@(" <> toLogStr (BS8.pack fileLocStr) <> ") ")
    <> msg
    <> "\n"
  
    where
      defaultLogLevelStr :: LogLevel -> LogStr
      defaultLogLevelStr lev = case lev of
        LevelOther t -> toLogStr t
        _ -> toLogStr $ BS8.pack $ Prelude.drop 5 $ show lev
  
      isDefaultLoc :: Loc -> Bool
      isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True
      isDefaultLoc _ = False
  
      fileLocStr = (loc_package loc) ++ ':' : (loc_module loc) ++
        ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
        where
          line = show . fst . loc_start
          char = show . snd . loc_start
  
  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.
    , optionsPruneTree :: Maybe TreeFilter
    -- ^ Filter to apply to the text tree before running that prunes out the matched tests and their subtrees.
    , optionsFilterTree :: Maybe TreeFilter
    -- ^ Filter to apply to the text tree before running that only retains the matched tests.
    , 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
  