@@ -1,632 +0,0 @@
1−port module FuzzMain exposing (Model, Msg(..), PossibleAttributes, Stage(..), Testable, TestableElement(..), allIndividualTestables, allPossibilities, analyze, attr, availableAttributes, content, createContainer, createElement, generateTest, generateTests, heightFill, heightPx, heights, init, layout, main, possibleToList, runTest, styles, subscriptions, testableLayout, tests, update, view, viewResult, widthFill, widthPx, widths)
2−
3−{-| -}
4−
5−import AnimationFrame
6−import Color
7−import Dict exposing (Dict)
8−import Element
9−import Element.Background as Background
10−import Element.Border as Border
11−import Element.Font as Font
12−import Expect
13−import Fuzz
14−import Html exposing (Html)
15−import List.Extra
16−import Random
17−import Test
18−import Test.Runner
19−import Test.Runner.Failure
20−import Testable
21−import Tests exposing (Testable)
22−import Time exposing (Time)
23−
24−
25−init : ( Model Msg, Cmd Msg )
26−init =
27− ( { current = Nothing
28− , upcoming =
29− -- Tests.tests
30− []
31−
32− -- generateTests (Random.initialSeed 227852860) 1
33− , finished = []
34− , stage = BeginRendering
35− }
36− , Cmd.none
37− )
38−
39−
40−main : Program Never (Model Msg) Msg
41−main =
42− Html.program
43− { init = init
44− , view = view
45− , update = update
46− , subscriptions = subscriptions
47− }
48−
49−
50−type alias Model msg =
51− { current : Maybe (Testable msg)
52− , upcoming : List (Testable msg)
53− , finished : List (Testable msg)
54− , stage : Stage
55− }
56−
57−
58−type Msg
59− = NoOp
60− | Tick Time
61− | RefreshBoundingBox
62− (List
63− { id : String
64− , bbox : Testable.BoundingBox
65− , style : Testable.Style
66− }
67− )
68−
69−
70−type Stage
71− = Rendered
72− | BeginRendering
73− | GatherData
74− | Finished
75−
76−
77−runTest : Dict String Testable.Found -> Testable msg -> Testable msg
78−runTest boxes test =
79− let
80− tests =
81− Testable.toTest test.label boxes test.element
82−
83− seed =
84− Random.initialSeed 227852860
85−
86− results =
87− Testable.runTests seed (Debug.log "created Tests" tests)
88− |> Debug.log "run tests"
89− in
90− { test | results = Just results }
91−
92−
93−generateTests : Random.Seed -> Int -> List (Testable msg)
94−generateTests seed num =
95− if num <= 0 then
96− []
97−
98− else
99− let
100− ( testable, newSeed ) =
101− generateTest seed
102− in
103− testable :: generateTests newSeed (num - 1)
104−
105−
106−generateTest : Random.Seed -> ( Testable msg, Random.Seed )
107−generateTest seed =
108− testableLayout
109− |> Test.Runner.fuzz
110− |> flip Random.step seed
111− |> (\( ( val, shrinker ), newSeed ) -> ( val, seed ))
112−
113−
114−update : Msg -> Model Msg -> ( Model Msg, Cmd Msg )
115−update msg model =
116− case msg of
117− NoOp ->
118− ( model, Cmd.none )
119−
120− RefreshBoundingBox boxes ->
121− case model.current of
122− Nothing ->
123− ( { model | stage = Finished }
124− , Cmd.none
125− )
126−
127− Just current ->
128− let
129− toTuple box =
130− ( box.id, { style = box.style, bbox = box.bbox } )
131−
132− foundData =
133− boxes
134− |> List.map toTuple
135− |> Dict.fromList
136−
137− currentResults =
138− runTest foundData current
139− in
140− case model.upcoming of
141− [] ->
142− ( { model
143− | stage = Finished
144− , current = Nothing
145− , finished = currentResults :: model.finished
146− }
147− , Cmd.none
148− )
149−
150− newCurrent :: remaining ->
151− ( { model
152− | finished = currentResults :: model.finished
153− , stage = BeginRendering
154− }
155− , Cmd.none
156− )
157−
158− Tick time ->
159− case model.stage of
160− BeginRendering ->
161− case model.upcoming of
162− [] ->
163− ( { model | stage = Rendered }
164− , Cmd.none
165− )
166−
167− current :: remaining ->
168− ( { model
169− | stage = Rendered
170− , upcoming = remaining
171− , current = Just current
172− }
173− , Cmd.none
174− )
175−
176− Rendered ->
177− case model.current of
178− Nothing ->
179− ( { model | stage = Finished }
180− , Cmd.none
181− )
182−
183− Just test ->
184− ( { model | stage = GatherData }
185− , analyze (Testable.getIds test.element)
186− )
187−
188− _ ->
189− ( { model | stage = Rendered }
190− , Cmd.none
191− )
192−
193−
194−subscriptions : { a | stage : Stage } -> Sub Msg
195−subscriptions model =
196− Sub.batch
197− [ styles RefreshBoundingBox
198− , case model.stage of
199− BeginRendering ->
200− AnimationFrame.times Tick
201−
202− Rendered ->
203− AnimationFrame.times Tick
204−
205− _ ->
206− Sub.none
207− ]
208−
209−
210−port analyze : List String -> Cmd msg
211−
212−
213−port styles : (List { id : String, bbox : Testable.BoundingBox, style : Testable.Style } -> msg) -> Sub msg
214−
215−
216−view : Model Msg -> Html Msg
217−view model =
218− case model.current of
219− Nothing ->
220− if model.stage == Finished then
221− Element.layout [] <|
222− Element.column
223− [ Element.spacing 20
224− , Element.padding 20
225− , Element.width (Element.px 800)
226−
227− -- , Background.color Color.grey
228− ]
229− (List.map viewResult model.finished)
230−
231− else
232− Html.text "running?"
233−
234− Just current ->
235− Testable.render current.element
236−
237−
238−viewResult : Testable Msg -> Element.Element Msg
239−viewResult testable =
240− let
241− viewSingle result =
242− case result of
243− ( label, Nothing ) ->
244− Element.el
245− [ Background.color Color.green
246− , Font.color Color.white
247− , Element.paddingXY 20 10
248− , Element.alignLeft
249− , Border.rounded 3
250− ]
251− <|
252− Element.text (label ++ " - " ++ "Success!")
253−
254− ( label, Just { given, description, reason } ) ->
255− Element.row
256− [ Background.color Color.red
257− , Font.color Color.white
258− , Element.paddingXY 20 10
259− , Element.alignLeft
260− , Element.spacing 25
261− , Border.rounded 3
262− ]
263− [ Element.el [ Element.width Element.fill ] <| Element.text label
264−
265− -- , Element.el [ Element.width Element.fill ] <| Element.text description
266− , Element.el [ Element.width Element.fill ] <| Element.text (toString reason)
267− ]
268− in
269− Element.column
270− [ Border.width 1
271− , Border.color Color.lightGrey
272− , Element.padding 20
273− , Element.height Element.shrink
274− , Element.alignLeft
275− ]
276− [ Element.el [ Font.bold ] (Element.text testable.label)
277− , Element.column [ Element.alignLeft, Element.spacing 20 ]
278− (case testable.results of
279− Nothing ->
280− [ Element.text "no results" ]
281−
282− Just results ->
283− List.map viewSingle results
284− )
285− ]
286−
287−
288−{--}
289−type alias Testable msg =
290− { element : Testable.Element msg
291− , label : String
292− , results :
293− Maybe
294− (List
295− ( String
296− , Maybe
297− { given : Maybe String
298− , description : String
299− , reason : Test.Runner.Failure.Reason
300− }
301− )
302− )
303− }
304−
305−
306−attr tag label attr test =
307− Testable.Batch
308− [ Testable.Attr attr
309− , Testable.AttrTest
310− (\found ->
311− Test.test (tag ++ ": " ++ label) <|
312− \_ -> test found
313− )
314− ]
315−
316−
317−widthFill tag =
318− attr tag
319− "width fill"
320− (Element.width Element.fill)
321− (\context ->
322− let
323− spacePerPortion =
324− context.parent.bbox.width / toFloat (List.length context.siblings + 1)
325− in
326− Expect.equal spacePerPortion context.self.bbox.width
327− )
328−
329−
330−heightFill tag =
331− attr tag
332− "height fill"
333− (Element.height Element.fill)
334− (\context ->
335− let
336− spacePerPortion =
337− context.parent.bbox.height / toFloat (List.length context.siblings + 1)
338− in
339− Expect.equal spacePerPortion context.self.bbox.height
340− )
341−
342−
343−heightPx px tag =
344− attr tag
345− ("height at " ++ toString px ++ "px")
346− (Element.height (Element.px (round px)))
347− (\found ->
348− Expect.equal found.self.bbox.height px
349− )
350−
351−
352−widthPx px tag =
353− attr tag
354− ("width at " ++ toString px ++ "px")
355− (Element.width (Element.px (round px)))
356− (\found ->
357− Expect.equal found.self.bbox.width px
358− )
359−
360−
361−type alias PossibleAttributes msg =
362− { width : String -> Testable.Attr msg
363− , height : String -> Testable.Attr msg
364− }
365−
366−
367−possibleToList str { width, height } =
368− width str :: height str :: []
369−
370−
371−availableAttributes : { width : Float, height : Float } -> Fuzz.Fuzzer (PossibleAttributes msg)
372−availableAttributes bounds =
373− Fuzz.map2 PossibleAttributes
374− (Fuzz.oneOf
375− (List.map Fuzz.constant (widths bounds.width))
376− )
377− (Fuzz.oneOf
378− (List.map Fuzz.constant (heights bounds.height))
379− )
380−
381−
382−widths : Float -> List (String -> Testable.Attr msg)
383−widths width =
384− [ \tag ->
385− attr tag
386− (" with width at " ++ toString width ++ "px")
387− (Element.width (Element.px (round width)))
388− (\found ->
389− Expect.equal found.self.bbox.width width
390− )
391− , \tag ->
392− attr tag
393− " with width fill"
394− (Element.width Element.fill)
395− (\context ->
396− let
397− -- {-|
398− -- Calculation is
399− -- totalparentwidth - (paddingLeft ++ paddingRight)
400− -- minus widths of all the other children
401− -- -}
402− otherWidth =
403− -- Debug.log "width" <|
404− List.sum <|
405− -- Debug.log "widths" <|
406− List.map (\child -> child.bbox.width) context.siblings
407−
408− spacePerPortion =
409− context.parent.bbox.width - otherWidth
410− in
411− Expect.equal spacePerPortion context.self.bbox.width
412− )
413− ]
414−
415−
416−heights : Float -> List (String -> Testable.Attr msg)
417−heights height =
418− [ \tag ->
419− attr tag
420− (" with height at " ++ toString height ++ "px")
421− (Element.height (Element.px (round height)))
422− (\found ->
423− Expect.equal found.self.bbox.height height
424− )
425− , \tag ->
426− attr tag
427− " with height fill"
428− (Element.height Element.fill)
429− (\context ->
430− let
431− -- {-|
432− -- Calculation is
433− -- totalparentwidth - (paddingLeft ++ paddingRight)
434− -- minus widths of all the other children
435− -- -}
436− otherHeight =
437− List.sum <|
438− List.map (\child -> child.bbox.height) context.siblings
439−
440− spacePerPortion =
441− context.parent.bbox.height - otherHeight
442− in
443− Expect.equal spacePerPortion context.self.bbox.height
444− )
445− ]
446−
447−
448−content : Testable.Element msg
449−content =
450− Testable.El
451− [ Testable.Attr <| Element.width (Element.px 20)
452− , Testable.Attr <| Element.height (Element.px 20)
453− ]
454− Testable.Empty
455−
456−
457−tests : List (Testable msg)
458−tests =
459− [ { label = "Width/Height 200"
460− , results = Nothing
461− , element =
462− Testable.El
463− [ widthPx 200 "single element"
464− , heightPx 200 "single element"
465− ]
466− Testable.Empty
467− }
468− , { label = "Width Fill/Height Fill - 1"
469− , results = Nothing
470− , element =
471− Testable.El
472− [ widthFill "single element"
473− , heightFill "single element"
474− ]
475− <|
476− content
477− }
478− , { label = "Width Fill/Height Fill - 2"
479− , results = Nothing
480− , element =
481− Testable.El
482− [ widthFill "top element"
483− , heightFill "top element"
484− ]
485− <|
486− Testable.El
487− [ widthFill "embedded element"
488− , heightFill "embedded element"
489− ]
490− <|
491− content
492− }
493− , { label = "Row Width Fill/Height Fill"
494− , results = Nothing
495− , element =
496− Testable.Row
497− [ widthFill "on row"
498− , heightFill "on row"
499− ]
500− [ Testable.El
501− [ widthFill "row - 1"
502− , heightFill "row - 1"
503− ]
504− content
505− , Testable.El
506− [ widthFill "row - 2"
507− , heightFill "row - 2"
508− ]
509− content
510− , Testable.El
511− [ widthFill "row - 3"
512− , heightFill "row - 3"
513− ]
514− content
515− ]
516− }
517− ]
518−
519−
520−
521−{- Generating A Complete Test Suite
522−
523−-}
524−
525−
526−type TestableElement
527− = El
528− | Row
529− | Column
530−
531−
532−allIndividualTestables : List (Fuzz.Fuzzer TestableElement)
533−allIndividualTestables =
534− [ Fuzz.constant El
535− , Fuzz.constant Row
536− , Fuzz.constant Column
537− ]
538−
539−
540−testableLayout : Fuzz.Fuzzer (Testable msg)
541−testableLayout =
542− let
543− asTestable layout =
544− { element = layout
545− , label = "A Sweet Test"
546− , results = Nothing
547− }
548− in
549− Fuzz.map asTestable layout
550−
551−
552−layout : Fuzz.Fuzzer (Testable.Element msg)
553−layout =
554− Fuzz.map4 createContainer
555− (Fuzz.tuple3
556− ( availableAttributes { width = 20, height = 20 }
557− , availableAttributes { width = 20, height = 20 }
558− , availableAttributes { width = 20, height = 20 }
559− )
560− )
561− (availableAttributes { width = 200, height = 200 })
562− (Fuzz.oneOf allIndividualTestables)
563− (Fuzz.oneOf allIndividualTestables)
564−
565−
566−createElement : String -> TestableElement -> PossibleAttributes msg -> Testable.Element msg
567−createElement tag layout possibleAttrs =
568− let
569− attrs =
570− possibleToList tag possibleAttrs
571− in
572− case layout of
573− El ->
574− Testable.El attrs content
575−
576− Row ->
577− Testable.Row attrs
578− [ content
579− , content
580− , content
581− ]
582−
583− Column ->
584− Testable.Column attrs
585− [ content
586− , content
587− , content
588− ]
589−
590−
591−createContainer : ( PossibleAttributes msg, PossibleAttributes msg, PossibleAttributes msg ) -> PossibleAttributes msg -> TestableElement -> TestableElement -> Testable.Element msg
592−createContainer ( a1, a2, a3 ) possibleAttrs parent child =
593− let
594− attrs =
595− possibleToList "0" possibleAttrs
596− in
597− case parent of
598− El ->
599− Testable.El attrs (createElement "0-0" child a1)
600−
601− Row ->
602− Testable.Row attrs
603− [ createElement "0-0" child a1
604− , createElement "0-1" child a2
605− , createElement "0-2" child a3
606− ]
607−
608− Column ->
609− Testable.Column attrs
610− [ createElement "0-0" child a1
611− , createElement "0-1" child a2
612− , createElement "0-2" child a3
613− ]
614−
615−
616−{-| Given a list of a list of possibilities,
617−
618−choose once from each list.
619−
620− [ [width (px 100), width fill]
621− , [height (px 100), height fill]
622− ]
623− ->
624−
625− [ [width (px 100), height (px 100)]
626− , [width (px 100), height fill]
627− ]
628−
629−-}
630−allPossibilities : List (List a) -> List (List a)
631−allPossibilities =
632− List.Extra.cartesianProduct