master..89b190c · compaREST

.github/actions/common_setup/action.yaml+6−27

@@ -1,34 +1,12 @@

11name: "Common setup"

22description: "Common setup steps"

33inputs:

4− authToken:

5− description: "Cachix auth token"

4+ key:

5+ description: "Caching key"

66 required: true

77runs:

88 using: "composite"

99 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−

3210 - name: Install Nix

3311 uses: cachix/install-nix-action@v16

3412 with:

@@ -36,7 +14,8 @@ runs:

3614 system-features = kvm

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

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

39− - uses: cachix/cachix-action@v10

17+

18+ - name: Cache Nix

19+ uses: ./.github/actions/nix_cache

4020 with:

41− name: typeable

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

21+ key: ${{ inputs.key }}

.github/actions/nix_cache/action.yamlnew file+25

@@ -0,0 +1,25 @@

1+name: "Nix cache"

2+description: "Cache nix build"

3+inputs:

4+ key:

5+ description: "Caching key"

6+ required: true

7+runs:

8+ using: "composite"

9+ steps:

10+ - name: Cache Nix

11+ id: cache-nix

12+ uses: actions/cache@v2.1.7

13+ with:

14+ path: |

15+ ~/nix/store

16+ key: ${{ inputs.key }}

17+ - name: Move nix cache

18+ shell: bash

19+ env:

20+ CACHE_HIT: ${{ steps.cache-nix.outputs.cache-hit }}

21+ run: |

22+ if [[ "$CACHE_HIT" == 'true' ]]; then

23+ sudo mkdir -p $NIX_STORE

24+ sudo mv -f ~/nix/store/* /nix/store/

25+ fi

.github/actions/nix_cache_post/action.yamlnew file+10

@@ -0,0 +1,10 @@

1+name: "Nix cache post"

2+description: "Cache nix build post"

3+runs:

4+ using: "composite"

5+ steps:

6+ - name: Move nix cache

7+ shell: bash

8+ run: |

9+ mkdir -p ~/nix/store

10+ sudo mv -f /nix/store/* ~/nix/store/

.github/workflows/github-actions-image.yaml+66−171

@@ -9,81 +9,21 @@ on:

99 types: [prereleased]

1010

1111jobs:

12− check-formatting:

13− name: Check Haskell formatting

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

27−

28− policeman:

29− runs-on: ubuntu-latest

30− steps:

31− - uses: actions/checkout@v2

32− with:

33− submodules: recursive

34−

35− - name: Common setup

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

37− with:

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

39−

40− - name: Run policeman

41− run: |

42− jq --argjson msg "$( $(nix-build ci/policeman.nix)/bin/policeman | grep -v "⚙" | jq -aRs . )" ".[0].message = \$msg" <policeman.json >message.json

43− cat message.json

44−

45− - name: Post notice

46− uses: yuzutech/annotations-action@v0.4.0

47− with:

48− title: 👮 Policeman

49− repo-token: "${{ secrets.GITHUB_TOKEN }}"

50− input: "./message.json"

51−

52− check_versions:

12+ Linux:

5313 runs-on: ubuntu-latest

5414 steps:

55− - uses: actions/checkout@v2

56− with:

57− submodules: recursive

58−

59− - name: Check library version

60− if: github.event_name == 'release'

15+ - name: Increase swap

16+ shell: bash

6117 run: |

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

63− echo "::error file=compaREST.cabal::Library version does not match release version."

64− exit 1

65− fi

18+ free -h

6619

67− - name: Check docker tag

68− if: github.event_name == 'release'

69− run: |

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

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

72− exit 1

73− fi

20+ sudo swapoff /mnt/swapfile

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

22+ sudo mkswap /mnt/swapfile

23+ sudo swapon /mnt/swapfile

7424

75− - name: Check changelog

76− if: github.event_name == 'release'

77− run: |

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

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

80− exit 1

81− fi

25+ free -h

8226

83− Linux:

84− needs: check_versions

85− runs-on: ubuntu-latest

86− steps:

8727 - uses: actions/checkout@v2

8828 with:

8929 submodules: recursive

@@ -91,17 +31,16 @@ jobs:

9131 - name: Common setup

9232 uses: ./.github/actions/common_setup

9333 with:

94− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

95−

96− - name: Test

97− shell: bash

98− run: |

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

34+ key: |

35+ Linux-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}-${{ hashFiles('**.cabal') }}

36+ Linux-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}

37+ Linux-${{ hashFiles('**.nix') }}

38+ Linux

10039

10140 - name: Build Linux static binary

10241 shell: bash

10342 run: |

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

43+ cp $(nix-build -A compaRESTStaticBin -j auto)/bin/compaREST compaREST

10544

10645 - name: Upload compaREST Linux Binary

10746 uses: actions/upload-artifact@v2

@@ -109,19 +48,19 @@ jobs:

10948 name: compaREST-Linux

11049 path: compaREST

11150

112− - name: Build Docker Images

51+ - name: Build Github Action Docker Image

11352 shell: bash

11453 run: |

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

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

54+ cp $(nix-build -A compaRESTGithubAction -j auto) compaREST-Github-Action-image.tar.gz

55+ cp $(nix-build -A compaRESTImage-j auto) compaREST-image.tar.gz

11756

118− - name: Upload compaREST Docker Github Action Image

57+ - name: Upload compaREST Github Action Image

11958 uses: actions/upload-artifact@v2

12059 with:

12160 name: compaREST Github Action Docker Image

12261 path: compaREST-Github-Action-image.tar.gz

12362

124− - name: Upload compaREST Docker Image

63+ - name: Upload compaREST Image

12564 uses: actions/upload-artifact@v2

12665 with:

12766 name: compaREST Docker Image

@@ -135,30 +74,18 @@ jobs:

13574 sudo apt-get -y install skopeo

13675

13776 - name: Login to DockerHub

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

13878 uses: docker/login-action@v1.10.0

13979 with:

140− username: ${{ secrets.DOCKER_HUB_USERNAME }}

141− password: ${{ secrets.DOCKER_HUB_ACCESS_TOKEN }}

80+ username: ${{ secrets.DOCKERHUB_USERNAME }}

81+ password: ${{ secrets.DOCKERHUB_TOKEN }}

14282

143− - name: Push Nightly Docker Images to DockerHub

144− if: github.ref == 'refs/heads/master' && github.event_name == 'push'

145− shell: bash

146− run: |

147− skopeo copy docker-archive:$(nix-build -A compaRESTGithubAction -j auto --no-out-link) docker://ilyakooo0/comparest-github-action:nightly

148− skopeo copy docker-archive:$(nix-build -A compaRESTImage -j auto --no-out-link) docker://ilyakooo0/comparest:nightly

149−

150− - name: Push Release Docker Images to DockerHub

151− if: github.event_name == 'release'

152− shell: bash

153− run: |

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

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

156−

157− - name: Zip Release Assets

83+ - name: Push Docker Images to DockerHub

15884 if: github.event_name == 'release'

15985 shell: bash

16086 run: |

161− zip compaREST-Linux-x86.zip compaREST

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

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

16289

16390 - name: Upload compaREST Github Action Docker Image to release

16491 if: github.event_name == 'release'

@@ -166,6 +93,7 @@ jobs:

16693 with:

16794 repo_token: ${{ secrets.GITHUB_TOKEN }}

16895 file: compaREST-Github-Action-image.tar.gz

96+ asset_name: compaREST Github Action Docker Image

16997 tag: ${{ github.ref }}

17098

17199 - name: Upload compaREST Docker Image to release

@@ -174,6 +102,7 @@ jobs:

174102 with:

175103 repo_token: ${{ secrets.GITHUB_TOKEN }}

176104 file: compaREST-image.tar.gz

105+ asset_name: compaREST Docker Image

177106 tag: ${{ github.ref }}

178107

179108 - name: Upload compaREST binary – Linux – x86 to release

@@ -181,63 +110,14 @@ jobs:

181110 uses: svenstaro/upload-release-action@2.2.1

182111 with:

183112 repo_token: ${{ secrets.GITHUB_TOKEN }}

184− file: compaREST-Linux-x86.zip

113+ file: compaREST

114+ asset_name: compaREST binary – Linux – x86

185115 tag: ${{ github.ref }}

186116

187− dist:

188− needs: check_versions

189− runs-on: ubuntu-latest

190− steps:

191− - uses: actions/checkout@v2

192− with:

193− submodules: recursive

194−

195− - name: Cache

196− uses: actions/cache@v1

197− with:

198− path: |

199− ~/.stack

200− .stack-work

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

202− restore-keys: |

203− ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }}

204− ${{ runner.os }}-stack

205−

206− - name: Upgrade stack

207− shell: bash

208− # Needed for Hackage token authorization

209− run: stack upgrade --git

210−

211− - name: Build dist

212− run: |

213− stack sdist --pvp-bounds both --test-tarball

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

215−

216− - name: Upload compaREST sources artifact

217− uses: actions/upload-artifact@v2

218− with:

219− name: compaREST sources

220− path: ${{ env.distPath }}/*.tar.gz

221−

222− - name: Upload compaREST sources to release

223− if: github.event_name == 'release'

224− uses: svenstaro/upload-release-action@2.2.1

225− with:

226− repo_token: ${{ secrets.GITHUB_TOKEN }}

227− file_glob: true

228− file: ${{ env.distPath }}/*.tar.gz

229− tag: ${{ github.ref }}

230−

231− - name: Publish compaREST candidate to Hackage

232− shell: bash

233− if: github.event_name == 'release'

234− env:

235− HACKAGE_KEY: ${{ secrets.HACKAGE_KEY }}

236− run: |

237− stack upload --pvp-bounds both --test-tarball --candidate .

117+ - name: Cache Nix post

118+ uses: ./.github/actions/nix_cache_post

238119

239120 macOS:

240− needs: check_versions

241121 runs-on: macos-latest

242122 steps:

243123 - uses: actions/checkout@v2

@@ -247,11 +127,15 @@ jobs:

247127 - name: Common setup

248128 uses: ./.github/actions/common_setup

249129 with:

250− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

130+ key: |

131+ macOS-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}-${{ hashFiles('**.cabal') }}

132+ macOS-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}

133+ macOS-${{ hashFiles('**.nix') }}

134+ macOS

251135

252136 - name: Build macOS binary bundle

253137 run: |

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

138+ cp -LR $(nix-build -A macOSCompaRESTBundle -j auto) compaREST

255139

256140 - name: Upload macOS compaREST bundle

257141 uses: actions/upload-artifact@v2

@@ -259,24 +143,33 @@ jobs:

259143 name: compaREST binary – macOS – x86

260144 path: compaREST

261145

262− - name: Zip Release Assets

263− if: github.event_name == 'release'

264− shell: bash

265− run: |

266− zip -r compaREST-macOS-x86.zip compaREST

267−

268146 - name: Upload compaREST binary – macOS – x86 to release

269147 if: github.event_name == 'release'

270148 uses: svenstaro/upload-release-action@2.2.1

271149 with:

272150 repo_token: ${{ secrets.GITHUB_TOKEN }}

273− file: compaREST-macOS-x86.zip

151+ file: compaREST

152+ asset_name: compaREST binary – macOS – x86

274153 tag: ${{ github.ref }}

275154

155+ - name: Cache Nix post

156+ uses: ./.github/actions/nix_cache_post

157+

276158 Linux-Windows:

277− needs: check_versions

278159 runs-on: ubuntu-latest

279160 steps:

161+ - name: Increase swap

162+ shell: bash

163+ run: |

164+ free -h

165+

166+ sudo swapoff /mnt/swapfile

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

168+ sudo mkswap /mnt/swapfile

169+ sudo swapon /mnt/swapfile

170+

171+ free -h

172+

280173 - uses: actions/checkout@v2

281174 with:

282175 submodules: recursive

@@ -284,11 +177,15 @@ jobs:

284177 - name: Common setup

285178 uses: ./.github/actions/common_setup

286179 with:

287− authToken: ${{ secrets.CACHIX_AUTH_TOKEN }}

180+ key: |

181+ Linux-Windows-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}-${{ hashFiles('**.cabal') }}

182+ Linux-Windows-${{ hashFiles('**.nix') }}-${{ hashFiles('stack.yaml') }}

183+ Linux-Windows-${{ hashFiles('**.nix') }}

184+ Linux-Windows

288185

289186 - name: Build Windows binary

290187 run: |

291− cp -LR $(nix-build -A WindowsCompaRESTBin -j auto --no-out-link)/bin compaREST

188+ cp -LR $(nix-build -A WindowsCompaRESTBin -j auto)/bin compaREST

292189

293190 - name: Upload Windows compaREST bundle

294191 uses: actions/upload-artifact@v2

@@ -296,16 +193,14 @@ jobs:

296193 name: compaREST binary – Windows

297194 path: compaREST

298195

299− - name: Zip Release Assets

300− if: github.event_name == 'release'

301− shell: bash

302− run: |

303− zip -r compaREST-Windows.zip compaREST

304−

305196 - name: Upload compaREST binary – Windows to release

306197 if: github.event_name == 'release'

307198 uses: svenstaro/upload-release-action@2.2.1

308199 with:

309200 repo_token: ${{ secrets.GITHUB_TOKEN }}

310− file: compaREST-Windows.zip

201+ file: compaREST

202+ asset_name: compaREST binary – Windows

311203 tag: ${{ github.ref }}

204+

205+ - name: Cache Nix post

206+ uses: ./.github/actions/nix_cache_post

action.yaml+1−1

@@ -29,7 +29,7 @@ inputs:

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

3030runs:

3131 using: "docker"

32− image: "docker://typeable/comparest-github-action:0.0.0.0"

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

3333 env:

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

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

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

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

11module Data.OpenApi.Compare.Options

2− ( Options (..),

3− OutputMode (..),

4− parseOptions,

2+ ( Options (..)

3+ , OutputMode (..)

4+ , parseOptions

55 )

66where

77

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

3030optionsParserInfo =

3131 info

3232 (helper <*> optionsParser)

33− ( fullDesc

34− <> header "CompaREST"

35− <> progDescDoc

36− ( Just $

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

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

39− <$$> indent

40− 4

41− ( 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 <> 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 <> 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 <> 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− )

50− )

51− )

33+ (fullDesc

34+ <> header "CompaREST"

35+ <> progDescDoc

36+ (Just $

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

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

39+ <$$> indent

40+ 4

41+ (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 <> 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 <> 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 <> 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")))

5249

5350optionsParser :: Parser Options

5451optionsParser =

5552 Options

5653 <$> strOption

57− ( short 'c'

58− <> long "client"

59− <> help

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

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

62− )

54+ (short 'c'

55+ <> long "client"

56+ <> help

57+ "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.")

6359 <*> strOption

64− ( short 's'

65− <> long "server"

66− <> help

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

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

69− )

70− <*> ( flag'

71− Nothing

72− ( long "silent"

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

74− )

75− <|> flag'

76− (Just OnlyErrors)

77− ( long "only-breaking"

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

79− )

80− <|> flag'

81− (Just All)

82− ( long "all"

83− <> help

84− "Report both incompatible and compatible changes. \

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

86− )

87− <|> pure (Just All)

88− )

89− <*> ( ( FileMode

90− <$> strOption

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

92− <> helpDoc

93− ( Just $

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

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

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

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

98− )

99− )

100− )

101− <|> pure StdoutMode

102− )

103− <*> ( flag'

104− FoldingBlockquotesTreeStyle

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

60+ (short 's'

61+ <> long "server"

62+ <> help

63+ "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.")

65+ <*> (flag'

66+ Nothing

67+ (long "silent"

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

69+ <|> flag'

70+ (Just OnlyErrors)

71+ (long "only-breaking"

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

73+ <|> flag'

74+ (Just All)

75+ (long "all"

76+ <> help

77+ "Report both incompatible and compatible changes. \

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

79+ <|> pure (Just All))

80+ <*> ((FileMode

81+ <$> strOption

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

83+ <> helpDoc

84+ (Just $

85+ 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."

87+ <$$> 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.")))

89+ <|> pure StdoutMode)

90+ <*> (flag'

91+ FoldingBlockquotesTreeStyle

92+ (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"

106102 <> help

107103 "The report tree is structured using \

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

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

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

111− \bugs on GitHub."

112− )

113− <|> flag'

114− HeadersTreeStyle

115− ( long "header-style"

116− <> help

117− "The report tree is structured using \

118− \increasing levels of headers."

119− )

120− <|> pure HeadersTreeStyle

121− )

122− <*> switch

123− ( long "signal-exit-code"

124− <> helpDoc

125− ( Just $

104+ \increasing levels of headers.")

105+ <|> pure HeadersTreeStyle)

106+ <*> switch

107+ (long "signal-exit-code"

108+ <> helpDoc (Just $

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

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

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

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

130− )

131− )

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

132113

133114par :: String -> Doc

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

app/FormatHeuristic.hs+1−1

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

22-- Originally based on:

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

44module FormatHeuristic

5− ( formatFromFilePath,

5+ ( formatFromFilePath

66 )

77where

88

ci/policeman.nixdeleted−4

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

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

2−, pkgs ? import sources.nixpkgs { }

3−}:

4−pkgs.haskellPackages.policeman

compaREST.cabal−7

@@ -14,9 +14,6 @@ extra-doc-files: README.md

1414 CHANGELOG.md

1515tested-with: GHC == 8.10.4

1616extra-source-files: awsm-css/dist/awsm.min.css

17−data-files:

18− test/golden/**/*.yaml

