@@ -9,17 +9,16 @@ module OpenAPI.Checker.Report
11import Control.Monad.Free hiding (unfoldM)
11import Control.Monad.Free hiding (unfoldM)
12−import Control.Monad.Reader
13−import Control.Monad.Writer
14import Data.Aeson (ToJSON)
12import Data.Aeson (ToJSON)
15import Data.Default
13import Data.Default
16import Data.Either
14import Data.Either
18import Data.Function
15import Data.Function
19import Data.Functor
16import Data.Functor
20import Data.List.NonEmpty
17import Data.List.NonEmpty
21import qualified Data.List.NonEmpty as NE
18import qualified Data.List.NonEmpty as NE
22import qualified Data.Map as M
19import qualified Data.Map as M
20+import Data.Map.Ordered (OMap)
21+import qualified Data.Map.Ordered as OM
23import Data.Maybe
22import Data.Maybe
24import Data.OpenUnion
23import Data.OpenUnion
25import Data.OpenUnion.Extra
24import Data.OpenUnion.Extra
@@ -78,26 +77,29 @@ generateReport cfg inp =
78 breakingChangesPresent = not $ P.null breaking
77 breakingChangesPresent = not $ P.null breaking
79 nonBreakingChangesPresent = not $ P.null nonBreaking
78 nonBreakingChangesPresent = not $ P.null nonBreaking
80 unsupportedChangesPresent = not $ P.null unsupported
79 unsupportedChangesPresent = not $ P.null unsupported
80+ builder = buildReport cfg
81− report = doc $
81+ report =
82− runReportMonad cfg jets $ do
82+ doc $
83− tell $ header 1 "Summary"
83+ header 1 "Summary"
85− simpleTable
84+ <> simpleTable
87 <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
86 <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
88 , refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
87 , refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
89 , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
88 , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
91 [para . show' <$> [P.size breaking, P.size nonBreaking, P.size unsupported]]
90 [para . show' <$> [P.size breaking, P.size nonBreaking, P.size unsupported]]
92− when breakingChangesPresent $ do
92+ breakingChangesPresent
93− tell $ header 1 $ anchor breakingChangesId <> "⚠️ Breaking changes"
93+ (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
94− incrementHeaders $ showErrs breaking
94+ <> builder (showErrs breaking))
95− when nonBreakingChangesPresent $ do
96+ nonBreakingChangesPresent
96− tell $ header 1 $ anchor nonBreakingChangesId <> "🙆 Non-breaking changes"
97+ (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
97− incrementHeaders $ showErrs nonBreaking
98+ <> builder (showErrs nonBreaking))
98− when unsupportedChangesPresent $ do
100+ unsupportedChangesPresent
99− tell $ header 1 $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
101+ (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
100− incrementHeaders $ showErrs unsupported
102+ <> builder (showErrs unsupported))
103 | breakingChangesPresent -> BreakingChanges
105 | breakingChangesPresent -> BreakingChanges
@@ -117,51 +119,12 @@ generateReport cfg inp =
117 unsupportedChangesId = "unsupported-changes"
119 unsupportedChangesId = "unsupported-changes"
118 nonBreakingChangesId = "non-breaking-changes"
120 nonBreakingChangesId = "non-breaking-changes"
120−data ReportState = ReportState
122+ when' :: Monoid m => Bool -> m -> m
121− { sourceJets :: [ReportJet' Behave Inlines]
123+ when' True m = m
122− , headerLevel :: Int
124+ when' False _ = mempty
123− , headerHandle :: Inlines -> ReportMonad () -> ReportMonad ()
124− , incrementHeadersHandle :: ReportState -> ReportState
127−type ReportMonad = ReaderT ReportState (Writer Blocks)
129−runReportMonad :: ReportConfig -> [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
130−runReportMonad cfg jts =
138− case treeStyle cfg of
139− HeadersTreeStyle -> \i body -> do
140− h <- asks headerLevel
143− FoldingBlockquotesTreeStyle -> \i body -> do
146− <> rawHtml "<summary>"
148− <> rawHtml "</summary>"
149− (mapReaderT . mapWriterT . fmap . fmap) blockQuote $ body
150− tell $ rawHtml "</details>"
152− rawHtml = rawBlock "html"
153− , incrementHeadersHandle = case treeStyle cfg of
154− HeadersTreeStyle -> \l -> l {headerLevel = headerLevel l + 1}
155− FoldingBlockquotesTreeStyle -> id
158−smartHeader :: Inlines -> ReportMonad () -> ReportMonad ()
159−smartHeader i body = do
160− f <- asks headerHandle
163−showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
126+showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> Report
164−showErrs x@(P.PathsPrefixNode currentIssues _) = do
127+showErrs x@(P.PathsPrefixNode currentIssues _) =
165 let -- Extract this pattern if more cases like this arise
128 let -- Extract this pattern if more cases like this arise
166 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
129 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
167 , otherIssues :: Set (AnIssue a)
130 , otherIssues :: Set (AnIssue a)
@@ -176,39 +139,38 @@ showErrs x@(P.PathsPrefixNode currentIssues _) = do
176 let p' = p <&> (\(AnIssue _ i) -> i)
139 let p' = p <&> (\(AnIssue _ i) -> i)
177 in (Just (ori, p'), o)
140 in (Just (ori, p'), o)
178 _ -> (Nothing, currentIssues)
141 _ -> (Nothing, currentIssues)
179− jts <- asks sourceJets
180− tell $ case S.toList otherIssues of
142+ issues = singletonBody $ case S.toList otherIssues of
181− [AnIssue ori i] -> describeIssue ori i
143+ [AnIssue ori i] -> describeIssue ori i
182− ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
144+ ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
183− case removedPaths of
145+ paths = case removedPaths of
184− Just (ori, paths) -> do
146+ Just (ori, ps) -> do
185− smartHeader
147+ singletonHeader
186− (case ori of
148+ (case ori of
187− Forward -> "Removed paths"
149+ Forward -> "Removed paths"
188− Backward -> "Added paths")
150+ Backward -> "Added paths")
189− $ tell $
151+ $ singletonBody $
190− bulletList $
152+ bulletList $
191− paths <&> \case
153+ ps <&> \case
192− (NoPathsMatched p) -> para . code $ T.pack p
154+ (NoPathsMatched p) -> para . code $ T.pack p
193− (AllPathsFailed p) -> para . code $ T.pack p
155+ (AllPathsFailed p) -> para . code $ T.pack p
194− Nothing -> pure ()
156+ Nothing -> mempty
195− unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
157+ rest = unfoldFunctions x (observeJetShowErrs <$> jets) $ \(P.PathsPrefixNode _ subIssues) -> do
196− for_ subIssues $ \(WrapTypeable (AStep m)) ->
158+ flip foldMap subIssues $ \(WrapTypeable (AStep m)) ->
197− for_ (M.toList m) $ \(bhv, subErrors) -> do
159+ flip foldMap (M.toList m) $ \(bhv, subErrors) ->
198− unless (P.null subErrors) $
160+ if P.null subErrors
199− smartHeader (describeBehaviour bhv) $
162+ else singletonHeader (describeBehaviour bhv) $ showErrs subErrors
200− incrementHeaders $ showErrs subErrors
163+ in issues <> paths <> rest
202−unfoldM :: Monad m => a -> [a -> m a] -> (a -> m ()) -> m ()
204−unfoldM a (f : ff) g = do
208−incrementHeaders :: ReportMonad x -> ReportMonad x
165+unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
209−incrementHeaders m = do
166+unfoldFunctions initA fs g = unfoldFunctions' initA fs
210− f <- asks incrementHeadersHandle
167+ where
211− local f m
168+ unfoldFunctions' :: a -> [a -> (m, a)] -> m
169+ unfoldFunctions' a [] | a == initA = g a
170+ unfoldFunctions' a [] = unfoldFunctions a fs g
171+ unfoldFunctions' a (f : ff) =
173+ in unfoldFunctions' a' ff <> m
213jets :: [ReportJet' Behave Inlines]
175jets :: [ReportJet' Behave Inlines]
@@ -216,9 +178,9 @@ jets =
216 <$> [ constructReportJet jsonPathJet
178 <$> [ constructReportJet jsonPathJet
217 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
179 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
218 strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
180 strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
219− , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
220 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
181 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
221 "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
182 "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
183+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
224 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
186 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
@@ -259,16 +221,16 @@ jets =
259observeJetShowErrs
221observeJetShowErrs
260 :: ReportJet' Behave Inlines
222 :: ReportJet' Behave Inlines
261 -> P.PathsPrefixTree Behave AnIssue a
223 -> P.PathsPrefixTree Behave AnIssue a
262− -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
224+ -> (Report, P.PathsPrefixTree Behave AnIssue a)
263observeJetShowErrs jet p = case observeJetShowErrs' jet p of
225observeJetShowErrs jet p = case observeJetShowErrs' jet p of
264 Just m -> m
226 Just m -> m
265− Nothing -> pure p
227+ Nothing -> (mempty, p)
267observeJetShowErrs'
229observeJetShowErrs'
268 :: forall a.
230 :: forall a.
269 ReportJet' Behave Inlines
231 ReportJet' Behave Inlines
270 -> P.PathsPrefixTree Behave AnIssue a
232 -> P.PathsPrefixTree Behave AnIssue a
271− -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
233+ -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
272observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
234observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
273 let results =
235 let results =
274 subIssues >>= \(WrapTypeable (AStep m)) ->
236 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -278,23 +240,75 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
278 & mapMaybe
240 & mapMaybe
280 Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
242 Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
281− Pure h -> Just $ do
243+ Pure h ->
282− unless (P.null subErrs) $ do
244+ if P.null subErrs
283− smartHeader h $ incrementHeaders $ showErrs subErrs
245+ then Just mempty
284− return mempty)
246+ else Just (singletonHeader h (showErrs subErrs), mempty))
285 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
247 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
286 if any isRight results
248 if any isRight results
291− Left e -> pure e
253+ Left e -> (mempty, e)
292 Right m -> m)
254 Right m -> m)
294 else Nothing
256 else Nothing
296−catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
258+data Report = Report {headers :: OMap Inlines Report, body :: Blocks}
297−catMapM f xs = mconcat <$> mapM f xs
259+ deriving stock (Generic)
261+instance Semigroup Report where
262+ (Report headers1 b1) <> (Report headers2 b2) = Report (OM.unionWithL (const (<>)) headers1 headers2) (b1 <> b2)
264+instance Monoid Report where
265+ mempty = Report OM.empty mempty
267+buildReport :: ReportConfig -> Report -> Blocks
268+buildReport cfg = case treeStyle cfg of
269+ HeadersTreeStyle -> headerStyleBuilder 2
270+ FoldingBlockquotesTreeStyle -> foldingStyleBuilder
272+ headerStyleBuilder :: HeaderLevel -> Report -> Blocks
273+ headerStyleBuilder level rprt =
278+ header level k <> subBuilder v)
280+ subBuilder = headerStyleBuilder (level + 1)
282+ foldingStyleBuilder :: Report -> Blocks
283+ foldingStyleBuilder rprt =
288+ if (OM.size . headers $ rprt) < 2
289+ then para k <> blockQuote (subBuilder v)
292+ <> rawHtml "<summary>"
294+ <> rawHtml "</summary>"
295+ <> blockQuote (subBuilder v)
296+ <> rawHtml "</details>")
298+ subBuilder = foldingStyleBuilder
300+ rawHtml = rawBlock "html"
302+type HeaderLevel = Int
304+singletonHeader :: Inlines -> Report -> Report
305+singletonHeader i b = Report (OM.singleton (i, b)) mempty
307+singletonBody :: Blocks -> Report
308+singletonBody = Report OM.empty
299show' :: Show x => x -> Inlines
310show' :: Show x => x -> Inlines
300show' = str . T.pack . show
311show' = str . T.pack . show
313+foldOMapWithKey :: Monoid m => OMap k v -> (k -> v -> m) -> m
314+foldOMapWithKey m f = foldMap (uncurry f) $ OM.assocs m