a1ea91f...master · typeable/compaREST

.github/actions/common_setup/action.yamlnew file+42

since splitsnapshots

unifiedsplit

@@ -0,0 +1,42 @@

1+name: "Common setup"

2+description: "Common setup steps"

3+inputs:

4+ authToken:

5+ description: "Cachix auth token"

6+ required: true

7+runs:

8+ using: "composite"

9+ steps:

10+ - name: Increase swap if linux

11+ shell: bash

12+ run: |

13+ if [ "$RUNNER_OS" == "Linux" ]; then

14+

15+ echo "Is Linux"

16+

17+ free -h

18+

19+ sudo swapoff /mnt/swapfile

20+ sudo fallocate -l 12G /mnt/swapfile

21+ sudo mkswap /mnt/swapfile

22+ sudo swapon /mnt/swapfile

23+

24+ free -h

25+

26+ else

27+

28+ echo "Not Linux"

29+

30+ fi

31+

32+ - name: Install Nix

33+ uses: cachix/install-nix-action@v27

34+ with:

35+ extra_nix_config: |

36+ system-features = kvm

37+ trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=

38+ substituters = https://hydra.iohk.io https://cache.nixos.org/

39+ - uses: cachix/cachix-action@v15

40+ with:

41+ name: typeable

42+ authToken: "${{ inputs.authToken }}"

.github/workflows/github-actions-image.yaml+261−27

@@ -5,52 +5,286 @@ on:

5 branches: [master]

6 pull_request:

7 branches: [master]

8+ release:

9+ types: [prereleased]

8

10

9jobs:

11jobs:

10− build-github-action-image:

12+# check-formatting:

13+# name: Check Haskell formatting

11− runs-on: ubuntu-latest

14+# runs-on: ubuntu-latest

15+# steps:

16+# - uses: actions/checkout@v2

17+#

18+# - name: Common setup

19+# uses: ./.github/actions/common_setup

20+# with:

21+# authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

22+#

23+# - name: Run fourmolu

24+# run: |

25+# nix-shell nix/ci.nix -j auto --run "git ls-files '*.hs' | xargs fourmolu -m inplace -o -XRecursiveDo -o -XTypeApplications -o -XPatternSynonyms -o -XBangPatterns"

26+# git diff --exit-code

12

27

28+ check_versions:

29+ runs-on: ubuntu-latest

13 steps:

30 steps:

14 - uses: actions/checkout@v2

31 - uses: actions/checkout@v2

15 with:

32 with:

16 submodules: recursive

33 submodules: recursive

17− - name: Increase swap

34+

35+ - name: Common setup

36+ uses: ./.github/actions/common_setup

37+ with:

38+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

39+

40+ - name: Check library version

41+ if: github.event_name == 'release'

18 run: |

42 run: |

19− free -h

43+ if [ "$(awk -F ':' '/^version/ {gsub(/ /, "", $2); print $2}' compaREST.cabal)" != "${{ github.event.release.tag_name }}" ]; then

44+ echo "::error file=compaREST.cabal::Library version does not match release version."

45+ exit 1

46+ fi

20

47

21− sudo swapoff /mnt/swapfile

48+ - name: Check docker tag

22− sudo fallocate -l 12G /mnt/swapfile

49+ if: github.event_name == 'release'

23− sudo mkswap /mnt/swapfile

50+ run: |

24− sudo swapon /mnt/swapfile

51+ if [ "$(yq eval '.runs.image' action.yaml | awk -F ':' '{print $NF}')" != "${{ github.event.release.tag_name }}" ]; then

52+ echo "::error file=action.yaml::Action docker tag does not match release tag."

53+ exit 1

54+ fi

25

55

26− free -h

56+ - name: Check changelog

57+ if: github.event_name == 'release'

58+ run: |

59+ if ! grep '^## ${{ github.event.release.tag_name }}$' CHANGELOG.md; then

60+ echo "::error file=CHANGELOG.md::CHANGELOG.md does not contain an entry for this release."

61+ exit 1

62+ fi

27

63

28− - name: Install Nix

64+ Linux:

29− uses: cachix/install-nix-action@v12

65+ needs: check_versions

66+ runs-on: ubuntu-latest

67+ steps:

68+ - uses: actions/checkout@v2

69+ with:

70+ submodules: recursive

71+

72+ - name: Common setup

73+ uses: ./.github/actions/common_setup

30 with:

74 with:

31− extra_nix_config: |

75+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

32− trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=

76+

33− substituters = https://hydra.iohk.io https://cache.nixos.org/

77+ - name: Test

78+ shell: bash

79+ run: |

80+ $(nix-build -A test -j auto --no-out-link)/bin/compaREST-tests

81+

82+ - name: Build Linux static binary

83+ shell: bash

84+ run: |

85+ cp $(nix-build -A compaRESTStaticBin -j auto --no-out-link)/bin/compaREST compaREST

34

86

35− - name: Login to Cachix

87+ - name: Upload compaREST Linux Binary

36− uses: cachix/cachix-action@v8

88+ uses: actions/upload-artifact@v2

37 with:

89 with:

38− name: octopod

90+ name: compaREST-Linux

39− signingKey: ${{ secrets.CACHIX_SIGNING_KEY }}

91+ path: compaREST

40

92

41− - name: Build Github Action Docker Image

93+ - name: Build Docker Images

94+ shell: bash

42 run: |

95 run: |

43− nix-build -A compaRESTGithubAction -j auto -o image

96+ cp $(nix-build -A compaRESTGithubAction -j auto --no-out-link) compaREST-Github-Action-image.tar.gz

97+ cp $(nix-build -A compaRESTImage -j auto --no-out-link) compaREST-image.tar.gz

44

98

45− - name: Log into Docker Hub

99+ - name: Upload compaREST Docker Github Action Image

46− if: github.ref == 'refs/heads/master'

100+ uses: actions/upload-artifact@v2

101+ with:

102+ name: compaREST Github Action Docker Image

103+ path: compaREST-Github-Action-image.tar.gz

104+

105+ - name: Upload compaREST Docker Image

106+ uses: actions/upload-artifact@v2

107+ with:

108+ name: compaREST Docker Image

109+ path: compaREST-image.tar.gz

110+

111+ - name: Login to DockerHub

47− uses: docker/login-action@v1

112+ uses: docker/login-action@v1.10.0

48 with:

113 with:

49 username: ${{ secrets.DOCKER_HUB_USERNAME }}

114 username: ${{ secrets.DOCKER_HUB_USERNAME }}

50 password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}

115 password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}

51

116

52− - name: Upload Image to Docker Hub

117+ - name: Push Nightly Docker Images to DockerHub

53− if: github.ref == 'refs/heads/master'

118+ if: github.ref == 'refs/heads/master' && github.event_name == 'push'

119+ shell: bash

120+ run: |

121+ skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://typeable/comparest-github-action:nightly

122+ skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://typeable/comparest:nightly

123+

124+ - name: Push Release Docker Images to DockerHub

125+ if: github.event_name == 'release'

126+ shell: bash

127+ run: |

128+ skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://typeable/comparest-github-action:${{ github.event.release.tag_name }}

129+ skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://typeable/comparest:${{ github.event.release.tag_name }}

130+

131+ - name: Zip Release Assets

132+ if: github.event_name == 'release'

133+ shell: bash

134+ run: |

135+ zip compaREST-Linux-x86.zip compaREST

136+

137+ - name: Upload compaREST Github Action Docker Image to release

138+ if: github.event_name == 'release'

139+ uses: svenstaro/upload-release-action@2.2.1

140+ with:

141+ repo_token: ${{ secrets.GITHUB_TOKEN }}

142+ file: compaREST-Github-Action-image.tar.gz

143+ tag: ${{ github.ref }}

144+

145+ - name: Upload compaREST Docker Image to release

146+ if: github.event_name == 'release'

147+ uses: svenstaro/upload-release-action@2.2.1

148+ with:

149+ repo_token: ${{ secrets.GITHUB_TOKEN }}

150+ file: compaREST-image.tar.gz

151+ tag: ${{ github.ref }}

152+

153+ - name: Upload compaREST binary – Linux – x86 to release

154+ if: github.event_name == 'release'

155+ uses: svenstaro/upload-release-action@2.2.1

156+ with:

157+ repo_token: ${{ secrets.GITHUB_TOKEN }}

158+ file: compaREST-Linux-x86.zip

159+ tag: ${{ github.ref }}

160+

161+ dist:

162+ needs: [check_versions, Linux]

163+ runs-on: ubuntu-latest

164+ steps:

165+ - uses: actions/checkout@v2

166+ with:

167+ submodules: recursive

168+

169+ - name: Common setup

170+ uses: ./.github/actions/common_setup

171+ with:

172+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

173+

174+ - name: Cache

175+ uses: actions/cache@v1

176+ with:

177+ path: |

178+ ~/.stack

179+ .stack-work

180+ key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}-${{ hashFiles('**.cabal') }}

181+ restore-keys: |

182+ ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}

183+ ${{ runner.os }}-stack

184+

185+ - name: Upgrade stack

186+ shell: bash

187+ # Needed for Hackage token authorization

188+ run: stack upgrade --git

189+

190+ - name: Build dist

191+ run: |

192+ stack sdist --pvp-bounds both

193+ echo "distPath=$(stack path | awk -F ": " '/dist-dir/ {print $2}')" >> $GITHUB_ENV

194+

195+ - name: Upload compaREST sources artifact

196+ uses: actions/upload-artifact@v2

197+ with:

198+ name: compaREST sources

199+ path: ${{ env.distPath }}/*.tar.gz

200+

201+ - name: Upload compaREST sources to release

202+ if: github.event_name == 'release'

203+ uses: svenstaro/upload-release-action@2.2.1

204+ with:

205+ repo_token: ${{ secrets.GITHUB_TOKEN }}

206+ file_glob: true

207+ file: ${{ env.distPath }}/*.tar.gz

208+ tag: ${{ github.ref }}

209+

210+ - name: Publish compaREST candidate to Hackage

211+ shell: bash

212+ if: github.event_name == 'release'

213+ env:

214+ HACKAGE_KEY: ${{ secrets.HACKAGE_KEY }}

54 run: |

215 run: |

55− docker load -i image

216+ stack upload --pvp-bounds both --candidate .

56− docker push typeable/comparest-github-action:latest

217+

218+ macOS:

219+ needs: check_versions

220+ runs-on: macos-latest

221+ steps:

222+ - uses: actions/checkout@v2

223+ with:

224+ submodules: recursive

225+

226+ - name: Common setup

227+ uses: ./.github/actions/common_setup

228+ with:

229+ authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

230+

231+ - name: Build macOS binary bundle

232+ run: |

233+ cp -LR $(nix-build -A macOSCompaRESTBundle -j auto --no-out-link) compaREST

234+

235+ - name: Upload macOS compaREST bundle

236+ uses: actions/upload-artifact@v2

237+ with:

238+ name: compaREST binary – macOS – x86

239+ path: compaREST

240+

241+ - name: Zip Release Assets

242+ if: github.event_name == 'release'

243+ shell: bash

244+ run: |

245+ zip -r compaREST-macOS-x86.zip compaREST

246+

247+ - name: Upload compaREST binary – macOS – x86 to release

248+ if: github.event_name == 'release'

249+ uses: svenstaro/upload-release-action@2.2.1

250+ with:

251+ repo_token: ${{ secrets.GITHUB_TOKEN }}

252+ file: compaREST-macOS-x86.zip

253+ tag: ${{ github.ref }}

254+

255+# Linux-Windows:

256+# needs: check_versions

257+# runs-on: ubuntu-latest

258+# steps:

259+# - uses: actions/checkout@v2

260+# with:

261+# submodules: recursive

262+#

263+# - name: Common setup

264+# uses: ./.github/actions/common_setup

265+# with:

266+# authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

267+#

268+# - name: Build Windows binary

269+# run: |

270+# cp -LR $(nix-build -A WindowsCompaRESTBin -j auto --no-out-link)/bin compaREST

271+#

272+# - name: Upload Windows compaREST bundle

273+# uses: actions/upload-artifact@v2

274+# with:

275+# name: compaREST binary – Windows

276+# path: compaREST

277+#

278+# - name: Zip Release Assets

279+# if: github.event_name == 'release'

280+# shell: bash

281+# run: |

282+# zip -r compaREST-Windows.zip compaREST

283+#

284+# - name: Upload compaREST binary – Windows to release

285+# if: github.event_name == 'release'

286+# uses: svenstaro/upload-release-action@2.2.1

287+# with:

288+# repo_token: ${{ secrets.GITHUB_TOKEN }}

289+# file: compaREST-Windows.zip

290+# tag: ${{ github.ref }}

.github/workflows/linux-binary.yamldeleted−54

@@ -1,54 +0,0 @@

1−name: Linux binary

2−

3−on:

4− push:

5− branches: [master]

6− pull_request:

7− branches: [master]

8−

9−jobs:

10− linux-build:

11− runs-on: ubuntu-latest

12−

13− steps:

14− - uses: actions/checkout@v2

15− with:

16− submodules: recursive

17− - name: Cache

18− uses: actions/cache@v1

19− with:

20− path: ~/.stack

21− key: ${{ runner.os }}-build-stack-${{ hashFiles('**/stack.yaml') }}-${{ hashFiles('**/*.cabal') }}

22− restore-keys: |

23− ${{ runner.os }}-build-stack-${{ hashFiles('**/stack.yaml') }}

24− ${{ runner.os }}-build-stack-

25− - name: Increase swap

26− run: |

27− free -h

28−

29− sudo swapoff /mnt/swapfile

30− sudo fallocate -l 13G /mnt/swapfile

31− sudo mkswap /mnt/swapfile

32− sudo swapon /mnt/swapfile

33−

34− free -h

35−

36− - name: Build

37− run: |

38− stack build --ghc-options=-O3 --local-bin-path comparest-linux --copy-bins --flag comparest:Static

39− - name: Test

40− run: stack test --ghc-options=-O3 --flag comparest:Static --test-arguments='--hide-successes --no-create'

41−

42− - name: Zip

43− if: github.ref == 'refs/heads/master'

44− run: |

45− zip comparest-linux comparest-linux/comparest

46− - uses: "marvinpinto/action-automatic-releases@latest"

47− if: github.ref == 'refs/heads/master'

48− with:

49− repo_token: "${{ secrets.GITHUB_TOKEN }}"

50− automatic_release_tag: "latest"

51− prerelease: false

52− title: "Pre-Release"

53− files: |

54− *.zip

.github/workflows/remove-artifacts.yamldeleted−17

@@ -1,17 +0,0 @@

1−name: Remove old artifacts

2−

3−on:

4− schedule:

5− - cron: '0 0 * * *'

6−jobs:

7− remove-old-artifacts:

8− runs-on: ubuntu-latest

9− timeout-minutes: 10

10−

11− steps:

12− - name: Remove old artifacts

13− uses: c-hive/gha-remove-artifacts@v1

14− with:

15− age: '7 days'

16− skip-tags: true

17− skip-recent: 10

.gitmodulesdeleted−3

@@ -1,3 +0,0 @@

1−[submodule "awsm-css"]

2− path = awsm-css

3− url = https://github.com/igoradamenko/awsm.css.git

CHANGELOG.md+7−3

@@ -1,9 +1,13 @@

1# Changelog

2

3−`comparest` uses [PVP Versioning][1].

3+`compaREST` uses [PVP Versioning][1].

4

5−## 0.0.0.0

5+## 0.1.0.1

6

7−* Initially created.

7+* Fixed an issue related to empty commit SHAs in GitHub Actions.

8+

9+## 0.1.0.0

10+

11+* Initial release.

8

12

9[1]: https://pvp.haskell.org

13[1]: https://pvp.haskell.org

LICENSE+1−1

@@ -1,6 +1,6 @@

1MIT License

2

4

5Permission is hereby granted, free of charge, to any person obtaining a copy

6of this software and associated documentation files (the "Software"), to deal

README.md+40−19

@@ -1,14 +1,33 @@

1−# CompaREST

1+# compaREST

2

