git.iko.soy/typeable/elm-ui
on 1ceefdb help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
872 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 , 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
486 testChildren : Found -> List (Element msg) -> List LayoutTest
487 testChildren found children =
488 let
489 childrenFound =
490 -- Should check that this lookup doesn't fail.
491 -- Thoug if it does, it'll fail when the element itself is tested
492 List.filterMap
493 (\x ->
494 Dict.get (levelToString (x :: level)) cache
495 )
496 (List.range 0 (List.length children))
497 in
498 List.foldl (applyChildTest found)
499 { index = 0
500 , upcoming = childrenFound
501 , previous = []
502 , tests = []
503 }
504 children
505 |> .tests
507 applyChildTest :
508 Found
509 -> Element msg
510 ->
511 { a
512 | index : Int
513 , previous : List Found
514 , tests : List LayoutTest
515 , upcoming : List Found
516 }
517 ->
518 { index : Int
519 , previous : List Found
520 , tests : List LayoutTest
521 , upcoming : List Found
522 }
523 applyChildTest found child childTest =
524 -- { index, upcoming, previous, tests }
525 let
526 surroundingChildren =
527 case childTest.upcoming of
528 [] ->
529 childTest.previous
531 x :: remaining ->
532 remaining ++ childTest.previous
534 childrenTests =
535 createTest
536 { siblings = surroundingChildren
537 , parent = found
538 , cache = cache
539 , level = childTest.index :: level
540 , element = child
541 , parentSpacing = spacing
542 , location =
543 case element of
544 El _ _ ->
545 InEl
547 Row _ _ ->
548 InRow
550 Column _ _ ->
551 InColumn
553 TextColumn _ _ ->
554 InColumn
556 Paragraph _ _ ->
557 InRow
559 Text _ ->
560 InEl
562 Empty ->
563 InEl
564 }
565 in
566 { index = childTest.index + 1
567 , tests = childTest.tests ++ childrenTests
568 , previous =
569 case childTest.upcoming of
570 [] ->
571 childTest.previous
573 x :: _ ->
574 x :: childTest.previous
575 , upcoming =
576 case childTest.upcoming of
577 [] ->
578 []
580 _ :: rest ->
581 rest
582 }
584 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
585 tests self attributes children =
586 let
587 findBBox elem ( i, gathered ) =
588 case elem of
589 Empty ->
590 ( i + 1
591 , gathered
592 )
594 Text _ ->
595 ( i + 1
596 , gathered
597 )
599 _ ->
600 case Dict.get (levelToString (i :: level)) cache of
601 Nothing ->
602 let
603 _ =
604 Debug.log "el failed to find" elem
606 _ =
607 Debug.log "Failed to find child" (levelToString (i :: level))
608 in
609 ( i + 1
610 , gathered
611 )
613 Just found ->
614 ( i + 1
615 , found :: gathered
616 )
618 childrenFoundData =
619 List.foldl findBBox ( 0, [] ) children
620 |> Tuple.second
622 attributeTests =
623 attributes
624 |> List.indexedMap
625 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
626 (\i attr ->
627 createAttributeTest self
628 cache
629 level
630 i
631 { siblings = siblings
632 , parent = parent
633 , self = self
634 , selfElement = element
635 , children = childrenFoundData
636 , parentLayout = location
637 , parentSpacing = parentSpacing
638 }
639 attr
640 )
641 |> List.concat
642 in
643 attributeTests
644 ++ testChildren self children
645 in
646 case Dict.get id cache of
647 Nothing ->
648 case element of
649 Empty ->
650 []
652 Text _ ->
653 []
655 _ ->
656 [ { elementDomId = id
657 , elementType = EmptyType
658 , label = "Finding element in DOM"
659 , expectations =
660 [ Expect
661 { description = "Locating element for rendering test"
662 , result = False
663 }
664 ]
665 }
666 ]
668 Just self ->
669 case element of
670 El attrs child ->
671 tests self attrs [ child ]
673 Row attrs children ->
674 tests self attrs children
676 Column attrs children ->
677 tests self attrs children
679 TextColumn attrs children ->
680 tests self attrs children
682 Paragraph attrs children ->
683 tests self attrs children
685 Empty ->
686 []
688 Text str ->
689 []
692createAttributeTest :
693 Found
694 -> Dict String Found
695 -> List Int
696 -> Int
697 -> Surroundings msg
698 -> Attr msg
699 -> List LayoutTest
700createAttributeTest parent cache level attrIndex surroundings attr =
701 let
702 domId =
703 "#" ++ levelToString level
704 in
705 case attr of
706 Attr _ ->
707 []
709 Spacing _ ->
710 []
712 AttrTest details ->
713 [ { elementDomId = domId
714 , elementType =
715 toElementType surroundings.selfElement
716 , label = details.label
717 , expectations = details.test surroundings
718 }
719 ]
721 Nearby nearby ->
722 createTest
723 { siblings = []
724 , parent = parent
725 , cache = cache
726 , parentSpacing = 0
727 , level = attrIndex :: -1 :: level
728 , location = IsNearby nearby.location
729 , element =
730 addAttribute
731 (AttrTest
732 { label = nearby.label
733 , test =
734 nearby.test
735 , id = NoId
736 }
737 )
738 nearby.element
739 }
741 Batch batch ->
742 batch
743 |> List.indexedMap (\i attribute -> createAttributeTest parent cache level i surroundings attribute)
744 |> List.concat
746 LabeledTest { label, test } ->
747 [ { elementDomId = domId
748 , elementType = toElementType surroundings.selfElement
749 , label = label
750 , expectations = test surroundings
751 }
752 ]
755addAttribute : Attr msg -> Element msg -> Element msg
756addAttribute attr el =
757 case el of
758 El attrs child ->
759 El (attr :: attrs) child
761 Row attrs children ->
762 Row (attr :: attrs) children
764 Column attrs children ->
765 Column (attr :: attrs) children
767 TextColumn attrs children ->
768 TextColumn (attr :: attrs) children
770 Paragraph attrs children ->
771 Paragraph (attr :: attrs) children
773 Empty ->
774 Empty
776 Text str ->
777 Text str
780compareFormattedColor : Color -> String -> Bool
781compareFormattedColor color expected =
782 formatColor color == expected || formatColorWithAlpha color == expected
785formatColorWithAlpha : Color -> String
786formatColorWithAlpha (Internal.Rgba red green blue alpha) =
787 if alpha == 1 then
788 ("rgba(" ++ String.fromInt (round (red * 255)))
789 ++ (", " ++ String.fromInt (round (green * 255)))
790 ++ (", " ++ String.fromInt (round (blue * 255)))
791 ++ ", 1"
792 ++ ")"
794 else
795 ("rgba(" ++ String.fromInt (round (red * 255)))
796 ++ (", " ++ String.fromInt (round (green * 255)))
797 ++ (", " ++ String.fromInt (round (blue * 255)))
798 ++ (", " ++ String.fromFloat alpha ++ ")")
801formatColor : Color -> String
802formatColor (Internal.Rgba red green blue alpha) =
803 if alpha == 1 then
804 ("rgb(" ++ String.fromInt (round (red * 255)))
805 ++ (", " ++ String.fromInt (round (green * 255)))
806 ++ (", " ++ String.fromInt (round (blue * 255)))
807 ++ ")"
809 else
810 ("rgb(" ++ String.fromInt (round (red * 255)))
811 ++ (", " ++ String.fromInt (round (green * 255)))
812 ++ (", " ++ String.fromInt (round (blue * 255)))
813 ++ ")"
816getSpacingFromAttributes attrs =
817 case attrs of
818 [] ->
819 0
821 (Spacing i) :: remain ->
822 i
824 (Batch batched) :: remain ->
825 getSpacingFromAttributes (batched ++ remain)
827 _ :: remain ->
828 getSpacingFromAttributes remain
831getSpacing : Element msg -> Maybe Int
832getSpacing el =
833 let
834 getSpacingAttr attr found =
835 if found /= Nothing then
836 found
838 else
839 case attr of
840 Spacing i ->
841 Just i
843 Batch attrs ->
844 List.foldr getSpacingAttr Nothing attrs
846 _ ->
847 Nothing
849 filterAttrs attrs =
850 List.foldr getSpacingAttr Nothing attrs
851 in
852 case el of
853 El attrs _ ->
854 filterAttrs attrs
856 Row attrs _ ->
857 filterAttrs attrs
859 Column attrs _ ->
860 filterAttrs attrs
862 TextColumn attrs _ ->
863 filterAttrs attrs
865 Paragraph attrs _ ->
866 filterAttrs attrs
868 Empty ->
869 Nothing
871 Text _ ->
872 Nothing