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
  { -- | forward 'CertainIssue', 'ProbablyIssue' and 'Comment'
    ReportInput -> Changes
breakingChanges :: Changes
  , -- | backward 'CertainIssue', 'ProbablyIssue' and 'Comment', except those shadowed by 'relatedIssues'
    ReportInput -> Changes
nonBreakingChanges :: Changes
  , -- | forward and backward 'Unsupported' (assumed to be the same anyway)
    ReportInput -> Changes
unsupportedChanges :: Changes
  , -- | forward and backward 'SchemaInvalid' (assumed to be the same anyway)
    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
  | -- | All changes that could be breaking are unsupported – we don't know if
    -- there actually are any breaking changes.
    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 = HeadersTreeStyle | 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 -- Extract this pattern if more cases like this arise
      ( 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 {Report -> OMap Inlines Report
headers :: 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 HeaderLevel = Int

singletonHeader :: Inlines -> Report -> Report
singletonHeader :: Inlines -> Report -> Report
singletonHeader 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