{-# 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 -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree Options
options CoreSpec
spec = do
BaseContext
baseContext <- Options -> IO BaseContext
baseContextFromOptions Options
options
BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree' BaseContext
baseContext Options
options CoreSpec
spec
startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree' BaseContext
baseContext (Options {Bool
[SomeFormatter]
Maybe FilePath
Maybe LogLevel
Maybe TreeFilter
TestTimerType
TestArtifactsDirectory
LogEntryFormatter
optionsTestTimerType :: Options -> TestTimerType
optionsProjectRoot :: Options -> Maybe FilePath
optionsFormatters :: Options -> [SomeFormatter]
optionsDryRun :: Options -> Bool
optionsFilterTree :: Options -> Maybe TreeFilter
optionsLogFormatter :: Options -> LogEntryFormatter
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
optionsTestTimerType :: TestTimerType
optionsProjectRoot :: Maybe FilePath
optionsFormatters :: [SomeFormatter]
optionsDryRun :: Bool
optionsFilterTree :: Maybe TreeFilter
optionsLogFormatter :: LogEntryFormatter
optionsMemoryLogLevel :: Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
optionsTestArtifactsDirectory :: TestArtifactsDirectory
..}) CoreSpec
spec' = do
let spec :: CoreSpec
spec = forall b a. b -> (a -> b) -> Maybe a -> b
maybe CoreSpec
spec' (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> FilePath -> Free (SpecCommand context m) ()
filterTree CoreSpec
spec' forall b c a. (b -> c) -> (a -> b) -> a -> c
. TreeFilter -> [FilePath]
unTreeFilter) Maybe TreeFilter
optionsFilterTree
[RunNode BaseContext]
runTree <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ BaseContext -> CoreSpec -> STM [RunNode BaseContext]
specToRunTreeVariable BaseContext
baseContext CoreSpec
spec
if | Bool
optionsDryRun -> forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode BaseContext]
runTree BaseContext
baseContext Result
DryRun
| Bool
otherwise -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode BaseContext]
runTree BaseContext
baseContext
forall (m :: * -> *) a. Monad m => a -> m a
return [RunNode BaseContext]
runTree
runSandwichTree :: Options -> CoreSpec -> IO [RunNode BaseContext]
runSandwichTree :: Options -> CoreSpec -> IO [RunNode BaseContext]
runSandwichTree Options
options CoreSpec
spec = do
[RunNode BaseContext]
rts <- Options -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree Options
options CoreSpec
spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall context. RunNode context -> IO Result
waitForTree [RunNode BaseContext]
rts
forall (m :: * -> *) a. Monad m => a -> m a
return [RunNode BaseContext]
rts
runWithRepeat :: Int -> Int -> IO (ExitReason, Int) -> IO ()
runWithRepeat :: Int -> Int -> IO (ExitReason, Int) -> IO ()
runWithRepeat Int
0 Int
totalTests IO (ExitReason, Int)
action = do
(ExitReason
_, Int
numFailures) <- IO (ExitReason, Int)
action
if | Int
numFailures forall a. Eq a => a -> a -> Bool
== Int
0 -> Int -> Int -> IO (ExitReason, Int) -> IO ()
runWithRepeat Int
0 Int
totalTests IO (ExitReason, Int)
action
| Bool
otherwise -> forall a. IO a
exitFailure
runWithRepeat Int
n Int
totalTests IO (ExitReason, Int)
action = do
(Int
successes, Int
total) <- (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
0 :: Int, Int
0 :: Int)) forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> a) -> a
fix (Int
n forall a. Num a => a -> a -> a
- Int
1) forall a b. (a -> b) -> a -> b
$ \Int -> StateT (Int, Int) IO ()
loop Int
n -> do
(ExitReason
exitReason, Int
numFailures) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (ExitReason, Int)
action
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \(Int
successes, Int
total) -> (Int
successes forall a. Num a => a -> a -> a
+ (if Int
numFailures forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
0), Int
total forall a. Num a => a -> a -> a
+ Int
1)
if | ExitReason
exitReason forall a. Eq a => a -> a -> Bool
== ExitReason
SignalExit -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Int
n forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> StateT (Int, Int) IO ()
loop (Int
n forall a. Num a => a -> a -> a
- Int
1)
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
FilePath -> IO ()
putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
successes forall a. Eq a => a -> a -> Bool
/= Int
total) forall a b. (a -> b) -> a -> b
$ forall a. IO a
exitFailure
baseContextFromOptions :: Options -> IO BaseContext
baseContextFromOptions :: Options -> IO BaseContext
baseContextFromOptions options :: Options
options@(Options {Bool
[SomeFormatter]
Maybe FilePath
Maybe LogLevel
Maybe TreeFilter
TestTimerType
TestArtifactsDirectory
LogEntryFormatter
optionsTestTimerType :: TestTimerType
optionsProjectRoot :: Maybe FilePath
optionsFormatters :: [SomeFormatter]
optionsDryRun :: Bool
optionsFilterTree :: Maybe TreeFilter
optionsLogFormatter :: LogEntryFormatter
optionsMemoryLogLevel :: Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsTestTimerType :: Options -> TestTimerType
optionsProjectRoot :: Options -> Maybe FilePath
optionsFormatters :: Options -> [SomeFormatter]
optionsDryRun :: Options -> Bool
optionsFilterTree :: Options -> Maybe TreeFilter
optionsLogFormatter :: Options -> LogEntryFormatter
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
..}) = do
Maybe FilePath
runRoot <- case TestArtifactsDirectory
optionsTestArtifactsDirectory of
TestArtifactsDirectory
TestArtifactsNone -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
TestArtifactsFixedDirectory FilePath
dir' -> do
FilePath
dir <- case FilePath -> Bool
isAbsolute FilePath
dir' of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir'
Bool
False -> do
FilePath
here <- IO FilePath
getCurrentDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
here FilePath -> FilePath -> FilePath
</> FilePath
dir'
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
dir
TestArtifactsGeneratedDirectory FilePath
base' IO FilePath
f -> do
FilePath
base <- case FilePath -> Bool
isAbsolute FilePath
base' of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
base'
Bool
False -> do
FilePath
here <- IO FilePath
getCurrentDirectory
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FilePath
here FilePath -> FilePath -> FilePath
</> FilePath
base'
FilePath
name <- IO FilePath
f
let dir :: FilePath
dir = FilePath
base FilePath -> FilePath -> FilePath
</> FilePath
name
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just FilePath
dir
TestTimer
testTimer <- case (TestTimerType
optionsTestTimerType, Maybe FilePath
runRoot) of
(SpeedScopeTestTimerType {Bool
speedScopeTestTimerWriteRawTimings :: TestTimerType -> Bool
speedScopeTestTimerWriteRawTimings :: Bool
..}, Just FilePath
rr) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ FilePath -> Bool -> IO TestTimer
newSpeedScopeTestTimer FilePath
rr Bool
speedScopeTestTimerWriteRawTimings
(TestTimerType, Maybe FilePath)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return TestTimer
NullTestTimer
let errorSymlinksDir :: Maybe FilePath
errorSymlinksDir = (FilePath -> FilePath -> FilePath
</> FilePath
"errors") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
runRoot
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe FilePath
errorSymlinksDir forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ BaseContext {
baseContextPath :: Maybe FilePath
baseContextPath = forall a. Monoid a => a
mempty
, baseContextOptions :: Options
baseContextOptions = Options
options
, baseContextRunRoot :: Maybe FilePath
baseContextRunRoot = Maybe FilePath
runRoot
, baseContextErrorSymlinksDir :: Maybe FilePath
baseContextErrorSymlinksDir = Maybe FilePath
errorSymlinksDir
, baseContextOnlyRunIds :: Maybe (Set Int)
baseContextOnlyRunIds = forall a. Maybe a
Nothing
, baseContextTestTimerProfile :: Text
baseContextTestTimerProfile = Text
defaultProfileName
, baseContextTestTimer :: TestTimer
baseContextTestTimer = TestTimer
testTimer
}
gatherNodeOptions :: Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions :: forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (Free x :: SpecCommand context m (Free (SpecCommand context m) r)
x@(It'' {})) = (forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) r)
x) forall a. a -> [a] -> [a]
: forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) r)
x)
gatherNodeOptions (Free (IntroduceWith'' {FilePath
Maybe SrcLoc
Free (SpecCommand context m) r
SpecFree (LabelValue l intro :> context) m ()
NodeOptions
Label l intro
(intro -> ExampleT context m [Result]) -> ExampleT context m ()
introduceAction :: ()
subspecAugmented :: ()
contextLabel :: ()
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> FilePath
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
next :: Free (SpecCommand context m) r
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
introduceAction :: (intro -> ExampleT context m [Result]) -> ExampleT context m ()
contextLabel :: Label l intro
label :: FilePath
nodeOptions :: NodeOptions
location :: Maybe SrcLoc
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
..})) = NodeOptions
nodeOptions forall a. a -> [a] -> [a]
: (forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
next forall a. Semigroup a => a -> a -> a
<> forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions SpecFree (LabelValue l intro :> context) m ()
subspecAugmented)
gatherNodeOptions (Free (Introduce'' {FilePath
Maybe SrcLoc
Free (SpecCommand context m) r
SpecFree (LabelValue l intro :> context) m ()
NodeOptions
Label l intro
ExampleT context m intro
intro -> ExampleT context m ()
cleanup :: ()
allocate :: ()
next :: Free (SpecCommand context m) r
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
cleanup :: intro -> ExampleT context m ()
allocate :: ExampleT context m intro
contextLabel :: Label l intro
label :: FilePath
nodeOptions :: NodeOptions
location :: Maybe SrcLoc
subspecAugmented :: ()
contextLabel :: ()
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> FilePath
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
..})) = NodeOptions
nodeOptions forall a. a -> [a] -> [a]
: (forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
next forall a. Semigroup a => a -> a -> a
<> forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions SpecFree (LabelValue l intro :> context) m ()
subspecAugmented)
gatherNodeOptions (Free SpecCommand context m (Free (SpecCommand context m) r)
x) = (forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) r)
x) forall a. a -> [a] -> [a]
: (forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) r)
x) forall a. Semigroup a => a -> a -> a
<> forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (forall context (m :: * -> *) next.
SpecCommand context m next -> SpecFree context m ()
subspec SpecCommand context m (Free (SpecCommand context m) r)
x))
gatherNodeOptions (Pure r
_) = []
gatherMainFunctions :: Free (SpecCommand context m) r -> [NodeModuleInfo]
gatherMainFunctions :: forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeModuleInfo]
gatherMainFunctions Free (SpecCommand context m) r
tests = forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
tests
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeOptions -> Maybe NodeModuleInfo
nodeOptionsModuleInfo
forall a b. a -> (a -> b) -> b
& forall a. [Maybe a] -> [a]
catMaybes
takenMainOptions :: [T.Text]
takenMainOptions :: [Text]
takenMainOptions = [
Text
"print", Text
"tui", Text
"silent", Text
"auto", Text
"markdown-summary"
, Text
"debug", Text
"info", Text
"warn", Text
"error"
, Text
"filter"
, Text
"repeat"
, Text
"fixed-root"
, Text
"list-tests"
, Text
"print-golden-flags"
, Text
"print-hedgehog-flags"
, Text
"print-quickcheck-flags"
, Text
"print-slack-flags"
, Text
"print-webdriver-flags"
, Text
"headless"
]
gatherShorthands :: [NodeModuleInfo] -> [(NodeModuleInfo, T.Text)]
gatherShorthands :: [NodeModuleInfo] -> [(NodeModuleInfo, Text)]
gatherShorthands = [Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, Text)]
gatherShorthands' []
where
gatherShorthands' :: [T.Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, T.Text)]
gatherShorthands' :: [Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, Text)]
gatherShorthands' [Text]
_ [] = []
gatherShorthands' [Text]
taken (NodeModuleInfo
x:[NodeModuleInfo]
xs) = (NodeModuleInfo
x, Text
newShorthand) forall a. a -> [a] -> [a]
: ([Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, Text)]
gatherShorthands' (Text
newShorthand forall a. a -> [a] -> [a]
: [Text]
taken) [NodeModuleInfo]
xs)
where newShorthand :: Text
newShorthand = [Text] -> NodeModuleInfo -> Text
getShorthand [Text]
taken NodeModuleInfo
x
getShorthand :: [T.Text] -> NodeModuleInfo -> T.Text
getShorthand :: [Text] -> NodeModuleInfo -> Text
getShorthand [Text]
taken NodeModuleInfo
nmi = forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
x -> Text
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
taken Bool -> Bool -> Bool
&& Text
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
takenMainOptions) forall a b. (a -> b) -> a -> b
$ NodeModuleInfo -> [Text]
getCandidates NodeModuleInfo
nmi
getCandidates :: NodeModuleInfo -> [T.Text]
getCandidates :: NodeModuleInfo -> [Text]
getCandidates (NodeModuleInfo {nodeModuleInfoModuleName :: NodeModuleInfo -> FilePath
nodeModuleInfoModuleName=FilePath
modName}) = [Text]
candidates
where parts :: [Text]
parts = Text -> Text -> [Text]
T.splitOn Text
"." (FilePath -> Text
T.pack FilePath
modName)
lastPart :: Text
lastPart = forall a. [a] -> a
last [Text]
parts
candidates :: [Text]
candidates = (Text -> Text
toDashed Text
lastPart) forall a. a -> [a] -> [a]
: [Text -> Text
toDashed [i|#{lastPart}#{n}|] | Integer
n <- [(Integer
2 :: Integer)..]]
toDashed :: T.Text -> T.Text
toDashed :: Text -> Text
toDashed Text
t = Text
t forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> FilePath -> [FilePath]
splitR Char -> Bool
isUpper
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)
forall a b. a -> (a -> b) -> b
& Text -> [Text] -> Text
T.intercalate Text
"-"
splitR :: (Char -> Bool) -> String -> [String]
splitR :: (Char -> Bool) -> FilePath -> [FilePath]
splitR Char -> Bool
_ [] = []
splitR Char -> Bool
p FilePath
s =
let
go :: Char -> String -> [String]
go :: Char -> FilePath -> [FilePath]
go Char
m FilePath
s' = case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s' of
(FilePath
b', []) -> [ Char
mforall a. a -> [a] -> [a]
:FilePath
b' ]
(FilePath
b', Char
x:FilePath
xs) -> ( Char
mforall a. a -> [a] -> [a]
:FilePath
b' ) forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
x FilePath
xs
in case forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s of
(FilePath
b, []) -> [ FilePath
b ]
([], Char
h:FilePath
t) -> Char -> FilePath -> [FilePath]
go Char
h FilePath
t
(FilePath
b, Char
h:FilePath
t) -> FilePath
b forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
h FilePath
t