3ad9d5f..master · compaREST

.github/workflows/github-actions-image.yaml+106−2

@@ -9,13 +9,57 @@ 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+

1252 check_versions:

1353 runs-on: ubuntu-latest

1454 steps:

55+ - uses: actions/checkout@v2

56+ with:

57+ submodules: recursive

58+

1559 - name: Check library version

1660 if: github.event_name == 'release'

1761 run: |

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

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

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

2064 exit 1

2165 fi

@@ -23,11 +67,19 @@ jobs:

2367 - name: Check docker tag

2468 if: github.event_name == 'release'

2569 run: |

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

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

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

2872 exit 1

2973 fi

3074

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

82+

3183 Linux:

3284 needs: check_versions

3385 runs-on: ubuntu-latest

@@ -132,6 +184,58 @@ jobs:

132184 file: compaREST-Linux-x86.zip

133185 tag: ${{ github.ref }}

134186

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 .

238+

135239 macOS:

136240 needs: check_versions

137241 runs-on: macos-latest

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:latest"

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

3333 env:

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

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

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

@@ -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,86 +30,105 @@ 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")))

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

4952

5053optionsParser :: Parser Options

5154optionsParser =

5255 Options

5356 <$> strOption

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

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

5963 <*> strOption

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"

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"

102106 <> help

103107 "The report tree is structured using \

104− \increasing levels of headers.")

105− <|> pure HeadersTreeStyle)

106− <*> switch

107− (long "signal-exit-code"

108− <> helpDoc (Just $

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 $

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

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

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

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

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

130+ )

131+ )

113132

114133par :: String -> Doc

115134par = 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.nixnew file+4

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

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

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+pkgs.haskellPackages.policeman

compaREST.cabal+5

@@ -14,6 +14,9 @@ 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

1720

1821common common-options

1922 ghc-options:

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

203206 other-modules:

204207 Spec.Golden.Extra

205208 Spec.Golden.TraceTree

209+ Paths_compaREST

210+ autogen-modules: Paths_compaREST

206211 build-depends:

207212 , compaREST

208213 , tasty-golden

nix/ci.nixnew file+6

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

1+{ sources ? import ./sources.nix

2+, pkgs ? import sources.nixpkgs { }

3+}:

4+pkgs.mkShell {

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

6+}

policeman.jsonnew file+6

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

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+31−21

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

11module Data.OpenApi.Compare.Formula

2− ( FormulaF

3− , VarRef

4− , variable

5− , eitherOf

6− , anError

7− , errors

8− , calculate

9− , maxFixpoint

10− , mapErrors

11− ) where

2+ ( FormulaF,

3+ VarRef,

4+ variable,

5+ eitherOf,

6+ anError,

7+ errors,

8+ calculate,

9+ maxFixpoint,

10+ mapErrors,

11+ )

12+where

1213

1314import Data.Kind

1415import qualified Data.List.NonEmpty as NE

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

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

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

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

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

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

3137 -- both not 'Result'

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

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

3544 -- 'SelectFirst'

45+ FormulaF q f r a

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

3747

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

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

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

4555mkSelectFirst fs allE h = case foldMap check fs of

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

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

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

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

4959 where

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

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

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

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

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

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

5464 check x = (mempty, [x])

5565

5666data SomeFormulaF (a :: Type) where

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

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

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

98108 where

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

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

100110 Left _ -> go rs

101111 Right x -> Right (h x)

102112 go [] = Left e

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

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

