git.iko.soy/typeable/elm-ui
on 4ea86ab help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
808 lines 21 kB history raw
1module Testable exposing
2 ( Attr(..)
3 , AttributeId(..)
4 , BoundingBox
5 , Element(..)
6 , Found
7 , LayoutContext(..)
8 , LayoutExpectation(..)
9 , LayoutTest
10 , Location(..)
11 , Style
12 , Surroundings
13 , compareFormattedColor
14 , equal
15 , formatColor
16 , formatColorWithAlpha
17 , getIds
18 , getSpacing
19 , runTests
20 , toElement
21 , toHtml
22 , todo
23 , true
24 )
26{-| -}
28import Dict exposing (Dict)
29import Element exposing (Color)
30import Html exposing (Html)
31import Html.Attributes
32import Internal.Model as Internal
33import Test exposing (Test)
36type Element msg
37 = El (List (Attr msg)) (Element msg)
38 | Row (List (Attr msg)) (List (Element msg))
39 | Column (List (Attr msg)) (List (Element msg))
40 | TextColumn (List (Attr msg)) (List (Element msg))
41 | Paragraph (List (Attr msg)) (List (Element msg))
42 | Text String
43 | Empty
46{-| We have an attribute id in order to remove tests when an overriding attribtue is assigned.
48Basically, we want to implictly test for height/width shrink.
50But we want to skip this test if width/height is already set.
52This allows us to do that by comparing identities.
54-}
55type AttributeId
56 = NoId
57 | IsWidth
58 | IsHeight
61type Attr msg
62 = Attr (Element.Attribute msg)
63 | AttrTest
64 { test : Surroundings -> List LayoutExpectation
65 , label : String
66 , id : AttributeId
67 }
68 | Batch (List (Attr msg))
69 | Spacing Int
70 | Nearby
71 { location : Location
72 , element : Element msg
73 , test : Surroundings -> List LayoutExpectation
74 , label : String
75 }
76 | LabeledTest
77 { test : Surroundings -> List LayoutExpectation
78 , label : String
79 , attr : Element.Attribute msg
80 , id : AttributeId
81 }
84type Location
85 = Above
86 | Below
87 | OnRight
88 | OnLeft
89 | InFront
90 | Behind
93type LayoutContext
94 = IsNearby Location
95 | InRow
96 | InEl
97 | InColumn
100type alias Surroundings =
101 { siblings : List Found
102 , parent : Found
103 , children : List Found
104 , self : Found
106 -- These values are needed to perform some types of tests.
107 , location : LayoutContext
108 , parentSpacing : Int
109 }
112type alias Found =
113 { bbox : BoundingBox
114 , style : Style
115 , isVisible : Bool
116 }
119{-| -}
120type alias Style =
121 Dict String String
124type alias BoundingBox =
125 { width : Float
126 , height : Float
127 , left : Float
128 , top : Float
129 , right : Float
130 , bottom : Float
131 , padding :
132 { left : Float
133 , right : Float
134 , top : Float
135 , bottom : Float
136 }
137 }
140type LayoutExpectation
141 = Expect
142 { description : String
143 , result : Bool
144 }
145 | Todo String
148type alias LayoutTest =
149 { elementDomId : String
150 , label : String
151 , expectations : List LayoutExpectation
152 }
156{- Expectations -}
159equal : a -> a -> LayoutExpectation
160equal one two =
161 Expect
162 { description = "Are equal"
163 , result = one == two
164 }
167true : String -> Bool -> LayoutExpectation
168true label passing =
169 Expect
170 { description = label
171 , result = passing
172 }
175todo : String -> LayoutExpectation
176todo =
177 Todo
181{- Retrieve Ids -}
184getIds : Element msg -> List String
185getIds el =
186 "se-0" :: getElementId [ 0, 0 ] el
189getElementId : List Int -> Element msg -> List String
190getElementId level el =
191 let
192 id =
193 levelToString level
195 attrID attrIndex attr =
196 case attr of
197 Nearby nearby ->
198 getElementId (attrIndex :: -1 :: level) nearby.element
200 _ ->
201 []
203 attributeIDs attrs =
204 attrs
205 |> List.indexedMap attrID
206 |> List.concat
208 childrenIDs children =
209 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
210 in
211 case el of
212 El attrs child ->
213 id :: getElementId (0 :: level) child ++ attributeIDs attrs
215 Row attrs children ->
216 id :: childrenIDs children ++ attributeIDs attrs
218 Column attrs children ->
219 id :: childrenIDs children ++ attributeIDs attrs
221 TextColumn attrs children ->
222 id :: childrenIDs children ++ attributeIDs attrs
224 Paragraph attrs children ->
225 id :: childrenIDs children ++ attributeIDs attrs
227 Empty ->
228 []
230 Text _ ->
231 []
235{- Render as Html -}
238toElement : Element msg -> Element.Element msg
239toElement el =
240 renderElement [ 0, 0 ] el
243toHtml : Element msg -> Html msg
244toHtml el =
245 Element.layout [ idAttr "0" ] <|
246 renderElement [ 0, 0 ] el
249idAttr : String -> Element.Attribute msg
250idAttr id =
251 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
254renderElement : List Int -> Element msg -> Element.Element msg
255renderElement level el =
256 let
257 id =
258 level
259 |> List.map String.fromInt
260 |> String.join "-"
261 |> idAttr
263 makeAttributes attrs =
264 attrs
265 |> List.indexedMap (renderAttribute level)
266 |> List.concat
267 in
268 case el of
269 El attrs child ->
270 Element.el
271 (id :: makeAttributes attrs)
272 (renderElement (0 :: level) child)
274 Row attrs children ->
275 Element.row
276 (id :: makeAttributes attrs)
277 (List.indexedMap (\i -> renderElement (i :: level)) children)
279 Column attrs children ->
280 Element.column
281 (id :: makeAttributes attrs)
282 (List.indexedMap (\i -> renderElement (i :: level)) children)
284 TextColumn attrs children ->
285 Element.textColumn
286 (id :: makeAttributes attrs)
287 (List.indexedMap (\i -> renderElement (i :: level)) children)
289 Paragraph attrs children ->
290 Element.paragraph
291 (id :: makeAttributes attrs)
292 (List.indexedMap (\i -> renderElement (i :: level)) children)
294 Empty ->
295 Element.none
297 Text str ->
298 Element.text str
301renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
302renderAttribute level attrIndex attr =
303 case attr of
304 Attr attribute ->
305 [ attribute ]
307 AttrTest _ ->
308 []
310 Spacing _ ->
311 []
313 Nearby { location, element } ->
314 case location of
315 Above ->
316 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
318 Below ->
319 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
321 OnRight ->
322 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
324 OnLeft ->
325 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
327 InFront ->
328 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
330 Behind ->
331 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
333 Batch batch ->
334 List.indexedMap (renderAttribute (attrIndex :: level)) batch
335 |> List.concat
337 LabeledTest tested ->
338 [ tested.attr ]
342{- Convert to Test -}
345runTests : Dict String Found -> Element msg -> List LayoutTest
346runTests harvested el =
347 let
348 maybeFound =
349 Dict.get "se-0" harvested
350 in
351 case maybeFound of
352 Nothing ->
353 [ { elementDomId = "se-0"
354 , label = "Finding root element"
355 , expectations =
356 [ Expect
357 { description = "Locating root element for rendering tests"
358 , result = False
359 }
360 ]
361 }
362 ]
364 Just root ->
365 createTest
366 { siblings = []
367 , parent = root
368 , cache = harvested
369 , parentSpacing = 0
370 , level = [ 0, 0 ]
371 , element = el
372 , location = InEl
373 }
376levelToString : List Int -> String
377levelToString level =
378 level
379 |> List.map String.fromInt
380 |> String.join "-"
381 |> (\x -> "se-" ++ x)
384createTest :
385 { siblings : List Found
386 , parent : Found
387 , cache : Dict String Found
388 , level : List Int
389 , element : Element msg
390 , location : LayoutContext
391 , parentSpacing : Int
392 }
393 -> List LayoutTest
394createTest { siblings, parent, cache, level, element, location, parentSpacing } =
395 let
396 spacing =
397 getSpacing element
398 |> Maybe.withDefault 0
400 id =
401 levelToString level
403 testChildren : Found -> List (Element msg) -> List LayoutTest
404 testChildren found children =
405 let
406 childrenFound =
407 -- Should check that this lookup doesn't fail.
408 -- Thoug if it does, it'll fail when the element itself is tested
409 List.filterMap
410 (\x ->
411 Dict.get (levelToString (x :: level)) cache
412 )
413 (List.range 0 (List.length children))
414 in
415 List.foldl (applyChildTest found)
416 { index = 0
417 , upcoming = childrenFound
418 , previous = []
419 , tests = []
420 }
421 children
422 |> .tests
424 applyChildTest :
425 Found
426 -> Element msg
427 ->
428 { a
429 | index : Int
430 , previous : List Found
431 , tests : List LayoutTest
432 , upcoming : List Found
433 }
434 ->
435 { index : Int
436 , previous : List Found
437 , tests : List LayoutTest
438 , upcoming : List Found
439 }
440 applyChildTest found child childTest =
441 -- { index, upcoming, previous, tests }
442 let
443 surroundingChildren =
444 case childTest.upcoming of
445 [] ->
446 childTest.previous
448 x :: remaining ->
449 remaining ++ childTest.previous
451 childrenTests =
452 createTest
453 { siblings = surroundingChildren
454 , parent = found
455 , cache = cache
456 , level = childTest.index :: level
457 , element = child
458 , parentSpacing = spacing
459 , location =
460 case element of
461 El _ _ ->
462 InEl
464 Row _ _ ->
465 InRow
467 Column _ _ ->
468 InColumn
470 TextColumn _ _ ->
471 InColumn
473 Paragraph _ _ ->
474 InRow
476 Text _ ->
477 InEl
479 Empty ->
480 InEl
481 }
482 in
483 { index = childTest.index + 1
484 , tests = childTest.tests ++ childrenTests
485 , previous =
486 case childTest.upcoming of
487 [] ->
488 childTest.previous
490 x :: _ ->
491 x :: childTest.previous
492 , upcoming =
493 case childTest.upcoming of
494 [] ->
495 []
497 _ :: rest ->
498 rest
499 }
501 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
502 tests self attributes children =
503 let
504 findBBox elem ( i, gathered ) =
505 case elem of
506 Empty ->
507 ( i + 1
508 , gathered
509 )
511 Text _ ->
512 ( i + 1
513 , gathered
514 )
516 _ ->
517 case Dict.get (levelToString (i :: level)) cache of
518 Nothing ->
519 let
520 _ =
521 Debug.log "el failed to find" elem
523 _ =
524 Debug.log "Failed to find child" (levelToString (i :: level))
525 in
526 ( i + 1
527 , gathered
528 )
530 Just found ->
531 ( i + 1
532 , found :: gathered
533 )
535 childrenFoundData =
536 List.foldl findBBox ( 0, [] ) children
537 |> Tuple.second
539 attributeTests =
540 attributes
541 |> List.indexedMap
542 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
543 (\i attr ->
544 createAttributeTest self
545 cache
546 level
547 i
548 { siblings = siblings
549 , parent = parent
550 , self = self
551 , children = childrenFoundData
552 , location = location
553 , parentSpacing = parentSpacing
554 }
555 attr
556 )
557 |> List.concat
558 in
559 attributeTests
560 ++ testChildren self children
561 in
562 case Dict.get id cache of
563 Nothing ->
564 case element of
565 Empty ->
566 []
568 Text _ ->
569 []
571 _ ->
572 [ { elementDomId = id
573 , label = "Finding element in DOM"
574 , expectations =
575 [ Expect
576 { description = "Locating element for rendering test"
577 , result = False
578 }
579 ]
580 }
581 ]
583 Just self ->
584 case element of
585 El attrs child ->
586 tests self attrs [ child ]
588 Row attrs children ->
589 tests self attrs children
591 Column attrs children ->
592 tests self attrs children
594 TextColumn attrs children ->
595 tests self attrs children
597 Paragraph attrs children ->
598 tests self attrs children
600 Empty ->
601 []
603 Text str ->
604 []
607createAttributeTest :
608 Found
609 -> Dict String Found
610 -> List Int
611 -> Int
612 -> Surroundings
613 -> Attr msg
614 -> List LayoutTest
615createAttributeTest parent cache level attrIndex surroundings attr =
616 let
617 domId =
618 "#" ++ levelToString level
619 in
620 case attr of
621 Attr _ ->
622 []
624 Spacing _ ->
625 []
627 AttrTest details ->
628 [ { elementDomId = domId
629 , label = details.label
630 , expectations = details.test surroundings
631 }
632 ]
634 Nearby nearby ->
635 createTest
636 { siblings = []
637 , parent = parent
638 , cache = cache
639 , parentSpacing = 0
640 , level = attrIndex :: -1 :: level
641 , location = IsNearby nearby.location
642 , element =
643 addAttribute
644 (AttrTest
645 { label = nearby.label
646 , test =
647 nearby.test
648 , id = NoId
649 }
650 )
651 nearby.element
652 }
654 Batch batch ->
655 batch
656 |> List.indexedMap (\i attribute -> createAttributeTest parent cache (attrIndex :: level) i surroundings attribute)
657 |> List.concat
659 LabeledTest { label, test } ->
660 [ { elementDomId = domId
661 , label = label
662 , expectations = test surroundings
663 }
664 ]
667addAttribute : Attr msg -> Element msg -> Element msg
668addAttribute attr el =
669 case el of
670 El attrs child ->
671 El (attr :: attrs) child
673 Row attrs children ->
674 Row (attr :: attrs) children
676 Column attrs children ->
677 Column (attr :: attrs) children
679 TextColumn attrs children ->
680 TextColumn (attr :: attrs) children
682 Paragraph attrs children ->
683 Paragraph (attr :: attrs) children
685 Empty ->
686 Empty
688 Text str ->
689 Text str
693-- runTests :
694-- Random.Seed
695-- -> Test
696-- ->
697-- List
698-- ( String
699-- , Maybe
700-- { given : Maybe String
701-- , description : String
702-- , reason : Test.Runner.Failure.Reason
703-- }
704-- )
705-- runTests seed tests =
706-- let
707-- run runner =
708-- let
709-- ran =
710-- List.map Test.Runner.getFailureReason (runner.run ())
711-- in
712-- List.map2 Tuple.pair runner.labels ran
713-- results =
714-- case Test.Runner.fromTest 100 seed tests of
715-- Test.Runner.Plain rnrs ->
716-- List.map run rnrs
717-- Test.Runner.Only rnrs ->
718-- List.map run rnrs
719-- Test.Runner.Skipping rnrs ->
720-- List.map run rnrs
721-- Test.Runner.Invalid invalid ->
722-- let
723-- _ =
724-- Debug.log "Invalid tests" invalid
725-- in
726-- []
727-- in
728-- List.concat results
731compareFormattedColor : Color -> String -> Bool
732compareFormattedColor color expected =
733 formatColor color == expected || formatColorWithAlpha color == expected
736formatColorWithAlpha : Color -> String
737formatColorWithAlpha (Internal.Rgba red green blue alpha) =
738 if alpha == 1 then
739 ("rgba(" ++ String.fromInt (round (red * 255)))
740 ++ (", " ++ String.fromInt (round (green * 255)))
741 ++ (", " ++ String.fromInt (round (blue * 255)))
742 ++ ", 1"
743 ++ ")"
745 else
746 ("rgba(" ++ String.fromInt (round (red * 255)))
747 ++ (", " ++ String.fromInt (round (green * 255)))
748 ++ (", " ++ String.fromInt (round (blue * 255)))
749 ++ (", " ++ String.fromFloat alpha ++ ")")
752formatColor : Color -> String
753formatColor (Internal.Rgba red green blue alpha) =
754 if alpha == 1 then
755 ("rgb(" ++ String.fromInt (round (red * 255)))
756 ++ (", " ++ String.fromInt (round (green * 255)))
757 ++ (", " ++ String.fromInt (round (blue * 255)))
758 ++ ")"
760 else
761 ("rgb(" ++ String.fromInt (round (red * 255)))
762 ++ (", " ++ String.fromInt (round (green * 255)))
763 ++ (", " ++ String.fromInt (round (blue * 255)))
764 ++ ")"
767getSpacing : Element msg -> Maybe Int
768getSpacing el =
769 let
770 getSpacingAttr attr found =
771 if found /= Nothing then
772 found
774 else
775 case attr of
776 Spacing i ->
777 Just i
779 Batch attrs ->
780 List.foldr getSpacingAttr Nothing attrs
782 _ ->
783 Nothing
785 filterAttrs attrs =
786 List.foldr getSpacingAttr Nothing attrs
787 in
788 case el of
789 El attrs _ ->
790 filterAttrs attrs
792 Row attrs _ ->
793 filterAttrs attrs
795 Column attrs _ ->
796 filterAttrs attrs
798 TextColumn attrs _ ->
799 filterAttrs attrs
801 Paragraph attrs _ ->
802 filterAttrs attrs
804 Empty ->
805 Nothing
807 Text _ ->
808 Nothing