git.iko.soy/typeable/elm-ui
on 2c582df help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
911 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
167type alias Surroundings msg =
168 { siblings : List Found
169 , parent : Found
170 , children : List Found
171 , self : Found
172 , selfElement : Element msg
174 -- These values are needed to perform some types of tests.
175 , parentLayout : LayoutContext
176 , parentSpacing : Int
177 }
180type alias Found =
181 { bbox : BoundingBox
182 , style : Style
183 , isVisible : Bool
184 , textMetrics : List TextMetrics
185 }
188type alias TextMetrics =
189 { actualBoundingBoxAscent : Float
190 , actualBoundingBoxDescent : Float
191 , actualBoundingBoxLeft : Float
192 , actualBoundingBoxRight : Float
193 , width : Float
194 }
197{-| The font metrics we currently have are `actual`, meaning for the text actually rendered, not the font as a whole.
199We also know the font size is 20, so we're just going to return 20.
201TODO: improve font metric collection using something like opentype.js
203-}
204textHeight metrics =
205 let
206 actualHeight =
207 metrics.actualBoundingBoxAscent
208 + metrics.actualBoundingBoxDescent
209 in
210 -- actualHeight / 20
211 20
214{-| -}
215type alias Style =
216 Dict String String
219type alias BoundingBox =
220 { width : Float
221 , height : Float
222 , left : Float
223 , top : Float
224 , right : Float
225 , bottom : Float
226 , padding :
227 { left : Float
228 , right : Float
229 , top : Float
230 , bottom : Float
231 }
232 }
235type LayoutExpectation
236 = Expect
237 { description : String
238 , result : Bool
239 }
240 | Todo String
243type alias LayoutTest =
244 { elementDomId : String
245 , elementType : ElementType
246 , label : String
247 , expectations : List LayoutExpectation
248 }
252{- Expectations -}
255floatToString : Float -> String
256floatToString x =
257 String.fromFloat (toFloat (round (x * 100)) / 100)
260lessThanOrEqual : String -> Float -> Float -> LayoutExpectation
261lessThanOrEqual label one two =
262 Expect
263 { description = label ++ " " ++ floatToString one ++ " <= " ++ floatToString two
264 , result = one <= two
265 }
268rounded : String -> { expected : Float, found : Float } -> LayoutExpectation
269rounded label { expected, found } =
270 true
271 (label ++ "| expected " ++ floatToString expected ++ ", found " ++ floatToString found)
272 (abs (expected - found) < 1)
275equal : a -> a -> LayoutExpectation
276equal one two =
277 Expect
278 { description = "Are equal"
279 , result = one == two
280 }
283true : String -> Bool -> LayoutExpectation
284true label passing =
285 Expect
286 { description = label
287 , result = passing
288 }
291todo : String -> LayoutExpectation
292todo =
293 Todo
297{- Retrieve Ids -}
300getIds : Element msg -> List String
301getIds el =
302 "se-0" :: getElementId [ 0, 0 ] el
305getElementId : List Int -> Element msg -> List String
306getElementId level el =
307 let
308 id =
309 levelToString level
311 attrID attrIndex attr =
312 case attr of
313 Nearby nearby ->
314 getElementId (attrIndex :: -1 :: level) nearby.element
316 _ ->
317 []
319 attributeIDs attrs =
320 attrs
321 |> List.indexedMap attrID
322 |> List.concat
324 childrenIDs children =
325 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
326 in
327 case el of
328 El attrs child ->
329 id :: getElementId (0 :: level) child ++ attributeIDs attrs
331 Row attrs children ->
332 id :: childrenIDs children ++ attributeIDs attrs
334 Column attrs children ->
335 id :: childrenIDs children ++ attributeIDs attrs
337 TextColumn attrs children ->
338 id :: childrenIDs children ++ attributeIDs attrs
340 Paragraph attrs children ->
341 id :: childrenIDs children ++ attributeIDs attrs
343 Empty ->
344 []
346 Text _ ->
347 []
351{- Render as Html -}
354toElement : Element msg -> Element.Element msg
355toElement el =
356 renderElement [ 0, 0 ] el
359toHtml : Element msg -> Html msg
360toHtml el =
361 Element.layout
362 [ idAttr "0"
363 , Element.width (Element.px 1000)
364 , Element.height (Element.px 1000)
365 ]
366 <|
367 renderElement [ 0, 0 ] el
370idAttr : String -> Element.Attribute msg
371idAttr id =
372 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
375renderElement : List Int -> Element msg -> Element.Element msg
376renderElement level el =
377 let
378 id =
379 level
380 |> List.map String.fromInt
381 |> String.join "-"
382 |> idAttr
384 makeAttributes attrs =
385 attrs
386 |> List.indexedMap (renderAttribute level)
387 |> List.concat
388 in
389 case el of
390 El attrs child ->
391 Element.el
392 (id :: makeAttributes attrs)
393 (renderElement (0 :: level) child)
395 Row attrs children ->
396 Element.row
397 (id :: makeAttributes attrs)
398 (List.indexedMap (\i -> renderElement (i :: level)) children)
400 Column attrs children ->
401 Element.column
402 (id :: makeAttributes attrs)
403 (List.indexedMap (\i -> renderElement (i :: level)) children)
405 TextColumn attrs children ->
406 Element.textColumn
407 (id :: makeAttributes attrs)
408 (List.indexedMap (\i -> renderElement (i :: level)) children)
410 Paragraph attrs children ->
411 Element.paragraph
412 (id :: makeAttributes attrs)
413 (List.indexedMap (\i -> renderElement (i :: level)) children)
415 Empty ->
416 Element.none
418 Text str ->
419 Element.text str
422renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
423renderAttribute level attrIndex attr =
424 case attr of
425 Attr attribute ->
426 [ attribute ]
428 AttrTest _ ->
429 []
431 Spacing _ ->
432 []
434 Nearby { location, element } ->
435 case location of
436 Above ->
437 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
439 Below ->
440 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
442 OnRight ->
443 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
445 OnLeft ->
446 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
448 InFront ->
449 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
451 Behind ->
452 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
454 Batch batch ->
455 List.indexedMap (renderAttribute (attrIndex :: level)) batch
456 |> List.concat
458 LabeledTest tested ->
459 [ tested.attr ]
463{- Convert to Test -}
466runTests : Dict String Found -> Element msg -> List LayoutTest
467runTests harvested el =
468 let
469 maybeFound =
470 Dict.get "se-0" harvested
471 in
472 case maybeFound of
473 Nothing ->
474 [ { elementDomId = "se-0"
475 , elementType = EmptyType
476 , label = "Finding root element"
477 , expectations =
478 [ Expect
479 { description = "Locating root element for rendering tests"
480 , result = False
481 }
482 ]
483 }
484 ]
486 Just root ->
487 createTest
488 { siblings = []
489 , parent = root
490 , cache = harvested
491 , parentSpacing = 0
492 , level = [ 0, 0 ]
493 , element = el
494 , location = InEl
495 }
498levelToString : List Int -> String
499levelToString level =
500 level
501 |> List.map String.fromInt
502 |> String.join "-"
503 |> (\x -> "se-" ++ x)
506createTest :
507 { siblings : List Found
508 , parent : Found
509 , cache : Dict String Found
510 , level : List Int
511 , element : Element msg
512 , location : LayoutContext
513 , parentSpacing : Int
514 }
515 -> List LayoutTest
516createTest { siblings, parent, cache, level, element, location, parentSpacing } =
517 let
518 spacing =
519 getSpacing element
520 |> Maybe.withDefault 0
522 id =
523 levelToString level
525 testChildren : Found -> List (Element msg) -> List LayoutTest
526 testChildren found children =
527 let
528 childrenFound =
529 -- Should check that this lookup doesn't fail.
530 -- Thoug if it does, it'll fail when the element itself is tested
531 List.filterMap
532 (\x ->
533 Dict.get (levelToString (x :: level)) cache
534 )
535 (List.range 0 (List.length children))
536 in
537 List.foldl (applyChildTest found)
538 { index = 0
539 , upcoming = childrenFound
540 , previous = []
541 , tests = []
542 }
543 children
544 |> .tests
546 applyChildTest :
547 Found
548 -> Element msg
549 ->
550 { a
551 | index : Int
552 , previous : List Found
553 , tests : List LayoutTest
554 , upcoming : List Found
555 }
556 ->
557 { index : Int
558 , previous : List Found
559 , tests : List LayoutTest
560 , upcoming : List Found
561 }
562 applyChildTest found child childTest =
563 -- { index, upcoming, previous, tests }
564 let
565 surroundingChildren =
566 case childTest.upcoming of
567 [] ->
568 childTest.previous
570 x :: remaining ->
571 remaining ++ childTest.previous
573 childrenTests =
574 createTest
575 { siblings = surroundingChildren
576 , parent = found
577 , cache = cache
578 , level = childTest.index :: level
579 , element = child
580 , parentSpacing = spacing
581 , location =
582 case element of
583 El _ _ ->
584 InEl
586 Row _ _ ->
587 InRow
589 Column _ _ ->
590 InColumn
592 TextColumn _ _ ->
593 InColumn
595 Paragraph _ _ ->
596 InRow
598 Text _ ->
599 InEl
601 Empty ->
602 InEl
603 }
604 in
605 { index = childTest.index + 1
606 , tests = childTest.tests ++ childrenTests
607 , previous =
608 case childTest.upcoming of
609 [] ->
610 childTest.previous
612 x :: _ ->
613 x :: childTest.previous
614 , upcoming =
615 case childTest.upcoming of
616 [] ->
617 []
619 _ :: rest ->
620 rest
621 }
623 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
624 tests self attributes children =
625 let
626 findBBox elem ( i, gathered ) =
627 case elem of
628 Empty ->
629 ( i + 1
630 , gathered
631 )
633 Text _ ->
634 ( i + 1
635 , gathered
636 )
638 _ ->
639 case Dict.get (levelToString (i :: level)) cache of
640 Nothing ->
641 let
642 _ =
643 Debug.log "el failed to find" elem
645 _ =
646 Debug.log "Failed to find child" (levelToString (i :: level))
647 in
648 ( i + 1
649 , gathered
650 )
652 Just found ->
653 ( i + 1
654 , found :: gathered
655 )
657 childrenFoundData =
658 List.foldl findBBox ( 0, [] ) children
659 |> Tuple.second
661 attributeTests =
662 attributes
663 |> List.indexedMap
664 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
665 (\i attr ->
666 createAttributeTest self
667 cache
668 level
669 i
670 { siblings = siblings
671 , parent = parent
672 , self = self
673 , selfElement = element
674 , children = childrenFoundData
675 , parentLayout = location
676 , parentSpacing = parentSpacing
677 }
678 attr
679 )
680 |> List.concat
681 in
682 attributeTests
683 ++ testChildren self children
684 in
685 case Dict.get id cache of
686 Nothing ->
687 case element of
688 Empty ->
689 []
691 Text _ ->
692 []
694 _ ->
695 [ { elementDomId = id
696 , elementType = EmptyType
697 , label = "Finding element in DOM"
698 , expectations =
699 [ Expect
700 { description = "Locating element for rendering test"
701 , result = False
702 }
703 ]
704 }
705 ]
707 Just self ->
708 case element of
709 El attrs child ->
710 tests self attrs [ child ]
712 Row attrs children ->
713 tests self attrs children
715 Column attrs children ->
716 tests self attrs children
718 TextColumn attrs children ->
719 tests self attrs children
721 Paragraph attrs children ->
722 tests self attrs children
724 Empty ->
725 []
727 Text str ->
728 []
731createAttributeTest :
732 Found
733 -> Dict String Found
734 -> List Int
735 -> Int
736 -> Surroundings msg
737 -> Attr msg
738 -> List LayoutTest
739createAttributeTest parent cache level attrIndex surroundings attr =
740 let
741 domId =
742 "#" ++ levelToString level
743 in
744 case attr of
745 Attr _ ->
746 []
748 Spacing _ ->
749 []
751 AttrTest details ->
752 [ { elementDomId = domId
753 , elementType =
754 toElementType surroundings.selfElement
755 , label = details.label
756 , expectations = details.test surroundings
757 }
758 ]
760 Nearby nearby ->
761 createTest
762 { siblings = []
763 , parent = parent
764 , cache = cache
765 , parentSpacing = 0
766 , level = attrIndex :: -1 :: level
767 , location = IsNearby nearby.location
768 , element =
769 addAttribute
770 (AttrTest
771 { label = nearby.label
772 , test =
773 nearby.test
774 , id = NoId
775 }
776 )
777 nearby.element
778 }
780 Batch batch ->
781 batch
782 |> List.indexedMap (\i attribute -> createAttributeTest parent cache level i surroundings attribute)
783 |> List.concat
785 LabeledTest { label, test } ->
786 [ { elementDomId = domId
787 , elementType = toElementType surroundings.selfElement
788 , label = label
789 , expectations = test surroundings
790 }
791 ]
794addAttribute : Attr msg -> Element msg -> Element msg
795addAttribute attr el =
796 case el of
797 El attrs child ->
798 El (attr :: attrs) child
800 Row attrs children ->
801 Row (attr :: attrs) children
803 Column attrs children ->
804 Column (attr :: attrs) children
806 TextColumn attrs children ->
807 TextColumn (attr :: attrs) children
809 Paragraph attrs children ->
810 Paragraph (attr :: attrs) children
812 Empty ->
813 Empty
815 Text str ->
816 Text str
819compareFormattedColor : Color -> String -> Bool
820compareFormattedColor color expected =
821 formatColor color == expected || formatColorWithAlpha color == expected
824formatColorWithAlpha : Color -> String
825formatColorWithAlpha (Internal.Rgba red green blue alpha) =
826 if alpha == 1 then
827 ("rgba(" ++ String.fromInt (round (red * 255)))
828 ++ (", " ++ String.fromInt (round (green * 255)))
829 ++ (", " ++ String.fromInt (round (blue * 255)))
830 ++ ", 1"
831 ++ ")"
833 else
834 ("rgba(" ++ String.fromInt (round (red * 255)))
835 ++ (", " ++ String.fromInt (round (green * 255)))
836 ++ (", " ++ String.fromInt (round (blue * 255)))
837 ++ (", " ++ String.fromFloat alpha ++ ")")
840formatColor : Color -> String
841formatColor (Internal.Rgba red green blue alpha) =
842 if alpha == 1 then
843 ("rgb(" ++ String.fromInt (round (red * 255)))
844 ++ (", " ++ String.fromInt (round (green * 255)))
845 ++ (", " ++ String.fromInt (round (blue * 255)))
846 ++ ")"
848 else
849 ("rgb(" ++ String.fromInt (round (red * 255)))
850 ++ (", " ++ String.fromInt (round (green * 255)))
851 ++ (", " ++ String.fromInt (round (blue * 255)))
852 ++ ")"
855getSpacingFromAttributes attrs =
856 case attrs of
857 [] ->
858 0
860 (Spacing i) :: remain ->
861 i
863 (Batch batched) :: remain ->
864 getSpacingFromAttributes (batched ++ remain)
866 _ :: remain ->
867 getSpacingFromAttributes remain
870getSpacing : Element msg -> Maybe Int
871getSpacing el =
872 let
873 getSpacingAttr attr found =
874 if found /= Nothing then
875 found
877 else
878 case attr of
879 Spacing i ->
880 Just i
882 Batch attrs ->
883 List.foldr getSpacingAttr Nothing attrs
885 _ ->
886 Nothing
888 filterAttrs attrs =
889 List.foldr getSpacingAttr Nothing attrs
890 in
891 case el of
892 El attrs _ ->
893 filterAttrs attrs
895 Row attrs _ ->
896 filterAttrs attrs
898 Column attrs _ ->
899 filterAttrs attrs
901 TextColumn attrs _ ->
902 filterAttrs attrs
904 Paragraph attrs _ ->
905 filterAttrs attrs
907 Empty ->
908 Nothing
910 Text _ ->
911 Nothing