{-# 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.PruneTree
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 {optionsPruneTree :: Options -> Maybe TreeFilter
optionsPruneTree=(Maybe TreeFilter -> [FilePath]
unwrapTreeFilter -> [FilePath]
pruneOpts), optionsFilterTree :: Options -> Maybe TreeFilter
optionsFilterTree=(Maybe TreeFilter -> [FilePath]
unwrapTreeFilter -> [FilePath]
filterOpts), Bool
optionsDryRun :: Options -> Bool
optionsDryRun :: Bool
optionsDryRun}) CoreSpec
spec = do
[RunNode BaseContext]
runTree <- CoreSpec
spec
forall a b. a -> (a -> b) -> b
& (\CoreSpec
tree -> 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) ()
pruneTree CoreSpec
tree [FilePath]
pruneOpts)
forall a b. a -> (a -> b) -> b
& (\CoreSpec
tree -> 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
tree [FilePath]
filterOpts)
forall a b. a -> (a -> b) -> b
& forall a. STM a -> IO a
atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseContext -> CoreSpec -> STM [RunNode BaseContext]
specToRunTreeVariable BaseContext
baseContext
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
unwrapTreeFilter :: Maybe TreeFilter -> [String]
unwrapTreeFilter :: Maybe TreeFilter -> [FilePath]
unwrapTreeFilter = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] TreeFilter -> [FilePath]
unTreeFilter
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 :: Options -> TestTimerType
optionsProjectRoot :: Options -> Maybe FilePath
optionsFormatters :: Options -> [SomeFormatter]
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
optionsPruneTree :: Maybe TreeFilter
optionsLogFormatter :: LogEntryFormatter
optionsMemoryLogLevel :: Maybe LogLevel
optionsSavedLogLevel :: Maybe LogLevel
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsDryRun :: Options -> Bool
optionsFilterTree :: Options -> Maybe TreeFilter
optionsPruneTree :: Options -> Maybe TreeFilter
..}) = 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