@@ -3,6 +3,8 @@ module OpenAPI.Checker.Report
33 , ReportInput (..)
44 , ReportStatus (..)
55 , Pandoc
6+ , ReportConfig (..)
7+ , ReportTreeStyle (..)
68 )
79where
810
@@ -10,6 +12,7 @@ import Control.Monad.Free hiding (unfoldM)
1012import Control.Monad.Reader
1113import Control.Monad.Writer
1214import Data.Aeson (ToJSON)
15+import Data.Default
1316import Data.Either
1417import Data.Foldable
1518import Data.Function
@@ -54,8 +57,20 @@ data ReportStatus
5457 -- there actually are any breaking changes.
5558 OnlyUnsupportedChanges
5659
57−generateReport :: ReportInput -> (Pandoc, ReportStatus)
58−generateReport inp =
60+data ReportConfig = ReportConfig
61+ { treeStyle :: ReportTreeStyle
62+ }
63+
64+instance Default ReportConfig where
65+ def =
66+ ReportConfig
67+ { treeStyle = HeadersTreeStyle
68+ }
69+
70+data ReportTreeStyle = HeadersTreeStyle | FoldingBlockquotesTreeStyle
71+
72+generateReport :: ReportConfig -> ReportInput -> (Pandoc, ReportStatus)
73+generateReport cfg inp =
5974 let partitionUnsupported = P.partition (\(AnIssue _ i) -> issueIsUnsupported i)
6075 (bUnsupported, breaking) = partitionUnsupported $ breakingChanges inp
6176 (nbUnsupported, invertIssueOrientationP -> nonBreaking) = partitionUnsupported $ nonBreakingChanges inp
@@ -64,8 +79,8 @@ generateReport inp =
6479 nonBreakingChangesPresent = not $ P.null nonBreaking
6580 unsupportedChangesPresent = not $ P.null unsupported
6681 report = doc $
67− runReportMonad jets $ do
68− smartHeader "Summary"
82+ runReportMonad cfg jets $ do
83+ tell $ header 1 "Summary"
6984 tell $
7085 simpleTable
7186 (para
@@ -75,13 +90,13 @@ generateReport inp =
7590 ])
7691 [para . show' <$> [P.size breaking, P.size nonBreaking, P.size unsupported]]
7792 when breakingChangesPresent $ do
78− smartHeader $ anchor breakingChangesId <> "⚠️ Breaking changes"
93+ tell $ header 1 $ anchor breakingChangesId <> "⚠️ Breaking changes"
7994 incrementHeaders $ showErrs breaking
8095 when nonBreakingChangesPresent $ do
81− smartHeader $ anchor nonBreakingChangesId <> "🙆 Non-breaking changes"
96+ tell $ header 1 $ anchor nonBreakingChangesId <> "🙆 Non-breaking changes"
8297 incrementHeaders $ showErrs nonBreaking
8398 when unsupportedChangesPresent $ do
84− smartHeader $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
99+ tell $ header 1 $ anchor unsupportedChangesId <> "🤷 Unsupported feature changes"
85100 incrementHeaders $ showErrs unsupported
86101 status =
87102 if
@@ -105,24 +120,45 @@ generateReport inp =
105120data ReportState = ReportState
106121 { sourceJets :: [ReportJet' Behave Inlines]
107122 , headerLevel :: Int
123+ , headerHandle :: Inlines -> ReportMonad () -> ReportMonad ()
124+ , incrementHeadersHandle :: ReportState -> ReportState
108125 }
109126
110127type ReportMonad = ReaderT ReportState (Writer Blocks)
111128
112−runReportMonad :: [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
113−runReportMonad jts =
129+runReportMonad :: ReportConfig -> [ReportJet' Behave Inlines] -> ReportMonad () -> Blocks
130+runReportMonad cfg jts =
114131 execWriter
115132 . flip
116133 runReaderT
117134 ReportState
118135 { sourceJets = jts
119136 , 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
120156 }
121157
122−smartHeader :: Inlines -> ReportMonad ()
123−smartHeader i = do
124− h <- asks headerLevel
125− tell $ header h i
158+smartHeader :: Inlines -> ReportMonad () -> ReportMonad ()
159+smartHeader i body = do
160+ f <- asks headerHandle
161+ f i body
126162
127163showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> ReportMonad ()
128164showErrs x@(P.PathsPrefixNode currentIssues _) = do
@@ -141,24 +177,27 @@ showErrs x@(P.PathsPrefixNode currentIssues _) = do
141177 in (Just (ori, p'), o)
142178 _ -> (Nothing, currentIssues)
143179 jts <- asks sourceJets
144− for_ otherIssues $ \(AnIssue ori i) -> tell . describeIssue ori $ i
180+ tell $ case S.toList otherIssues of
181+ [AnIssue ori i] -> describeIssue ori i
182+ ii -> orderedList $ ii <&> (\(AnIssue ori i) -> describeIssue ori i)
145183 case removedPaths of
146184 Just (ori, paths) -> do
147− smartHeader $ case ori of
148− Forward -> "Removed paths"
149− Backward -> "Added paths"
150− tell $
151− bulletList $
152− paths <&> \case
153− (NoPathsMatched p) -> para . code $ T.pack p
154− (AllPathsFailed p) -> para . code $ T.pack p
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
155194 Nothing -> pure ()
156195 unfoldM x (observeJetShowErrs <$> jts) $ \(P.PathsPrefixNode _ subIssues) -> do
157196 for_ subIssues $ \(WrapTypeable (AStep m)) ->
158197 for_ (M.toList m) $ \(bhv, subErrors) -> do
159− unless (P.null subErrors) $ do
160− smartHeader $ describeBehaviour bhv
161− incrementHeaders $ showErrs subErrors
198+ unless (P.null subErrors) $
199+ smartHeader (describeBehaviour bhv) $
200+ incrementHeaders $ showErrs subErrors
162201
163202unfoldM :: Monad m => a -> [a -> m a] -> (a -> m ()) -> m ()
164203unfoldM a [] g = g a
@@ -168,8 +207,8 @@ unfoldM a (f : ff) g = do
168207
169208incrementHeaders :: ReportMonad x -> ReportMonad x
170209incrementHeaders m = do
171− l <- asks headerLevel
172− local (\x -> x {headerLevel = l + 1}) m
210+ f <- asks incrementHeadersHandle
211+ local f m
173212
174213jets :: [ReportJet' Behave Inlines]
175214jets =
@@ -241,8 +280,7 @@ observeJetShowErrs' (ReportJet jet) (P.PathsPrefixNode currentIssues subIssues)
241280 Free jet' -> fmap (embed $ step bhv) <$> observeJetShowErrs' jet' subErrs
242281 Pure h -> Just $ do
243282 unless (P.null subErrs) $ do
244− smartHeader h
245− incrementHeaders $ showErrs subErrs
283+ smartHeader h $ incrementHeaders $ showErrs subErrs
246284 return mempty)
247285 in (fmap . fmap) (PathsPrefixNode currentIssues mempty <>) $
248286 if any isRight results