0 | module Evince.Async.Shared
  1 |
  2 | import Data.IORef
  3 | import Data.Linear.Ref1
  4 | import Data.List
  5 | import System
  6 | import IO.Async
  7 | import Evince.Config
  8 | import Evince.Core
  9 | import Evince.Report
 10 | import Evince.Reporter
 11 | import Evince.Rerun
 12 | import Evince.Runner
 13 | import Evince.Synchronized
 14 | import Evince.Async.Synchronized
 15 |
 16 | ||| The fail-fast abort flag threaded through the runner - a base `Data.IORef`
 17 | ||| cell (not the `IORef` that IO.Async re-exports from Data.Linear.Ref1).
 18 | public export
 19 | 0 AbortRef : Type
 20 | AbortRef = Data.IORef.IORef Bool
 21 |
 22 | -- Guard every event with the lock so events emitted from different fibers
 23 | -- can't interleave.
 24 | lockedReporter : Reporter (Async e []) -> Lock (Async e []) -> Reporter (Async e [])
 25 | lockedReporter base lock = MkReporter (\ev => lock.withLock (base.onEvent ev))
 26 |
 27 | ||| Evaluate the top-level groups, running up to `cfg.jobs` of them
 28 | ||| concurrently. `jobs = 0` falls back to core's sequential walk; otherwise a
 29 | ||| pool of `jobs` workers claims groups from a shared queue as slots free up
 30 | ||| (sliding window - a slow group never stalls the ones after it). Under
 31 | ||| `--fail-fast` the first failure also cancels the in-flight groups: their
 32 | ||| partial output is flushed, their completed tests keep their results, and a
 33 | ||| `SuiteAborted` event notes that the run was cut short. A concurrent group's
 34 | ||| events are buffered and replayed under the lock when the group finishes, so
 35 | ||| groups' output never interleaves.
 36 | export
 37 | evalAsyncForest :
 38 |      Reporter (Async e [])
 39 |   -> Lock (Async e [])
 40 |   -> RunConfig
 41 |   -> AbortRef
 42 |   -> List (SpecTree (Async e []) ())
 43 |   -> Async e [] EvalResult
 44 | evalAsyncForest base lock cfg abortRef trees =
 45 |   case cfg.jobs of
 46 |     Z   => evalForest (lockedReporter base lock) cfg abortRef [] trees 0
 47 |     S k => do
 48 |       queue       <- newref trees
 49 |       results     <- newref emptyResult
 50 |       cancelled   <- newref False
 51 |       interrupted <- newref False
 52 |       registry    <- newref (the (List (Nat, Fiber [] ())) [])
 53 |       let idxs = workerIds (min (S k) (length trees))
 54 |       fibs <- traverse (\i => start (worker queue results cancelled registry interrupted i)) idxs
 55 |       writeref registry (zip idxs fibs)
 56 |       traverse_ wait fibs
 57 |       unclaimed <- readref queue
 58 |       cut       <- readref interrupted
 59 |       when (cut || not (null unclaimed)) (lock.withLock (base.onEvent SuiteAborted))
 60 |       readref results
 61 |   where
 62 |     workerIds : Nat -> List Nat
 63 |     workerIds Z     = []
 64 |     workerIds (S m) = [0 .. m]
 65 |
 66 |     toSummary : TestReport -> Summary
 67 |     toSummary rep = case rep.outcome of
 68 |       Passed d   => MkSummary 1 0 0 d
 69 |       Failed _ d => MkSummary 0 1 0 d
 70 |       Skipped _  => MkSummary 0 0 1 0
 71 |
 72 |     -- A cancelled group's buffer is the source of truth: the results of its
 73 |     -- completed tests are recovered from the buffered events.
 74 |     partialResult : List Event -> EvalResult
 75 |     partialResult evs =
 76 |       let reps = mapMaybe (\case TestDone rep _ => Just rep; _ => Nothing) evs
 77 |       in (foldMap toSummary reps, Lin <>< reps)
 78 |
 79 |     deposit : Ref World EvalResult -> EvalResult -> Async e [] ()
 80 |     deposit results r = runIO $ casupdate1 results (\acc => (mergeResults acc r, ()))
 81 |
 82 |     runGroup : Ref World EvalResult -> Ref World Bool -> SpecTree (Async e []) () -> Async e [] ()
 83 |     runGroup results interrupted t = do
 84 |       buf  <- liftIO (newIORef (the (SnocList Event) [<]))
 85 |       done <- liftIO (newIORef False)
 86 |       let buffered = MkReporter (\ev => liftIO (modifyIORef buf (:< ev)))
 87 |           flush : Async e [] (List Event)
 88 |           flush = do
 89 |             evs <- liftIO (readIORef buf)
 90 |             let l = evs <>> []
 91 |             lock.withLock (traverse_ base.onEvent l)
 92 |             pure l
 93 |       onCancel
 94 |         (do r <- evalTree buffered cfg abortRef [] t 0
 95 |             -- Masked so a fiber is never cancelled while holding the reporter
 96 |             -- lock (the cancel finalizer flushes too, and the lock is not
 97 |             -- reentrant).
 98 |             uncancelable $ \_ => do
 99 |               ignore flush
100 |               deposit results r
101 |               liftIO (writeIORef done True))
102 |         -- A cancel requested during the masked tail is observed right after
103 |         -- it, with the group already flushed and deposited - the finalizer
104 |         -- must be a no-op then, or the group would be counted twice.
105 |         (do d <- liftIO (readIORef done)
106 |             when (not d) $ do
107 |               writeref interrupted True
108 |               evs <- flush
109 |               deposit results (partialResult evs))
110 |
111 |     claim : Ref World (List (SpecTree (Async e []) ())) -> Async e [] (Maybe (SpecTree (Async e []) ()))
112 |     claim queue = runIO $ casupdate1 queue $ \case
113 |       []        => ([], Nothing)
114 |       (t :: ts) => (ts, Just t)
115 |
116 |     worker :
117 |          Ref World (List (SpecTree (Async e []) ()))
118 |       -> Ref World EvalResult
119 |       -> Ref World Bool
120 |       -> Ref World (List (Nat, Fiber [] ()))
121 |       -> Ref World Bool
122 |       -> Nat
123 |       -> Async e [] ()
124 |     worker queue results cancelled registry interrupted me = loop
125 |       where
126 |         -- Only the first observer cancels, so siblings are cancelled once.
127 |         cancelSiblings : Async e [] ()
128 |         cancelSiblings = do
129 |           won <- runIO (caswrite1 cancelled False True)
130 |           when won $ do
131 |             fibs <- readref registry
132 |             traverse_ (\(i, f) => when (i /= me) (cancel f)) fibs
133 |
134 |         loop : Async e [] ()
135 |         loop = do
136 |           stop <- liftIO (readIORef abortRef)
137 |           if stop then cancelSiblings else do
138 |             Just t <- claim queue
139 |               | Nothing => pure ()
140 |             runGroup results interrupted t
141 |             st <- liftIO (readIORef abortRef)
142 |             if st then cancelSiblings else loop
143 |
144 | ||| Run a spec on a caller-supplied event loop and return the full result.
145 | ||| The `runLoop` argument is the backend's `Async` runner (`syncApp` for the
146 | ||| SyncST loop, `app` for the JS loop). Dies if the loop terminates before
147 | ||| the suite completes, rather than reporting an empty successful run.
148 | export
149 | runResultVia :
150 |      {e : Type}
151 |   -> (Async e [] () -> IO ())
152 |   -> RunConfig
153 |   -> Spec (Async e []) () ()
154 |   -> IO EvalResult
155 | runResultVia runLoop cfg spec = do
156 |   out <- newIORef (the (Maybe EvalResult) Nothing)
157 |   runLoop $ do
158 |     base <- makeReporter cfg
159 |     lock <- liftIO newLock
160 |     result <- runForestWith (lockedReporter base lock)
161 |                             (\ref, ts => evalAsyncForest base lock cfg ref ts)
162 |                             cfg (getSpecTrees spec)
163 |     liftIO (writeIORef out (Just result))
164 |   Just r <- readIORef out
165 |     | Nothing => die "evince: the event loop ended before the suite completed"
166 |   pure r
167 |
168 | ||| Run a spec on the given event loop, writing the failure list for `--rerun`
169 | ||| and exiting non-zero if any test failed.
170 | export
171 | runSpecVia : {e : Type} -> (Async e [] () -> IO ()) -> RunConfig -> Spec (Async e []) () () -> IO ()
172 | runSpecVia runLoop cfg spec = do
173 |   (summary, reports) <- runResultVia runLoop cfg spec
174 |   writeFailures (failedPaths reports)
175 |   when (summary.failed > 0) exitFailure
176 |
177 | ||| Run a spec on the given event loop and return the summary without exiting.
178 | export
179 | summaryVia : {e : Type} -> (Async e [] () -> IO ()) -> RunConfig -> Spec (Async e []) () () -> IO Summary
180 | summaryVia runLoop cfg spec = fst <$> runResultVia runLoop cfg spec
181 |
182 | ||| Run a spec on the given event loop, reading CLI args (including `--jobs`)
183 | ||| for configuration.
184 | export
185 | runSpecArgsVia : {e : Type} -> (Async e [] () -> IO ()) -> Spec (Async e []) () () -> IO ()
186 | runSpecArgsVia runLoop spec = do
187 |   args <- getArgs
188 |   cfg <- handleArgs (drop 1 args)
189 |   runSpecVia runLoop cfg spec
190 |
191 | ||| Run a spec on the given event loop with fail-fast enabled.
192 | export
193 | runSpecFailFastVia : {e : Type} -> (Async e [] () -> IO ()) -> Spec (Async e []) () () -> IO ()
194 | runSpecFailFastVia runLoop = runSpecVia runLoop ({ failFast := True } defaultConfig)
195 |
196 | ||| Run a spec on the given event loop with per-test timing displayed.
197 | export
198 | runSpecTimedVia : {e : Type} -> (Async e [] () -> IO ()) -> Spec (Async e []) () () -> IO ()
199 | runSpecTimedVia runLoop = runSpecVia runLoop ({ showTiming := True } defaultConfig)
200 |