git.iko.soy/typeable/elm-ui
on cd088cb help sign in
typeable/elm-ui/tests/src/Testable.elm
734 lines 20 kB history raw
1module Testable exposing (Attr(..), BoundingBox, Element(..), Found, LayoutContext(..), Location(..), Style, Surroundings, addAttribute, applyLabels, compareFormattedColor, createAttributeTest, createTest, formatColor, formatColorWithAlpha, getElementId, getIds, getSpacing, idAttr, levelToString, render, renderAttribute, renderElement, runTests, toTest)
3{-| -}
5import Dict exposing (Dict)
6import Element exposing (Color)
7import Expect
8import Html exposing (Html)
9import Html.Attributes
10import Internal.Model as Internal
11import Random
12import Test exposing (Test)
13import Test.Runner
14import Test.Runner.Failure
17type Element msg
18 = El (List (Attr msg)) (Element msg)
19 | Row (List (Attr msg)) (List (Element msg))
20 | Column (List (Attr msg)) (List (Element msg))
21 | TextColumn (List (Attr msg)) (List (Element msg))
22 | Paragraph (List (Attr msg)) (List (Element msg))
23 | Text String
24 | Empty
27type Attr msg
28 = Attr (Element.Attribute msg)
29 | AttrTest (Surroundings -> Test)
30 | Batch (List (Attr msg))
31 | Spacing Int
32 | Nearby
33 { location : Location
34 , element : Element msg
35 , test : Surroundings -> () -> Expect.Expectation
36 , label : String
37 }
38 | Label String
39 | LabeledTest
40 { test : Surroundings -> () -> Expect.Expectation
41 , label : String
42 , attr : Element.Attribute msg
43 }
46type Location
47 = Above
48 | Below
49 | OnRight
50 | OnLeft
51 | InFront
52 | Behind
55type LayoutContext
56 = IsNearby Location
57 | InRow
58 | InEl
59 | InColumn
62type alias Surroundings =
63 { siblings : List Found
64 , parent : Found
65 , children : List Found
66 , self : Found
68 -- These values are needed to perform some types of tests.
69 , location : LayoutContext
70 , parentSpacing : Int
71 }
74type alias Found =
75 { bbox : BoundingBox
76 , style : Style
77 , isVisible : Bool
78 }
81{-| -}
82type alias Style =
83 Dict String String
86type alias BoundingBox =
87 { width : Float
88 , height : Float
89 , left : Float
90 , top : Float
91 , right : Float
92 , bottom : Float
93 , padding :
94 { left : Float
95 , right : Float
96 , top : Float
97 , bottom : Float
98 }
99 }
103{- Retrieve Ids -}
106getIds : Element msg -> List String
107getIds el =
108 "se-0" :: getElementId [ 0, 0 ] el
111getElementId : List Int -> Element msg -> List String
112getElementId level el =
113 let
114 id =
115 levelToString level
117 attrID attrIndex attr =
118 case attr of
119 Nearby nearby ->
120 getElementId (attrIndex :: -1 :: level) nearby.element
122 _ ->
123 []
125 attributeIDs attrs =
126 attrs
127 |> List.indexedMap attrID
128 |> List.concat
130 childrenIDs children =
131 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
132 in
133 case el of
134 El attrs child ->
135 id :: getElementId (0 :: level) child ++ attributeIDs attrs
137 Row attrs children ->
138 id :: childrenIDs children ++ attributeIDs attrs
140 Column attrs children ->
141 id :: childrenIDs children ++ attributeIDs attrs
143 TextColumn attrs children ->
144 id :: childrenIDs children ++ attributeIDs attrs
146 Paragraph attrs children ->
147 id :: childrenIDs children ++ attributeIDs attrs
149 Empty ->
150 []
152 Text _ ->
153 []
157{- Render as Html -}
160render : Element msg -> Html msg
161render el =
162 Element.layout [ idAttr "0" ] <|
163 renderElement [ 0, 0 ] el
166idAttr : String -> Element.Attribute msg
167idAttr id =
168 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
171renderElement : List Int -> Element msg -> Element.Element msg
172renderElement level el =
173 let
174 id =
175 level
176 |> List.map String.fromInt
177 |> String.join "-"
178 |> idAttr
180 makeAttributes attrs =
181 attrs
182 |> List.indexedMap (renderAttribute level)
183 |> List.concat
184 in
185 case el of
186 El attrs child ->
187 Element.el
188 (id :: makeAttributes attrs)
189 (renderElement (0 :: level) child)
191 Row attrs children ->
192 Element.row
193 (id :: makeAttributes attrs)
194 (List.indexedMap (\i -> renderElement (i :: level)) children)
196 Column attrs children ->
197 Element.column
198 (id :: makeAttributes attrs)
199 (List.indexedMap (\i -> renderElement (i :: level)) children)
201 TextColumn attrs children ->
202 Element.textColumn
203 (id :: makeAttributes attrs)
204 (List.indexedMap (\i -> renderElement (i :: level)) children)
206 Paragraph attrs children ->
207 Element.paragraph
208 (id :: makeAttributes attrs)
209 (List.indexedMap (\i -> renderElement (i :: level)) children)
211 Empty ->
212 Element.none
214 Text str ->
215 Element.text str
218renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
219renderAttribute level attrIndex attr =
220 case attr of
221 Attr attribute ->
222 [ attribute ]
224 AttrTest _ ->
225 []
227 Spacing _ ->
228 []
230 Label _ ->
231 []
233 Nearby { location, element } ->
234 case location of
235 Above ->
236 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
238 Below ->
239 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
241 OnRight ->
242 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
244 OnLeft ->
245 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
247 InFront ->
248 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
250 Behind ->
251 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
253 Batch batch ->
254 List.indexedMap (renderAttribute (attrIndex :: level)) batch
255 |> List.concat
257 LabeledTest tested ->
258 [ tested.attr ]
262{- Convert to Test -}
265toTest : String -> Dict String Found -> Element msg -> Test
266toTest label harvested el =
267 let
268 maybeFound =
269 Dict.get "se-0" harvested
270 in
271 case maybeFound of
272 Nothing ->
273 Test.describe label
274 [ Test.test "Find Root" <|
275 \_ -> Expect.fail "unable to find root"
276 ]
278 Just root ->
279 Test.describe label <|
280 createTest
281 { siblings = []
282 , parent = root
283 , cache = harvested
284 , parentSpacing = 0
285 , level = [ 0, 0 ]
286 , element = el
287 , location = InEl
288 }
291levelToString : List Int -> String
292levelToString level =
293 level
294 |> List.map String.fromInt
295 |> String.join "-"
296 |> (\x -> "se-" ++ x)
299createTest :
300 { siblings : List Found
301 , parent : Found
302 , cache : Dict String Found
303 , level : List Int
304 , element : Element msg
305 , location : LayoutContext
306 , parentSpacing : Int
307 }
308 -> List Test
309createTest { siblings, parent, cache, level, element, location, parentSpacing } =
310 let
311 spacing =
312 getSpacing element
313 |> Maybe.withDefault 0
315 id =
316 levelToString level
318 testChildren : Found -> List (Element msg) -> List Test
319 testChildren found children =
320 let
321 childrenFound =
322 -- Should check that this lookup doesn't fail.
323 -- Thoug if it does, it'll fail when the element itself is tested
324 List.filterMap
325 (\x ->
326 Dict.get (levelToString (x :: level)) cache
327 )
328 (List.range 0 (List.length children))
329 in
330 List.foldl (applyChildTest found)
331 { index = 0
332 , upcoming = childrenFound
333 , previous = []
334 , tests = []
335 }
336 children
337 |> .tests
339 applyChildTest :
340 Found
341 -> Element msg
342 ->
343 { a
344 | index : Int
345 , previous : List Found
346 , tests : List Test
347 , upcoming : List Found
348 }
349 ->
350 { index : Int
351 , previous : List Found
352 , tests : List Test
353 , upcoming : List Found
354 }
355 applyChildTest found child childTest =
356 -- { index, upcoming, previous, tests }
357 let
358 surroundingChildren =
359 case childTest.upcoming of
360 [] ->
361 childTest.previous
363 x :: remaining ->
364 remaining ++ childTest.previous
366 childrenTests =
367 createTest
368 { siblings = surroundingChildren
369 , parent = found
370 , cache = cache
371 , level = childTest.index :: level
372 , element = child
373 , parentSpacing = spacing
374 , location =
375 case element of
376 El _ _ ->
377 InEl
379 Row _ _ ->
380 InRow
382 Column _ _ ->
383 InColumn
385 TextColumn _ _ ->
386 InColumn
388 Paragraph _ _ ->
389 InRow
391 Text _ ->
392 InEl
394 Empty ->
395 InEl
396 }
397 in
398 { index = childTest.index + 1
399 , tests = childTest.tests ++ childrenTests
400 , previous =
401 case childTest.upcoming of
402 [] ->
403 childTest.previous
405 x :: _ ->
406 x :: childTest.previous
407 , upcoming =
408 case childTest.upcoming of
409 [] ->
410 []
412 _ :: rest ->
413 rest
414 }
416 tests : Found -> List (Attr msg) -> List (Element msg) -> List Test
417 tests self attributes children =
418 let
419 findBBox elem ( i, gathered ) =
420 case elem of
421 Empty ->
422 ( i + 1
423 , gathered
424 )
426 Text _ ->
427 ( i + 1
428 , gathered
429 )
431 _ ->
432 case Dict.get (levelToString (i :: level)) cache of
433 Nothing ->
434 let
435 _ =
436 Debug.log "el failed to find" elem
438 _ =
439 Debug.log "Failed to find child" (levelToString (i :: level))
440 in
441 ( i + 1
442 , gathered
443 )
445 Just found ->
446 ( i + 1
447 , found :: gathered
448 )
450 childrenFoundData =
451 List.foldl findBBox ( 0, [] ) children
452 |> Tuple.second
454 attributeTests =
455 attributes
456 |> applyLabels
457 |> List.indexedMap
458 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
459 (\i attr ->
460 createAttributeTest self
461 cache
462 level
463 i
464 { siblings = siblings
465 , parent = parent
466 , self = self
467 , children = childrenFoundData
468 , location = location
469 , parentSpacing = parentSpacing
470 }
471 attr
472 )
473 |> List.concat
474 in
475 attributeTests
476 ++ testChildren self children
477 in
478 case Dict.get id cache of
479 Nothing ->
480 case element of
481 Empty ->
482 []
484 Text _ ->
485 []
487 _ ->
488 [ Test.test ("Unable to find " ++ id) (always <| Expect.fail "failed id lookup") ]
490 Just self ->
491 case element of
492 El attrs child ->
493 tests self attrs [ child ]
495 Row attrs children ->
496 tests self attrs children
498 Column attrs children ->
499 tests self attrs children
501 TextColumn attrs children ->
502 tests self attrs children
504 Paragraph attrs children ->
505 tests self attrs children
507 Empty ->
508 []
510 Text str ->
511 []
514applyLabels : List (Attr msg) -> List (Attr msg)
515applyLabels attrs =
516 let
517 toLabel attr =
518 case attr of
519 Label label ->
520 Just label
522 _ ->
523 Nothing
525 newLabels =
526 attrs
527 |> List.filterMap toLabel
528 |> String.join ", "
530 applyLabel newLabel attr =
531 case attr of
532 LabeledTest labeled ->
533 LabeledTest
534 { labeled
535 | label =
536 if newLabel == "" then
537 labeled.label
539 else
540 newLabel ++ ", " ++ labeled.label
541 }
543 x ->
544 x
545 in
546 List.map (applyLabel newLabels) attrs
549createAttributeTest : Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
550createAttributeTest parent cache level attrIndex surroundings attr =
551 let
552 indexLabel =
553 levelToString (attrIndex :: level)
554 in
555 case attr of
556 Attr _ ->
557 []
559 Label _ ->
560 []
562 Spacing _ ->
563 []
565 AttrTest test ->
566 [ test surroundings
567 ]
569 Nearby nearby ->
570 createTest
571 { siblings = []
572 , parent = parent
573 , cache = cache
574 , parentSpacing = 0
575 , level = attrIndex :: -1 :: level
576 , location = IsNearby nearby.location
577 , element = addAttribute (AttrTest (\context -> Test.test (nearby.label ++ " #" ++ indexLabel) (nearby.test context))) nearby.element
578 }
580 Batch batch ->
581 batch
582 |> List.indexedMap (\i attribute -> createAttributeTest parent cache (attrIndex :: level) i surroundings attribute)
583 |> List.concat
585 LabeledTest { label, test } ->
586 [ Test.test (label ++ " #" ++ indexLabel) (test surroundings)
587 ]
590addAttribute : Attr msg -> Element msg -> Element msg
591addAttribute attr el =
592 case el of
593 El attrs child ->
594 El (attr :: attrs) child
596 Row attrs children ->
597 Row (attr :: attrs) children
599 Column attrs children ->
600 Column (attr :: attrs) children
602 TextColumn attrs children ->
603 TextColumn (attr :: attrs) children
605 Paragraph attrs children ->
606 Paragraph (attr :: attrs) children
608 Empty ->
609 Empty
611 Text str ->
612 Text str
615runTests :
616 Random.Seed
617 -> Test
618 ->
619 List
620 ( String
621 , Maybe
622 { given : Maybe String
623 , description : String
624 , reason : Test.Runner.Failure.Reason
625 }
626 )
627runTests seed tests =
628 let
629 run runner =
630 let
631 ran =
632 List.map Test.Runner.getFailureReason (runner.run ())
633 in
634 List.map2 Tuple.pair runner.labels ran
636 results =
637 case Test.Runner.fromTest 100 seed tests of
638 Test.Runner.Plain rnrs ->
639 List.map run rnrs
641 Test.Runner.Only rnrs ->
642 List.map run rnrs
644 Test.Runner.Skipping rnrs ->
645 List.map run rnrs
647 Test.Runner.Invalid invalid ->
648 let
649 _ =
650 Debug.log "Invalid tests" invalid
651 in
652 []
653 in
654 List.concat results
657compareFormattedColor : Color -> String -> Bool
658compareFormattedColor color expected =
659 formatColor color == expected || formatColorWithAlpha color == expected
662formatColorWithAlpha : Color -> String
663formatColorWithAlpha (Internal.Rgba red green blue alpha) =
664 if alpha == 1 then
665 ("rgba(" ++ String.fromInt (round (red * 255)))
666 ++ (", " ++ String.fromInt (round (green * 255)))
667 ++ (", " ++ String.fromInt (round (blue * 255)))
668 ++ ", 1"
669 ++ ")"
671 else
672 ("rgba(" ++ String.fromInt (round (red * 255)))
673 ++ (", " ++ String.fromInt (round (green * 255)))
674 ++ (", " ++ String.fromInt (round (blue * 255)))
675 ++ (", " ++ String.fromFloat alpha ++ ")")
678formatColor : Color -> String
679formatColor (Internal.Rgba red green blue alpha) =
680 if alpha == 1 then
681 ("rgb(" ++ String.fromInt (round (red * 255)))
682 ++ (", " ++ String.fromInt (round (green * 255)))
683 ++ (", " ++ String.fromInt (round (blue * 255)))
684 ++ ")"
686 else
687 ("rgb(" ++ String.fromInt (round (red * 255)))
688 ++ (", " ++ String.fromInt (round (green * 255)))
689 ++ (", " ++ String.fromInt (round (blue * 255)))
690 ++ ")"
693getSpacing : Element msg -> Maybe Int
694getSpacing el =
695 let
696 getSpacingAttr attr found =
697 if found /= Nothing then
698 found
700 else
701 case attr of
702 Spacing i ->
703 Just i
705 Batch attrs ->
706 List.foldr getSpacingAttr Nothing attrs
708 _ ->
709 Nothing
711 filterAttrs attrs =
712 List.foldr getSpacingAttr Nothing attrs
713 in
714 case el of
715 El attrs _ ->
716 filterAttrs attrs
718 Row attrs _ ->
719 filterAttrs attrs
721 Column attrs _ ->
722 filterAttrs attrs
724 TextColumn attrs _ ->
725 filterAttrs attrs
727 Paragraph attrs _ ->
728 filterAttrs attrs
730 Empty ->
731 Nothing
733 Text _ ->
734 Nothing