11{-# LANGUAGE AllowAmbiguousTypes #-}

2+

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

34module Data.OpenApi.Compare.Memo

4− ( MonadMemo

5− , MemoState

6− , runMemo

7− , modifyMemoNonce

8− , KnotTier(..)

9− , unknot

10− , memoWithKnot

11− , memoTaggedWithKnot

12− ) where

5+ ( MonadMemo,

6+ MemoState,

7+ runMemo,

8+ modifyMemoNonce,

9+ KnotTier (..),

10+ unknot,

11+ memoWithKnot,

12+ memoTaggedWithKnot,

13+ )

14+where

1315

1416import Control.Monad.State

1517import Data.Dynamic

1618import qualified Data.Map as M

1719import Data.Tagged

18−import Data.Void

1920import qualified Data.TypeRepMap as T

21+import Data.Void

2022import Type.Reflection

2123

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

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

2931-- | An effectful memoization monad.

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

3133

32−memoStateLookup

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

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

34+memoStateLookup ::

35+ forall k v s.

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

37+ k ->

38+ MemoState s ->

39+ Maybe (Progress v)

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

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

3742 Nothing -> Nothing

3843

39−memoStateInsert

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

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

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

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

4352 where

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

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

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

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

6170data KnotTier v d m = KnotTier

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

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

6474 -- to the inner computations

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

75+ onKnotUsed :: d -> m v

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

6677 -- knot using the datum

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

6779 }

6880

6981unknot :: KnotTier v Void m

70−unknot = KnotTier

71− { onKnotFound = error "Recursion detected"

72− , onKnotUsed = absurd

73− , tieKnot = absurd

74− }

82+unknot =

83+ KnotTier

84+ { onKnotFound = error "Recursion detected"

85+ , onKnotUsed = absurd

86+ , tieKnot = absurd

87+ }

7588

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

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

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

8093--

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

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

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'

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'

118147

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

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)

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)

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, map, null, lookup)

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

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+140−120

@@ -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.TypedJson

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

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

3535import Data.OpenUnion

3636import Data.OpenUnion.Extra

3737import Data.Set

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

5454 deriving anyclass (ToJSON)

5555

5656data ReportInput = ReportInput

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)

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

6165 }

6266 deriving stock (Generic)

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

6468 deriving anyclass (ToJSON)

6569

6670segregateIssues :: CheckerOutput -> ReportInput

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

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+ }

7378 where

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

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

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

106111

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

108113generateReport cfg inp =

109− let

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

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

111115 breakingChangesPresent = not $ P.null $ breakingChanges inp

112116 nonBreakingChangesPresent = not $ P.null $ nonBreakingChanges inp

113117 unsupportedChangesPresent = not $ P.null $ unsupportedChanges inp

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

116120 OnlyErrors -> False

117121 builder = buildReport cfg

118122 report =

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"

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"

129134 , show' $ P.size $ breakingChanges inp

130135 )

131136 ]

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

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

160172 status =

161173 if

162174 | breakingChangesPresent -> BreakingChanges

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

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

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

188200 , otherIssues :: Set (AnIssue a)

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

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

190202 Just Refl

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

192204 S.partition

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

194− NoPathsMatched {} -> True

195− AllPathsFailed {} -> True)

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

206+ NoPathsMatched {} -> True

207+ AllPathsFailed {} -> True

208+ )

196209 currentIssues ->

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

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

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

203216 paths = case removedPaths of

204217 Just (ori, ps) -> do

205218 singletonHeader

206− (case ori of

207− Forward -> "Removed paths"

208− Backward -> "Added paths")

219+ ( case ori of

220+ Forward -> "Removed paths"

221+ Backward -> "Added paths"

222+ )

209223 $ singletonBody $

210224 bulletList $

211225 ps <&> \case

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

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

250264 unwrapReportJetResult (Free f) = f

251265

252− jsonPathJet

253− :: NonEmpty

254− ( Union

255− '[ Behave 'SchemaLevel 'TypedSchemaLevel

256− , Behave 'TypedSchemaLevel 'SchemaLevel

257− ]

258− )

259− -> Inlines

266+ jsonPathJet ::

267+ NonEmpty

268+ ( Union

269+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

270+ , Behave 'TypedSchemaLevel 'SchemaLevel

271+ ]

272+ ) ->

273+ Inlines

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

261275 where

262− showParts

263− :: [ Union

264− '[ Behave 'SchemaLevel 'TypedSchemaLevel

265− , Behave 'TypedSchemaLevel 'SchemaLevel

266− ]

267− ]

268− -> Text

