git.iko.soy/typeable/elm-ui
on fe73cbd help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
903 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 , runTests
25 , textHeight
26 , toElement
27 , toHtml
28 , todo
29 , true
30 )
32{-| -}
34import Dict exposing (Dict)
35import Element exposing (Color)
36import Html exposing (Html)
37import Html.Attributes
38import Internal.Model as Internal
39import Test exposing (Test)
42type Element msg
43 = El (List (Attr msg)) (Element msg)
44 | Row (List (Attr msg)) (List (Element msg))
45 | Column (List (Attr msg)) (List (Element msg))
46 | TextColumn (List (Attr msg)) (List (Element msg))
47 | Paragraph (List (Attr msg)) (List (Element msg))
48 | Text String
49 | Empty
52type ElementType
53 = ElType
54 | RowType
55 | ColumnType
56 | TextColumnType
57 | ParagraphType
58 | TextType
59 | EmptyType
62elementTypeToString : ElementType -> String
63elementTypeToString elem =
64 case elem of
65 ElType ->
66 "El"
68 RowType ->
69 "Row"
71 ColumnType ->
72 "Column"
74 TextColumnType ->
75 "TextColumn"
77 ParagraphType ->
78 "Paragraph"
80 TextType ->
81 "Text"
83 EmptyType ->
84 "Empty"
87toElementType : Element msg -> ElementType
88toElementType elem =
89 case elem of
90 El _ _ ->
91 ElType
93 Row _ _ ->
94 RowType
96 Column _ _ ->
97 ColumnType
99 TextColumn _ _ ->
100 TextColumnType
102 Paragraph _ _ ->
103 ParagraphType
105 Text _ ->
106 TextType
108 Empty ->
109 EmptyType
112{-| We have an attribute id in order to remove tests when an overriding attribtue is assigned.
114Basically, we want to implictly test for height/width shrink.
116But we want to skip this test if width/height is already set.
118This allows us to do that by comparing identities.
120-}
121type AttributeId
122 = NoId
123 | IsWidth
124 | IsHeight
127type Attr msg
128 = Attr (Element.Attribute msg)
129 | AttrTest
130 { test : Surroundings msg -> List LayoutExpectation
131 , label : String
132 , id : AttributeId
133 }
134 | Batch (List (Attr msg))
135 | Spacing Int
136 | Nearby
137 { location : Location
138 , element : Element msg
139 , test : Surroundings msg -> List LayoutExpectation
140 , label : String
141 }
142 | LabeledTest
143 { test : Surroundings msg -> List LayoutExpectation
144 , label : String
145 , attr : Element.Attribute msg
146 , id : AttributeId
147 }
150type Location
151 = Above
152 | Below
153 | OnRight
154 | OnLeft
155 | InFront
156 | Behind
159type LayoutContext
160 = IsNearby Location
161 | InRow
162 | InEl
163 | InColumn
166type alias Surroundings msg =
167 { siblings : List Found
168 , parent : Found
169 , children : List Found
170 , self : Found
171 , selfElement : Element msg
173 -- These values are needed to perform some types of tests.
174 , parentLayout : LayoutContext
175 , parentSpacing : Int
176 }
179type alias Found =
180 { bbox : BoundingBox
181 , style : Style
182 , isVisible : Bool
183 , textMetrics : List TextMetrics
184 }
187type alias TextMetrics =
188 { actualBoundingBoxAscent : Float
189 , actualBoundingBoxDescent : Float
190 , actualBoundingBoxLeft : Float
191 , actualBoundingBoxRight : Float
192 , width : Float
193 }
196{-| The font metrics we currently have are `actual`, meaning for the text actually rendered, not the font as a whole.
198We also know the font size is 20, so we're just going to return 20.
200TODO: improve font metric collection using something like opentype.js
202-}
203textHeight metrics =
204 let
205 actualHeight =
206 metrics.actualBoundingBoxAscent
207 + metrics.actualBoundingBoxDescent
208 in
209 -- actualHeight / 20
210 20
213{-| -}
214type alias Style =
215 Dict String String
218type alias BoundingBox =
219 { width : Float
220 , height : Float
221 , left : Float
222 , top : Float
223 , right : Float
224 , bottom : Float
225 , padding :
226 { left : Float
227 , right : Float
228 , top : Float
229 , bottom : Float
230 }
231 }
234type LayoutExpectation
235 = Expect
236 { description : String
237 , result : Bool
238 }
239 | Todo String
242type alias LayoutTest =
243 { elementDomId : String
244 , elementType : ElementType
245 , label : String
246 , expectations : List LayoutExpectation
247 }
251{- Expectations -}
254floatToString : Float -> String
255floatToString x =
256 String.fromFloat (toFloat (round (x * 100)) / 100)
259lessThanOrEqual : String -> Float -> Float -> LayoutExpectation
260lessThanOrEqual label one two =
261 Expect
262 { description = label ++ " " ++ floatToString one ++ " <= " ++ floatToString two
263 , result = one <= two
264 }
267equal : a -> a -> LayoutExpectation
268equal one two =
269 Expect
270 { description = "Are equal"
271 , result = one == two
272 }
275true : String -> Bool -> LayoutExpectation
276true label passing =
277 Expect
278 { description = label
279 , result = passing
280 }
283todo : String -> LayoutExpectation
284todo =
285 Todo
289{- Retrieve Ids -}
292getIds : Element msg -> List String
293getIds el =
294 "se-0" :: getElementId [ 0, 0 ] el
297getElementId : List Int -> Element msg -> List String
298getElementId level el =
299 let
300 id =
301 levelToString level
303 attrID attrIndex attr =
304 case attr of
305 Nearby nearby ->
306 getElementId (attrIndex :: -1 :: level) nearby.element
308 _ ->
309 []
311 attributeIDs attrs =
312 attrs
313 |> List.indexedMap attrID
314 |> List.concat
316 childrenIDs children =
317 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
318 in
319 case el of
320 El attrs child ->
321 id :: getElementId (0 :: level) child ++ attributeIDs attrs
323 Row attrs children ->
324 id :: childrenIDs children ++ attributeIDs attrs
326 Column attrs children ->
327 id :: childrenIDs children ++ attributeIDs attrs
329 TextColumn attrs children ->
330 id :: childrenIDs children ++ attributeIDs attrs
332 Paragraph attrs children ->
333 id :: childrenIDs children ++ attributeIDs attrs
335 Empty ->
336 []
338 Text _ ->
339 []
343{- Render as Html -}
346toElement : Element msg -> Element.Element msg
347toElement el =
348 renderElement [ 0, 0 ] el
351toHtml : Element msg -> Html msg
352toHtml el =
353 Element.layout
354 [ idAttr "0"
355 , Element.width (Element.px 1000)
356 , Element.height (Element.px 1000)
357 ]
358 <|
359 renderElement [ 0, 0 ] el
362idAttr : String -> Element.Attribute msg
363idAttr id =
364 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
367renderElement : List Int -> Element msg -> Element.Element msg
368renderElement level el =
369 let
370 id =
371 level
372 |> List.map String.fromInt
373 |> String.join "-"
374 |> idAttr
376 makeAttributes attrs =
377 attrs
378 |> List.indexedMap (renderAttribute level)
379 |> List.concat
380 in
381 case el of
382 El attrs child ->
383 Element.el
384 (id :: makeAttributes attrs)
385 (renderElement (0 :: level) child)
387 Row attrs children ->
388 Element.row
389 (id :: makeAttributes attrs)
390 (List.indexedMap (\i -> renderElement (i :: level)) children)
392 Column attrs children ->
393 Element.column
394 (id :: makeAttributes attrs)
395 (List.indexedMap (\i -> renderElement (i :: level)) children)
397 TextColumn attrs children ->
398 Element.textColumn
399 (id :: makeAttributes attrs)
400 (List.indexedMap (\i -> renderElement (i :: level)) children)
402 Paragraph attrs children ->
403 Element.paragraph
404 (id :: makeAttributes attrs)
405 (List.indexedMap (\i -> renderElement (i :: level)) children)
407 Empty ->
408 Element.none
410 Text str ->
411 Element.text str
414renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
415renderAttribute level attrIndex attr =
416 case attr of
417 Attr attribute ->
418 [ attribute ]
420 AttrTest _ ->
421 []
423 Spacing _ ->
424 []
426 Nearby { location, element } ->
427 case location of
428 Above ->
429 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
431 Below ->
432 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
434 OnRight ->
435 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
437 OnLeft ->
438 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
440 InFront ->
441 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
443 Behind ->
444 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
446 Batch batch ->
447 List.indexedMap (renderAttribute (attrIndex :: level)) batch
448 |> List.concat
450 LabeledTest tested ->
451 [ tested.attr ]
455{- Convert to Test -}
458runTests : Dict String Found -> Element msg -> List LayoutTest
459runTests harvested el =
460 let
461 maybeFound =
462 Dict.get "se-0" harvested
463 in
464 case maybeFound of
465 Nothing ->
466 [ { elementDomId = "se-0"
467 , elementType = EmptyType
468 , label = "Finding root element"
469 , expectations =
470 [ Expect
471 { description = "Locating root element for rendering tests"
472 , result = False
473 }
474 ]
475 }
476 ]
478 Just root ->
479 createTest
480 { siblings = []
481 , parent = root
482 , cache = harvested
483 , parentSpacing = 0
484 , level = [ 0, 0 ]
485 , element = el
486 , location = InEl
487 }
490levelToString : List Int -> String
491levelToString level =
492 level
493 |> List.map String.fromInt
494 |> String.join "-"
495 |> (\x -> "se-" ++ x)
498createTest :
499 { siblings : List Found
500 , parent : Found
501 , cache : Dict String Found
502 , level : List Int
503 , element : Element msg
504 , location : LayoutContext
505 , parentSpacing : Int
506 }
507 -> List LayoutTest
508createTest { siblings, parent, cache, level, element, location, parentSpacing } =
509 let
510 spacing =
511 getSpacing element
512 |> Maybe.withDefault 0
514 id =
515 levelToString level
517 testChildren : Found -> List (Element msg) -> List LayoutTest
518 testChildren found children =
519 let
520 childrenFound =
521 -- Should check that this lookup doesn't fail.
522 -- Thoug if it does, it'll fail when the element itself is tested
523 List.filterMap
524 (\x ->
525 Dict.get (levelToString (x :: level)) cache
526 )
527 (List.range 0 (List.length children))
528 in
529 List.foldl (applyChildTest found)
530 { index = 0
531 , upcoming = childrenFound
532 , previous = []
533 , tests = []
534 }
535 children
536 |> .tests
538 applyChildTest :
539 Found
540 -> Element msg
541 ->
542 { a
543 | index : Int
544 , previous : List Found
545 , tests : List LayoutTest
546 , upcoming : List Found
547 }
548 ->
549 { index : Int
550 , previous : List Found
551 , tests : List LayoutTest
552 , upcoming : List Found
553 }
554 applyChildTest found child childTest =
555 -- { index, upcoming, previous, tests }
556 let
557 surroundingChildren =
558 case childTest.upcoming of
559 [] ->
560 childTest.previous
562 x :: remaining ->
563 remaining ++ childTest.previous
565 childrenTests =
566 createTest
567 { siblings = surroundingChildren
568 , parent = found
569 , cache = cache
570 , level = childTest.index :: level
571 , element = child
572 , parentSpacing = spacing
573 , location =
574 case element of
575 El _ _ ->
576 InEl
578 Row _ _ ->
579 InRow
581 Column _ _ ->
582 InColumn
584 TextColumn _ _ ->
585 InColumn
587 Paragraph _ _ ->
588 InRow
590 Text _ ->
591 InEl
593 Empty ->
594 InEl
595 }
596 in
597 { index = childTest.index + 1
598 , tests = childTest.tests ++ childrenTests
599 , previous =
600 case childTest.upcoming of
601 [] ->
602 childTest.previous
604 x :: _ ->
605 x :: childTest.previous
606 , upcoming =
607 case childTest.upcoming of
608 [] ->
609 []
611 _ :: rest ->
612 rest
613 }
615 tests : Found -> List (Attr msg) -> List (Element msg) -> List LayoutTest
616 tests self attributes children =
617 let
618 findBBox elem ( i, gathered ) =
619 case elem of
620 Empty ->
621 ( i + 1
622 , gathered
623 )
625 Text _ ->
626 ( i + 1
627 , gathered
628 )
630 _ ->
631 case Dict.get (levelToString (i :: level)) cache of
632 Nothing ->
633 let
634 _ =
635 Debug.log "el failed to find" elem
637 _ =
638 Debug.log "Failed to find child" (levelToString (i :: level))
639 in
640 ( i + 1
641 , gathered
642 )
644 Just found ->
645 ( i + 1
646 , found :: gathered
647 )
649 childrenFoundData =
650 List.foldl findBBox ( 0, [] ) children
651 |> Tuple.second
653 attributeTests =
654 attributes
655 |> List.indexedMap
656 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
657 (\i attr ->
658 createAttributeTest self
659 cache
660 level
661 i
662 { siblings = siblings
663 , parent = parent
664 , self = self
665 , selfElement = element
666 , children = childrenFoundData
667 , parentLayout = location
668 , parentSpacing = parentSpacing
669 }
670 attr
671 )
672 |> List.concat
673 in
674 attributeTests
675 ++ testChildren self children
676 in
677 case Dict.get id cache of
678 Nothing ->
679 case element of
680 Empty ->
681 []
683 Text _ ->
684 []
686 _ ->
687 [ { elementDomId = id
688 , elementType = EmptyType
689 , label = "Finding element in DOM"
690 , expectations =
691 [ Expect
692 { description = "Locating element for rendering test"
693 , result = False
694 }
695 ]
696 }
697 ]
699 Just self ->
700 case element of
701 El attrs child ->
702 tests self attrs [ child ]
704 Row attrs children ->
705 tests self attrs children
707 Column attrs children ->
708 tests self attrs children
710 TextColumn attrs children ->
711 tests self attrs children
713 Paragraph attrs children ->
714 tests self attrs children
716 Empty ->
717 []
719 Text str ->
720 []
723createAttributeTest :
724 Found
725 -> Dict String Found
726 -> List Int
727 -> Int
728 -> Surroundings msg
729 -> Attr msg
730 -> List LayoutTest
731createAttributeTest parent cache level attrIndex surroundings attr =
732 let
733 domId =
734 "#" ++ levelToString level
735 in
736 case attr of
737 Attr _ ->
738 []
740 Spacing _ ->
741 []
743 AttrTest details ->
744 [ { elementDomId = domId
745 , elementType =
746 toElementType surroundings.selfElement
747 , label = details.label
748 , expectations = details.test surroundings
749 }
750 ]
752 Nearby nearby ->
753 createTest
754 { siblings = []
755 , parent = parent
756 , cache = cache
757 , parentSpacing = 0
758 , level = attrIndex :: -1 :: level
759 , location = IsNearby nearby.location
760 , element =
761 addAttribute
762 (AttrTest
763 { label = nearby.label
764 , test =
765 nearby.test
766 , id = NoId
767 }
768 )
769 nearby.element
770 }
772 Batch batch ->
773 batch
774 |> List.indexedMap (\i attribute -> createAttributeTest parent cache level i surroundings attribute)
775 |> List.concat
777 LabeledTest { label, test } ->
778 [ { elementDomId = domId
779 , elementType = toElementType surroundings.selfElement
780 , label = label
781 , expectations = test surroundings
782 }
783 ]
786addAttribute : Attr msg -> Element msg -> Element msg
787addAttribute attr el =
788 case el of
789 El attrs child ->
790 El (attr :: attrs) child
792 Row attrs children ->
793 Row (attr :: attrs) children
795 Column attrs children ->
796 Column (attr :: attrs) children
798 TextColumn attrs children ->
799 TextColumn (attr :: attrs) children
801 Paragraph attrs children ->
802 Paragraph (attr :: attrs) children
804 Empty ->
805 Empty
807 Text str ->
808 Text str
811compareFormattedColor : Color -> String -> Bool
812compareFormattedColor color expected =
813 formatColor color == expected || formatColorWithAlpha color == expected
816formatColorWithAlpha : Color -> String
817formatColorWithAlpha (Internal.Rgba red green blue alpha) =
818 if alpha == 1 then
819 ("rgba(" ++ String.fromInt (round (red * 255)))
820 ++ (", " ++ String.fromInt (round (green * 255)))
821 ++ (", " ++ String.fromInt (round (blue * 255)))
822 ++ ", 1"
823 ++ ")"
825 else
826 ("rgba(" ++ String.fromInt (round (red * 255)))
827 ++ (", " ++ String.fromInt (round (green * 255)))
828 ++ (", " ++ String.fromInt (round (blue * 255)))
829 ++ (", " ++ String.fromFloat alpha ++ ")")
832formatColor : Color -> String
833formatColor (Internal.Rgba red green blue alpha) =
834 if alpha == 1 then
835 ("rgb(" ++ String.fromInt (round (red * 255)))
836 ++ (", " ++ String.fromInt (round (green * 255)))
837 ++ (", " ++ String.fromInt (round (blue * 255)))
838 ++ ")"
840 else
841 ("rgb(" ++ String.fromInt (round (red * 255)))
842 ++ (", " ++ String.fromInt (round (green * 255)))
843 ++ (", " ++ String.fromInt (round (blue * 255)))
844 ++ ")"
847getSpacingFromAttributes attrs =
848 case attrs of
849 [] ->
850 0
852 (Spacing i) :: remain ->
853 i
855 (Batch batched) :: remain ->
856 getSpacingFromAttributes (batched ++ remain)
858 _ :: remain ->
859 getSpacingFromAttributes remain
862getSpacing : Element msg -> Maybe Int
863getSpacing el =
864 let
865 getSpacingAttr attr found =
866 if found /= Nothing then
867 found
869 else
870 case attr of
871 Spacing i ->
872 Just i
874 Batch attrs ->
875 List.foldr getSpacingAttr Nothing attrs
877 _ ->
878 Nothing
880 filterAttrs attrs =
881 List.foldr getSpacingAttr Nothing attrs
882 in
883 case el of
884 El attrs _ ->
885 filterAttrs attrs
887 Row attrs _ ->
888 filterAttrs attrs
890 Column attrs _ ->
891 filterAttrs attrs
893 TextColumn attrs _ ->
894 filterAttrs attrs
896 Paragraph attrs _ ->
897 filterAttrs attrs
899 Empty ->
900 Nothing
902 Text _ ->
903 Nothing