git.iko.soy/typeable/elm-ui
on dfef577 help sign in
typeable/elm-ui/tests-rendering/src/Testable.elm
760 lines 20 kB history raw
1module Testable exposing
2 ( Attr(..)
3 , BoundingBox
4 , Element(..)
5 , Found
6 , LayoutContext(..)
7 , Location(..)
8 , Style
9 , Surroundings
10 , addAttribute
11 , applyLabels
12 , compareFormattedColor
13 , createAttributeTest
14 , createTest
15 , formatColor
16 , formatColorWithAlpha
17 , getElementId
18 , getIds
19 , getSpacing
20 , idAttr
21 , levelToString
22 , render
23 , renderAttribute
24 , renderElement
25 , runTests
26 , toTest
27 )
29{-| -}
31import Dict exposing (Dict)
32import Element exposing (Color)
33import Expect
34import Html exposing (Html)
35import Html.Attributes
36import Internal.Model as Internal
37import Random
38import Test exposing (Test)
39import Test.Runner
40import Test.Runner.Failure
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 Attr msg
54 = Attr (Element.Attribute msg)
55 | AttrTest (Surroundings -> Test)
56 | Batch (List (Attr msg))
57 | Spacing Int
58 | Nearby
59 { location : Location
60 , element : Element msg
61 , test : Surroundings -> () -> Expect.Expectation
62 , label : String
63 }
64 | Label String
65 | LabeledTest
66 { test : Surroundings -> () -> Expect.Expectation
67 , label : String
68 , attr : Element.Attribute msg
69 }
72type Location
73 = Above
74 | Below
75 | OnRight
76 | OnLeft
77 | InFront
78 | Behind
81type LayoutContext
82 = IsNearby Location
83 | InRow
84 | InEl
85 | InColumn
88type alias Surroundings =
89 { siblings : List Found
90 , parent : Found
91 , children : List Found
92 , self : Found
94 -- These values are needed to perform some types of tests.
95 , location : LayoutContext
96 , parentSpacing : Int
97 }
100type alias Found =
101 { bbox : BoundingBox
102 , style : Style
103 , isVisible : Bool
104 }
107{-| -}
108type alias Style =
109 Dict String String
112type alias BoundingBox =
113 { width : Float
114 , height : Float
115 , left : Float
116 , top : Float
117 , right : Float
118 , bottom : Float
119 , padding :
120 { left : Float
121 , right : Float
122 , top : Float
123 , bottom : Float
124 }
125 }
129{- Retrieve Ids -}
132getIds : Element msg -> List String
133getIds el =
134 "se-0" :: getElementId [ 0, 0 ] el
137getElementId : List Int -> Element msg -> List String
138getElementId level el =
139 let
140 id =
141 levelToString level
143 attrID attrIndex attr =
144 case attr of
145 Nearby nearby ->
146 getElementId (attrIndex :: -1 :: level) nearby.element
148 _ ->
149 []
151 attributeIDs attrs =
152 attrs
153 |> List.indexedMap attrID
154 |> List.concat
156 childrenIDs children =
157 List.concat <| List.indexedMap (\i -> getElementId (i :: level)) children
158 in
159 case el of
160 El attrs child ->
161 id :: getElementId (0 :: level) child ++ attributeIDs attrs
163 Row attrs children ->
164 id :: childrenIDs children ++ attributeIDs attrs
166 Column attrs children ->
167 id :: childrenIDs children ++ attributeIDs attrs
169 TextColumn attrs children ->
170 id :: childrenIDs children ++ attributeIDs attrs
172 Paragraph attrs children ->
173 id :: childrenIDs children ++ attributeIDs attrs
175 Empty ->
176 []
178 Text _ ->
179 []
183{- Render as Html -}
186render : Element msg -> Html msg
187render el =
188 Element.layout [ idAttr "0" ] <|
189 renderElement [ 0, 0 ] el
192idAttr : String -> Element.Attribute msg
193idAttr id =
194 Element.htmlAttribute (Html.Attributes.id ("se-" ++ id))
197renderElement : List Int -> Element msg -> Element.Element msg
198renderElement level el =
199 let
200 id =
201 level
202 |> List.map String.fromInt
203 |> String.join "-"
204 |> idAttr
206 makeAttributes attrs =
207 attrs
208 |> List.indexedMap (renderAttribute level)
209 |> List.concat
210 in
211 case el of
212 El attrs child ->
213 Element.el
214 (id :: makeAttributes attrs)
215 (renderElement (0 :: level) child)
217 Row attrs children ->
218 Element.row
219 (id :: makeAttributes attrs)
220 (List.indexedMap (\i -> renderElement (i :: level)) children)
222 Column attrs children ->
223 Element.column
224 (id :: makeAttributes attrs)
225 (List.indexedMap (\i -> renderElement (i :: level)) children)
227 TextColumn attrs children ->
228 Element.textColumn
229 (id :: makeAttributes attrs)
230 (List.indexedMap (\i -> renderElement (i :: level)) children)
232 Paragraph attrs children ->
233 Element.paragraph
234 (id :: makeAttributes attrs)
235 (List.indexedMap (\i -> renderElement (i :: level)) children)
237 Empty ->
238 Element.none
240 Text str ->
241 Element.text str
244renderAttribute : List Int -> Int -> Attr msg -> List (Element.Attribute msg)
245renderAttribute level attrIndex attr =
246 case attr of
247 Attr attribute ->
248 [ attribute ]
250 AttrTest _ ->
251 []
253 Spacing _ ->
254 []
256 Label _ ->
257 []
259 Nearby { location, element } ->
260 case location of
261 Above ->
262 [ Element.above (renderElement (attrIndex :: -1 :: level) element) ]
264 Below ->
265 [ Element.below (renderElement (attrIndex :: -1 :: level) element) ]
267 OnRight ->
268 [ Element.onRight (renderElement (attrIndex :: -1 :: level) element) ]
270 OnLeft ->
271 [ Element.onLeft (renderElement (attrIndex :: -1 :: level) element) ]
273 InFront ->
274 [ Element.inFront (renderElement (attrIndex :: -1 :: level) element) ]
276 Behind ->
277 [ Element.behindContent (renderElement (attrIndex :: -1 :: level) element) ]
279 Batch batch ->
280 List.indexedMap (renderAttribute (attrIndex :: level)) batch
281 |> List.concat
283 LabeledTest tested ->
284 [ tested.attr ]
288{- Convert to Test -}
291toTest : String -> Dict String Found -> Element msg -> Test
292toTest label harvested el =
293 let
294 maybeFound =
295 Dict.get "se-0" harvested
296 in
297 case maybeFound of
298 Nothing ->
299 Test.describe label
300 [ Test.test "Find Root" <|
301 \_ -> Expect.fail "unable to find root"
302 ]
304 Just root ->
305 Test.describe label <|
306 createTest
307 { siblings = []
308 , parent = root
309 , cache = harvested
310 , parentSpacing = 0
311 , level = [ 0, 0 ]
312 , element = el
313 , location = InEl
314 }
317levelToString : List Int -> String
318levelToString level =
319 level
320 |> List.map String.fromInt
321 |> String.join "-"
322 |> (\x -> "se-" ++ x)
325createTest :
326 { siblings : List Found
327 , parent : Found
328 , cache : Dict String Found
329 , level : List Int
330 , element : Element msg
331 , location : LayoutContext
332 , parentSpacing : Int
333 }
334 -> List Test
335createTest { siblings, parent, cache, level, element, location, parentSpacing } =
336 let
337 spacing =
338 getSpacing element
339 |> Maybe.withDefault 0
341 id =
342 levelToString level
344 testChildren : Found -> List (Element msg) -> List Test
345 testChildren found children =
346 let
347 childrenFound =
348 -- Should check that this lookup doesn't fail.
349 -- Thoug if it does, it'll fail when the element itself is tested
350 List.filterMap
351 (\x ->
352 Dict.get (levelToString (x :: level)) cache
353 )
354 (List.range 0 (List.length children))
355 in
356 List.foldl (applyChildTest found)
357 { index = 0
358 , upcoming = childrenFound
359 , previous = []
360 , tests = []
361 }
362 children
363 |> .tests
365 applyChildTest :
366 Found
367 -> Element msg
368 ->
369 { a
370 | index : Int
371 , previous : List Found
372 , tests : List Test
373 , upcoming : List Found
374 }
375 ->
376 { index : Int
377 , previous : List Found
378 , tests : List Test
379 , upcoming : List Found
380 }
381 applyChildTest found child childTest =
382 -- { index, upcoming, previous, tests }
383 let
384 surroundingChildren =
385 case childTest.upcoming of
386 [] ->
387 childTest.previous
389 x :: remaining ->
390 remaining ++ childTest.previous
392 childrenTests =
393 createTest
394 { siblings = surroundingChildren
395 , parent = found
396 , cache = cache
397 , level = childTest.index :: level
398 , element = child
399 , parentSpacing = spacing
400 , location =
401 case element of
402 El _ _ ->
403 InEl
405 Row _ _ ->
406 InRow
408 Column _ _ ->
409 InColumn
411 TextColumn _ _ ->
412 InColumn
414 Paragraph _ _ ->
415 InRow
417 Text _ ->
418 InEl
420 Empty ->
421 InEl
422 }
423 in
424 { index = childTest.index + 1
425 , tests = childTest.tests ++ childrenTests
426 , previous =
427 case childTest.upcoming of
428 [] ->
429 childTest.previous
431 x :: _ ->
432 x :: childTest.previous
433 , upcoming =
434 case childTest.upcoming of
435 [] ->
436 []
438 _ :: rest ->
439 rest
440 }
442 tests : Found -> List (Attr msg) -> List (Element msg) -> List Test
443 tests self attributes children =
444 let
445 findBBox elem ( i, gathered ) =
446 case elem of
447 Empty ->
448 ( i + 1
449 , gathered
450 )
452 Text _ ->
453 ( i + 1
454 , gathered
455 )
457 _ ->
458 case Dict.get (levelToString (i :: level)) cache of
459 Nothing ->
460 let
461 _ =
462 Debug.log "el failed to find" elem
464 _ =
465 Debug.log "Failed to find child" (levelToString (i :: level))
466 in
467 ( i + 1
468 , gathered
469 )
471 Just found ->
472 ( i + 1
473 , found :: gathered
474 )
476 childrenFoundData =
477 List.foldl findBBox ( 0, [] ) children
478 |> Tuple.second
480 attributeTests =
481 attributes
482 |> applyLabels
483 |> List.indexedMap
484 -- Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
485 (\i attr ->
486 createAttributeTest self
487 cache
488 level
489 i
490 { siblings = siblings
491 , parent = parent
492 , self = self
493 , children = childrenFoundData
494 , location = location
495 , parentSpacing = parentSpacing
496 }
497 attr
498 )
499 |> List.concat
500 in
501 attributeTests
502 ++ testChildren self children
503 in
504 case Dict.get id cache of
505 Nothing ->
506 case element of
507 Empty ->
508 []
510 Text _ ->
511 []
513 _ ->
514 [ Test.test ("Unable to find " ++ id) (always <| Expect.fail "failed id lookup") ]
516 Just self ->
517 case element of
518 El attrs child ->
519 tests self attrs [ child ]
521 Row attrs children ->
522 tests self attrs children
524 Column attrs children ->
525 tests self attrs children
527 TextColumn attrs children ->
528 tests self attrs children
530 Paragraph attrs children ->
531 tests self attrs children
533 Empty ->
534 []
536 Text str ->
537 []
540applyLabels : List (Attr msg) -> List (Attr msg)
541applyLabels attrs =
542 let
543 toLabel attr =
544 case attr of
545 Label label ->
546 Just label
548 _ ->
549 Nothing
551 newLabels =
552 attrs
553 |> List.filterMap toLabel
554 |> String.join ", "
556 applyLabel newLabel attr =
557 case attr of
558 LabeledTest labeled ->
559 LabeledTest
560 { labeled
561 | label =
562 if newLabel == "" then
563 labeled.label
565 else
566 newLabel ++ ", " ++ labeled.label
567 }
569 x ->
570 x
571 in
572 List.map (applyLabel newLabels) attrs
575createAttributeTest : Found -> Dict String Found -> List Int -> Int -> Surroundings -> Attr msg -> List Test
576createAttributeTest parent cache level attrIndex surroundings attr =
577 let
578 indexLabel =
579 levelToString (attrIndex :: level)
580 in
581 case attr of
582 Attr _ ->
583 []
585 Label _ ->
586 []
588 Spacing _ ->
589 []
591 AttrTest test ->
592 [ test surroundings
593 ]
595 Nearby nearby ->
596 createTest
597 { siblings = []
598 , parent = parent
599 , cache = cache
600 , parentSpacing = 0
601 , level = attrIndex :: -1 :: level
602 , location = IsNearby nearby.location
603 , element = addAttribute (AttrTest (\context -> Test.test (nearby.label ++ " #" ++ indexLabel) (nearby.test context))) nearby.element
604 }
606 Batch batch ->
607 batch
608 |> List.indexedMap (\i attribute -> createAttributeTest parent cache (attrIndex :: level) i surroundings attribute)
609 |> List.concat
611 LabeledTest { label, test } ->
612 [ Test.test (label ++ " #" ++ indexLabel) (test surroundings)
613 ]
616addAttribute : Attr msg -> Element msg -> Element msg
617addAttribute attr el =
618 case el of
619 El attrs child ->
620 El (attr :: attrs) child
622 Row attrs children ->
623 Row (attr :: attrs) children
625 Column attrs children ->
626 Column (attr :: attrs) children
628 TextColumn attrs children ->
629 TextColumn (attr :: attrs) children
631 Paragraph attrs children ->
632 Paragraph (attr :: attrs) children
634 Empty ->
635 Empty
637 Text str ->
638 Text str
641runTests :
642 Random.Seed
643 -> Test
644 ->
645 List
646 ( String
647 , Maybe
648 { given : Maybe String
649 , description : String
650 , reason : Test.Runner.Failure.Reason
651 }
652 )
653runTests seed tests =
654 let
655 run runner =
656 let
657 ran =
658 List.map Test.Runner.getFailureReason (runner.run ())
659 in
660 List.map2 Tuple.pair runner.labels ran
662 results =
663 case Test.Runner.fromTest 100 seed tests of
664 Test.Runner.Plain rnrs ->
665 List.map run rnrs
667 Test.Runner.Only rnrs ->
668 List.map run rnrs
670 Test.Runner.Skipping rnrs ->
671 List.map run rnrs
673 Test.Runner.Invalid invalid ->
674 let
675 _ =
676 Debug.log "Invalid tests" invalid
677 in
678 []
679 in
680 List.concat results
683compareFormattedColor : Color -> String -> Bool
684compareFormattedColor color expected =
685 formatColor color == expected || formatColorWithAlpha color == expected
688formatColorWithAlpha : Color -> String
689formatColorWithAlpha (Internal.Rgba red green blue alpha) =
690 if alpha == 1 then
691 ("rgba(" ++ String.fromInt (round (red * 255)))
692 ++ (", " ++ String.fromInt (round (green * 255)))
693 ++ (", " ++ String.fromInt (round (blue * 255)))
694 ++ ", 1"
695 ++ ")"
697 else
698 ("rgba(" ++ String.fromInt (round (red * 255)))
699 ++ (", " ++ String.fromInt (round (green * 255)))
700 ++ (", " ++ String.fromInt (round (blue * 255)))
701 ++ (", " ++ String.fromFloat alpha ++ ")")
704formatColor : Color -> String
705formatColor (Internal.Rgba red green blue alpha) =
706 if alpha == 1 then
707 ("rgb(" ++ String.fromInt (round (red * 255)))
708 ++ (", " ++ String.fromInt (round (green * 255)))
709 ++ (", " ++ String.fromInt (round (blue * 255)))
710 ++ ")"
712 else
713 ("rgb(" ++ String.fromInt (round (red * 255)))
714 ++ (", " ++ String.fromInt (round (green * 255)))
715 ++ (", " ++ String.fromInt (round (blue * 255)))
716 ++ ")"
719getSpacing : Element msg -> Maybe Int
720getSpacing el =
721 let
722 getSpacingAttr attr found =
723 if found /= Nothing then
724 found
726 else
727 case attr of
728 Spacing i ->
729 Just i
731 Batch attrs ->
732 List.foldr getSpacingAttr Nothing attrs
734 _ ->
735 Nothing
737 filterAttrs attrs =
738 List.foldr getSpacingAttr Nothing attrs
739 in
740 case el of
741 El attrs _ ->
742 filterAttrs attrs
744 Row attrs _ ->
745 filterAttrs attrs
747 Column attrs _ ->
748 filterAttrs attrs
750 TextColumn attrs _ ->
751 filterAttrs attrs
753 Paragraph attrs _ ->
754 filterAttrs attrs
756 Empty ->
757 Nothing
759 Text _ ->
760 Nothing