git.iko.soy/typeable/elm-ui
on 79f5e1e help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
856 lines 22 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 , runTests
23 , textHeight
24 , toElement
25 , toHtml
26 , todo
27 , true
28 )
30{-| -}
32import Dict exposing (Dict)
33import Element exposing (Color)
34import Html exposing (Html)
35import Html.Attributes
36import Internal.Model as Internal
37import Test exposing (Test)
40type Element msg
41 = El (List (Attr msg)) (Element msg)
42 | Row (List (Attr msg)) (List (Element msg))
43 | Column (List (Attr msg)) (List (Element msg))
44 | TextColumn (List (Attr msg)) (List (Element msg))
45 | Paragraph (List (Attr msg)) (List (Element msg))
46 | Text String
47 | Empty
50type ElementType
51 = ElType
52 | RowType
53 | ColumnType
54 | TextColumnType
55 | ParagraphType
56 | TextType
57 | EmptyType
60elementTypeToString : ElementType -> String
61elementTypeToString elem =
62 case elem of
63 ElType ->
64 "El"
66 RowType ->
67 "Row"
69 ColumnType ->
70 "Column"
72 TextColumnType ->
73 "TextColumn"
75 ParagraphType ->
76 "Paragraph"
78 TextType ->
79 "Text"
81 EmptyType ->
82 "Empty"
85toElementType : Element msg -> ElementType
86toElementType elem =
87 case elem of
88 El _ _ ->
89 ElType
91 Row _ _ ->
92 RowType
94 Column _ _ ->
95 ColumnType
97 TextColumn _ _ ->
98 TextColumnType
100 Paragraph _ _ ->
101 ParagraphType
103 Text _ ->
104 TextType
106 Empty ->
107 EmptyType
110{-| We have an attribute id in order to remove tests when an overriding attribtue is assigned.
112Basically, we want to implictly test for height/width shrink.
114But we want to skip this test if width/height is already set.
116This allows us to do that by comparing identities.
118-}
119type AttributeId
120 = NoId
121 | IsWidth
122 | IsHeight
125type Attr msg
126 = Attr (Element.Attribute msg)
127 | AttrTest
128 { test : Surroundings msg -> List LayoutExpectation
129 , label : String
130 , id : AttributeId
131 }
132 | Batch (List (Attr msg))
133 | Spacing Int
134 | Nearby
135 { location : Location
136 , element : Element msg
137 , test : Surroundings msg -> List LayoutExpectation
138 , label : String
139 }
140 | LabeledTest
141 { test : Surroundings msg -> List LayoutExpectation
142 , label : String
143 , attr : Element.Attribute msg
144 , id : AttributeId
145 }
148type Location
149 = Above
150 | Below
151 | OnRight
152 | OnLeft
153 | InFront
154 | Behind
157type LayoutContext
158 = IsNearby Location
159 | InRow
160 | InEl
161 | InColumn
164type alias Surroundings msg =
165 { siblings : List Found
166 , parent : Found
167 , children : List Found
168 , self : Found
169 , selfElement : Element msg
171 -- These values are needed to perform some types of tests.
172 , parentLayout : LayoutContext
173 , parentSpacing : Int
174 }
177type alias Found =
178 { bbox : BoundingBox
179 , style : Style
180 , isVisible : Bool
181 , textMetrics : List TextMetrics
182 }
185type alias TextMetrics =
186 { actualBoundingBoxAscent : Float
187 , actualBoundingBoxDescent : Float
188 , actualBoundingBoxLeft : Float
189 , actualBoundingBoxRight : Float
190 , width : Float
191 }
194textHeight metrics =
195 metrics.actualBoundingBoxAscent
196 + metrics.actualBoundingBoxDescent
199{-| -}
200type alias Style =
201 Dict String String
204type alias BoundingBox =
205 { width : Float
206 , height : Float
207 , left : Float
208 , top : Float
209 , right : Float
210 , bottom : Float
211 , padding :
212 { left : Float
213 , right : Float
214 , top : Float
215 , bottom : Float
216 }
217 }
220type LayoutExpectation
221 = Expect
222 { description : String
223 , result : Bool
224 }
225 | Todo String
228type alias LayoutTest =
229 { elementDomId : String
230 , elementType : ElementType
231 , label : String
232 , expectations : List LayoutExpectation
233 }
237{- Expectations -}
240equal : a -> a -> LayoutExpectation
241equal one two =
242 Expect
243 { description = "Are equal"
244 , result = one == two
245 }
248true : String -> Bool -> LayoutExpectation
249true label passing =
250 Expect
251 { description = label
252 , result = passing
253 }
256todo : String -> LayoutExpectation
257todo =
258 Todo
262{- Retrieve Ids -}
265getIds : Element msg -> List String
266getIds el =
267 "se-0" :: getElementId [ 0, 0 ] el
270getElementId : List Int -> Element msg -> List String
271getElementId level el =
272 let
273 id =
274 levelToString level
276 attrID attrIndex attr =
277 case attr of
278 Nearby nearby ->
279 getElementId (attrIndex :: -1 :: level) nearby.element
281 _ ->
282 []
284 attributeIDs attrs =
285 attrs
286 |> List.indexedMap attrID
287 |> List.concat
289 childrenIDs children =
290 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
291 in
292 case el of
293 El attrs child ->
294 id :: getElementId (0 :: level) child ++ attributeIDs attrs
296 Row attrs children ->
297 id :: childrenIDs children ++ attributeIDs attrs
299 Column attrs children ->
300 id :: childrenIDs children ++ attributeIDs attrs
302 TextColumn attrs children ->
303 id :: childrenIDs children ++ attributeIDs attrs
305 Paragraph attrs children ->
306 id :: childrenIDs children ++ attributeIDs attrs
308 Empty ->
309 []
311 Text _ ->
312 []
316{- Render as Html -}
319toElement : Element msg -> Element.Element msg
320toElement el =
321 renderElement [ 0, 0 ] el
324toHtml : Element msg -> Html msg
325toHtml el =
326 Element.layout [ idAttr "0" ] <|
327 renderElement [ 0, 0 ] el
330idAttr : String -> Element.Attribute msg
331idAttr id =
332 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
335renderElement : List Int -> Element msg -> Element.Element msg
336renderElement level el =
337 let
338 id =
339 level
340 |> List.map String.fromInt
341 |> String.join "-"
342 |> idAttr
344 makeAttributes attrs =
345 attrs
346 |> List.indexedMap (renderAttribute level)
347 |> List.concat
348 in
349 case el of
350 El attrs child ->
351 Element.el
352 (id :: makeAttributes attrs)
353 (renderElement (0 :: level) child)
355 Row attrs children ->
356 Element.row
357 (id :: makeAttributes attrs)
358 (List.indexedMap (\i -> renderElement (i :: level)) children)
360 Column attrs children ->
361 Element.column
362 (id :: makeAttributes attrs)
363 (List.indexedMap (\i -> renderElement (i :: level)) children)
365 TextColumn attrs children ->
366 Element.textColumn
367 (id :: makeAttributes attrs)
368 (List.indexedMap (\i -> renderElement (i :: level)) children)
370 Paragraph attrs children ->
371 Element.paragraph
372 (id :: makeAttributes attrs)
373 (List.indexedMap (\i -> renderElement (i :: level)) children)
375 Empty ->
376 Element.none
378 Text str ->
379 Element.text str
382renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
383renderAttribute level attrIndex attr =
384 case attr of
385 Attr attribute ->
386 [ attribute ]
388 AttrTest _ ->
389 []
391 Spacing _ ->
392 []
394 Nearby { location, element } ->
395 case location of
396 Above ->
397 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
399 Below ->
400 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
402 OnRight ->
403 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
405 OnLeft ->
406 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
408 InFront ->
409 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
411 Behind ->
412 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
414 Batch batch ->
415 List.indexedMap (renderAttribute (attrIndex :: level)) batch
416 |> List.concat
418 LabeledTest tested ->
419 [ tested.attr ]
423{- Convert to Test -}
426runTests : Dict String Found -> Element msg -> List LayoutTest
427runTests harvested el =
428 let
429 maybeFound =
430 Dict.get "se-0" harvested
431 in
432 case maybeFound of
433 Nothing ->
434 [ { elementDomId = "se-0"
435 , elementType = EmptyType
436 , label = "Finding root element"
437 , expectations =
438 [ Expect
439 { description = "Locating root element for rendering tests"
440 , result = False
441 }
442 ]
443 }
444 ]
446 Just root ->
447 createTest
448 { siblings = []
449 , parent = root
450 , cache = harvested
451 , parentSpacing = 0
452 , level = [ 0, 0 ]
453 , element = el
454 , location = InEl
455 }
458levelToString : List Int -> String
459levelToString level =
460 level
461 |> List.map String.fromInt
462 |> String.join "-"
463 |> (\x -> "se-" ++ x)
466createTest :
467 { siblings : List Found
468 , parent : Found
469 , cache : Dict String Found
470 , level : List Int
471 , element : Element msg
472 , location : LayoutContext
473 , parentSpacing : Int
474 }
475 -> List LayoutTest
476createTest { siblings, parent, cache, level, element, location, parentSpacing } =
477 let
478 spacing =
479 getSpacing element
480 |> Maybe.withDefault 0
482 id =
483 levelToString level
485 testChildren : Found -> List (Element msg) -> List LayoutTest
486 testChildren found children =
487 let
488 childrenFound =
489 -- Should check that this lookup doesn't fail.
490 -- Thoug if it does, it'll fail when the element itself is tested
491 List.filterMap
492 (\x ->
493 Dict.get (levelToString (x :: level)) cache
494 )
495 (List.range 0 (List.length children))
496 in
497 List.foldl (applyChildTest found)
498 { index = 0
499 , upcoming = childrenFound
500 , previous = []
501 , tests = []
502 }
503 children
504 |> .tests
506 applyChildTest :
507 Found
508 -> Element msg
509 ->
510 { a
511 | index : Int
512 , previous : List Found
513 , tests : List LayoutTest
514 , upcoming : List Found
515 }
516 ->
517 { index : Int
518 , previous : List Found
519 , tests : List LayoutTest
520 , upcoming : List Found
521 }
522 applyChildTest found child childTest =
523 -- { index, upcoming, previous, tests }
524 let
525 surroundingChildren =
526 case childTest.upcoming of
527 [] ->
528 childTest.previous
530 x :: remaining ->
531 remaining ++ childTest.previous
533 childrenTests =
534 createTest
535 { siblings = surroundingChildren
536 , parent = found
537 , cache = cache
538 , level = childTest.index :: level
539 , element = child
540 , parentSpacing = spacing
541 , location =
542 case element of
543 El _ _ ->
544 InEl
546 Row _ _ ->
547 InRow
549 Column _ _ ->
550 InColumn
552 TextColumn _ _ ->
553 InColumn
555 Paragraph _ _ ->
556 InRow
558 Text _ ->
559 InEl
561 Empty ->
562 InEl
563 }
564 in
565 { index = childTest.index + 1
566 , tests = childTest.tests ++ childrenTests
567 , previous =
568 case childTest.upcoming of
569 [] ->
570 childTest.previous
572 x :: _ ->
573 x :: childTest.previous
574 , upcoming =
575 case childTest.upcoming of
576 [] ->
577 []
579 _ :: rest ->
580 rest
581 }
583 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
584 tests self attributes children =
585 let
586 findBBox elem ( i, gathered ) =
587 case elem of
588 Empty ->
589 ( i + 1
590 , gathered
591 )
593 Text _ ->
594 ( i + 1
595 , gathered
596 )
598 _ ->
599 case Dict.get (levelToString (i :: level)) cache of
600 Nothing ->
601 let
602 _ =
603 Debug.log "el failed to find" elem
605 _ =
606 Debug.log "Failed to find child" (levelToString (i :: level))
607 in
608 ( i + 1
609 , gathered
610 )
612 Just found ->
613 ( i + 1
614 , found :: gathered
615 )
617 childrenFoundData =
618 List.foldl findBBox ( 0, [] ) children
619 |> Tuple.second
621 attributeTests =
622 attributes
623 |> List.indexedMap
624 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
625 (\i attr ->
626 createAttributeTest self
627 cache
628 level
629 i
630 { siblings = siblings
631 , parent = parent
632 , self = self
633 , selfElement = element
634 , children = childrenFoundData
635 , parentLayout = location
636 , parentSpacing = parentSpacing
637 }
638 attr
639 )
640 |> List.concat
641 in
642 attributeTests
643 ++ testChildren self children
644 in
645 case Dict.get id cache of
646 Nothing ->
647 case element of
648 Empty ->
649 []
651 Text _ ->
652 []
654 _ ->
655 [ { elementDomId = id
656 , elementType = EmptyType
657 , label = "Finding element in DOM"
658 , expectations =
659 [ Expect
660 { description = "Locating element for rendering test"
661 , result = False
662 }
663 ]
664 }
665 ]
667 Just self ->
668 case element of
669 El attrs child ->
670 tests self attrs [ child ]
672 Row attrs children ->
673 tests self attrs children
675 Column attrs children ->
676 tests self attrs children
678 TextColumn attrs children ->
679 tests self attrs children
681 Paragraph attrs children ->
682 tests self attrs children
684 Empty ->
685 []
687 Text str ->
688 []
691createAttributeTest :
692 Found
693 -> Dict String Found
694 -> List Int
695 -> Int
696 -> Surroundings msg
697 -> Attr msg
698 -> List LayoutTest
699createAttributeTest parent cache level attrIndex surroundings attr =
700 let
701 domId =
702 "#" ++ levelToString level
703 in
704 case attr of
705 Attr _ ->
706 []
708 Spacing _ ->
709 []
711 AttrTest details ->
712 [ { elementDomId = domId
713 , elementType =
714 toElementType surroundings.selfElement
715 , label = details.label
716 , expectations = details.test surroundings
717 }
718 ]
720 Nearby nearby ->
721 createTest
722 { siblings = []
723 , parent = parent
724 , cache = cache
725 , parentSpacing = 0
726 , level = attrIndex :: -1 :: level
727 , location = IsNearby nearby.location
728 , element =
729 addAttribute
730 (AttrTest
731 { label = nearby.label
732 , test =
733 nearby.test
734 , id = NoId
735 }
736 )
737 nearby.element
738 }
740 Batch batch ->
741 batch
742 |> List.indexedMap (\i attribute -> createAttributeTest parent cache (attrIndex :: level) i surroundings attribute)
743 |> List.concat
745 LabeledTest { label, test } ->
746 [ { elementDomId = domId
747 , elementType = toElementType surroundings.selfElement
748 , label = label
749 , expectations = test surroundings
750 }
751 ]
754addAttribute : Attr msg -> Element msg -> Element msg
755addAttribute attr el =
756 case el of
757 El attrs child ->
758 El (attr :: attrs) child
760 Row attrs children ->
761 Row (attr :: attrs) children
763 Column attrs children ->
764 Column (attr :: attrs) children
766 TextColumn attrs children ->
767 TextColumn (attr :: attrs) children
769 Paragraph attrs children ->
770 Paragraph (attr :: attrs) children
772 Empty ->
773 Empty
775 Text str ->
776 Text str
779compareFormattedColor : Color -> String -> Bool
780compareFormattedColor color expected =
781 formatColor color == expected || formatColorWithAlpha color == expected
784formatColorWithAlpha : Color -> String
785formatColorWithAlpha (Internal.Rgba red green blue alpha) =
786 if alpha == 1 then
787 ("rgba(" ++ String.fromInt (round (red * 255)))
788 ++ (", " ++ String.fromInt (round (green * 255)))
789 ++ (", " ++ String.fromInt (round (blue * 255)))
790 ++ ", 1"
791 ++ ")"
793 else
794 ("rgba(" ++ String.fromInt (round (red * 255)))
795 ++ (", " ++ String.fromInt (round (green * 255)))
796 ++ (", " ++ String.fromInt (round (blue * 255)))
797 ++ (", " ++ String.fromFloat alpha ++ ")")
800formatColor : Color -> String
801formatColor (Internal.Rgba red green blue alpha) =
802 if alpha == 1 then
803 ("rgb(" ++ String.fromInt (round (red * 255)))
804 ++ (", " ++ String.fromInt (round (green * 255)))
805 ++ (", " ++ String.fromInt (round (blue * 255)))
806 ++ ")"
808 else
809 ("rgb(" ++ String.fromInt (round (red * 255)))
810 ++ (", " ++ String.fromInt (round (green * 255)))
811 ++ (", " ++ String.fromInt (round (blue * 255)))
812 ++ ")"
815getSpacing : Element msg -> Maybe Int
816getSpacing el =
817 let
818 getSpacingAttr attr found =
819 if found /= Nothing then
820 found
822 else
823 case attr of
824 Spacing i ->
825 Just i
827 Batch attrs ->
828 List.foldr getSpacingAttr Nothing attrs
830 _ ->
831 Nothing
833 filterAttrs attrs =
834 List.foldr getSpacingAttr Nothing attrs
835 in
836 case el of
837 El attrs _ ->
838 filterAttrs attrs
840 Row attrs _ ->
841 filterAttrs attrs
843 Column attrs _ ->
844 filterAttrs attrs
846 TextColumn attrs _ ->
847 filterAttrs attrs
849 Paragraph attrs _ ->
850 filterAttrs attrs
852 Empty ->
853 Nothing
855 Text _ ->
856 Nothing