{-# 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 :: Bool
optionsDryRun :: Options -> Bool
optionsDryRun}) CoreSpec
spec = do
  [RunNode BaseContext]
runTree <- CoreSpec
spec
    CoreSpec -> (CoreSpec -> CoreSpec) -> CoreSpec
forall a b. a -> (a -> b) -> b
& (\CoreSpec
tree -> (CoreSpec -> FilePath -> CoreSpec)
-> CoreSpec -> [FilePath] -> CoreSpec
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' CoreSpec -> FilePath -> CoreSpec
forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> FilePath -> Free (SpecCommand context m) ()
pruneTree CoreSpec
tree [FilePath]
pruneOpts)
    CoreSpec -> (CoreSpec -> CoreSpec) -> CoreSpec
forall a b. a -> (a -> b) -> b
& (\CoreSpec
tree -> (CoreSpec -> FilePath -> CoreSpec)
-> CoreSpec -> [FilePath] -> CoreSpec
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' CoreSpec -> FilePath -> CoreSpec
forall context (m :: * -> *).
Free (SpecCommand context m) ()
-> FilePath -> Free (SpecCommand context m) ()
filterTree CoreSpec
tree [FilePath]
filterOpts)
    CoreSpec
-> (CoreSpec -> IO [RunNode BaseContext])
-> IO [RunNode BaseContext]
forall a b. a -> (a -> b) -> b
& STM [RunNode BaseContext] -> IO [RunNode BaseContext]
forall a. STM a -> IO a
atomically (STM [RunNode BaseContext] -> IO [RunNode BaseContext])
-> (CoreSpec -> STM [RunNode BaseContext])
-> CoreSpec
-> IO [RunNode BaseContext]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseContext -> CoreSpec -> STM [RunNode BaseContext]
specToRunTreeVariable BaseContext
baseContext

  if | Bool
optionsDryRun -> [RunNode BaseContext] -> BaseContext -> Result -> IO ()
forall (m :: * -> *) context' context.
(MonadIO m, HasBaseContext context') =>
[RunNode context] -> context' -> Result -> m ()
markAllChildrenWithResult [RunNode BaseContext]
runTree BaseContext
baseContext Result
DryRun
     | Bool
otherwise -> IO (Async ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async ()) -> IO ()) -> IO (Async ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ IO [Result] -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO [Result] -> IO ()) -> IO [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [RunNode BaseContext] -> BaseContext -> IO [Result]
forall context.
HasBaseContext context =>
[RunNode context] -> context -> IO [Result]
runNodesSequentially [RunNode BaseContext]
runTree BaseContext
baseContext

  [RunNode BaseContext] -> IO [RunNode BaseContext]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [RunNode BaseContext]
runTree

unwrapTreeFilter :: Maybe TreeFilter -> [String]
unwrapTreeFilter :: Maybe TreeFilter -> [FilePath]
unwrapTreeFilter = [FilePath]
-> (TreeFilter -> [FilePath]) -> Maybe TreeFilter -> [FilePath]
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
  (RunNode BaseContext -> IO Result)
-> [RunNode BaseContext] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunNode BaseContext -> IO Result
forall context. RunNode context -> IO Result
waitForTree [RunNode BaseContext]
rts
  [RunNode BaseContext] -> IO [RunNode BaseContext]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [RunNode BaseContext]
rts

-- | For 0 repeats, repeat until a failure
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 Int -> Int -> Bool
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 -> IO ()
forall a. IO a
exitFailure
-- | For 1 repeat, run once and return
runWithRepeat Int
n Int
totalTests IO (ExitReason, Int)
action = do
  (Int
successes, Int
total) <- ((StateT (Int, Int) IO () -> (Int, Int) -> IO (Int, Int))
-> (Int, Int) -> StateT (Int, Int) IO () -> IO (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Int, Int) IO () -> (Int, Int) -> IO (Int, Int)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
0 :: Int, Int
0 :: Int)) (StateT (Int, Int) IO () -> IO (Int, Int))
-> StateT (Int, Int) IO () -> IO (Int, Int)
forall a b. (a -> b) -> a -> b
$ (((Int -> StateT (Int, Int) IO ())
  -> Int -> StateT (Int, Int) IO ())
 -> Int -> StateT (Int, Int) IO ())
-> Int
-> ((Int -> StateT (Int, Int) IO ())
    -> Int -> StateT (Int, Int) IO ())
-> StateT (Int, Int) IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int -> StateT (Int, Int) IO ())
 -> Int -> StateT (Int, Int) IO ())
