@@ -9,17 +9,16 @@ module OpenAPI.Checker.Report
99where
1010
1111import Control.Monad.Free hiding (unfoldM)
12−import Control.Monad.Reader
13−import Control.Monad.Writer
1412import Data.Aeson (ToJSON)
1513import Data.Default
1614import Data.Either
17−import Data.Foldable
1815import Data.Function
1916import Data.Functor
2017import Data.List.NonEmpty
2118import qualified Data.List.NonEmpty as NE
2219import qualified Data.Map as M
20+import Data.Map.Ordered (OMap)
21+import qualified Data.Map.Ordered as OM
2322import Data.Maybe
2423import Data.OpenUnion
2524import Data.OpenUnion.Extra
@@ -78,26 +77,29 @@ generateReport cfg inp =
7877 breakingChangesPresent = not $ P.null breaking
7978 nonBreakingChangesPresent = not $ P.null nonBreaking
8079 unsupportedChangesPresent = not $ P.null unsupported
81− report = doc $
82− runReportMonad cfg jets $ do
83− tell $ header 1 "Summary"
84− tell $
85− simpleTable
80+ builder = buildReport cfg
81+ report =
82+ doc $
83+ header 1 "Summary"
84+ <> simpleTable
8685 (para
8786 <$> [ refOpt breakingChangesPresent breakingChangesId "⚠️ Breaking changes"
8887 , refOpt nonBreakingChangesPresent nonBreakingChangesId "🙆 Non-breaking changes"
8988 , refOpt unsupportedChangesPresent unsupportedChangesId "🤷 Unsupported feature changes"
9089 ])
9190 [para . show' <$> [P.size breaking, P.size nonBreaking, P.size unsupported]]
92− when breakingChangesPresent $ do
93− tell $ header 1 $ anchor breakingChangesId <> "⚠️ Breaking changes"
94− incrementHeaders $ showErrs breaking
95− when nonBreakingChangesPresent $ do
96− tell $ header 1 $ anchor nonBreakingChangesId <> "🙆 Non-breaking changes"
97− incrementHeaders $ showErrs nonBreaking
98− when unsupportedChangesPresent $ do
99− tell $ header 1 $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
100− incrementHeaders $ showErrs unsupported
91+ <> when'
92+ breakingChangesPresent
93+ (header 1 (anchor breakingChangesId <> "⚠️ Breaking changes")
94+ <> builder (showErrs breaking))
95+ <> when'
96+ nonBreakingChangesPresent
97+ (header 1 (anchor nonBreakingChangesId <> "🙆 Non-breaking changes")
98+ <> builder (showErrs nonBreaking))
99+ <> when'
100+ unsupportedChangesPresent
101+ (header 1 (anchor unsupportedChangesId <> "🤷 Unsupported feature changes")
102+ <> builder (showErrs unsupported))
101103 status =
102104 if
103105 | breakingChangesPresent -> BreakingChanges
@@ -117,51 +119,12 @@ generateReport cfg inp =
117119 unsupportedChangesId = "unsupported-changes"
118120 nonBreakingChangesId = "non-breaking-changes"
119121
120−data ReportState = ReportState
121− { sourceJets :: [ReportJet' Behave Inlines]
122− , headerLevel :: Int
123− , headerHandle :: Inlines -> ReportMonad () -> ReportMonad ()
124− , incrementHeadersHandle :: ReportState -> ReportState
125− }
126−
127−type ReportMonad = ReaderT ReportState (Writer Blocks)
128−
129−runReportMonad :: ReportConfig -> [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
130−runReportMonad cfg jts =
131− execWriter
132− . flip
133− runReaderT
134− ReportState
135− { sourceJets = jts
136− , headerLevel = 1
137− , headerHandle =
138− case treeStyle cfg of
139− HeadersTreeStyle -> \i body -> do
140− h <- asks headerLevel
141− tell $ header h i
142− body
143− FoldingBlockquotesTreeStyle -> \i body -> do
144− tell $
145− rawHtml "<details>"
146− <> rawHtml "<summary>"
147− <> plain i
148− <> rawHtml "</summary>"
149− (mapReaderT . mapWriterT . fmap . fmap) blockQuote $ body
150− tell $ rawHtml "</details>"
151− where
152− rawHtml = rawBlock "html"
153− , incrementHeadersHandle = case treeStyle cfg of
154− HeadersTreeStyle -> \l -> l {headerLevel = headerLevel l + 1}
155− FoldingBlockquotesTreeStyle -> id
156− }
122+ when' :: Monoid m => Bool -> m -> m
123+ when' True m = m
124+ when' False _ = mempty
157125
158−smartHeader :: Inlines -> ReportMonad () -> ReportMonad ()
159−smartHeader i body = do
160− f <- asks headerHandle
161− f i body
162−
163−showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
164−showErrs x@(P.PathsPrefixNode currentIssues _) = do
126+showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> Report
127+showErrs x@(P.PathsPrefixNode currentIssues _) =
165128 let -- Extract this pattern if more cases like this arise
166129 ( removedPaths :: Maybe (Orientation, [Issue 'APILevel])
167130 , otherIssues :: Set (AnIssue a)
@@ -176,39 +139,38 @@ showErrs x@(P.PathsPrefixNode currentIssues _) = do
176139 let p' = p <&> (\(AnIssue _ i) -> i)
177140 in (Just (ori, p'), o)
178141 _ -> (Nothing, currentIssues)
179− jts <- asks sourceJets
180− tell $ case S.toList otherIssues of
181− [AnIssue ori i] -> describeIssue ori i
182− ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
183− case removedPaths of
184− Just (ori, paths) -> do
185− smartHeader
186− (case ori of
187− Forward -> "Removed paths"
188− Backward -> "Added paths")
189− $ tell $
190− bulletList $
191− paths <&> \case
192− (NoPathsMatched p) -> para . code $ T.pack p
193− (AllPathsFailed p) -> para . code $ T.pack p
194− Nothing -> pure ()
195− unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
196− for_ subIssues $ \(WrapTypeable (AStep m)) ->
197− for_ (M.toList m) $ \(bhv, subErrors) -> do
198− unless (P.null subErrors) $
199− smartHeader (describeBehaviour bhv) $
200− incrementHeaders $ showErrs subErrors
201−
202−unfoldM :: Monad m => a -> [a -> m a] -> (a -> m ()) -> m ()
203−unfoldM a [] g = g a
204−unfoldM a (f : ff) g = do
205− a' <- f a
206− unfoldM a' ff g
142+ issues = singletonBody $ case S.toList otherIssues of
143+ [AnIssue ori i] -> describeIssue ori i
144+ ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
145+ paths = case removedPaths of
146+ Just (ori, ps) -> do
147+ singletonHeader
148+ (case ori of
149+ Forward -> "Removed paths"
150+ Backward -> "Added paths")
151+ $ singletonBody $
152+ bulletList $
153+ ps <&> \case
154+ (NoPathsMatched p) -> para . code $ T.pack p
155+ (AllPathsFailed p) -> para . code $ T.pack p
156+ Nothing -> mempty
157+ rest = unfoldFunctions x (observeJetShowErrs <$> jets) $ \(P.PathsPrefixNode _ subIssues) -> do
158+ flip foldMap subIssues $ \(WrapTypeable (AStep m)) ->
159+ flip foldMap (M.toList m) $ \(bhv, subErrors) ->
160+ if P.null subErrors
161+ then mempty
162+ else singletonHeader (describeBehaviour bhv) $ showErrs subErrors
163+ in issues <> paths <> rest
207164
208−incrementHeaders :: ReportMonad x -> ReportMonad x
209−incrementHeaders m = do
210− f <- asks incrementHeadersHandle
211− local f m
165+unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
166+unfoldFunctions initA fs g = unfoldFunctions' initA fs
167+ where
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) =
172+ let (m, a') = f a
173+ in unfoldFunctions' a' ff <> m
212174
213175jets :: [ReportJet' Behave Inlines]
214176jets =
@@ -216,9 +178,9 @@ jets =
216178 <$> [ constructReportJet jsonPathJet
217179 , constructReportJet $ \p@(AtPath _) op@(InOperation _) ->
218180 strong (describeBehaviour op) <> " " <> describeBehaviour p :: Inlines
219− , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
220181 , constructReportJet $ \(WithStatusCode c) ResponsePayload PayloadSchema ->
221182 "📱⬅️ JSON Response – " <> str (T.pack . show $ c) :: Inlines
183+ , constructReportJet $ \InRequest InPayload PayloadSchema -> "📱➡️ JSON Request" :: Inlines
222184 ]
223185 where
224186 unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
@@ -259,16 +221,16 @@ jets =
259221observeJetShowErrs
260222 :: ReportJet' Behave Inlines
261223 -> P.PathsPrefixTree Behave AnIssue a
262− -> ReportMonad (P.PathsPrefixTree Behave AnIssue a)
224+ -> (Report, P.PathsPrefixTree Behave AnIssue a)
263225observeJetShowErrs jet p = case observeJetShowErrs' jet p of
264226 Just m -> m
265− Nothing -> pure p
227+ Nothing -> (mempty, p)
266228
267229observeJetShowErrs'
268230 :: forall a.
269231 ReportJet' Behave Inlines
270232 -> P.PathsPrefixTree Behave AnIssue a
271− -> Maybe (ReportMonad (P.PathsPrefixTree Behave AnIssue a))
233+ -> Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
272234observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues) =
273235 let results =
274236 subIssues >>= \(WrapTypeable (AStep m)) ->
@@ -278,23 +240,75 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
278240 & mapMaybe
279241 (\case
280242 Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
281− Pure h -> Just $ do
282− unless (P.null subErrs) $ do
283− smartHeader h $ incrementHeaders $ showErrs subErrs
284− return mempty)
243+ Pure h ->
244+ if P.null subErrs
245+ then Just mempty
246+ else Just (singletonHeader h (showErrs subErrs), mempty))
285247 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
286248 if any isRight results
287249 then
288250 Just $
289− catMapM
251+ foldMap
290252 (\case
291− Left e -> pure e
253+ Left e -> (mempty, e)
292254 Right m -> m)
293255 results
294256 else Nothing
295257
296−catMapM :: (Monad m, Monoid b) => (a -> m b) -> [a] -> m b
297−catMapM f xs = mconcat <$> mapM f xs
258+data Report = Report {headers :: OMap Inlines Report, body :: Blocks}
259+ deriving stock (Generic)
260+
261+instance Semigroup Report where
262+ (Report headers1 b1) <> (Report headers2 b2) = Report (OM.unionWithL (const (<>)) headers1 headers2) (b1 <> b2)
263+
264+instance Monoid Report where
265+ mempty = Report OM.empty mempty
266+
267+buildReport :: ReportConfig -> Report -> Blocks
268+buildReport cfg = case treeStyle cfg of
269+ HeadersTreeStyle -> headerStyleBuilder 2
270+ FoldingBlockquotesTreeStyle -> foldingStyleBuilder
271+ where
272+ headerStyleBuilder :: HeaderLevel -> Report -> Blocks
273+ headerStyleBuilder level rprt =
274+ body rprt
275+ <> foldOMapWithKey
276+ (headers rprt)
277+ (\k v ->
278+ header level k <> subBuilder v)
279+ where
280+ subBuilder = headerStyleBuilder (level + 1)
281+
282+ foldingStyleBuilder :: Report -> Blocks
283+ foldingStyleBuilder rprt =
284+ body rprt
285+ <> foldOMapWithKey
286+ (headers rprt)
287+ (\k v ->
288+ if (OM.size . headers $ rprt) < 2
289+ then para k <> blockQuote (subBuilder v)
290+ else
291+ rawHtml "<details>"
292+ <> rawHtml "<summary>"
293+ <> plain k
294+ <> rawHtml "</summary>"
295+ <> blockQuote (subBuilder v)
296+ <> rawHtml "</details>")
297+ where
298+ subBuilder = foldingStyleBuilder
299+
300+ rawHtml = rawBlock "html"
301+
302+type HeaderLevel = Int
303+
304+singletonHeader :: Inlines -> Report -> Report
305+singletonHeader i b = Report (OM.singleton (i, b)) mempty
306+
307+singletonBody :: Blocks -> Report
308+singletonBody = Report OM.empty
298309
299310show' :: Show x => x -> Inlines
300311show' = str . T.pack . show
312+
313+foldOMapWithKey :: Monoid m => OMap k v -> (k -> v -> m) -> m
314+foldOMapWithKey m f = foldMap (uncurry f) $ OM.assocs m