276+ showParts ::

277+ [ Union

278+ '[ Behave 'SchemaLevel 'TypedSchemaLevel

279+ , Behave 'TypedSchemaLevel 'SchemaLevel

280+ ]

281+ ] ->

282+ Text

269283 showParts [] = mempty

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

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

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

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

274288 showParts (y : ys) =

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

276− @@> (\case

277− InItems -> "[*]"

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

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

280− InAdditionalProperty -> ".*")

281− @@> typesExhausted)

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

282298 y

283299 <> showParts ys

284300

285−observeJetShowErrs

286− :: ReportJet' Behave (Maybe Inlines)

287− -> P.PathsPrefixTree Behave AnIssue a

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

301+observeJetShowErrs ::

302+ ReportJet' Behave (Maybe Inlines) ->

303+ P.PathsPrefixTree Behave AnIssue a ->

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

289305observeJetShowErrs jet p = case observeJetShowErrs' jet p of

290306 Just m -> m

291307 Nothing -> (mempty, p)

292308

293−observeJetShowErrs'

294− :: forall a.

295− ReportJet' Behave (Maybe Inlines)

296− -> P.PathsPrefixTree Behave AnIssue a

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

309+observeJetShowErrs' ::

310+ forall a.

311+ ReportJet' Behave (Maybe Inlines) ->

312+ P.PathsPrefixTree Behave AnIssue a ->

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

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

299315 let results =

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

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

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

303319 jet @_ @_ @[] bhv

304320 & mapMaybe

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)

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

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

313330 if any isRight results

314331 then

315332 Just $

316333 foldMap

317− (\case

318− Left e -> (mempty, e)

319− Right m -> m)

334+ ( \case

335+ Left e -> (mempty, e)

336+ Right m -> m

337+ )

320338 results

321339 else Nothing

322340

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

339357 body rprt

340358 <> foldOMapWithKey

341359 (headers rprt)

342− (\k v ->

343− header level k <> subBuilder v)

360+ ( \k v ->

361+ header level k <> subBuilder v

362+ )

344363 where

345364 subBuilder = headerStyleBuilder (level + 1)

346365

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

349368 body rprt

350369 <> foldOMapWithKey

351370 (headers rprt)

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>")

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

362382 where

363383 subBuilder = foldingStyleBuilder

364384

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

1110import Data.OpenApi.Compare.Paths

1211import Data.OpenApi.Compare.Report

1312import Data.OpenApi.Compare.Subtree

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

14+import Text.Pandoc.Builder

1515

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

1717runChecker (client, server) =

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

@@ -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,25 +266,26 @@ 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)

280+ ( \eKey ->

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

282+ )

282283 else structuralIssue

283284{-# INLINE iohmStructuralWith #-}

284285

285−runCompatFormula

286− :: CompatFormula' q f r a

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

286+runCompatFormula ::

287+ CompatFormula' q f r a ->

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

288289runCompatFormula (Compose f) =

289290 calculate . runIdentity . runMemo 0 . unCompatM $ f

290291{-# INLINE runCompatFormula #-}

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

314315structuralIssue :: StructuralCompatFormula a

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

316317

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

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

323324anyOfAt _ _ [x] = x

324325anyOfAt xs issue fs =

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

326327

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

328−clarifyIssue

329− :: AnItem q AnIssue r

330− -> CompatFormula' q AnIssue r a

331− -> CompatFormula' q AnIssue r a

329+clarifyIssue ::

330+ AnItem q AnIssue r ->

331+ CompatFormula' q AnIssue r a ->

332+ CompatFormula' q AnIssue r a

332333clarifyIssue item f =

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

334335

335−fixpointKnot

336− :: MonadState (MemoState VarRef) m

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

336+fixpointKnot ::

337+ MonadState (MemoState VarRef) m =>

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

338339fixpointKnot =

339340 KnotTier

340341 { onKnotFound = modifyMemoNonce succ

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

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

343344 }

344345

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

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

351352memo bhv k f pc = Compose $ do

352353 formula' <-

353354 memoWithKnot

354355 fixpointKnot

355− (do

356− formula <- getCompose $ f pc

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

356+ ( do

357+ formula <- getCompose $ f pc

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

359+ )

358360 (k, ask <$> pc)

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

360362

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+13−12

@@ -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,16 +79,17 @@ 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)

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

9293 (tracedPaths <$> prodCons)

9394

9495instance Steppable OpenApi ProcessedPathItems where

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

@@ -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,10 +87,11 @@ tracedCallbacks (Traced t oper) =

8787 ]

8888

8989-- FIXME: #28

90−getServers

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

92− -> MatchedOperation

93− -> [Server]

90+getServers ::

91+ -- | Servers from env

92+ [Server] ->

93+ MatchedOperation ->

94+ [Server]

9495getServers env oper =

9596 case _operationServers . operation $ oper of

9697 [] -> env

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

337338 deriving stock (Eq, Ord, Show)

338339 issueKind = \case

339340 _ -> CertainIssue

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

341− NoPathsMatched fp -> Just fp

342− AllPathsFailed fp -> Just fp

341+ relatedIssues =

342+ (==) `withClass` \case

343+ NoPathsMatched fp -> Just fp

344+ AllPathsFailed fp -> Just fp

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

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

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

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

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

435437 ]