-> Int -> StateT (Int, Int) IO ()
forall a. (a -> a) -> a
fix (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (((Int -> StateT (Int, Int) IO ())
  -> Int -> StateT (Int, Int) IO ())
 -> StateT (Int, Int) IO ())
-> ((Int -> StateT (Int, Int) IO ())
    -> Int -> StateT (Int, Int) IO ())
-> StateT (Int, Int) IO ()
forall a b. (a -> b) -> a -> b
$ \Int -> StateT (Int, Int) IO ()
loop Int
n -> do
    (ExitReason
exitReason, Int
numFailures) <- IO (ExitReason, Int) -> StateT (Int, Int) IO (ExitReason, Int)
forall a. IO a -> StateT (Int, Int) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (ExitReason, Int)
action

    ((Int, Int) -> (Int, Int)) -> StateT (Int, Int) IO ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (((Int, Int) -> (Int, Int)) -> StateT (Int, Int) IO ())
-> ((Int, Int) -> (Int, Int)) -> StateT (Int, Int) IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
successes, Int
total) -> (Int
successes Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Int
numFailures Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
1 else Int
0), Int
total Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

    if | ExitReason
exitReason ExitReason -> ExitReason -> Bool
forall a. Eq a => a -> a -> Bool
== ExitReason
SignalExit -> () -> StateT (Int, Int) IO ()
forall a. a -> StateT (Int, Int) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 -> Int -> StateT (Int, Int) IO ()
loop (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
       | Bool
otherwise -> () -> StateT (Int, Int) IO ()
forall a. a -> StateT (Int, Int) IO a
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)|]

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
successes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
total) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO ()
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
optionsPruneTree :: Options -> Maybe TreeFilter
optionsFilterTree :: Options -> Maybe TreeFilter
optionsDryRun :: Options -> Bool
optionsTestArtifactsDirectory :: TestArtifactsDirectory
optionsSavedLogLevel :: Maybe LogLevel
optionsMemoryLogLevel :: Maybe LogLevel
optionsLogFormatter :: LogEntryFormatter
optionsPruneTree :: Maybe TreeFilter
optionsFilterTree :: Maybe TreeFilter
optionsDryRun :: Bool
optionsFormatters :: [SomeFormatter]
optionsProjectRoot :: Maybe FilePath
optionsTestTimerType :: TestTimerType
optionsTestArtifactsDirectory :: Options -> TestArtifactsDirectory
optionsSavedLogLevel :: Options -> Maybe LogLevel
optionsMemoryLogLevel :: Options -> Maybe LogLevel
optionsLogFormatter :: Options -> LogEntryFormatter
optionsFormatters :: Options -> [SomeFormatter]
optionsProjectRoot :: Options -> Maybe FilePath
optionsTestTimerType :: Options -> TestTimerType
..}) = do
  Maybe FilePath
runRoot <- case TestArtifactsDirectory
optionsTestArtifactsDirectory of
    TestArtifactsDirectory
TestArtifactsNone -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
forall a. Maybe a
Nothing
    TestArtifactsFixedDirectory FilePath
dir' -> do
      FilePath
dir <- case FilePath -> Bool
isAbsolute FilePath
dir' of
        Bool
True -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
dir'
        Bool
False -> do
          FilePath
here <- IO FilePath
getCurrentDirectory
          FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
here FilePath -> FilePath -> FilePath
</> FilePath
dir'

      Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
      Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
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 -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
base'
        Bool
False -> do
          FilePath
here <- IO FilePath
getCurrentDirectory
          FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
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
      Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FilePath -> IO (Maybe FilePath))
-> Maybe FilePath -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
dir

  TestTimer
testTimer <- case (TestTimerType
optionsTestTimerType, Maybe FilePath
runRoot) of
    (SpeedScopeTestTimerType {Bool
speedScopeTestTimerWriteRawTimings :: Bool
speedScopeTestTimerWriteRawTimings :: TestTimerType -> Bool
..}, Just FilePath
rr) -> IO TestTimer -> IO TestTimer
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO TestTimer -> IO TestTimer) -> IO TestTimer -> IO TestTimer
forall a b. (a -> b) -> a -> b
$ FilePath -> Bool -> IO TestTimer
newSpeedScopeTestTimer FilePath
rr Bool
speedScopeTestTimerWriteRawTimings
    (TestTimerType, Maybe FilePath)
_ -> TestTimer -> IO TestTimer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TestTimer
NullTestTimer

  let errorSymlinksDir :: Maybe FilePath
errorSymlinksDir = (FilePath -> FilePath -> FilePath
</> FilePath
"errors") (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe FilePath
runRoot
  Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => Maybe a -> (a -> m b) -> m ()
whenJust Maybe FilePath
errorSymlinksDir ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True
  BaseContext -> IO BaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BaseContext -> IO BaseContext) -> BaseContext -> IO BaseContext
forall a b. (a -> b) -> a -> b
$ BaseContext {
    baseContextPath :: Maybe FilePath
baseContextPath = Maybe FilePath
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 = Maybe (Set Int)
forall a. Maybe a
Nothing
    , baseContextTestTimerProfile :: Text
baseContextTestTimerProfile = Text
defaultProfileName
    , baseContextTestTimer :: TestTimer
baseContextTestTimer = TestTimer
testTimer
    }


