git.iko.soy/typeable/elm-ui
on 1ceefdb help sign in
typeable/elm-ui/tests-rendering/src/Testable/Runner.elm
518 lines 15 kB history raw
1port module Testable.Runner exposing (Msg, TestableProgram, program, show)
3{-| -}
5import Browser
6import Dict exposing (Dict)
7import Element
8import Element.Background as Background
9import Element.Border as Border
10import Element.Events as Events
11import Element.Font as Font
12import Html exposing (Html)
13import Html.Attributes
14import Process
15import Task
16import Testable
17import Time
20show : Testable.Element msg -> Html msg
21show =
22 Testable.toHtml
25type alias TestableProgram =
26 Program () (Model Msg) Msg
29palette =
30 { white = Element.rgb 1 1 1
31 , red = Element.rgb 1 0 0
32 , green = Element.rgb 0 1 0
33 , black = Element.rgb 0 0 0
34 , lightGrey = Element.rgb 0.7 0.7 0.7
35 }
38program : List ( String, Testable.Element Msg ) -> TestableProgram
39program tests =
40 let
41 ( current, upcoming ) =
42 case tests of
43 [] ->
44 ( Nothing, [] )
46 cur :: remaining ->
47 ( Just cur, remaining )
48 in
49 Browser.element
50 { init =
51 always
52 ( { current = current
53 , upcoming = upcoming
54 , finished = []
55 , highlightDomId = Nothing
56 }
57 , Task.perform (always Analyze)
58 (Process.sleep 32
59 |> Task.andThen
60 (always Time.now)
61 )
62 )
63 , view = view
64 , update = update
65 , subscriptions = subscriptions
66 }
69subscriptions : Model Msg -> Sub Msg
70subscriptions model =
71 Sub.batch
72 [ styles RefreshBoundingBox
73 ]
76type alias Model msg =
77 { current : Maybe ( String, Testable.Element msg )
78 , upcoming : List ( String, Testable.Element msg )
79 , finished : List (WithResults (Testable.Element msg))
80 , highlightDomId : Maybe String
81 }
84type alias WithResults thing =
85 { element : thing
86 , label : String
87 , results :
88 List Testable.LayoutTest
89 }
92encodeForReport :
93 List (WithResults (Testable.Element msg))
94 ->
95 List
96 { label : String
97 , results :
98 List
99 { description : String
100 , passing : Bool
101 , todo : Bool
102 }
103 }
104encodeForReport withResults =
105 let
106 prepareExpectation layoutTest exp =
107 case exp of
108 Testable.Todo description ->
109 { description = description
110 , passing = False
111 , todo = True
112 }
114 Testable.Expect details ->
115 { description = details.description
116 , passing = details.result
117 , todo = False
118 }
120 prepareNode layoutTest =
121 List.map (prepareExpectation layoutTest) layoutTest.expectations
123 prepare { label, results } =
124 { label = label
125 , results = List.concatMap prepareNode results
126 }
127 in
128 List.map prepare withResults
131type Msg
132 = NoOp
133 | Analyze
134 | HighlightDomID (Maybe String)
135 | RefreshBoundingBox
136 (List
137 { id : String
138 , bbox : Testable.BoundingBox
139 , style : List ( String, String )
140 , isVisible : Bool
141 , textMetrics : List Testable.TextMetrics
142 }
143 )
146runTest : Dict String Testable.Found -> String -> Testable.Element msg -> WithResults (Testable.Element msg)
147runTest boxes label element =
148 let
149 results =
150 Testable.runTests boxes element
151 in
152 { element = element
153 , label = label
154 , results = results
155 }
158update : Msg -> Model Msg -> ( Model Msg, Cmd Msg )
159update msg model =
160 case msg of
161 NoOp ->
162 ( model, Cmd.none )
164 HighlightDomID newId ->
165 ( { model | highlightDomId = newId }
166 , Cmd.none
167 )
169 RefreshBoundingBox boxes ->
170 case model.current of
171 Nothing ->
172 ( model
173 , Cmd.none
174 )
176 Just ( label, current ) ->
177 let
178 toTuple box =
179 ( box.id
180 , { style = Dict.fromList box.style
181 , bbox = box.bbox
182 , isVisible = box.isVisible
183 , textMetrics = box.textMetrics
184 }
185 )
187 foundData =
188 boxes
189 |> List.map toTuple
190 |> Dict.fromList
192 currentResults =
193 runTest foundData label current
194 in
195 case model.upcoming of
196 [] ->
197 ( { model
198 | current = Nothing
199 , finished = model.finished ++ [ currentResults ]
200 }
201 , report (encodeForReport (currentResults :: model.finished))
202 )
204 newCurrent :: remaining ->
205 ( { model
206 | finished = model.finished ++ [ currentResults ]
207 , current = Just newCurrent
208 , upcoming = remaining
209 }
210 , Task.perform (always Analyze)
211 (Process.sleep 32
212 |> Task.andThen
213 (always Time.now)
214 )
215 )
217 Analyze ->
218 case model.current of
219 Nothing ->
220 ( model
221 , Cmd.none
222 )
224 Just ( label, current ) ->
225 ( model
226 , analyze (Testable.getIds current)
227 )
230view : Model Msg -> Html.Html Msg
231view model =
232 case model.current of
233 Nothing ->
234 if List.isEmpty model.upcoming then
235 case model.finished of
236 [] ->
237 Element.layout [] <|
238 Element.column
239 [ Element.spacing 20
240 , Element.padding 20
241 , Element.width (Element.px 800)
242 ]
243 [ Element.none ]
245 finished :: remaining ->
246 Element.layout
247 [ Font.size 16
248 , Element.inFront (Element.html (viewElementHighlight model))
249 , Element.height Element.fill
250 ]
251 <|
252 Element.row [ Element.width Element.fill, Element.height Element.fill ]
253 [ Element.el
254 [ Element.width
255 (Element.fill
256 |> Element.maximum 900)
257 , Element.alignTop
258 , Element.height Element.fill
259 , Element.scrollbars
260 ]
261 (Element.el
262 [ Element.centerX
263 , Element.padding 100
264 , Border.dashed
265 , Border.width 2
266 , Border.color palette.lightGrey
267 , Font.size 20
268 , Element.inFront
269 (Element.el
270 [ Font.size 14
271 , Font.color palette.lightGrey
272 ]
273 (Element.text "test case")
274 )
275 ]
276 (Testable.toElement finished.element)
277 )
278 , Element.column
279 [ Element.spacing 20
280 , Element.padding 20
281 , Element.width Element.fill
282 , Element.height Element.fill
283 , Element.scrollbarY
284 ]
285 (List.map viewResult (finished :: remaining))
286 ]
288 else
289 Html.text ""
291 Just ( label, current ) ->
292 Testable.toHtml current
295viewElementHighlight model =
296 case model.highlightDomId of
297 Nothing ->
298 Html.text ""
300 Just highlightDomId ->
301 let
302 elementHighlight =
303 highlightDomId ++ " { outline: solid black; }"
305 testId =
306 highlightDomId
307 |> String.dropLeft 1
308 |> String.append "#tests-"
310 testHighlight =
311 testId ++ " { outline: dashed black; }"
313 styleSheet =
314 String.join "\n"
315 [ elementHighlight
316 , testHighlight
317 ]
318 in
319 Html.node "style"
320 []
321 [ Html.text styleSheet
322 ]
325viewResult : WithResults (Testable.Element Msg) -> Element.Element Msg
326viewResult testable =
327 let
328 isExpectationPassing result =
329 case result of
330 Testable.Todo label ->
331 True
333 Testable.Expect details ->
334 details.result
336 isPassing layoutTest =
337 List.any isExpectationPassing layoutTest.expectations
339 ( passing, failing ) =
340 List.partition isPassing testable.results
341 in
342 Element.column
343 [ Element.alignLeft
344 , Element.spacing 16
345 ]
346 [ Element.el [ Font.size 24 ] (Element.text testable.label)
347 , Element.column
348 [ Element.alignLeft, Element.spacing 16 ]
349 (testable.results
350 |> groupBy .elementDomId
351 |> List.map (expandDetails >> viewLayoutTestGroup)
352 )
353 ]
356expandDetails group =
357 case group.members of
358 [] ->
359 { id = group.id
360 , elementType = Testable.EmptyType
361 , members = group.members
362 }
364 top :: _ ->
365 { id = group.id
366 , elementType = top.elementType
367 , members = group.members
368 }
371groupBy fn list =
372 groupWhile (\one two -> fn one == fn two) list
373 |> List.map
374 (\( fst, remaining ) ->
375 { id = fn fst
376 , members = fst :: remaining
377 }
378 )
381groupWhile : (a -> a -> Bool) -> List a -> List ( a, List a )
382groupWhile isSameGroup items =
383 List.foldr
384 (\x acc ->
385 case acc of
386 [] ->
387 [ ( x, [] ) ]
389 ( y, restOfGroup ) :: groups ->
390 if isSameGroup x y then
391 ( x, y :: restOfGroup ) :: groups
393 else
394 ( x, [] ) :: acc
395 )
396 []
397 items
400viewLayoutTestGroup group =
401 let
402 testId =
403 group.id
404 |> String.dropLeft 1
405 |> String.append "tests-"
406 in
407 Element.column
408 [ Element.spacing 8
409 , Element.htmlAttribute (Html.Attributes.id testId)
410 , Events.onMouseEnter (HighlightDomID (Just group.id))
411 , Events.onMouseLeave (HighlightDomID Nothing)
412 , Element.htmlAttribute (Html.Attributes.style "user-select" "none")
413 ]
414 [ Element.row [ Element.spacing 16 ]
415 [ Element.el [] (Element.text (Testable.elementTypeToString group.elementType))
416 , Element.el [ Font.color palette.lightGrey ] (Element.text group.id)
417 ]
418 , Element.column
419 [ Element.spacing 8
420 , Element.paddingXY 32 0
421 ]
422 (List.map viewLayoutTest group.members)
423 ]
426type alias Grouped thing =
427 { id : String
428 , members : List thing
429 }
432viewLayoutTest layoutTest =
433 Element.column
434 [ Element.spacing 8
435 ]
436 [ Element.row [ Element.spacing 8 ]
437 [ Element.el [ Font.bold ] (Element.text layoutTest.label)
439 -- , Element.el [ Font.color palette.lightGrey ] (Element.text layoutTest.elementDomId)
440 ]
441 , Element.column [ Element.spacing 8 ]
442 (List.map viewLayoutExpectation layoutTest.expectations)
443 ]
446viewLayoutExpectation expectation =
447 case expectation of
448 Testable.Todo label ->
449 Element.row [ Element.spacing 4 ]
450 [ todo, Element.text label ]
452 Testable.Expect details ->
453 if details.result then
454 Element.row [ Element.spacing 4 ]
455 [ pass, Element.text details.description ]
457 else
458 Element.row [ Element.spacing 4 ]
459 [ fail, Element.text details.description ]
462badge color text =
463 Element.el
464 [ Background.color color
465 , Font.color palette.black
466 , Element.paddingXY 4 8
467 , Border.rounded 2
468 ]
469 (Element.text text)
472todo =
473 badge palette.lightGrey "todo"
476pass =
477 badge palette.green "pass"
480fail =
481 badge palette.red "fail"
484formatKeyValue : String -> String -> String
485formatKeyValue key val =
486 key ++ ": " ++ val
489port report :
490 List
491 { label : String
492 , results :
493 List
494 { description : String
495 , passing : Bool
496 , todo : Bool
497 }
498 }
499 -> Cmd msg
502port test : String -> Cmd msg
505port analyze : List String -> Cmd msg
508port styles :
509 (List
510 { id : String
511 , bbox : Testable.BoundingBox
512 , style : List ( String, String )
513 , isVisible : Bool
514 , textMetrics : List Testable.TextMetrics
515 }
516 -> msg
517 )
518 -> Sub msg