436438

437−tracedMethod

438− :: OperationMethod

439− -> Traced MatchedPathItem

440− -> Maybe (Traced' MatchedOperation Operation)

439+tracedMethod ::

440+ OperationMethod ->

441+ Traced MatchedPathItem ->

442+ Maybe (Traced' MatchedOperation Operation)

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

442444

443445instance Issuable 'PathLevel where

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

485487 checkSemanticCompatibility env beh prodCons = do

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

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

488− getPathParams

489− :: Traced (Definitions Param)

490− -> Traced MatchedPathItem

491− -> [Traced Param]

490+ getPathParams ::

491+ Traced (Definitions Param) ->

492+ Traced MatchedPathItem ->

493+ [Traced Param]

492494 getPathParams defs mpi = do

493495 paramRef <- tracedMatchedPathItemParameters mpi

494496 pure $ dereference defs paramRef

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

@@ -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,15 +106,17 @@ 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))

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

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

111+ )

111112 $ issueAt beh ParamRequired

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

113114 (ParamQuery, ParamQuery) -> do

114115 -- Emptiness is only for query params

115116 when

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

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

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

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

119+ )

118120 $ issueAt beh ParamEmptinessIncompatible

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

120122 _ -> 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+27−28

@@ -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 -}

14−

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

1514module Data.OpenApi.Compare.Validate.Products

16− ( checkProducts

17− , ProductLike(..)

18− ) where

15+ ( checkProducts,

16+ ProductLike (..),

17+ )

18+where

1919

2020import Data.Foldable

2121import Data.Map.Strict (Map)

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

3030 , required :: Bool

3131 }

3232

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

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

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

48− elts = ProdCons prodElt consElt

47+ let elts = ProdCons prodElt consElt

4948 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+76−97

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

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

2+

23module Data.OpenApi.Compare.Validate.Schema

34 (

45 )

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

1011import Data.Foldable (for_, toList)

1112import Data.Functor

1213import Data.HList

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

1315import qualified Data.List.NonEmpty as NE

1416import qualified Data.Map as M

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

1617import Data.Maybe

1718import Data.OpenApi

1819import Data.OpenApi.Compare.Behavior

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

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

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

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

25−import Data.OpenApi.Compare.Validate.Schema.Traced

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

2726import Data.OpenApi.Compare.Validate.Schema.Partition

2827import Data.OpenApi.Compare.Validate.Schema.Process

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

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

2930import Data.Ord

3031import Data.Ratio

3132import Data.Semigroup

3233import qualified Data.Set as S

3334import Data.Text (Text)

3435

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

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

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

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

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

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

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

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

146147

147−checkContradiction

148− :: Behavior 'TypedSchemaLevel

149− -> Maybe Partition