-- | Gather all node options from a spec
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'' {})) = (SpecCommand context m (Free (SpecCommand context m) r)
-> NodeOptions
forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) r)
x) NodeOptions -> [NodeOptions] -> [NodeOptions]
forall a. a -> [a] -> [a]
: Free (SpecCommand context m) r -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) r
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 ()
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
location :: Maybe SrcLoc
nodeOptions :: NodeOptions
label :: FilePath
contextLabel :: Label l intro
introduceAction :: (intro -> ExampleT context m [Result]) -> ExampleT context m ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
next :: Free (SpecCommand context m) r
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> FilePath
contextLabel :: ()
subspecAugmented :: ()
introduceAction :: ()
..})) = NodeOptions
nodeOptions NodeOptions -> [NodeOptions] -> [NodeOptions]
forall a. a -> [a] -> [a]
: (Free (SpecCommand context m) r -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
next [NodeOptions] -> [NodeOptions] -> [NodeOptions]
forall a. Semigroup a => a -> a -> a
<> SpecFree (LabelValue l intro :> context) m () -> [NodeOptions]
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 ()
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> FilePath
contextLabel :: ()
subspecAugmented :: ()
location :: Maybe SrcLoc
nodeOptions :: NodeOptions
label :: FilePath
contextLabel :: Label l intro
allocate :: ExampleT context m intro
cleanup :: intro -> ExampleT context m ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
next :: Free (SpecCommand context m) r
allocate :: ()
cleanup :: ()
..})) = NodeOptions
nodeOptions NodeOptions -> [NodeOptions] -> [NodeOptions]
forall a. a -> [a] -> [a]
: (Free (SpecCommand context m) r -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
next [NodeOptions] -> [NodeOptions] -> [NodeOptions]
forall a. Semigroup a => a -> a -> a
<> SpecFree (LabelValue l intro :> context) m () -> [NodeOptions]
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) = (SpecCommand context m (Free (SpecCommand context m) r)
-> NodeOptions
forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
nodeOptions SpecCommand context m (Free (SpecCommand context m) r)
x) NodeOptions -> [NodeOptions] -> [NodeOptions]
forall a. a -> [a] -> [a]
: (Free (SpecCommand context m) r -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) r
forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) r)
x) [NodeOptions] -> [NodeOptions] -> [NodeOptions]
forall a. Semigroup a => a -> a -> a
<> Free (SpecCommand context m) () -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) ()
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 = Free (SpecCommand context m) r -> [NodeOptions]
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> [NodeOptions]
gatherNodeOptions Free (SpecCommand context m) r
tests
                          [NodeOptions]
-> ([NodeOptions] -> [Maybe NodeModuleInfo])
-> [Maybe NodeModuleInfo]
forall a b. a -> (a -> b) -> b
& (NodeOptions -> Maybe NodeModuleInfo)
-> [NodeOptions] -> [Maybe NodeModuleInfo]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NodeOptions -> Maybe NodeModuleInfo
nodeOptionsModuleInfo
                          [Maybe NodeModuleInfo]
-> ([Maybe NodeModuleInfo] -> [NodeModuleInfo]) -> [NodeModuleInfo]
forall a b. a -> (a -> b) -> b
& [Maybe NodeModuleInfo] -> [NodeModuleInfo]
forall a. [Maybe a] -> [a]
catMaybes

-- | TODO: get these automatically from mainCommandLineOptions
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) (NodeModuleInfo, Text)
-> [(NodeModuleInfo, Text)] -> [(NodeModuleInfo, Text)]
forall a. a -> [a] -> [a]
: ([Text] -> [NodeModuleInfo] -> [(NodeModuleInfo, Text)]
gatherShorthands' (Text
newShorthand Text -> [Text] -> [Text]
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 = [Text] -> Text
forall a. HasCallStack => [a] -> a
head ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Text
x -> Text
x Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
taken Bool -> Bool -> Bool
&& Text
x Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
takenMainOptions) ([Text] -> [Text]) -> [Text] -> [Text]
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 = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." (FilePath -> Text
T.pack FilePath
modName)
            lastPart :: Text
lastPart = [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
parts
            candidates :: [Text]
candidates = (Text -> Text
toDashed Text
lastPart) Text -> [Text] -> [Text]
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 Text -> (Text -> FilePath) -> FilePath
forall a b. a -> (a -> b) -> b
& Text -> FilePath
T.unpack
                   FilePath -> (FilePath -> [FilePath]) -> [FilePath]
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> FilePath -> [FilePath]
splitR Char -> Bool
isUpper
                   [FilePath] -> ([FilePath] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (FilePath -> Text) -> [FilePath] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Text
T.toLower (Text -> Text) -> (FilePath -> Text) -> FilePath -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack)
                   [Text] -> ([Text] -> Text) -> Text
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 (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.break Char -> Bool
p FilePath
s' of
          (FilePath
b', [])     -> [ Char
mChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
b' ]
          (FilePath
b', Char
x:FilePath
xs) -> ( Char
mChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
b' ) FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
x FilePath
xs
      in case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
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 FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: Char -> FilePath -> [FilePath]
go Char
h FilePath
t