git.iko.soy/typeable/elm-ui
on d188db2 help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
882 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 , runTests
24 , textHeight
25 , toElement
26 , toHtml
27 , todo
28 , true
29 )
31{-| -}
33import Dict exposing (Dict)
34import Element exposing (Color)
35import Html exposing (Html)
36import Html.Attributes
37import Internal.Model as Internal
38import Test exposing (Test)
41type Element msg
42 = El (List (Attr msg)) (Element msg)
43 | Row (List (Attr msg)) (List (Element msg))
44 | Column (List (Attr msg)) (List (Element msg))
45 | TextColumn (List (Attr msg)) (List (Element msg))
46 | Paragraph (List (Attr msg)) (List (Element msg))
47 | Text String
48 | Empty
51type ElementType
52 = ElType
53 | RowType
54 | ColumnType
55 | TextColumnType
56 | ParagraphType
57 | TextType
58 | EmptyType
61elementTypeToString : ElementType -> String
62elementTypeToString elem =
63 case elem of
64 ElType ->
65 "El"
67 RowType ->
68 "Row"
70 ColumnType ->
71 "Column"
73 TextColumnType ->
74 "TextColumn"
76 ParagraphType ->
77 "Paragraph"
79 TextType ->
80 "Text"
82 EmptyType ->
83 "Empty"
86toElementType : Element msg -> ElementType
87toElementType elem =
88 case elem of
89 El _ _ ->
90 ElType
92 Row _ _ ->
93 RowType
95 Column _ _ ->
96 ColumnType
98 TextColumn _ _ ->
99 TextColumnType
101 Paragraph _ _ ->
102 ParagraphType
104 Text _ ->
105 TextType
107 Empty ->
108 EmptyType
111{-| We have an attribute id in order to remove tests when an overriding attribtue is assigned.
113Basically, we want to implictly test for height/width shrink.
115But we want to skip this test if width/height is already set.
117This allows us to do that by comparing identities.
119-}
120type AttributeId
121 = NoId
122 | IsWidth
123 | IsHeight
126type Attr msg
127 = Attr (Element.Attribute msg)
128 | AttrTest
129 { test : Surroundings msg -> List LayoutExpectation
130 , label : String
131 , id : AttributeId
132 }
133 | Batch (List (Attr msg))
134 | Spacing Int
135 | Nearby
136 { location : Location
137 , element : Element msg
138 , test : Surroundings msg -> List LayoutExpectation
139 , label : String
140 }
141 | LabeledTest
142 { test : Surroundings msg -> List LayoutExpectation
143 , label : String
144 , attr : Element.Attribute msg
145 , id : AttributeId
146 }
149type Location
150 = Above
151 | Below
152 | OnRight
153 | OnLeft
154 | InFront
155 | Behind
158type LayoutContext
159 = IsNearby Location
160 | InRow
161 | InEl
162 | InColumn
165type alias Surroundings msg =
166 { siblings : List Found
167 , parent : Found
168 , children : List Found
169 , self : Found
170 , selfElement : Element msg
172 -- These values are needed to perform some types of tests.
173 , parentLayout : LayoutContext
174 , parentSpacing : Int
175 }
178type alias Found =
179 { bbox : BoundingBox
180 , style : Style
181 , isVisible : Bool
182 , textMetrics : List TextMetrics
183 }
186type alias TextMetrics =
187 { actualBoundingBoxAscent : Float
188 , actualBoundingBoxDescent : Float
189 , actualBoundingBoxLeft : Float
190 , actualBoundingBoxRight : Float
191 , width : Float
192 }
195textHeight metrics =
196 metrics.actualBoundingBoxAscent
197 + metrics.actualBoundingBoxDescent
200{-| -}
201type alias Style =
202 Dict String String
205type alias BoundingBox =
206 { width : Float
207 , height : Float
208 , left : Float
209 , top : Float
210 , right : Float
211 , bottom : Float
212 , padding :
213 { left : Float
214 , right : Float
215 , top : Float
216 , bottom : Float
217 }
218 }
221type LayoutExpectation
222 = Expect
223 { description : String
224 , result : Bool
225 }
226 | Todo String
229type alias LayoutTest =
230 { elementDomId : String
231 , elementType : ElementType
232 , label : String
233 , expectations : List LayoutExpectation
234 }
238{- Expectations -}
241equal : a -> a -> LayoutExpectation
242equal one two =
243 Expect
244 { description = "Are equal"
245 , result = one == two
246 }
249true : String -> Bool -> LayoutExpectation
250true label passing =
251 Expect
252 { description = label
253 , result = passing
254 }
257todo : String -> LayoutExpectation
258todo =
259 Todo
263{- Retrieve Ids -}
266getIds : Element msg -> List String
267getIds el =
268 "se-0" :: getElementId [ 0, 0 ] el
271getElementId : List Int -> Element msg -> List String
272getElementId level el =
273 let
274 id =
275 levelToString level
277 attrID attrIndex attr =
278 case attr of
279 Nearby nearby ->
280 getElementId (attrIndex :: -1 :: level) nearby.element
282 _ ->
283 []
285 attributeIDs attrs =
286 attrs
287 |> List.indexedMap attrID
288 |> List.concat
290 childrenIDs children =
291 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
292 in
293 case el of
294 El attrs child ->
295 id :: getElementId (0 :: level) child ++ attributeIDs attrs
297 Row attrs children ->
298 id :: childrenIDs children ++ attributeIDs attrs
300 Column attrs children ->
301 id :: childrenIDs children ++ attributeIDs attrs
303 TextColumn attrs children ->
304 id :: childrenIDs children ++ attributeIDs attrs
306 Paragraph attrs children ->
307 id :: childrenIDs children ++ attributeIDs attrs
309 Empty ->
310 []
312 Text _ ->
313 []
317{- Render as Html -}
320toElement : Element msg -> Element.Element msg
321toElement el =
322 renderElement [ 0, 0 ] el
325toHtml : Element msg -> Html msg
326toHtml el =
327 Element.layout [ idAttr "0" ] <|
328 renderElement [ 0, 0 ] el
331idAttr : String -> Element.Attribute msg
332idAttr id =
333 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
336renderElement : List Int -> Element msg -> Element.Element msg
337renderElement level el =
338 let
339 id =
340 level
341 |> List.map String.fromInt
342 |> String.join "-"
343 |> idAttr
345 makeAttributes attrs =
346 attrs
347 |> List.indexedMap (renderAttribute level)
348 |> List.concat
349 in
350 case el of
351 El attrs child ->
352 Element.el
353 (id :: makeAttributes attrs)
354 (renderElement (0 :: level) child)
356 Row attrs children ->
357 Element.row
358 (id :: makeAttributes attrs)
359 (List.indexedMap (\i -> renderElement (i :: level)) children)
361 Column attrs children ->
362 Element.column
363 (id :: makeAttributes attrs)
364 (List.indexedMap (\i -> renderElement (i :: level)) children)
366 TextColumn attrs children ->
367 Element.textColumn
368 (id :: makeAttributes attrs)
369 (List.indexedMap (\i -> renderElement (i :: level)) children)
371 Paragraph attrs children ->
372 Element.paragraph
373 (id :: makeAttributes attrs)
374 (List.indexedMap (\i -> renderElement (i :: level)) children)
376 Empty ->
377 Element.none
379 Text str ->
380 Element.text str
383renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
384renderAttribute level attrIndex attr =
385 case attr of
386 Attr attribute ->
387 [ attribute ]
389 AttrTest _ ->
390 []
392 Spacing _ ->
393 []
395 Nearby { location, element } ->
396 case location of
397 Above ->
398 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
400 Below ->
401 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
403 OnRight ->
404 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
406 OnLeft ->
407 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
409 InFront ->
410 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
412 Behind ->
413 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
415 Batch batch ->
416 List.indexedMap (renderAttribute (attrIndex :: level)) batch
417 |> List.concat
419 LabeledTest tested ->
420 [ tested.attr ]
424{- Convert to Test -}
427runTests : Dict String Found -> Element msg -> List LayoutTest
428runTests harvested el =
429 let
430 maybeFound =
431 Dict.get "se-0" harvested
432 in
433 case maybeFound of
434 Nothing ->
435 [ { elementDomId = "se-0"
436 , elementType = EmptyType
437 , label = "Finding root element"
438 , expectations =
439 [ Expect
440 { description = "Locating root element for rendering tests"
441 , result = False
442 }
443 ]
444 }
445 ]
447 Just root ->
448 createTest
449 { siblings = []
450 , parent = root
451 , cache = harvested
452 , parentSpacing = 0
453 , level = [ 0, 0 ]
454 , element = el
455 , location = InEl
456 }
459levelToString : List Int -> String
460levelToString level =
461 level
462 |> List.map String.fromInt
463 |> String.join "-"
464 |> (\x -> "se-" ++ x)
467createTest :
468 { siblings : List Found
469 , parent : Found
470 , cache : Dict String Found
471 , level : List Int
472 , element : Element msg
473 , location : LayoutContext
474 , parentSpacing : Int
475 }
476 -> List LayoutTest
477createTest { siblings, parent, cache, level, element, location, parentSpacing } =
478 let
479 spacing =
480 getSpacing element
481 |> Maybe.withDefault 0
483 id =
484 levelToString level
485 |> Debug.log "id"
487 _ =
488 Debug.log "element" element
490 testChildren : Found -> List (Element msg) -> List LayoutTest
491 testChildren found children =
492 let
493 childrenFound =
494 -- Should check that this lookup doesn't fail.
495 -- Thoug if it does, it'll fail when the element itself is tested
496 List.filterMap
497 (\x ->
498 Dict.get (levelToString (x :: level)) cache
499 )
500 (List.range 0 (List.length children))
501 in
502 List.foldl (applyChildTest found)
503 { index = 0
504 , upcoming = childrenFound
505 , previous = []
506 , tests = []
507 }
508 children
509 |> .tests
511 applyChildTest :
512 Found
513 -> Element msg
514 ->
515 { a
516 | index : Int
517 , previous : List Found
518 , tests : List LayoutTest
519 , upcoming : List Found
520 }
521 ->
522 { index : Int
523 , previous : List Found
524 , tests : List LayoutTest
525 , upcoming : List Found
526 }
527 applyChildTest found child childTest =
528 -- { index, upcoming, previous, tests }
529 let
530 surroundingChildren =
531 case childTest.upcoming of
532 [] ->
533 childTest.previous
535 x :: remaining ->
536 remaining ++ childTest.previous
538 childrenTests =
539 createTest
540 { siblings = surroundingChildren
541 , parent = found
542 , cache = cache
543 , level = childTest.index :: level
544 , element = child
545 , parentSpacing = spacing
546 , location =
547 case element of
548 El _ _ ->
549 InEl
551 Row _ _ ->
552 InRow
554 Column _ _ ->
555 InColumn
557 TextColumn _ _ ->
558 InColumn
560 Paragraph _ _ ->
561 InRow
563 Text _ ->
564 InEl
566 Empty ->
567 InEl
568 }
569 in
570 { index = childTest.index + 1
571 , tests = childTest.tests ++ childrenTests
572 , previous =
573 case childTest.upcoming of
574 [] ->
575 childTest.previous
577 x :: _ ->
578 x :: childTest.previous
579 , upcoming =
580 case childTest.upcoming of
581 [] ->
582 []
584 _ :: rest ->
585 rest
586 }
588 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
589 tests self attributes children =
590 let
591 findBBox elem ( i, gathered ) =
592 case elem of
593 Empty ->
594 ( i + 1
595 , gathered
596 )
598 Text _ ->
599 ( i + 1
600 , gathered
601 )
603 _ ->
604 case Dict.get (levelToString (i :: level)) cache of
605 Nothing ->
606 let
607 _ =
608 Debug.log "el failed to find" elem
610 _ =
611 Debug.log "Failed to find child" (levelToString (i :: level))
612 in
613 ( i + 1
614 , gathered
615 )
617 Just found ->
618 ( i + 1
619 , found :: gathered
620 )
622 childrenFoundData =
623 List.foldl findBBox ( 0, [] ) children
624 |> Tuple.second
626 attributeTests =
627 attributes
628 |> Debug.log "attributes"
629 |> List.indexedMap
630 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
631 (\i attr ->
632 createAttributeTest self
633 cache
634 level
635 i
636 { siblings = siblings
637 , parent = parent
638 , self = self
639 , selfElement = element
640 , children = childrenFoundData
641 , parentLayout = location
642 , parentSpacing = parentSpacing
643 }
644 attr
645 )
646 |> List.concat
647 in
648 attributeTests
649 ++ testChildren self children
650 in
651 case Dict.get id cache of
652 Nothing ->
653 case element of
654 Empty ->
655 []
657 Text _ ->
658 []
660 _ ->
661 [ { elementDomId = id
662 , elementType = EmptyType
663 , label = "Finding element in DOM"
664 , expectations =
665 [ Expect
666 { description = "Locating element for rendering test"
667 , result = False
668 }
669 ]
670 }
671 ]
673 Just self ->
674 case element of
675 El attrs child ->
676 tests self attrs [ child ]
678 Row attrs children ->
679 tests self attrs children
681 Column attrs children ->
682 tests self attrs children
684 TextColumn attrs children ->
685 tests self attrs children
687 Paragraph attrs children ->
688 tests self attrs children
690 Empty ->
691 []
693 Text str ->
694 []
697createAttributeTest :
698 Found
699 -> Dict String Found
700 -> List Int
701 -> Int
702 -> Surroundings msg
703 -> Attr msg
704 -> List LayoutTest
705createAttributeTest parent cache level attrIndex surroundings attr =
706 let
707 _ =
708 Debug.log "attribute test" attr
710 domId =
711 "#"
712 ++ levelToString level
713 |> Debug.log "domid"
714 in
715 case attr of
716 Attr _ ->
717 []
719 Spacing _ ->
720 []
722 AttrTest details ->
723 [ { elementDomId = domId
724 , elementType =
725 toElementType surroundings.selfElement
726 , label = details.label
727 , expectations = details.test surroundings
728 }
729 ]
731 Nearby nearby ->
732 createTest
733 { siblings = []
734 , parent = parent
735 , cache = cache
736 , parentSpacing = 0
737 , level = attrIndex :: -1 :: level
738 , location = IsNearby nearby.location
739 , element =
740 addAttribute
741 (AttrTest
742 { label = nearby.label
743 , test =
744 nearby.test
745 , id = NoId
746 }
747 )
748 nearby.element
749 }
751 Batch batch ->
752 batch
753 |> List.indexedMap (\i attribute -> createAttributeTest parent cache level i surroundings attribute)
754 |> List.concat
756 LabeledTest { label, test } ->
757 [ { elementDomId = domId
758 , elementType = toElementType surroundings.selfElement
759 , label = label
760 , expectations = test surroundings
761 }
762 ]
765addAttribute : Attr msg -> Element msg -> Element msg
766addAttribute attr el =
767 case el of
768 El attrs child ->
769 El (attr :: attrs) child
771 Row attrs children ->
772 Row (attr :: attrs) children
774 Column attrs children ->
775 Column (attr :: attrs) children
777 TextColumn attrs children ->
778 TextColumn (attr :: attrs) children
780 Paragraph attrs children ->
781 Paragraph (attr :: attrs) children
783 Empty ->
784 Empty
786 Text str ->
787 Text str
790compareFormattedColor : Color -> String -> Bool
791compareFormattedColor color expected =
792 formatColor color == expected || formatColorWithAlpha color == expected
795formatColorWithAlpha : Color -> String
796formatColorWithAlpha (Internal.Rgba red green blue alpha) =
797 if alpha == 1 then
798 ("rgba(" ++ String.fromInt (round (red * 255)))
799 ++ (", " ++ String.fromInt (round (green * 255)))
800 ++ (", " ++ String.fromInt (round (blue * 255)))
801 ++ ", 1"
802 ++ ")"
804 else
805 ("rgba(" ++ String.fromInt (round (red * 255)))
806 ++ (", " ++ String.fromInt (round (green * 255)))
807 ++ (", " ++ String.fromInt (round (blue * 255)))
808 ++ (", " ++ String.fromFloat alpha ++ ")")
811formatColor : Color -> String
812formatColor (Internal.Rgba red green blue alpha) =
813 if alpha == 1 then
814 ("rgb(" ++ String.fromInt (round (red * 255)))
815 ++ (", " ++ String.fromInt (round (green * 255)))
816 ++ (", " ++ String.fromInt (round (blue * 255)))
817 ++ ")"
819 else
820 ("rgb(" ++ String.fromInt (round (red * 255)))
821 ++ (", " ++ String.fromInt (round (green * 255)))
822 ++ (", " ++ String.fromInt (round (blue * 255)))
823 ++ ")"
826getSpacingFromAttributes attrs =
827 case attrs of
828 [] ->
829 0
831 (Spacing i) :: remain ->
832 i
834 (Batch batched) :: remain ->
835 getSpacingFromAttributes (batched ++ remain)
837 _ :: remain ->
838 getSpacingFromAttributes remain
841getSpacing : Element msg -> Maybe Int
842getSpacing el =
843 let
844 getSpacingAttr attr found =
845 if found /= Nothing then
846 found
848 else
849 case attr of
850 Spacing i ->
851 Just i
853 Batch attrs ->
854 List.foldr getSpacingAttr Nothing attrs
856 _ ->
857 Nothing
859 filterAttrs attrs =
860 List.foldr getSpacingAttr Nothing attrs
861 in
862 case el of
863 El attrs _ ->
864 filterAttrs attrs
866 Row attrs _ ->
867 filterAttrs attrs
869 Column attrs _ ->
870 filterAttrs attrs
872 TextColumn attrs _ ->
873 filterAttrs attrs
875 Paragraph attrs _ ->
876 filterAttrs attrs
878 Empty ->
879 Nothing
881 Text _ ->
882 Nothing