150− -> S.Set (Condition t)

151− -> SemanticCompatFormula ()

148+checkContradiction ::

149+ Behavior 'TypedSchemaLevel ->

150+ Maybe Partition ->

151+ S.Set (Condition t) ->

152+ SemanticCompatFormula ()

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

153154

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

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

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

163164 Just e

164165 | all (satisfiesTyped e) prods ->

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

166167 then pure ()

167168 else issueAt beh (EnumDoesntSatisfy $ untypeValue e)

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

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

175174 Maximum m' -> Just m'

176175 _ -> Nothing

177−

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

179177 Minimum m' -> Just m'

180178 _ -> Nothing

181−

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

183180 MultipleOf m' -> Just m'

184181 _ -> Nothing

185−

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

187− NumberFormat f' -> f == f'

188− _ -> False

189− of

183+ NumberFormat f' -> f == f'

184+ _ -> False of

190185 True -> pure ()

191186 False -> issueAt beh (NoMatchingFormat f)

192−

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

194188 MaxLength m' -> Just m'

195189 _ -> Nothing

196−

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

198191 MinLength m' -> Just m'

199192 _ -> Nothing

200−

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

202− Pattern p' -> p == p'

203− _ -> False

204− of

194+ Pattern p' -> p == p'

195+ _ -> False of

205196 True -> pure ()

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

207−

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

209− StringFormat f' -> f == f'

210− _ -> False

211− of

199+ StringFormat f' -> f == f'

200+ _ -> False of

212201 True -> pure ()

213202 False -> issueAt beh (NoMatchingFormat f)

214−

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

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

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

218− _ -> Nothing

219− of

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

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

206+ _ -> Nothing of

220207 Just (mItems, Just pfs)

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

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'

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'

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

229217 let prod' = tracedConjunct prods'

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

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

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

233−

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

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

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

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

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

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})

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})

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

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

258245 -- ...and no "items" schema

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

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

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

262− _ -> issueAt beh NoMatchingTupleItems

263−

249+ _ -> issueAt beh NoMatchingTupleItems

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

265251 MaxItems m' -> Just m'

266252 TupleItems fs -> Just $ toInteger $ length fs

267253 _ -> Nothing

268−

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

270255 MinItems m' -> Just m'

271256 TupleItems fs -> Just $ toInteger $ length fs

272257 _ -> Nothing

273−

274258 UniqueItems -> case flip any prods $ \case

275− UniqueItems -> True

276− MaxItems 1 -> True

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

278− _ -> False

279− of

259+ UniqueItems -> True

260+ MaxItems 1 -> True

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

262+ _ -> False of

280263 True -> pure ()

281264 False -> issueAt beh NoMatchingUniqueItems

282−

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

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

285− _ -> Nothing

286− of

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

267+ _ -> Nothing of

287268 Just pm ->

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

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

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

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

315296 pure ()

316297 Nothing -> issueAt beh NoMatchingProperties

317−

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

319299 MaxProperties m' -> Just m'

320300 _ -> Nothing

321−

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

323302 MinProperties m' -> Just m'

324303 _ -> Nothing

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

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

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

328307

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

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

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

338317 Just m'

339318 | 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+53−51

@@ -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,53 +100,54 @@ instance Issuable 'TypedSchemaLevel where

100100 TypeBecomesEmpty -> ProbablyIssue -- TODO: #70

101101 PartitionBecomesEmpty _ -> ProbablyIssue -- ditto

102102 _ -> CertainIssue

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

103+ relatedIssues =

104+ (==) `withClass` \case

104105 EnumDoesntSatisfy v -> Just v

105106 NoMatchingEnum v -> Just v

106107 _ -> 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

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

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

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

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

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

254255 PropertyToAdditional -> Comment

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

256257 _ -> CertainIssue

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

258+ relatedIssues =

259+ (==) `withClass` \case

258260 AdditionalToProperty -> Just ()

259261 PropertyToAdditional -> Just ()

260262 _ -> Nothing

261− `withClass` \case