3−[![Hackage](https://img.shields.io/hackage/v/comparest.svg?logo=haskell)](https://hackage.haskell.org/package/comparest)

3+[![Hackage](https://img.shields.io/hackage/v/compaREST.svg?logo=haskell)](https://hackage.haskell.org/package/compaREST)

4−[![Stackage Lts](http://stackage.org/package/comparest/badge/lts)](http://stackage.org/lts/package/comparest)

5−[![Stackage Nightly](http://stackage.org/package/comparest/badge/nightly)](http://stackage.org/nightly/package/comparest)

6[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)

4[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE)

7

5

8Compatibility checker for OpenAPI

6Compatibility checker for OpenAPI

9−# Quick Start Guide

10

7

8+## Using compaREST in Github Actions

9+

10+Add the following step to your Github Actions workflow:

11+

12+```yaml

13+- uses: typeable/comparest

14+ if: ${{ github.event_name == 'pull_request' }}

15+ with:

16+ old: old-openapi.yaml

17+ new: new-openapi.yaml

18+```

19+

20+The `new` and `old` values should be paths to your OpenAPI specifications you want to compare.

21+

22+You will get something like this in your pull requests:

23+

24+![](docs/img/github-action-report.png)

25+

26+For more detail please see our [integration guide](docs/Integration_guide.md).

27+

28+## An example

29+

11−## Your situation

30+### Your situation

12

31

13You are developing a very important server with a REST API. You have clients who use your API that you do not control. Say, you are also developing a mobile app that uses your API and you can't force someone to update to the latest version. (Or you prefer not to for UX reasons.)

32You are developing a very important server with a REST API. You have clients who use your API that you do not control. Say, you are also developing a mobile app that uses your API and you can't force someone to update to the latest version. (Or you prefer not to for UX reasons.)

14

33

@@ -75,7 +94,7 @@ components:

75 $ref: "#/components/schemas/Pet"

94 $ref: "#/components/schemas/Pet"

76```

95```

77

96

78−## Evolving your product

97+### Evolving your product

79

98

80Enthused over your initial success you hurry to release a new and improved version of your API and mobile app.

99Enthused over your initial success you hurry to release a new and improved version of your API and mobile app.

81

100

@@ -144,7 +163,7 @@ components:

144

163

145Looking at the very large and complex API description, you grow more and more concerned that your old mobile app might stop working when you update the server. But the spec is too large and too complex to reasonably assess this manually.

164Looking at the very large and complex API description, you grow more and more concerned that your old mobile app might stop working when you update the server. But the spec is too large and too complex to reasonably assess this manually.

146

165

147−## Assessing compatibility automatically

166+### Assessing compatibility automatically

148

167

149Luckily, you have access to compaREST which can programmatically analyze your APIs and determine what, if anything, breaks compatibility and what doesn't.

168Luckily, you have access to compaREST which can programmatically analyze your APIs and determine what, if anything, breaks compatibility and what doesn't.

150

169

@@ -158,15 +177,15 @@ Running this command will output a file `report.md`, containing the compatibilit

158

177

159> # Summary

178> # Summary

160>

179>

161−> | [⚠️ Breaking changes](#breaking-changes) | [🙆 Non-breaking changes](#non-breaking-changes) | 🤷 Unsupported feature changes |

180+> | [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

162−> |------------------------------------------|-------------------------------------------------|-------------------------------|

181+> |------------------------------------------|--------------------------------------------------|

163−> | 5 | 6 | 0 |

182+> | 5 | 6 |

164>

183>

165−> # ⚠️ Breaking changes

184+> # ❌ Breaking changes

166>

185>

167> ## **GET** /pets

186> ## **GET** /pets

168>

187>

169−> ### 📱⬅️ JSON Response – 200

188+> ### ⬅️☁️ JSON Response – 200

170>

189>

171> #### `$[*].name(String)`

190> #### `$[*].name(String)`

172>

191>

@@ -176,7 +195,7 @@ Running this command will output a file `report.md`, containing the compatibilit

176>

195>

177> ## **POST** /pets

196> ## **POST** /pets

178>

197>

179−> ### 📱➡️ JSON Request

198+> ### ➡️☁️ JSON Request

180>

199>

181> #### `$.weight`

200> #### `$.weight`

182>

201>

@@ -191,7 +210,7 @@ Running this command will output a file `report.md`, containing the compatibilit

191>

210>

192> Value is now a multiple of 1.0.

211> Value is now a multiple of 1.0.

193>

212>

194−> # 🙆 Non-breaking changes

213+> # ⚠️ Non-breaking changes

195>

214>

196> ## **GET** /pets

215> ## **GET** /pets

197>

216>

@@ -203,7 +222,7 @@ Running this command will output a file `report.md`, containing the compatibilit

203>

222>

204> Upper bound changed from 20.0 inclusive to 30.0 inclusive.

223> Upper bound changed from 20.0 inclusive to 30.0 inclusive.

205>

224>

206−> ### 📱⬅️ JSON Response – 200

225+> ### ⬅️☁️ JSON Response – 200

207>

226>

208> #### `$[*].weight`

227> #### `$[*].weight`

209>

228>

@@ -220,7 +239,7 @@ Running this command will output a file `report.md`, containing the compatibilit

220>

239>

221> ## **POST** /pets

240> ## **POST** /pets

222>

241>

223−> ### 📱➡️ JSON Request

242+> ### ➡️☁️ JSON Request

224>

243>

225> #### `$.name(String)`

244> #### `$.name(String)`

226>

245>

@@ -230,7 +249,7 @@ Running this command will output a file `report.md`, containing the compatibilit

230

249

231You now know exactly in what situations and in what way your 1.0 version of the app will break if you deploy your 1.1 version of the server.

250You now know exactly in what situations and in what way your 1.0 version of the app will break if you deploy your 1.1 version of the server.

232

251

233−## Additional formats

252+### Additional formats

234

253

235You can also produce a self-contained HTML report that you can open in your browser by simply omitting the file extension of the output file:

254You can also produce a self-contained HTML report that you can open in your browser by simply omitting the file extension of the output file:

236

255

@@ -238,7 +257,9 @@ You can also produce a self-contained HTML report that you can open in your brow

238docker run --rm -v $(pwd):/data:rw typeable/comparest --client /data/api-1.0.0.yaml --server /data/api-1.1.0.yaml --output /data/report

257docker run --rm -v $(pwd):/data:rw typeable/comparest --client /data/api-1.0.0.yaml --server /data/api-1.1.0.yaml --output /data/report

239```

258```

240

259

241−# CLI docs

260+## CLI docs

261+

262+For more detail please see our [user guide](docs/User_guide.md).

242

263

243```

264```

244Usage: comparest (-c|--client ARG) (-s|--server ARG)

265Usage: comparest (-c|--client ARG) (-s|--server ARG)

action.yaml+14−13

@@ -7,41 +7,42 @@ inputs:

7 default: "${{ github.token }}"

8 required: false

9 repo:

10− description: The owner of the repo in which to post the comment.

10+ description: The owner of the repo in which to post the results.

11 default: "${{ github.repository }}"

12 required: false

13− pull_request:

14− description: The pull request in which to post the comment.

15− default: "${{ github.event.pull_request.number }}"

16− required: false

17 project_name:

13 project_name:

18− description: The name of the project to which the API pertains.

14+ description: The name of the project to which the API pertains. Used to name the check. Useful when you have multiple APIs in the same repo.

19− required: true

15+ required: false

16+ default: ""

20 footer:

17 footer:

21− description: A footer that can be appended to the comment.

18+ description: A footer that can be appended to the check body.

22 required: false

19 required: false

23 default: ""

20 default: ""

24 old:

21 old:

25− description: The path to old specification of the API.

22+ description: The path to the old (client) specification of the API.

26 required: true

23 required: true

27 new:

24 new:

28− description: The path to new specification of the API.

25+ description: The path to new (server) specification of the API.

29 required: true

26 required: true

27+ sha:

28+ description: The sha of the commit to post the check for.

29+ required: false

30+ default: "${{ github.event.pull_request.head.sha }}"

30runs:

31runs:

31 using: "docker"

32 using: "docker"

32− image: "typeable/comparest-github-action:latest"

33+ image: "docker://typeable/comparest-github-action:0.1.0.1"

33 env:

34 env:

34 GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"

35 GITHUB_TOKEN: "${{ inputs.GITHUB_TOKEN }}"

35 REPO: "${{ inputs.repo }}"

36 REPO: "${{ inputs.repo }}"

36− PR_NUMBER: "${{ inputs.pull_request }}"

37 PROJECT_NAME: "${{ inputs.project_name }}"

38 FOOTER: "${{ inputs.footer }}"

39 ROOT: "/github/workspace"

40 OLD: "${{ inputs.old }}"

41 NEW: "${{ inputs.new }}"

42+ SHA: "${{ inputs.sha }}"

42 pre-entrypoint: "/bin/pre"

43 pre-entrypoint: "/bin/pre"

43 entrypoint: "/bin/run"

44 entrypoint: "/bin/run"

44

45

45branding:

46branding:

46 icon: crosshair

47 icon: crosshair

47− color: gray-dark

48+ color: blue

app/Data/OpenApi/Compare/Options.hs+92−72

@@ -1,7 +1,7 @@

1module Data.OpenApi.Compare.Options

2− ( Options (..)

2+ ( Options (..),

3− , OutputMode (..)

3+ OutputMode (..),

4− , parseOptions

4+ parseOptions,

5 )

6where

7

@@ -9,6 +9,7 @@ import Data.OpenApi.Compare.Report

9import GHC.Generics (Generic)

10import Options.Applicative

11import Options.Applicative.Help hiding (fullDesc)

12+import Text.PrettyPrint.ANSI.Leijen ((<$$>),string)

12

13

13parseOptions :: IO Options

14parseOptions :: IO Options

14parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo

15parseOptions = customExecParser (prefs $ showHelpOnError) optionsParserInfo

@@ -30,86 +31,105 @@ optionsParserInfo :: ParserInfo Options

30optionsParserInfo =

31optionsParserInfo =

31 info

32 info

32 (helper <*> optionsParser)

33 (helper <*> optionsParser)

33− (fullDesc

34+ ( fullDesc

34− <> header "CompaREST"

35+ <> header "CompaREST"

35− <> progDescDoc

36+ <> progDescDoc

36− (Just $

37+ ( Just $

37− par "A tool to check compatibility between two OpenAPI specifications."

38+ par "A tool to check compatibility between two OpenAPI specifications."

38− <$$> hardline <> par "Usage examples" <> hardline

39+ <$$> hardline <> par "Usage examples" <> hardline

39− <$$> indent

40+ <$$> indent

40− 4

41+ 4

41− (par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"

42+ ( par "Compare files old.yaml with new.yaml and output the resulting report to stdout:"

42− <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"

43+ <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml"

43− <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"

44+ <$$> hardline <> par "Only output breaking changes and write a styled HTML report to file report.html:"

44− <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"

45+ <$$> hardline <> indent 4 "comparest -c old.yaml -s new.yaml --only-breaking -o report"

45− <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"

46+ <$$> hardline <> par "Don't output anything, only fail if there are breaking changes:"

46− <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"

47+ <$$> hardline <> indent 4 "comparest -c old.json -s new.json --silent"

47− <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"

48+ <$$> hardline <> par "Write full report suitable for embedding into a GitHub comment to report.html:"

48− <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html")))

49+ <$$> hardline <> indent 4 "comparest -c old.json -s new.json --folding-block-quotes-style -o report.html"

50+ )

51+ )

52+ )

49

53

50optionsParser :: Parser Options

54optionsParser :: Parser Options

51optionsParser =

55optionsParser =

52 Options

56 Options

53 <$> strOption

57 <$> strOption

54− (short 'c'

58+ ( short 'c'

55− <> long "client"

59+ <> long "client"

56− <> help

60+ <> help

57− "A path to the file containing the specification that will be \

61+ "A path to the file containing the specification that will be \

58− \used for the client of the API. Can be either a YAML or JSON file.")

62+ \used for the client of the API. Can be either a YAML or JSON file."

63+ )

59 <*> strOption

64 <*> strOption

60− (short 's'

65+ ( short 's'

61− <> long "server"

66+ <> long "server"

62− <> help

67+ <> help

63− "A path to the file containing the specification that will be \

68+ "A path to the file containing the specification that will be \

64− \used for the server of the API. Can be either a YAML or JSON file.")

69+ \used for the server of the API. Can be either a YAML or JSON file."

70+ )

65− <*> (flag'

71+ <*> ( flag'

66− Nothing

72+ Nothing

67− (long "silent"

73+ ( long "silent"

68− <> help "Silence all output. Only makes sense in combination with --signal-exit-code.")

74+ <> help "Silence all output. Only makes sense in combination with --signal-exit-code."

75+ )

69− <|> flag'

76+ <|> flag'

70− (Just OnlyErrors)

77+ (Just OnlyErrors)

71− (long "only-breaking"

78+ ( long "only-breaking"

72− <> help "Only report breaking changes in the output.")

79+ <> help "Only report breaking changes in the output."

80+ )

73− <|> flag'

81+ <|> flag'

74− (Just All)

82+ (Just All)

75− (long "all"

83+ ( long "all"

76− <> help

84+ <> help

77− "Report both incompatible and compatible changes. \

85+ "Report both incompatible and compatible changes. \

78− \Compatible changes will not trigger a failure exit code.")

86+ \Compatible changes will not trigger a failure exit code."

87+ )

79− <|> pure (Just All))

88+ <|> pure (Just All)

89+ )

80− <*> ((FileMode

90+ <*> ( ( FileMode

81− <$> strOption

91+ <$> strOption

82− (short 'o' <> long "output"

92+ ( short 'o' <> long "output"

83− <> helpDoc

93+ <> helpDoc

84− (Just $

94+ ( Just $

85− par "The file path where the output should be written. If the option is omitted the result will be written to stdout."

95+ par "The file path where the output should be written. If the option is omitted the result will be written to stdout."

86− <$$> hardline <> par "The file extension is used to determine the type of the output file."

96+ <$$> hardline <> par "The file extension is used to determine the type of the output file."

87− <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."

97+ <$$> hardline <> par "Supports many formats such as markdown, html, rtf, doc, txt, rst, and many more."

88− <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling.")))

98+ <$$> hardline <> par "Leave out the extension to produce a self-contained HTML report with styling."

99+ )

100+ )

101+ )

89− <|> pure StdoutMode)

102+ <|> pure StdoutMode

103+ )

90− <*> (flag'

104+ <*> ( flag'

91− FoldingBlockquotesTreeStyle

105+ FoldingBlockquotesTreeStyle

92− (long "folding-block-quotes-style"

106+ ( long "folding-block-quotes-style"

93− <> help

94− "The report tree is structured using \

95− \summary/detail HTML elements and indented using \

96− \block quotes. This style renders well on GitHub.\

97− \Intended for HTML output format. Markdown has rendering \

98− \bugs on GitHub.")

99− <|> flag'

100− HeadersTreeStyle

101− (long "header-style"

102 <> help

107 <> help

103 "The report tree is structured using \

108 "The report tree is structured using \

109+ \summary/detail HTML elements and indented using \

110+ \block quotes. This style renders well on GitHub.\

111+ \Intended for HTML output format. Markdown has rendering \

112+ \bugs on GitHub."

113+ )

114+ <|> flag'

115+ HeadersTreeStyle

116+ ( long "header-style"

117+ <> help

118+ "The report tree is structured using \

104− \increasing levels of headers.")

119+ \increasing levels of headers."

120+ )

105− <|> pure HeadersTreeStyle)

121+ <|> pure HeadersTreeStyle

122+ )

106− <*> switch

123+ <*> switch

107− (long "signal-exit-code"

124+ ( long "signal-exit-code"

108− <> helpDoc (Just $

125+ <> helpDoc

126+ ( Just $

109 par "Signal API compatibility with the exit code."

127 par "Signal API compatibility with the exit code."

110 <$$> hardline <> par "Exit with 0 if there are no breaking changes."

128 <$$> hardline <> par "Exit with 0 if there are no breaking changes."

111 <$$> par "Exit with 1 if there are breaking changes."

129 <$$> par "Exit with 1 if there are breaking changes."

112− <$$> par "Exit with 2 if could not determine compatibility."))

130+ <$$> par "Exit with 2 if could not determine compatibility."

131+ )

132+ )

113

133

114par :: String -> Doc

134par :: String -> Doc

115par = foldr1 (</>) . fmap string . words

135par = foldr1 (</>) . fmap string . words

app/FormatHeuristic.hs+1−1

@@ -2,7 +2,7 @@

2-- Originally based on:

3-- https://github.com/jgm/pandoc/blob/master/src/Text/Pandoc/App/FormatHeuristics.hs

4module FormatHeuristic

5− ( formatFromFilePath

5+ ( formatFromFilePath,

6 )

7where

8

app/Main.hs+1

@@ -2,6 +2,7 @@ module Main (main) where

2

3import Control.Monad

4import Control.Monad.Except

5+import Control.Monad.Trans (lift)

5import Data.Aeson

6import Data.Aeson

6import qualified Data.ByteString.Lazy as BSL

7import qualified Data.ByteString.Lazy as BSL

7import Data.Default

8import Data.Default

awsm-cssdeleted−1

Submodule changed.

ci/policeman.nixnew file+4

@@ -0,0 +1,4 @@

1+{ sources ? import ../nix/sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+pkgs.haskellPackages.policeman

comparest.cabal → compaREST.cabalrenamed+24−20

@@ -1,29 +1,24 @@

1cabal-version: 2.4

2−name: comparest

2+name: compaREST

3−version: 0.0.0.0

3+version: 0.1.0.1

4synopsis: Compatibility checker for OpenAPI

5description: Compatibility checker for OpenAPI.

6license: MIT

7license-file: LICENSE

8author: Typeable

9−maintainer: comparest@typeable.io

9+maintainer: compaREST@typeable.io

10copyright: 2021 Typeable

11category: Web

12build-type: Simple

13extra-doc-files: README.md

14 CHANGELOG.md

15−tested-with: GHC == 8.10.4

15+tested-with: GHC == 9.6

16−extra-source-files: awsm-css/dist/awsm.min.css

16+extra-source-files: css/awsm.min.css

17−

17+extra-source-files:

18−Flag static

18+ test/golden/**/*.yaml

19− Default: False

19+ test/golden/**/*.md

20− Manual: True

21

20

22common common-options

21common common-options

23− if flag(static)

24− cc-options: -static

25− ld-options: -static -pthread

26− ghc-options: -static

27 ghc-options:

22 ghc-options:

28 -Weverything

23 -Weverything

29 -Wno-implicit-prelude

24 -Wno-implicit-prelude

@@ -31,15 +26,17 @@ common common-options

31 -Wno-safe

26 -Wno-safe

32 -Wno-prepositive-qualified-module

27 -Wno-prepositive-qualified-module

33 -Wno-missing-import-lists

28 -Wno-missing-import-lists

29+ -Wno-missing-kind-signatures

34 -Wno-partial-fields

30 -Wno-partial-fields

35 -Wno-all-missed-specialisations

31 -Wno-all-missed-specialisations

36 -Wno-missing-local-signatures

32 -Wno-missing-local-signatures

37 -Wno-unsafe

33 -Wno-unsafe

38 -fconstraint-solver-iterations=0

34 -fconstraint-solver-iterations=0

39 default-language: Haskell2010

35 default-language: Haskell2010

40− build-depends: base >= 4.12.0.0 && < 4.16

36+ build-depends: base >= 4.12.0.0 && < 5

41 , text

37 , text

42

38

39+

43 default-extensions: ApplicativeDo

40 default-extensions: ApplicativeDo

44 , BangPatterns

41 , BangPatterns

45 , ConstraintKinds

42 , ConstraintKinds

@@ -81,6 +78,7 @@ common common-options

81 , QuantifiedConstraints

78 , QuantifiedConstraints

82 , DefaultSignatures

79 , DefaultSignatures

83

80

81+

84library

82library

85 import: common-options

83 import: common-options

86 build-depends:

84 build-depends:

@@ -151,12 +149,12 @@ library

151 other-modules: Data.HList

149 other-modules: Data.HList

152 , Data.OpenUnion.Extra

150 , Data.OpenUnion.Extra

153

151

154−executable comparest

152+executable compaREST

155 import: common-options

153 import: common-options

156 hs-source-dirs: app

154 hs-source-dirs: app

157 main-is: Main.hs

155 main-is: Main.hs

158 build-depends:

156 build-depends:

159− comparest

157+ compaREST

160 , pandoc

158 , pandoc

161 , data-default

159 , data-default

162 , bytestring

160 , bytestring

@@ -168,6 +166,7 @@ executable comparest

168 , containers

166 , containers

169 , doctemplates

167 , doctemplates

170 , pandoc-types

168 , pandoc-types

169+ , prettyprinter-compat-ansi-wl-pprint

171 ghc-options: -threaded

170 ghc-options: -threaded

172 -rtsopts

171 -rtsopts

173 -with-rtsopts=-N

172 -with-rtsopts=-N

@@ -175,12 +174,12 @@ executable comparest

175 FormatHeuristic

174 FormatHeuristic

176 Data.OpenApi.Compare.Options

175 Data.OpenApi.Compare.Options

177

176

178−executable comparest-github-action

177+executable compaREST-GitHub-Action

179 import: common-options

178 import: common-options

180 hs-source-dirs: github-action

179 hs-source-dirs: github-action

181 main-is: Main.hs

180 main-is: Main.hs

182 build-depends:

181 build-depends:

183− comparest

182+ compaREST

184 , pandoc

183 , pandoc

185 , yaml

184 , yaml

186 , aeson

185 , aeson

@@ -190,6 +189,7 @@ executable comparest-github-action

190 , pandoc-types

189 , pandoc-types

191 , envy

190 , envy

192 , filepath

191 , filepath

192+ , bytestring

193 ghc-options: -threaded

194 -rtsopts

195 -with-rtsopts=-N

@@ -197,8 +197,10 @@ executable comparest-github-action

197 Control.Monad.Freer.GitHub

198 CompaREST.GitHub.API

199 CompaREST.GitHub.Action.Config

200+ GitHub.Data.Checks

201+ GitHub.Endpoints.Checks

200

202

201−test-suite comparest-tests

203+test-suite compaREST-tests

202 import: common-options

204 import: common-options

203 type: exitcode-stdio-1.0

205 type: exitcode-stdio-1.0

204 hs-source-dirs: test

206 hs-source-dirs: test

@@ -206,8 +208,10 @@ test-suite comparest-tests

206 other-modules:

208 other-modules:

207 Spec.Golden.Extra

209 Spec.Golden.Extra

208 Spec.Golden.TraceTree

210 Spec.Golden.TraceTree

211+ Paths_compaREST

212+ autogen-modules: Paths_compaREST

209 build-depends:

213 build-depends:

210− , comparest

214+ , compaREST

211 , tasty-golden

215 , tasty-golden

212 , tasty

216 , tasty

213 , bytestring

217 , bytestring

css/awsm.min.cssnew file+1

@@ -0,0 +1 @@

1+@charset "UTF-8";html{font-family:"PT Serif",Georgia,serif;font-size:100%;line-height:1.6;background:#fff;color:#000;-webkit-overflow-scrolling:touch}body{margin:1em;font-size:1rem}@media (min-width:20rem){body{font-size:calc(1rem + .0125*(100vw - 20rem))}}@media (min-width:40rem){body{font-size:1.25rem}}body article,body footer,body header,body main{position:relative;max-width:40rem;margin:0 auto}body>header{margin-bottom:3.5em}body>header h1{margin:0;font-size:1.5em}body>header p{margin:0;font-size:.85em}body>footer{margin-top:4.5em;padding-bottom:1.5em;text-align:center;font-size:.8rem;color:#aaa}details,nav,p{margin:1em 0}nav ul{list-style:none;margin:0;padding:0}nav li{display:inline-block;margin-right:1em;margin-bottom:.25em}nav a:visited{color:#0064c1}article header h1 a:visited:hover,article header h2 a:visited:hover,nav a:hover{color:#3000c1}ol,ul{margin-top:0;padding-top:0;padding-left:2.5em}p{-webkit-hyphens:auto;-ms-hyphens:auto;hyphens:auto}aside:first-child,p:first-child{margin-top:0}aside:last-child,p:last-child{margin-bottom:0}p+ol,p+ul{margin-top:-.75em}p img,p picture{float:right;margin-bottom:.5em;margin-left:.5em}p picture img{float:none;margin:0}blockquote,dd{padding-left:2.5em}dd{margin-bottom:1em;margin-left:0}dt{font-weight:700}blockquote{margin:0}aside{margin:.5em 0;font-style:italic;color:#aaa}@media (min-width:65rem){aside{position:absolute;right:-12.5rem;width:9.375rem;max-width:9.375rem;margin:0;padding-left:.5em;font-size:.8em;border-left:1px solid #f2f2f2}}section+section{margin-top:2em}h1,h2,h3,h4,h5,h6{margin:1.25em 0 0;line-height:1.2}h1:focus>a[href^="#"][id],h1:hover>a[href^="#"][id],h2:focus>a[href^="#"][id],h2:hover>a[href^="#"][id],h3:focus>a[href^="#"][id],h3:hover>a[href^="#"][id],h4:focus>a[href^="#"][id],h4:hover>a[href^="#"][id],h5:focus>a[href^="#"][id],h5:hover>a[href^="#"][id],h6:focus>a[href^="#"][id],h6:hover>a[href^="#"][id]{opacity:1;transition:opacity 0s,color 300ms ease-out}figure+p,h1+details,h1+p,h2+details,h2+p,h3+details,h3+p,h4+details,h4+p,h5+details,h5+p,h6+details,h6+p{margin-top:.5em}h1>a[href^="#"][id],h2>a[href^="#"][id],h3>a[href^="#"][id],h4>a[href^="#"][id],h5>a[href^="#"][id],h6>a[href^="#"][id]{position:absolute;left:-.5em;opacity:0;background:0 0;color:rgba(0,0,0,.5);transition:opacity 300ms ease-out}h1>a[href^="#"][id]:focus,h1>a[href^="#"][id]:hover,h1>a[href^="#"][id]:target,h2>a[href^="#"][id]:focus,h2>a[href^="#"][id]:hover,h2>a[href^="#"][id]:target,h3>a[href^="#"][id]:focus,h3>a[href^="#"][id]:hover,h3>a[href^="#"][id]:target,h4>a[href^="#"][id]:focus,h4>a[href^="#"][id]:hover,h4>a[href^="#"][id]:target,h5>a[href^="#"][id]:focus,h5>a[href^="#"][id]:hover,h5>a[href^="#"][id]:target,h6>a[href^="#"][id]:focus,h6>a[href^="#"][id]:hover,h6>a[href^="#"][id]:target{opacity:1;box-shadow:none;color:#000;transition:opacity 0s,color 0s}h1>a[href^="#"][id]:target:focus,h2>a[href^="#"][id]:target:focus,h3>a[href^="#"][id]:target:focus,h4>a[href^="#"][id]:target:focus,h5>a[href^="#"][id]:target:focus,h6>a[href^="#"][id]:target:focus{outline:0}h1>a[href^="#"][id]::before,h2>a[href^="#"][id]::before,h3>a[href^="#"][id]::before,h4>a[href^="#"][id]::before,h5>a[href^="#"][id]::before,h6>a[href^="#"][id]::before{content:"â€¢"}h1{font-size:2em}h2{font-size:1.75em}h3{font-size:1.25em}h4{font-size:1.15em}h5,h6{font-size:1em}h6{margin-top:1em;color:#aaa}article+article{margin-top:5em}article header p{font-family:system-ui,-apple-system,BlinkMacSystemFont,"Segoe UI",Roboto,Oxygen,Ubuntu,Cantarell,"Fira Sans","Droid Sans","Helvetica Neue",Helvetica,Arial,sans-serif;font-size:.6em;color:#aaa}article header p+h1,article header p+h2{margin-top:-.25em}article header h1+p,article header h2+p{margin-top:.25em}article header h1 a,article header h2 a{color:#000;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(0, 0, 0, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){article header h1 a,article header h2 a{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(0, 0, 0, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}article header h1 a:visited,article header h2 a:visited{color:#aaa;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(170, 170, 170, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){article header h1 a:visited,article header h2 a:visited{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(170, 170, 170, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}article>footer{margin-top:1.5em;font-size:.85em}a,abbr{text-decoration:none}a{color:#0064c1;transition:color 300ms ease-out,box-shadow 300ms ease-out;background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="1"%3E%3Crect x="0" y="0.5" width="1" height="0.5" fill="rgba(0, 100, 193, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}@media screen and (-ms-high-contrast:active),(-ms-high-contrast:none){a{background:url('data:image/svg+xml;charset=utf8,%3Csvg xmlns="http://www.w3.org/2000/svg" width="1" height="2"%3E%3Crect x="0" y="1" width="1" height="1" fill="rgba(0, 100, 193, 0.35)"/%3E%3C/svg%3E') left bottom repeat-x}}a:visited{color:#80b2e0}a:active,a:hover{outline-width:0}a:hover{box-shadow:inset 0 -1px #3000c1;color:#3000c1;transition:color 0s,box-shadow 0s}abbr{margin-right:-.075em;-webkit-hyphens:none;-ms-hyphens:none;hyphens:none;letter-spacing:.075em;font-size:.9em;border-bottom:1px dotted}img,picture{display:block;max-width:100%;margin:0 auto}audio,video{width:100%;max-width:100%}video{-o-object-position:0 -1px;object-position:0 -1px}figure{margin:1em 0 .5em;padding:0}figure figcaption{opacity:.65;font-size:.85em}table{display:inline-block;border-spacing:0;border-collapse:collapse;overflow-x:auto;max-width:100%;text-align:left;vertical-align:top;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}table caption{font-size:.9em;background:#fff}table td,table th{padding:.35em .75em;vertical-align:top;font-size:.9em;border:1px solid #f2f2f2;border-top:0;border-left:0}table td:first-child,table th:first-child{padding-left:0;background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%);background-size:2px 100%;background-repeat:no-repeat}table td:last-child,table th:last-child{padding-right:0;border-right:0;background-image:linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:100% 0;background-size:2px 100%;background-repeat:no-repeat}table td:only-child,table th:only-child{background-image:linear-gradient(to right,#fff 50%,rgba(255,255,255,0) 100%),linear-gradient(to left,#fff 50%,rgba(255,255,255,0) 100%);background-position:0 0,100% 0;background-size:2px 100%,2px 100%;background-repeat:no-repeat,no-repeat}table th{line-height:1.2}code,kbd,samp,var{font-family:Consolas,"Lucida Console",Monaco,monospace;font-style:normal}pre{overflow-x:auto;font-size:.8em;background:linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 0 0,linear-gradient(rgba(0,0,0,.15) 0%,rgba(0,0,0,.15) 100%) 100% 0;background-attachment:scroll,scroll;background-size:1px 100%,1px 100%;background-repeat:no-repeat,no-repeat}pre>code,summary{display:inline-block}pre>code{overflow-x:visible;box-sizing:border-box;min-width:100%;border-right:3px solid #fff;border-left:1px solid #fff}hr{height:1px;margin:2em 0;border:0;background:#f2f2f2}details[open]{padding-bottom:.5em;border-bottom:1px solid #f2f2f2}summary{font-weight:700;border-bottom:1px dashed;cursor:pointer}summary::-webkit-details-marker{display:none}noscript{color:#d00000}::selection{background:rgba(0,100,193,.15)}

default.nix+68−14

@@ -1,10 +1,14 @@

1{ sources ? import ./nix/sources.nix

2, haskellNix ? import sources.haskellNix { inherit system; }

3−, pkgs ? import haskellNix.sources.nixpkgs-2105 (haskellNix.nixpkgsArgs // { inherit system; })

3+, pkgs ? import haskellNix.sources.nixpkgs-2311 (haskellNix.nixpkgsArgs // { inherit system; })

4, system ? builtins.currentSystem

5, nix-filter ? import sources.nix-filter

6}:

7let

8+ masterPkgs = import sources.nixpkgs { inherit system; };

9+ yq = import ./nix/yq.nix { pkgs = masterPkgs; };

10+ diffYaml = import ./nix/diff-yaml.nix { pkgs = masterPkgs; };

11+

8 hsPkgs = pkgs.haskell-nix.stackProject {

12 hsPkgs = pkgs.haskell-nix.stackProject {

9 src = nix-filter {

13 src = nix-filter {

10 root = ./.;

14 root = ./.;

@@ -12,7 +16,7 @@ let

12 include = [

16 include = [

13 ./stack.yaml

17 ./stack.yaml

14 ./stack.yaml.lock

18 ./stack.yaml.lock

15− ./comparest.cabal

19+ ./compaREST.cabal

16 ];

20 ];

17 };

21 };

18

22

@@ -21,16 +25,22 @@ let

21 dontStrip = false;

25 dontStrip = false;

22 dontPatchELF = false;

26 dontPatchELF = false;

23 enableDeadCodeElimination = true;

27 enableDeadCodeElimination = true;

28+ ghcOptions = [

29+ "-O2"

30+ "-fexpose-all-unfoldings"

31+ "-fspecialise-aggressively"

32+ ];

33+ packages.pandoc.ghcOptions = [ "-O1" ];

24− packages.comparest.src = nix-filter {

34+ packages.compaREST.src = nix-filter {

25 root = ./.;

35 root = ./.;

26 name = "compaREST-src";

36 name = "compaREST-src";

27 include = with nix-filter; [

37 include = with nix-filter; [

28− (./comparest.cabal)

38+ (./compaREST.cabal)

29 (inDirectory ./test)

39 (inDirectory ./test)

30 (inDirectory ./src)

40 (inDirectory ./src)

31 (inDirectory ./app)

41 (inDirectory ./app)

32 (inDirectory ./github-action)

42 (inDirectory ./github-action)

33− ./awsm-css/dist/awsm.min.css

43+ ./css/awsm.min.css

34 ./LICENSE

44 ./LICENSE

35 ];

45 ];

36 };

46 };

@@ -45,27 +55,71 @@ let

45 ${pkgs.nukeReferences}/bin/nuke-refs $out/bin/*

55 ${pkgs.nukeReferences}/bin/nuke-refs $out/bin/*

46 '';

56 '';

47

57

58+ compaRESTBin = hsPkgs.compaREST.components.exes.compaREST;

59+ compaRESTStaticBin = (staticify "compaREST-static" hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.exes.compaREST);

60+

61+

62+ # doesn't work

63+ armDarwinCompaREST = hsPkgs.projectCross.aarch64-darwin.hsPkgs.compaREST.components.exes.compaREST;

64+

48− compaREST = pkgs.dockerTools.buildImage {

65+ compaRESTImage = pkgs.dockerTools.buildImage {

49 name = "compaREST";

66 name = "compaREST";

50− contents = [ (staticify "compaREST-static" hsPkgs.projectCross.musl64.hsPkgs.comparest.components.exes.comparest) ];

67+ contents = [ compaRESTStaticBin ];

51 config = {

68 config = {

52− Entrypoint = [ "/bin/comparest" ];

69+ Entrypoint = [ "/bin/compaREST" ];

53 };

70 };

54 };

71 };

55

72

73+ macOSCompaRESTBundle = pkgs.runCommand "compaREST-macOS-bundled"

74+ {

75+ buildInputs = [ masterPkgs.macdylibbundler ];

76+ } ''

77+ mkdir -p $out/lib

78+ cp ${compaRESTBin}/bin/compaREST $out/compaREST

79+ chmod 755 $out/compaREST

80+ dylibbundler -b \

81+ -x $out/compaREST \

82+ -d $out/lib \

83+ -p '@executable_path/lib'

84+ '';

85+

86+

56 compaRESTGithubAction =

87 compaRESTGithubAction =

57 let

88 let

58− action = staticify "compaREST-github-action-static" hsPkgs.projectCross.musl64.hsPkgs.comparest.components.exes.comparest-github-action;

89+ action = staticify "compaREST-GitHub-Action-static" hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.exes.compaREST-GitHub-Action;

59− wrapped = pkgs.runCommand "wrapped-compaREST-github-action" { buildInputs = [ pkgs.makeWrapper ]; } ''

90+ wrapped = pkgs.runCommand "wrapped-compaREST-GitHub-Action" { buildInputs = [ pkgs.makeWrapper ]; } ''

60− makeWrapper ${action}/bin/comparest-github-action $out/bin/pre --add-flags "pre"

91+ makeWrapper ${action}/bin/compaREST-GitHub-Action $out/bin/pre --add-flags "pre"

61− makeWrapper ${action}/bin/comparest-github-action $out/bin/run --add-flags "run"

92+ makeWrapper ${action}/bin/compaREST-GitHub-Action $out/bin/run --add-flags "run"

62 '';

93 '';

63 in

94 in

64 pkgs.dockerTools.buildImage {

95 pkgs.dockerTools.buildImage {

65− name = "typeable/comparest-github-action";

96+ name = "typeable/compaREST-GitHub-Action";

66 tag = "latest";

97 tag = "latest";

67 contents = [ wrapped pkgs.cacert ];

98 contents = [ wrapped pkgs.cacert ];

68 };

99 };

69

100

101+ WindowsCompaRESTBin = hsPkgs.projectCross.mingwW64.hsPkgs.compaREST.components.exes.compaREST;

102+

103+ # We use the static version so that we don't have to rebuild everything on CI.

104+ # The only binaries build on CI are static.

105+ test = hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.tests.compaREST-tests.overrideAttrs (final: old: {

106+ buildInputs = old.buildInputs ++ [ diffYaml yq ];

107+ nativeBuildInputs = old.nativeBuildInputs ++ (with masterPkgs; [ makeWrapper ]);

108+

109+ postInstall = ''

110+ wrapProgram $out/bin/compaREST-tests \

111+ --prefix PATH : ${masterPkgs.lib.makeBinPath [ diffYaml yq ]}

112+ '';

113+ });

70in

114in

115+{

116+ inherit

117+ compaRESTImage

71−{ inherit compaREST compaRESTGithubAction hsPkgs haskellNix; }

118+ compaRESTGithubAction

119+ compaRESTStaticBin

120+ compaRESTBin

121+ hsPkgs

122+ macOSCompaRESTBundle

123+ WindowsCompaRESTBin

124+ test;

125+}

docs/Integration_guide.md+3−5

@@ -28,8 +28,6 @@ In our example we have already generated the two OpenAPI specs and placed them i

28

29We can now run our action:

30

31−##### NOTE: will only work after public release

32−

33```yaml

31```yaml

34- uses: typeable/comparest

32- uses: typeable/comparest

35 with:

33 with:

@@ -38,11 +36,11 @@ We can now run our action:

38 project_name: TEST

36 project_name: TEST

39```

37```

40

38

41−This will create a comment on the pull request displaying the changes (if there are any) similar to this:

39+This will create a check on the pull request displaying the changes (if there are any) similar to this:

42

40

43−![](img/github-action-comment.png)

41+![](img/github-action-report.png)

44

42

45−Consecutive runs of the action will update the comment instead of creating new ones. This will prevent the pile-up of compaREST comments and save you from distracting notifications.

43+The check will show success when there are no breaking changes, and be neutral otherwise.

46

44

47## Integrating into something other than Github Actions

45## Integrating into something other than Github Actions

48

46

docs/Releasing.mdnew file+15

@@ -0,0 +1,15 @@

1+# The release procedure

2+

3+1. Update the version number everywhere:

4+ 1. Version in [compaREST.cabal](../compaREST.cabal)

5+ 2. Docker tag in [action.yaml](../action.yaml)

6+ 3. Set the version of unreleased changes in [CHANGELOG.md](../CHANGELOG.md)

7+2. Publish!

8+ 1. Create a pre-release on GitHub:

9+ ![](img/pre-release.png)

10+ 2. This will automatically start the release procedure. You can check the state of it in the "Actions" tab on GitHub:

11+ ![](img/pre-release-ci.png)

12+ 3. If everything goes as planned, the release action should pass and all assets should be added to the release:

13+ ![](img/pre-release-artifacts.png)

14+ 4. The new version should be automatically uploaded a release candidate to [Hackage](https://hackage.haskell.org/package/compaREST/candidates/). Make sure everything looks okay and publish it.

15+ 5. Go to the Releases tab on GitHub and edit the release to make it not a "pre-release".

docs/img/github-action-comment.pngdeleted

Binary file not shown.

docs/img/github-action-report.pngnew file

Binary file not shown.

docs/img/pre-release-artifacts.pngnew file

Binary file not shown.

docs/img/pre-release-ci.pngnew file

Binary file not shown.

docs/img/pre-release.pngnew file

Binary file not shown.

github-action/CompaREST/GitHub/API.hs+70−39

@@ -1,55 +1,86 @@

1module CompaREST.GitHub.API

2− ( mapComment,

2+ ( postStatus,

3− createOrUpdateComment,

3+ postStatusProcessing,

4 )

5where

6

7import CompaREST.GitHub.Action.Config

8−import Control.Monad

9import Control.Monad.Freer

8import Control.Monad.Freer

10import Control.Monad.Freer.GitHub

9import Control.Monad.Freer.GitHub

11import Control.Monad.Freer.Reader

10import Control.Monad.Freer.Reader

12−import Data.Foldable

11+import Control.Monad.IO.Class

12+import Data.Aeson

13+import qualified Data.ByteString.Lazy.Char8 as BSLC

14+import Data.OpenApi.Compare.Report

13import Data.Proxy

15import Data.Proxy

14import Data.Text (Text)

16import Data.Text (Text)

15−import qualified Data.Text as T

16−import qualified Data.Vector as V

17import GitHub

18−import qualified GitHub as GH

18+import GitHub.Data.Checks

19+import GitHub.Endpoints.Checks

19

20

21+postStatusProcessing ::

20−findComment :: Members '[GitHub, Reader Config] effs => Eff effs (Maybe GH.IssueComment)

22+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

21−findComment = do

23+ Eff effs ()

24+postStatusProcessing = do

22 Config {..} <- ask

25 Config {..} <- ask

23− comments <- sendGitHub $ GH.commentsR repoOwner repoName issue GH.FetchAll

26+ printJSON $

24− htmlComment <- getHTMLComment

27+ sendGitHub $

25− let tryStripPrefix :: GH.IssueComment -> Maybe GH.IssueComment

28+ checkR

26− tryStripPrefix c@GH.IssueComment {issueCommentBody = (T.stripSuffix htmlComment -> Just b)} =

29+ repoOwner

27− Just $ c {GH.issueCommentBody = b}

30+ repoName

28− tryStripPrefix _ = Nothing

31+ Check

29− pure . (V.!? 0) $ V.mapMaybe tryStripPrefix comments

32+ { checkName = mkName Proxy checkName

33+ , checkSha = sha

34+ , checkDetailsURL = Nothing

35+ , checkExternalId = Nothing

36+ , checkStatus = Just CheckInProgress

37+ , checkStartedAt = Nothing

38+ , checkConclusion = Nothing

39+ , checkCompletedAt = Nothing

40+ , checkOutput = Nothing

41+ , checkActions = Nothing

42+ }

30

43

44+postStatus ::

31−mapComment :: Members '[GitHub, Reader Config] effs => (Text -> Text) -> Eff effs ()

45+ (Members '[GitHub, Reader Config] effs, MonadIO (Eff effs)) =>

32−mapComment f = do

46+ -- | 'Nothing' means that there were no changes at all

33− findComment

47+ Maybe (Text, ReportStatus) ->

34− >>= traverse_

48+ Eff effs ()

35− ( \comment -> do

49+postStatus x = do

36− Config {..} <- ask

50+ let (body, (title, conclusion)) = case x of

37− htmlComment <- getHTMLComment

51+ Just (b, s) -> (b,) $ case s of

38− sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) ((<> htmlComment) . f $ GH.issueCommentBody comment)

52+ BreakingChanges -> ("⚠️ Breaking changes found!", CheckNeutral)

39− pure ()

53+ NoBreakingChanges -> ("No breaking changes found ✨", CheckSuccess)

40− )

54+ OnlyUnsupportedChanges -> ("🤷 Couldn't determine compatibility", CheckNeutral)

41−

55+ Nothing -> ("", ("✅ The API did not change", CheckSuccess))

42−createOrUpdateComment :: Members '[GitHub, Reader Config] effs => Text -> Eff effs ()

43−createOrUpdateComment body' = do

44 Config {..} <- ask

56 Config {..} <- ask

45− htmlComment <- getHTMLComment

57+ printJSON $

46− let body = body' <> htmlComment

58+ sendGitHub $

47− void $

59+ checkR

48− findComment >>= \case

60+ repoOwner

49− Just comment -> sendGitHub $ editCommentR repoOwner repoName (GH.mkId Proxy $ GH.issueCommentId comment) body

61+ repoName

50− Nothing -> sendGitHub $ createCommentR repoOwner repoName issue body

62+ Check

63+ { checkName = mkName Proxy checkName

64+ , checkSha = sha

65+ , checkDetailsURL = Nothing

66+ , checkExternalId = Nothing

67+ , checkStatus = Just CheckCompleted

68+ , checkStartedAt = Nothing

69+ , checkConclusion = Just conclusion

70+ , checkCompletedAt = Nothing

71+ , checkOutput =

72+ Just $

73+ CheckOutput

74+ { checkTitle = title

75+ , checkSummary = body

76+ , checkText = Nothing

77+ , checkAnnotations = Nothing

78+ , checkImages = Nothing

79+ }

80+ , checkActions = Nothing

81+ }

51

82

52−getHTMLComment :: Member (Reader Config) effs => Eff effs Text

83+printJSON :: MonadIO (Eff effs) => Eff effs Value -> Eff effs ()

53−getHTMLComment = do

84+printJSON m = do

54− name <- asks projectName

85+ x <- m

55− pure $ "\n\n"

86+ liftIO . BSLC.putStrLn $ encode x

github-action/CompaREST/GitHub/Action/Config.hs+10−6

@@ -8,16 +8,17 @@ import Data.Text (Text)

8import qualified Data.Text as T

9import qualified GitHub as GH

10

11+import Data.Functor

11import System.Envy

12import System.Envy

12

13

13data Config = Config

14data Config = Config

14 { githubToken :: GH.Auth

15 { githubToken :: GH.Auth

15 , repoOwner :: GH.Name GH.Owner

16 , repoOwner :: GH.Name GH.Owner

16 , repoName :: GH.Name GH.Repo

17 , repoName :: GH.Name GH.Repo

17− , issue :: GH.IssueNumber

18+ , checkName :: Text

18− , projectName :: Text

19 , footerText :: Text

20 , root :: FilePath

21+ , sha :: GH.Name GH.Commit

21 }

22 }

22

23

23instance FromEnv Config where

24instance FromEnv Config where

@@ -27,17 +28,20 @@ instance FromEnv Config where

27 T.split (== '/') <$> env "REPO" >>= \case

28 T.split (== '/') <$> env "REPO" >>= \case

28 [owner, name] -> pure (owner, name)

29 [owner, name] -> pure (owner, name)

29 _ -> fail "malformed repo"

30 _ -> fail "malformed repo"

30− issue <- GH.IssueNumber <$> env "PR_NUMBER"

31+ checkName <-

31− projectName <- env "PROJECT_NAME"

32+ envMaybe "PROJECT_NAME" <&> \case

33+ Just pName | not . T.null . T.strip $ pName -> "compaREST – " <> pName

34+ _ -> "compaREST"

32 footerText <- env "FOOTER"

35 footerText <- env "FOOTER"

33 root <- envMaybe "ROOT" .!= "."

36 root <- envMaybe "ROOT" .!= "."

37+ sha <- env "SHA"

34 pure $

38 pure $

35 Config

39 Config

36 { githubToken = token

40 { githubToken = token

37 , repoOwner = GH.mkName Proxy owner

41 , repoOwner = GH.mkName Proxy owner

38 , repoName = GH.mkName Proxy repo

42 , repoName = GH.mkName Proxy repo

39− , issue = issue

43+ , checkName = checkName

40− , projectName = projectName

41 , footerText = footerText

44 , footerText = footerText

42 , root = root

45 , root = root

46+ , sha = GH.mkName Proxy sha

43 }

47 }

github-action/GitHub/Data/Checks.hsnew file+173

@@ -0,0 +1,173 @@

1+module GitHub.Data.Checks

2+ ( Check (..),

3+ CheckStatus (..),

4+ CheckConclusion (..),

5+ CheckOutput (..),

6+ CheckAnnotation (..),

7+ CheckAnnotationLevel (..),

8+ CheckImage (..),

9+ CheckAction (..),

10+ )

11+where

12+

13+import Data.Aeson

14+import Data.Aeson.Types

15+import Data.Text (Text)

16+import Data.Vector (Vector)

17+import GHC.Generics (Generic)

18+import GitHub

19+import GitHub.Internal.Prelude (UTCTime)

20+

21+data Check = Check

22+ { checkName :: !(Name Check)

23+ , checkSha :: !(Name Commit)

24+ , checkDetailsURL :: !(Maybe URL)

25+ , checkExternalId :: !(Maybe (Id Check))

26+ , checkStatus :: !(Maybe CheckStatus)

27+ , checkStartedAt :: !(Maybe UTCTime)

28+ , checkConclusion :: !(Maybe CheckConclusion)

29+ , checkCompletedAt :: !(Maybe UTCTime)

30+ , checkOutput :: !(Maybe CheckOutput)

31+ , checkActions :: !(Maybe (Vector CheckAction))

32+ }

33+ deriving stock (Show, Eq, Ord, Generic)

34+

35+instance ToJSON Check where

36+ toJSON (Check n sha durl eid s sa c ca o a) =

37+ object'

38+ [ "name" .= n

39+ , "head_sha" .= sha

40+ , "details_url" .= durl

41+ , "external_id" .= eid

42+ , "status" .= s

43+ , "started_at" .= sa

44+ , "conclusion" .= c

45+ , "completed_at" .= ca

46+ , "output" .= o

47+ , "actions" .= a

48+ ]

49+

50+data CheckStatus

51+ = CheckQueued

52+ | CheckInProgress

53+ | CheckCompleted

54+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

55+

56+instance ToJSON CheckStatus where

57+ toJSON CheckQueued = String "queued"

58+ toJSON CheckInProgress = String "in_progress"

59+ toJSON CheckCompleted = String "completed"

60+

61+data CheckConclusion

62+ = CheckActionRequired

63+ | CheckCancelled

64+ | CheckFailure

65+ | CheckNeutral

66+ | CheckSuccess

67+ | CheckSkipped

68+ | CheckStale

69+ | CheckTimedOut

70+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

71+

72+instance ToJSON CheckConclusion where

73+ toJSON CheckActionRequired = String "action_required"

74+ toJSON CheckCancelled = String "cancelled"

75+ toJSON CheckFailure = String "failure"

76+ toJSON CheckNeutral = String "neutral"

77+ toJSON CheckSuccess = String "success"

78+ toJSON CheckSkipped = String "skipped"

79+ toJSON CheckStale = String "stale"

80+ toJSON CheckTimedOut = String "timed_out"

81+

82+data CheckOutput = CheckOutput

83+ { checkTitle :: !Text

84+ , checkSummary :: !Text

85+ , checkText :: !(Maybe Text)

86+ , checkAnnotations :: !(Maybe (Vector CheckAnnotation))

87+ , checkImages :: !(Maybe (Vector CheckImage))

88+ }

89+ deriving stock (Show, Eq, Ord, Generic)

90+

91+instance ToJSON CheckOutput where

92+ toJSON (CheckOutput t s txt a i) =

93+ object'

94+ [ "title" .= t

95+ , "summary" .= s

96+ , "text" .= txt

97+ , "annotations" .= a

98+ , "images" .= i

99+ ]

100+

101+data CheckAnnotation = CheckAnnotation

102+ { checkPath :: !Text

103+ , checkStartLine :: !Int

104+ , checkEndLine :: !Int

105+ , checkStartColumn :: !(Maybe Int)

106+ , checkEndColumn :: !(Maybe Int)

107+ , checkAnnotationLevel :: !CheckAnnotationLevel

108+ , checkMessage :: !Text

109+ , checkTitle :: !(Maybe Text)

110+ , checkRawDetails :: !(Maybe Text)

111+ }

112+ deriving stock (Show, Eq, Ord, Generic)

113+

114+instance ToJSON CheckAnnotation where

115+ toJSON (CheckAnnotation p sl el sc ec al m t rd) =

116+ object'

117+ [ "path" .= p

118+ , "start_line" .= sl

119+ , "end_line" .= el

120+ , "start_column" .= sc

121+ , "end_column" .= ec

122+ , "annotation_level" .= al

123+ , "message" .= m

124+ , "title" .= t

125+ , "raw_details" .= rd

126+ ]

127+

128+data CheckAnnotationLevel

129+ = NoticeAnnotation

130+ | WarningAnnotation

131+ | FailureAnnotation

132+ deriving stock (Show, Enum, Bounded, Eq, Ord, Generic)

133+

134+instance ToJSON CheckAnnotationLevel where

135+ toJSON NoticeAnnotation = String "notice"

136+ toJSON WarningAnnotation = String "warning"

137+ toJSON FailureAnnotation = String "failure"

138+

139+data CheckImage = CheckImage

140+ { checkImageAlt :: !Text

141+ , checkImageURL :: !URL

142+ , checkImageCaption :: !(Maybe Text)

143+ }

144+ deriving stock (Show, Eq, Ord, Generic)

145+

146+instance ToJSON CheckImage where

147+ toJSON (CheckImage a url c) =

148+ object'

149+ [ "alt" .= a

150+ , "image_url" .= url

151+ , "caption" .= c

152+ ]

153+

154+data CheckAction = CheckAction

155+ { checkActionLabel :: !Text

156+ , checkActionDescription :: !Text

157+ , checkActionIdentifier :: !Text

158+ }

159+ deriving stock (Show, Eq, Ord, Generic)

160+

161+instance ToJSON CheckAction where

162+ toJSON (CheckAction l d i) =

163+ object'

164+ [ "label" .= l

165+ , "description" .= d

166+ , "identifier" .= i

167+ ]

168+

169+object' :: [Pair] -> Value

170+object' = object . filter notNull

171+ where

172+ notNull (_, Null) = False

173+ notNull (_, _) = True

github-action/GitHub/Endpoints/Checks.hsnew file+12

@@ -0,0 +1,12 @@

1+module GitHub.Endpoints.Checks

2+ ( checkR,

3+ )

4+where

5+

6+import Data.Aeson

7+import GitHub

8+import GitHub.Data.Checks

9+

10+checkR :: Name Owner -> Name Repo -> Check -> Request 'RW Value

11+checkR user repo =

12+ command Post ["repos", toPathPart user, toPathPart repo, "check-runs"] . encode

github-action/Main.hs+20−35

@@ -9,6 +9,7 @@ import Control.Monad.Freer.GitHub

9import Control.Monad.Freer.Reader

10import Data.OpenApi.Compare.Run

11import Data.Text (Text)

12+import qualified Data.Text as T

12import qualified Data.Yaml.Aeson as Yaml

13import qualified Data.Yaml.Aeson as Yaml

13import qualified GitHub as GH

14import qualified GitHub as GH

14import System.Environment

15import System.Environment

@@ -22,13 +23,18 @@ import Text.Pandoc.Writers

22main :: IO ()

23main :: IO ()

23main = do

24main = do

24 cfg <- decodeEnv >>= either error pure

25 cfg <- decodeEnv >>= either error pure

26+ case sha cfg of

27+ x | T.null . T.strip . GH.untagName $ x -> do

28+ putStrLn "SHA not specified. Exiting without doing anything."

29+ pure ()

30+ _ ->

25− getArgs >>= \case

31+ getArgs >>= \case

26− ["pre"] -> runPre cfg

32+ ["pre"] -> runPre cfg

27− ["run"] -> do

33+ ["run"] -> do

28− oldFile <- getEnv "OLD"

34+ oldFile <- getEnv "OLD"

29− newFile <- getEnv "NEW"

35+ newFile <- getEnv "NEW"

30− runRun cfg (root cfg </> oldFile) (root cfg </> newFile)

36+ runRun cfg (root cfg </> oldFile) (root cfg </> newFile)

31− _ -> error "Invalid arguments."

37+ _ -> error "Invalid arguments."

32

38

33runner :: Config -> Eff '[GitHub, Error GH.Error, Reader Config, IO] a -> IO a

39runner :: Config -> Eff '[GitHub, Error GH.Error, Reader Config, IO] a -> IO a

34runner cfg =

40runner cfg =

@@ -37,10 +43,7 @@ runner cfg =

37 . runGitHub (githubToken cfg)

43 . runGitHub (githubToken cfg)

38

44

39runPre :: Config -> IO ()

45runPre :: Config -> IO ()

40−runPre cfg =

46+runPre cfg = runner cfg postStatusProcessing

41− runner cfg $

42− mapComment

43− (markdown (header 4 "⏳ Report might not be accurate. Attempting to update." <> horizontalRule) <>)

44

47

45runRun :: Config -> FilePath -> FilePath -> IO ()

48runRun :: Config -> FilePath -> FilePath -> IO ()

46runRun cfg old' new' = runner cfg $ do

49runRun cfg old' new' = runner cfg $ do

@@ -53,31 +56,13 @@ runRun cfg old' new' = runner cfg $ do

53 }

56 }

54 (report, status) = runReport reportConfig (old, new)

57 (report, status) = runReport reportConfig (old, new)

55

58

56− summaryDetail s d =

59+ body = markdown report <> "\n\n" <> footerText cfg

57− rawHtml "<details>"

58− <> rawHtml "<summary>"

59− <> s

60− <> rawHtml "</summary>"

61− <> d

62− <> rawHtml "</details>"

63− where

64− rawHtml = rawBlock "html"

65

60

66− message =

61+ result =

67− header 3 (text $ "⛄ compaREST – " <> projectName cfg)

68− <> if old == new

62+ if old == new

69− then header 1 "✅ The API did not change"

63+ then Nothing

70− else

71− header

72− 1

73− ( case status of

64+ else Just (body, status)

74− BreakingChanges -> "⚠️ Breaking changes found!"

65+ postStatus result

75− NoBreakingChanges -> "No breaking changes found ✨"

76− OnlyUnsupportedChanges -> "🤷 Couldn't determine compatibility"

77− )

78− <> summaryDetail (plain "ℹ️ Details") report

79− messageBody = markdown message <> "\n\n" <> footerText cfg

80− createOrUpdateComment messageBody

81

66

82markdown :: Blocks -> Text

67markdown :: Blocks -> Text

83markdown =

68markdown =

nix/ci.nixnew file+11

@@ -0,0 +1,11 @@

1+{ sources ? import ./sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+

5+let

6+ yq = import ./yq.nix { inherit pkgs; };

7+ diff-yaml = import ./diff-yaml.nix { inherit pkgs; };

8+in

9+pkgs.mkShell {

10+ packages = [ pkgs.haskellPackages.fourmolu diff-yaml yq ];

11+}

nix/diff-yaml.nixnew file+20

@@ -0,0 +1,20 @@

1+{ pkgs ? import <nixpkgs> {} }:

2+

3+let

4+ inherit (pkgs) stdenv;

5+ yq = import ./yq.nix { inherit pkgs; };

6+in

7+stdenv.mkDerivation {

8+ name = "diff-yaml";

9+

10+ src = ../scripts/diff-yaml;

11+

12+ buildInputs = [ pkgs.bash yq ];

13+

14+ phases = [ "installPhase" ];

15+

16+ installPhase = ''

17+ mkdir -p $out/bin

18+ cp $src $out/bin/diff-yaml

19+ '';

20+}

nix/shell.nixnew file+11

@@ -0,0 +1,11 @@

1+{ sources ? import ./sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+

5+let

6+ patched-yq = import ./yq.nix { inherit pkgs; };

7+ diffYaml = import ./diff-yaml.nix { inherit pkgs; };

8+in

9+pkgs.mkShell {

10+ buildInputs = with pkgs; [ pkg-config diffYaml patched-yq zlib ];

11+}

nix/sources.json+22−10

@@ -5,10 +5,10 @@

5 "homepage": "https://input-output-hk.github.io/haskell.nix",

6 "owner": "input-output-hk",

7 "repo": "haskell.nix",

8− "rev": "1992b910e9b4d880e1f4639f4fe7266bceb9a5ad",

8+ "rev": "d7f95903c84a5a50d6fe0844280da82c3c81680a",

9− "sha256": "15w3wixjnb52f7cj3s94fy0zc0l1gc94p3n2wyq3qqxj10hvirfw",

9+ "sha256": "02870rk4sx44lwwa0k20iwdhqcx0ayz34yb3b0qy045p22q45815",

10 "type": "tarball",

11− "url": "https://github.com/input-output-hk/haskell.nix/archive/1992b910e9b4d880e1f4639f4fe7266bceb9a5ad.tar.gz",

11+ "url": "https://github.com/input-output-hk/haskell.nix/archive/d7f95903c84a5a50d6fe0844280da82c3c81680a.tar.gz",

12 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

13 },

14 "niv": {

@@ -17,22 +17,34 @@

17 "homepage": "https://github.com/nmattia/niv",

18 "owner": "nmattia",

19 "repo": "niv",

20− "rev": "e0ca65c81a2d7a4d82a189f1e23a48d59ad42070",

20+ "rev": "f7c538837892dd2eb83567c9f380a11efb59b53f",

21− "sha256": "1pq9nh1d8nn3xvbdny8fafzw87mj7gsmp6pxkdl65w2g18rmcmzx",

21+ "sha256": "0xl33k24vfc29cg9lnp95kvcq69qbq5fzb7jk9ig4lgrhaarh651",

22 "type": "tarball",

23− "url": "https://github.com/nmattia/niv/archive/e0ca65c81a2d7a4d82a189f1e23a48d59ad42070.tar.gz",

23+ "url": "https://github.com/nmattia/niv/archive/f7c538837892dd2eb83567c9f380a11efb59b53f.tar.gz",

24 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

25 },

26 "nix-filter": {

27− "branch": "master",

27+ "branch": "main",

28 "description": "a small self-container source filtering lib",

29 "homepage": "",

30 "owner": "numtide",

31 "repo": "nix-filter",

32− "rev": "3c9e33ed627e009428197b07216613206f06ed80",

32+ "rev": "3342559a24e85fc164b295c3444e8a139924675b",

33− "sha256": "19w142crrkywxynmyw4rhz4nglrg64yjawfkw3j91qwkwbfjds84",

33+ "sha256": "08xia32g5jzaiyhfl3kzxslzbr4w1i56i0mhy5gpfggv8gqy8sym",

34+ "type": "tarball",

35+ "url": "https://github.com/numtide/nix-filter/archive/3342559a24e85fc164b295c3444e8a139924675b.tar.gz",

36+ "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37+ },

38+ "nixpkgs": {

39+ "branch": "master",

40+ "description": "Nix Packages collection",

41+ "homepage": "",

42+ "owner": "NixOS",

43+ "repo": "nixpkgs",

44+ "rev": "bf038bd724982de67a2ee9a6b2f1fcb7d6a87bd7",

45+ "sha256": "0ivvwdmg9fipj6ylq5ipxqpb0xnz6hsx3lyn377jacfpiqi9w0cv",

34 "type": "tarball",

46 "type": "tarball",

35− "url": "https://github.com/numtide/nix-filter/archive/3c9e33ed627e009428197b07216613206f06ed80.tar.gz",

47+ "url": "https://github.com/NixOS/nixpkgs/archive/bf038bd724982de67a2ee9a6b2f1fcb7d6a87bd7.tar.gz",

36 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

48 "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"

37 }

49 }

38}

50}

nix/yq.nixnew file+26

@@ -0,0 +1,26 @@

1+{ pkgs ? import <nixpkgs> {} }:

2+

3+# Make yq work inside whatever `stack test` launches.

4+# Nuke this when https://github.com/kislyuk/yq/pull/193 is merged

5+# and nixpkgs includes that fix.

6+

7+let

8+ yq-patch = pkgs.writeText "yq-tty-fix.patch" ''

9+diff --git a/yq/__init__.py b/yq/__init__.py

10+index d95ac4b..ae7d59e 100644

11+--- a/yq/__init__.py

12++++ b/yq/__init__.py

13+@@ -110,7 +110,7 @@ def cli(args=None, input_format="yaml", program_name="yq"):

14+ in_place = args.in_place

15+ delattr(args, "in_place")

16+

17+- if sys.stdin.isatty() and not args.input_streams:

18++ if (sys.stdin is None or sys.stdin.isatty()) and not args.input_streams:

19+ parser.print_help()

20+ sys.exit(2)

21+ elif not args.input_streams:

22+ '';

23+in

24+pkgs.yq.overrideAttrs (final: old: {

25+ patches = old.patches ++ [ yq-patch ];

26+})

scripts/diff-yamlnew file+35

@@ -0,0 +1,35 @@

1+#!/usr/bin/env bash

2+set -e

3+

4+# Normalise YAML files passed as inputs, then run diff on them.

5+

6+check_util() {

7+ local util=$1

8+

9+ if [ -z $util ]; then

10+ echo "Error: $util not found in PATH"

11+ exit 1

12+ fi

13+}

14+

15+DIFF=`which diff`

16+check_util $DIFF

17+

18+YQ=`which yq`

19+check_util $YQ

20+

21+# Only normalise YAML files.

22+# Print anything else as is.

23+normalise() {

24+ local file=$1

25+ local contents=($YQ -y -S '.' $file)

26+

27+ # if $contents contains actual YAML data, print it

28+ if [[ $? == 0 ]]; then

29+ echo $contents

30+ else

31+ cat $file

32+ fi

33+}

34+

35+$DIFF -u <(normalise $1) <(normalise $2)

src/Data/HList.hs+11−11

@@ -1,11 +1,11 @@

1module Data.HList

2− ( Has

2+ ( Has,

3− , HasAll

3+ HasAll,

4− , getH

4+ getH,

5− , HList (..)

5+ HList (..),

6− , singletonH

6+ singletonH,

7− , ReassembleHList

7+ ReassembleHList,

8− , reassemble

8+ reassemble,

9 )

10where

11

@@ -40,8 +40,8 @@ instance (Has' x xs t, HeadEq x (y : xs) ~ 'False) => Has' x (y ': xs) 'False wh

40 {-# INLINE getH #-}

41

42instance

43− TypeError ('ShowType x ':<>: 'Text " is not a part of the list.")

43+ TypeError ( 'ShowType x ':<>: 'Text " is not a part of the list.") =>

44− => Has' x '[] 'False

44+ Has' x '[] 'False

45 where

46 getH HNil = undefined

47 {-# INLINE getH #-}

@@ -74,8 +74,8 @@ instance ReassembleHList' (x ': xs) '[] 'False where

74 {-# INLINE reassemble #-}

75

76instance

77− (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False)

77+ (Has y xs, ReassembleHList' xs ys f, (xs == (y ': ys)) ~ 'False) =>

78− => ReassembleHList' xs (y ': ys) 'False

78+ ReassembleHList' xs (y ': ys) 'False

79 where

80 reassemble xs = getH @y xs `HCons` reassemble xs

81 {-# INLINE reassemble #-}

src/Data/OpenApi/Compare/Behavior.hs+11−11

@@ -1,15 +1,15 @@

1module Data.OpenApi.Compare.Behavior

2− ( BehaviorLevel (..)

2+ ( BehaviorLevel (..),

3− , Behavable (..)

3+ Behavable (..),

4− , IssueKind (..)

4+ IssueKind (..),

5− , Issuable (..)

5+ Issuable (..),

6− , Orientation (..)

6+ Orientation (..),

7− , toggleOrientation

7+ toggleOrientation,

8− , Behavior

8+ Behavior,

9− , AnIssue (..)

9+ AnIssue (..),

10− , withClass

10+ withClass,

11− , anIssueKind

11+ anIssueKind,

12− , relatedAnIssues

12+ relatedAnIssues,

13 )

14where

15

src/Data/OpenApi/Compare/Common.hs+1−1

@@ -1,5 +1,5 @@

1module Data.OpenApi.Compare.Common

2− ( zipAll

2+ ( zipAll,

3 )

4where

5

src/Data/OpenApi/Compare/Formula.hs+31−21

@@ -1,14 +1,15 @@

1module Data.OpenApi.Compare.Formula

2− ( FormulaF

2+ ( FormulaF,

3− , VarRef

3+ VarRef,

4− , variable

4+ variable,

5− , eitherOf

5+ eitherOf,

6− , anError

6+ anError,

7− , errors

7+ errors,

8− , calculate

8+ calculate,

9− , maxFixpoint

9+ maxFixpoint,

10− , mapErrors

10+ mapErrors,

11+ )

11− ) where

12+where

12

13

13import Data.Kind

14import Data.Kind

14import qualified Data.List.NonEmpty as NE

15import qualified Data.List.NonEmpty as NE

@@ -24,15 +25,24 @@ type VarRef = Int

24-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.

25-- fixpoints always exist, i.e. that @x = f x@ has at least one solution.

25data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

26data FormulaF (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: Type) where

26 Result :: a -> FormulaF q f r a

27 Result :: a -> FormulaF q f r a

28+ Errors ::

27− Errors :: !(P.PathsPrefixTree q f r) -> FormulaF q f r a

29+ !(P.PathsPrefixTree q f r) ->

28− -- ^ invariant: never empty

30+ -- | invariant: never empty

31+ FormulaF q f r a

32+ Apply ::

29− Apply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

33+ FormulaF q f r (b -> c) ->

34+ FormulaF q f r b ->

35+ (c -> a) ->

30− -- ^ invariant: at least one of LHS and RHS is not 'Errors', and they are

36+ -- | invariant: at least one of LHS and RHS is not 'Errors', and they are

31 -- both not 'Result'

37 -- both not 'Result'

38+ FormulaF q f r a

39+ SelectFirst ::

32− SelectFirst :: NE.NonEmpty (SomeFormulaF b)

40+ NE.NonEmpty (SomeFormulaF b) ->

33− -> !(P.PathsPrefixTree q f r) -> (b -> a) -> FormulaF q f r a

41+ !(P.PathsPrefixTree q f r) ->

42+ (b -> a) ->

34− -- ^ invariant: the list doesn't contain any 'Result's, 'Errors' or

43+ -- | invariant: the list doesn't contain any 'Result's, 'Errors' or

35 -- 'SelectFirst'

44 -- 'SelectFirst'

45+ FormulaF q f r a

36 Variable :: !VarRef -> a -> FormulaF q f r a

46 Variable :: !VarRef -> a -> FormulaF q f r a

37

47

38mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

48mkApply :: FormulaF q f r (b -> c) -> FormulaF q f r b -> (c -> a) -> FormulaF q f r a

@@ -44,13 +54,13 @@ mkApply f x h = Apply f x h

44mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a

54mkSelectFirst :: [SomeFormulaF b] -> P.PathsPrefixTree q f r -> (b -> a) -> FormulaF q f r a

45mkSelectFirst fs allE h = case foldMap check fs of

55mkSelectFirst fs allE h = case foldMap check fs of

46 (First (Just x), _) -> Result (h x)

56 (First (Just x), _) -> Result (h x)

47− (First Nothing, x:xs) -> SelectFirst (x NE.:| xs) allE h

57+ (First Nothing, x : xs) -> SelectFirst (x NE.:| xs) allE h

48 (First Nothing, []) -> Errors allE

58 (First Nothing, []) -> Errors allE

49 where

59 where

50 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

60 check (SomeFormulaF (Result x)) = (First (Just x), mempty)

51 check (SomeFormulaF (Errors _)) = (mempty, mempty)

61 check (SomeFormulaF (Errors _)) = (mempty, mempty)

52− check (SomeFormulaF (SelectFirst xs _ h'))

62+ check (SomeFormulaF (SelectFirst xs _ h')) =

53− = (mempty, NE.toList (fmap (fmap h') xs))

63+ (mempty, NE.toList (fmap (fmap h') xs))

54 check x = (mempty, [x])

64 check x = (mempty, [x])

55

65

56data SomeFormulaF (a :: Type) where

66data SomeFormulaF (a :: Type) where

@@ -96,7 +106,7 @@ calculate (Apply f x h) = case calculate f of

96 Right x' -> Right (h (f' x'))

106 Right x' -> Right (h (f' x'))

97calculate (SelectFirst xs e h) = go (NE.toList xs)

107calculate (SelectFirst xs e h) = go (NE.toList xs)

98 where

108 where

99− go (SomeFormulaF r:rs) = case calculate r of

109+ go (SomeFormulaF r : rs) = case calculate r of

100 Left _ -> go rs

110 Left _ -> go rs

101 Right x -> Right (h x)

111 Right x -> Right (h x)

102 go [] = Left e

112 go [] = Left e

src/Data/OpenApi/Compare/Memo.hs+104−66

@@ -1,22 +1,24 @@

1{-# LANGUAGE AllowAmbiguousTypes #-}

2+

2-- | Utilities for effectfully memoizing other, more effectful functions.

3-- | Utilities for effectfully memoizing other, more effectful functions.

3module Data.OpenApi.Compare.Memo

4module Data.OpenApi.Compare.Memo

4− ( MonadMemo

5+ ( MonadMemo,

5− , MemoState

6+ MemoState,

6− , runMemo

7+ runMemo,

7− , modifyMemoNonce

8+ modifyMemoNonce,

8− , KnotTier(..)

9+ KnotTier (..),

9− , unknot

10+ unknot,

10− , memoWithKnot

11+ memoWithKnot,

11− , memoTaggedWithKnot

12+ memoTaggedWithKnot,

13+ )

12− ) where

14+where

13

15

14import Control.Monad.State

16import Control.Monad.State

15import Data.Dynamic

17import Data.Dynamic

16import qualified Data.Map as M

18import qualified Data.Map as M

17import Data.Tagged

19import Data.Tagged

18−import Data.Void

19import qualified Data.TypeRepMap as T

20import qualified Data.TypeRepMap as T

21+import Data.Void

20import Type.Reflection

22import Type.Reflection

21

23

22data Progress a = Finished a | Started | TyingKnot Dynamic

24data Progress a = Finished a | Started | TyingKnot Dynamic

@@ -29,16 +31,23 @@ data MemoState s = MemoState s (T.TypeRepMap MemoMap)

29-- | An effectful memoization monad.

31-- | An effectful memoization monad.

30type MonadMemo s m = MonadState (MemoState s) m

32type MonadMemo s m = MonadState (MemoState s) m

31

33

32−memoStateLookup

34+memoStateLookup ::

35+ forall k v s.

33− :: forall k v s. (Typeable k, Typeable v, Ord k)

36+ (Typeable k, Typeable v, Ord k) =>

37+ k ->

38+ MemoState s ->

34− => k -> MemoState s -> Maybe (Progress v)

39+ Maybe (Progress v)

35memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of

40memoStateLookup k (MemoState _ t) = case T.lookup @(k, v) t of

36 Just (MemoMap m) -> M.lookup k m

41 Just (MemoMap m) -> M.lookup k m

37 Nothing -> Nothing

42 Nothing -> Nothing

38

43

39−memoStateInsert

44+memoStateInsert ::

45+ forall k v s.

40− :: forall k v s. (Typeable k, Typeable v, Ord k)

46+ (Typeable k, Typeable v, Ord k) =>

47+ k ->

48+ Progress v ->

41− => k -> Progress v -> MemoState s -> MemoState s

49+ MemoState s ->

50+ MemoState s

42memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t

51memoStateInsert k x (MemoState s t) = MemoState s $ T.insert (MemoMap m'') t

43 where

52 where

44 m'' = M.insert k x m'

53 m'' = M.insert k x m'

@@ -59,19 +68,23 @@ runMemo s = (`evalStateT` MemoState s T.empty)

59-- | A description of how to effectfully tie knots in type @v@, using the @m@

68-- | A description of how to effectfully tie knots in type @v@, using the @m@

60-- monad, and by sharing some @d@ data among the recursive instances.

69-- monad, and by sharing some @d@ data among the recursive instances.

61data KnotTier v d m = KnotTier

70data KnotTier v d m = KnotTier

62− { onKnotFound :: m d -- ^ Create some data that will be connected to this knot

71+ { -- | Create some data that will be connected to this knot

72+ onKnotFound :: m d

63− , onKnotUsed :: d -> m v -- ^ This is what the knot will look like as a value

73+ , -- | This is what the knot will look like as a value

64 -- to the inner computations

74 -- to the inner computations

75+ onKnotUsed :: d -> m v

65− , tieKnot :: d -> v -> m v -- ^ Once we're done and we're outside, tie the

76+ , -- | Once we're done and we're outside, tie the

66 -- knot using the datum

77 -- knot using the datum

78+ tieKnot :: d -> v -> m v

67 }

79 }

68

80

69unknot :: KnotTier v Void m

81unknot :: KnotTier v Void m

82+unknot =

70−unknot = KnotTier

83+ KnotTier

71− { onKnotFound = error "Recursion detected"

84+ { onKnotFound = error "Recursion detected"

72− , onKnotUsed = absurd

85+ , onKnotUsed = absurd

73− , tieKnot = absurd

86+ , tieKnot = absurd

74− }

87+ }

75

88

76-- | Run a potentially recursive computation. The provided key will be used to

89-- | Run a potentially recursive computation. The provided key will be used to

77-- refer to the result of this computation. If during the computation, another

90-- refer to the result of this computation. If during the computation, another

@@ -80,47 +93,72 @@ unknot = KnotTier

80--

93--

81-- If another attempt to run the computation with the same key is made

94-- If another attempt to run the computation with the same key is made

82-- *after we're done*, we will return the memoized value.

95-- *after we're done*, we will return the memoized value.

83−memoWithKnot

96+memoWithKnot ::

84− :: forall k v d m s.

97+ forall k v d m s.

85− (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m)

98+ (Typeable k, Typeable v, Typeable d, Ord k, MonadMemo s m) =>

86− => KnotTier v d m

99+ KnotTier v d m ->

87− -> m v -- ^ the computation to memoize

100+ -- | the computation to memoize

101+ m v ->

88− -> k -- ^ key for memoization

102+ -- | key for memoization

103+ k ->

89− -> m v

104+ m v

105+memoWithKnot tier f k =

90−memoWithKnot tier f k = memoStateLookup @k @v k <$> get >>= \case

106+ memoStateLookup @k @v k <$> get >>= \case

91− Just (Finished v) -> pure v

107+ Just (Finished v) -> pure v

92− Just Started -> do

108+ Just Started -> do

93− d <- onKnotFound tier

109+ d <- onKnotFound tier

94− modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)

110+ modify $ memoStateInsert @k @v k (TyingKnot $ toDyn d)

95− onKnotUsed tier d

111+ onKnotUsed tier d

96− Just (TyingKnot dyn) -> case fromDynamic dyn of

112+ Just (TyingKnot dyn) -> case fromDynamic dyn of

97− Just d -> onKnotUsed tier d

113+ Just d -> onKnotUsed tier d

114+ Nothing ->

115+ error $

98− Nothing -> error $ "Type mismatch when examining the knot of "

116+ "Type mismatch when examining the knot of "

99− <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)

117+ <> show (typeRep @(k -> v))

118+ <> ": expected "

119+ <> show (typeRep @d)

120+ <> ", got "

100− <> ", got " <> show (dynTypeRep dyn)

121+ <> show (dynTypeRep dyn)

101− Nothing -> do

122+ Nothing -> do

102− modify $ memoStateInsert @k @v k Started

123+ modify $ memoStateInsert @k @v k Started

103− v <- f

124+ v <- f

125+ v' <-

104− v' <- memoStateLookup @k @v k <$> get >>= \case

126+ memoStateLookup @k @v k <$> get >>= \case

105− Just Started -> pure v

127+ Just Started -> pure v

106− Just (TyingKnot dyn) -> case fromDynamic dyn of

128+ Just (TyingKnot dyn) -> case fromDynamic dyn of

107− Just d -> tieKnot tier d v

129+ Just d -> tieKnot tier d v

130+ Nothing ->

131+ error $

108− Nothing -> error $ "Type mismatch when tying the knot of "

132+ "Type mismatch when tying the knot of "

109− <> show (typeRep @(k -> v)) <> ": expected " <> show (typeRep @d)

133+ <> show (typeRep @(k -> v))

134+ <> ": expected "

135+ <> show (typeRep @d)

136+ <> ", got "

110− <> ", got " <> show (dynTypeRep dyn)

137+ <> show (dynTypeRep dyn)

138+ Just (Finished _) ->

139+ error $

111− Just (Finished _) -> error $ "Unexpected Finished when memoizing "

140+ "Unexpected Finished when memoizing "

112− <> show (typeRep @(k -> v))

141+ <> show (typeRep @(k -> v))

113− Nothing -> pure v

142+ Nothing -> pure v

114− -- Normally this would be an error, but the underlying monad can refuse

143+ -- Normally this would be an error, but the underlying monad can refuse

115− -- to remember memoization state

144+ -- to remember memoization state

116− modify $ memoStateInsert @k @v k (Finished v')

145+ modify $ memoStateInsert @k @v k (Finished v')

117− pure v'

146+ pure v'

118

147

119-- | Disambiguate memoized computations with an arbitrary tag.

148-- | Disambiguate memoized computations with an arbitrary tag.

120−memoTaggedWithKnot

149+memoTaggedWithKnot ::

121− :: forall t k v d m s.

150+ forall t k v d m s.

122− ( Typeable t, Typeable k, Typeable v, Typeable d

151+ ( Typeable t

152+ , Typeable k

153+ , Typeable v

154+ , Typeable d

155+ , Ord k

123− , Ord k, MonadMemo s m )

156+ , MonadMemo s m

157+ ) =>

124− => KnotTier v d m -> m v -> k -> m v

158+ KnotTier v d m ->

159+ m v ->

160+ k ->

161+ m v

162+memoTaggedWithKnot tier f k =

125−memoTaggedWithKnot tier f k = withTypeable (typeRepKind $ typeRep @t) $

163+ withTypeable (typeRepKind $ typeRep @t) $

126− memoWithKnot tier f (Tagged @t k)

164+ memoWithKnot tier f (Tagged @t k)

src/Data/OpenApi/Compare/Paths.hs+9−9

@@ -2,17 +2,17 @@

2-- collection of datatypes that "contain" eachother in some form of tree

3-- structure.

4module Data.OpenApi.Compare.Paths

5− ( NiceQuiver

5+ ( NiceQuiver,

6− , AdditionalQuiverConstraints

6+ AdditionalQuiverConstraints,

7− , Paths (..)

7+ Paths (..),

8− , DiffPaths (..)

8+ DiffPaths (..),

9− , catDiffPaths

9+ catDiffPaths,

10− , AnItem (..)

10+ AnItem (..),

11− , step

11+ step,

12

13 -- * Reexports

14− , (>>>)

14+ (>>>),

15− , (<<<)

15+ (<<<),

16 )

17where

18

src/Data/OpenApi/Compare/PathsPrefixTree.hs+42−41

@@ -1,29 +1,30 @@

1{-# LANGUAGE QuantifiedConstraints #-}

2

3module Data.OpenApi.Compare.PathsPrefixTree

4− ( PathsPrefixTree (PathsPrefixNode)

4+ ( PathsPrefixTree (PathsPrefixNode),

5− , AStep (..)

5+ AStep (..),

6− , empty

6+ empty,

7− , singleton

7+ singleton,

8− , fromList

8+ fromList,

9− , null

9+ null,

10− , foldWith

10+ foldWith,

11− , toList

11+ toList,

12− , filter

12+ filter,

13− , filterWithKey

13+ filterWithKey,

14− , takeSubtree

14+ takeSubtree,

15− , lookup

15+ lookup,

16− , embed

16+ embed,

17− , size

17+ size,

18− , partition

18+ partition,

19− , map

19+ map,

20 )

21where

22

23import Control.Monad

24import Data.Aeson

25import Data.Foldable hiding (null, toList)

26−import qualified Data.HashMap.Strict as HM

26+import qualified Data.Aeson.Key as Key

27+import qualified Data.Aeson.KeyMap as KeyMap

27import Data.Kind

28import Data.Kind

28import qualified Data.Map as M

29import qualified Data.Map as M

29import Data.Monoid

30import Data.Monoid

@@ -35,7 +36,7 @@ import qualified Data.TypeRepMap as TRM

35import qualified Data.Vector as V

36import qualified Data.Vector as V

36import qualified GHC.Exts as Exts

37import qualified GHC.Exts as Exts

37import Type.Reflection

38import Type.Reflection

38−import Prelude hiding (filter, map, null, lookup)

39+import Prelude hiding (filter, lookup, map, null)

39

40

40-- | A list of @AnItem r f@, but optimized into a prefix tree.

41-- | A list of @AnItem r f@, but optimized into a prefix tree.

41data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree

42data PathsPrefixTree (q :: k -> k -> Type) (f :: k -> Type) (r :: k) = PathsPrefixTree

@@ -102,11 +103,11 @@ deriving stock instance Eq (PathsPrefixTree q f a)

102

103

103-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

104-- Kind of orphan. Treat the map as an infinite tuple of @Maybe (f a)@'s, where

104-- the components are ordered by the @SomeTypeRep@ of the @a@.

105-- the components are ordered by the @SomeTypeRep@ of the @a@.

105−compareTRM

106+compareTRM ::

106− :: (forall a. Typeable a => Ord (f a))

107+ (forall a. Typeable a => Ord (f a)) =>

107− => TRM.TypeRepMap f

108+ TRM.TypeRepMap f ->

108− -> TRM.TypeRepMap f

109+ TRM.TypeRepMap f ->

109− -> Ordering

110+ Ordering

110compareTRM s1 s2 =

111compareTRM s1 s2 =

111 foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys

112 foldMap (\k -> compareMaybe compareW (M.lookup k m1) (M.lookup k m2)) mKeys

112 where

113 where

@@ -116,11 +117,11 @@ compareTRM s1 s2 =

116 compareMaybe _ Nothing (Just _) = LT

117 compareMaybe _ Nothing (Just _) = LT

117 compareMaybe _ (Just _) Nothing = GT

118 compareMaybe _ (Just _) Nothing = GT

118 compareMaybe cmp (Just x) (Just y) = cmp x y

119 compareMaybe cmp (Just x) (Just y) = cmp x y

119− compareW

120+ compareW ::

120− :: (forall a. Typeable a => Ord (f a))

121+ (forall a. Typeable a => Ord (f a)) =>

121− => TRM.WrapTypeable f

122+ TRM.WrapTypeable f ->

122− -> TRM.WrapTypeable f

123+ TRM.WrapTypeable f ->

123− -> Ordering

124+ Ordering

124 compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))

125 compareW (TRM.WrapTypeable (x :: f a)) (TRM.WrapTypeable (y :: f b))

125 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y

126 | Just Refl <- testEquality (typeRep @a) (typeRep @b) = compare x y

126 | otherwise = EQ -- unreachable

127 | otherwise = EQ -- unreachable

@@ -172,10 +173,10 @@ instance Monoid (ASet a) where

172 mempty = AnEmptySet

173 mempty = AnEmptySet

173

174

174data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

175data AStep (q :: k -> k -> Type) (f :: k -> Type) (r :: k) (a :: k) where

175− AStep

176+ AStep ::

176− :: NiceQuiver q r a =>

177+ NiceQuiver q r a =>

177− !(M.Map (q r a) (PathsPrefixTree q f a))

178+ !(M.Map (q r a) (PathsPrefixTree q f a)) ->

178− -> AStep q f r a

179+ AStep q f r a

179

180

180mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a

181mapAStep :: (forall x. f x -> f x) -> AStep q f r a -> AStep q f r a

181mapAStep f (AStep m) = AStep $ M.map (map f) m

182mapAStep f (AStep m) = AStep $ M.map (map f) m

@@ -215,12 +216,12 @@ null :: PathsPrefixTree q f r -> Bool

215null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)

216null (PathsPrefixTree AnEmptySet s) = all (\(TRM.WrapTypeable (AStep x)) -> all null x) (Exts.toList s)

216null _ = False

217null _ = False

217

218

218−foldWith

219+foldWith ::

219− :: forall q f m r.

220+ forall q f m r.

220− Monoid m

221+ Monoid m =>

221− => (forall a. Ord (f a) => Paths q r a -> f a -> m)

222+ (forall a. Ord (f a) => Paths q r a -> f a -> m) ->

222− -> PathsPrefixTree q f r

223+ PathsPrefixTree q f r ->

223− -> m

224+ m

224foldWith k = goTPT Root

225foldWith k = goTPT Root

225 where

226 where

226 goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

227 goTPT :: forall a. Paths q r a -> PathsPrefixTree q f a -> m

@@ -256,7 +257,7 @@ newtype MergableObject = MergableObject {getMergableObject :: Object}

256

257

257instance Semigroup MergableObject where

258instance Semigroup MergableObject where

258 (MergableObject x) <> (MergableObject y) =

259 (MergableObject x) <> (MergableObject y) =

259− MergableObject $ HM.unionWith mergeValue x y

260+ MergableObject $ KeyMap.unionWith mergeValue x y

260 where

261 where

261 mergeValue :: Value -> Value -> Value

262 mergeValue :: Value -> Value -> Value

262 mergeValue (Object a) (Object b) =

263 mergeValue (Object a) (Object b) =

@@ -271,6 +272,6 @@ instance Monoid MergableObject where

271

272

272traceObject :: Paths q r a -> Value -> Object

273traceObject :: Paths q r a -> Value -> Object

273traceObject Root (Object o) = o

274traceObject Root (Object o) = o

274−traceObject Root v = HM.singleton "root" v

275+traceObject Root v = KeyMap.singleton "root" v

275traceObject (root `Snoc` s) v =

276traceObject (root `Snoc` s) v =

276− traceObject root . Object $ HM.singleton (T.pack . show $ s) v

277+ traceObject root . Object $ KeyMap.singleton (Key.fromText . T.pack . show $ s) v

src/Data/OpenApi/Compare/References.hs+8−9

@@ -1,9 +1,9 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.References

4− ( Step (..)

4+ ( Step (..),

5− , dereference

5+ dereference,

6− , Typeable

6+ Typeable,

7 )

8where

9

@@ -13,17 +13,16 @@ import Data.Maybe

13import Data.OpenApi

14import Data.OpenApi.Compare.Orphans ()

15import Data.OpenApi.Compare.Subtree

16−import Data.Typeable

17

16

18instance Typeable a => Steppable (Referenced a) a where

17instance Typeable a => Steppable (Referenced a) a where

19 data Step (Referenced a) a = InlineStep

18 data Step (Referenced a) a = InlineStep

20 deriving stock (Eq, Ord, Show)

19 deriving stock (Eq, Ord, Show)

21

20

22−dereference

21+dereference ::

23− :: Typeable a

22+ Typeable a =>

24− => Traced (Definitions a)

23+ Traced (Definitions a) ->

25− -> Traced (Referenced a)

24+ Traced (Referenced a) ->

26− -> Traced a

25+ Traced a

27dereference defs x = case extract x of

26dereference defs x = case extract x of

28 Inline a ->

27 Inline a ->

29 traced (ask x >>> step InlineStep) a

28 traced (ask x >>> step InlineStep) a

src/Data/OpenApi/Compare/Report.hs+139−119

@@ -1,13 +1,13 @@

1module Data.OpenApi.Compare.Report

2− ( generateReport

2+ ( generateReport,

3− , CheckerOutput(..)

3+ CheckerOutput (..),

4− , ReportInput (..)

4+ ReportInput (..),

5− , segregateIssues

5+ segregateIssues,

6− , ReportStatus (..)

6+ ReportStatus (..),

7− , Pandoc

7+ Pandoc,

8− , ReportConfig (..)

8+ ReportConfig (..),

9− , ReportTreeStyle (..)

9+ ReportTreeStyle (..),

10− , ReportMode (..)

10+ ReportMode (..),

11 )

12where

13

@@ -30,8 +30,8 @@ import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)

30import Data.OpenApi.Compare.Report.Jet

31import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)

32import Data.OpenApi.Compare.Validate.OpenApi

33−import Data.OpenApi.Compare.Validate.Schema.TypedJson

34import Data.OpenApi.Compare.Validate.Schema.Issues

33import Data.OpenApi.Compare.Validate.Schema.Issues

34+import Data.OpenApi.Compare.Validate.Schema.TypedJson

35import Data.OpenUnion

36import Data.OpenUnion.Extra

37import Data.Set

@@ -54,22 +54,27 @@ data CheckerOutput = CheckerOutput

54 deriving anyclass (ToJSON)

55

56data ReportInput = ReportInput

57+ { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'

57− { breakingChanges :: Changes -- ^ forward 'CertainIssue', 'ProbablyIssue' and 'Comment'

58+ breakingChanges :: Changes

58− , nonBreakingChanges :: Changes -- ^ backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'

59+ , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'

60+ nonBreakingChanges :: Changes

61+ , -- | forward and backward 'Unsupported' (assumed to be the same anyway)

59− , unsupportedChanges :: Changes -- ^ forward and backward 'Unsupported' (assumed to be the same anyway)

62+ unsupportedChanges :: Changes

60− , schemaIssues :: Changes -- ^ forward and backward 'SchemaInvalid' (assumed to be the same anyway)

63+ , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)

64+ schemaIssues :: Changes

61 }

65 }

62 deriving stock (Generic)

66 deriving stock (Generic)

63 deriving (Semigroup, Monoid) via (Generically ReportInput)

67 deriving (Semigroup, Monoid) via (Generically ReportInput)

64 deriving anyclass (ToJSON)

68 deriving anyclass (ToJSON)

65

69

66segregateIssues :: CheckerOutput -> ReportInput

70segregateIssues :: CheckerOutput -> ReportInput

67−segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} = ReportInput

71+segregateIssues CheckerOutput {forwardChanges = fwd, backwardChanges = bck} =

72+ ReportInput

68− { breakingChanges = P.filter isBreaking fwd

73+ { breakingChanges = P.filter isBreaking fwd

69− , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck

74+ , nonBreakingChanges = invertIssueOrientationP $ P.filterWithKey isNonBreaking bck

70− , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck

75+ , unsupportedChanges = P.filter isUnsupported fwd <> P.filter isUnsupported bck

71− , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck

76+ , schemaIssues = P.filter isSchemaIssue fwd <> P.filter isSchemaIssue bck

72− }

77+ }

73 where

78 where

74 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]

79 isBreaking i = anIssueKind i `elem` [CertainIssue, ProbablyIssue, Comment]

75 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool

80 isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool

@@ -106,8 +111,7 @@ twoRowTable x = simpleTable (para . fst <$> x) [para . snd <$> x]

106

111

107generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)

112generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)

108generateReport cfg inp =

113generateReport cfg inp =

109− let

110− schemaIssuesPresent = not $ P.null $ schemaIssues inp

114+ let schemaIssuesPresent = not $ P.null $ schemaIssues inp

111 breakingChangesPresent = not $ P.null $ breakingChanges inp

115 breakingChangesPresent = not $ P.null $ breakingChanges inp

112 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

116 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

113 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

117 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

@@ -116,47 +120,55 @@ generateReport cfg inp =

116 OnlyErrors -> False

120 OnlyErrors -> False

117 builder = buildReport cfg

121 builder = buildReport cfg

118 report =

122 report =

119− header 1 "Summary"

123+ header 1 "Summary"

120− <> twoRowTable

124+ <> twoRowTable

121− (when'

125+ ( when'

122− schemaIssuesPresent

126+ schemaIssuesPresent

127+ [

123− [ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"

128+ ( refOpt schemaIssuesPresent schemaIssuesId "‼️ Schema issues"

124− , show' $ P.size $ schemaIssues inp

129+ , show' $ P.size $ schemaIssues inp

125− )

130+ )

126− ]

131+ ]

127− ++

132+ ++ [

128− [ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"

133+ ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"

129 , show' $ P.size $ breakingChanges inp

134 , show' $ P.size $ breakingChanges inp

130 )

135 )

131 ]

136 ]

132− ++ when'

137+ ++ when'

133− nonBreakingChangesShown

138+ nonBreakingChangesShown

139+ [

134− [ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"

140+ ( refOpt nonBreakingChangesPresent nonBreakingChangesId "⚠️ Non-breaking changes"

135− , show' $ P.size $ nonBreakingChanges inp

141+ , show' $ P.size $ nonBreakingChanges inp

136− )

142+ )

137− ]

143+ ]

138− ++ when'

144+ ++ when'

139− unsupportedChangesPresent

145+ unsupportedChangesPresent

146+ [

140− [ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"

147+ ( refOpt unsupportedChangesPresent unsupportedChangesId "❓ Unsupported feature changes"

141− , show' $ P.size $ unsupportedChanges inp

148+ , show' $ P.size $ unsupportedChanges inp

142− )

149+ )

143− ])

150+ ]

151+ )

144− <> when'

152+ <> when'

145− schemaIssuesPresent

153+ schemaIssuesPresent

146− (header 1 (anchor schemaIssuesId <> "‼️ Schema issues")

154+ ( header 1 (anchor schemaIssuesId <> "‼️ Schema issues")

147− <> builder (showErrs $ schemaIssues inp))

155+ <> builder (showErrs $ schemaIssues inp)

156+ )

148− <> when'

157+ <> when'

149− breakingChangesPresent

158+ breakingChangesPresent

150− (header 1 (anchor breakingChangesId <> "❌ Breaking changes")

159+ ( header 1 (anchor breakingChangesId <> "❌ Breaking changes")

151− <> builder (showErrs $ breakingChanges inp))

160+ <> builder (showErrs $ breakingChanges inp)

161+ )

152− <> when'

162+ <> when'

153− (nonBreakingChangesPresent && nonBreakingChangesShown)

163+ (nonBreakingChangesPresent && nonBreakingChangesShown)

154− (header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")

164+ ( header 1 (anchor nonBreakingChangesId <> "⚠️ Non-breaking changes")

155− <> builder (showErrs $ nonBreakingChanges inp))

165+ <> builder (showErrs $ nonBreakingChanges inp)

166+ )

156− <> when'

167+ <> when'

157− unsupportedChangesPresent

168+ unsupportedChangesPresent

158− (header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")

169+ ( header 1 (anchor unsupportedChangesId <> "❓ Unsupported feature changes")

159− <> builder (showErrs $ unsupportedChanges inp))

170+ <> builder (showErrs $ unsupportedChanges inp)

171+ )

160 status =

172 status =

161 if

173 if

162 | breakingChangesPresent -> BreakingChanges

174 | breakingChangesPresent -> BreakingChanges

@@ -190,9 +202,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

190 Just Refl

202 Just Refl

191 | (S.toList -> p@((AnIssue ori _) : _), o) <-

203 | (S.toList -> p@((AnIssue ori _) : _), o) <-

192 S.partition

204 S.partition

193− (\((AnIssue _ u)) -> case u of

205+ ( \((AnIssue _ u)) -> case u of

194− NoPathsMatched {} -> True

206+ NoPathsMatched {} -> True

195− AllPathsFailed {} -> True)

207+ AllPathsFailed {} -> True

208+ )

196 currentIssues ->

209 currentIssues ->

197 let p' = p <&> (\(AnIssue _ i) -> i)

210 let p' = p <&> (\(AnIssue _ i) -> i)

198 in (Just (ori, p'), o)

211 in (Just (ori, p'), o)

@@ -203,9 +216,10 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

203 paths = case removedPaths of

216 paths = case removedPaths of

204 Just (ori, ps) -> do

217 Just (ori, ps) -> do

205 singletonHeader

218 singletonHeader

206− (case ori of

219+ ( case ori of

207− Forward -> "Removed paths"

220+ Forward -> "Removed paths"

208− Backward -> "Added paths")

221+ Backward -> "Added paths"

222+ )

209 $ singletonBody $

223 $ singletonBody $

210 bulletList $

224 bulletList $

211 ps <&> \case

225 ps <&> \case

@@ -249,52 +263,54 @@ jets =

249 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."

263 unwrapReportJetResult (Pure _) = error "There really shouldn't be any results here."

250 unwrapReportJetResult (Free f) = f

264 unwrapReportJetResult (Free f) = f

251

265

252− jsonPathJet

266+ jsonPathJet ::

253− :: NonEmpty

267+ NonEmpty

254− ( Union

268+ ( Union

255− '[ Behave 'SchemaLevel 'TypedSchemaLevel

269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

256− , Behave 'TypedSchemaLevel 'SchemaLevel

270+ , Behave 'TypedSchemaLevel 'SchemaLevel

257− ]

271+ ]

258− )

272+ ) ->

259− -> Inlines

273+ Inlines

260 jsonPathJet x = code $ "$" <> showParts (NE.toList x)

274 jsonPathJet x = code $ "$" <> showParts (NE.toList x)

261 where

275 where

262− showParts

276+ showParts ::

263− :: [ Union

277+ [ Union

264− '[ Behave 'SchemaLevel 'TypedSchemaLevel

278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

265− , Behave 'TypedSchemaLevel 'SchemaLevel

279+ , Behave 'TypedSchemaLevel 'SchemaLevel

266− ]

267− ]

280+ ]

281+ ] ->

268− -> Text

282+ Text

269 showParts [] = mempty

283 showParts [] = mempty

270 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs

284 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion (InProperty _)) : _)) = showParts xs

271 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs

285 showParts (SingletonUnion (OfType Object) : xs@((SingletonUnion InAdditionalProperty) : _)) = showParts xs

272 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs

286 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion InItems : _)) = showParts xs

273 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs

287 showParts (SingletonUnion (OfType Array) : xs@(SingletonUnion (InItem _) : _)) = showParts xs

274 showParts (y : ys) =

288 showParts (y : ys) =

275− ((\(OfType t) -> "(" <> describeJSONType t <> ")")

289+ ( (\(OfType t) -> "(" <> describeJSONType t <> ")")

276− @@> (\case

290+ @@> ( \case

277− InItems -> "[*]"

291+ InItems -> "[*]"

278− InItem i -> "[" <> T.pack (show i) <> "]"

292+ InItem i -> "[" <> T.pack (show i) <> "]"

279− InProperty p -> "." <> p

293+ InProperty p -> "." <> p

280− InAdditionalProperty -> ".*")

294+ InAdditionalProperty -> ".*"

295+ )

281− @@> typesExhausted)

296+ @@> typesExhausted

297+ )

282 y

298 y

283 <> showParts ys

299 <> showParts ys

284

300

285−observeJetShowErrs

301+observeJetShowErrs ::

286− :: ReportJet' Behave (Maybe Inlines)

302+ ReportJet' Behave (Maybe Inlines) ->

287− -> P.PathsPrefixTree Behave AnIssue a

303+ P.PathsPrefixTree Behave AnIssue a ->

288− -> (Report, P.PathsPrefixTree Behave AnIssue a)

304+ (Report, P.PathsPrefixTree Behave AnIssue a)

289observeJetShowErrs jet p = case observeJetShowErrs' jet p of

305observeJetShowErrs jet p = case observeJetShowErrs' jet p of

290 Just m -> m

306 Just m -> m

291 Nothing -> (mempty, p)

307 Nothing -> (mempty, p)

292

308

293−observeJetShowErrs'

309+observeJetShowErrs' ::

294− :: forall a.

310+ forall a.

295− ReportJet' Behave (Maybe Inlines)

311+ ReportJet' Behave (Maybe Inlines) ->

296− -> P.PathsPrefixTree Behave AnIssue a

312+ P.PathsPrefixTree Behave AnIssue a ->

297− -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

313+ Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

298observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =

314observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =

299 let results =

315 let results =

300 subIssues >>= \(WrapTypeable (AStep m)) ->

316 subIssues >>= \(WrapTypeable (AStep m)) ->

@@ -302,21 +318,23 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)

302 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $

318 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $

303 jet @_ @_ @[] bhv

319 jet @_ @_ @[] bhv

304 & mapMaybe

320 & mapMaybe

305− (\case

321+ ( \case

306− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

322+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

307− Pure (Just h) ->

323+ Pure (Just h) ->

308− if P.null subErrs

324+ if P.null subErrs

309− then Just mempty

325+ then Just mempty

310− else Just (singletonHeader h (showErrs subErrs), mempty)

326+ else Just (singletonHeader h (showErrs subErrs), mempty)

311− Pure Nothing -> Nothing)

327+ Pure Nothing -> Nothing

328+ )

312 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

329 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

313 if any isRight results

330 if any isRight results

314 then

331 then

315 Just $

332 Just $

316 foldMap

333 foldMap

317− (\case

334+ ( \case

318− Left e -> (mempty, e)

335+ Left e -> (mempty, e)

319− Right m -> m)

336+ Right m -> m

337+ )

320 results

338 results

321 else Nothing

339 else Nothing

322

340

@@ -339,8 +357,9 @@ buildReport cfg = case treeStyle cfg of

339 body rprt

357 body rprt

340 <> foldOMapWithKey

358 <> foldOMapWithKey

341 (headers rprt)

359 (headers rprt)

342− (\k v ->

360+ ( \k v ->

343− header level k <> subBuilder v)

361+ header level k <> subBuilder v

362+ )

344 where

363 where

345 subBuilder = headerStyleBuilder (level + 1)

364 subBuilder = headerStyleBuilder (level + 1)

346

365

@@ -349,16 +368,17 @@ buildReport cfg = case treeStyle cfg of

349 body rprt

368 body rprt

350 <> foldOMapWithKey

369 <> foldOMapWithKey

351 (headers rprt)

370 (headers rprt)

352− (\k v ->

371+ ( \k v ->

353− if (OM.size . headers $ rprt) < 2

372+ if (OM.size . headers $ rprt) < 2

354− then para k <> blockQuote (subBuilder v)

373+ then para k <> blockQuote (subBuilder v)

355− else

374+ else

356− rawHtml "<details>"

375+ rawHtml "<details>"

357− <> rawHtml "<summary>"

376+ <> rawHtml "<summary>"

358− <> plain k

377+ <> plain k

359− <> rawHtml "</summary>"

378+ <> rawHtml "</summary>"

360− <> blockQuote (subBuilder v)

379+ <> blockQuote (subBuilder v)

361− <> rawHtml "</details>")

380+ <> rawHtml "</details>"

381+ )

362 where

382 where

363 subBuilder = foldingStyleBuilder

383 subBuilder = foldingStyleBuilder

364

384

src/Data/OpenApi/Compare/Report/Html/Template.hs+2−2

@@ -1,7 +1,7 @@

1{-# LANGUAGE TemplateHaskell #-}

2

3module Data.OpenApi.Compare.Report.Html.Template

4− ( template

4+ ( template,

5 )

6where

7

@@ -36,4 +36,4 @@ template =

36 \</html>"

37

38awsmCss :: ByteString

39−awsmCss = $(makeRelativeToProject "awsm-css/dist/awsm.min.css" >>= embedFile)

39+awsmCss = $(makeRelativeToProject "css/awsm.min.css" >>= embedFile)

src/Data/OpenApi/Compare/Report/Jet.hs+4−4

@@ -1,8 +1,8 @@

1module Data.OpenApi.Compare.Report.Jet

2− ( ReportJet (..)

2+ ( ReportJet (..),

3− , ReportJet'

3+ ReportJet',

4− , ConstructReportJet (..)

4+ ConstructReportJet (..),

5− , ReportJetResult

5+ ReportJetResult,

6 )

7where

8

src/Data/OpenApi/Compare/Run.hs+4−4

@@ -1,17 +1,17 @@

1module Data.OpenApi.Compare.Run

2− ( runChecker

2+ ( runChecker,

3− , runReport

3+ runReport,

4− , module Data.OpenApi.Compare.Report

4+ module Data.OpenApi.Compare.Report,

5 )

6where

7

8import Data.HList

9import Data.OpenApi (OpenApi)

10−import Text.Pandoc.Builder

11import Data.OpenApi.Compare.Paths

10import Data.OpenApi.Compare.Paths

12import Data.OpenApi.Compare.Report

11import Data.OpenApi.Compare.Report

13import Data.OpenApi.Compare.Subtree

12import Data.OpenApi.Compare.Subtree

14import Data.OpenApi.Compare.Validate.OpenApi ()

13import Data.OpenApi.Compare.Validate.OpenApi ()

14+import Text.Pandoc.Builder

15

16runChecker :: (OpenApi, OpenApi) -> CheckerOutput

17runChecker (client, server) =

src/Data/OpenApi/Compare/Subtree.hs+122−120

@@ -1,52 +1,52 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Subtree

4− ( Steppable (..)

4+ ( Steppable (..),

5− , Step (..)

5+ Step (..),

6− , TraceRoot

6+ TraceRoot,

7− , Trace

7+ Trace,

8− , Traced

8+ Traced,

9− , Traced'

9+ Traced',

10− , pattern Traced

10+ pattern Traced,

11− , traced

11+ traced,

12− , retraced

12+ retraced,

13− , stepTraced

13+ stepTraced,

14− , Subtree (..)

14+ Subtree (..),

15− , checkCompatibility

15+ checkCompatibility,

16− , checkSubstructure

16+ checkSubstructure,

17− , CompatM (..)

17+ CompatM (..),

18− , CompatFormula'

18+ CompatFormula',

19− , SemanticCompatFormula

19+ SemanticCompatFormula,

20− , ProdCons (..)

20+ ProdCons (..),

21− , orientProdCons

21+ orientProdCons,

22− , swapProdCons

22+ swapProdCons,

23− , runCompatFormula

23+ runCompatFormula,

24− , issueAt

24+ issueAt,

25− , anItem

25+ anItem,

26− , anIssue

26+ anIssue,

27− , invertIssueOrientation

27+ invertIssueOrientation,

28− , invertIssueOrientationP

28+ invertIssueOrientationP,

29− , embedFormula

29+ embedFormula,

30− , anyOfAt

30+ anyOfAt,

31− , clarifyIssue

31+ clarifyIssue,

32− , structuralIssue

32+ structuralIssue,

33

34 -- * Structural helpers

35− , structuralMaybe

35+ structuralMaybe,

36− , structuralMaybeWith

36+ structuralMaybeWith,

37− , structuralEq

37+ structuralEq,

38− , iohmStructural

38+ iohmStructural,

39− , iohmStructuralWith

39+ iohmStructuralWith,

40− , structuralList

40+ structuralList,

41

42 -- * Reexports

43− , (>>>)

43+ (>>>),

44− , (<<<)

44+ (<<<),

45− , extract

45+ extract,

46− , ask

46+ ask,

47− , local

47+ local,

48− , step

48+ step,

49− , Typeable

49+ Typeable,

50 )

51where

52

@@ -115,10 +115,10 @@ orientProdCons :: Orientation -> ProdCons x -> ProdCons x

115orientProdCons Forward x = x

116orientProdCons Backward (ProdCons p c) = ProdCons c p

117

118−swapProdCons

118+swapProdCons ::

119− :: SwapEnvRoles xs

119+ SwapEnvRoles xs =>

120− => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

120+ (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a) ->

121− -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

121+ (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

122swapProdCons f e (ProdCons p c) =

123 invertIssueOrientation $

124 f (swapEnvRoles e) (ProdCons c p)

@@ -153,8 +153,8 @@ instance Applicative ProdCons where

153 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

154

155newtype CompatM a = CompatM

156− { unCompatM

156+ { unCompatM ::

157− :: StateT (MemoState VarRef) Identity a

157+ StateT (MemoState VarRef) Identity a

158 }

159 deriving newtype

160 ( Functor

@@ -183,64 +183,64 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

183 type CheckEnv t :: [Type]

184 type SubtreeLevel t :: BehaviorLevel

185

186− checkStructuralCompatibility

186+ checkStructuralCompatibility ::

187− :: HList (CheckEnv t)

187+ HList (CheckEnv t) ->

188− -> ProdCons (Traced t)

188+ ProdCons (Traced t) ->

189− -> StructuralCompatFormula ()

189+ StructuralCompatFormula ()

190

191− checkSemanticCompatibility

191+ checkSemanticCompatibility ::

192− :: HList (CheckEnv t)

192+ HList (CheckEnv t) ->

193− -> Behavior (SubtreeLevel t)

193+ Behavior (SubtreeLevel t) ->

194− -> ProdCons (Traced t)

194+ ProdCons (Traced t) ->

195− -> SemanticCompatFormula ()

195+ SemanticCompatFormula ()

196

197{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

198

199{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

200

201−checkCompatibility

201+checkCompatibility ::

202− :: forall t xs.

202+ forall t xs.

203− (ReassembleHList xs (CheckEnv t), Subtree t)

203+ (ReassembleHList xs (CheckEnv t), Subtree t) =>

204− => Behavior (SubtreeLevel t)

204+ Behavior (SubtreeLevel t) ->

205− -> HList xs

205+ HList xs ->

206− -> ProdCons (Traced t)

206+ ProdCons (Traced t) ->

207− -> SemanticCompatFormula ()

207+ SemanticCompatFormula ()

208checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

209 case runCompatFormula $ checkSubstructure e pc of

210 Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

211 Right () -> pure ()

212{-# INLINE checkCompatibility #-}

213

214−checkSubstructure

214+checkSubstructure ::

215− :: (ReassembleHList xs (CheckEnv t), Subtree t)

215+ (ReassembleHList xs (CheckEnv t), Subtree t) =>

216− => HList xs

216+ HList xs ->

217− -> ProdCons (Traced t)

217+ ProdCons (Traced t) ->

218− -> StructuralCompatFormula ()

218+ StructuralCompatFormula ()

219checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

220{-# INLINE checkSubstructure #-}

221

222−structuralMaybe

222+structuralMaybe ::

223− :: (Subtree a, ReassembleHList xs (CheckEnv a))

223+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>

224− => HList xs

224+ HList xs ->

225− -> ProdCons (Maybe (Traced a))

225+ ProdCons (Maybe (Traced a)) ->

226− -> StructuralCompatFormula ()

226+ StructuralCompatFormula ()

227structuralMaybe e = structuralMaybeWith (checkSubstructure e)

228{-# INLINE structuralMaybe #-}

229

230−structuralMaybeWith

230+structuralMaybeWith ::

231− :: (ProdCons a -> StructuralCompatFormula ())

231+ (ProdCons a -> StructuralCompatFormula ()) ->

232− -> ProdCons (Maybe a)

232+ ProdCons (Maybe a) ->

233− -> StructuralCompatFormula ()

233+ StructuralCompatFormula ()

234structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

235structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

236structuralMaybeWith _ _ = structuralIssue

237{-# INLINE structuralMaybeWith #-}

238

239−structuralList

239+structuralList ::

240− :: (Subtree a, ReassembleHList xs (CheckEnv a))

240+ (Subtree a, ReassembleHList xs (CheckEnv a)) =>

241− => HList xs

241+ HList xs ->

242− -> ProdCons [Traced a]

242+ ProdCons [Traced a] ->

243− -> StructuralCompatFormula ()

243+ StructuralCompatFormula ()

244structuralList _ (ProdCons [] []) = pure ()

245structuralList e (ProdCons (a : aa) (b : bb)) = do

246 checkSubstructure e $ ProdCons a b

@@ -253,11 +253,11 @@ structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula (

253structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

254{-# INLINE structuralEq #-}

255

256−iohmStructural

256+iohmStructural ::

257− :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)

257+ (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k) =>

258− => HList xs

258+ HList xs ->

259− -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

259+ ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

260− -> StructuralCompatFormula ()

260+ StructuralCompatFormula ()

261iohmStructural e =

262 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

263{-# INLINE iohmStructural #-}

@@ -266,25 +266,26 @@ instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMa

266 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

267 deriving stock (Eq, Ord, Show)

268

269−iohmStructuralWith

269+iohmStructuralWith ::

270− :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

270+ (Ord k, Hashable k, Typeable k, Typeable v, Show k) =>

271− => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())

271+ (k -> ProdCons (Traced v) -> StructuralCompatFormula ()) ->

272− -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

272+ ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

273− -> StructuralCompatFormula ()

273+ StructuralCompatFormula ()

274iohmStructuralWith f pc = do

275 let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

276 if pEKeys == cEKeys

277 then

278 for_

279 pEKeys

280− (\eKey ->

280+ ( \eKey ->

281− f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

281+ f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc

282+ )

282 else structuralIssue

283 else structuralIssue

283{-# INLINE iohmStructuralWith #-}

284{-# INLINE iohmStructuralWith #-}

284

285

285−runCompatFormula

286+runCompatFormula ::

286− :: CompatFormula' q f r a

287+ CompatFormula' q f r a ->

287− -> Either (P.PathsPrefixTree q f r) a

288+ Either (P.PathsPrefixTree q f r) a

288runCompatFormula (Compose f) =

289runCompatFormula (Compose f) =

289 calculate . runIdentity . runMemo 0 . unCompatM $ f

290 calculate . runIdentity . runMemo 0 . unCompatM $ f

290{-# INLINE runCompatFormula #-}

291{-# INLINE runCompatFormula #-}

@@ -314,27 +315,27 @@ invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation

314structuralIssue :: StructuralCompatFormula a

315structuralIssue :: StructuralCompatFormula a

315structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

316structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

316

317

317−anyOfAt

318+anyOfAt ::

318− :: Issuable l

319+ Issuable l =>

319− => Paths q r l

320+ Paths q r l ->

320− -> Issue l

321+ Issue l ->

321− -> [CompatFormula' q AnIssue r a]

322+ [CompatFormula' q AnIssue r a] ->

322− -> CompatFormula' q AnIssue r a

323+ CompatFormula' q AnIssue r a

323anyOfAt _ _ [x] = x

324anyOfAt _ _ [x] = x

324anyOfAt xs issue fs =

325anyOfAt xs issue fs =

325 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

326 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

326

327

327-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

328-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

328−clarifyIssue

329+clarifyIssue ::

329− :: AnItem q AnIssue r

330+ AnItem q AnIssue r ->

330− -> CompatFormula' q AnIssue r a

331+ CompatFormula' q AnIssue r a ->

331− -> CompatFormula' q AnIssue r a

332+ CompatFormula' q AnIssue r a

332clarifyIssue item f =

333clarifyIssue item f =

333 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

334 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

334

335

335−fixpointKnot

336+fixpointKnot ::

336− :: MonadState (MemoState VarRef) m

337+ MonadState (MemoState VarRef) m =>

337− => KnotTier (FormulaF q f r ()) VarRef m

338+ KnotTier (FormulaF q f r ()) VarRef m

338fixpointKnot =

339fixpointKnot =

339 KnotTier

340 KnotTier

340 { onKnotFound = modifyMemoNonce succ

341 { onKnotFound = modifyMemoNonce succ

@@ -342,19 +343,20 @@ fixpointKnot =

342 , tieKnot = \i x -> pure $ maxFixpoint i x

343 , tieKnot = \i x -> pure $ maxFixpoint i x

343 }

344 }

344

345

345−memo

346+memo ::

346− :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

347+ (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a) =>

347− => Paths q r l

348+ Paths q r l ->

348− -> MemoKey

349+ MemoKey ->

349− -> (ProdCons (Traced a) -> CompatFormula' q f r ())

350+ (ProdCons (Traced a) -> CompatFormula' q f r ()) ->

350− -> (ProdCons (Traced a) -> CompatFormula' q f r ())

351+ (ProdCons (Traced a) -> CompatFormula' q f r ())

351memo bhv k f pc = Compose $ do

352memo bhv k f pc = Compose $ do

352 formula' <-

353 formula' <-

353 memoWithKnot

354 memoWithKnot

354 fixpointKnot

355 fixpointKnot

355− (do

356+ ( do

356− formula <- getCompose $ f pc

357+ formula <- getCompose $ f pc

357− pure $ mapErrors (P.takeSubtree bhv) formula)

358+ pure $ mapErrors (P.takeSubtree bhv) formula

359+ )

358 (k, ask <$> pc)

360 (k, ask <$> pc)

359 pure $ mapErrors (P.embed bhv) formula'

361 pure $ mapErrors (P.embed bhv) formula'

360

362

src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs+2−2

@@ -1,8 +1,8 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.MediaTypeObject

4− ( Issue (..)

4+ ( Issue (..),

5− , Behave (..)

5+ Behave (..),

6 )

7where

8

src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs+13−13

@@ -1,9 +1,9 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.OAuth2Flows

4− ( Step (..)

4+ ( Step (..),

5− , Issue (..)

5+ Issue (..),

6− , Behave (..)

6+ Behave (..),

7 )

8where

9

@@ -26,11 +26,11 @@ instance Subtree OAuth2Flows where

26 type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel

27 checkStructuralCompatibility _ = structuralEq

28 checkSemanticCompatibility env bhv pc = do

29− let supportFlow

29+ let supportFlow ::

30− :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)

30+ (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t) =>

31− => Issue 'SecuritySchemeLevel

31+ Issue 'SecuritySchemeLevel ->

32− -> ProdCons (Maybe (Traced t))

32+ ProdCons (Maybe (Traced t)) ->

33− -> SemanticCompatFormula ()

33+ SemanticCompatFormula ()

34 supportFlow i x = case x of

35 -- producer will not attempt this flow

36 (ProdCons Nothing _) -> pure ()

@@ -38,11 +38,11 @@ instance Subtree OAuth2Flows where

38 (ProdCons (Just _) Nothing) -> issueAt bhv i

39 (ProdCons (Just p) (Just c)) ->

40 checkCompatibility bhv env $ ProdCons p c

41− getFlow

41+ getFlow ::

42− :: Typeable x

42+ Typeable x =>

43− => (OAuth2Flows -> Maybe (OAuth2Flow x))

43+ (OAuth2Flows -> Maybe (OAuth2Flow x)) ->

44− -> Traced OAuth2Flows

44+ Traced OAuth2Flows ->

45− -> Maybe (Traced (OAuth2Flow x))

45+ Maybe (Traced (OAuth2Flow x))

46 getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a

47 supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc

48 supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc

src/Data/OpenApi/Compare/Validate/OpenApi.hs+15−13

@@ -3,8 +3,8 @@

3{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}

4

5module Data.OpenApi.Compare.Validate.OpenApi

6− ( Behave (..)

6+ ( Behave (..),

7− , Issue (..)

7+ Issue (..),

8 )

9where

10

@@ -38,7 +38,8 @@ tracedSecuritySchemes :: Traced OpenApi -> Traced (Definitions SecurityScheme)

38tracedSecuritySchemes oa =

39 traced

40 (ask oa >>> step ComponentsSecurityScheme)

41− (_componentsSecuritySchemes . _openApiComponents . extract $ oa)

41+ (unSecurityDefinitions . _componentsSecuritySchemes . _openApiComponents . extract $ oa)

42+ where unSecurityDefinitions (SecurityDefinitions ds) = ds

42

43

43tracedResponses :: Traced OpenApi -> Traced (Definitions Response)

44tracedResponses :: Traced OpenApi -> Traced (Definitions Response)

44tracedResponses oa =

45tracedResponses oa =

@@ -79,16 +80,17 @@ instance Subtree OpenApi where

79 checkSemanticCompatibility _ beh prodCons = do

80 checkSemanticCompatibility _ beh prodCons = do

80 checkCompatibility @ProcessedPathItems

81 checkCompatibility @ProcessedPathItems

81 beh

82 beh

82− ((tracedRequestBodies <$> prodCons)

83+ ( (tracedRequestBodies <$> prodCons)

83− `HCons` (tracedParameters <$> prodCons)

84+ `HCons` (tracedParameters <$> prodCons)

84− `HCons` (tracedSecuritySchemes <$> prodCons)

85+ `HCons` (tracedSecuritySchemes <$> prodCons)

85− `HCons` (tracedResponses <$> prodCons)

86+ `HCons` (tracedResponses <$> prodCons)

86− `HCons` (tracedHeaders <$> prodCons)

87+ `HCons` (tracedHeaders <$> prodCons)

87− `HCons` (tracedSchemas <$> prodCons)

88+ `HCons` (tracedSchemas <$> prodCons)

88− `HCons` (_openApiServers . extract <$> prodCons)

89+ `HCons` (_openApiServers . extract <$> prodCons)

89− `HCons` (tracedLinks <$> prodCons)

90+ `HCons` (tracedLinks <$> prodCons)

90− `HCons` (tracedCallbacks <$> prodCons)

91+ `HCons` (tracedCallbacks <$> prodCons)

91− `HCons` HNil)

92+ `HCons` HNil

93+ )

92 (tracedPaths <$> prodCons)

94 (tracedPaths <$> prodCons)

93

95

94instance Steppable OpenApi ProcessedPathItems where

96instance Steppable OpenApi ProcessedPathItems where

src/Data/OpenApi/Compare/Validate/Operation.hs+26−24

@@ -4,17 +4,17 @@

4

5module Data.OpenApi.Compare.Validate.Operation

6 ( -- * Operation

7− MatchedOperation (..)

7+ MatchedOperation (..),

8− , OperationMethod (..)

8+ OperationMethod (..),

9− , pathItemMethod

9+ pathItemMethod,

10

11 -- * ProcessedPathItem

12− , ProcessedPathItem (..)

12+ ProcessedPathItem (..),

13− , ProcessedPathItems (..)

13+ ProcessedPathItems (..),

14− , processPathItems

14+ processPathItems,

15− , Step (..)

15+ Step (..),

16− , Behave (..)

16+ Behave (..),

17− , Issue (..)

17+ Issue (..),

18 )

19where

20

@@ -87,10 +87,11 @@ tracedCallbacks (Traced t oper) =

87 ]

88

89-- FIXME: #28

90−getServers

90+getServers ::

91− :: [Server] -- ^ Servers from env

91+ -- | Servers from env

92+ [Server] ->

92− -> MatchedOperation

93+ MatchedOperation ->

93− -> [Server]

94+ [Server]

94getServers env oper =

95getServers env oper =

95 case _operationServers . operation $ oper of

96 case _operationServers . operation $ oper of

96 [] -> env

97 [] -> env

@@ -337,9 +338,10 @@ instance Issuable 'APILevel where

337 deriving stock (Eq, Ord, Show)

338 deriving stock (Eq, Ord, Show)

338 issueKind = \case

339 issueKind = \case

339 _ -> CertainIssue

340 _ -> CertainIssue

340− relatedIssues = (==) `withClass` \case

341+ relatedIssues =

342+ (==) `withClass` \case

341− NoPathsMatched fp -> Just fp

343+ NoPathsMatched fp -> Just fp

342− AllPathsFailed fp -> Just fp

344+ AllPathsFailed fp -> Just fp

343 describeIssue Forward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

345 describeIssue Forward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

344 describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."

346 describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."

345 describeIssue Forward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

347 describeIssue Forward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

@@ -434,10 +436,10 @@ tracedFragments mpi =

434 | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi

436 | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi

435 ]

437 ]

436

438

437−tracedMethod

439+tracedMethod ::

438− :: OperationMethod

440+ OperationMethod ->

439− -> Traced MatchedPathItem

441+ Traced MatchedPathItem ->

440− -> Maybe (Traced' MatchedOperation Operation)

442+ Maybe (Traced' MatchedOperation Operation)

441tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

443tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

442

444

443instance Issuable 'PathLevel where

445instance Issuable 'PathLevel where

@@ -485,10 +487,10 @@ instance Subtree MatchedPathItem where

485 checkSemanticCompatibility env beh prodCons = do

487 checkSemanticCompatibility env beh prodCons = do

486 let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

488 let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

487 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

489 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

488− getPathParams

490+ getPathParams ::

489− :: Traced (Definitions Param)

491+ Traced (Definitions Param) ->

490− -> Traced MatchedPathItem

492+ Traced MatchedPathItem ->

491− -> [Traced Param]

493+ [Traced Param]

492 getPathParams defs mpi = do

494 getPathParams defs mpi = do

493 paramRef <- tracedMatchedPathItemParameters mpi

495 paramRef <- tracedMatchedPathItemParameters mpi

494 pure $ dereference defs paramRef

496 pure $ dereference defs paramRef

src/Data/OpenApi/Compare/Validate/Param.hs+9−7

@@ -2,8 +2,8 @@

2{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

3

4module Data.OpenApi.Compare.Validate.Param

5− ( Behave (..)

5+ ( Behave (..),

6− , Issue (..)

6+ Issue (..),

7 )

8where

9

@@ -79,7 +79,7 @@ instance Issuable 'PathFragmentLevel where

79 describeIssue _ ParamPlaceIncompatible = para "Parameters in incompatible locations."

80 describeIssue _ ParamStyleMismatch = para "Different parameter styles (encodings)."

81 describeIssue _ ParamSchemaMismatch = para "Expected a schema, but didn't find one."

82− describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =

82+ describeIssue ori (PathFragmentsDontMatch (orientProdCons ori -> ProdCons e a)) =

83 para $ "Parameter changed from " <> code e <> " to " <> code a <> "."

84

85instance Behavable 'PathFragmentLevel 'SchemaLevel where

@@ -106,15 +106,17 @@ instance Subtree Param where

106 when (_paramName (extract p) /= _paramName (extract c)) $

107 issueAt beh ParamNameMismatch

108 when

109− ((fromMaybe False . _paramRequired . extract $ c)

109+ ( (fromMaybe False . _paramRequired . extract $ c)

110− && not (fromMaybe False . _paramRequired . extract $ p))

110+ && not (fromMaybe False . _paramRequired . extract $ p)

111+ )

111 $ issueAt beh ParamRequired

112 $ issueAt beh ParamRequired

112 case (_paramIn . extract $ p, _paramIn . extract $ c) of

113 case (_paramIn . extract $ p, _paramIn . extract $ c) of

113 (ParamQuery, ParamQuery) -> do

114 (ParamQuery, ParamQuery) -> do

114 -- Emptiness is only for query params

115 -- Emptiness is only for query params

115 when

116 when

116− ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

117+ ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)

117− && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

118+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)

119+ )

118 $ issueAt beh ParamEmptinessIncompatible

120 $ issueAt beh ParamEmptinessIncompatible

119 (a, b) | a == b -> pure ()

121 (a, b) | a == b -> pure ()

120 _ -> issueAt beh ParamPlaceIncompatible

122 _ -> issueAt beh ParamPlaceIncompatible

src/Data/OpenApi/Compare/Validate/PathFragment.hs+3−4

@@ -1,7 +1,7 @@

1module Data.OpenApi.Compare.Validate.PathFragment

2− ( parsePath

2+ ( parsePath,

3− , PathFragment (..)

3+ PathFragment (..),

4− , PathFragmentParam

4+ PathFragmentParam,

5 )

6where

7

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Subtree

12import Data.OpenApi.Compare.Validate.Param

13import Data.Text (Text)

14import qualified Data.Text as T

15−import Data.Typeable

16

15

17-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

16-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.

18-- #23

17-- #23

src/Data/OpenApi/Compare/Validate/Products.hs+27−28

@@ -1,21 +1,21 @@

1−{- | Checks product-like entities. The key is some identificator for the product

1+-- | Checks product-like entities. The key is some identificator for the product

2−element. Each element may be required or optional.

2+--element. Each element may be required or optional.

3−

3+--

4−One example of product is request parameters. There are optional and required

4+--One example of product is request parameters. There are optional and required

5−parameters. The client and server have possibly different set of

5+--parameters. The client and server have possibly different set of

6−parameters. What we must check is if server requires some request parameter,

6+--parameters. What we must check is if server requires some request parameter,

7−then this parameter must be presented by client and their schemas must match.

7+--then this parameter must be presented by client and their schemas must match.

8−

8+--

9−So when we checking products we are checking from the server's (consumer)

9+--So when we checking products we are checking from the server's (consumer)

10−perspective, ensuring that all parameters are provided by the client (producer)

10+--perspective, ensuring that all parameters are provided by the client (producer)

11−and their schemas match.

11+--and their schemas match.

12−

12+--

13−This module abstracts this logic for arbitrary elements -}

13+--This module abstracts this logic for arbitrary elements

14−

15module Data.OpenApi.Compare.Validate.Products

14module Data.OpenApi.Compare.Validate.Products

16− ( checkProducts

15+ ( checkProducts,

17− , ProductLike(..)

16+ ProductLike (..),

17+ )

18− ) where

18+where

19

20import Data.Foldable

21import Data.Map.Strict (Map)

@@ -30,20 +30,19 @@ data ProductLike a = ProductLike

30 , required :: Bool

31 }

32

33−checkProducts

33+checkProducts ::

34− :: (Ord k, Issuable l)

34+ (Ord k, Issuable l) =>

35− => Paths q r l

35+ Paths q r l ->

36− -> (k -> Issue l)

37− -- ^ No required element found

36+ -- | No required element found

37+ (k -> Issue l) ->

38− -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

38+ (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

39− -> ProdCons (Map k (ProductLike t))

39+ ProdCons (Map k (ProductLike t)) ->

40− -> CompatFormula' q AnIssue r ()

40+ CompatFormula' q AnIssue r ()

41checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

42 case M.lookup key p of

43 Nothing -> case required consElt of

44− True -> issueAt xs $ noElt key

44+ True -> issueAt xs $ noElt key

45 False -> pure ()

46 Just prodElt -> do

47− let

48− elts = ProdCons prodElt consElt

47+ let elts = ProdCons prodElt consElt

49 check key (productValue <$> elts)

48 check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/RequestBody.hs+2−2

@@ -1,8 +1,8 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.RequestBody

4− ( Issue (..)

4+ ( Issue (..),

5− , Behave (..)

5+ Behave (..),

6 )

7where

8

src/Data/OpenApi/Compare/Validate/Responses.hs+1−1

@@ -2,7 +2,7 @@

2{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

3

4module Data.OpenApi.Compare.Validate.Responses

5− ( Behave (..)

5+ ( Behave (..),

6 )

7where

8

src/Data/OpenApi/Compare/Validate/Schema.hs+77−98

@@ -1,18 +1,19 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2+

2module Data.OpenApi.Compare.Validate.Schema

3module Data.OpenApi.Compare.Validate.Schema

3 (

4 (

4 )

5 )

5where

6where

6

7

7−import Control.Monad.Writer

8+import Control.Monad (when,unless)

8import qualified Data.Aeson as A

9import qualified Data.Aeson as A

9import Data.Coerce

10import Data.Coerce

10import Data.Foldable (for_, toList)

11import Data.Foldable (for_, toList)

11import Data.Functor

12import Data.Functor

12import Data.HList

13import Data.HList

14+import Data.List (genericIndex, genericLength, group)

13import qualified Data.List.NonEmpty as NE

15import qualified Data.List.NonEmpty as NE

14import qualified Data.Map as M

16import qualified Data.Map as M

15−import Data.List (group, genericLength, genericIndex)

16import Data.Maybe

17import Data.Maybe

17import Data.OpenApi

18import Data.OpenApi

18import Data.OpenApi.Compare.Behavior

19import Data.OpenApi.Compare.Behavior

@@ -22,24 +23,24 @@ import Data.OpenApi.Compare.Subtree

22import Data.OpenApi.Compare.Validate.Schema.DNF

23import Data.OpenApi.Compare.Validate.Schema.DNF

23import Data.OpenApi.Compare.Validate.Schema.Issues

24import Data.OpenApi.Compare.Validate.Schema.Issues

24import Data.OpenApi.Compare.Validate.Schema.JsonFormula

25import Data.OpenApi.Compare.Validate.Schema.JsonFormula

25−import Data.OpenApi.Compare.Validate.Schema.Traced

26−import Data.OpenApi.Compare.Validate.Schema.TypedJson

27import Data.OpenApi.Compare.Validate.Schema.Partition

26import Data.OpenApi.Compare.Validate.Schema.Partition

28import Data.OpenApi.Compare.Validate.Schema.Process

27import Data.OpenApi.Compare.Validate.Schema.Process

28+import Data.OpenApi.Compare.Validate.Schema.Traced

29+import Data.OpenApi.Compare.Validate.Schema.TypedJson

29import Data.Ord

30import Data.Ord

30import Data.Ratio

31import Data.Ratio

31import Data.Semigroup

32import Data.Semigroup

32import qualified Data.Set as S

33import qualified Data.Set as S

33import Data.Text (Text)

34import Data.Text (Text)

34

35

35−checkFormulas

36+checkFormulas ::

36− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

37+ (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

37− => HList xs

38+ HList xs ->

38− -> Behavior 'SchemaLevel

39+ Behavior 'SchemaLevel ->

39− -> ProdCons (Trace Schema)

40+ ProdCons (Trace Schema) ->

40− -> ProdCons (Traced (Definitions Schema))

41+ ProdCons (Traced (Definitions Schema)) ->

41− -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

42+ ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->

42− -> SemanticCompatFormula ()

43+ SemanticCompatFormula ()

43checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

44checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

44 case P.toList ep ++ P.toList ec of

45 case P.toList ep ++ P.toList ec of

45 issues@(_ : _) -> for_ issues $ embedFormula beh . anItem

46 issues@(_ : _) -> for_ issues $ embedFormula beh . anItem

@@ -144,21 +145,21 @@ checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

144 EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

145 EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

145 issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps

146 issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps

146

147

147−checkContradiction

148+checkContradiction ::

148− :: Behavior 'TypedSchemaLevel

149+ Behavior 'TypedSchemaLevel ->

149− -> Maybe Partition

150+ Maybe Partition ->

150− -> S.Set (Condition t)

151+ S.Set (Condition t) ->

151− -> SemanticCompatFormula ()

152+ SemanticCompatFormula ()

152checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70

153checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70

153

154

154−checkImplication

155+checkImplication ::

155− :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

156+ (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

156− => HList xs

157+ HList xs ->

157− -> Behavior 'TypedSchemaLevel

158+ Behavior 'TypedSchemaLevel ->

158− -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison

159+ ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison

159− -> S.Set (Condition t)

160+ S.Set (Condition t) ->

160− -> Condition t

161+ Condition t ->

161− -> SemanticCompatFormula ()

162+ SemanticCompatFormula ()

162checkImplication env beh trs prods cons = case findExactly prods of

163checkImplication env beh trs prods cons = case findExactly prods of

163 Just e

164 Just e

164 | all (satisfiesTyped e) prods ->

165 | all (satisfiesTyped e) prods ->

@@ -166,124 +167,104 @@ checkImplication env beh trs prods cons = case findExactly prods of

166 then pure ()

167 then pure ()

167 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

168 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

168 | otherwise -> pure () -- vacuously true

169 | otherwise -> pure () -- vacuously true

169−

170 Nothing -> case cons of

171 -- the above code didn't catch it, so there's no Exactly condition on the lhs

172 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

173−

174 Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case

173 Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case

175 Maximum m' -> Just m'

174 Maximum m' -> Just m'

176 _ -> Nothing

175 _ -> Nothing

177−

178 Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case

176 Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case

179 Minimum m' -> Just m'

177 Minimum m' -> Just m'

180 _ -> Nothing

178 _ -> Nothing

181−

182 MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case

179 MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case

183 MultipleOf m' -> Just m'

180 MultipleOf m' -> Just m'

184 _ -> Nothing

181 _ -> Nothing

185−

186 NumberFormat f -> case flip any prods $ \case

182 NumberFormat f -> case flip any prods $ \case

187− NumberFormat f' -> f == f'

183+ NumberFormat f' -> f == f'

188− _ -> False

184+ _ -> False of

189− of

190 True -> pure ()

185 True -> pure ()

191 False -> issueAt beh (NoMatchingFormat f)

186 False -> issueAt beh (NoMatchingFormat f)

192−

193 MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case

187 MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case

194 MaxLength m' -> Just m'

188 MaxLength m' -> Just m'

195 _ -> Nothing

189 _ -> Nothing

196−

197 MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case

190 MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case

198 MinLength m' -> Just m'

191 MinLength m' -> Just m'

199 _ -> Nothing

192 _ -> Nothing

200−

201 Pattern p -> case flip any prods $ \case

193 Pattern p -> case flip any prods $ \case

202− Pattern p' -> p == p'

194+ Pattern p' -> p == p'

203− _ -> False

195+ _ -> False of

204− of

205 True -> pure ()

196 True -> pure ()

206 False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

197 False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

207−

208 StringFormat f -> case flip any prods $ \case

198 StringFormat f -> case flip any prods $ \case

209− StringFormat f' -> f == f'

199+ StringFormat f' -> f == f'

210− _ -> False

200+ _ -> False of

211− of

212 True -> pure ()

201 True -> pure ()

213 False -> issueAt beh (NoMatchingFormat f)

202 False -> issueAt beh (NoMatchingFormat f)

214−

215 Items _ cons' -> case foldSome (<>) prods $ \case

203 Items _ cons' -> case foldSome (<>) prods $ \case

216− Items _ rs -> Just (Just (rs NE.:| []), mempty)

204+ Items _ rs -> Just (Just (rs NE.:| []), mempty)

217− TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

205+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

218− _ -> Nothing

206+ _ -> Nothing of

219− of

220 Just (mItems, Just pfs)

207 Just (mItems, Just pfs)

221 | not $ allSame (length <$> pfs) -> pure () -- vacuously

208 | not $ allSame (length <$> pfs) -> pure () -- vacuously

222− | let plen = genericLength (NE.head pfs)

209+ | let plen = genericLength (NE.head pfs) ->

223− -> clarifyIssue (AnItem beh (anIssue TupleToArray)) $ for_ [0 .. plen - 1] $ \i -> do

210+ clarifyIssue (AnItem beh (anIssue TupleToArray)) $

211+ for_ [0 .. plen - 1] $ \i -> do

224− let prod' = tracedConjunct $ case mItems of

212+ let prod' = tracedConjunct $ case mItems of

225− Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

213+ Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

226− Nothing -> (`genericIndex` i) <$> pfs

214+ Nothing -> (`genericIndex` i) <$> pfs

227− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

215+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

228 Just (Just prods', Nothing) -> do

216 Just (Just prods', Nothing) -> do

229 let prod' = tracedConjunct prods'

217 let prod' = tracedConjunct prods'

230 checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'

218 checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'

231 _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do

219 _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do

232 checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'

220 checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'

233−

234 TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case

221 TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case

235− TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)

222+ TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)

236− MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)

223+ MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)

237− MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

224+ MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

238− Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

225+ Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

239− _ -> Nothing

226+ _ -> Nothing of

240− of

241− -- if the length constraints in the producer are contradictory:

227+ -- if the length constraints in the producer are contradictory:

242− Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

228+ Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

243− -- We have an explicit tuple items clause...

229+ -- We have an explicit tuple items clause...

244− Just (Just pfs, Just (Max plen), _, _)

230+ Just (Just pfs, Just (Max plen), _, _)

245− | plen /= genericLength fs -- ...of wrong length

231+ | plen /= genericLength fs -> -- ...of wrong length

246− -> issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

232+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

247− | otherwise

233+ | otherwise ->

248− -> for_ [0 .. plen - 1] $ \i -> do

234+ for_ [0 .. plen - 1] $ \i -> do

249 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)

235 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)

250− -- We have a fixed length array in the producer...

236+ -- We have a fixed length array in the producer...

251− Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

237+ Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

252− | plen == plen'

238+ | plen == plen' ->

253− -> clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

239+ clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

240+ _

254− _ | plen /= genericLength fs -> -- ...of wrong length

241+ | plen /= genericLength fs -> -- ...of wrong length

255− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

242+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

256 Just rs -> for_ [0 .. plen - 1] $ \i -> do

243 Just rs -> for_ [0 .. plen - 1] $ \i -> do

257 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)

244 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)

258 -- ...and no "items" schema

245 -- ...and no "items" schema

259 Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do

246 Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do

260 for_ [0 .. plen - 1] $ \i -> do

247 for_ [0 .. plen - 1] $ \i -> do

261 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)

248 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)

262− _ -> issueAt beh NoMatchingTupleItems

249+ _ -> issueAt beh NoMatchingTupleItems

263−

264 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case

250 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case

265 MaxItems m' -> Just m'

251 MaxItems m' -> Just m'

266 TupleItems fs -> Just $ toInteger $ length fs

252 TupleItems fs -> Just $ toInteger $ length fs

267 _ -> Nothing

253 _ -> Nothing

268−

269 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case

254 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case

270 MinItems m' -> Just m'

255 MinItems m' -> Just m'

271 TupleItems fs -> Just $ toInteger $ length fs

256 TupleItems fs -> Just $ toInteger $ length fs

272 _ -> Nothing

257 _ -> Nothing

273−

274 UniqueItems -> case flip any prods $ \case

258 UniqueItems -> case flip any prods $ \case

275− UniqueItems -> True

259+ UniqueItems -> True

276− MaxItems 1 -> True

260+ MaxItems 1 -> True

277− TupleItems fs | length fs == 1 -> True

261+ TupleItems fs | length fs == 1 -> True

278− _ -> False

262+ _ -> False of

279− of

280 True -> pure ()

263 True -> pure ()

281 False -> issueAt beh NoMatchingUniqueItems

264 False -> issueAt beh NoMatchingUniqueItems

282−

283 Properties props _ madd -> case foldSome (<>) prods $ \case

265 Properties props _ madd -> case foldSome (<>) prods $ \case

284− Properties props' _ madd' -> Just $ (props', madd') NE.:| []

266+ Properties props' _ madd' -> Just $ (props', madd') NE.:| []

285− _ -> Nothing

267+ _ -> Nothing of

286− of

287 Just pm ->

268 Just pm ->

288 anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists

269 anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists

289 NE.toList pm <&> \(props', madd') -> do

270 NE.toList pm <&> \(props', madd') -> do

@@ -314,11 +295,9 @@ checkImplication env beh trs prods cons = case findExactly prods of

314 (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)

295 (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)

315 pure ()

296 pure ()

316 Nothing -> issueAt beh NoMatchingProperties

297 Nothing -> issueAt beh NoMatchingProperties

317−

318 MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case

298 MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case

319 MaxProperties m' -> Just m'

299 MaxProperties m' -> Just m'

320 _ -> Nothing

300 _ -> Nothing

321−

322 MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case

301 MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case

323 MinProperties m' -> Just m'

302 MinProperties m' -> Just m'

324 _ -> Nothing

303 _ -> Nothing

@@ -326,14 +305,14 @@ checkImplication env beh trs prods cons = case findExactly prods of

326 lcmScientific (toRational -> a) (toRational -> b) =

305 lcmScientific (toRational -> a) (toRational -> b) =

327 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

306 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

328

307

329− foldCheck

308+ foldCheck ::

330− :: Eq a

309+ Eq a =>

331− => (a -> a -> a)

310+ (a -> a -> a) ->

332− -> a

311+ a ->

333− -> (a -> Issue 'TypedSchemaLevel)

312+ (a -> Issue 'TypedSchemaLevel) ->

334− -> (ProdCons a -> Issue 'TypedSchemaLevel)

313+ (ProdCons a -> Issue 'TypedSchemaLevel) ->

335− -> (forall t. Condition t -> Maybe a)

314+ (forall t. Condition t -> Maybe a) ->

336− -> SemanticCompatFormula ()

315+ SemanticCompatFormula ()

337 foldCheck f m missing weak extr = case foldSome f prods extr of

316 foldCheck f m missing weak extr = case foldSome f prods extr of

338 Just m'

317 Just m'

339 | f m' m == m' -> pure ()

318 | f m' m == m' -> pure ()

src/Data/OpenApi/Compare/Validate/Schema/DNF.hs+8−8

@@ -1,12 +1,12 @@

1module Data.OpenApi.Compare.Validate.Schema.DNF

2− ( DNF (..)

2+ ( DNF (..),

3− , Disjunct (..)

3+ Disjunct (..),

4− , pattern SingleDisjunct

4+ pattern SingleDisjunct,

5− , pattern TopDNF

5+ pattern TopDNF,

6− , pattern BottomDNF

6+ pattern BottomDNF,

7− , pattern LiteralDNF

7+ pattern LiteralDNF,

8− , foldDNF

8+ foldDNF,

9− , forDNF

9+ forDNF,

10 )

11where

12

src/Data/OpenApi/Compare/Validate/Schema/Issues.hs+53−51

@@ -1,8 +1,8 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.Schema.Issues

4− ( Issue (..)

4+ ( Issue (..),

5− , Behave (..)

5+ Behave (..),

6 )

7where

8

@@ -100,53 +100,54 @@ instance Issuable 'TypedSchemaLevel where

100 TypeBecomesEmpty -> ProbablyIssue -- TODO: #70

101 PartitionBecomesEmpty _ -> ProbablyIssue -- ditto

102 _ -> CertainIssue

103− relatedIssues = (==) `withClass` \case

103+ relatedIssues =

104+ (==) `withClass` \case

104 EnumDoesntSatisfy v -> Just v

105 EnumDoesntSatisfy v -> Just v

105 NoMatchingEnum v -> Just v

106 NoMatchingEnum v -> Just v

106 _ -> Nothing

107 _ -> Nothing

107− `withClass` \case

108+ `withClass` \case

108− NoMatchingMaximum _ -> Just ()

109+ NoMatchingMaximum _ -> Just ()

109− MatchingMaximumWeak _ -> Just ()

110+ MatchingMaximumWeak _ -> Just ()

110− _ -> Nothing

111+ _ -> Nothing

111− `withClass` \case

112+ `withClass` \case

112− NoMatchingMinimum _ -> Just ()

113+ NoMatchingMinimum _ -> Just ()

113− MatchingMinimumWeak _ -> Just ()

114+ MatchingMinimumWeak _ -> Just ()

114− _ -> Nothing

115+ _ -> Nothing

115− `withClass` \case

116+ `withClass` \case

116− NoMatchingMultipleOf _ -> Just ()

117+ NoMatchingMultipleOf _ -> Just ()

117− MatchingMultipleOfWeak _ -> Just ()

118+ MatchingMultipleOfWeak _ -> Just ()

118− _ -> Nothing

119+ _ -> Nothing

119− `withClass` \case

120+ `withClass` \case

120− NoMatchingMaxLength _ -> Just ()

121+ NoMatchingMaxLength _ -> Just ()

121− MatchingMaxLengthWeak _ -> Just ()

122+ MatchingMaxLengthWeak _ -> Just ()

122− _ -> Nothing

123+ _ -> Nothing

123− `withClass` \case

124+ `withClass` \case

124− NoMatchingMinLength _ -> Just ()

125+ NoMatchingMinLength _ -> Just ()

125− MatchingMinLengthWeak _ -> Just ()

126+ MatchingMinLengthWeak _ -> Just ()

126− _ -> Nothing

127+ _ -> Nothing

127− `withClass` \case

128+ `withClass` \case

128− NoMatchingItems -> Just ()

129+ NoMatchingItems -> Just ()

129− ArrayToTuple -> Just ()

130+ ArrayToTuple -> Just ()

130− TupleToArray -> Just ()

131+ TupleToArray -> Just ()

131− NoMatchingTupleItems -> Just ()

132+ NoMatchingTupleItems -> Just ()

132− TupleItemsLengthChanged _ -> Just ()

133+ TupleItemsLengthChanged _ -> Just ()

133− _ -> Nothing

134+ _ -> Nothing

134− `withClass` \case

135+ `withClass` \case

135− NoMatchingMaxItems _ -> Just ()

136+ NoMatchingMaxItems _ -> Just ()

136− MatchingMaxItemsWeak _ -> Just ()

137+ MatchingMaxItemsWeak _ -> Just ()

137− _ -> Nothing

138+ _ -> Nothing

138− `withClass` \case

139+ `withClass` \case

139− NoMatchingMinItems _ -> Just ()

140+ NoMatchingMinItems _ -> Just ()

140− MatchingMinItemsWeak _ -> Just ()

141+ MatchingMinItemsWeak _ -> Just ()

141− _ -> Nothing

142+ _ -> Nothing

142− `withClass` \case

143+ `withClass` \case

143− NoMatchingMaxProperties _ -> Just ()

144+ NoMatchingMaxProperties _ -> Just ()

144− MatchingMaxPropertiesWeak _ -> Just ()

145+ MatchingMaxPropertiesWeak _ -> Just ()

145− _ -> Nothing

146+ _ -> Nothing

146− `withClass` \case

147+ `withClass` \case

147− NoMatchingMinProperties _ -> Just ()

148+ NoMatchingMinProperties _ -> Just ()

148− MatchingMinPropertiesWeak _ -> Just ()

149+ MatchingMinPropertiesWeak _ -> Just ()

149− _ -> Nothing

150+ _ -> Nothing

150 describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

151 describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

151 describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v

152 describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v

152 describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

153 describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

@@ -254,14 +255,15 @@ instance Issuable 'SchemaLevel where

254 PropertyToAdditional -> Comment

255 PropertyToAdditional -> Comment

255 TypesRestricted _ -> ProbablyIssue -- TODO: #70

256 TypesRestricted _ -> ProbablyIssue -- TODO: #70

256 _ -> CertainIssue

257 _ -> CertainIssue

257− relatedIssues = (==) `withClass` \case

258+ relatedIssues =

259+ (==) `withClass` \case

258 AdditionalToProperty -> Just ()

260 AdditionalToProperty -> Just ()

259 PropertyToAdditional -> Just ()

261 PropertyToAdditional -> Just ()

260 _ -> Nothing

262 _ -> Nothing

261− `withClass` \case

263+ `withClass` \case

262− PropertyNowRequired -> Just ()

264+ PropertyNowRequired -> Just ()

263− UnexpectedProperty -> Just ()

265+ UnexpectedProperty -> Just ()

264− _ -> Nothing

266+ _ -> Nothing

265 describeIssue _ (NotSupported i) =

267 describeIssue _ (NotSupported i) =

266 para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")

268 para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")

267 describeIssue _ OneOfNotDisjoint =

269 describeIssue _ OneOfNotDisjoint =

src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs+56−48

@@ -1,26 +1,27 @@

1module Data.OpenApi.Compare.Validate.Schema.JsonFormula

2− ( Bound (..)

2+ ( Bound (..),

3− , showBound

3+ showBound,

4− , Property (..)

4+ Property (..),

5− , Condition (..)

5+ Condition (..),

6− , showCondition

6+ showCondition,

7− , satisfiesTyped

7+ satisfiesTyped,

8− , checkStringFormat

8+ checkStringFormat,

9− , checkNumberFormat

9+ checkNumberFormat,

10− , SomeCondition (..)

10+ SomeCondition (..),

11− , JsonFormula (..)

11+ JsonFormula (..),

12− , satisfiesFormula

12+ satisfiesFormula,

13− , satisfies

13+ satisfies,

14− , showJSONValue

14+ showJSONValue,

15− , showJSONValueInline

15+ showJSONValueInline,

16 )

17where

18

19import Algebra.Lattice

20import qualified Data.Aeson as A

21+import qualified Data.Aeson.Key as Key

22+import qualified Data.Aeson.KeyMap as KeyMap

21import qualified Data.ByteString.Lazy as BSL

23import qualified Data.ByteString.Lazy as BSL

22import qualified Data.Foldable as F

24import qualified Data.Foldable as F

23−import qualified Data.HashMap.Strict as HM

24import Data.Functor

25import Data.Functor

25import Data.Int

26import Data.Int

26import Data.Kind

27import Data.Kind

@@ -39,7 +40,7 @@ import Data.Text (Text)

39import qualified Data.Text as T

40import qualified Data.Text as T

40import qualified Data.Text.Encoding as T

41import qualified Data.Text.Encoding as T

41import Data.Typeable

42import Data.Typeable

42−import Text.Pandoc.Builder hiding (Format, Null)

43+import Text.Pandoc.Builder hiding (Format)

43import Text.Regex.Pcre2

44import Text.Regex.Pcre2

44

45

45data Bound a = Exclusive !a | Inclusive !a

46data Bound a = Exclusive !a | Inclusive !a

@@ -67,30 +68,33 @@ data Property = Property

67data Condition :: JsonType -> Type where

68data Condition :: JsonType -> Type where

68 Exactly :: TypedValue t -> Condition t

69 Exactly :: TypedValue t -> Condition t

69 Maximum :: !(Bound Scientific) -> Condition 'Number

70 Maximum :: !(Bound Scientific) -> Condition 'Number

70− Minimum

71+ Minimum ::

71− :: !(Down (Bound (Down Scientific)))

72+ !(Down (Bound (Down Scientific))) ->

72− -> Condition 'Number -- ^ this has the right Ord

73+ -- | this has the right Ord

74+ Condition 'Number

73 MultipleOf :: !Scientific -> Condition 'Number

75 MultipleOf :: !Scientific -> Condition 'Number

74 NumberFormat :: !Format -> Condition 'Number

76 NumberFormat :: !Format -> Condition 'Number

75 MaxLength :: !Integer -> Condition 'String

77 MaxLength :: !Integer -> Condition 'String

76 MinLength :: !Integer -> Condition 'String

78 MinLength :: !Integer -> Condition 'String

77 Pattern :: !Pattern -> Condition 'String

79 Pattern :: !Pattern -> Condition 'String

78 StringFormat :: !Format -> Condition 'String

80 StringFormat :: !Format -> Condition 'String

79− Items

81+ Items ::

80− :: !(ForeachType JsonFormula)

82+ !(ForeachType JsonFormula) ->

81− -> !(Traced (Referenced Schema))

83+ !(Traced (Referenced Schema)) ->

82− -> Condition 'Array

84+ Condition 'Array

83− TupleItems

85+ TupleItems ::

84− :: ![(ForeachType JsonFormula, Traced (Referenced Schema))]

86+ ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->

85− -> Condition 'Array

87+ Condition 'Array

86 MaxItems :: !Integer -> Condition 'Array

88 MaxItems :: !Integer -> Condition 'Array

87 MinItems :: !Integer -> Condition 'Array

89 MinItems :: !Integer -> Condition 'Array

88 UniqueItems :: Condition 'Array

90 UniqueItems :: Condition 'Array

89− Properties

91+ Properties ::

90− :: !(M.Map Text Property)

92+ !(M.Map Text Property) ->

93+ -- | formula for additional properties

91− -> !(ForeachType JsonFormula) -- ^ formula for additional properties

94+ !(ForeachType JsonFormula) ->

92− -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom

95+ -- | schema for additional properties, Nothing means bottom

96+ !(Maybe (Traced (Referenced Schema))) ->

93− -> Condition 'Object

97+ Condition 'Object

94 MaxProperties :: !Integer -> Condition 'Object

98 MaxProperties :: !Integer -> Condition 'Object

95 MinProperties :: !Integer -> Condition 'Object

99 MinProperties :: !Integer -> Condition 'Object

96

100

@@ -118,13 +122,15 @@ showCondition = \case

118 UniqueItems -> para "The elements in the array should be unique."

122 UniqueItems -> para "The elements in the array should be unique."

119 (Properties props additional _) ->

123 (Properties props additional _) ->

120 bulletList $

124 bulletList $

121− (M.toList props

125+ ( M.toList props

122− <&> (\(k, p) ->

126+ <&> ( \(k, p) ->

123− para (code k)

127+ para (code k)

124− <> para (strong $ if propRequired p then "Required" else "Optional")

128+ <> para (strong $ if propRequired p then "Required" else "Optional")

125− <> showForEachJsonFormula (propFormula p)))

129+ <> showForEachJsonFormula (propFormula p)

130+ )

131+ )

126 <> [ para (emph "Additional properties")

132 <> [ para (emph "Additional properties")

127− <> showForEachJsonFormula additional

133+ <> showForEachJsonFormula additional

128 ]

134 ]

129 (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."

135 (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."

130 (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."

136 (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."

@@ -133,15 +139,17 @@ showCondition = \case

133 showForEachJsonFormula i =

139 showForEachJsonFormula i =

134 bulletList $

140 bulletList $

135 foldType

141 foldType

136− (\t f -> case getJsonFormula $ f i of

142+ ( \t f -> case getJsonFormula $ f i of

137− BottomDNF -> mempty

143+ BottomDNF -> mempty

138− (DNF conds) ->

144+ (DNF conds) ->

139 [ para (describeJSONType t)

145 [ para (describeJSONType t)

140 <> bulletList

146 <> bulletList

141− (S.toList conds <&> \case

147+ ( S.toList conds <&> \case

142− Disjunct (S.toList -> []) -> para "Empty"

148+ Disjunct (S.toList -> []) -> para "Empty"

143− Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))

149+ Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)

150+ )

144− ])

151+ ]

152+ )

145

153

146showJSONValue :: A.Value -> Blocks

154showJSONValue :: A.Value -> Blocks

147showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

155showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

@@ -170,10 +178,10 @@ satisfiesTyped (TArray a) (MaxItems m) = fromIntegral (F.length a) <= m

170satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

178satisfiesTyped (TArray a) (MinItems m) = fromIntegral (F.length a) >= m

171satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36

179satisfiesTyped (TArray a) UniqueItems = S.size (S.fromList $ F.toList a) == F.length a -- TODO: could be better #36

172satisfiesTyped (TObject o) (Properties props additional _) =

180satisfiesTyped (TObject o) (Properties props additional _) =

173− all (`HM.member` o) (M.keys (M.filter propRequired props))

181+ all (`KeyMap.member` o) (map Key.fromText $ M.keys (M.filter propRequired props))

174− && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup k props) (HM.toList o)

182+ && all (\(k, v) -> satisfies v $ maybe additional propFormula $ M.lookup (Key.toText k) props) (KeyMap.toList o)

175−satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (HM.size o) <= m

183+satisfiesTyped (TObject o) (MaxProperties m) = fromIntegral (KeyMap.size o) <= m

176−satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (HM.size o) >= m

184+satisfiesTyped (TObject o) (MinProperties m) = fromIntegral (KeyMap.size o) >= m

177

185

178checkNumberFormat :: Format -> Scientific -> Bool

186checkNumberFormat :: Format -> Scientific -> Bool

179checkNumberFormat "int32" (toRational -> n) =

187checkNumberFormat "int32" (toRational -> n) =

src/Data/OpenApi/Compare/Validate/Schema/Partition.hs+34−30

@@ -1,21 +1,22 @@

1module Data.OpenApi.Compare.Validate.Schema.Partition

2− ( partitionSchema

2+ ( partitionSchema,

3− , partitionRefSchema

3+ partitionRefSchema,

4− , selectPartition

4+ selectPartition,

5− , runPartitionM

5+ runPartitionM,

6− , tryPartition

6+ tryPartition,

7− , showPartition

7+ showPartition,

8− , intersectSchema

8+ intersectSchema,

9− , intersectRefSchema

9+ intersectRefSchema,

10− , IntersectionResult (..)

10+ IntersectionResult (..),

11− , runIntersectionM

11+ runIntersectionM,

12− , Partition

12+ Partition,

13 )

14where

15

16import Algebra.Lattice

17import Algebra.Lattice.Lifted

18import Control.Applicative

19+import Control.Monad (when)

19import Control.Monad.Reader hiding (ask)

20import Control.Monad.Reader hiding (ask)

20import qualified Control.Monad.Reader as R

21import qualified Control.Monad.Reader as R

21import Control.Monad.State

22import Control.Monad.State

@@ -31,6 +32,7 @@ import qualified Data.List as L

31import qualified Data.List.NonEmpty as NE

32import qualified Data.List.NonEmpty as NE

32import qualified Data.Map as M

33import qualified Data.Map as M

33import Data.Maybe

34import Data.Maybe

35+import Data.Monoid

34import Data.OpenApi

36import Data.OpenApi

35import Data.OpenApi.Compare.Memo

37import Data.OpenApi.Compare.Memo

36import Data.OpenApi.Compare.References

38import Data.OpenApi.Compare.References

@@ -43,7 +45,8 @@ import Data.Ord

43import qualified Data.Set as S

45import qualified Data.Set as S

44import Data.Text (Text)

46import Data.Text (Text)

45import qualified Data.Text as T

47import qualified Data.Text as T

48+import Data.Traversable (forM)

46−import Text.Pandoc.Builder hiding (Format, Null)

49+import Text.Pandoc.Builder hiding (Format)

47

50

48data PartitionData

51data PartitionData

49 = DByEnumValue (DNF (S.Set A.Value))

52 = DByEnumValue (DNF (S.Set A.Value))

@@ -143,10 +146,11 @@ partitionCondition = \case

143 Just _ -> top

146 Just _ -> top

144 Nothing ->

147 Nothing ->

145 singletonPart $

148 singletonPart $

146− DByProperties $ LiteralDNF

149+ DByProperties $

150+ LiteralDNF

147− ( M.keysSet $ M.filter (not . propRequired) props

151+ ( M.keysSet $ M.filter (not . propRequired) props

148− , M.keysSet $ M.filter propRequired props

152+ , M.keysSet $ M.filter propRequired props

149− )

153+ )

150 inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

154 inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

151 f <- partitionRefSchema $ propRefSchema prop

155 f <- partitionRefSchema $ propRefSchema prop

152 pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

156 pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

@@ -156,10 +160,10 @@ partitionCondition = \case

156runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

160runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

157runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

161runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

158

162

159−partitionJsonFormulas

163+partitionJsonFormulas ::

160− :: ProdCons (Traced (Definitions Schema))

164+ ProdCons (Traced (Definitions Schema)) ->

161− -> ProdCons (JsonFormula t)

165+ ProdCons (JsonFormula t) ->

162− -> Lifted Partitions

166+ Lifted Partitions

163partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

167partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

164 where

168 where

165 pcPart = partitionFormula <$> defs <*> pc

169 pcPart = partitionFormula <$> defs <*> pc

@@ -211,11 +215,11 @@ runIntersectionM defs act = case runWriterT $ runReaderT act defs of

211 Just (x, Any False) -> Same x

215 Just (x, Any False) -> Same x

212 Just (x, Any True) -> New x

216 Just (x, Any True) -> New x

213

217

214−intersectSchema

218+intersectSchema ::

215− :: PartitionLocation

219+ PartitionLocation ->

216− -> PartitionChoice

220+ PartitionChoice ->

217− -> Traced Schema

221+ Traced Schema ->

218− -> IntersectionM Schema

222+ IntersectionM Schema

219intersectSchema loc part sch = do

223intersectSchema loc part sch = do

220 allOf' <- forM (tracedAllOf sch) $ \rss ->

224 allOf' <- forM (tracedAllOf sch) $ \rss ->

221 -- Assuming i ranges over a nonempty set (checked in processSchema)

225 -- Assuming i ranges over a nonempty set (checked in processSchema)

@@ -258,11 +262,11 @@ intersectSchema loc part sch = do

258 pure $ sch' {_schemaEnum = Just enum'}

262 pure $ sch' {_schemaEnum = Just enum'}

259 CByProperties {} -> error "CByProperties not implemented"

263 CByProperties {} -> error "CByProperties not implemented"

260

264

261−intersectRefSchema

265+intersectRefSchema ::

262− :: PartitionLocation

266+ PartitionLocation ->

263− -> PartitionChoice

267+ PartitionChoice ->

264− -> Traced (Referenced Schema)

268+ Traced (Referenced Schema) ->

265− -> IntersectionM (Referenced Schema)

269+ IntersectionM (Referenced Schema)

266intersectRefSchema loc part rs = do

270intersectRefSchema loc part rs = do

267 defs <- R.ask

271 defs <- R.ask

268 Inline <$> intersectSchema loc part (dereference defs rs)

272 Inline <$> intersectSchema loc part (dereference defs rs)

src/Data/OpenApi/Compare/Validate/Schema/Process.hs+47−48

@@ -1,11 +1,11 @@

1module Data.OpenApi.Compare.Validate.Schema.Process

2− ( schemaToFormula

2+ ( schemaToFormula,

3 )

4where

5

6import Algebra.Lattice

7−import qualified Control.Monad.Reader as R

8import Control.Monad.Reader hiding (ask)

7import Control.Monad.Reader hiding (ask)

8+import qualified Control.Monad.Reader as R

9import Control.Monad.State

10import Control.Monad.Writer

11import qualified Data.Aeson as A

@@ -13,6 +13,7 @@ import Data.Functor.Identity

13import qualified Data.HashMap.Strict.InsOrd as IOHM

14import qualified Data.Map as M

15import Data.Maybe

16+import Data.Monoid

16import Data.OpenApi hiding (get)

17import Data.OpenApi hiding (get)

17import Data.OpenApi.Compare.Behavior

18import Data.OpenApi.Compare.Behavior

18import Data.OpenApi.Compare.Memo

19import Data.OpenApi.Compare.Memo

@@ -28,6 +29,7 @@ import Data.OpenApi.Compare.Validate.Schema.Traced

28import Data.OpenApi.Compare.Validate.Schema.TypedJson

29import Data.OpenApi.Compare.Validate.Schema.TypedJson

29import Data.Ord

30import Data.Ord

30import qualified Data.Set as S

31import qualified Data.Set as S

32+import Data.Traversable (forM)

31

33

32-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.

34-- | A fake writer monad that doesn't actually record anything and allows lazy recursion.

33newtype Silent w a = Silent {runSilent :: a}

35newtype Silent w a = Silent {runSilent :: a}

@@ -39,15 +41,11 @@ instance Monoid w => MonadWriter w (Silent w) where

39 listen (Silent x) = Silent (x, mempty)

41 listen (Silent x) = Silent (x, mempty)

40 pass (Silent (x, _)) = Silent x

42 pass (Silent (x, _)) = Silent x

41

43

42−instance MonadState (MemoState ()) (Silent w) where

43− get = Silent $ runIdentity $ runMemo () get

44− put _ = pure ()

45−

46type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

44type ProcessM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Writer (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

47

45

48−type SilentM = ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel))

46+type SilentM = StateT (MemoState ()) (ReaderT (Traced (Definitions Schema)) (Silent (P.PathsPrefixTree Behave AnIssue 'SchemaLevel)))

49

47

50−-- Either SilentM or ProcessM

48+-- Either ProcessM or SilentM

51type MonadProcess m =

49type MonadProcess m =

52 ( MonadReader (Traced (Definitions Schema)) m

50 ( MonadReader (Traced (Definitions Schema)) m

53 , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m

51 , MonadWriter (P.PathsPrefixTree Behave AnIssue 'SchemaLevel) m

@@ -57,11 +55,11 @@ type MonadProcess m =

57warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

55warn :: MonadProcess m => Issue 'SchemaLevel -> m ()

58warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

56warn issue = tell $ P.singleton $ AnItem Root $ anIssue issue

59

57

60−-- | Ignore warnings but allow a recursive loop that lazily computes a recursive 'Condition'.

58+-- Perform a computation lazily, ignoring the warnings and discarding memoization/loop detection information.

61−silently :: MonadProcess m => SilentM a -> m a

59+lazily :: MonadProcess m => SilentM a -> m a

62−silently m = do

60+lazily m = do

63 defs <- R.ask

61 defs <- R.ask

64− pure . runSilent $ runReaderT m defs

62+ pure $ runSilent $ runReaderT (runMemo () m) defs

65

63

66warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

64warnKnot :: MonadProcess m => KnotTier (ForeachType JsonFormula) () m

67warnKnot =

65warnKnot =

@@ -71,10 +69,10 @@ warnKnot =

71 , tieKnot = \_ -> pure

69 , tieKnot = \_ -> pure

72 }

70 }

73

71

74−processRefSchema

72+processRefSchema ::

75− :: MonadProcess m

73+ MonadProcess m =>

76− => Traced (Referenced Schema)

74+ Traced (Referenced Schema) ->

77− -> m (ForeachType JsonFormula)

75+ m (ForeachType JsonFormula)

78processRefSchema x = do

76processRefSchema x = do

79 defs <- R.ask

77 defs <- R.ask

80 memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

78 memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

@@ -82,10 +80,10 @@ processRefSchema x = do

82-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

80-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

83-- for every possible type of a JSON value. The conditions are independent, and

81-- for every possible type of a JSON value. The conditions are independent, and

84-- are thus checked independently.

82-- are thus checked independently.

85−processSchema

83+processSchema ::

86− :: MonadProcess m

84+ MonadProcess m =>

87− => Traced Schema

85+ Traced Schema ->

88− -> m (ForeachType JsonFormula)

86+ m (ForeachType JsonFormula)

89processSchema sch@(extract -> Schema {..}) = do

87processSchema sch@(extract -> Schema {..}) = do

90 let singletonFormula :: Condition t -> JsonFormula t

88 let singletonFormula :: Condition t -> JsonFormula t

91 singletonFormula = JsonFormula . LiteralDNF

89 singletonFormula = JsonFormula . LiteralDNF

@@ -243,11 +241,11 @@ processSchema sch@(extract -> Schema {..}) = do

243 itemsClause <- case tracedItems sch of

241 itemsClause <- case tracedItems sch of

244 Nothing -> pure top

242 Nothing -> pure top

245 Just (Left rs) -> do

243 Just (Left rs) -> do

246− f <- silently $ processRefSchema rs

244+ f <- lazily $ processRefSchema rs

247 pure top {forArray = singletonFormula $ Items f rs}

245 pure top {forArray = singletonFormula $ Items f rs}

248 Just (Right rss) -> do

246 Just (Right rss) -> do

249 fsrs <- forM rss $ \rs -> do

247 fsrs <- forM rss $ \rs -> do

250− f <- silently $ processRefSchema rs

248+ f <- lazily $ processRefSchema rs

251 pure (f, rs)

249 pure (f, rs)

252 pure top {forArray = singletonFormula $ TupleItems fsrs}

250 pure top {forArray = singletonFormula $ TupleItems fsrs}

253

251

@@ -273,12 +271,12 @@ processSchema sch@(extract -> Schema {..}) = do

273 _ -> top

271 _ -> top

274

272

275 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

273 (addProps, addPropSchema) <- case tracedAdditionalProperties sch of

276− Just (Right rs) -> (,Just rs) <$> silently (processRefSchema rs)

274+ Just (Right rs) -> (,Just rs) <$> lazily (processRefSchema rs)

277 Just (Left False) -> pure (bottom, Nothing)

275 Just (Left False) -> pure (bottom, Nothing)

278 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

276 _ -> pure (top, Just $ traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty)

279 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

277 propList <- forM (S.toList . S.fromList $ IOHM.keys _schemaProperties <> _schemaRequired) $ \k -> do

280 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

278 (f, psch) <- case IOHM.lookup k $ tracedProperties sch of

281− Just rs -> (,rs) <$> silently (processRefSchema rs)

279+ Just rs -> (,rs) <$> lazily (processRefSchema rs)

282 Nothing ->

280 Nothing ->

283 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

281 let fakeSchema = traced (ask sch `Snoc` AdditionalPropertiesStep) $ Inline mempty

284 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

282 in -- The mempty here is incorrect, but if addPropSchema was Nothing, then

@@ -331,26 +329,27 @@ processSchema sch@(extract -> Schema {..}) = do

331 pure $

329 pure $

332 nullableClause

330 nullableClause

333 \/ meets

331 \/ meets

334− (allClauses

332+ ( allClauses

335− <> [ anyClause

333+ <> [ anyClause

336− , oneClause

334+ , oneClause

337− , typeClause

335+ , typeClause

338− , enumClause

336+ , enumClause

339− , maximumClause

337+ , maximumClause

340− , minimumClause

338+ , minimumClause

341− , multipleOfClause

339+ , multipleOfClause

342− , formatClause

340+ , formatClause

343− , maxLengthClause

341+ , maxLengthClause

344− , minLengthClause

342+ , minLengthClause

345− , patternClause

343+ , patternClause

346− , itemsClause

344+ , itemsClause

347− , maxItemsClause

345+ , maxItemsClause

348− , minItemsClause

346+ , minItemsClause

349− , uniqueItemsClause

347+ , uniqueItemsClause

350− , propertiesClause

348+ , propertiesClause

351− , maxPropertiesClause

349+ , maxPropertiesClause

352− , minPropertiesClause

350+ , minPropertiesClause

353− ])

351+ ]

352+ )

354

353

355{- TODO: ReadOnly/WriteOnly #68 -}

354{- TODO: ReadOnly/WriteOnly #68 -}

356

355

@@ -369,8 +368,8 @@ checkOneOfDisjoint schs = do

369runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

368runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

370runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

369runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

371

370

372−schemaToFormula

371+schemaToFormula ::

373− :: Traced (Definitions Schema)

372+ Traced (Definitions Schema) ->

374− -> Traced Schema

373+ Traced Schema ->

375− -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

374+ (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

376schemaToFormula defs rs = runProcessM defs $ processSchema rs

375schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/Data/OpenApi/Compare/Validate/Schema/Traced.hs+12−12

@@ -1,18 +1,18 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.Schema.Traced

4− ( Step (..)

4+ ( Step (..),

5− , tracedAllOf

5+ tracedAllOf,

6− , tracedAnyOf

6+ tracedAnyOf,

7− , tracedOneOf

7+ tracedOneOf,

8− , tracedItems

8+ tracedItems,

9− , tracedAdditionalProperties

9+ tracedAdditionalProperties,

10− , tracedDiscriminator

10+ tracedDiscriminator,

11− , tracedProperties

11+ tracedProperties,

12− , tracedConjunct

12+ tracedConjunct,

13− , PartitionLocation (..)

13+ PartitionLocation (..),

14− , PartitionChoice (..)

14+ PartitionChoice (..),

15− , Partition

15+ Partition,

16 )

17where

18

src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs+25−23

@@ -1,11 +1,11 @@

1module Data.OpenApi.Compare.Validate.Schema.TypedJson

2− ( JsonType (..)

2+ ( JsonType (..),

3− , describeJSONType

3+ describeJSONType,

4− , TypedValue (..)

4+ TypedValue (..),

5− , untypeValue

5+ untypeValue,

6− , ForeachType (..)

6+ ForeachType (..),

7− , foldType

7+ foldType,

8− , forType_

8+ forType_,

9 )

10where

11

@@ -88,24 +88,26 @@ forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f

88forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)

89

90broadcastType :: (forall x. Typeable x => f x) -> ForeachType f

91−broadcastType k = ForeachType

91+broadcastType k =

92+ ForeachType

92− { forNull = k

93+ { forNull = k

93− , forBoolean = k

94+ , forBoolean = k

94− , forNumber = k

95+ , forNumber = k

95− , forString = k

96+ , forString = k

96− , forArray = k

97+ , forArray = k

97− , forObject = k

98+ , forObject = k

98− }

99+ }

99

100

100zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

101zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

101−zipType k f1 f2 = ForeachType

102+zipType k f1 f2 =

103+ ForeachType

102− { forNull = k (forNull f1) (forNull f2)

104+ { forNull = k (forNull f1) (forNull f2)

103− , forBoolean = k (forBoolean f1) (forBoolean f2)

105+ , forBoolean = k (forBoolean f1) (forBoolean f2)

104− , forNumber = k (forNumber f1) (forNumber f2)

106+ , forNumber = k (forNumber f1) (forNumber f2)

105− , forString = k (forString f1) (forString f2)

107+ , forString = k (forString f1) (forString f2)

106− , forArray = k (forArray f1) (forArray f2)

108+ , forArray = k (forArray f1) (forArray f2)

107− , forObject = k (forObject f1) (forObject f2)

109+ , forObject = k (forObject f1) (forObject f2)

108− }

110+ }

109

111

110instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

112instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

111 (\/) = zipType (\/)

113 (\/) = zipType (\/)

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs+9−8

@@ -2,7 +2,7 @@

2{-# OPTIONS_GHC -Wno-orphans #-}

3

4module Data.OpenApi.Compare.Validate.SecurityRequirement

5− ( Issue (..)

5+ ( Issue (..),

6 )

7where

8

@@ -41,18 +41,19 @@ instance Subtree SecurityRequirement where

41 for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->

42 (,scopes) <$> lookupScheme key defs

43 structuralMaybeWith

44− (\pc' -> do

44+ ( \pc' -> do

45− let ProdCons pScopes cScopes = fmap snd <$> pc'

45+ let ProdCons pScopes cScopes = fmap snd <$> pc'

46− unless (pScopes == cScopes) structuralIssue

46+ unless (pScopes == cScopes) structuralIssue

47− structuralList env $ fmap fst <$> pc'

47+ structuralList env $ fmap fst <$> pc'

48− pure ())

48+ pure ()

49+ )

49 normalized

50 normalized

50 pure ()

51 pure ()

51 checkSemanticCompatibility env bhv' pc = do

52 checkSemanticCompatibility env bhv' pc = do

52 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

53 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

53 ( ProdCons pErrs cErrs

54 ( ProdCons pErrs cErrs

54− , (ProdCons pSchemes cSchemes)

55+ , (ProdCons pSchemes cSchemes) ::

55− :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

56+ ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

56 ) =

57 ) =

57 NE.unzip $

58 NE.unzip $

58 partitionEithers <$> do

59 partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/Server.hs+10−9

@@ -1,7 +1,7 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

2

3module Data.OpenApi.Compare.Validate.Server

4− ( Issue (..)

4+ ( Issue (..),

5 )

6where

7

@@ -31,9 +31,9 @@ import Data.Traversable

31import Text.Pandoc.Builder

32import Prelude as P

33

34−tracedParsedServerUrlParts

34+tracedParsedServerUrlParts ::

35− :: Server

35+ Server ->

36− -> Either (Issue 'ServerLevel) ProcessedServer

36+ Either (Issue 'ServerLevel) ProcessedServer

37tracedParsedServerUrlParts s =

38 let parsedUrl = parseServerUrl $ _serverUrl s

39 lookupVar var = case IOHM.lookup var (_serverVariables s) of

@@ -63,11 +63,12 @@ instance Subtree [Server] where

63 pcServer

64 <&> partitionEithers

65 . fmap

66− (\(Traced t s) ->

66+ ( \(Traced t s) ->

67− let bhv = beh >>> step (InServer $ _serverUrl s)

67+ let bhv = beh >>> step (InServer $ _serverUrl s)

68− in case tracedParsedServerUrlParts s of

68+ in case tracedParsedServerUrlParts s of

69− Left e -> Left $ issueAt bhv e

69+ Left e -> Left $ issueAt bhv e

70− Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))

70+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u)

71+ )

71 . sequence

72 . sequence

72 sequenceA_ pErrs

73 sequenceA_ pErrs

73 sequenceA_ cErrs

74 sequenceA_ cErrs

src/Data/OpenApi/Compare/Validate/Sums.hs+12−11

@@ -1,24 +1,25 @@

1module Data.OpenApi.Compare.Validate.Sums

2− ( checkSums

2+ ( checkSums,

3+ )

3− ) where

4+where

4

5

5import Data.Foldable

6import Data.Foldable

6import Data.Map.Strict (Map)

7import Data.Map.Strict (Map)

7import qualified Data.Map.Strict as M

8import qualified Data.Map.Strict as M

8import Data.OpenApi.Compare.Behavior

9import Data.OpenApi.Compare.Behavior

9−import Data.OpenApi.Compare.Subtree

10import Data.OpenApi.Compare.Paths

11+import Data.OpenApi.Compare.Subtree

11

12

12−checkSums

13+checkSums ::

13− :: (Ord k, Issuable l)

14+ (Ord k, Issuable l) =>

14− => Paths q r l

15+ Paths q r l ->

15− -> (k -> Issue l)

16+ (k -> Issue l) ->

16− -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

17+ (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

17− -> ProdCons (Map k t)

18+ ProdCons (Map k t) ->

18− -> CompatFormula' q AnIssue r ()

19+ CompatFormula' q AnIssue r ()

19checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

20checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

20 case M.lookup key c of

21 case M.lookup key c of

21 Nothing -> issueAt xs $ noElt key

22 Nothing -> issueAt xs $ noElt key

22 Just consElt ->

23 Just consElt ->

23 let sumElts = ProdCons prodElt consElt

24 let sumElts = ProdCons prodElt consElt

24− in check key sumElts

25+ in check key sumElts

src/Data/OpenUnion/Extra.hs+5−5

@@ -1,7 +1,7 @@

1module Data.OpenUnion.Extra

2− ( (@@>)

2+ ( (@@>),

3− , TryLiftUnion (..)

3+ TryLiftUnion (..),

4− , pattern SingletonUnion

4+ pattern SingletonUnion,

5 )

6where

7

@@ -18,8 +18,8 @@ instance TryLiftUnion '[] where

18 tryLiftUnion _ = empty

19

20instance

21− (Typeable y, SubList ys (y : ys), TryLiftUnion ys)

21+ (Typeable y, SubList ys (y : ys), TryLiftUnion ys) =>

22− => TryLiftUnion (y ': ys)

22+ TryLiftUnion (y ': ys)

23 where

24 tryLiftUnion (x :: x) = case eqT @x @y of

25 Nothing -> reUnion <$> tryLiftUnion @ys x

stack.yaml+18−6

@@ -1,11 +1,23 @@

1−resolver: lts-18.4

1+resolver: lts-22.34

2+

3+packages:

4+ - .

2

5

3extra-deps:

6extra-deps:

7+ - base16-bytestring-1.0.2.0

8+ - freer-simple-1.2.1.2

9+ - generics-sop-0.5.1.4

10+ - github-0.29

11+ - http-link-header-1.2.1

4 - open-union-0.4.0.0

12 - open-union-0.4.0.0

13+ - th-abstraction-0.7.0.0

5 - type-fun-0.1.3

14 - type-fun-0.1.3

6− - github-0.26

15+ - typerep-map-0.6.0.0

7− - base16-bytestring-0.1.1.7

16+

8− - http-link-header-1.0.3.1

17+# Required for freer-simple and typerep-map

18+allow-newer: true

9

19

10−apply-ghc-options: everything

20+nix:

11−rebuild-ghc-options: true

21+# packages: [pkg-config yq zlib]

22+ shell-file: ./nix/shell.nix

23+ pure: false

stack.yaml.lock+4−4

@@ -41,7 +41,7 @@ packages:

41 hackage: http-link-header-1.0.3.1

42snapshots:

43- completed:

44− size: 585817

44+ size: 587393

45− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/4.yaml

45+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/25.yaml

46− sha256: ea3a318eafa9e9cc56bfbe46099fd0d54d32641ab7bbe1d182ed8f5de39f804c

46+ sha256: 1b74fb5e970497b5aefae56703f1bd44aa648bd1a5ef95c1eb8c29775087e2bf

47− original: lts-18.4

47+ original: lts-18.25

test/Spec/Golden/Extra.hs+48−44

@@ -1,8 +1,8 @@

1module Spec.Golden.Extra

2− ( getGoldenInputs

2+ ( getGoldenInputs,

3− , getGoldenInputsUniform

3+ getGoldenInputsUniform,

4− , goldenInputsTree

4+ goldenInputsTree,

5− , goldenInputsTreeUniform

5+ goldenInputsTreeUniform,

6 )

7where

8

@@ -19,12 +19,12 @@ data TestInput t

19 | TestInputLeaf TestName t FilePath

20 deriving stock (Functor)

21

22−getGoldenInputs

22+getGoldenInputs ::

23− :: (Each s t (FilePath, FilePath -> IO a) a)

23+ (Each s t (FilePath, FilePath -> IO a) a) =>

24− => TestName

24+ TestName ->

25− -> FilePath

25+ FilePath ->

26− -> s

26+ s ->

27− -> IO (TestInput t)

27+ IO (TestInput t)

28getGoldenInputs name filepath inp = do

29 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))

30 case dirs' of

@@ -39,51 +39,55 @@ getGoldenInputs name filepath inp = do

39 TestInputNode name

40 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)

41

42−getGoldenInputsUniform

42+getGoldenInputsUniform ::

43− :: (Each t h (FilePath, FilePath -> IO a) a)

43+ (Each t h (FilePath, FilePath -> IO a) a) =>

44− => (Each s t FilePath (FilePath, FilePath -> IO a))

44+ (Each s t FilePath (FilePath, FilePath -> IO a)) =>

45− => TestName

45+ TestName ->

46− -> (FilePath -> IO a)

46+ (FilePath -> IO a) ->

47− -> FilePath

47+ FilePath ->

48− -> s

48+ s ->

49− -> IO (TestInput h)

49+ IO (TestInput h)

50getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)

51

52−goldenInputsTree

52+goldenInputsTree ::

53− :: (Each s t (FilePath, FilePath -> IO a) a)

53+ (Each s t (FilePath, FilePath -> IO a) a) =>

54− => TestName

54+ TestName ->

55− -> FilePath -- ^ Root path

55+ -- | Root path

56+ FilePath ->

56− -> FilePath -- ^ Name of golden file

57+ -- | Name of golden file

57− -> s

58+ FilePath ->

59+ s ->

58− -> (t -> IO BSL.ByteString)

60+ (t -> IO BSL.ByteString) ->

59− -> IO TestTree

61+ IO TestTree

60−goldenInputsTree name filepath golden inp f = do

62+goldenInputsTree name filepath golden inp f =

61 runTestInputTree golden f <$> getGoldenInputs name filepath inp

63 runTestInputTree golden f <$> getGoldenInputs name filepath inp

62

64

63−runTestInputTree

65+runTestInputTree ::

64− :: FilePath

66+ FilePath ->

65− -> (t -> IO BSL.ByteString)

67+ (t -> IO BSL.ByteString) ->

66− -> TestInput t

68+ TestInput t ->

67− -> TestTree

69+ TestTree

68runTestInputTree golden f (TestInputNode name rest) =

70runTestInputTree golden f (TestInputNode name rest) =

69 testGroup name (runTestInputTree golden f <$> rest)

71 testGroup name (runTestInputTree golden f <$> rest)

70runTestInputTree golden f (TestInputLeaf name t path) =

72runTestInputTree golden f (TestInputLeaf name t path) =

71 goldenVsStringDiff

73 goldenVsStringDiff

72 name

74 name

73− (\ref new -> ["diff", "-u", ref, new])

75+ (\ref new -> ["diff-yaml", ref, new])

74 (path </> golden)

76 (path </> golden)

75 (f t)

77 (f t)

76

78

77−goldenInputsTreeUniform

79+goldenInputsTreeUniform ::

78− :: ( Each t h (FilePath, FilePath -> IO a) a

80+ ( Each t h (FilePath, FilePath -> IO a) a

79− , Each s t FilePath (FilePath, FilePath -> IO a)

81+ , Each s t FilePath (FilePath, FilePath -> IO a)

80− )

82+ ) =>

81− => String

83+ String ->

82− -> FilePath -- ^ Root path

84+ -- | Root path

85+ FilePath ->

83− -> FilePath -- ^ Name of golden file

86+ -- | Name of golden file

84− -> s

87+ FilePath ->

88+ s ->

85− -> (FilePath -> IO a)

89+ (FilePath -> IO a) ->

86− -> (h -> IO BSL.ByteString)

90+ (h -> IO BSL.ByteString) ->

87− -> IO TestTree

91+ IO TestTree

88goldenInputsTreeUniform name filepath golden inp h =

92goldenInputsTreeUniform name filepath golden inp h =

89 goldenInputsTree name filepath golden (inp & each %~ (,h))

93 goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/TraceTree.hs+2−2

@@ -25,7 +25,7 @@ tests = do

25 traceTreeTests <-

26 goldenInputsTreeUniform

27 "TraceTree"

28− "test/golden/common"

28+ "test/golden"

29 "trace-tree.yaml"

30 ("a.yaml", "b.yaml")

31 Yaml.decodeFileThrow

@@ -34,7 +34,7 @@ tests = do

34 reportTests <-

35 goldenInputsTreeUniform

36 "Report"

37− "test/golden/common"

37+ "test/golden"

38 "report.md"

39 ("a.yaml", "b.yaml")

40 Yaml.decodeFileThrow

test/golden/common/bad-oneof-unchanged/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

4−|--------------------|-------------------------|-------------------------------------------------------|

4+|---------------------|-------------------------|--------------------------------------------------------|

5−| 0 | 0 | 2 |

5+| 0 | 0 | 2 |

6

7# ❓ Unsupported feature changes

8

test/golden/common/enum-added/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/enum-anyof/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/id/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/json/recursive/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/maximum-lowered/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/parameters/allowEmptyValue/reset/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/parameters/allowEmptyValue/set/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/parameters/change/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/parameters/required/false/add/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/pathItem/operation/parameters/required/false/del/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/pathItem/operation/parameters/required/reset/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/parameters/required/set/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/parameters/required/true/add/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/parameters/required/true/del/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/add/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/change/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/requestBody/mediaTypeObject/del/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/requestBody/required/reset/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/requestBody/required/set/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/responses/add/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/responses/change/headers/mandatory/add/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/responses/change/headers/mandatory/del/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/responses/change/headers/optional/add/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/pathItem/operation/responses/change/headers/optional/del/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/add/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 1 | 0 |

5+| 1 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/change/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/pathItem/operation/responses/change/mediaTypeObject/del/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/pathItem/operation/responses/del/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|--------------------|--------------------------------------------------|

4+|---------------------|--------------------------------------------------|

5−| 0 | 1 |

5+| 0 | 1 |

6

7# ⚠️ Non-breaking changes

8

test/golden/common/property-removed-additional/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 3 | 3 |

5+| 3 | 3 |

6

7# ❌ Breaking changes

8

test/golden/common/property-removed/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 2 | 0 |

5+| 2 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/property-required/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/random-example/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 5 | 6 |

5+| 5 | 6 |

6

7# ❌ Breaking changes

8

test/golden/common/random-example/trace-tree.yaml+4−4

@@ -23,6 +23,10 @@ forwardChanges:

23backwardChanges:

24 AtPath "/pets":

25 InOperation GetMethod:

26+ InParam "limit":

27+ InParamSchema:

28+ OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,

29+ consumer = Inclusive 20.0})

26 WithStatusCode 200:

30 WithStatusCode 200:

27 ResponsePayload:

31 ResponsePayload:

28 PayloadSchema:

32 PayloadSchema:

@@ -33,10 +37,6 @@ backwardChanges:

33 - TypesRestricted [Number]

37 - TypesRestricted [Number]

34 - AdditionalToProperty

38 - AdditionalToProperty

35 - OfType Number: NoMatchingMultipleOf 1.0

39 - OfType Number: NoMatchingMultipleOf 1.0

36− InParam "limit":

37− InParamSchema:

38− OfType Number: MatchingMaximumWeak (ProdCons {producer = Inclusive 30.0,

39− consumer = Inclusive 20.0})

40 InOperation PostMethod:

41 InRequest:

42 InPayload:

test/golden/common/recursive/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/security-scheme/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 2 | 1 |

5+| 2 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/servers/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 3 | 1 |

5+| 3 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/tuple-items/heterogeneous-component-mismatch/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

5+| 2 | 2 |

6

7# ❌ Breaking changes

8

test/golden/common/tuple-items/heterogeneous-length-mismatch/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | ⚠️ Non-breaking changes |

4−|-----------------------------------------|-------------------------|

4+|------------------------------------------|-------------------------|

5−| 2 | 0 |

5+| 2 | 0 |

6

7# ❌ Breaking changes

8

test/golden/common/tuple-items/homogeneous-component-mismatch/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 4 | 2 |

5+| 4 | 2 |

6

7# ❌ Breaking changes

8

test/golden/common/tuple-items/homogeneous-length-mismatch/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 5 | 5 |

5+| 5 | 5 |

6

7# ❌ Breaking changes

8

test/golden/common/tuple-items/homogeneous-vector/report.md+2−2

@@ -1,5 +1,5 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes |

4−|--------------------|-------------------------|

4+|---------------------|-------------------------|

5−| 0 | 0 |

5+| 0 | 0 |

test/golden/common/type-changing/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 6 | 6 |

5+| 6 | 6 |

6

7# ❌ Breaking changes

8

test/golden/common/unguarded-recursive/a.yaml → test/golden/common/unguarded-recursive/basic/a.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/b.yaml → test/golden/common/unguarded-recursive/basic/b.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/report.md → test/golden/common/unguarded-recursive/basic/report.mdrenamed+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

4−|--------------------|-------------------------|-------------------------------------------------------|

4+|---------------------|-------------------------|--------------------------------------------------------|

5−| 0 | 0 | 1 |

5+| 0 | 0 | 1 |

6

7# ❓ Unsupported feature changes

8

test/golden/common/unguarded-recursive/trace-tree.yaml → test/golden/common/unguarded-recursive/basic/trace-tree.yamlrenamed

The content is the same.

test/golden/common/unguarded-recursive/silent/a.yamlnew file+25

@@ -0,0 +1,25 @@

1+components:

2+ schemas:

3+ A:

4+ type: object

5+ properties:

6+ bar:

7+ $ref: "#/components/schemas/B"

8+ B:

9+ anyOf:

10+ - $ref: "#/components/schemas/B"

11+ type: object

12+openapi: 3.0.0

13+info:

14+ version: ""

15+ title: ""

16+paths:

17+ /foo:

18+ get:

19+ responses:

20+ "200":

21+ content:

22+ application/json;charset=utf-8:

23+ schema:

24+ $ref: "#/components/schemas/A"

25+ description: ""

test/golden/common/unguarded-recursive/silent/b.yamlnew file+19

@@ -0,0 +1,19 @@

1+components:

2+ schemas: {}

3+openapi: 3.0.0

4+info:

5+ version: ""

6+ title: ""

7+paths:

8+ /foo:

9+ get:

10+ responses:

11+ "200":

12+ content:

13+ application/json;charset=utf-8:

14+ schema:

15+ type: object

16+ properties:

17+ bar:

18+ type: object

19+ description: ""

test/golden/common/unguarded-recursive/silent/report.mdnew file+15

@@ -0,0 +1,15 @@

1+# Summary

2+

3+| ❌ Breaking changes | ⚠️ Non-breaking changes | [❓ Unsupported feature changes](#unsupported-changes) |

4+|---------------------|-------------------------|--------------------------------------------------------|

5+| 0 | 0 | 1 |

6+

7+# ❓ Unsupported feature changes

8+

9+## **GET** /foo

10+

11+### ⬅️☁️ JSON Response – 200

12+

13+#### `$.bar`

14+

15+Encountered recursion that is too complex for CompaREST to untangle.

test/golden/common/unguarded-recursive/silent/trace-tree.yamlnew file+16

@@ -0,0 +1,16 @@

1+forwardChanges:

2+ AtPath "/foo":

3+ InOperation GetMethod:

4+ WithStatusCode 200:

5+ ResponsePayload:

6+ PayloadSchema:

7+ OfType Object:

8+ InProperty "bar": UnguardedRecursion

9+backwardChanges:

10+ AtPath "/foo":

11+ InOperation GetMethod:

12+ WithStatusCode 200:

13+ ResponsePayload:

14+ PayloadSchema:

15+ OfType Object:

16+ InProperty "bar": UnguardedRecursion

test/golden/common/variant-added/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 1 | 1 |

5+| 1 | 1 |

6

7# ❌ Breaking changes

8

test/golden/common/variant-changed/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

5+| 2 | 2 |

6

7# ❌ Breaking changes

8

test/golden/common/variant-deep-changed/report.md+2−2

@@ -1,8 +1,8 @@

1# Summary

2

3| [❌ Breaking changes](#breaking-changes) | [⚠️ Non-breaking changes](#non-breaking-changes) |

4−|-----------------------------------------|--------------------------------------------------|

4+|------------------------------------------|--------------------------------------------------|

5−| 2 | 2 |

5+| 2 | 2 |

6

7# ❌ Breaking changes

8