{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
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
(Int -> Status -> ShowS)
-> (Status -> String) -> ([Status] -> ShowS) -> Show Status
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
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
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 :: {
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon :: RunNodeCommonWithStatus s l t
, RunNodeWithStatus context s l t
-> [RunNodeWithStatus context s l t]
runNodeChildren :: [RunNodeWithStatus context s l t]
, 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]
, 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]
, 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
, 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)
data RunNodeCommonWithStatus s l t = RunNodeCommonWithStatus {
RunNodeCommonWithStatus s l t -> String
runTreeLabel :: String
, RunNodeCommonWithStatus s l t -> Int
runTreeId :: Int
, RunNodeCommonWithStatus s l t -> Seq Int
runTreeAncestors :: Seq Int
, RunNodeCommonWithStatus s l t -> t
runTreeToggled :: t
, RunNodeCommonWithStatus s l t -> t
runTreeOpen :: t
, RunNodeCommonWithStatus s l t -> s
runTreeStatus :: s
, RunNodeCommonWithStatus s l t -> Bool
runTreeVisible :: Bool
, RunNodeCommonWithStatus s l t -> Maybe String
runTreeFolder :: Maybe FilePath
, RunNodeCommonWithStatus s l t -> Int
runTreeVisibilityLevel :: Int
, RunNodeCommonWithStatus s l t -> Bool
runTreeRecordTime :: Bool
, RunNodeCommonWithStatus s l t -> l
runTreeLogs :: l
, RunNodeCommonWithStatus s l t -> Maybe SrcLoc
runTreeLoc :: Maybe SrcLoc
} deriving (Int -> RunNodeCommonWithStatus s l t -> ShowS
[RunNodeCommonWithStatus s l t] -> ShowS
RunNodeCommonWithStatus s l t -> String
(Int -> RunNodeCommonWithStatus s l t -> ShowS)
-> (RunNodeCommonWithStatus s l t -> String)
-> ([RunNodeCommonWithStatus s l t] -> ShowS)
-> Show (RunNodeCommonWithStatus s l t)
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
(RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool)
-> (RunNodeCommonWithStatus s l t
-> RunNodeCommonWithStatus s l t -> Bool)
-> Eq (RunNodeCommonWithStatus s l t)
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)
type Var = TVar
data LogEntry = LogEntry { LogEntry -> UTCTime
logEntryTime :: UTCTime
, LogEntry -> Loc
logEntryLoc :: Loc
, LogEntry -> LogSource
logEntrySource :: LogSource
, LogEntry -> LogLevel
logEntryLevel :: LogLevel
, LogEntry -> LogStr
logEntryStr :: LogStr
} deriving (Int -> LogEntry -> ShowS
[LogEntry] -> ShowS
LogEntry -> String
(Int -> LogEntry -> ShowS)
-> (LogEntry -> String) -> ([LogEntry] -> ShowS) -> Show LogEntry
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
(LogEntry -> LogEntry -> Bool)
-> (LogEntry -> LogEntry -> Bool) -> Eq LogEntry
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)
data RunTreeContext = RunTreeContext {
RunTreeContext -> Maybe String
runTreeCurrentFolder :: Maybe FilePath
, RunTreeContext -> Seq Int
runTreeCurrentAncestors :: Seq Int
, RunTreeContext -> Int
runTreeIndexInParent :: Int
, RunTreeContext -> Int
runTreeNumSiblings :: Int
}
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 -> LogSource
baseContextTestTimerProfile :: T.Text
, BaseContext -> TestTimer
baseContextTestTimer :: TestTimer
}
class HasBaseContext a where
getBaseContext :: a -> BaseContext
modifyBaseContext :: a -> (BaseContext -> BaseContext) -> a
instance HasBaseContext BaseContext where
getBaseContext :: BaseContext -> BaseContext
getBaseContext = BaseContext -> BaseContext
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) = context -> BaseContext
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 intro -> context -> intro :> context
forall a b. a -> b -> a :> b
:> context -> (BaseContext -> BaseContext) -> context
forall a.
HasBaseContext a =>
a -> (BaseContext -> BaseContext) -> a
modifyBaseContext context
ctx BaseContext -> BaseContext
f
instance HasBaseContext context => HasTestTimer context where
getTestTimer :: context -> TestTimer
getTestTimer = BaseContext -> TestTimer
baseContextTestTimer (BaseContext -> TestTimer)
-> (context -> BaseContext) -> context -> TestTimer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> context -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext
type CoreSpec = Spec BaseContext IO
type TopSpec = forall context. HasBaseContext context => SpecFree context IO ()
commandLineOptions :: Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions = forall a. Label "commandLineOptions" (CommandLineOptions a)
forall k (l :: Symbol) (a :: k). Label l a
Label :: Label "commandLineOptions" (CommandLineOptions a)
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 ()
class Formatter f where
formatterName :: f -> String
runFormatter :: (MonadIO m, MonadLogger m, MonadUnliftIO m, MonadCatch m) => f -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()
finalizeFormatter :: (MonadIO m, MonadLogger m, MonadCatch m) => f -> [RunNode BaseContext] -> BaseContext -> m ()
data SomeFormatter = forall f. (Formatter f, Typeable f) => SomeFormatter f
data TestArtifactsDirectory =
TestArtifactsNone
| TestArtifactsFixedDirectory {
TestArtifactsDirectory -> String
testRootFixed :: FilePath
}
| TestArtifactsGeneratedDirectory {
TestArtifactsDirectory -> String
runsRoot :: FilePath
, TestArtifactsDirectory -> IO String
getTestRunDirectoryName :: IO FilePath
}
newtype TreeFilter = TreeFilter String
type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> BS8.ByteString
defaultLogEntryFormatter :: LogEntryFormatter
defaultLogEntryFormatter :: LogEntryFormatter
defaultLogEntryFormatter UTCTime
ts Loc
loc LogSource
src LogLevel
level LogStr
msg = LogStr -> ByteString
fromLogStr (LogStr -> ByteString) -> LogStr -> ByteString
forall a b. (a -> b) -> a -> b
$
ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %X%4Q %Z" UTCTime
ts)
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" ["
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogLevel -> LogStr
defaultLogLevelStr LogLevel
level
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"] ("
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
src
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
") "
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> (if Loc -> Bool
isDefaultLoc Loc
loc then LogStr
"" else LogStr
"@(" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Loc -> String
fileLocStr Loc
loc) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
") ")
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
msg
LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
"\n"
where
defaultLogLevelStr :: LogLevel -> LogStr
defaultLogLevelStr :: LogLevel -> LogStr
defaultLogLevelStr LogLevel
level = case LogLevel
level of
LevelOther LogSource
t -> LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
t
LogLevel
_ -> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BS8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
Prelude.drop Int
5 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ LogLevel -> String
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) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
loc_module Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++
Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
loc_filename Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
line Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
char Loc
loc)
where
line :: Loc -> String
line = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> a
fst ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start
char :: Loc -> String
char = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Int) -> Int
forall a b. (a, b) -> b
snd ((Int, Int) -> Int) -> (Loc -> (Int, Int)) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> (Int, Int)
loc_start
data TestTimerType =
NullTestTimerType
| SpeedScopeTestTimerType { TestTimerType -> Bool
speedScopeTestTimerWriteRawTimings :: Bool
}
data Options = Options {
Options -> TestArtifactsDirectory
optionsTestArtifactsDirectory :: TestArtifactsDirectory
, Options -> Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
, Options -> Maybe LogLevel
optionsMemoryLogLevel :: Maybe LogLevel
, Options -> LogEntryFormatter
optionsLogFormatter :: LogEntryFormatter
, Options -> Maybe TreeFilter
optionsFilterTree :: Maybe TreeFilter
, Options -> Bool
optionsDryRun :: Bool
, Options -> [SomeFormatter]
optionsFormatters :: [SomeFormatter]
, Options -> Maybe String
optionsProjectRoot :: Maybe FilePath
, Options -> TestTimerType
optionsTestTimerType :: TestTimerType
}
data SomeExceptionWithCallStack = forall e. Exception e => SomeExceptionWithCallStack e CallStack
instance Show SomeExceptionWithCallStack where
showsPrec :: Int -> SomeExceptionWithCallStack -> ShowS
showsPrec Int
p (SomeExceptionWithCallStack e
e CallStack
_) = Int -> e -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p e
e
instance Exception SomeExceptionWithCallStack