262− PropertyNowRequired -> Just ()

263− UnexpectedProperty -> Just ()

264− _ -> Nothing

263+ `withClass` \case

264+ PropertyNowRequired -> Just ()

265+ UnexpectedProperty -> Just ()

266+ _ -> Nothing

265267 describeIssue _ (NotSupported i) =

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

267269 describeIssue _ OneOfNotDisjoint =

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

@@ -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 qualified Data.HashMap.Strict as HM

2423import Data.Functor

24+import qualified Data.HashMap.Strict as HM

2525import Data.Int

2626import Data.Kind

2727import qualified Data.Map as M

@@ -67,30 +67,33 @@ 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− -> Condition 'Number -- ^ this has the right Ord

70+ Minimum ::

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

72+ -- | this has the right Ord

73+ Condition 'Number

7374 MultipleOf :: !Scientific -> Condition 'Number

7475 NumberFormat :: !Format -> Condition 'Number

7576 MaxLength :: !Integer -> Condition 'String

7677 MinLength :: !Integer -> Condition 'String

7778 Pattern :: !Pattern -> Condition 'String

7879 StringFormat :: !Format -> Condition 'String

79− Items

80− :: !(ForeachType JsonFormula)

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

82− -> Condition 'Array

83− TupleItems

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

85− -> Condition 'Array

80+ Items ::

81+ !(ForeachType JsonFormula) ->

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

83+ Condition 'Array

84+ TupleItems ::

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

86+ Condition 'Array

8687 MaxItems :: !Integer -> Condition 'Array

8788 MinItems :: !Integer -> Condition 'Array

8889 UniqueItems :: Condition 'Array

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

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

9497 MaxProperties :: !Integer -> Condition 'Object

9598 MinProperties :: !Integer -> Condition 'Object

9699

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

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

119122 (Properties props additional _) ->

120123 bulletList $

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

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

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

127− <> showForEachJsonFormula additional

132+ <> showForEachJsonFormula additional

128133 ]

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

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

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

133138 showForEachJsonFormula i =

134139 bulletList $

135140 foldType

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

137− BottomDNF -> mempty

138− (DNF conds) ->

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

142+ BottomDNF -> mempty

143+ (DNF conds) ->

139144 [ para (describeJSONType t)

140145 <> bulletList

141− (S.toList conds <&> \case

142− Disjunct (S.toList -> []) -> para "Empty"

143− Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond))

144− ])

146+ ( S.toList conds <&> \case

147+ Disjunct (S.toList -> []) -> para "Empty"

148+ Disjunct (S.toList -> cond) -> bulletList (showCondition <$> cond)

149+ )

150+ ]

151+ )

145152

146153showJSONValue :: A.Value -> Blocks

147154showJSONValue v = codeBlockWith ("", ["json"], mempty) (T.decodeUtf8 . BSL.toStrict . A.encode $ v)

src/Data/OpenApi/Compare/Validate/Schema/Partition.hs+30−29

@@ -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,10 +143,11 @@ partitionCondition = \case

143143 Just _ -> top

144144 Nothing ->

145145 singletonPart $

146− DByProperties $ LiteralDNF

147− ( M.keysSet $ M.filter (not . propRequired) props

148− , M.keysSet $ M.filter propRequired props

149− )

146+ DByProperties $

147+ LiteralDNF

148+ ( M.keysSet $ M.filter (not . propRequired) props

149+ , M.keysSet $ M.filter propRequired props

150+ )

150151 inProps <- forM (M.toList $ M.filter propRequired props) $ \(k, prop) -> do

151152 f <- partitionRefSchema $ propRefSchema prop

152153 pure $ fmap (\(Partitions m) -> Partitions $ M.mapKeysMonotonic (PInProperty k) m) f

@@ -156,10 +157,10 @@ partitionCondition = \case

156157runPartitionM :: Traced (Definitions Schema) -> PartitionM a -> a

157158runPartitionM defs = runIdentity . runMemo () . (`runReaderT` defs)

158159

159−partitionJsonFormulas

