module Data.OpenApi.Compare.Report
( generateReport,
CheckerOutput (..),
ReportInput (..),
segregateIssues,
ReportStatus (..),
Pandoc,
ReportConfig (..),
ReportTreeStyle (..),
ReportMode (..),
)
where
import Control.Monad.Free hiding (unfoldM)
import Data.Aeson (ToJSON)
import Data.Default
import Data.Either
import Data.Function
import Data.Functor
import Data.List.NonEmpty
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Map.Ordered (OMap)
import qualified Data.Map.Ordered as OM
import Data.Maybe
import Data.OpenApi.Compare.Behavior
import Data.OpenApi.Compare.Paths
import Data.OpenApi.Compare.PathsPrefixTree hiding (empty)
import qualified Data.OpenApi.Compare.PathsPrefixTree as P hiding (empty)
import Data.OpenApi.Compare.Report.Jet
import Data.OpenApi.Compare.Subtree (invertIssueOrientationP)
import Data.OpenApi.Compare.Validate.OpenApi
import Data.OpenApi.Compare.Validate.Schema.Issues
import Data.OpenApi.Compare.Validate.Schema.TypedJson
import Data.OpenUnion
import Data.OpenUnion.Extra
import Data.Set
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import Data.TypeRepMap hiding (empty)
import Data.Typeable
import Generic.Data
import Text.Pandoc.Builder
type Changes = P.PathsPrefixTree Behave AnIssue 'APILevel
data CheckerOutput = CheckerOutput
{ CheckerOutput -> Changes
forwardChanges :: Changes
, CheckerOutput -> Changes
backwardChanges :: Changes
}
deriving stock ((forall x. CheckerOutput -> Rep CheckerOutput x)
-> (forall x. Rep CheckerOutput x -> CheckerOutput)
-> Generic CheckerOutput
forall x. Rep CheckerOutput x -> CheckerOutput
forall x. CheckerOutput -> Rep CheckerOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CheckerOutput x -> CheckerOutput
$cfrom :: forall x. CheckerOutput -> Rep CheckerOutput x
Generic)
deriving (b -> CheckerOutput -> CheckerOutput
NonEmpty CheckerOutput -> CheckerOutput
CheckerOutput -> CheckerOutput -> CheckerOutput
(CheckerOutput -> CheckerOutput -> CheckerOutput)
-> (NonEmpty CheckerOutput -> CheckerOutput)
-> (forall b. Integral b => b -> CheckerOutput -> CheckerOutput)
-> Semigroup CheckerOutput
forall b. Integral b => b -> CheckerOutput -> CheckerOutput
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> CheckerOutput -> CheckerOutput
$cstimes :: forall b. Integral b => b -> CheckerOutput -> CheckerOutput
sconcat :: NonEmpty CheckerOutput -> CheckerOutput
$csconcat :: NonEmpty CheckerOutput -> CheckerOutput
<> :: CheckerOutput -> CheckerOutput -> CheckerOutput
$c<> :: CheckerOutput -> CheckerOutput -> CheckerOutput
Semigroup, Semigroup CheckerOutput
CheckerOutput
Semigroup CheckerOutput
-> CheckerOutput
-> (CheckerOutput -> CheckerOutput -> CheckerOutput)
-> ([CheckerOutput] -> CheckerOutput)
-> Monoid CheckerOutput
[CheckerOutput] -> CheckerOutput
CheckerOutput -> CheckerOutput -> CheckerOutput
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [CheckerOutput] -> CheckerOutput
$cmconcat :: [CheckerOutput] -> CheckerOutput
mappend :: CheckerOutput -> CheckerOutput -> CheckerOutput
$cmappend :: CheckerOutput -> CheckerOutput -> CheckerOutput
mempty :: CheckerOutput
$cmempty :: CheckerOutput
$cp1Monoid :: Semigroup CheckerOutput
Monoid) via (Generically CheckerOutput)
deriving anyclass ([CheckerOutput] -> Encoding
[CheckerOutput] -> Value
CheckerOutput -> Encoding
CheckerOutput -> Value
(CheckerOutput -> Value)
-> (CheckerOutput -> Encoding)
-> ([CheckerOutput] -> Value)
-> ([CheckerOutput] -> Encoding)
-> ToJSON CheckerOutput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CheckerOutput] -> Encoding
$ctoEncodingList :: [CheckerOutput] -> Encoding
toJSONList :: [CheckerOutput] -> Value
$ctoJSONList :: [CheckerOutput] -> Value
toEncoding :: CheckerOutput -> Encoding
$ctoEncoding :: CheckerOutput -> Encoding
toJSON :: CheckerOutput -> Value
$ctoJSON :: CheckerOutput -> Value
ToJSON)
data ReportInput = ReportInput
{
ReportInput -> Changes
breakingChanges :: Changes
,
ReportInput -> Changes
nonBreakingChanges :: Changes
,
ReportInput -> Changes
unsupportedChanges :: Changes
,
ReportInput -> Changes
schemaIssues :: Changes
}
deriving stock ((forall x. ReportInput -> Rep ReportInput x)
-> (forall x. Rep ReportInput x -> ReportInput)
-> Generic ReportInput
forall x. Rep ReportInput x -> ReportInput
forall x. ReportInput -> Rep ReportInput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ReportInput x -> ReportInput
$cfrom :: forall x. ReportInput -> Rep ReportInput x
Generic)
deriving (b -> ReportInput -> ReportInput
NonEmpty ReportInput -> ReportInput
ReportInput -> ReportInput -> ReportInput
(ReportInput -> ReportInput -> ReportInput)
-> (NonEmpty ReportInput -> ReportInput)
-> (forall b. Integral b => b -> ReportInput -> ReportInput)
-> Semigroup ReportInput
forall b. Integral b => b -> ReportInput -> ReportInput
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> ReportInput -> ReportInput
$cstimes :: forall b. Integral b => b -> ReportInput -> ReportInput
sconcat :: NonEmpty ReportInput -> ReportInput
$csconcat :: NonEmpty ReportInput -> ReportInput
<> :: ReportInput -> ReportInput -> ReportInput
$c<> :: ReportInput -> ReportInput -> ReportInput
Semigroup, Semigroup ReportInput
ReportInput
Semigroup ReportInput
-> ReportInput
-> (ReportInput -> ReportInput -> ReportInput)
-> ([ReportInput] -> ReportInput)
-> Monoid ReportInput
[ReportInput] -> ReportInput
ReportInput -> ReportInput -> ReportInput
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ReportInput] -> ReportInput
$cmconcat :: [ReportInput] -> ReportInput
mappend :: ReportInput -> ReportInput -> ReportInput
$cmappend :: ReportInput -> ReportInput -> ReportInput
mempty :: ReportInput
$cmempty :: ReportInput
$cp1Monoid :: Semigroup ReportInput
Monoid) via (Generically ReportInput)
deriving anyclass ([ReportInput] -> Encoding
[ReportInput] -> Value
ReportInput -> Encoding
ReportInput -> Value
(ReportInput -> Value)
-> (ReportInput -> Encoding)
-> ([ReportInput] -> Value)
-> ([ReportInput] -> Encoding)
-> ToJSON ReportInput
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [ReportInput] -> Encoding
$ctoEncodingList :: [ReportInput] -> Encoding
toJSONList :: [ReportInput] -> Value
$ctoJSONList :: [ReportInput] -> Value
toEncoding :: ReportInput -> Encoding
$ctoEncoding :: ReportInput -> Encoding
toJSON :: ReportInput -> Value
$ctoJSON :: ReportInput -> Value
ToJSON)
segregateIssues :: CheckerOutput -> ReportInput
segregateIssues :: CheckerOutput -> ReportInput
segregateIssues CheckerOutput {$sel:forwardChanges:CheckerOutput :: CheckerOutput -> Changes
forwardChanges = Changes
fwd, $sel:backwardChanges:CheckerOutput :: CheckerOutput -> Changes
backwardChanges = Changes
bck} =
ReportInput :: Changes -> Changes -> Changes -> Changes -> ReportInput
ReportInput
{ $sel:breakingChanges:ReportInput :: Changes
breakingChanges = (forall (a :: BehaviorLevel). AnIssue a -> Bool)
-> Changes -> Changes
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filter forall (a :: BehaviorLevel). AnIssue a -> Bool
isBreaking Changes
fwd
, $sel:nonBreakingChanges:ReportInput :: Changes
nonBreakingChanges = Changes -> Changes
forall (q :: BehaviorLevel -> BehaviorLevel -> *)
(r :: BehaviorLevel).
PathsPrefixTree q AnIssue r -> PathsPrefixTree q AnIssue r
invertIssueOrientationP (Changes -> Changes) -> Changes -> Changes
forall a b. (a -> b) -> a -> b
$ (forall (a :: BehaviorLevel).
Paths Behave 'APILevel a -> AnIssue a -> Bool)
-> Changes -> Changes
forall k (q :: k -> k -> *) (r :: k) (f :: k -> *).
(forall (a :: k). Paths q r a -> f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filterWithKey forall (a :: BehaviorLevel).
Paths Behave 'APILevel a -> AnIssue a -> Bool
isNonBreaking Changes
bck
, $sel:unsupportedChanges:ReportInput :: Changes
unsupportedChanges = (forall (a :: BehaviorLevel). AnIssue a -> Bool)
-> Changes -> Changes
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filter forall (a :: BehaviorLevel). AnIssue a -> Bool
isUnsupported Changes
fwd Changes -> Changes -> Changes
forall a. Semigroup a => a -> a -> a
<> (forall (a :: BehaviorLevel). AnIssue a -> Bool)
-> Changes -> Changes
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filter forall (a :: BehaviorLevel). AnIssue a -> Bool
isUnsupported Changes
bck
, $sel:schemaIssues:ReportInput :: Changes
schemaIssues = (forall (a :: BehaviorLevel). AnIssue a -> Bool)
-> Changes -> Changes
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filter forall (a :: BehaviorLevel). AnIssue a -> Bool
isSchemaIssue Changes
fwd Changes -> Changes -> Changes
forall a. Semigroup a => a -> a -> a
<> (forall (a :: BehaviorLevel). AnIssue a -> Bool)
-> Changes -> Changes
forall k (f :: k -> *) (q :: k -> k -> *) (r :: k).
(forall (a :: k). f a -> Bool)
-> PathsPrefixTree q f r -> PathsPrefixTree q f r
P.filter forall (a :: BehaviorLevel). AnIssue a -> Bool
isSchemaIssue Changes
bck
}
where
isBreaking :: AnIssue l -> Bool
isBreaking AnIssue l
i = AnIssue l -> IssueKind
forall (l :: BehaviorLevel). AnIssue l -> IssueKind
anIssueKind AnIssue l
i IssueKind -> [IssueKind] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [IssueKind
CertainIssue, IssueKind
ProbablyIssue, IssueKind
Comment]
isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
isNonBreaking :: Paths Behave 'APILevel a -> AnIssue a -> Bool
isNonBreaking Paths Behave 'APILevel a
xs AnIssue a
i = AnIssue a -> Bool
forall (a :: BehaviorLevel). AnIssue a -> Bool
isBreaking AnIssue a
i Bool -> Bool -> Bool
&& (AnIssue a -> Bool) -> Set (AnIssue a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\AnIssue a
j -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ AnIssue a -> AnIssue a -> Bool
forall (l :: BehaviorLevel). AnIssue l -> AnIssue l -> Bool
relatedAnIssues AnIssue a
i AnIssue a
j) (Paths Behave 'APILevel a -> Changes -> Set (AnIssue a)
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f r -> Set (f a)
P.lookup Paths Behave 'APILevel a
xs Changes
fwd)
isUnsupported :: AnIssue l -> Bool
isUnsupported AnIssue l
i = AnIssue l -> IssueKind
forall (l :: BehaviorLevel). AnIssue l -> IssueKind
anIssueKind AnIssue l
i IssueKind -> IssueKind -> Bool
forall a. Eq a => a -> a -> Bool
== IssueKind
Unsupported
isSchemaIssue :: AnIssue l -> Bool
isSchemaIssue AnIssue l
i = AnIssue l -> IssueKind
forall (l :: BehaviorLevel). AnIssue l -> IssueKind
anIssueKind AnIssue l
i IssueKind -> IssueKind -> Bool
forall a. Eq a => a -> a -> Bool
== IssueKind
SchemaInvalid
data ReportStatus
= BreakingChanges
| NoBreakingChanges
|
OnlyUnsupportedChanges
data ReportMode = OnlyErrors | All
deriving stock (ReportMode -> ReportMode -> Bool
(ReportMode -> ReportMode -> Bool)
-> (ReportMode -> ReportMode -> Bool) -> Eq ReportMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportMode -> ReportMode -> Bool
$c/= :: ReportMode -> ReportMode -> Bool
== :: ReportMode -> ReportMode -> Bool
$c== :: ReportMode -> ReportMode -> Bool
Eq)
data ReportConfig = ReportConfig
{ ReportConfig -> ReportTreeStyle
treeStyle :: ReportTreeStyle
, ReportConfig -> ReportMode
reportMode :: ReportMode
}
instance Default ReportConfig where
def :: ReportConfig
def =
ReportConfig :: ReportTreeStyle -> ReportMode -> ReportConfig
ReportConfig
{ $sel:treeStyle:ReportConfig :: ReportTreeStyle
treeStyle = ReportTreeStyle
HeadersTreeStyle
, $sel:reportMode:ReportConfig :: ReportMode
reportMode = ReportMode
All
}
data ReportTreeStyle = | FoldingBlockquotesTreeStyle
twoRowTable :: [(Inlines, Inlines)] -> Blocks
twoRowTable :: [(Inlines, Inlines)] -> Blocks
twoRowTable [(Inlines, Inlines)]
x = [Blocks] -> [[Blocks]] -> Blocks
simpleTable (Inlines -> Blocks
para (Inlines -> Blocks)
-> ((Inlines, Inlines) -> Inlines) -> (Inlines, Inlines) -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inlines, Inlines) -> Inlines
forall a b. (a, b) -> a
fst ((Inlines, Inlines) -> Blocks) -> [(Inlines, Inlines)] -> [Blocks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Inlines, Inlines)]
x) [Inlines -> Blocks
para (Inlines -> Blocks)
-> ((Inlines, Inlines) -> Inlines) -> (Inlines, Inlines) -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inlines, Inlines) -> Inlines
forall a b. (a, b) -> b
snd ((Inlines, Inlines) -> Blocks) -> [(Inlines, Inlines)] -> [Blocks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Inlines, Inlines)]
x]
generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
generateReport :: ReportConfig -> ReportInput -> (Blocks, ReportStatus)
generateReport ReportConfig
cfg ReportInput
inp =
let schemaIssuesPresent :: Bool
schemaIssuesPresent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Changes -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null (Changes -> Bool) -> Changes -> Bool
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
schemaIssues ReportInput
inp
breakingChangesPresent :: Bool
breakingChangesPresent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Changes -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null (Changes -> Bool) -> Changes -> Bool
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
breakingChanges ReportInput
inp
nonBreakingChangesPresent :: Bool
nonBreakingChangesPresent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Changes -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null (Changes -> Bool) -> Changes -> Bool
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
nonBreakingChanges ReportInput
inp
unsupportedChangesPresent :: Bool
unsupportedChangesPresent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Changes -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null (Changes -> Bool) -> Changes -> Bool
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
unsupportedChanges ReportInput
inp
nonBreakingChangesShown :: Bool
nonBreakingChangesShown = case ReportConfig -> ReportMode
reportMode ReportConfig
cfg of
ReportMode
All -> Bool
True
ReportMode
OnlyErrors -> Bool
False
builder :: Report -> Blocks
builder = ReportConfig -> Report -> Blocks
buildReport ReportConfig
cfg
report :: Blocks
report =
Int -> Inlines -> Blocks
header Int
1 Inlines
"Summary"
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> [(Inlines, Inlines)] -> Blocks
twoRowTable
( Bool -> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall m. Monoid m => Bool -> m -> m
when'
Bool
schemaIssuesPresent
[
( Bool -> Text -> Inlines -> Inlines
refOpt Bool
schemaIssuesPresent Text
schemaIssuesId Inlines
"‼️ Schema issues"
, Int -> Inlines
forall x. Show x => x -> Inlines
show' (Int -> Inlines) -> Int -> Inlines
forall a b. (a -> b) -> a -> b
$ Changes -> Int
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Int
P.size (Changes -> Int) -> Changes -> Int
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
schemaIssues ReportInput
inp
)
]
[(Inlines, Inlines)]
-> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall a. [a] -> [a] -> [a]
++ [
( Bool -> Text -> Inlines -> Inlines
refOpt Bool
breakingChangesPresent Text
breakingChangesId Inlines
"❌ Breaking changes"
, Int -> Inlines
forall x. Show x => x -> Inlines
show' (Int -> Inlines) -> Int -> Inlines
forall a b. (a -> b) -> a -> b
$ Changes -> Int
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Int
P.size (Changes -> Int) -> Changes -> Int
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
breakingChanges ReportInput
inp
)
]
[(Inlines, Inlines)]
-> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall a. [a] -> [a] -> [a]
++ Bool -> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall m. Monoid m => Bool -> m -> m
when'
Bool
nonBreakingChangesShown
[
( Bool -> Text -> Inlines -> Inlines
refOpt Bool
nonBreakingChangesPresent Text
nonBreakingChangesId Inlines
"⚠️ Non-breaking changes"
, Int -> Inlines
forall x. Show x => x -> Inlines
show' (Int -> Inlines) -> Int -> Inlines
forall a b. (a -> b) -> a -> b
$ Changes -> Int
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Int
P.size (Changes -> Int) -> Changes -> Int
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
nonBreakingChanges ReportInput
inp
)
]
[(Inlines, Inlines)]
-> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall a. [a] -> [a] -> [a]
++ Bool -> [(Inlines, Inlines)] -> [(Inlines, Inlines)]
forall m. Monoid m => Bool -> m -> m
when'
Bool
unsupportedChangesPresent
[
( Bool -> Text -> Inlines -> Inlines
refOpt Bool
unsupportedChangesPresent Text
unsupportedChangesId Inlines
"❓ Unsupported feature changes"
, Int -> Inlines
forall x. Show x => x -> Inlines
show' (Int -> Inlines) -> Int -> Inlines
forall a b. (a -> b) -> a -> b
$ Changes -> Int
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Int
P.size (Changes -> Int) -> Changes -> Int
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
unsupportedChanges ReportInput
inp
)
]
)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Bool -> Blocks -> Blocks
forall m. Monoid m => Bool -> m -> m
when'
Bool
schemaIssuesPresent
( Int -> Inlines -> Blocks
header Int
1 (Text -> Inlines
anchor Text
schemaIssuesId Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"‼️ Schema issues")
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Report -> Blocks
builder (Changes -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs (Changes -> Report) -> Changes -> Report
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
schemaIssues ReportInput
inp)
)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Bool -> Blocks -> Blocks
forall m. Monoid m => Bool -> m -> m
when'
Bool
breakingChangesPresent
( Int -> Inlines -> Blocks
header Int
1 (Text -> Inlines
anchor Text
breakingChangesId Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"❌ Breaking changes")
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Report -> Blocks
builder (Changes -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs (Changes -> Report) -> Changes -> Report
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
breakingChanges ReportInput
inp)
)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Bool -> Blocks -> Blocks
forall m. Monoid m => Bool -> m -> m
when'
(Bool
nonBreakingChangesPresent Bool -> Bool -> Bool
&& Bool
nonBreakingChangesShown)
( Int -> Inlines -> Blocks
header Int
1 (Text -> Inlines
anchor Text
nonBreakingChangesId Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"⚠️ Non-breaking changes")
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Report -> Blocks
builder (Changes -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs (Changes -> Report) -> Changes -> Report
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
nonBreakingChanges ReportInput
inp)
)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Bool -> Blocks -> Blocks
forall m. Monoid m => Bool -> m -> m
when'
Bool
unsupportedChangesPresent
( Int -> Inlines -> Blocks
header Int
1 (Text -> Inlines
anchor Text
unsupportedChangesId Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
"❓ Unsupported feature changes")
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Report -> Blocks
builder (Changes -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs (Changes -> Report) -> Changes -> Report
forall a b. (a -> b) -> a -> b
$ ReportInput -> Changes
unsupportedChanges ReportInput
inp)
)
status :: ReportStatus
status =
if
| Bool
breakingChangesPresent -> ReportStatus
BreakingChanges
| Bool
unsupportedChangesPresent -> ReportStatus
OnlyUnsupportedChanges
| Bool
otherwise -> ReportStatus
NoBreakingChanges
in (Blocks
report, ReportStatus
status)
where
anchor :: Text -> Inlines
anchor :: Text -> Inlines
anchor Text
a = Attr -> Inlines -> Inlines
spanWith (Text
a, [], []) Inlines
forall a. Monoid a => a
mempty
refOpt :: Bool -> Text -> Inlines -> Inlines
refOpt :: Bool -> Text -> Inlines -> Inlines
refOpt Bool
False Text
_ Inlines
i = Inlines
i
refOpt Bool
True Text
a Inlines
i = Text -> Text -> Inlines -> Inlines
link (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
a) Text
"" Inlines
i
breakingChangesId, nonBreakingChangesId, unsupportedChangesId, schemaIssuesId :: Text
breakingChangesId :: Text
breakingChangesId = Text
"breaking-changes"
unsupportedChangesId :: Text
unsupportedChangesId = Text
"unsupported-changes"
nonBreakingChangesId :: Text
nonBreakingChangesId = Text
"non-breaking-changes"
schemaIssuesId :: Text
schemaIssuesId = Text
"schema-issues"
when' :: Monoid m => Bool -> m -> m
when' :: Bool -> m -> m
when' Bool
True m
m = m
m
when' Bool
False m
_ = m
forall a. Monoid a => a
mempty
showErrs :: forall a. Typeable a => P.PathsPrefixTree Behave AnIssue a -> Report
showErrs :: PathsPrefixTree Behave AnIssue a -> Report
showErrs x :: PathsPrefixTree Behave AnIssue a
x@(P.PathsPrefixNode Set (AnIssue a)
currentIssues [WrapTypeable (AStep Behave AnIssue a)]
_) =
let
( Maybe (Orientation, [Issue 'APILevel])
removedPaths :: Maybe (Orientation, [Issue 'APILevel])
, Set (AnIssue a)
otherIssues :: Set (AnIssue a)
) = case (Typeable a, Typeable 'APILevel) => Maybe (a :~: 'APILevel)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @ 'APILevel of
Just a :~: 'APILevel
Refl
| (Set (AnIssue a) -> [AnIssue a]
forall a. Set a -> [a]
S.toList -> p :: [AnIssue a]
p@((AnIssue Orientation
ori Issue a
_) : [AnIssue a]
_), Set (AnIssue a)
o) <-
(AnIssue a -> Bool)
-> Set (AnIssue a) -> (Set (AnIssue a), Set (AnIssue a))
forall a. (a -> Bool) -> Set a -> (Set a, Set a)
S.partition
( \((AnIssue Orientation
_ Issue a
u)) -> case Issue a
u of
NoPathsMatched {} -> Bool
True
AllPathsFailed {} -> Bool
True
)
Set (AnIssue a)
currentIssues ->
let p' :: [Issue 'APILevel]
p' = [AnIssue a]
p [AnIssue a] -> (AnIssue a -> Issue 'APILevel) -> [Issue 'APILevel]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(AnIssue Orientation
_ Issue a
i) -> Issue a
Issue 'APILevel
i)
in ((Orientation, [Issue 'APILevel])
-> Maybe (Orientation, [Issue 'APILevel])
forall a. a -> Maybe a
Just (Orientation
ori, [Issue 'APILevel]
p'), Set (AnIssue a)
o)
Maybe (a :~: 'APILevel)
_ -> (Maybe (Orientation, [Issue 'APILevel])
forall a. Maybe a
Nothing, Set (AnIssue a)
currentIssues)
issues :: Report
issues = Blocks -> Report
singletonBody (Blocks -> Report) -> Blocks -> Report
forall a b. (a -> b) -> a -> b
$ case Set (AnIssue a) -> [AnIssue a]
forall a. Set a -> [a]
S.toList Set (AnIssue a)
otherIssues of
[AnIssue Orientation
ori Issue a
i] -> Orientation -> Issue a -> Blocks
forall (l :: BehaviorLevel).
Issuable l =>
Orientation -> Issue l -> Blocks
describeIssue Orientation
ori Issue a
i
[AnIssue a]
ii -> [Blocks] -> Blocks
orderedList ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall a b. (a -> b) -> a -> b
$ [AnIssue a]
ii [AnIssue a] -> (AnIssue a -> Blocks) -> [Blocks]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(AnIssue Orientation
ori Issue a
i) -> Orientation -> Issue a -> Blocks
forall (l :: BehaviorLevel).
Issuable l =>
Orientation -> Issue l -> Blocks
describeIssue Orientation
ori Issue a
i)
paths :: Report
paths = case Maybe (Orientation, [Issue 'APILevel])
removedPaths of
Just (Orientation
ori, [Issue 'APILevel]
ps) -> do
Inlines -> Report -> Report
singletonHeader
( case Orientation
ori of
Orientation
Forward -> Inlines
"Removed paths"
Orientation
Backward -> Inlines
"Added paths"
)
(Report -> Report) -> Report -> Report
forall a b. (a -> b) -> a -> b
$ Blocks -> Report
singletonBody (Blocks -> Report) -> Blocks -> Report
forall a b. (a -> b) -> a -> b
$
[Blocks] -> Blocks
bulletList ([Blocks] -> Blocks) -> [Blocks] -> Blocks
forall a b. (a -> b) -> a -> b
$
[Issue 'APILevel]
ps [Issue 'APILevel] -> (Issue 'APILevel -> Blocks) -> [Blocks]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
(NoPathsMatched p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> (Text -> Inlines) -> Text -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
code (Text -> Blocks) -> Text -> Blocks
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
p
(AllPathsFailed p) -> Inlines -> Blocks
para (Inlines -> Blocks) -> (Text -> Inlines) -> Text -> Blocks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Inlines
code (Text -> Blocks) -> Text -> Blocks
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
p
Maybe (Orientation, [Issue 'APILevel])
Nothing -> Report
forall a. Monoid a => a
mempty
rest :: Report
rest = PathsPrefixTree Behave AnIssue a
-> [PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a)]
-> (PathsPrefixTree Behave AnIssue a -> Report)
-> Report
forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
unfoldFunctions PathsPrefixTree Behave AnIssue a
x (ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a)
forall (a :: BehaviorLevel).
ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a)
observeJetShowErrs (ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a))
-> [ReportJet' Behave (Maybe Inlines)]
-> [PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ReportJet' Behave (Maybe Inlines)]
jets) ((PathsPrefixTree Behave AnIssue a -> Report) -> Report)
-> (PathsPrefixTree Behave AnIssue a -> Report) -> Report
forall a b. (a -> b) -> a -> b
$ \(P.PathsPrefixNode Set (AnIssue a)
_ [WrapTypeable (AStep Behave AnIssue a)]
subIssues) -> do
((WrapTypeable (AStep Behave AnIssue a) -> Report)
-> [WrapTypeable (AStep Behave AnIssue a)] -> Report)
-> [WrapTypeable (AStep Behave AnIssue a)]
-> (WrapTypeable (AStep Behave AnIssue a) -> Report)
-> Report
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WrapTypeable (AStep Behave AnIssue a) -> Report)
-> [WrapTypeable (AStep Behave AnIssue a)] -> Report
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [WrapTypeable (AStep Behave AnIssue a)]
subIssues ((WrapTypeable (AStep Behave AnIssue a) -> Report) -> Report)
-> (WrapTypeable (AStep Behave AnIssue a) -> Report) -> Report
forall a b. (a -> b) -> a -> b
$ \(WrapTypeable (AStep Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
m)) ->
(((Behave a a, PathsPrefixTree Behave AnIssue a) -> Report)
-> [(Behave a a, PathsPrefixTree Behave AnIssue a)] -> Report)
-> [(Behave a a, PathsPrefixTree Behave AnIssue a)]
-> ((Behave a a, PathsPrefixTree Behave AnIssue a) -> Report)
-> Report
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Behave a a, PathsPrefixTree Behave AnIssue a) -> Report)
-> [(Behave a a, PathsPrefixTree Behave AnIssue a)] -> Report
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
-> [(Behave a a, PathsPrefixTree Behave AnIssue a)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
m) (((Behave a a, PathsPrefixTree Behave AnIssue a) -> Report)
-> Report)
-> ((Behave a a, PathsPrefixTree Behave AnIssue a) -> Report)
-> Report
forall a b. (a -> b) -> a -> b
$ \(Behave a a
bhv, PathsPrefixTree Behave AnIssue a
subErrors) ->
if PathsPrefixTree Behave AnIssue a -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null PathsPrefixTree Behave AnIssue a
subErrors
then Report
forall a. Monoid a => a
mempty
else Inlines -> Report -> Report
singletonHeader (Behave a a -> Inlines
forall (a :: BehaviorLevel) (b :: BehaviorLevel).
Behavable a b =>
Behave a b -> Inlines
describeBehavior Behave a a
bhv) (Report -> Report) -> Report -> Report
forall a b. (a -> b) -> a -> b
$ PathsPrefixTree Behave AnIssue a -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs PathsPrefixTree Behave AnIssue a
subErrors
in Report
issues Report -> Report -> Report
forall a. Semigroup a => a -> a -> a
<> Report
paths Report -> Report -> Report
forall a. Semigroup a => a -> a -> a
<> Report
rest
unfoldFunctions :: forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
unfoldFunctions :: a -> [a -> (m, a)] -> (a -> m) -> m
unfoldFunctions a
initA [a -> (m, a)]
fs a -> m
g = a -> [a -> (m, a)] -> m
unfoldFunctions' a
initA [a -> (m, a)]
fs
where
unfoldFunctions' :: a -> [a -> (m, a)] -> m
unfoldFunctions' :: a -> [a -> (m, a)] -> m
unfoldFunctions' a
a [] | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
initA = a -> m
g a
a
unfoldFunctions' a
a [] = a -> [a -> (m, a)] -> (a -> m) -> m
forall m a. (Monoid m, Eq a) => a -> [a -> (m, a)] -> (a -> m) -> m
unfoldFunctions a
a [a -> (m, a)]
fs a -> m
g
unfoldFunctions' a
a (a -> (m, a)
f : [a -> (m, a)]
ff) =
let (m
m, a
a') = a -> (m, a)
f a
a
in a -> [a -> (m, a)] -> m
unfoldFunctions' a
a' [a -> (m, a)]
ff m -> m -> m
forall a. Semigroup a => a -> a -> a
<> m
m
jets :: [ReportJet' Behave (Maybe Inlines)]
jets :: [ReportJet' Behave (Maybe Inlines)]
jets =
ReportJetResult Behave (Maybe Inlines)
-> ReportJet' Behave (Maybe Inlines)
forall x. ReportJetResult Behave x -> ReportJet' Behave x
unwrapReportJetResult
(ReportJetResult Behave (Maybe Inlines)
-> ReportJet' Behave (Maybe Inlines))
-> [ReportJetResult Behave (Maybe Inlines)]
-> [ReportJet' Behave (Maybe Inlines)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ (Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel -> Maybe Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall k k x (f :: k -> k -> *).
ConstructReportJet x f =>
x -> ReportJetResult f (Maybe Inlines)
constructReportJet ((Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel -> Maybe Inlines)
-> ReportJetResult Behave (Maybe Inlines))
-> (Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel -> Maybe Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall a b. (a -> b) -> a -> b
$
((Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> Maybe Inlines)
-> Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel
-> Maybe Inlines
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (((Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> Maybe Inlines)
-> Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel
-> Maybe Inlines)
-> ((Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'TypedSchemaLevel)
-> Maybe Inlines)
-> Behave 'SchemaLevel 'TypedSchemaLevel
-> Behave 'TypedSchemaLevel 'TypedSchemaLevel
-> Maybe Inlines
forall a b. (a -> b) -> a -> b
$ \case
(OfType Object, p :: Behave 'TypedSchemaLevel 'TypedSchemaLevel
p@(InPartition _)) -> Inlines -> Maybe Inlines
forall a. a -> Maybe a
Just (Inlines -> Maybe Inlines) -> Inlines -> Maybe Inlines
forall a b. (a -> b) -> a -> b
$ Behave 'TypedSchemaLevel 'TypedSchemaLevel -> Inlines
forall (a :: BehaviorLevel) (b :: BehaviorLevel).
Behavable a b =>
Behave a b -> Inlines
describeBehavior Behave 'TypedSchemaLevel 'TypedSchemaLevel
p :: Maybe Inlines
(Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'TypedSchemaLevel)
_ -> Maybe Inlines
forall a. Maybe a
Nothing
, (NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall k k x (f :: k -> k -> *).
ConstructReportJet x f =>
x -> ReportJetResult f (Maybe Inlines)
constructReportJet NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
-> Inlines
jsonPathJet
, (Behave 'APILevel 'PathLevel
-> Behave 'PathLevel 'OperationLevel -> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall k k x (f :: k -> k -> *).
ConstructReportJet x f =>
x -> ReportJetResult f (Maybe Inlines)
constructReportJet ((Behave 'APILevel 'PathLevel
-> Behave 'PathLevel 'OperationLevel -> Inlines)
-> ReportJetResult Behave (Maybe Inlines))
-> (Behave 'APILevel 'PathLevel
-> Behave 'PathLevel 'OperationLevel -> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall a b. (a -> b) -> a -> b
$ \p :: Behave 'APILevel 'PathLevel
p@(AtPath _) op :: Behave 'PathLevel 'OperationLevel
op@(InOperation _) ->
Inlines -> Inlines
strong (Behave 'PathLevel 'OperationLevel -> Inlines
forall (a :: BehaviorLevel) (b :: BehaviorLevel).
Behavable a b =>
Behave a b -> Inlines
describeBehavior Behave 'PathLevel 'OperationLevel
op) Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Inlines
" " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Behave 'APILevel 'PathLevel -> Inlines
forall (a :: BehaviorLevel) (b :: BehaviorLevel).
Behavable a b =>
Behave a b -> Inlines
describeBehavior Behave 'APILevel 'PathLevel
p :: Inlines
, (Behave 'OperationLevel 'ResponseLevel
-> Behave 'ResponseLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall k k x (f :: k -> k -> *).
ConstructReportJet x f =>
x -> ReportJetResult f (Maybe Inlines)
constructReportJet ((Behave 'OperationLevel 'ResponseLevel
-> Behave 'ResponseLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines))
-> (Behave 'OperationLevel 'ResponseLevel
-> Behave 'ResponseLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall a b. (a -> b) -> a -> b
$ \(WithStatusCode c) Behave 'ResponseLevel 'PayloadLevel
ResponsePayload Behave 'PayloadLevel 'SchemaLevel
PayloadSchema ->
Inlines
"⬅️☁️ JSON Response – " Inlines -> Inlines -> Inlines
forall a. Semigroup a => a -> a -> a
<> Text -> Inlines
str (String -> Text
T.pack (String -> Text) -> (Int -> String) -> Int -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> Text) -> Int -> Text
forall a b. (a -> b) -> a -> b
$ Int
c) :: Inlines
, (Behave 'OperationLevel 'RequestLevel
-> Behave 'RequestLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall k k x (f :: k -> k -> *).
ConstructReportJet x f =>
x -> ReportJetResult f (Maybe Inlines)
constructReportJet ((Behave 'OperationLevel 'RequestLevel
-> Behave 'RequestLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines))
-> (Behave 'OperationLevel 'RequestLevel
-> Behave 'RequestLevel 'PayloadLevel
-> Behave 'PayloadLevel 'SchemaLevel
-> Inlines)
-> ReportJetResult Behave (Maybe Inlines)
forall a b. (a -> b) -> a -> b
$ \Behave 'OperationLevel 'RequestLevel
InRequest Behave 'RequestLevel 'PayloadLevel
InPayload Behave 'PayloadLevel 'SchemaLevel
PayloadSchema -> Inlines
"➡️☁️ JSON Request" :: Inlines
]
where
unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
unwrapReportJetResult :: ReportJetResult Behave x -> ReportJet' Behave x
unwrapReportJetResult (Pure x
_) = String -> ReportJet' Behave x
forall a. HasCallStack => String -> a
error String
"There really shouldn't be any results here."
unwrapReportJetResult (Free ReportJet' Behave x
f) = ReportJet' Behave x
f
jsonPathJet ::
NonEmpty
( Union
'[ Behave 'SchemaLevel 'TypedSchemaLevel
, Behave 'TypedSchemaLevel 'SchemaLevel
]
) ->
Inlines
jsonPathJet :: NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
-> Inlines
jsonPathJet NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
x = Text -> Inlines
code (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts (NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
-> [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty
(Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel])
x)
where
showParts ::
[ Union
'[ Behave 'SchemaLevel 'TypedSchemaLevel
, Behave 'TypedSchemaLevel 'SchemaLevel
]
] ->
Text
showParts :: [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [] = Text
forall a. Monoid a => a
mempty
showParts (SingletonUnion (OfType Object) : xs :: [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs@((SingletonUnion (InProperty _)) : [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
_)) = [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs
showParts (SingletonUnion (OfType Object) : xs :: [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs@((SingletonUnion Behave 'TypedSchemaLevel 'SchemaLevel
InAdditionalProperty) : [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
_)) = [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs
showParts (SingletonUnion (OfType Array) : xs :: [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs@(SingletonUnion Behave 'TypedSchemaLevel 'SchemaLevel
InItems : [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
_)) = [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs
showParts (SingletonUnion (OfType Array) : xs :: [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs@(SingletonUnion (InItem _) : [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
_)) = [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
xs
showParts (Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]
y : [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
ys) =
( (\(OfType t) -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> JsonType -> Text
forall s. IsString s => JsonType -> s
describeJSONType JsonType
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
(Behave 'SchemaLevel 'TypedSchemaLevel -> Text)
-> (Union '[Behave 'TypedSchemaLevel 'SchemaLevel] -> Text)
-> Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]
-> Text
forall a b (xs :: [*]).
Typeable a =>
(a -> b) -> (Union xs -> b) -> Union (a : xs) -> b
@@> ( \case
Behave 'TypedSchemaLevel 'SchemaLevel
InItems -> Text
"[*]"
InItem i -> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Integer -> String
forall a. Show a => a -> String
show Integer
i) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
InProperty p -> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
p
Behave 'TypedSchemaLevel 'SchemaLevel
InAdditionalProperty -> Text
".*"
)
(Behave 'TypedSchemaLevel 'SchemaLevel -> Text)
-> (Union '[] -> Text)
-> Union '[Behave 'TypedSchemaLevel 'SchemaLevel]
-> Text
forall a b (xs :: [*]).
Typeable a =>
(a -> b) -> (Union xs -> b) -> Union (a : xs) -> b
@@> Union '[] -> Text
forall a. Union '[] -> a
typesExhausted
)
Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]
y
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
-> Text
showParts [Union
'[Behave 'SchemaLevel 'TypedSchemaLevel,
Behave 'TypedSchemaLevel 'SchemaLevel]]
ys
observeJetShowErrs ::
ReportJet' Behave (Maybe Inlines) ->
P.PathsPrefixTree Behave AnIssue a ->
(Report, P.PathsPrefixTree Behave AnIssue a)
observeJetShowErrs :: ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> (Report, PathsPrefixTree Behave AnIssue a)
observeJetShowErrs ReportJet' Behave (Maybe Inlines)
jet PathsPrefixTree Behave AnIssue a
p = case ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall (a :: BehaviorLevel).
ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
observeJetShowErrs' ReportJet' Behave (Maybe Inlines)
jet PathsPrefixTree Behave AnIssue a
p of
Just (Report, PathsPrefixTree Behave AnIssue a)
m -> (Report, PathsPrefixTree Behave AnIssue a)
m
Maybe (Report, PathsPrefixTree Behave AnIssue a)
Nothing -> (Report
forall a. Monoid a => a
mempty, PathsPrefixTree Behave AnIssue a
p)
observeJetShowErrs' ::
forall a.
ReportJet' Behave (Maybe Inlines) ->
P.PathsPrefixTree Behave AnIssue a ->
Maybe (Report, P.PathsPrefixTree Behave AnIssue a)
observeJetShowErrs' :: ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
observeJetShowErrs' (ReportJet forall (a :: BehaviorLevel) (b :: BehaviorLevel) (m :: * -> *).
(Typeable (Behave a b), Alternative m, Monad m) =>
Behave a b -> m (ReportJetResult Behave (Maybe Inlines))
jet) (P.PathsPrefixNode Set (AnIssue a)
currentIssues [WrapTypeable (AStep Behave AnIssue a)]
subIssues) =
let results :: [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
results =
[WrapTypeable (AStep Behave AnIssue a)]
subIssues [WrapTypeable (AStep Behave AnIssue a)]
-> (WrapTypeable (AStep Behave AnIssue a)
-> [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)])
-> [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(WrapTypeable (AStep Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
m)) ->
Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
-> [(Behave a a, PathsPrefixTree Behave AnIssue a)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Behave a a) (PathsPrefixTree Behave AnIssue a)
m [(Behave a a, PathsPrefixTree Behave AnIssue a)]
-> ((Behave a a, PathsPrefixTree Behave AnIssue a)
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a))
-> [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(Behave a a
bhv, PathsPrefixTree Behave AnIssue a
subErrs) ->
Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
-> ((Report, PathsPrefixTree Behave AnIssue a)
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a))
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PathsPrefixTree Behave AnIssue a
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall a b. a -> Either a b
Left (PathsPrefixTree Behave AnIssue a
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a))
-> PathsPrefixTree Behave AnIssue a
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall a b. (a -> b) -> a -> b
$ Paths Behave a a
-> PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
embed (Behave a a -> Paths Behave a a
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Behave a a
bhv) PathsPrefixTree Behave AnIssue a
subErrs) (Report, PathsPrefixTree Behave AnIssue a)
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall a b. b -> Either a b
Right (Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a))
-> ([(Report, PathsPrefixTree Behave AnIssue a)]
-> Maybe (Report, PathsPrefixTree Behave AnIssue a))
-> [(Report, PathsPrefixTree Behave AnIssue a)]
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Report, PathsPrefixTree Behave AnIssue a)]
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. [a] -> Maybe a
listToMaybe ([(Report, PathsPrefixTree Behave AnIssue a)]
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a))
-> [(Report, PathsPrefixTree Behave AnIssue a)]
-> Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
forall a b. (a -> b) -> a -> b
$
Behave a a -> [ReportJetResult Behave (Maybe Inlines)]
forall (a :: BehaviorLevel) (b :: BehaviorLevel) (m :: * -> *).
(Typeable (Behave a b), Alternative m, Monad m) =>
Behave a b -> m (ReportJetResult Behave (Maybe Inlines))
jet @_ @_ @[] Behave a a
bhv
[ReportJetResult Behave (Maybe Inlines)]
-> ([ReportJetResult Behave (Maybe Inlines)]
-> [(Report, PathsPrefixTree Behave AnIssue a)])
-> [(Report, PathsPrefixTree Behave AnIssue a)]
forall a b. a -> (a -> b) -> b
& (ReportJetResult Behave (Maybe Inlines)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a))
-> [ReportJetResult Behave (Maybe Inlines)]
-> [(Report, PathsPrefixTree Behave AnIssue a)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
( \case
Free ReportJet' Behave (Maybe Inlines)
jet' -> (PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Paths Behave a a
-> PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a
forall k (q :: k -> k -> *) (r :: k) (a :: k) (f :: k -> *).
Paths q r a -> PathsPrefixTree q f a -> PathsPrefixTree q f r
embed (Paths Behave a a
-> PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a)
-> Paths Behave a a
-> PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a
forall a b. (a -> b) -> a -> b
$ Behave a a -> Paths Behave a a
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step Behave a a
bhv) ((Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a))
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall (a :: BehaviorLevel).
ReportJet' Behave (Maybe Inlines)
-> PathsPrefixTree Behave AnIssue a
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
observeJetShowErrs' ReportJet' Behave (Maybe Inlines)
jet' PathsPrefixTree Behave AnIssue a
subErrs
Pure (Just Inlines
h) ->
if PathsPrefixTree Behave AnIssue a -> Bool
forall k (q :: k -> k -> *) (f :: k -> *) (r :: k).
PathsPrefixTree q f r -> Bool
P.null PathsPrefixTree Behave AnIssue a
subErrs
then (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. a -> Maybe a
Just (Report, PathsPrefixTree Behave AnIssue a)
forall a. Monoid a => a
mempty
else (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. a -> Maybe a
Just (Inlines -> Report -> Report
singletonHeader Inlines
h (PathsPrefixTree Behave AnIssue a -> Report
forall (a :: BehaviorLevel).
Typeable a =>
PathsPrefixTree Behave AnIssue a -> Report
showErrs PathsPrefixTree Behave AnIssue a
subErrs), PathsPrefixTree Behave AnIssue a
forall a. Monoid a => a
mempty)
Pure Maybe Inlines
Nothing -> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. Maybe a
Nothing
)
in (((Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a))
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a))
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a))
-> ((PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a))
-> (PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (Set (AnIssue a)
-> [WrapTypeable (AStep Behave AnIssue a)]
-> PathsPrefixTree Behave AnIssue a
forall k (f :: k -> *) (r :: k) (q :: k -> k -> *).
Ord (f r) =>
Set (f r) -> [WrapTypeable (AStep q f r)] -> PathsPrefixTree q f r
PathsPrefixNode Set (AnIssue a)
currentIssues [WrapTypeable (AStep Behave AnIssue a)]
forall a. Monoid a => a
mempty PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a
-> PathsPrefixTree Behave AnIssue a
forall a. Semigroup a => a -> a -> a
<>) (Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a))
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a b. (a -> b) -> a -> b
$
if (Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
-> Bool)
-> [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
-> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
-> Bool
forall a b. Either a b -> Bool
isRight [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
results
then
(Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. a -> Maybe a
Just ((Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a))
-> (Report, PathsPrefixTree Behave AnIssue a)
-> Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a b. (a -> b) -> a -> b
$
(Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)
-> (Report, PathsPrefixTree Behave AnIssue a))
-> [Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
-> (Report, PathsPrefixTree Behave AnIssue a)
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
( \case
Left PathsPrefixTree Behave AnIssue a
e -> (Report
forall a. Monoid a => a
mempty, PathsPrefixTree Behave AnIssue a
e)
Right (Report, PathsPrefixTree Behave AnIssue a)
m -> (Report, PathsPrefixTree Behave AnIssue a)
m
)
[Either
(PathsPrefixTree Behave AnIssue a)
(Report, PathsPrefixTree Behave AnIssue a)]
results
else Maybe (Report, PathsPrefixTree Behave AnIssue a)
forall a. Maybe a
Nothing
data Report = Report { :: OMap Inlines Report, Report -> Blocks
body :: Blocks}
deriving stock ((forall x. Report -> Rep Report x)
-> (forall x. Rep Report x -> Report) -> Generic Report
forall x. Rep Report x -> Report
forall x. Report -> Rep Report x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Report x -> Report
$cfrom :: forall x. Report -> Rep Report x
Generic)
instance Semigroup Report where
(Report OMap Inlines Report
headers1 Blocks
b1) <> :: Report -> Report -> Report
<> (Report OMap Inlines Report
headers2 Blocks
b2) = OMap Inlines Report -> Blocks -> Report
Report ((Inlines -> Report -> Report -> Report)
-> OMap Inlines Report
-> OMap Inlines Report
-> OMap Inlines Report
forall k v.
Ord k =>
(k -> v -> v -> v) -> OMap k v -> OMap k v -> OMap k v
OM.unionWithL ((Report -> Report -> Report)
-> Inlines -> Report -> Report -> Report
forall a b. a -> b -> a
const Report -> Report -> Report
forall a. Semigroup a => a -> a -> a
(<>)) OMap Inlines Report
headers1 OMap Inlines Report
headers2) (Blocks
b1 Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Blocks
b2)
instance Monoid Report where
mempty :: Report
mempty = OMap Inlines Report -> Blocks -> Report
Report OMap Inlines Report
forall k v. OMap k v
OM.empty Blocks
forall a. Monoid a => a
mempty
buildReport :: ReportConfig -> Report -> Blocks
buildReport :: ReportConfig -> Report -> Blocks
buildReport ReportConfig
cfg = case ReportConfig -> ReportTreeStyle
treeStyle ReportConfig
cfg of
ReportTreeStyle
HeadersTreeStyle -> Int -> Report -> Blocks
headerStyleBuilder Int
2
ReportTreeStyle
FoldingBlockquotesTreeStyle -> Report -> Blocks
foldingStyleBuilder
where
headerStyleBuilder :: HeaderLevel -> Report -> Blocks
headerStyleBuilder :: Int -> Report -> Blocks
headerStyleBuilder Int
level Report
rprt =
Report -> Blocks
body Report
rprt
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> OMap Inlines Report -> (Inlines -> Report -> Blocks) -> Blocks
forall m k v. Monoid m => OMap k v -> (k -> v -> m) -> m
foldOMapWithKey
(Report -> OMap Inlines Report
headers Report
rprt)
( \Inlines
k Report
v ->
Int -> Inlines -> Blocks
header Int
level Inlines
k Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Report -> Blocks
subBuilder Report
v
)
where
subBuilder :: Report -> Blocks
subBuilder = Int -> Report -> Blocks
headerStyleBuilder (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
foldingStyleBuilder :: Report -> Blocks
foldingStyleBuilder :: Report -> Blocks
foldingStyleBuilder Report
rprt =
Report -> Blocks
body Report
rprt
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> OMap Inlines Report -> (Inlines -> Report -> Blocks) -> Blocks
forall m k v. Monoid m => OMap k v -> (k -> v -> m) -> m
foldOMapWithKey
(Report -> OMap Inlines Report
headers Report
rprt)
( \Inlines
k Report
v ->
if (OMap Inlines Report -> Int
forall k v. OMap k v -> Int
OM.size (OMap Inlines Report -> Int)
-> (Report -> OMap Inlines Report) -> Report -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Report -> OMap Inlines Report
headers (Report -> Int) -> Report -> Int
forall a b. (a -> b) -> a -> b
$ Report
rprt) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2
then Inlines -> Blocks
para Inlines
k Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Blocks -> Blocks
blockQuote (Report -> Blocks
subBuilder Report
v)
else
Text -> Blocks
rawHtml Text
"<details>"
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Text -> Blocks
rawHtml Text
"<summary>"
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Inlines -> Blocks
plain Inlines
k
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Text -> Blocks
rawHtml Text
"</summary>"
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Blocks -> Blocks
blockQuote (Report -> Blocks
subBuilder Report
v)
Blocks -> Blocks -> Blocks
forall a. Semigroup a => a -> a -> a
<> Text -> Blocks
rawHtml Text
"</details>"
)
where
subBuilder :: Report -> Blocks
subBuilder = Report -> Blocks
foldingStyleBuilder
rawHtml :: Text -> Blocks
rawHtml = Text -> Text -> Blocks
rawBlock Text
"html"
type = Int
singletonHeader :: Inlines -> Report -> Report
Inlines
i Report
b = OMap Inlines Report -> Blocks -> Report
Report ((Inlines, Report) -> OMap Inlines Report
forall k v. (k, v) -> OMap k v
OM.singleton (Inlines
i, Report
b)) Blocks
forall a. Monoid a => a
mempty
singletonBody :: Blocks -> Report
singletonBody :: Blocks -> Report
singletonBody = OMap Inlines Report -> Blocks -> Report
Report OMap Inlines Report
forall k v. OMap k v
OM.empty
show' :: Show x => x -> Inlines
show' :: x -> Inlines
show' = Text -> Inlines
str (Text -> Inlines) -> (x -> Text) -> x -> Inlines
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (x -> String) -> x -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> String
forall a. Show a => a -> String
show
foldOMapWithKey :: Monoid m => OMap k v -> (k -> v -> m) -> m
foldOMapWithKey :: OMap k v -> (k -> v -> m) -> m
foldOMapWithKey OMap k v
m k -> v -> m
f = ((k, v) -> m) -> [(k, v)] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((k -> v -> m) -> (k, v) -> m
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry k -> v -> m
f) ([(k, v)] -> m) -> [(k, v)] -> m
forall a b. (a -> b) -> a -> b
$ OMap k v -> [(k, v)]
forall k v. OMap k v -> [(k, v)]
OM.assocs OMap k v
m