git.iko.soy/typeable/elm-ui
on d5c8a94 help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
914 lines 23 kB history raw
1module Testable exposing
2 ( Attr(..)
3 , AttributeId(..)
4 , BoundingBox
5 , Element(..)
6 , ElementType(..)
7 , Found
8 , LayoutContext(..)
9 , LayoutExpectation(..)
10 , LayoutTest
11 , Location(..)
12 , Style
13 , Surroundings
14 , TextMetrics
15 , compareFormattedColor
16 , elementTypeToString
17 , equal
18 , formatColor
19 , formatColorWithAlpha
20 , getIds
21 , getSpacing
22 , getSpacingFromAttributes
23 , lessThanOrEqual
24 , rounded
25 , runTests
26 , textHeight
27 , toElement
28 , toHtml
29 , todo
30 , true
31 )
33{-| -}
35import Dict exposing (Dict)
36import Element exposing (Color)
37import Html exposing (Html)
38import Html.Attributes
39import Internal.Model as Internal
40import Test exposing (Test)
43type Element msg
44 = El (List (Attr msg)) (Element msg)
45 | Row (List (Attr msg)) (List (Element msg))
46 | Column (List (Attr msg)) (List (Element msg))
47 | TextColumn (List (Attr msg)) (List (Element msg))
48 | Paragraph (List (Attr msg)) (List (Element msg))
49 | Text String
50 | Empty
53type ElementType
54 = ElType
55 | RowType
56 | ColumnType
57 | TextColumnType
58 | ParagraphType
59 | TextType
60 | EmptyType
63elementTypeToString : ElementType -> String
64elementTypeToString elem =
65 case elem of
66 ElType ->
67 "El"
69 RowType ->
70 "Row"
72 ColumnType ->
73 "Column"
75 TextColumnType ->
76 "TextColumn"
78 ParagraphType ->
79 "Paragraph"
81 TextType ->
82 "Text"
84 EmptyType ->
85 "Empty"
88toElementType : Element msg -> ElementType
89toElementType elem =
90 case elem of
91 El _ _ ->
92 ElType
94 Row _ _ ->
95 RowType
97 Column _ _ ->
98 ColumnType
100 TextColumn _ _ ->
101 TextColumnType
103 Paragraph _ _ ->
104 ParagraphType
106 Text _ ->
107 TextType
109 Empty ->
110 EmptyType
113{-| We have an attribute id in order to remove tests when an overriding attribtue is assigned.
115Basically, we want to implictly test for height/width shrink.
117But we want to skip this test if width/height is already set.
119This allows us to do that by comparing identities.
121-}
122type AttributeId
123 = NoId
124 | IsWidth
125 | IsHeight
128type Attr msg
129 = Attr (Element.Attribute msg)
130 | AttrTest
131 { test : Surroundings msg -> List LayoutExpectation
132 , label : String
133 , id : AttributeId
134 }
135 | Batch (List (Attr msg))
136 | Spacing Int
137 | Nearby
138 { location : Location
139 , element : Element msg
140 , test : Surroundings msg -> List LayoutExpectation
141 , label : String
142 }
143 | LabeledTest
144 { test : Surroundings msg -> List LayoutExpectation
145 , label : String
146 , attr : Element.Attribute msg
147 , id : AttributeId
148 }
151type Location
152 = Above
153 | Below
154 | OnRight
155 | OnLeft
156 | InFront
157 | Behind
160type LayoutContext
161 = IsNearby Location
162 | InRow
163 | InEl
164 | InColumn
165 | InParagraph
166 | InTextCol
167 | AtRoot
170type alias Surroundings msg =
171 { siblings : List Found
172 , parent : Found
173 , children : List Found
174 , self : Found
175 , selfElement : Element msg
177 -- These values are needed to perform some types of tests.
178 , parentLayout : LayoutContext
179 , parentSpacing : Int
180 }
183type alias Found =
184 { bbox : BoundingBox
185 , style : Style
186 , isVisible : Bool
187 , textMetrics : List TextMetrics
188 }
191type alias TextMetrics =
192 { actualBoundingBoxAscent : Float
193 , actualBoundingBoxDescent : Float
194 , actualBoundingBoxLeft : Float
195 , actualBoundingBoxRight : Float
196 , width : Float
197 }
200{-| The font metrics we currently have are `actual`, meaning for the text actually rendered, not the font as a whole.
202We also know the font size is 20, so we're just going to return 20.
204TODO: improve font metric collection using something like opentype.js
206-}
207textHeight metrics =
208 let
209 actualHeight =
210 metrics.actualBoundingBoxAscent
211 + metrics.actualBoundingBoxDescent
212 in
213 -- actualHeight / 20
214 20
217{-| -}
218type alias Style =
219 Dict String String
222type alias BoundingBox =
223 { width : Float
224 , height : Float
225 , left : Float
226 , top : Float
227 , right : Float
228 , bottom : Float
229 , padding :
230 { left : Float
231 , right : Float
232 , top : Float
233 , bottom : Float
234 }
235 }
238type LayoutExpectation
239 = Expect
240 { description : String
241 , result : Bool
242 }
243 | Todo String
246type alias LayoutTest =
247 { elementDomId : String
248 , elementType : ElementType
249 , label : String
250 , expectations : List LayoutExpectation
251 }
255{- Expectations -}
258floatToString : Float -> String
259floatToString x =
260 String.fromFloat (toFloat (round (x * 100)) / 100)
263lessThanOrEqual : String -> Float -> Float -> LayoutExpectation
264lessThanOrEqual label one two =
265 Expect
266 { description = label ++ " " ++ floatToString one ++ " <= " ++ floatToString two
267 , result = one <= two
268 }
271rounded : String -> { expected : Float, found : Float } -> LayoutExpectation
272rounded label { expected, found } =
273 true
274 (label ++ "| expected " ++ floatToString expected ++ ", found " ++ floatToString found)
275 (abs (expected - found) < 1)
278equal : a -> a -> LayoutExpectation
279equal one two =
280 Expect
281 { description = "Are equal"
282 , result = one == two
283 }
286true : String -> Bool -> LayoutExpectation
287true label passing =
288 Expect
289 { description = label
290 , result = passing
291 }
294todo : String -> LayoutExpectation
295todo =
296 Todo
300{- Retrieve Ids -}
303getIds : Element msg -> List String
304getIds el =
305 "se-0" :: getElementId [ 0, 0 ] el
308getElementId : List Int -> Element msg -> List String
309getElementId level el =
310 let
311 id =
312 levelToString level
314 attrID attrIndex attr =
315 case attr of
316 Nearby nearby ->
317 getElementId (attrIndex :: -1 :: level) nearby.element
319 _ ->
320 []
322 attributeIDs attrs =
323 attrs
324 |> List.indexedMap attrID
325 |> List.concat
327 childrenIDs children =
328 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
329 in
330 case el of
331 El attrs child ->
332 id :: getElementId (0 :: level) child ++ attributeIDs attrs
334 Row attrs children ->
335 id :: childrenIDs children ++ attributeIDs attrs
337 Column attrs children ->
338 id :: childrenIDs children ++ attributeIDs attrs
340 TextColumn attrs children ->
341 id :: childrenIDs children ++ attributeIDs attrs
343 Paragraph attrs children ->
344 id :: childrenIDs children ++ attributeIDs attrs
346 Empty ->
347 []
349 Text _ ->
350 []
354{- Render as Html -}
357toElement : Element msg -> Element.Element msg
358toElement el =
359 renderElement [ 0, 0 ] el
362toHtml : Element msg -> Html msg
363toHtml el =
364 Element.layout
365 [ idAttr "0"
366 , Element.width (Element.px 1000)
367 , Element.height (Element.px 1000)
368 ]
369 <|
370 renderElement [ 0, 0 ] el
373idAttr : String -> Element.Attribute msg
374idAttr id =
375 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
378renderElement : List Int -> Element msg -> Element.Element msg
379renderElement level el =
380 let
381 id =
382 level
383 |> List.map String.fromInt
384 |> String.join "-"
385 |> idAttr
387 makeAttributes attrs =
388 attrs
389 |> List.indexedMap (renderAttribute level)
390 |> List.concat
391 in
392 case el of
393 El attrs child ->
394 Element.el
395 (id :: makeAttributes attrs)
396 (renderElement (0 :: level) child)
398 Row attrs children ->
399 Element.row
400 (id :: makeAttributes attrs)
401 (List.indexedMap (\i -> renderElement (i :: level)) children)
403 Column attrs children ->
404 Element.column
405 (id :: makeAttributes attrs)
406 (List.indexedMap (\i -> renderElement (i :: level)) children)
408 TextColumn attrs children ->
409 Element.textColumn
410 (id :: makeAttributes attrs)
411 (List.indexedMap (\i -> renderElement (i :: level)) children)
413 Paragraph attrs children ->
414 Element.paragraph
415 (id :: makeAttributes attrs)
416 (List.indexedMap (\i -> renderElement (i :: level)) children)
418 Empty ->
419 Element.none
421 Text str ->
422 Element.text str
425renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
426renderAttribute level attrIndex attr =
427 case attr of
428 Attr attribute ->
429 [ attribute ]
431 AttrTest _ ->
432 []
434 Spacing _ ->
435 []
437 Nearby { location, element } ->
438 case location of
439 Above ->
440 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
442 Below ->
443 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
445 OnRight ->
446 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
448 OnLeft ->
449 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
451 InFront ->
452 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
454 Behind ->
455 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
457 Batch batch ->
458 List.indexedMap (renderAttribute (attrIndex :: level)) batch
459 |> List.concat
461 LabeledTest tested ->
462 [ tested.attr ]
466{- Convert to Test -}
469runTests : Dict String Found -> Element msg -> List LayoutTest
470runTests harvested el =
471 let
472 maybeFound =
473 Dict.get "se-0" harvested
474 in
475 case maybeFound of
476 Nothing ->
477 [ { elementDomId = "se-0"
478 , elementType = EmptyType
479 , label = "Finding root element"
480 , expectations =
481 [ Expect
482 { description = "Locating root element for rendering tests"
483 , result = False
484 }
485 ]
486 }
487 ]
489 Just root ->
490 createTest
491 { siblings = []
492 , parent = root
493 , cache = harvested
494 , parentSpacing = 0
495 , level = [ 0, 0 ]
496 , element = el
497 , location = AtRoot
498 }
501levelToString : List Int -> String
502levelToString level =
503 level
504 |> List.map String.fromInt
505 |> String.join "-"
506 |> (\x -> "se-" ++ x)
509createTest :
510 { siblings : List Found
511 , parent : Found
512 , cache : Dict String Found
513 , level : List Int
514 , element : Element msg
515 , location : LayoutContext
516 , parentSpacing : Int
517 }
518 -> List LayoutTest
519createTest { siblings, parent, cache, level, element, location, parentSpacing } =
520 let
521 spacing =
522 getSpacing element
523 |> Maybe.withDefault 0
525 id =
526 levelToString level
528 testChildren : Found -> List (Element msg) -> List LayoutTest
529 testChildren found children =
530 let
531 childrenFound =
532 -- Should check that this lookup doesn't fail.
533 -- Thoug if it does, it'll fail when the element itself is tested
534 List.filterMap
535 (\x ->
536 Dict.get (levelToString (x :: level)) cache
537 )
538 (List.range 0 (List.length children))
539 in
540 List.foldl (applyChildTest found)
541 { index = 0
542 , upcoming = childrenFound
543 , previous = []
544 , tests = []
545 }
546 children
547 |> .tests
549 applyChildTest :
550 Found
551 -> Element msg
552 ->
553 { a
554 | index : Int
555 , previous : List Found
556 , tests : List LayoutTest
557 , upcoming : List Found
558 }
559 ->
560 { index : Int
561 , previous : List Found
562 , tests : List LayoutTest
563 , upcoming : List Found
564 }
565 applyChildTest found child childTest =
566 -- { index, upcoming, previous, tests }
567 let
568 surroundingChildren =
569 case childTest.upcoming of
570 [] ->
571 childTest.previous
573 x :: remaining ->
574 remaining ++ childTest.previous
576 childrenTests =
577 createTest
578 { siblings = surroundingChildren
579 , parent = found
580 , cache = cache
581 , level = childTest.index :: level
582 , element = child
583 , parentSpacing = spacing
584 , location =
585 case element of
586 El _ _ ->
587 InEl
589 Row _ _ ->
590 InRow
592 Column _ _ ->
593 InColumn
595 TextColumn _ _ ->
596 InTextCol
598 Paragraph _ _ ->
599 InParagraph
601 Text _ ->
602 InEl
604 Empty ->
605 InEl
606 }
607 in
608 { index = childTest.index + 1
609 , tests = childTest.tests ++ childrenTests
610 , previous =
611 case childTest.upcoming of
612 [] ->
613 childTest.previous
615 x :: _ ->
616 x :: childTest.previous
617 , upcoming =
618 case childTest.upcoming of
619 [] ->
620 []
622 _ :: rest ->
623 rest
624 }
626 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
627 tests self attributes children =
628 let
629 findBBox elem ( i, gathered ) =
630 case elem of
631 Empty ->
632 ( i + 1
633 , gathered
634 )
636 Text _ ->
637 ( i + 1
638 , gathered
639 )
641 _ ->
642 case Dict.get (levelToString (i :: level)) cache of
643 Nothing ->
644 let
645 _ =
646 Debug.log "el failed to find" elem
648 _ =
649 Debug.log "Failed to find child" (levelToString (i :: level))
650 in
651 ( i + 1
652 , gathered
653 )
655 Just found ->
656 ( i + 1
657 , found :: gathered
658 )
660 childrenFoundData =
661 List.foldl findBBox ( 0, [] ) children
662 |> Tuple.second
664 attributeTests =
665 attributes
666 |> List.indexedMap
667 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
668 (\i attr ->
669 createAttributeTest self
670 cache
671 level
672 i
673 { siblings = siblings
674 , parent = parent
675 , self = self
676 , selfElement = element
677 , children = childrenFoundData
678 , parentLayout = location
679 , parentSpacing = parentSpacing
680 }
681 attr
682 )
683 |> List.concat
684 in
685 attributeTests
686 ++ testChildren self children
687 in
688 case Dict.get id cache of
689 Nothing ->
690 case element of
691 Empty ->
692 []
694 Text _ ->
695 []
697 _ ->
698 [ { elementDomId = id
699 , elementType = EmptyType
700 , label = "Finding element in DOM"
701 , expectations =
702 [ Expect
703 { description = "Locating element for rendering test"
704 , result = False
705 }
706 ]
707 }
708 ]
710 Just self ->
711 case element of
712 El attrs child ->
713 tests self attrs [ child ]
715 Row attrs children ->
716 tests self attrs children
718 Column attrs children ->
719 tests self attrs children
721 TextColumn attrs children ->
722 tests self attrs children
724 Paragraph attrs children ->
725 tests self attrs children
727 Empty ->
728 []
730 Text str ->
731 []
734createAttributeTest :
735 Found
736 -> Dict String Found
737 -> List Int
738 -> Int
739 -> Surroundings msg
740 -> Attr msg
741 -> List LayoutTest
742createAttributeTest parent cache level attrIndex surroundings attr =
743 let
744 domId =
745 "#" ++ levelToString level
746 in
747 case attr of
748 Attr _ ->
749 []
751 Spacing _ ->
752 []
754 AttrTest details ->
755 [ { elementDomId = domId
756 , elementType =
757 toElementType surroundings.selfElement
758 , label = details.label
759 , expectations = details.test surroundings
760 }
761 ]
763 Nearby nearby ->
764 createTest
765 { siblings = []
766 , parent = parent
767 , cache = cache
768 , parentSpacing = 0
769 , level = attrIndex :: -1 :: level
770 , location = IsNearby nearby.location
771 , element =
772 addAttribute
773 (AttrTest
774 { label = nearby.label
775 , test =
776 nearby.test
777 , id = NoId
778 }
779 )
780 nearby.element
781 }
783 Batch batch ->
784 batch
785 |> List.indexedMap (\i attribute -> createAttributeTest parent cache level i surroundings attribute)
786 |> List.concat
788 LabeledTest { label, test } ->
789 [ { elementDomId = domId
790 , elementType = toElementType surroundings.selfElement
791 , label = label
792 , expectations = test surroundings
793 }
794 ]
797addAttribute : Attr msg -> Element msg -> Element msg
798addAttribute attr el =
799 case el of
800 El attrs child ->
801 El (attr :: attrs) child
803 Row attrs children ->
804 Row (attr :: attrs) children
806 Column attrs children ->
807 Column (attr :: attrs) children
809 TextColumn attrs children ->
810 TextColumn (attr :: attrs) children
812 Paragraph attrs children ->
813 Paragraph (attr :: attrs) children
815 Empty ->
816 Empty
818 Text str ->
819 Text str
822compareFormattedColor : Color -> String -> Bool
823compareFormattedColor color expected =
824 formatColor color == expected || formatColorWithAlpha color == expected
827formatColorWithAlpha : Color -> String
828formatColorWithAlpha (Internal.Rgba red green blue alpha) =
829 if alpha == 1 then
830 ("rgba(" ++ String.fromInt (round (red * 255)))
831 ++ (", " ++ String.fromInt (round (green * 255)))
832 ++ (", " ++ String.fromInt (round (blue * 255)))
833 ++ ", 1"
834 ++ ")"
836 else
837 ("rgba(" ++ String.fromInt (round (red * 255)))
838 ++ (", " ++ String.fromInt (round (green * 255)))
839 ++ (", " ++ String.fromInt (round (blue * 255)))
840 ++ (", " ++ String.fromFloat alpha ++ ")")
843formatColor : Color -> String
844formatColor (Internal.Rgba red green blue alpha) =
845 if alpha == 1 then
846 ("rgb(" ++ String.fromInt (round (red * 255)))
847 ++ (", " ++ String.fromInt (round (green * 255)))
848 ++ (", " ++ String.fromInt (round (blue * 255)))
849 ++ ")"
851 else
852 ("rgb(" ++ String.fromInt (round (red * 255)))
853 ++ (", " ++ String.fromInt (round (green * 255)))
854 ++ (", " ++ String.fromInt (round (blue * 255)))
855 ++ ")"
858getSpacingFromAttributes attrs =
859 case attrs of
860 [] ->
861 0
863 (Spacing i) :: remain ->
864 i
866 (Batch batched) :: remain ->
867 getSpacingFromAttributes (batched ++ remain)
869 _ :: remain ->
870 getSpacingFromAttributes remain
873getSpacing : Element msg -> Maybe Int
874getSpacing el =
875 let
876 getSpacingAttr attr found =
877 if found /= Nothing then
878 found
880 else
881 case attr of
882 Spacing i ->
883 Just i
885 Batch attrs ->
886 List.foldr getSpacingAttr Nothing attrs
888 _ ->
889 Nothing
891 filterAttrs attrs =
892 List.foldr getSpacingAttr Nothing attrs
893 in
894 case el of
895 El attrs _ ->
896 filterAttrs attrs
898 Row attrs _ ->
899 filterAttrs attrs
901 Column attrs _ ->
902 filterAttrs attrs
904 TextColumn attrs _ ->
905 filterAttrs attrs
907 Paragraph attrs _ ->
908 filterAttrs attrs
910 Empty ->
911 Nothing
913 Text _ ->
914 Nothing