160− :: ProdCons (Traced (Definitions Schema))

161− -> ProdCons (JsonFormula t)

162− -> Lifted Partitions

160+partitionJsonFormulas ::

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

162+ ProdCons (JsonFormula t) ->

163+ Lifted Partitions

163164partitionJsonFormulas defs pc = producer pcPart \/ consumer pcPart

164165 where

165166 pcPart = partitionFormula <$> defs <*> pc

@@ -211,11 +212,11 @@ runIntersectionM defs act = case runWriterT $ runReaderT act defs of

211212 Just (x, Any False) -> Same x

212213 Just (x, Any True) -> New x

213214

214−intersectSchema

215− :: PartitionLocation

216− -> PartitionChoice

217− -> Traced Schema

218− -> IntersectionM Schema

215+intersectSchema ::

216+ PartitionLocation ->

217+ PartitionChoice ->

218+ Traced Schema ->

219+ IntersectionM Schema

219220intersectSchema loc part sch = do

220221 allOf' <- forM (tracedAllOf sch) $ \rss ->

221222 -- Assuming i ranges over a nonempty set (checked in processSchema)

@@ -258,11 +259,11 @@ intersectSchema loc part sch = do

258259 pure $ sch' {_schemaEnum = Just enum'}

259260 CByProperties {} -> error "CByProperties not implemented"

260261

261−intersectRefSchema

262− :: PartitionLocation

263− -> PartitionChoice

264− -> Traced (Referenced Schema)

265− -> IntersectionM (Referenced Schema)

262+intersectRefSchema ::

263+ PartitionLocation ->

264+ PartitionChoice ->

265+ Traced (Referenced Schema) ->

266+ IntersectionM (Referenced Schema)

266267intersectRefSchema loc part rs = do

267268 defs <- R.ask

268269 Inline <$> intersectSchema loc part (dereference defs rs)

src/Data/OpenApi/Compare/Validate/Schema/Process.hs+35−34

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

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

2− ( schemaToFormula

2+ ( schemaToFormula,

33 )

44where

55

66import Algebra.Lattice

7−import qualified Control.Monad.Reader as R

87import Control.Monad.Reader hiding (ask)

8+import qualified Control.Monad.Reader as R

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,26 +331,27 @@ 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− ])

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

354355