19− test/golden/**/*.md

2017

2118common common-options

2219 ghc-options:

@@ -35,7 +32,6 @@ common common-options

3532 build-depends: base >= 4.12.0.0 && < 4.16

3633 , text

3734

38−

3935 default-extensions: ApplicativeDo

4036 , BangPatterns

4137 , ConstraintKinds

@@ -77,7 +73,6 @@ common common-options

7773 , QuantifiedConstraints

7874 , DefaultSignatures

7975

80−

8176library

8277 import: common-options

8378 build-depends:

@@ -206,8 +201,6 @@ test-suite compaREST-tests

206201 other-modules:

207202 Spec.Golden.Extra

208203 Spec.Golden.TraceTree

209− Paths_compaREST

210− autogen-modules: Paths_compaREST

211204 build-depends:

212205 , compaREST

213206 , tasty-golden

default.nix+5−7

@@ -98,17 +98,15 @@ let

9898

9999 WindowsCompaRESTBin = hsPkgs.projectCross.mingwW64.hsPkgs.compaREST.components.exes.compaREST;

100100in

101+builtins.trace hsPkgs.compaREST.components.exes

101102{

102− inherit

103− compaRESTImage

103+ inherit compaRESTImage

104104 compaRESTGithubAction

105105 compaRESTStaticBin

106106 compaRESTBin

107107 hsPkgs

108108 macOSCompaRESTBundle

109− WindowsCompaRESTBin;

110−

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

112− # The only binaries build on CI are static.

113− test = hsPkgs.projectCross.musl64.hsPkgs.compaREST.components.tests.compaREST-tests;

109+ WindowsCompaRESTBin

110+ ;

111+ test = hsPkgs.compaREST.components.tests.compaREST-tests;

114112}

nix/ci.nixdeleted−6

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

1−{ sources ? import ./sources.nix

2−, pkgs ? import sources.nixpkgs { }

3−}:

4−pkgs.mkShell {

5− packages = [ pkgs.haskellPackages.fourmolu ];

6−}

policeman.jsondeleted−6

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

1−[{

2− "file": "compaREST.cabal",

3− "annotation_level": "notice",

4− "end_line": 0,

5− "start_line": 0

6−}]

src/Data/HList.hs+11−11

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

11module Data.HList

2− ( Has,

3− HasAll,

4− getH,

5− HList (..),

6− singletonH,

7− ReassembleHList,

8− reassemble,

2+ ( Has

3+ , HasAll

4+ , getH

5+ , HList (..)

6+ , singletonH

7+ , ReassembleHList

8+ , reassemble

99 )

1010where

1111

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

4040 {-# INLINE getH #-}

4141

4242instance

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

44− Has' x '[] 'False

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

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

4545 where

4646 getH HNil = undefined

4747 {-# INLINE getH #-}

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

7474 {-# INLINE reassemble #-}

7575

7676instance

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

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

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

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

7979 where

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

8181 {-# INLINE reassemble #-}

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

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

11module Data.OpenApi.Compare.Behavior

2− ( BehaviorLevel (..),

3− Behavable (..),

4− IssueKind (..),

5− Issuable (..),

6− Orientation (..),

7− toggleOrientation,

8− Behavior,

9− AnIssue (..),

10− withClass,

11− anIssueKind,

12− relatedAnIssues,

2+ ( BehaviorLevel (..)

3+ , Behavable (..)

4+ , IssueKind (..)

5+ , Issuable (..)

6+ , Orientation (..)

7+ , toggleOrientation

8+ , Behavior

9+ , AnIssue (..)

10+ , withClass

11+ , anIssueKind

12+ , relatedAnIssues

1313 )

1414where

1515

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

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

11module Data.OpenApi.Compare.Common

2− ( zipAll,

2+ ( zipAll

33 )

44where

55

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

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

11module Data.OpenApi.Compare.Formula

2− ( FormulaF,

3− VarRef,

4− variable,

5− eitherOf,

6− anError,

7− errors,

8− calculate,

9− maxFixpoint,

10− mapErrors,

11− )

12−where

2+ ( FormulaF

3+ , VarRef

4+ , variable

5+ , eitherOf

6+ , anError

7+ , errors

8+ , calculate

9+ , maxFixpoint

10+ , mapErrors

11+ ) where

1312

1413import Data.Kind

1514import qualified Data.List.NonEmpty as NE

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

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

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

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

28− Errors ::

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

30− -- | invariant: never empty

31− FormulaF q f r a

32− Apply ::

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

34− FormulaF q f r b ->

35− (c -> a) ->

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

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

28+ -- ^ invariant: never empty

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

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

3731 -- both not 'Result'

38− FormulaF q f r a

39− SelectFirst ::

40− NE.NonEmpty (SomeFormulaF b) ->

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

42− (b -> a) ->

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

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

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

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

4435 -- 'SelectFirst'

45− FormulaF q f r a

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

4737

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

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

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

5545mkSelectFirst fs allE h = case foldMap check fs of

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

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

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

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

5949 where

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

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

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

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

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

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

6454 check x = (mempty, [x])

6555

6656data SomeFormulaF (a :: Type) where

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

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

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

10898 where

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

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

110100 Left _ -> go rs

111101 Right x -> Right (h x)

112102 go [] = Left e

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2−

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

43module Data.OpenApi.Compare.Memo

5− ( MonadMemo,

6− MemoState,

7− runMemo,

8− modifyMemoNonce,

9− KnotTier (..),

10− unknot,

11− memoWithKnot,

12− memoTaggedWithKnot,

13− )

14−where

4+ ( MonadMemo

5+ , MemoState

6+ , runMemo

7+ , modifyMemoNonce

8+ , KnotTier(..)

9+ , unknot

10+ , memoWithKnot

11+ , memoTaggedWithKnot

12+ ) where

1513

1614import Control.Monad.State

1715import Data.Dynamic

1816import qualified Data.Map as M

1917import Data.Tagged

20−import qualified Data.TypeRepMap as T

2118import Data.Void

19+import qualified Data.TypeRepMap as T

2220import Type.Reflection

2321

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

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

3129-- | An effectful memoization monad.

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

3331

34−memoStateLookup ::

35− forall k v s.

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

37− k ->

38− MemoState s ->

39− Maybe (Progress v)

32+memoStateLookup

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

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

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

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

4237 Nothing -> Nothing

4338

44−memoStateInsert ::

45− forall k v s.

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

47− k ->

48− Progress v ->

49− MemoState s ->

50− MemoState s

39+memoStateInsert

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

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

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

5243 where

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

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

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

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

7061data KnotTier v d m = KnotTier

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

72− onKnotFound :: m d

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

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

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

7464 -- to the inner computations

75− onKnotUsed :: d -> m v

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

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

7766 -- knot using the datum

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

7967 }

8068

8169unknot :: KnotTier v Void m

82−unknot =

83− KnotTier

84− { onKnotFound = error "Recursion detected"

85− , onKnotUsed = absurd

86− , tieKnot = absurd

87− }

70+unknot = KnotTier

71+ { onKnotFound = error "Recursion detected"

72+ , onKnotUsed = absurd

73+ , tieKnot = absurd

74+ }

8875

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

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

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

9380--

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

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

96−memoWithKnot ::

97− forall k v d m s.

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

99− KnotTier v d m ->

100− -- | the computation to memoize

101− m v ->

102− -- | key for memoization

103− k ->

104− m v

105−memoWithKnot tier f k =

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

107− Just (Finished v) -> pure v

108− Just Started -> do

109− d <- onKnotFound tier

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

111− onKnotUsed tier d

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

113− Just d -> onKnotUsed tier d

114− Nothing ->

115− error $

116− "Type mismatch when examining the knot of "

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

118− <> ": expected "

119− <> show (typeRep @d)

120− <> ", got "

121− <> show (dynTypeRep dyn)

122− Nothing -> do

123− modify $ memoStateInsert @k @v k Started

124− v <- f

125− v' <-

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

127− Just Started -> pure v

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

129− Just d -> tieKnot tier d v

130− Nothing ->

131− error $

132− "Type mismatch when tying the knot of "

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

134− <> ": expected "

135− <> show (typeRep @d)

136− <> ", got "

137− <> show (dynTypeRep dyn)

138− Just (Finished _) ->

139− error $

140− "Unexpected Finished when memoizing "

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

142− Nothing -> pure v

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

144− -- to remember memoization state

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

146− pure v'

83+memoWithKnot

84+ :: forall k v d m s.

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

86+ => KnotTier v d m

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

88+ -> k -- ^ key for memoization

89+ -> m v

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

91+ Just (Finished v) -> pure v

92+ Just Started -> do

93+ d <- onKnotFound tier

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

95+ onKnotUsed tier d

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

97+ Just d -> onKnotUsed tier d

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

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

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

101+ Nothing -> do

102+ modify $ memoStateInsert @k @v k Started

103+ v <- f

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

105+ Just Started -> pure v

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

107+ Just d -> tieKnot tier d v

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

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

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

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

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

113+ Nothing -> pure v

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

115+ -- to remember memoization state

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

117+ pure v'

147118

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

149−memoTaggedWithKnot ::

150− forall t k v d m s.

151− ( Typeable t

152− , Typeable k

153− , Typeable v

154− , Typeable d

155− , Ord k

156− , MonadMemo s m

157− ) =>

158− KnotTier v d m ->

159− m v ->

160− k ->

161− m v

162−memoTaggedWithKnot tier f k =

163− withTypeable (typeRepKind $ typeRep @t) $

164− memoWithKnot tier f (Tagged @t k)

120+memoTaggedWithKnot

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

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

123+ , Ord k, MonadMemo s m )

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

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

126+ memoWithKnot tier f (Tagged @t k)

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

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

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

33-- structure.

44module Data.OpenApi.Compare.Paths

5− ( NiceQuiver,

6− AdditionalQuiverConstraints,

7− Paths (..),

8− DiffPaths (..),

9− catDiffPaths,

10− AnItem (..),

11− step,

5+ ( NiceQuiver

6+ , AdditionalQuiverConstraints

7+ , Paths (..)

8+ , DiffPaths (..)

9+ , catDiffPaths

10+ , AnItem (..)

11+ , step

1212

1313 -- * Reexports

14− (>>>),

15− (<<<),

14+ , (>>>)

15+ , (<<<)

1616 )

1717where

1818

src/Data/OpenApi/Compare/PathsPrefixTree.hs+37−37

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

11{-# LANGUAGE QuantifiedConstraints #-}

22

33module Data.OpenApi.Compare.PathsPrefixTree

4− ( PathsPrefixTree (PathsPrefixNode),

5− AStep (..),

6− empty,

7− singleton,

8− fromList,

9− null,

10− foldWith,

11− toList,

12− filter,

13− filterWithKey,

14− takeSubtree,

15− lookup,

16− embed,

17− size,

18− partition,

19− map,

4+ ( PathsPrefixTree (PathsPrefixNode)

5+ , AStep (..)

6+ , empty

7+ , singleton

8+ , fromList

9+ , null

10+ , foldWith

11+ , toList

12+ , filter

13+ , filterWithKey

14+ , takeSubtree

15+ , lookup

16+ , embed

17+ , size

18+ , partition

19+ , map

2020 )

2121where

2222

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

3535import qualified Data.Vector as V

3636import qualified GHC.Exts as Exts

3737import Type.Reflection

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

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

3939

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

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

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

102102

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

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

105−compareTRM ::

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

107− TRM.TypeRepMap f ->

108− TRM.TypeRepMap f ->

109− Ordering

105+compareTRM

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

107+ => TRM.TypeRepMap f

108+ -> TRM.TypeRepMap f

109+ -> Ordering

110110compareTRM s1 s2 =

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

112112 where

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

116116 compareMaybe _ Nothing (Just _) = LT

117117 compareMaybe _ (Just _) Nothing = GT

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

119− compareW ::

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

121− TRM.WrapTypeable f ->

122− TRM.WrapTypeable f ->

123− Ordering

119+ compareW

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

121+ => TRM.WrapTypeable f

122+ -> TRM.WrapTypeable f

123+ -> Ordering

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

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

126126 | otherwise = EQ -- unreachable

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

172172 mempty = AnEmptySet

173173

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

175− AStep ::

176− NiceQuiver q r a =>

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

178− AStep q f r a

175+ AStep

176+ :: NiceQuiver q r a =>

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

178+ -> AStep q f r a

179179

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

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

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

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

216216null _ = False

217217

218−foldWith ::

219− forall q f m r.

220− Monoid m =>

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

222− PathsPrefixTree q f r ->

223− m

218+foldWith

219+ :: forall q f m r.

220+ Monoid m

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

222+ -> PathsPrefixTree q f r

223+ -> m

224224foldWith k = goTPT Root

225225 where

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

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

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.References

4− ( Step (..),

5− dereference,

6− Typeable,

4+ ( Step (..)

5+ , dereference

6+ , Typeable

77 )

88where

99

@@ -18,11 +18,11 @@ instance Typeable a => Steppable (Referenced a) a where

1818 data Step (Referenced a) a = InlineStep

1919 deriving stock (Eq, Ord, Show)

2020

21−dereference ::

22− Typeable a =>

23− Traced (Definitions a) ->

24− Traced (Referenced a) ->

25− Traced a

21+dereference

22+ :: Typeable a

23+ => Traced (Definitions a)

24+ -> Traced (Referenced a)

25+ -> Traced a

2626dereference defs x = case extract x of

2727 Inline a ->

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

src/Data/OpenApi/Compare/Report.hs+120−140

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

11module Data.OpenApi.Compare.Report

2− ( generateReport,

3− CheckerOutput (..),

4− ReportInput (..),

5− segregateIssues,

6− ReportStatus (..),

7− Pandoc,

8− ReportConfig (..),

9− ReportTreeStyle (..),

10− ReportMode (..),

2+ ( generateReport

3+ , CheckerOutput(..)

4+ , ReportInput (..)

5+ , segregateIssues

6+ , ReportStatus (..)

7+ , Pandoc

8+ , ReportConfig (..)

9+ , ReportTreeStyle (..)

10+ , ReportMode (..)

1111 )

1212where

1313

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

3030import Data.OpenApi.Compare.Report.Jet

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

3232import Data.OpenApi.Compare.Validate.OpenApi

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

3433import Data.OpenApi.Compare.Validate.Schema.TypedJson

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

3535import Data.OpenUnion

3636import Data.OpenUnion.Extra

3737import Data.Set

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

5454 deriving anyclass (ToJSON)

5555

5656data ReportInput = ReportInput

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

58− breakingChanges :: Changes

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)

62− unsupportedChanges :: Changes

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

64− schemaIssues :: Changes

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

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

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

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

6561 }

6662 deriving stock (Generic)

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

6864 deriving anyclass (ToJSON)

6965

7066segregateIssues :: CheckerOutput -> ReportInput

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

72− ReportInput

73− { breakingChanges = P.filter isBreaking fwd

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

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

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

77− }

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

68+ { breakingChanges = P.filter isBreaking fwd

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

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

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

72+ }

7873 where

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

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

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

111106

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

113108generateReport cfg inp =

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

109+ let

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

115111 breakingChangesPresent = not $ P.null $ breakingChanges inp

116112 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

117113 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

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

120116 OnlyErrors -> False

121117 builder = buildReport cfg

122118 report =

123− header 1 "Summary"

124− <> twoRowTable

125− ( when'

126− schemaIssuesPresent

127− [

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

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

130− )

131− ]

132− ++ [

133− ( refOpt breakingChangesPresent breakingChangesId "❌ Breaking changes"

119+ header 1 "Summary"

120+ <> twoRowTable

121+ (when'

122+ schemaIssuesPresent

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

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

125+ )

126+ ]

127+ ++

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

134129 , show' $ P.size $ breakingChanges inp

135130 )

136131 ]

137− ++ when'

138− nonBreakingChangesShown

139− [

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

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

142− )

143− ]

144− ++ when'

145− unsupportedChangesPresent

146− [

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

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

149− )

150− ]

151− )

152− <> when'

153− schemaIssuesPresent

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

155− <> builder (showErrs $ schemaIssues inp)

156− )

157− <> when'

158− breakingChangesPresent

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

160− <> builder (showErrs $ breakingChanges inp)

161− )

162− <> when'

163− (nonBreakingChangesPresent && nonBreakingChangesShown)

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

165− <> builder (showErrs $ nonBreakingChanges inp)

166− )

167− <> when'

168− unsupportedChangesPresent

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

170− <> builder (showErrs $ unsupportedChanges inp)

171− )

