
   0 | module Evince.Runner
   1 | 
   2 | import Data.IORef
   3 | import Data.List
   4 | import Data.String
   5 | import System
   6 | import System.Clock
   7 | import Evince.Config
   8 | import Evince.Core
   9 | import Evince.Random
  10 | import Evince.Report
  11 | import Evince.Reporter
  12 | import Evince.Reporter.Console
  13 | import Evince.Reporter.JUnit
  14 | import Evince.Rerun
  15 | 
  16 | hasFocused : List (SpecTree m a) -> Bool
  17 | hasFocused [] = False
  18 | hasFocused (Focused _ :: _) = True
  19 | hasFocused (Describe _ children :: rest) = hasFocused children || hasFocused rest
  20 | hasFocused (WithCleanup _ children :: rest) = hasFocused children || hasFocused rest
  21 | hasFocused (_ :: rest) = hasFocused rest
  22 | 
  23 | mutual
  24 |   filterFocused : List (SpecTree m a) -> List (SpecTree m a)
  25 |   filterFocused [] = []
  26 |   filterFocused (Focused t :: rest) = t :: filterFocused rest
  27 |   filterFocused (Describe label children :: rest) =
  28 |     focusedInto (Describe label) children (filterFocused rest)
  29 |   filterFocused (WithCleanup cleanup children :: rest) =
  30 |     focusedInto (WithCleanup cleanup) children (filterFocused rest)
  31 |   filterFocused (_ :: rest) = filterFocused rest
  32 | 
  33 |   focusedInto : (List (SpecTree m a) -> SpecTree m a) -> List (SpecTree m a) -> List (SpecTree m a) -> List (SpecTree m a)
  34 |   focusedInto wrap children rest =
  35 |     case filterFocused children of
  36 |       [] => rest
  37 |       filtered => wrap filtered :: rest
  38 | 
  39 | applyFocus : List (SpecTree m a) -> List (SpecTree m a)
  40 | applyFocus trees = if hasFocused trees then filterFocused trees else trees
  41 | 
  42 | -- Match-shaped selection: a matching group label selects its whole subtree;
  43 | -- otherwise recurse and keep the group only if some child survives.
  44 | filterByLabel : (keep : String -> Bool) -> List (SpecTree m a) -> List (SpecTree m a)
  45 | filterByLabel keep [] = []
  46 | filterByLabel keep (It label loc test :: rest) =
  47 |   if keep label
  48 |     then It label loc test :: filterByLabel keep rest
  49 |     else filterByLabel keep rest
  50 | filterByLabel keep (Describe label children :: rest) =
  51 |   if keep label
  52 |     then Describe label children :: filterByLabel keep rest
  53 |     else let filtered = filterByLabel keep children
  54 |          in case filtered of
  55 |               [] => filterByLabel keep rest
  56 |               _  => Describe label filtered :: filterByLabel keep rest
  57 | filterByLabel keep (Pending label reason :: rest) =
  58 |   if keep label
  59 |     then Pending label reason :: filterByLabel keep rest
  60 |     else filterByLabel keep rest
  61 | filterByLabel keep (Focused t :: rest) =
  62 |   case filterByLabel keep [t] of
  63 |     [t'] => Focused t' :: filterByLabel keep rest
  64 |     _    => filterByLabel keep rest
  65 | filterByLabel keep (WithCleanup cleanup children :: rest) =
  66 |   case filterByLabel keep children of
  67 |     [] => filterByLabel keep rest
  68 |     filtered => WithCleanup cleanup filtered :: filterByLabel keep rest
  69 | 
  70 | -- Skip-shaped exclusion: a matching label drops the node wholesale
  71 | -- (a matching group label skips its entire subtree); otherwise recurse.
  72 | dropByLabel : (matches : String -> Bool) -> List (SpecTree m a) -> List (SpecTree m a)
  73 | dropByLabel matches [] = []
  74 | dropByLabel matches (It label loc test :: rest) =
  75 |   if matches label
  76 |     then dropByLabel matches rest
  77 |     else It label loc test :: dropByLabel matches rest
  78 | dropByLabel matches (Describe label children :: rest) =
  79 |   if matches label
  80 |     then dropByLabel matches rest
  81 |     else case dropByLabel matches children of
  82 |            [] => dropByLabel matches rest
  83 |            filtered => Describe label filtered :: dropByLabel matches rest
  84 | dropByLabel matches (Pending label reason :: rest) =
  85 |   if matches label
  86 |     then dropByLabel matches rest
  87 |     else Pending label reason :: dropByLabel matches rest
  88 | dropByLabel matches (Focused t :: rest) =
  89 |   case dropByLabel matches [t] of
  90 |     [t'] => Focused t' :: dropByLabel matches rest
  91 |     _    => dropByLabel matches rest
  92 | dropByLabel matches (WithCleanup cleanup children :: rest) =
  93 |   case dropByLabel matches children of
  94 |     [] => dropByLabel matches rest
  95 |     filtered => WithCleanup cleanup filtered :: dropByLabel matches rest
  96 | 
  97 | filterByMatch : String -> List (SpecTree m a) -> List (SpecTree m a)
  98 | filterByMatch pat = filterByLabel (isInfixOf pat)
  99 | 
 100 | filterBySkip : String -> List (SpecTree m a) -> List (SpecTree m a)
 101 | filterBySkip pat = dropByLabel (isInfixOf pat)
 102 | 
 103 | filterByPaths : List String -> List String -> List (SpecTree m a) -> List (SpecTree m a)
 104 | filterByPaths _ _ [] = []
 105 | filterByPaths paths ctx (It label loc test :: rest) =
 106 |   if joinPath (ctx ++ [label]) `elem` paths
 107 |     then It label loc test :: filterByPaths paths ctx rest
 108 |     else filterByPaths paths ctx rest
 109 | filterByPaths paths ctx (Describe label children :: rest) =
 110 |   let filtered = filterByPaths paths (ctx ++ [label]) children
 111 |   in case filtered of
 112 |        [] => filterByPaths paths ctx rest
 113 |        _  => Describe label filtered :: filterByPaths paths ctx rest
 114 | filterByPaths paths ctx (Pending label reason :: rest) =
 115 |   if joinPath (ctx ++ [label]) `elem` paths
 116 |     then Pending label reason :: filterByPaths paths ctx rest
 117 |     else filterByPaths paths ctx rest
 118 | filterByPaths paths ctx (Focused t :: rest) =
 119 |   case filterByPaths paths ctx [t] of
 120 |     [t'] => Focused t' :: filterByPaths paths ctx rest
 121 |     _    => filterByPaths paths ctx rest
 122 | filterByPaths paths ctx (WithCleanup cleanup children :: rest) =
 123 |   case filterByPaths paths ctx children of
 124 |     [] => filterByPaths paths ctx rest
 125 |     filtered => WithCleanup cleanup filtered :: filterByPaths paths ctx rest
 126 | 
 127 | shuffleTrees : Nat -> List (SpecTree m a) -> List (SpecTree m a)
 128 | shuffleTrees seed [] = []
 129 | shuffleTrees seed trees = shuffle seed (go (nextSeed seed) trees)
 130 |   where
 131 |     goTree : Nat -> SpecTree m a -> SpecTree m a
 132 |     goTree s (Describe label children) = Describe label (shuffleTrees s children)
 133 |     goTree s (WithCleanup cleanup children) = WithCleanup cleanup (shuffleTrees s children)
 134 |     goTree s (Focused t) = Focused (goTree s t)
 135 |     goTree s t = t
 136 | 
 137 |     -- Thread the seed across siblings so same-length sibling groups
 138 |     -- don't get the same permutation.
 139 |     go : Nat -> List (SpecTree m a) -> List (SpecTree m a)
 140 |     go s [] = []
 141 |     go s (t :: ts) = goTree s t :: go (nextSeed s) ts
 142 | 
 143 | applyFilters : RunConfig -> List (SpecTree m a) -> List (SpecTree m a)
 144 | applyFilters cfg trees =
 145 |   let t1 = applyFocus trees
 146 |       t2 = maybe t1 (\p => filterByMatch p t1) cfg.match
 147 |       t3 = maybe t2 (\p => filterBySkip p t2) cfg.skip
 148 |       t4 = if cfg.randomize
 149 |              then let s = maybe 42 id cfg.seed in shuffleTrees s t3
 150 |              else t3
 151 |   in t4
 152 | 
 153 | ||| A running tally: the summary counts plus the per-test reports collected
 154 | ||| so far. Accumulated as the forest is evaluated.
 155 | public export
 156 | EvalResult : Type
 157 | EvalResult = (Summary, SnocList TestReport)
 158 | 
 159 | ||| The empty tally - no counts and no reports - used as the starting
 160 | ||| accumulator when folding results together.
 161 | export
 162 | emptyResult : EvalResult
 163 | emptyResult = (neutral, [<])
 164 | 
 165 | ||| Combine two tallies, adding their summary counts and concatenating their
 166 | ||| reports.
 167 | export
 168 | mergeResults : EvalResult -> EvalResult -> EvalResult
 169 | mergeResults (s1, r1) (s2, r2) = (s1 <+> s2, r1 ++ r2)
 170 | 
 171 | mutual
 172 |   ||| Evaluate one spec-tree node, emitting the matching reporter events and
 173 |   ||| returning its tally. Recurses through groups; runs and times each test,
 174 |   ||| honouring the abort flag (`--fail-fast`).
 175 |   export
 176 |   evalTree : HasIO m => Reporter m -> RunConfig -> IORef Bool -> List String -> SpecTree m () -> Nat -> m EvalResult
 177 |   evalTree reporter cfg abortRef path (Describe label children) level = do
 178 |     reporter.onEvent (GroupStarted label level)
 179 |     r <- evalForest reporter cfg abortRef (path ++ [label]) children (S level)
 180 |     reporter.onEvent (GroupDone label)
 181 |     pure r
 182 |   evalTree reporter cfg abortRef path (It label loc test) level = do
 183 |     abort <- liftIO (readIORef abortRef)
 184 |     if abort
 185 |       then pure emptyResult
 186 |       else do
 187 |         start <- liftIO (clockTime Monotonic)
 188 |         result <- test ()
 189 |         end <- liftIO (clockTime Monotonic)
 190 |         let elapsed = toNano (timeDifference end start)
 191 |         let testPath = path ++ [label]
 192 |         let s = case result of
 193 |               Pass _   => { passed := 1, duration := elapsed } neutral
 194 |               Fail _   => { failed := 1, duration := elapsed } neutral
 195 |               Skip _   => { pending := 1 } neutral
 196 |         let report = case result of
 197 |               Pass _      => MkTestReport testPath loc (Passed elapsed)
 198 |               Fail info   => MkTestReport testPath loc (Failed info elapsed)
 199 |               Skip reason => MkTestReport testPath loc (Skipped reason)
 200 |         reporter.onEvent (TestDone report level)
 201 |         when (cfg.failFast && s.failed > 0) (liftIO (writeIORef abortRef True))
 202 |         pure (s, [< report])
 203 |   evalTree reporter cfg abortRef path (Pending label reason) level = do
 204 |     reporter.onEvent (PendingTest label reason level)
 205 |     let report = MkTestReport (path ++ [label]) Nothing (Skipped reason)
 206 |     pure ({ pending := 1 } neutral, [< report])
 207 |   evalTree reporter cfg abortRef path (Focused tree) level =
 208 |     evalTree reporter cfg abortRef path tree level
 209 |   evalTree reporter cfg abortRef path (WithCleanup cleanup children) level = do
 210 |     r <- evalForest reporter cfg abortRef path children level
 211 |     cleanup
 212 |     pure r
 213 | 
 214 |   ||| Evaluate a list of spec trees left to right, accumulating their tallies
 215 |   ||| and stopping early once the abort flag (`--fail-fast`) is set.
 216 |   export
 217 |   evalForest : HasIO m => Reporter m -> RunConfig -> IORef Bool -> List String -> List (SpecTree m ()) -> Nat -> m EvalResult
 218 |   evalForest _ _ _ _ [] _ = pure emptyResult
 219 |   evalForest reporter cfg abortRef path (t :: ts) level = do
 220 |     abort <- liftIO (readIORef abortRef)
 221 |     if abort
 222 |       then pure emptyResult
 223 |       else do
 224 |         r1 <- evalTree reporter cfg abortRef path t level
 225 |         r2 <- evalForest reporter cfg abortRef path ts level
 226 |         pure (mergeResults r1 r2)
 227 | 
 228 | ||| Build the reporter for a run: the console reporter, combined with the
 229 | ||| JUnit reporter when `--junit` is set. Colors are dropped when the
 230 | ||| `NO_COLOR` environment variable is set.
 231 | export
 232 | makeReporter : HasIO m => RunConfig -> m (Reporter m)
 233 | makeReporter cfg0 = do
 234 |   noColor <- getEnv "NO_COLOR"
 235 |   let cfg = if maybe False (/= "") noColor then { color := False } cfg0 else cfg0
 236 |   let console = consoleReporter cfg
 237 |   case cfg.junitOutput of
 238 |     Just path => do
 239 |       junit <- junitReporter path
 240 |       pure (combineReporters [console, junit])
 241 |     Nothing => pure console
 242 | 
 243 | ||| The paths of every failed test, for `--rerun` to replay next time.
 244 | export
 245 | failedPaths : SnocList TestReport -> List (List String)
 246 | failedPaths = foldl (\acc, r => case r.outcome of Failed _ _ => r.path :: acc; _ => acc) []
 247 | 
 248 | ||| Run a suite's forest with a caller-supplied evaluator. Applies the CLI
 249 | ||| filters and rerun selection, then brackets the evaluation with the
 250 | ||| suite-started/done events.
 251 | export
 252 | runForestWith :
 253 |      HasIO m
 254 |   => Reporter m
 255 |   -> (eval : IORef Bool -> List (SpecTree m ()) -> m EvalResult)
 256 |   -> RunConfig
 257 |   -> List (SpecTree m ())
 258 |   -> m EvalResult
 259 | runForestWith reporter eval cfg trees = do
 260 |   let filtered = applyFilters cfg trees
 261 |   rerunFiltered <- if cfg.rerun
 262 |     then do
 263 |       Just failures <- liftIO readFailures
 264 |         | Nothing => pure filtered
 265 |       pure (filterByPaths failures [] filtered)
 266 |     else pure filtered
 267 |   abortRef <- liftIO (newIORef False)
 268 |   reporter.onEvent SuiteStarted
 269 |   r <- eval abortRef rerunFiltered
 270 |   reporter.onEvent (SuiteDone (fst r))
 271 |   pure r
 272 | 
 273 | -- Core runs sequentially. `cfg.jobs` is parsed and stored but ignored here;
 274 | -- a concurrent driver reads it to run groups concurrently.
 275 | runWithConfig : HasIO m => RunConfig -> List (SpecTree m ()) -> m EvalResult
 276 | runWithConfig cfg trees = do
 277 |   reporter <- makeReporter cfg
 278 |   runForestWith reporter (\abortRef, ts => evalForest reporter cfg abortRef [] ts 0) cfg trees
 279 | 
 280 | ||| Run a spec suite with custom configuration and return the summary.
 281 | export
 282 | runSpecWithSummaryAndConfig : RunConfig -> Spec IO () () -> IO Summary
 283 | runSpecWithSummaryAndConfig cfg spec = do
 284 |   (summary, _) <- runWithConfig cfg (getSpecTrees spec)
 285 |   pure summary
 286 | 
 287 | ||| Run a spec suite and return the summary without exiting. Useful for
 288 | ||| meta-testing (testing evince with evince).
 289 | export
 290 | runSpecWithSummary : Spec IO () () -> IO Summary
 291 | runSpecWithSummary = runSpecWithSummaryAndConfig defaultConfig
 292 | 
 293 | ||| Run a spec suite with custom configuration.
 294 | export
 295 | runSpecWith : RunConfig -> Spec IO () () -> IO ()
 296 | runSpecWith cfg spec = do
 297 |   (summary, reports) <- runWithConfig cfg (getSpecTrees spec)
 298 |   writeFailures (failedPaths reports)
 299 |   when (summary.failed > 0) exitFailure
 300 | 
 301 | ||| Run a spec suite, print colored results, exit with code 1 if any test failed.
 302 | export
 303 | runSpec : Spec IO () () -> IO ()
 304 | runSpec = runSpecWith defaultConfig
 305 | 
 306 | ||| Run with fail-fast enabled - stop after the first failure.
 307 | export
 308 | runSpecFailFast : Spec IO () () -> IO ()
 309 | runSpecFailFast = runSpecWith ({ failFast := True } defaultConfig)
 310 | 
 311 | ||| Run with per-test timing displayed.
 312 | export
 313 | runSpecTimed : Spec IO () () -> IO ()
 314 | runSpecTimed = runSpecWith ({ showTiming := True } defaultConfig)
 315 | 
 316 | ||| Run a spec suite, reading CLI args for configuration. `--help` prints the
 317 | ||| flag reference and exits; unknown or invalid arguments warn on stderr.
 318 | export
 319 | runSpecWithArgs : Spec IO () () -> IO ()
 320 | runSpecWithArgs spec = do
 321 |   args <- getArgs
 322 |   cfg <- handleArgs (drop 1 args)
 323 |   runSpecWith cfg spec
 324 |