7 | import System.Concurrency
10 | import Evince.Parallel
11 | import Evince.Random
12 | import Evince.Report
13 | import Evince.Reporter
14 | import Evince.Reporter.Console
15 | import Evince.Reporter.JUnit
18 | hasFocused : List (SpecTree a) -> Bool
19 | hasFocused [] = False
20 | hasFocused (Focused _ :: _) = True
21 | hasFocused (Describe _ children :: rest) = hasFocused children || hasFocused rest
22 | hasFocused (WithCleanup _ children :: rest) = hasFocused children || hasFocused rest
23 | hasFocused (_ :: rest) = hasFocused rest
26 | filterFocused : List (SpecTree a) -> List (SpecTree a)
27 | filterFocused [] = []
28 | filterFocused (Focused t :: rest) = t :: filterFocused rest
29 | filterFocused (Describe label children :: rest) =
30 | focusedInto (Describe label) children (filterFocused rest)
31 | filterFocused (WithCleanup cleanup children :: rest) =
32 | focusedInto (WithCleanup cleanup) children (filterFocused rest)
33 | filterFocused (_ :: rest) = filterFocused rest
35 | focusedInto : (List (SpecTree a) -> SpecTree a) -> List (SpecTree a) -> List (SpecTree a) -> List (SpecTree a)
36 | focusedInto wrap children rest =
37 | case filterFocused children of
39 | filtered => wrap filtered :: rest
41 | applyFocus : List (SpecTree a) -> List (SpecTree a)
42 | applyFocus trees = if hasFocused trees then filterFocused trees else trees
44 | filterByLabel : (keep : String -> Bool) -> List (SpecTree a) -> List (SpecTree a)
45 | filterByLabel keep [] = []
46 | filterByLabel keep (It label loc test :: rest) =
48 | then It label loc test :: filterByLabel keep rest
49 | else filterByLabel keep rest
50 | filterByLabel keep (Describe label children :: rest) =
52 | then Describe label children :: filterByLabel keep rest
53 | else let filtered = filterByLabel keep children
55 | [] => filterByLabel keep rest
56 | _ => Describe label filtered :: filterByLabel keep rest
57 | filterByLabel keep (Focused t :: rest) =
58 | case filterByLabel keep [t] of
59 | [t'] => Focused t' :: filterByLabel keep rest
60 | _ => filterByLabel keep rest
61 | filterByLabel keep (t :: rest) = t :: filterByLabel keep rest
63 | filterByMatch : String -> List (SpecTree a) -> List (SpecTree a)
64 | filterByMatch pat = filterByLabel (isInfixOf pat)
66 | filterBySkip : String -> List (SpecTree a) -> List (SpecTree a)
67 | filterBySkip pat = filterByLabel (not . isInfixOf pat)
69 | joinPath : List String -> String
70 | joinPath = concat . intersperse "."
72 | filterByPaths : List String -> List String -> List (SpecTree a) -> List (SpecTree a)
73 | filterByPaths _ _ [] = []
74 | filterByPaths paths ctx (It label loc test :: rest) =
75 | if joinPath (ctx ++ [label]) `elem` paths
76 | then It label loc test :: filterByPaths paths ctx rest
77 | else filterByPaths paths ctx rest
78 | filterByPaths paths ctx (Describe label children :: rest) =
79 | let filtered = filterByPaths paths (ctx ++ [label]) children
81 | [] => filterByPaths paths ctx rest
82 | _ => Describe label filtered :: filterByPaths paths ctx rest
83 | filterByPaths paths ctx (Focused t :: rest) =
84 | case filterByPaths paths ctx [t] of
85 | [t'] => Focused t' :: filterByPaths paths ctx rest
86 | _ => filterByPaths paths ctx rest
87 | filterByPaths paths ctx (t :: rest) = t :: filterByPaths paths ctx rest
89 | shuffleTrees : Nat -> List (SpecTree a) -> List (SpecTree a)
90 | shuffleTrees seed [] = []
91 | shuffleTrees seed trees = shuffle seed (map go trees)
93 | go : SpecTree a -> SpecTree a
94 | go (Describe label children) = Describe label (shuffleTrees seed children)
95 | go (WithCleanup cleanup children) = WithCleanup cleanup (shuffleTrees seed children)
96 | go (Focused t) = Focused (go t)
99 | applyFilters : RunConfig -> List (SpecTree a) -> List (SpecTree a)
100 | applyFilters cfg trees =
101 | let t1 = applyFocus trees
102 | t2 = maybe t1 (\p => filterByMatch p t1) cfg.match
103 | t3 = maybe t2 (\p => filterBySkip p t2) cfg.skip
104 | t4 = if cfg.randomize
105 | then let s = maybe 42 id cfg.seed in shuffleTrees s t3
110 | EvalResult = (Summary, SnocList TestReport)
112 | emptyResult : EvalResult
113 | emptyResult = (neutral, [<])
115 | mergeResults : EvalResult -> EvalResult -> EvalResult
116 | mergeResults (s1, r1) (s2, r2) = (s1 <+> s2, r1 ++ r2)
119 | evalTree : Reporter -> RunConfig -> IORef Bool -> List String -> SpecTree () -> Nat -> IO EvalResult
120 | evalTree reporter cfg abortRef path (Describe label children) level = do
121 | reporter.onEvent (GroupStarted label level)
122 | r <- evalForest reporter cfg abortRef (path ++ [label]) children (S level)
123 | reporter.onEvent (GroupDone label)
125 | evalTree reporter cfg abortRef path (It label loc test) level = do
126 | abort <- readIORef abortRef
128 | then pure emptyResult
130 | start <- clockTime Monotonic
132 | end <- clockTime Monotonic
133 | let elapsed = toNano (timeDifference end start)
134 | let testPath = path ++ [label]
135 | let s = case result of
136 | Pass _ => { passed := 1, duration := elapsed } neutral
137 | Fail _ => { failed := 1, duration := elapsed } neutral
138 | Skip _ => { pending := 1 } neutral
139 | let report = case result of
140 | Pass _ => MkTestReport testPath loc (Passed elapsed)
141 | Fail info => MkTestReport testPath loc (Failed info elapsed)
142 | Skip reason => MkTestReport testPath loc (Skipped reason)
143 | reporter.onEvent (TestDone report level)
144 | when (cfg.failFast && s.failed > 0) (writeIORef abortRef True)
145 | pure (s, [< report])
146 | evalTree reporter cfg abortRef path (Pending label reason) level = do
147 | reporter.onEvent (PendingTest label reason level)
148 | let report = MkTestReport (path ++ [label]) Nothing (Skipped reason)
149 | pure ({ pending := 1 } neutral, [< report])
150 | evalTree reporter cfg abortRef path (Focused tree) level =
151 | evalTree reporter cfg abortRef path tree level
152 | evalTree reporter cfg abortRef path (WithCleanup cleanup children) level = do
153 | r <- evalForest reporter cfg abortRef path children level
157 | evalForest : Reporter -> RunConfig -> IORef Bool -> List String -> List (SpecTree ()) -> Nat -> IO EvalResult
158 | evalForest _ _ _ _ [] _ = pure emptyResult
159 | evalForest reporter cfg abortRef path (t :: ts) level = do
160 | abort <- readIORef abortRef
162 | then pure emptyResult
164 | r1 <- evalTree reporter cfg abortRef path t level
165 | r2 <- evalForest reporter cfg abortRef path ts level
166 | pure (mergeResults r1 r2)
168 | makeReporter : RunConfig -> IO Reporter
169 | makeReporter cfg = do
170 | let console = consoleReporter cfg
171 | case cfg.junitOutput of
173 | junit <- junitReporter path
174 | pure (combineReporters [console, junit])
175 | Nothing => pure console
177 | threadSafeReporter : Reporter -> IO Reporter
178 | threadSafeReporter r = do
180 | pure $
MkReporter $
\e => do
185 | collectResults : Channel EvalResult -> Nat -> EvalResult -> IO EvalResult
186 | collectResults _ Z acc = pure acc
187 | collectResults chan (S k) acc = do
188 | r <- channelGet chan
189 | collectResults chan k (mergeResults acc r)
191 | evalParallel : Reporter -> RunConfig -> List (SpecTree ()) -> IO EvalResult
192 | evalParallel reporter cfg trees = do
193 | chan <- makeChannel
194 | abortRef <- newIORef False
195 | let n = length trees
196 | for_ trees $
\tree =>
198 | r <- tryIO (evalTree reporter cfg abortRef [] tree 0) (pure emptyResult)
200 | collectResults chan n emptyResult
202 | failedPaths : SnocList TestReport -> List (List String)
203 | failedPaths = foldl (\acc, r => case r.outcome of Failed _ _ => r.path :: acc;
_ => acc) []
205 | runWithConfig : RunConfig -> List (SpecTree ()) -> IO EvalResult
206 | runWithConfig cfg trees = do
207 | let filtered = applyFilters cfg trees
208 | rerunFiltered <- if cfg.rerun
210 | Just failures <- readFailures
211 | | Nothing => pure filtered
212 | pure (filterByPaths failures [] filtered)
214 | baseReporter <- makeReporter cfg
215 | reporter <- if cfg.jobs > 0
216 | then threadSafeReporter baseReporter
217 | else pure baseReporter
218 | abortRef <- newIORef False
219 | reporter.onEvent SuiteStarted
220 | r <- if cfg.jobs > 0
221 | then evalParallel reporter cfg rerunFiltered
222 | else evalForest reporter cfg abortRef [] rerunFiltered 0
223 | reporter.onEvent (SuiteDone (fst r))
228 | runSpecWithSummaryAndConfig : RunConfig -> Spec () () -> IO Summary
229 | runSpecWithSummaryAndConfig cfg spec = do
230 | (summary, _) <- runWithConfig cfg (getSpecTrees spec)
236 | runSpecWithSummary : Spec () () -> IO Summary
237 | runSpecWithSummary = runSpecWithSummaryAndConfig defaultConfig
241 | runSpecWith : RunConfig -> Spec () () -> IO ()
242 | runSpecWith cfg spec = do
243 | (summary, reports) <- runWithConfig cfg (getSpecTrees spec)
244 | writeFailures (failedPaths reports)
245 | when (summary.failed > 0) exitFailure
249 | runSpec : Spec () () -> IO ()
250 | runSpec = runSpecWith defaultConfig
254 | runSpecFailFast : Spec () () -> IO ()
255 | runSpecFailFast = runSpecWith ({ failFast := True } defaultConfig)
259 | runSpecTimed : Spec () () -> IO ()
260 | runSpecTimed = runSpecWith ({ showTiming := True } defaultConfig)
264 | runSpecWithArgs : Spec () () -> IO ()
265 | runSpecWithArgs spec = do
267 | let cfg = parseArgs (drop 1 args)
268 | runSpecWith cfg spec