132+ ++ when'

133+ nonBreakingChangesShown

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

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

136+ )

137+ ]

138+ ++ when'

139+ unsupportedChangesPresent

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

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

142+ )

143+ ])

144+ <> when'

145+ schemaIssuesPresent

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

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

148+ <> when'

149+ breakingChangesPresent

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

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

152+ <> when'

153+ (nonBreakingChangesPresent && nonBreakingChangesShown)

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

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

156+ <> when'

157+ unsupportedChangesPresent

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

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

172160 status =

173161 if

174162 | breakingChangesPresent -> BreakingChanges

@@ -198,14 +186,13 @@ showErrs x@(P.PathsPrefixNode currentIssues _) =

198186 let -- Extract this pattern if more cases like this arise

199187 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])

200188 , otherIssues :: Set (AnIssue a)

201− ) = case eqT @a @ 'APILevel of

189+ ) = case eqT @a @'APILevel of

202190 Just Refl

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

204192 S.partition

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

206− NoPathsMatched {} -> True

207− AllPathsFailed {} -> True

208− )

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

194+ NoPathsMatched {} -> True

195+ AllPathsFailed {} -> True)

209196 currentIssues ->

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

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

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

216203 paths = case removedPaths of

217204 Just (ori, ps) -> do

218205 singletonHeader

219− ( case ori of

220− Forward -> "Removed paths"

221− Backward -> "Added paths"

222− )

206+ (case ori of

207+ Forward -> "Removed paths"

208+ Backward -> "Added paths")

223209 $ singletonBody $

224210 bulletList $

225211 ps <&> \case

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

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

264250 unwrapReportJetResult (Free f) = f

265251

266− jsonPathJet ::

267− NonEmpty

268− ( Union

269− '[ Behave 'SchemaLevel 'TypedSchemaLevel

270− , Behave 'TypedSchemaLevel 'SchemaLevel

271− ]

272− ) ->

273− Inlines

252+ jsonPathJet

253+ :: NonEmpty

254+ ( Union

255+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

256+ , Behave 'TypedSchemaLevel 'SchemaLevel

257+ ]

258+ )

259+ -> Inlines

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

275261 where

276− showParts ::

277− [ Union

278− '[ Behave 'SchemaLevel 'TypedSchemaLevel

279− , Behave 'TypedSchemaLevel 'SchemaLevel

280− ]

281− ] ->

282− Text

262+ showParts

263+ :: [ Union

264+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

265+ , Behave 'TypedSchemaLevel 'SchemaLevel

266+ ]

267+ ]

268+ -> Text

283269 showParts [] = mempty

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

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

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

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

288274 showParts (y : ys) =

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

290− @@> ( \case

291− InItems -> "[*]"

292− InItem i -> "[" <> T.pack (show i) <> "]"

293− InProperty p -> "." <> p

294− InAdditionalProperty -> ".*"

295− )

296− @@> typesExhausted

297− )

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

276+ @@> (\case

277+ InItems -> "[*]"

278+ InItem i -> "[" <> T.pack (show i) <> "]"

279+ InProperty p -> "." <> p

280+ InAdditionalProperty -> ".*")

281+ @@> typesExhausted)

298282 y

299283 <> showParts ys

300284

301−observeJetShowErrs ::

302− ReportJet' Behave (Maybe Inlines) ->

303− P.PathsPrefixTree Behave AnIssue a ->

304− (Report, P.PathsPrefixTree Behave AnIssue a)

285+observeJetShowErrs

286+ :: ReportJet' Behave (Maybe Inlines)

287+ -> P.PathsPrefixTree Behave AnIssue a

288+ -> (Report, P.PathsPrefixTree Behave AnIssue a)

305289observeJetShowErrs jet p = case observeJetShowErrs' jet p of

306290 Just m -> m

307291 Nothing -> (mempty, p)

308292

309−observeJetShowErrs' ::

310− forall a.

311− ReportJet' Behave (Maybe Inlines) ->

312− P.PathsPrefixTree Behave AnIssue a ->

313− Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

293+observeJetShowErrs'

294+ :: forall a.

295+ ReportJet' Behave (Maybe Inlines)

296+ -> P.PathsPrefixTree Behave AnIssue a

297+ -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)

314298observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =

315299 let results =

316300 subIssues >>= \(WrapTypeable (AStep m)) ->

@@ -318,23 +302,21 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)

318302 maybe (Left $ embed (step bhv) subErrs) Right . listToMaybe $

319303 jet @_ @_ @[] bhv

320304 & mapMaybe

321− ( \case

322− Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

323− Pure (Just h) ->

324− if P.null subErrs

325− then Just mempty

326− else Just (singletonHeader h (showErrs subErrs), mempty)

327− Pure Nothing -> Nothing

328− )

305+ (\case

306+ Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs

307+ Pure (Just h) ->

308+ if P.null subErrs

309+ then Just mempty

310+ else Just (singletonHeader h (showErrs subErrs), mempty)

311+ Pure Nothing -> Nothing)

329312 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $

330313 if any isRight results

331314 then

332315 Just $

333316 foldMap

334− ( \case

335− Left e -> (mempty, e)

336− Right m -> m

337− )

317+ (\case

318+ Left e -> (mempty, e)

319+ Right m -> m)

338320 results

339321 else Nothing

340322

@@ -357,9 +339,8 @@ buildReport cfg = case treeStyle cfg of

357339 body rprt

358340 <> foldOMapWithKey

359341 (headers rprt)

360− ( \k v ->

361− header level k <> subBuilder v

362− )

342+ (\k v ->

343+ header level k <> subBuilder v)

363344 where

364345 subBuilder = headerStyleBuilder (level + 1)

365346

@@ -368,17 +349,16 @@ buildReport cfg = case treeStyle cfg of

368349 body rprt

369350 <> foldOMapWithKey

370351 (headers rprt)

371− ( \k v ->

372− if (OM.size . headers $ rprt) < 2

373− then para k <> blockQuote (subBuilder v)

374− else

375− rawHtml "<details>"

376− <> rawHtml "<summary>"

377− <> plain k

378− <> rawHtml "</summary>"

379− <> blockQuote (subBuilder v)

380− <> rawHtml "</details>"

381− )

352+ (\k v ->

353+ if (OM.size . headers $ rprt) < 2

354+ then para k <> blockQuote (subBuilder v)

355+ else

356+ rawHtml "<details>"

357+ <> rawHtml "<summary>"

358+ <> plain k

359+ <> rawHtml "</summary>"

360+ <> blockQuote (subBuilder v)

361+ <> rawHtml "</details>")

382362 where

383363 subBuilder = foldingStyleBuilder

384364

src/Data/OpenApi/Compare/Report/Html/Template.hs+1−1

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

