tests-rendering/src/Testable/FuzzMain.elm.old · typeable/elm-ui

git.iko.soy/typeable/elm-ui

typeable/elm-ui/tests-rendering/src/Testable/FuzzMain.elm.old

632 lines 17 kB history raw

1port 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)

3{-| -}

5import AnimationFrame

6import Color

7import Dict exposing (Dict)

8import Element

9import Element.Background as Background

10import Element.Border as Border

11import Element.Font as Font

12import Expect

13import Fuzz

14import Html exposing (Html)

15import List.Extra

16import Random

17import Test

18import Test.Runner

19import Test.Runner.Failure

20import Testable

21import Tests exposing (Testable)

22import Time exposing (Time)

25init : ( Model Msg, Cmd Msg )

26init =

27 ( { current = Nothing

28 , upcoming =

29 -- Tests.tests

30 []

32 -- generateTests (Random.initialSeed 227852860) 1

33 , finished = []

34 , stage = BeginRendering

35 }

36 , Cmd.none

37 )

40main : Program Never (Model Msg) Msg

41main =

42 Html.program

43 { init = init

44 , view = view

45 , update = update

46 , subscriptions = subscriptions

47 }

50type alias Model msg =

51 { current : Maybe (Testable msg)

52 , upcoming : List (Testable msg)

53 , finished : List (Testable msg)

54 , stage : Stage

55 }

58type Msg

59 = NoOp

60 | Tick Time

61 | RefreshBoundingBox

62 (List

63 { id : String

64 , bbox : Testable.BoundingBox

65 , style : Testable.Style

66 }

67 )

70type Stage

71 = Rendered

72 | BeginRendering

73 | GatherData

74 | Finished

77runTest : Dict String Testable.Found -> Testable msg -> Testable msg

78runTest boxes test =

79 let

80 tests =

81 Testable.toTest test.label boxes test.element

83 seed =

84 Random.initialSeed 227852860

86 results =

87 Testable.runTests seed (Debug.log "created Tests" tests)

88 |> Debug.log "run tests"

89 in

90 { test | results = Just results }

93generateTests : Random.Seed -> Int -> List (Testable msg)

94generateTests seed num =

95 if num <= 0 then

96 []

98 else

99 let

100 ( testable, newSeed ) =

101 generateTest seed

102 in

103 testable :: generateTests newSeed (num - 1)

104

105

106generateTest : Random.Seed -> ( Testable msg, Random.Seed )

107generateTest seed =

108 testableLayout

109 |> Test.Runner.fuzz

110 |> flip Random.step seed

111 |> (\( ( val, shrinker ), newSeed ) -> ( val, seed ))

112

113

114update : Msg -> Model Msg -> ( Model Msg, Cmd Msg )

115update 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

194subscriptions : { a | stage : Stage } -> Sub Msg

195subscriptions 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

210port analyze : List String -> Cmd msg

211

212

213port styles : (List { id : String, bbox : Testable.BoundingBox, style : Testable.Style } -> msg) -> Sub msg

214

215

216view : Model Msg -> Html Msg

217view 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

238viewResult : Testable Msg -> Element.Element Msg

239viewResult 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{--}

289type 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

306attr 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

317widthFill 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

330heightFill 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

343heightPx 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

352widthPx 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

361type alias PossibleAttributes msg =

362 { width : String -> Testable.Attr msg

363 , height : String -> Testable.Attr msg

364 }

365

366

367possibleToList str { width, height } =

368 width str :: height str :: []

369

370

371availableAttributes : { width : Float, height : Float } -> Fuzz.Fuzzer (PossibleAttributes msg)

372availableAttributes 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

382widths : Float -> List (String -> Testable.Attr msg)

383widths 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

416heights : Float -> List (String -> Testable.Attr msg)

417heights 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

448content : Testable.Element msg

449content =

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

457tests : List (Testable msg)

458tests =

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

526type TestableElement

527 = El

528 | Row

529 | Column

530

531

532allIndividualTestables : List (Fuzz.Fuzzer TestableElement)

533allIndividualTestables =

534 [ Fuzz.constant El

535 , Fuzz.constant Row

536 , Fuzz.constant Column

537 ]

538

539

540testableLayout : Fuzz.Fuzzer (Testable msg)

541testableLayout =

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

552layout : Fuzz.Fuzzer (Testable.Element msg)

553layout =

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

566createElement : String -> TestableElement -> PossibleAttributes msg -> Testable.Element msg

567createElement 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

591createContainer : ( PossibleAttributes msg, PossibleAttributes msg, PossibleAttributes msg ) -> PossibleAttributes msg -> TestableElement -> TestableElement -> Testable.Element msg

592createContainer ( 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