355356{- TODO: ReadOnly/WriteOnly #68 -}

356357

@@ -369,8 +370,8 @@ checkOneOfDisjoint schs = do

369370runProcessM :: Traced (Definitions Schema) -> ProcessM a -> (a, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

370371runProcessM defs = runWriter . (`runReaderT` defs) . runMemo ()

371372

372−schemaToFormula

373− :: Traced (Definitions Schema)

374− -> Traced Schema

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

373+schemaToFormula ::

374+ Traced (Definitions Schema) ->

375+ Traced Schema ->

376+ (ForeachType JsonFormula, P.PathsPrefixTree Behave AnIssue 'SchemaLevel)

376377schemaToFormula 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+25−23

@@ -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,24 +88,26 @@ 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 = ForeachType

92− { forNull = k

93− , forBoolean = k

94− , forNumber = k

95− , forString = k

96− , forArray = k

97− , forObject = k

98− }

91+broadcastType k =

92+ ForeachType

93+ { forNull = k

94+ , forBoolean = k

95+ , forNumber = k

96+ , forString = k

97+ , forArray = k

98+ , forObject = k

99+ }

99100

100101zipType :: (forall x. Typeable x => f x -> g x -> h x) -> ForeachType f -> ForeachType g -> ForeachType h

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

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+ }

109111

110112instance (forall x. Lattice (f x)) => Lattice (ForeachType f) where

111113 (\/) = zipType (\/)

src/Data/OpenApi/Compare/Validate/SecurityRequirement.hs+9−8

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

22{-# OPTIONS_GHC -Wno-orphans #-}

33

44module Data.OpenApi.Compare.Validate.SecurityRequirement

5− ( Issue (..)

5+ ( Issue (..),

66 )

77where

88

@@ -41,18 +41,19 @@ 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 ())

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

4950 normalized

5051 pure ()

5152 checkSemanticCompatibility env bhv' pc = do

5253 let schemes = getH @(ProdCons (Traced (Definitions SecurityScheme))) env

5354 ( ProdCons pErrs cErrs

54− , (ProdCons pSchemes cSchemes)

55− :: ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

55+ , (ProdCons pSchemes cSchemes) ::

56+ ProdCons [(Behavior 'SecuritySchemeLevel, Traced SecurityScheme, [Text])]

5657 ) =

5758 NE.unzip $

5859 partitionEithers <$> do

src/Data/OpenApi/Compare/Validate/Server.hs+10−9

@@ -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,11 +63,12 @@ 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))

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

7172 . sequence

7273 sequenceA_ pErrs

7374 sequenceA_ cErrs

src/Data/OpenApi/Compare/Validate/Sums.hs+12−11

@@ -1,24 +1,25 @@

11module Data.OpenApi.Compare.Validate.Sums

2− ( checkSums

3− ) where

2+ ( checkSums,

3+ )

4+where

45

56import Data.Foldable

67import Data.Map.Strict (Map)

78import qualified Data.Map.Strict as M

89import Data.OpenApi.Compare.Behavior

9−import Data.OpenApi.Compare.Subtree

1010import Data.OpenApi.Compare.Paths

11+import Data.OpenApi.Compare.Subtree

1112

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

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

1920checkSums xs noElt check (ProdCons p c) = for_ (M.toList p) $ \(key, prodElt) ->

2021 case M.lookup key c of

2122 Nothing -> issueAt xs $ noElt key

2223 Just consElt ->

2324 let sumElts = ProdCons prodElt consElt

24− in check key sumElts

25+ in check key sumElts

src/Data/OpenUnion/Extra.hs+5−5

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

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+46−42

@@ -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,32 +39,34 @@ 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− -> FilePath -- ^ Root path

56− -> FilePath -- ^ Name of golden file

57− -> s

58− -> (t -> IO BSL.ByteString)

59− -> IO TestTree

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

6062goldenInputsTree name filepath golden inp f = do

6163 runTestInputTree golden f <$> getGoldenInputs name filepath inp

6264

63−runTestInputTree

64− :: FilePath

65− -> (t -> IO BSL.ByteString)

66− -> TestInput t

67− -> TestTree

65+runTestInputTree ::

66+ FilePath ->

67+ (t -> IO BSL.ByteString) ->

68+ TestInput t ->

69+ TestTree

6870runTestInputTree golden f (TestInputNode name rest) =

6971 testGroup name (runTestInputTree golden f <$> rest)

7072runTestInputTree golden f (TestInputLeaf name t path) =

@@ -74,16 +76,18 @@ runTestInputTree golden f (TestInputLeaf name t path) =

7476 (path </> golden)

7577 (f t)

7678

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

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

8892goldenInputsTreeUniform name filepath golden inp h =

8993 goldenInputsTree name filepath golden (inp & each %~ (,h))

test/Spec/Golden/TraceTree.hs+4−2

@@ -12,6 +12,7 @@ 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

1516import Spec.Golden.Extra

1617import Test.Tasty (TestTree, testGroup)

1718import Text.Pandoc.Builder

@@ -22,10 +23,11 @@ import Prelude hiding (id, (.))

2223

2324tests :: IO TestTree

2425tests = do

26+ dir <- getDataDir

2527 traceTreeTests <-

2628 goldenInputsTreeUniform

2729 "TraceTree"

28− "test/golden/common"

30+ dir

2931 "trace-tree.yaml"

3032 ("a.yaml", "b.yaml")

3133 Yaml.decodeFileThrow

@@ -34,7 +36,7 @@ tests = do

3436 reportTests <-

3537 goldenInputsTreeUniform

3638 "Report"

37− "test/golden/common"

39+ dir

3840 "report.md"

3941 ("a.yaml", "b.yaml")

4042 Yaml.decodeFileThrow