11{-# LANGUAGE TemplateHaskell #-}

22

33module Data.OpenApi.Compare.Report.Html.Template

4− ( template,

4+ ( template

55 )

66where

77

src/Data/OpenApi/Compare/Report/Jet.hs+4−4

@@ -1,8 +1,8 @@

11module Data.OpenApi.Compare.Report.Jet

2− ( ReportJet (..),

3− ReportJet',

4− ConstructReportJet (..),

5− ReportJetResult,

2+ ( ReportJet (..)

3+ , ReportJet'

4+ , ConstructReportJet (..)

5+ , ReportJetResult

66 )

77where

88

src/Data/OpenApi/Compare/Run.hs+4−4

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

11module Data.OpenApi.Compare.Run

2− ( runChecker,

3− runReport,

4− module Data.OpenApi.Compare.Report,

2+ ( runChecker

3+ , runReport

4+ , module Data.OpenApi.Compare.Report

55 )

66where

77

88import Data.HList

99import Data.OpenApi (OpenApi)

10+import Text.Pandoc.Builder

1011import Data.OpenApi.Compare.Paths

1112import Data.OpenApi.Compare.Report

1213import Data.OpenApi.Compare.Subtree

1314import Data.OpenApi.Compare.Validate.OpenApi ()

14−import Text.Pandoc.Builder

1515

1616runChecker :: (OpenApi, OpenApi) -> CheckerOutput

1717runChecker (client, server) =

src/Data/OpenApi/Compare/Subtree.hs+120−122

@@ -1,52 +1,52 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Subtree

4− ( Steppable (..),

5− Step (..),

6− TraceRoot,

7− Trace,

8− Traced,

9− Traced',

10− pattern Traced,

11− traced,

12− retraced,

13− stepTraced,

14− Subtree (..),

15− checkCompatibility,

16− checkSubstructure,

17− CompatM (..),

18− CompatFormula',

19− SemanticCompatFormula,

20− ProdCons (..),

21− orientProdCons,

22− swapProdCons,

23− runCompatFormula,

24− issueAt,

25− anItem,

26− anIssue,

27− invertIssueOrientation,

28− invertIssueOrientationP,

29− embedFormula,

30− anyOfAt,

31− clarifyIssue,

32− structuralIssue,

4+ ( Steppable (..)

5+ , Step (..)

6+ , TraceRoot

7+ , Trace

8+ , Traced

9+ , Traced'

10+ , pattern Traced

11+ , traced

12+ , retraced

13+ , stepTraced

14+ , Subtree (..)

15+ , checkCompatibility

16+ , checkSubstructure

17+ , CompatM (..)

18+ , CompatFormula'

19+ , SemanticCompatFormula

20+ , ProdCons (..)

21+ , orientProdCons

22+ , swapProdCons

23+ , runCompatFormula

24+ , issueAt

25+ , anItem

26+ , anIssue

27+ , invertIssueOrientation

28+ , invertIssueOrientationP

29+ , embedFormula

30+ , anyOfAt

31+ , clarifyIssue

32+ , structuralIssue

3333

3434 -- * Structural helpers

35− structuralMaybe,

36− structuralMaybeWith,

37− structuralEq,

38− iohmStructural,

39− iohmStructuralWith,

40− structuralList,

35+ , structuralMaybe

36+ , structuralMaybeWith

37+ , structuralEq

38+ , iohmStructural

39+ , iohmStructuralWith

40+ , structuralList

4141

4242 -- * Reexports

43− (>>>),

44− (<<<),

45− extract,

46− ask,

47− local,

48− step,

49− Typeable,

43+ , (>>>)

44+ , (<<<)

45+ , extract

46+ , ask

47+ , local

48+ , step

49+ , Typeable

5050 )

5151where

5252

@@ -115,10 +115,10 @@ orientProdCons :: Orientation -> ProdCons x -> ProdCons x

115115orientProdCons Forward x = x

116116orientProdCons Backward (ProdCons p c) = ProdCons c p

117117

118−swapProdCons ::

119− SwapEnvRoles xs =>

120− (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a) ->

121− (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

118+swapProdCons

119+ :: SwapEnvRoles xs

120+ => (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

121+ -> (HList xs -> ProdCons x -> CompatFormula' q AnIssue r a)

122122swapProdCons f e (ProdCons p c) =

123123 invertIssueOrientation $

124124 f (swapEnvRoles e) (ProdCons c p)

@@ -153,8 +153,8 @@ instance Applicative ProdCons where

153153 ProdCons fp fc <*> ProdCons xp xc = ProdCons (fp xp) (fc xc)

154154

155155newtype CompatM a = CompatM

156− { unCompatM ::

157− StateT (MemoState VarRef) Identity a

156+ { unCompatM

157+ :: StateT (MemoState VarRef) Identity a

158158 }

159159 deriving newtype

160160 ( Functor

@@ -183,64 +183,64 @@ class (Typeable t, Issuable (SubtreeLevel t)) => Subtree (t :: Type) where

183183 type CheckEnv t :: [Type]

184184 type SubtreeLevel t :: BehaviorLevel

185185

186− checkStructuralCompatibility ::

187− HList (CheckEnv t) ->

188− ProdCons (Traced t) ->

189− StructuralCompatFormula ()

186+ checkStructuralCompatibility

187+ :: HList (CheckEnv t)

188+ -> ProdCons (Traced t)

189+ -> StructuralCompatFormula ()

190190

191− checkSemanticCompatibility ::

192− HList (CheckEnv t) ->

193− Behavior (SubtreeLevel t) ->

194− ProdCons (Traced t) ->

195− SemanticCompatFormula ()

191+ checkSemanticCompatibility

192+ :: HList (CheckEnv t)

193+ -> Behavior (SubtreeLevel t)

194+ -> ProdCons (Traced t)

195+ -> SemanticCompatFormula ()

196196

197197{-# WARNING checkStructuralCompatibility "You should not be calling this directly. Use 'checkSubstructure'" #-}

198198

199199{-# WARNING checkSemanticCompatibility "You should not be calling this directly. Use 'checkCompatibility'" #-}

200200

201−checkCompatibility ::

202− forall t xs.

203− (ReassembleHList xs (CheckEnv t), Subtree t) =>

204− Behavior (SubtreeLevel t) ->

205− HList xs ->

206− ProdCons (Traced t) ->

207− SemanticCompatFormula ()

201+checkCompatibility

202+ :: forall t xs.

203+ (ReassembleHList xs (CheckEnv t), Subtree t)

204+ => Behavior (SubtreeLevel t)

205+ -> HList xs

206+ -> ProdCons (Traced t)

207+ -> SemanticCompatFormula ()

208208checkCompatibility bhv e = memo bhv SemanticMemoKey $ \pc ->

209209 case runCompatFormula $ checkSubstructure e pc of

210210 Left _ -> checkSemanticCompatibility (reassemble e) bhv pc

211211 Right () -> pure ()

212212{-# INLINE checkCompatibility #-}

213213

214−checkSubstructure ::

215− (ReassembleHList xs (CheckEnv t), Subtree t) =>

216− HList xs ->

217− ProdCons (Traced t) ->

218− StructuralCompatFormula ()

214+checkSubstructure

215+ :: (ReassembleHList xs (CheckEnv t), Subtree t)

216+ => HList xs

217+ -> ProdCons (Traced t)

218+ -> StructuralCompatFormula ()

219219checkSubstructure e = memo Root StructuralMemoKey $ checkStructuralCompatibility (reassemble e)

220220{-# INLINE checkSubstructure #-}

221221

222−structuralMaybe ::

223− (Subtree a, ReassembleHList xs (CheckEnv a)) =>

224− HList xs ->

225− ProdCons (Maybe (Traced a)) ->

226− StructuralCompatFormula ()

222+structuralMaybe

223+ :: (Subtree a, ReassembleHList xs (CheckEnv a))

224+ => HList xs

225+ -> ProdCons (Maybe (Traced a))

226+ -> StructuralCompatFormula ()

227227structuralMaybe e = structuralMaybeWith (checkSubstructure e)

228228{-# INLINE structuralMaybe #-}

229229

230−structuralMaybeWith ::

231− (ProdCons a -> StructuralCompatFormula ()) ->

232− ProdCons (Maybe a) ->

233− StructuralCompatFormula ()

230+structuralMaybeWith

231+ :: (ProdCons a -> StructuralCompatFormula ())

232+ -> ProdCons (Maybe a)

233+ -> StructuralCompatFormula ()

234234structuralMaybeWith f (ProdCons (Just a) (Just b)) = f $ ProdCons a b

235235structuralMaybeWith _ (ProdCons Nothing Nothing) = pure ()

236236structuralMaybeWith _ _ = structuralIssue

237237{-# INLINE structuralMaybeWith #-}

238238

239−structuralList ::

240− (Subtree a, ReassembleHList xs (CheckEnv a)) =>

241− HList xs ->

242− ProdCons [Traced a] ->

243− StructuralCompatFormula ()

239+structuralList

240+ :: (Subtree a, ReassembleHList xs (CheckEnv a))

241+ => HList xs

242+ -> ProdCons [Traced a]

243+ -> StructuralCompatFormula ()

244244structuralList _ (ProdCons [] []) = pure ()

245245structuralList e (ProdCons (a : aa) (b : bb)) = do

246246 checkSubstructure e $ ProdCons a b

@@ -253,11 +253,11 @@ structuralEq :: (Eq a, Comonad w) => ProdCons (w a) -> StructuralCompatFormula (

253253structuralEq (ProdCons a b) = if extract a == extract b then pure () else structuralIssue

254254{-# INLINE structuralEq #-}

255255

256−iohmStructural ::

257− (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k) =>

258− HList xs ->

259− ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

260− StructuralCompatFormula ()

256+iohmStructural

257+ :: (ReassembleHList (k ': xs) (CheckEnv v), Ord k, Subtree v, Hashable k, Typeable k, Show k)

258+ => HList xs

259+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

260+ -> StructuralCompatFormula ()

261261iohmStructural e =

262262 iohmStructuralWith (\k -> checkSubstructure (k `HCons` e))

263263{-# INLINE iohmStructural #-}

@@ -266,26 +266,25 @@ instance (Typeable k, Typeable v, Ord k, Show k) => Steppable (IOHM.InsOrdHashMa

266266 data Step (IOHM.InsOrdHashMap k v) v = InsOrdHashMapKeyStep k

267267 deriving stock (Eq, Ord, Show)

268268

269−iohmStructuralWith ::

270− (Ord k, Hashable k, Typeable k, Typeable v, Show k) =>

271− (k -> ProdCons (Traced v) -> StructuralCompatFormula ()) ->

272− ProdCons (Traced (IOHM.InsOrdHashMap k v)) ->

273− StructuralCompatFormula ()

269+iohmStructuralWith

270+ :: (Ord k, Hashable k, Typeable k, Typeable v, Show k)

271+ => (k -> ProdCons (Traced v) -> StructuralCompatFormula ())

272+ -> ProdCons (Traced (IOHM.InsOrdHashMap k v))

273+ -> StructuralCompatFormula ()

274274iohmStructuralWith f pc = do

275275 let ProdCons pEKeys cEKeys = S.fromList . IOHM.keys . extract <$> pc

276276 if pEKeys == cEKeys

277277 then

278278 for_

279279 pEKeys

280− ( \eKey ->

281− f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc

282− )

280+ (\eKey ->

281+ f eKey $ stepTraced (InsOrdHashMapKeyStep eKey) . fmap (IOHM.lookupDefault (error "impossible") eKey) <$> pc)

283282 else structuralIssue

284283{-# INLINE iohmStructuralWith #-}

285284

286−runCompatFormula ::

287− CompatFormula' q f r a ->

288− Either (P.PathsPrefixTree q f r) a

285+runCompatFormula

286+ :: CompatFormula' q f r a

287+ -> Either (P.PathsPrefixTree q f r) a

289288runCompatFormula (Compose f) =

290289 calculate . runIdentity . runMemo 0 . unCompatM $ f

291290{-# INLINE runCompatFormula #-}

@@ -315,27 +314,27 @@ invertIssueOrientationP = P.map (\(AnIssue ori i) -> AnIssue (toggleOrientation

315314structuralIssue :: StructuralCompatFormula a

316315structuralIssue = Compose $ pure $ anError $ AnItem Root Proxy

317316

318−anyOfAt ::

319− Issuable l =>

320− Paths q r l ->

321− Issue l ->

322− [CompatFormula' q AnIssue r a] ->

323− CompatFormula' q AnIssue r a

317+anyOfAt

318+ :: Issuable l

319+ => Paths q r l

320+ -> Issue l

321+ -> [CompatFormula' q AnIssue r a]

322+ -> CompatFormula' q AnIssue r a

324323anyOfAt _ _ [x] = x

325324anyOfAt xs issue fs =

326325 Compose $ (`eitherOf` AnItem xs (anIssue issue)) <$> traverse getCompose fs

327326

328327-- | If the given formula contains any issues, add another issue on top. Otherwise succeed.

329−clarifyIssue ::

330− AnItem q AnIssue r ->

331− CompatFormula' q AnIssue r a ->

332− CompatFormula' q AnIssue r a

328+clarifyIssue

329+ :: AnItem q AnIssue r

330+ -> CompatFormula' q AnIssue r a

331+ -> CompatFormula' q AnIssue r a

333332clarifyIssue item f =

334333 Compose ((`eitherOf` item) <$> pure <$> getCompose f) *> f

335334

336−fixpointKnot ::

337− MonadState (MemoState VarRef) m =>

338− KnotTier (FormulaF q f r ()) VarRef m

335+fixpointKnot

336+ :: MonadState (MemoState VarRef) m

337+ => KnotTier (FormulaF q f r ()) VarRef m

339338fixpointKnot =

340339 KnotTier

341340 { onKnotFound = modifyMemoNonce succ

@@ -343,20 +342,19 @@ fixpointKnot =

343342 , tieKnot = \i x -> pure $ maxFixpoint i x

344343 }

345344

346−memo ::

347− (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a) =>

348− Paths q r l ->

349− MemoKey ->

350− (ProdCons (Traced a) -> CompatFormula' q f r ()) ->

351− (ProdCons (Traced a) -> CompatFormula' q f r ())

345+memo

346+ :: (Typeable (l :: k), Typeable q, Typeable f, Typeable k, Typeable a)

347+ => Paths q r l

348+ -> MemoKey

349+ -> (ProdCons (Traced a) -> CompatFormula' q f r ())

350+ -> (ProdCons (Traced a) -> CompatFormula' q f r ())

352351memo bhv k f pc = Compose $ do

353352 formula' <-

354353 memoWithKnot

355354 fixpointKnot

356− ( do

357− formula <- getCompose $ f pc

358− pure $ mapErrors (P.takeSubtree bhv) formula

359− )

355+ (do

356+ formula <- getCompose $ f pc

357+ pure $ mapErrors (P.takeSubtree bhv) formula)

360358 (k, ask <$> pc)

361359 pure $ mapErrors (P.embed bhv) formula'

362360

src/Data/OpenApi/Compare/Validate/MediaTypeObject.hs+2−2

@@ -1,8 +1,8 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.MediaTypeObject

4− ( Issue (..),

5− Behave (..),

4+ ( Issue (..)

5+ , Behave (..)

66 )

77where

88

src/Data/OpenApi/Compare/Validate/OAuth2Flows.hs+13−13

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.OAuth2Flows

4− ( Step (..),

5− Issue (..),

6− Behave (..),

4+ ( Step (..)

5+ , Issue (..)

6+ , Behave (..)

77 )

88where

99

@@ -26,11 +26,11 @@ instance Subtree OAuth2Flows where

2626 type SubtreeLevel OAuth2Flows = 'SecuritySchemeLevel

2727 checkStructuralCompatibility _ = structuralEq

2828 checkSemanticCompatibility env bhv pc = do

29− let supportFlow ::

30− (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t) =>

31− Issue 'SecuritySchemeLevel ->

32− ProdCons (Maybe (Traced t)) ->

33− SemanticCompatFormula ()

29+ let supportFlow

30+ :: (Subtree t, SubtreeLevel t ~ SubtreeLevel OAuth2Flows, CheckEnv OAuth2Flows ~ CheckEnv t)

31+ => Issue 'SecuritySchemeLevel

32+ -> ProdCons (Maybe (Traced t))

33+ -> SemanticCompatFormula ()

3434 supportFlow i x = case x of

3535 -- producer will not attempt this flow

3636 (ProdCons Nothing _) -> pure ()

@@ -38,11 +38,11 @@ instance Subtree OAuth2Flows where

3838 (ProdCons (Just _) Nothing) -> issueAt bhv i

3939 (ProdCons (Just p) (Just c)) ->

4040 checkCompatibility bhv env $ ProdCons p c

41− getFlow ::

42− Typeable x =>

43− (OAuth2Flows -> Maybe (OAuth2Flow x)) ->

44− Traced OAuth2Flows ->

45− Maybe (Traced (OAuth2Flow x))

41+ getFlow

42+ :: Typeable x

43+ => (OAuth2Flows -> Maybe (OAuth2Flow x))

44+ -> Traced OAuth2Flows

45+ -> Maybe (Traced (OAuth2Flow x))

4646 getFlow f (Traced t a) = Traced (t >>> step (OAuth2FlowsFlow Proxy)) <$> f a

4747 supportFlow ConsumerDoesNotSupportImplicitFlow $ getFlow _oAuth2FlowsImplicit <$> pc

4848 supportFlow ConsumerDoesNotSupportPasswordFlow $ getFlow _oAuth2FlowsPassword <$> pc

src/Data/OpenApi/Compare/Validate/OpenApi.hs+12−13

@@ -3,8 +3,8 @@

33{-# OPTIONS_GHC -fconstraint-solver-iterations=0 #-}

44

55module Data.OpenApi.Compare.Validate.OpenApi

6− ( Behave (..),

7− Issue (..),

6+ ( Behave (..)

7+ , Issue (..)

88 )

99where

1010

@@ -79,17 +79,16 @@ instance Subtree OpenApi where

7979 checkSemanticCompatibility _ beh prodCons = do

8080 checkCompatibility @ProcessedPathItems

8181 beh

82− ( (tracedRequestBodies <$> prodCons)

83− `HCons` (tracedParameters <$> prodCons)

84− `HCons` (tracedSecuritySchemes <$> prodCons)

85− `HCons` (tracedResponses <$> prodCons)

86− `HCons` (tracedHeaders <$> prodCons)

87− `HCons` (tracedSchemas <$> prodCons)

88− `HCons` (_openApiServers . extract <$> prodCons)

89− `HCons` (tracedLinks <$> prodCons)

90− `HCons` (tracedCallbacks <$> prodCons)

91− `HCons` HNil

92− )

82+ ((tracedRequestBodies <$> prodCons)

83+ `HCons` (tracedParameters <$> prodCons)

84+ `HCons` (tracedSecuritySchemes <$> prodCons)

85+ `HCons` (tracedResponses <$> prodCons)

86+ `HCons` (tracedHeaders <$> prodCons)

87+ `HCons` (tracedSchemas <$> prodCons)

88+ `HCons` (_openApiServers . extract <$> prodCons)

89+ `HCons` (tracedLinks <$> prodCons)

90+ `HCons` (tracedCallbacks <$> prodCons)

91+ `HCons` HNil)

9392 (tracedPaths <$> prodCons)

9493

9594instance Steppable OpenApi ProcessedPathItems where

src/Data/OpenApi/Compare/Validate/Operation.hs+24−26

@@ -4,17 +4,17 @@

44

55module Data.OpenApi.Compare.Validate.Operation

66 ( -- * Operation

7− MatchedOperation (..),

8− OperationMethod (..),

9− pathItemMethod,

7+ MatchedOperation (..)

8+ , OperationMethod (..)

9+ , pathItemMethod

1010

1111 -- * ProcessedPathItem

12− ProcessedPathItem (..),

13− ProcessedPathItems (..),

14− processPathItems,

15− Step (..),

16− Behave (..),

17− Issue (..),

12+ , ProcessedPathItem (..)

13+ , ProcessedPathItems (..)

14+ , processPathItems

15+ , Step (..)

16+ , Behave (..)

17+ , Issue (..)

1818 )

1919where

2020

@@ -87,11 +87,10 @@ tracedCallbacks (Traced t oper) =

8787 ]

8888

8989-- FIXME: #28

90−getServers ::

91− -- | Servers from env

92− [Server] ->

93− MatchedOperation ->

94− [Server]

90+getServers

91+ :: [Server] -- ^ Servers from env

92+ -> MatchedOperation

93+ -> [Server]

9594getServers env oper =

9695 case _operationServers . operation $ oper of

9796 [] -> env

@@ -338,10 +337,9 @@ instance Issuable 'APILevel where

338337 deriving stock (Eq, Ord, Show)

339338 issueKind = \case

340339 _ -> CertainIssue

341− relatedIssues =

342− (==) `withClass` \case

343− NoPathsMatched fp -> Just fp

344− AllPathsFailed fp -> Just fp

340+ relatedIssues = (==) `withClass` \case

341+ NoPathsMatched fp -> Just fp

342+ AllPathsFailed fp -> Just fp

345343 describeIssue Forward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

346344 describeIssue Backward (NoPathsMatched p) = para $ "The path " <> (code . T.pack) p <> " has been added."

347345 describeIssue Forward (AllPathsFailed p) = para $ "The path " <> (code . T.pack) p <> " has been removed."

@@ -436,10 +434,10 @@ tracedFragments mpi =

436434 | (i, x) <- L.zip [0 ..] $ pathFragments $ extract mpi

437435 ]

438436

439−tracedMethod ::

440− OperationMethod ->

441− Traced MatchedPathItem ->

442− Maybe (Traced' MatchedOperation Operation)

437+tracedMethod

438+ :: OperationMethod

439+ -> Traced MatchedPathItem

440+ -> Maybe (Traced' MatchedOperation Operation)

443441tracedMethod s mpi = env (ask mpi >>> step (OperationMethodStep s)) <$> (pathItemMethod s . pathItem . extract $ mpi)

444442

445443instance Issuable 'PathLevel where

@@ -487,10 +485,10 @@ instance Subtree MatchedPathItem where

487485 checkSemanticCompatibility env beh prodCons = do

488486 let paramDefs = getH @(ProdCons (Traced (Definitions Param))) env

489487 pathTracedParams = getPathParams <$> paramDefs <*> prodCons

490− getPathParams ::

491− Traced (Definitions Param) ->

492− Traced MatchedPathItem ->

493− [Traced Param]

488+ getPathParams

489+ :: Traced (Definitions Param)

490+ -> Traced MatchedPathItem

491+ -> [Traced Param]

494492 getPathParams defs mpi = do

495493 paramRef <- tracedMatchedPathItemParameters mpi

496494 pure $ dereference defs paramRef

src/Data/OpenApi/Compare/Validate/Param.hs+7−9

@@ -2,8 +2,8 @@

22{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

33

44module Data.OpenApi.Compare.Validate.Param

5− ( Behave (..),

6− Issue (..),

5+ ( Behave (..)

6+ , Issue (..)

77 )

88where

99

@@ -79,7 +79,7 @@ instance Issuable 'PathFragmentLevel where

7979 describeIssue _ ParamPlaceIncompatible = para "Parameters in incompatible locations."

8080 describeIssue _ ParamStyleMismatch = para "Different parameter styles (encodings)."

8181 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)) =

8383 para $ "Parameter changed from " <> code e <> " to " <> code a <> "."

8484

8585instance Behavable 'PathFragmentLevel 'SchemaLevel where

@@ -106,17 +106,15 @@ instance Subtree Param where

106106 when (_paramName (extract p) /= _paramName (extract c)) $

107107 issueAt beh ParamNameMismatch

108108 when

109− ( (fromMaybe False . _paramRequired . extract $ c)

110− && not (fromMaybe False . _paramRequired . extract $ p)

111− )

109+ ((fromMaybe False . _paramRequired . extract $ c)

110+ && not (fromMaybe False . _paramRequired . extract $ p))

112111 $ issueAt beh ParamRequired

113112 case (_paramIn . extract $ p, _paramIn . extract $ c) of

114113 (ParamQuery, ParamQuery) -> do

115114 -- Emptiness is only for query params

116115 when

117− ( (fromMaybe False . _paramAllowEmptyValue . extract $ p)

118− && not (fromMaybe False . _paramAllowEmptyValue . extract $ c)

119− )

116+ ((fromMaybe False . _paramAllowEmptyValue . extract $ p)

117+ && not (fromMaybe False . _paramAllowEmptyValue . extract $ c))

120118 $ issueAt beh ParamEmptinessIncompatible

121119 (a, b) | a == b -> pure ()

122120 _ -> issueAt beh ParamPlaceIncompatible

src/Data/OpenApi/Compare/Validate/PathFragment.hs+3−3

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

11module Data.OpenApi.Compare.Validate.PathFragment

2− ( parsePath,

3− PathFragment (..),

4− PathFragmentParam,

2+ ( parsePath

3+ , PathFragment (..)

4+ , PathFragmentParam

55 )

66where

77

src/Data/OpenApi/Compare/Validate/Products.hs+28−27

@@ -1,21 +1,21 @@

1−-- | Checks product-like entities. The key is some identificator for the product

2−--element. Each element may be required or optional.

3−--

4−--One example of product is request parameters. There are optional and required

5−--parameters. The client and server have possibly different set of

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.

8−--

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)

11−--and their schemas match.

12−--

13−--This module abstracts this logic for arbitrary elements

1+{- | Checks product-like entities. The key is some identificator for the product

2+element. Each element may be required or optional.

3+

4+One example of product is request parameters. There are optional and required

5+parameters. The client and server have possibly different set of

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.

8+

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)

11+and their schemas match.

12+

13+This module abstracts this logic for arbitrary elements -}

14+

1415module Data.OpenApi.Compare.Validate.Products

15− ( checkProducts,

16− ProductLike (..),

17− )

18−where

16+ ( checkProducts

17+ , ProductLike(..)

18+ ) where

1919

2020import Data.Foldable

2121import Data.Map.Strict (Map)

@@ -30,19 +30,20 @@ data ProductLike a = ProductLike

3030 , required :: Bool

3131 }

3232

33−checkProducts ::

34− (Ord k, Issuable l) =>

35− Paths q r l ->

36− -- | No required element found

37− (k -> Issue l) ->

38− (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

39− ProdCons (Map k (ProductLike t)) ->

40− CompatFormula' q AnIssue r ()

33+checkProducts

34+ :: (Ord k, Issuable l)

35+ => Paths q r l

36+ -> (k -> Issue l)

37+ -- ^ No required element found

38+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

39+ -> ProdCons (Map k (ProductLike t))

40+ -> CompatFormula' q AnIssue r ()

4141checkProducts xs noElt check (ProdCons p c) = for_ (M.toList c) $ \(key, consElt) ->

4242 case M.lookup key p of

4343 Nothing -> case required consElt of

44− True -> issueAt xs $ noElt key

44+ True -> issueAt xs $ noElt key

4545 False -> pure ()

4646 Just prodElt -> do

47− let elts = ProdCons prodElt consElt

47+ let

48+ elts = ProdCons prodElt consElt

4849 check key (productValue <$> elts)

src/Data/OpenApi/Compare/Validate/RequestBody.hs+2−2

@@ -1,8 +1,8 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.RequestBody

4− ( Issue (..),

5− Behave (..),

4+ ( Issue (..)

5+ , Behave (..)

66 )

77where

88

src/Data/OpenApi/Compare/Validate/Responses.hs+1−1

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

22{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

33

44module Data.OpenApi.Compare.Validate.Responses

5− ( Behave (..),

5+ ( Behave (..)

66 )

77where

88

src/Data/OpenApi/Compare/Validate/Schema.hs+97−76

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

11{-# OPTIONS_GHC -Wno-orphans #-}

2−

32module Data.OpenApi.Compare.Validate.Schema

43 (

54 )

@@ -11,9 +10,9 @@ import Data.Coerce

1110import Data.Foldable (for_, toList)

1211import Data.Functor

1312import Data.HList

14−import Data.List (genericIndex, genericLength, group)

1513import qualified Data.List.NonEmpty as NE

1614import qualified Data.Map as M

15+import Data.List (group, genericLength, genericIndex)

1716import Data.Maybe

1817import Data.OpenApi

1918import Data.OpenApi.Compare.Behavior

@@ -23,24 +22,24 @@ import Data.OpenApi.Compare.Subtree

2322import Data.OpenApi.Compare.Validate.Schema.DNF

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

2524import Data.OpenApi.Compare.Validate.Schema.JsonFormula

26−import Data.OpenApi.Compare.Validate.Schema.Partition

27−import Data.OpenApi.Compare.Validate.Schema.Process

2825import Data.OpenApi.Compare.Validate.Schema.Traced

2926import Data.OpenApi.Compare.Validate.Schema.TypedJson

27+import Data.OpenApi.Compare.Validate.Schema.Partition

28+import Data.OpenApi.Compare.Validate.Schema.Process

3029import Data.Ord

3130import Data.Ratio

3231import Data.Semigroup

3332import qualified Data.Set as S

3433import Data.Text (Text)

3534

36−checkFormulas ::

37− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

38− HList xs ->

39− Behavior 'SchemaLevel ->

40− ProdCons (Trace Schema) ->

41− ProdCons (Traced (Definitions Schema)) ->

42− ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel) ->

43− SemanticCompatFormula ()

35+checkFormulas

36+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

37+ => HList xs

38+ -> Behavior 'SchemaLevel

39+ -> ProdCons (Trace Schema)

40+ -> ProdCons (Traced (Definitions Schema))

41+ -> ProdCons (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

42+ -> SemanticCompatFormula ()

4443checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

4544 case P.toList ep ++ P.toList ec of

4645 issues@(_ : _) -> for_ issues $ embedFormula beh . anItem

@@ -145,21 +144,21 @@ checkFormulas env beh trs defs (ProdCons (fp, ep) (fc, ec)) =

145144 EnumDoesntSatisfy $ untypeValue e -- what does this look like when partitioned?

146145 issueFromDisjunct mPart ps = NoMatchingCondition mPart $ SomeCondition <$> S.toList ps

147146

148−checkContradiction ::

149− Behavior 'TypedSchemaLevel ->

150− Maybe Partition ->

151− S.Set (Condition t) ->

152− SemanticCompatFormula ()

147+checkContradiction

148+ :: Behavior 'TypedSchemaLevel

149+ -> Maybe Partition

150+ -> S.Set (Condition t)

151+ -> SemanticCompatFormula ()

153152checkContradiction beh mPart _ = issueAt beh $ maybe TypeBecomesEmpty PartitionBecomesEmpty mPart -- TODO #70

154153

155−checkImplication ::

156− (ReassembleHList xs (CheckEnv (Referenced Schema))) =>

157− HList xs ->

158− Behavior 'TypedSchemaLevel ->

159− ProdCons (Trace Schema) -> -- the traces of the root schemas used in this comparison

160− S.Set (Condition t) ->

161− Condition t ->

162− SemanticCompatFormula ()

154+checkImplication

155+ :: (ReassembleHList xs (CheckEnv (Referenced Schema)))

156+ => HList xs

157+ -> Behavior 'TypedSchemaLevel

158+ -> ProdCons (Trace Schema) -- the traces of the root schemas used in this comparison

159+ -> S.Set (Condition t)

160+ -> Condition t

161+ -> SemanticCompatFormula ()

163162checkImplication env beh trs prods cons = case findExactly prods of

164163 Just e

165164 | all (satisfiesTyped e) prods ->

@@ -167,104 +166,124 @@ checkImplication env beh trs prods cons = case findExactly prods of

167166 then pure ()

168167 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

169168 | otherwise -> pure () -- vacuously true

169+

170170 Nothing -> case cons of

171171 -- the above code didn't catch it, so there's no Exactly condition on the lhs

172172 Exactly e -> issueAt beh (NoMatchingEnum $ untypeValue e)

173+

173174 Maximum m -> foldCheck min m NoMatchingMaximum MatchingMaximumWeak $ \case

174175 Maximum m' -> Just m'

175176 _ -> Nothing

177+

176178 Minimum m -> foldCheck max m (NoMatchingMinimum . coerce) (MatchingMinimumWeak . coerce) $ \case

177179 Minimum m' -> Just m'

178180 _ -> Nothing

181+

179182 MultipleOf m -> foldCheck lcmScientific m NoMatchingMultipleOf MatchingMultipleOfWeak $ \case

180183 MultipleOf m' -> Just m'

181184 _ -> Nothing

185+

182186 NumberFormat f -> case flip any prods $ \case

183− NumberFormat f' -> f == f'

184− _ -> False of

187+ NumberFormat f' -> f == f'

188+ _ -> False

189+ of

185190 True -> pure ()

186191 False -> issueAt beh (NoMatchingFormat f)

192+

187193 MaxLength m -> foldCheck min m NoMatchingMaxLength MatchingMaxLengthWeak $ \case

188194 MaxLength m' -> Just m'

189195 _ -> Nothing

196+

190197 MinLength m -> foldCheck max m NoMatchingMinLength MatchingMinLengthWeak $ \case

191198 MinLength m' -> Just m'

192199 _ -> Nothing

200+

193201 Pattern p -> case flip any prods $ \case

194− Pattern p' -> p == p'

195− _ -> False of

202+ Pattern p' -> p == p'

203+ _ -> False

204+ of

196205 True -> pure ()

197206 False -> issueAt beh (NoMatchingPattern p) -- TODO: regex comparison #32

207+

198208 StringFormat f -> case flip any prods $ \case

199− StringFormat f' -> f == f'

200− _ -> False of

209+ StringFormat f' -> f == f'

210+ _ -> False

211+ of

201212 True -> pure ()

202213 False -> issueAt beh (NoMatchingFormat f)

214+

203215 Items _ cons' -> case foldSome (<>) prods $ \case

204− Items _ rs -> Just (Just (rs NE.:| []), mempty)

205− TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

206− _ -> Nothing of

216+ Items _ rs -> Just (Just (rs NE.:| []), mempty)

217+ TupleItems (map snd -> fs) -> Just (mempty, Just (fs NE.:| []))

218+ _ -> Nothing

219+ of

207220 Just (mItems, Just pfs)

208221 | not $ allSame (length <$> pfs) -> pure () -- vacuously

209− | let plen = genericLength (NE.head pfs) ->

210− clarifyIssue (AnItem beh (anIssue TupleToArray)) $

211− for_ [0 .. plen - 1] $ \i -> do

212− let prod' = tracedConjunct $ case mItems of

213− Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

214− Nothing -> (`genericIndex` i) <$> pfs

215− checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

222+ | let plen = genericLength (NE.head pfs)

223+ -> clarifyIssue (AnItem beh (anIssue TupleToArray)) $ for_ [0 .. plen - 1] $ \i -> do

224+ let prod' = tracedConjunct $ case mItems of

225+ Just prods' -> ((`genericIndex` i) <$> pfs) <> prods'

226+ Nothing -> (`genericIndex` i) <$> pfs

227+ checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prod' cons'

216228 Just (Just prods', Nothing) -> do

217229 let prod' = tracedConjunct prods'

218230 checkCompatibility (beh >>> step InItems) env $ ProdCons prod' cons'

219231 _ -> clarifyIssue (AnItem beh (anIssue NoMatchingItems)) $ do

220232 checkCompatibility (beh >>> step InItems) env $ ProdCons prodTopSchema cons'

233+

221234 TupleItems (map snd -> fs) -> case foldSome (<>) prods $ \case

222− TupleItems (map snd -> fs') -> Just (Just $ fs' NE.:| [], Just . Max $ genericLength fs', Just . Min $ genericLength fs', mempty)

223− MinItems m' -> Just (mempty, Just . Max $ m', mempty, mempty)

224− MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

225− Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

226− _ -> Nothing of

227− -- if the length constraints in the producer are contradictory:

228− Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

229− -- We have an explicit tuple items clause...

230− Just (Just pfs, Just (Max plen), _, _)

231− | plen /= genericLength fs -> -- ...of wrong length

232− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

233− | otherwise ->

234− for_ [0 .. plen - 1] $ \i -> do

235+ 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)

237+ MaxItems m' -> Just (mempty, mempty, Just . Min $ m', mempty)

238+ Items _ rs -> Just (mempty, mempty, mempty, Just (rs NE.:| []))

239+ _ -> Nothing

240+ of

241+ -- if the length constraints in the producer are contradictory:

242+ Just (_, Just (Max lowest), Just (Min highest), _) | lowest > highest -> pure ()

243+ -- We have an explicit tuple items clause...

244+ Just (Just pfs, Just (Max plen), _, _)

245+ | plen /= genericLength fs -- ...of wrong length

246+ -> issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

247+ | otherwise

248+ -> for_ [0 .. plen - 1] $ \i -> do

235249 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct $ (`genericIndex` i) <$> pfs) (fs `genericIndex` i)

236− -- We have a fixed length array in the producer...

237− Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

238− | plen == plen' ->

239− clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

240− _

241− | plen /= genericLength fs -> -- ...of wrong length

242− issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

250+ -- We have a fixed length array in the producer...

251+ Just (Nothing, Just (Max plen), Just (Min plen'), mProd)

252+ | plen == plen'

253+ -> clarifyIssue (AnItem beh (anIssue ArrayToTuple)) $ case mProd of

254+ _ | plen /= genericLength fs -> -- ...of wrong length

255+ issueAt beh (TupleItemsLengthChanged ProdCons {producer = plen, consumer = genericLength fs})

243256 Just rs -> for_ [0 .. plen - 1] $ \i -> do

244257 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons (tracedConjunct rs) (fs `genericIndex` i)

245258 -- ...and no "items" schema

246259 Nothing -> clarifyIssue (AnItem beh (anIssue NoMatchingTupleItems)) $ do

247260 for_ [0 .. plen - 1] $ \i -> do

248261 checkCompatibility (beh >>> step (InItem i)) env $ ProdCons prodTopSchema (fs `genericIndex` i)

249− _ -> issueAt beh NoMatchingTupleItems

262+ _ -> issueAt beh NoMatchingTupleItems

263+

250264 MaxItems m -> foldCheck min m NoMatchingMaxItems MatchingMaxItemsWeak $ \case

251265 MaxItems m' -> Just m'

252266 TupleItems fs -> Just $ toInteger $ length fs

253267 _ -> Nothing

268+

254269 MinItems m -> foldCheck max m NoMatchingMinItems MatchingMinItemsWeak $ \case

255270 MinItems m' -> Just m'

256271 TupleItems fs -> Just $ toInteger $ length fs

257272 _ -> Nothing

273+

258274 UniqueItems -> case flip any prods $ \case

259− UniqueItems -> True

260− MaxItems 1 -> True

261− TupleItems fs | length fs == 1 -> True

262− _ -> False of

275+ UniqueItems -> True

276+ MaxItems 1 -> True

277+ TupleItems fs | length fs == 1 -> True

278+ _ -> False

279+ of

263280 True -> pure ()

264281 False -> issueAt beh NoMatchingUniqueItems

282+

265283 Properties props _ madd -> case foldSome (<>) prods $ \case

266− Properties props' _ madd' -> Just $ (props', madd') NE.:| []

267− _ -> Nothing of

284+ Properties props' _ madd' -> Just $ (props', madd') NE.:| []

285+ _ -> Nothing

286+ of

268287 Just pm ->

269288 anyOfAt beh NoMatchingProperties $ -- TODO: could first "concat" the lists

270289 NE.toList pm <&> \(props', madd') -> do

@@ -295,9 +314,11 @@ checkImplication env beh trs prods cons = case findExactly prods of

295314 (Just add', Just add) -> checkCompatibility (beh >>> step InAdditionalProperty) env (ProdCons add' add)

296315 pure ()

297316 Nothing -> issueAt beh NoMatchingProperties

317+

298318 MaxProperties m -> foldCheck min m NoMatchingMaxProperties MatchingMaxPropertiesWeak $ \case

299319 MaxProperties m' -> Just m'

300320 _ -> Nothing

321+

301322 MinProperties m -> foldCheck max m NoMatchingMinProperties MatchingMinPropertiesWeak $ \case

302323 MinProperties m' -> Just m'

303324 _ -> Nothing

@@ -305,14 +326,14 @@ checkImplication env beh trs prods cons = case findExactly prods of

305326 lcmScientific (toRational -> a) (toRational -> b) =

306327 fromRational $ lcm (numerator a) (numerator b) % gcd (denominator a) (denominator b)

307328

308− foldCheck ::

309− Eq a =>

310− (a -> a -> a) ->

311− a ->

312− (a -> Issue 'TypedSchemaLevel) ->

313− (ProdCons a -> Issue 'TypedSchemaLevel) ->

314− (forall t. Condition t -> Maybe a) ->

315− SemanticCompatFormula ()

329+ foldCheck

330+ :: Eq a

331+ => (a -> a -> a)

332+ -> a

333+ -> (a -> Issue 'TypedSchemaLevel)

334+ -> (ProdCons a -> Issue 'TypedSchemaLevel)

335+ -> (forall t. Condition t -> Maybe a)

336+ -> SemanticCompatFormula ()

316337 foldCheck f m missing weak extr = case foldSome f prods extr of

317338 Just m'

318339 | f m' m == m' -> pure ()

src/Data/OpenApi/Compare/Validate/Schema/DNF.hs+8−8

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

11module Data.OpenApi.Compare.Validate.Schema.DNF

2− ( DNF (..),

3− Disjunct (..),

4− pattern SingleDisjunct,

5− pattern TopDNF,

6− pattern BottomDNF,

7− pattern LiteralDNF,

8− foldDNF,

9− forDNF,

2+ ( DNF (..)

3+ , Disjunct (..)

4+ , pattern SingleDisjunct

5+ , pattern TopDNF

6+ , pattern BottomDNF

7+ , pattern LiteralDNF

8+ , foldDNF

9+ , forDNF

1010 )

1111where

1212

src/Data/OpenApi/Compare/Validate/Schema/Issues.hs+51−53

@@ -1,8 +1,8 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

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

4− ( Issue (..),

5− Behave (..),

4+ ( Issue (..)

5+ , Behave (..)

66 )

77where

88

@@ -100,54 +100,53 @@ instance Issuable 'TypedSchemaLevel where

100100 TypeBecomesEmpty -> ProbablyIssue -- TODO: #70

101101 PartitionBecomesEmpty _ -> ProbablyIssue -- ditto

102102 _ -> CertainIssue

103− relatedIssues =

104− (==) `withClass` \case

103+ relatedIssues = (==) `withClass` \case

105104 EnumDoesntSatisfy v -> Just v

106105 NoMatchingEnum v -> Just v

107106 _ -> Nothing

108− `withClass` \case

109− NoMatchingMaximum _ -> Just ()

110− MatchingMaximumWeak _ -> Just ()

111− _ -> Nothing

112− `withClass` \case

113− NoMatchingMinimum _ -> Just ()

114− MatchingMinimumWeak _ -> Just ()

115− _ -> Nothing

116− `withClass` \case

117− NoMatchingMultipleOf _ -> Just ()

118− MatchingMultipleOfWeak _ -> Just ()

119− _ -> Nothing

120− `withClass` \case

121− NoMatchingMaxLength _ -> Just ()

122− MatchingMaxLengthWeak _ -> Just ()

123− _ -> Nothing

124− `withClass` \case

125− NoMatchingMinLength _ -> Just ()

126− MatchingMinLengthWeak _ -> Just ()

127− _ -> Nothing

128− `withClass` \case

129− NoMatchingItems -> Just ()

130− ArrayToTuple -> Just ()

131− TupleToArray -> Just ()

132− NoMatchingTupleItems -> Just ()

133− TupleItemsLengthChanged _ -> Just ()

134− _ -> Nothing

135− `withClass` \case

136− NoMatchingMaxItems _ -> Just ()

137− MatchingMaxItemsWeak _ -> Just ()

138− _ -> Nothing

139− `withClass` \case

140− NoMatchingMinItems _ -> Just ()

141− MatchingMinItemsWeak _ -> Just ()

142− _ -> Nothing

143− `withClass` \case

144− NoMatchingMaxProperties _ -> Just ()

145− MatchingMaxPropertiesWeak _ -> Just ()

146− _ -> Nothing

147− `withClass` \case

148− NoMatchingMinProperties _ -> Just ()

149− MatchingMinPropertiesWeak _ -> Just ()

150− _ -> Nothing

107+ `withClass` \case

108+ NoMatchingMaximum _ -> Just ()

109+ MatchingMaximumWeak _ -> Just ()

110+ _ -> Nothing

111+ `withClass` \case

112+ NoMatchingMinimum _ -> Just ()

113+ MatchingMinimumWeak _ -> Just ()

114+ _ -> Nothing

115+ `withClass` \case

116+ NoMatchingMultipleOf _ -> Just ()

117+ MatchingMultipleOfWeak _ -> Just ()

118+ _ -> Nothing

119+ `withClass` \case

120+ NoMatchingMaxLength _ -> Just ()

121+ MatchingMaxLengthWeak _ -> Just ()

122+ _ -> Nothing

123+ `withClass` \case

124+ NoMatchingMinLength _ -> Just ()

125+ MatchingMinLengthWeak _ -> Just ()

126+ _ -> Nothing

127+ `withClass` \case

128+ NoMatchingItems -> Just ()

129+ ArrayToTuple -> Just ()

130+ TupleToArray -> Just ()

131+ NoMatchingTupleItems -> Just ()

132+ TupleItemsLengthChanged _ -> Just ()

133+ _ -> Nothing

134+ `withClass` \case

135+ NoMatchingMaxItems _ -> Just ()

136+ MatchingMaxItemsWeak _ -> Just ()

137+ _ -> Nothing

138+ `withClass` \case

139+ NoMatchingMinItems _ -> Just ()

140+ MatchingMinItemsWeak _ -> Just ()

141+ _ -> Nothing

142+ `withClass` \case

143+ NoMatchingMaxProperties _ -> Just ()

144+ MatchingMaxPropertiesWeak _ -> Just ()

145+ _ -> Nothing

146+ `withClass` \case

147+ NoMatchingMinProperties _ -> Just ()

148+ MatchingMinPropertiesWeak _ -> Just ()

149+ _ -> Nothing

151150 describeIssue Forward (EnumDoesntSatisfy v) = para "The following enum value was removed:" <> showJSONValue v

152151 describeIssue Backward (EnumDoesntSatisfy v) = para "The following enum value was added:" <> showJSONValue v

153152 describeIssue Forward (NoMatchingEnum v) = para "The following enum value has been added:" <> showJSONValue v

@@ -255,15 +254,14 @@ instance Issuable 'SchemaLevel where

255254 PropertyToAdditional -> Comment

256255 TypesRestricted _ -> ProbablyIssue -- TODO: #70

257256 _ -> CertainIssue

258− relatedIssues =

259− (==) `withClass` \case

257+ relatedIssues = (==) `withClass` \case

260258 AdditionalToProperty -> Just ()

261259 PropertyToAdditional -> Just ()

262260 _ -> Nothing

263− `withClass` \case

264− PropertyNowRequired -> Just ()

265− UnexpectedProperty -> Just ()

266− _ -> Nothing

261+ `withClass` \case

262+ PropertyNowRequired -> Just ()

263+ UnexpectedProperty -> Just ()

264+ _ -> Nothing

267265 describeIssue _ (NotSupported i) =

268266 para (emph "Encountered a feature that CompaREST does not support: " <> text i <> ".")

269267 describeIssue _ OneOfNotDisjoint =

src/Data/OpenApi/Compare/Validate/Schema/JsonFormula.hs+43−50

@@ -1,18 +1,18 @@

11module Data.OpenApi.Compare.Validate.Schema.JsonFormula

2− ( Bound (..),

3− showBound,

4− Property (..),

5− Condition (..),

6− showCondition,

7− satisfiesTyped,

8− checkStringFormat,

9− checkNumberFormat,

10− SomeCondition (..),

11− JsonFormula (..),

12− satisfiesFormula,

13− satisfies,

14− showJSONValue,

15− showJSONValueInline,

2+ ( Bound (..)

3+ , showBound

4+ , Property (..)

5+ , Condition (..)

6+ , showCondition

7+ , satisfiesTyped

8+ , checkStringFormat

9+ , checkNumberFormat

10+ , SomeCondition (..)

11+ , JsonFormula (..)

12+ , satisfiesFormula

13+ , satisfies

14+ , showJSONValue

15+ , showJSONValueInline

1616 )

1717where

1818

@@ -20,8 +20,8 @@ import Algebra.Lattice

2020import qualified Data.Aeson as A

2121import qualified Data.ByteString.Lazy as BSL

2222import qualified Data.Foldable as F

23−import Data.Functor

2423import qualified Data.HashMap.Strict as HM

24+import Data.Functor

2525import Data.Int

2626import Data.Kind

2727import qualified Data.Map as M

@@ -67,33 +67,30 @@ data Property = Property

6767data Condition :: JsonType -> Type where

6868 Exactly :: TypedValue t -> Condition t

6969 Maximum :: !(Bound Scientific) -> Condition 'Number

70− Minimum ::

71− !(Down (Bound (Down Scientific))) ->

72− -- | this has the right Ord

73− Condition 'Number

70+ Minimum

71+ :: !(Down (Bound (Down Scientific)))

72+ -> Condition 'Number -- ^ this has the right Ord

7473 MultipleOf :: !Scientific -> Condition 'Number

7574 NumberFormat :: !Format -> Condition 'Number

7675 MaxLength :: !Integer -> Condition 'String

7776 MinLength :: !Integer -> Condition 'String

7877 Pattern :: !Pattern -> Condition 'String

7978 StringFormat :: !Format -> Condition 'String

80− Items ::

81− !(ForeachType JsonFormula) ->

82− !(Traced (Referenced Schema)) ->

83− Condition 'Array

84− TupleItems ::

85− ![(ForeachType JsonFormula, Traced (Referenced Schema))] ->

86− Condition 'Array

79+ Items

80+ :: !(ForeachType JsonFormula)

81+ -> !(Traced (Referenced Schema))

82+ -> Condition 'Array

83+ TupleItems

84+ :: ![(ForeachType JsonFormula, Traced (Referenced Schema))]

85+ -> Condition 'Array

8786 MaxItems :: !Integer -> Condition 'Array

8887 MinItems :: !Integer -> Condition 'Array

8988 UniqueItems :: Condition 'Array

90− Properties ::

91− !(M.Map Text Property) ->

92− -- | formula for additional properties

93− !(ForeachType JsonFormula) ->

94− -- | schema for additional properties, Nothing means bottom

95− !(Maybe (Traced (Referenced Schema))) ->

96− Condition 'Object

89+ Properties

90+ :: !(M.Map Text Property)

91+ -> !(ForeachType JsonFormula) -- ^ formula for additional properties

92+ -> !(Maybe (Traced (Referenced Schema))) -- ^ schema for additional properties, Nothing means bottom

93+ -> Condition 'Object

9794 MaxProperties :: !Integer -> Condition 'Object

9895 MinProperties :: !Integer -> Condition 'Object

9996

@@ -121,15 +118,13 @@ showCondition = \case

121118 UniqueItems -> para "The elements in the array should be unique."

122119 (Properties props additional _) ->

123120 bulletList $

124− ( M.toList props

125− <&> ( \(k, p) ->

126− para (code k)

127− <> para (strong $ if propRequired p then "Required" else "Optional")

128− <> showForEachJsonFormula (propFormula p)

129− )

130− )

121+ (M.toList props

122+ <&> (\(k, p) ->

123+ para (code k)

124+ <> para (strong $ if propRequired p then "Required" else "Optional")

125+ <> showForEachJsonFormula (propFormula p)))

131126 <> [ para (emph "Additional properties")

132− <> showForEachJsonFormula additional

127+ <> showForEachJsonFormula additional

133128 ]

134129 (MaxProperties n) -> para $ "The maximum number of fields should be " <> show' n <> "."

135130 (MinProperties n) -> para $ "The minimum number of fields should be " <> show' n <> "."

@@ -138,17 +133,15 @@ showCondition = \case

138133 showForEachJsonFormula i =

139134 bulletList $

140135 foldType

141− ( \t f -> case getJsonFormula $ f i of

142− BottomDNF -> mempty

143− (DNF conds) ->

136+ (\t f -> case getJsonFormula $ f i of

137+ BottomDNF -> mempty

138+ (DNF conds) ->

144139 [ para (describeJSONType t)

145140 <> bulletList

146− ( S.toList conds <&> \case

147− Disjunct (S.toList -> []) -> para "Empty"

148− Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)

149− )

150− ]

151− )

141+ (S.toList conds <&> \case

142+ Disjunct (S.toList -> []) -> para "Empty"

143+ Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))

144+ ])

152145

153146showJSONValue :: A.Value -> Blocks

154147showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

src/Data/OpenApi/Compare/Validate/Schema/Partition.hs+29−30

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

11module Data.OpenApi.Compare.Validate.Schema.Partition

2− ( partitionSchema,

3− partitionRefSchema,

4− selectPartition,

5− runPartitionM,

6− tryPartition,

7− showPartition,

8− intersectSchema,

9− intersectRefSchema,

10− IntersectionResult (..),

11− runIntersectionM,

12− Partition,

2+ ( partitionSchema

3+ , partitionRefSchema

4+ , selectPartition

5+ , runPartitionM

6+ , tryPartition

7+ , showPartition

8+ , intersectSchema

9+ , intersectRefSchema

10+ , IntersectionResult (..)

11+ , runIntersectionM

12+ , Partition

1313 )

1414where

1515

@@ -143,11 +143,10 @@ partitionCondition = \case

143143 Just _ -> top

144144 Nothing ->

145145 singletonPart $

146− DByProperties $

147− LiteralDNF

148− ( M.keysSet $ M.filter (not . propRequired) props

149− , M.keysSet $ M.filter propRequired props

150− )

146+ DByProperties $ LiteralDNF

147+ ( M.keysSet $ M.filter (not . propRequired) props

148+ , M.keysSet $ M.filter propRequired props

149+ )

151150 inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

152151 f <- partitionRefSchema $ propRefSchema prop

153152 pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

@@ -157,10 +156,10 @@ partitionCondition = \case

157156runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

158157runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

159158

160−partitionJsonFormulas ::

161− ProdCons (Traced (Definitions Schema)) ->

162− ProdCons (JsonFormula t) ->

163− Lifted Partitions

159+partitionJsonFormulas

160+ :: ProdCons (Traced (Definitions Schema))

161+ -> ProdCons (JsonFormula t)

162+ -> Lifted Partitions

164163partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

165164 where

166165 pcPart = partitionFormula <$> defs <*> pc

@@ -212,11 +211,11 @@ runIntersectionM defs act = case runWriterT $ runReaderT act defs of

212211 Just (x, Any False) -> Same x

213212 Just (x, Any True) -> New x

214213

215−intersectSchema ::

216− PartitionLocation ->

217− PartitionChoice ->

218− Traced Schema ->

219− IntersectionM Schema

214+intersectSchema

215+ :: PartitionLocation

216+ -> PartitionChoice

217+ -> Traced Schema

218+ -> IntersectionM Schema

220219intersectSchema loc part sch = do

221220 allOf' <- forM (tracedAllOf sch) $ \rss ->

222221 -- Assuming i ranges over a nonempty set (checked in processSchema)

@@ -259,11 +258,11 @@ intersectSchema loc part sch = do

259258 pure $ sch' {_schemaEnum = Just enum'}

260259 CByProperties {} -> error "CByProperties not implemented"

261260

262−intersectRefSchema ::

263− PartitionLocation ->

264− PartitionChoice ->

265− Traced (Referenced Schema) ->

266− IntersectionM (Referenced Schema)

261+intersectRefSchema

262+ :: PartitionLocation

263+ -> PartitionChoice

264+ -> Traced (Referenced Schema)

265+ -> IntersectionM (Referenced Schema)

267266intersectRefSchema loc part rs = do

268267 defs <- R.ask

269268 Inline <$> intersectSchema loc part (dereference defs rs)

src/Data/OpenApi/Compare/Validate/Schema/Process.hs+34−35

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

11module Data.OpenApi.Compare.Validate.Schema.Process

2− ( schemaToFormula,

2+ ( schemaToFormula

33 )

44where

55

66import Algebra.Lattice

7−import Control.Monad.Reader hiding (ask)

87import qualified Control.Monad.Reader as R

8+import Control.Monad.Reader hiding (ask)

99import Control.Monad.State

1010import Control.Monad.Writer

1111import qualified Data.Aeson as A

@@ -71,10 +71,10 @@ warnKnot =

7171 , tieKnot = \_ -> pure

7272 }

7373

74−processRefSchema ::

75− MonadProcess m =>

76− Traced (Referenced Schema) ->

77− m (ForeachType JsonFormula)

74+processRefSchema

75+ :: MonadProcess m

76+ => Traced (Referenced Schema)

77+ -> m (ForeachType JsonFormula)

7878processRefSchema x = do

7979 defs <- R.ask

8080 memoWithKnot warnKnot (processSchema $ dereference defs x) (ask x)

@@ -82,10 +82,10 @@ processRefSchema x = do

8282-- | Turn a schema into a tuple of 'JsonFormula's that describes the condition

8383-- for every possible type of a JSON value. The conditions are independent, and

8484-- are thus checked independently.

85−processSchema ::

86− MonadProcess m =>

87− Traced Schema ->

88− m (ForeachType JsonFormula)

85+processSchema

86+ :: MonadProcess m

87+ => Traced Schema

88+ -> m (ForeachType JsonFormula)

8989processSchema sch@(extract -> Schema {..}) = do

9090 let singletonFormula :: Condition t -> JsonFormula t

9191 singletonFormula = JsonFormula . LiteralDNF

@@ -331,27 +331,26 @@ processSchema sch@(extract -> Schema {..}) = do

331331 pure $

332332 nullableClause

333333 \/ meets

334− ( allClauses

335− <> [ anyClause

336− , oneClause

337− , typeClause

338− , enumClause

339− , maximumClause

340− , minimumClause

341− , multipleOfClause

342− , formatClause

343− , maxLengthClause

344− , minLengthClause

345− , patternClause

346− , itemsClause

347− , maxItemsClause

348− , minItemsClause

349− , uniqueItemsClause

350− , propertiesClause

351− , maxPropertiesClause

352− , minPropertiesClause

353− ]

354− )

334+ (allClauses

335+ <> [ anyClause

336+ , oneClause

337+ , typeClause

338+ , enumClause

339+ , maximumClause

340+ , minimumClause

341+ , multipleOfClause

342+ , formatClause

343+ , maxLengthClause

344+ , minLengthClause

345+ , patternClause

346+ , itemsClause

347+ , maxItemsClause

348+ , minItemsClause

349+ , uniqueItemsClause

350+ , propertiesClause

351+ , maxPropertiesClause

352+ , minPropertiesClause

353+ ])

355354

356355{- TODO: ReadOnly/WriteOnly #68 -}

357356

@@ -370,8 +369,8 @@ checkOneOfDisjoint schs = do

370369runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

371370runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

372371

373−schemaToFormula ::

374− Traced (Definitions Schema) ->

375− Traced Schema ->

376− (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

372+schemaToFormula

373+ :: Traced (Definitions Schema)

374+ -> Traced Schema

375+ -> (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

377376schemaToFormula defs rs = runProcessM defs $ processSchema rs

src/Data/OpenApi/Compare/Validate/Schema/Traced.hs+12−12

@@ -1,18 +1,18 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.Schema.Traced

4− ( Step (..),

5− tracedAllOf,

6− tracedAnyOf,

7− tracedOneOf,

8− tracedItems,

9− tracedAdditionalProperties,

10− tracedDiscriminator,

11− tracedProperties,

12− tracedConjunct,

13− PartitionLocation (..),

14− PartitionChoice (..),

15− Partition,

4+ ( Step (..)

5+ , tracedAllOf

6+ , tracedAnyOf

7+ , tracedOneOf

8+ , tracedItems

9+ , tracedAdditionalProperties

10+ , tracedDiscriminator

11+ , tracedProperties

12+ , tracedConjunct

13+ , PartitionLocation (..)

14+ , PartitionChoice (..)

15+ , Partition

1616 )

1717where

1818

src/Data/OpenApi/Compare/Validate/Schema/TypedJson.hs+23−25

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

11module Data.OpenApi.Compare.Validate.Schema.TypedJson

2− ( JsonType (..),

3− describeJSONType,

4− TypedValue (..),

5− untypeValue,

6− ForeachType (..),

7− foldType,

8− forType_,

2+ ( JsonType (..)

3+ , describeJSONType

4+ , TypedValue (..)

5+ , untypeValue

6+ , ForeachType (..)

7+ , foldType

8+ , forType_

99 )

1010where

1111

@@ -88,26 +88,24 @@ forType_ :: Applicative m => (forall x. Typeable x => JsonType -> (ForeachType f

8888forType_ k = getAp $ foldType (\ty proj -> Ap $ k ty proj)

8989

9090broadcastType :: (forall x. Typeable x => f x) -> ForeachType f

91−broadcastType k =

92− ForeachType

93− { forNull = k

94− , forBoolean = k

95− , forNumber = k

96− , forString = k

97− , forArray = k

98− , forObject = k

99− }

91+broadcastType k = ForeachType

92+ { forNull = k

93+ , forBoolean = k

94+ , forNumber = k

95+ , forString = k

96+ , forArray = k

97+ , forObject = k

98+ }

10099

101100zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

102−zipType k f1 f2 =

103− ForeachType

104− { forNull = k (forNull f1) (forNull f2)

105− , forBoolean = k (forBoolean f1) (forBoolean f2)

106− , forNumber = k (forNumber f1) (forNumber f2)

107− , forString = k (forString f1) (forString f2)

108− , forArray = k (forArray f1) (forArray f2)

109− , forObject = k (forObject f1) (forObject f2)

110− }

101+zipType k f1 f2 = ForeachType

102+ { forNull = k (forNull f1) (forNull f2)

103+ , forBoolean = k (forBoolean f1) (forBoolean f2)

104+ , forNumber = k (forNumber f1) (forNumber f2)

105+ , forString = k (forString f1) (forString f2)

106+ , forArray = k (forArray f1) (forArray f2)

107+ , forObject = k (forObject f1) (forObject f2)

108+ }

111109

112110instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

113111 (\/) = zipType (\/)

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs+8−9

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

22{-# OPTIONS_GHC -Wno-orphans #-}

33

44module Data.OpenApi.Compare.Validate.SecurityRequirement

5− ( Issue (..),

5+ ( Issue (..)

66 )

77where

88

@@ -41,19 +41,18 @@ instance Subtree SecurityRequirement where

4141 for (IOHM.toList $ getSecurityRequirement sec) $ \(key, scopes) ->

4242 (,scopes) <$> lookupScheme key defs

4343 structuralMaybeWith

44− ( \pc' -> do

45− let ProdCons pScopes cScopes = fmap snd <$> pc'

46− unless (pScopes == cScopes) structuralIssue

47− structuralList env $ fmap fst <$> pc'

48− pure ()

49− )

44+ (\pc' -> do

45+ let ProdCons pScopes cScopes = fmap snd <$> pc'

46+ unless (pScopes == cScopes) structuralIssue

47+ structuralList env $ fmap fst <$> pc'

48+ pure ())

5049 normalized

5150 pure ()

5251 checkSemanticCompatibility env bhv' pc = do

5352 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

5453 ( ProdCons pErrs cErrs

55− , (ProdCons pSchemes cSchemes) ::

56− ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

54+ , (ProdCons pSchemes cSchemes)

55+ :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

5756 ) =

5857 NE.unzip $

5958 partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/Server.hs+9−10

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

11{-# OPTIONS_GHC -Wno-orphans #-}

22

33module Data.OpenApi.Compare.Validate.Server

4− ( Issue (..),

4+ ( Issue (..)

55 )

66where

77

@@ -31,9 +31,9 @@ import Data.Traversable

3131import Text.Pandoc.Builder

3232import Prelude as P

3333

34−tracedParsedServerUrlParts ::

35− Server ->

36− Either (Issue 'ServerLevel) ProcessedServer

34+tracedParsedServerUrlParts

35+ :: Server

36+ -> Either (Issue 'ServerLevel) ProcessedServer

3737tracedParsedServerUrlParts s =

3838 let parsedUrl = parseServerUrl $ _serverUrl s

3939 lookupVar var = case IOHM.lookup var (_serverVariables s) of

@@ -63,12 +63,11 @@ instance Subtree [Server] where

6363 pcServer

6464 <&> partitionEithers

6565 . fmap

66− ( \(Traced t s) ->

67− let bhv = beh >>> step (InServer $ _serverUrl s)

68− in case tracedParsedServerUrlParts s of

69− Left e -> Left $ issueAt bhv e

70− Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u)

71− )

66+ (\(Traced t s) ->

67+ let bhv = beh >>> step (InServer $ _serverUrl s)

68+ in case tracedParsedServerUrlParts s of

69+ Left e -> Left $ issueAt bhv e

70+ Right u -> Right (bhv, Traced (t >>> step (ServerStep $ _serverUrl s)) u))

7271 . sequence

7372 sequenceA_ pErrs

7473 sequenceA_ cErrs

src/Data/OpenApi/Compare/Validate/Sums.hs+11−12

@@ -1,25 +1,24 @@

11module Data.OpenApi.Compare.Validate.Sums

2− ( checkSums,

3− )

4−where

2+ ( checkSums

3+ ) where

54

65import Data.Foldable

76import Data.Map.Strict (Map)

87import qualified Data.Map.Strict as M

98import Data.OpenApi.Compare.Behavior

10−import Data.OpenApi.Compare.Paths

119import Data.OpenApi.Compare.Subtree

10+import Data.OpenApi.Compare.Paths

1211

13−checkSums ::

14− (Ord k, Issuable l) =>

15− Paths q r l ->

16− (k -> Issue l) ->

17− (k -> ProdCons t -> CompatFormula' q AnIssue r ()) ->

18− ProdCons (Map k t) ->

19− CompatFormula' q AnIssue r ()

12+checkSums

13+ :: (Ord k, Issuable l)

14+ => Paths q r l

15+ -> (k -> Issue l)

16+ -> (k -> ProdCons t -> CompatFormula' q AnIssue r ())

17+ -> ProdCons (Map k t)

18+ -> CompatFormula' q AnIssue r ()

2019checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

2120 case M.lookup key c of

2221 Nothing -> issueAt xs $ noElt key

2322 Just consElt ->

2423 let sumElts = ProdCons prodElt consElt

25− in check key sumElts

24+ in check key sumElts

src/Data/OpenUnion/Extra.hs+5−5

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

11module Data.OpenUnion.Extra

2− ( (@@>),

3− TryLiftUnion (..),

4− pattern SingletonUnion,

2+ ( (@@>)

3+ , TryLiftUnion (..)

4+ , pattern SingletonUnion

55 )

66where

77

@@ -18,8 +18,8 @@ instance TryLiftUnion '[] where

1818 tryLiftUnion _ = empty

1919

2020instance

21− (Typeable y, SubList ys (y : ys), TryLiftUnion ys) =>

22− TryLiftUnion (y ': ys)

21+ (Typeable y, SubList ys (y : ys), TryLiftUnion ys)

22+ => TryLiftUnion (y ': ys)

2323 where

2424 tryLiftUnion (x :: x) = case eqT @x @y of

2525 Nothing -> reUnion <$> tryLiftUnion @ys x

test/Spec/Golden/Extra.hs+42−46

@@ -1,8 +1,8 @@

11module Spec.Golden.Extra

2− ( getGoldenInputs,

3− getGoldenInputsUniform,

4− goldenInputsTree,

5− goldenInputsTreeUniform,

2+ ( getGoldenInputs

3+ , getGoldenInputsUniform

4+ , goldenInputsTree

5+ , goldenInputsTreeUniform

66 )

77where

88

@@ -19,12 +19,12 @@ data TestInput t

1919 | TestInputLeaf TestName t FilePath

2020 deriving stock (Functor)

2121

22−getGoldenInputs ::

23− (Each s t (FilePath, FilePath -> IO a) a) =>

24− TestName ->

25− FilePath ->

26− s ->

27− IO (TestInput t)

22+getGoldenInputs

23+ :: (Each s t (FilePath, FilePath -> IO a) a)

24+ => TestName

25+ -> FilePath

26+ -> s

27+ -> IO (TestInput t)

2828getGoldenInputs name filepath inp = do

2929 dirs' <- listDirectory filepath >>= filterM (doesDirectoryExist . (filepath </>))

3030 case dirs' of

@@ -39,34 +39,32 @@ getGoldenInputs name filepath inp = do

3939 TestInputNode name

4040 <$> forM dirs (\dir -> getGoldenInputs dir (filepath </> dir) inp)

4141

42−getGoldenInputsUniform ::

43− (Each t h (FilePath, FilePath -> IO a) a) =>

44− (Each s t FilePath (FilePath, FilePath -> IO a)) =>

45− TestName ->

46− (FilePath -> IO a) ->

47− FilePath ->

48− s ->

49− IO (TestInput h)

42+getGoldenInputsUniform

43+ :: (Each t h (FilePath, FilePath -> IO a) a)

44+ => (Each s t FilePath (FilePath, FilePath -> IO a))

45+ => TestName

46+ -> (FilePath -> IO a)

47+ -> FilePath

48+ -> s

49+ -> IO (TestInput h)

5050getGoldenInputsUniform name f filepath inp = getGoldenInputs name filepath $ inp & each %~ (,f)

5151

52−goldenInputsTree ::

53− (Each s t (FilePath, FilePath -> IO a) a) =>

54− TestName ->

55− -- | Root path

56− FilePath ->

57− -- | Name of golden file

58− FilePath ->

59− s ->

60− (t -> IO BSL.ByteString) ->

61− IO TestTree

52+goldenInputsTree

53+ :: (Each s t (FilePath, FilePath -> IO a) a)

54+ => TestName

55+ -> FilePath -- ^ Root path

56+ -> FilePath -- ^ Name of golden file

57+ -> s

58+ -> (t -> IO BSL.ByteString)

59+ -> IO TestTree

6260goldenInputsTree name filepath golden inp f = do

6361 runTestInputTree golden f <$> getGoldenInputs name filepath inp

6462

65−runTestInputTree ::

66− FilePath ->

67− (t -> IO BSL.ByteString) ->

68− TestInput t ->

69− TestTree

63+runTestInputTree

64+ :: FilePath

65+ -> (t -> IO BSL.ByteString)

66+ -> TestInput t

67+ -> TestTree

7068runTestInputTree golden f (TestInputNode name rest) =

7169 testGroup name (runTestInputTree golden f <$> rest)

7270runTestInputTree golden f (TestInputLeaf name t path) =

@@ -76,18 +74,16 @@ runTestInputTree golden f (TestInputLeaf name t path) =

7674 (path </> golden)

7775 (f t)

7876

79−goldenInputsTreeUniform ::

80− ( Each t h (FilePath, FilePath -> IO a) a

81− , Each s t FilePath (FilePath, FilePath -> IO a)

82− ) =>

83− String ->

84− -- | Root path

85− FilePath ->

86− -- | Name of golden file

87− FilePath ->

88− s ->

89− (FilePath -> IO a) ->

90− (h -> IO BSL.ByteString) ->

91− IO TestTree

77+goldenInputsTreeUniform

78+ :: ( Each t h (FilePath, FilePath -> IO a) a

79+ , Each s t FilePath (FilePath, FilePath -> IO a)

80+ )

81+ => String

82+ -> FilePath -- ^ Root path

83+ -> FilePath -- ^ Name of golden file

84+ -> s

85+ -> (FilePath -> IO a)

86+ -> (h -> IO BSL.ByteString)

87+ -> IO TestTree

9288goldenInputsTreeUniform name filepath golden inp h =

9389 goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/TraceTree.hs+2−4

@@ -12,7 +12,6 @@ import Data.OpenApi.Compare.Validate.OpenApi ()

1212import Data.Text (Text)

1313import qualified Data.Text.Encoding as T

1414import qualified Data.Yaml as Yaml

15−import Paths_compaREST

1615import Spec.Golden.Extra

1716import Test.Tasty (TestTree, testGroup)

1817import Text.Pandoc.Builder

@@ -23,11 +22,10 @@ import Prelude hiding (id, (.))

2322

2423tests :: IO TestTree

2524tests = do

26− dir <- getDataDir

2725 traceTreeTests <-

2826 goldenInputsTreeUniform

2927 "TraceTree"

30− dir

28+ "test/golden/common"

3129 "trace-tree.yaml"

3230 ("a.yaml", "b.yaml")

3331 Yaml.decodeFileThrow

@@ -36,7 +34,7 @@ tests = do

3634 reportTests <-

3735 goldenInputsTreeUniform

3836 "Report"

39− dir

37+ "test/golden/common"

4038 "report.md"

4139 ("a.yaml", "b.yaml")

4240 Yaml.decodeFileThrow