{-# LANGUAGE LambdaCase #-}

{- |
Module      : Conformance.Extent
Description : Every live refusal of a run, classified against the model
License     : Apache-2.0

The replay index of a run names every refusal its live rows met. A refusal
whose step carried an executed model reason is class A by fact: the runner
records it, and its reason must agree with the traced replay's or be
uncompared with a named cause. Every other refusal must be listed, by its
row, in the committed table of the extent document as B, C or D; one that is
not is unclassified, and fails. The index must also name each refusal the
run's receipts record exactly once, and an accepting control for each script
role that refused.

Pure: the index entries, the receipts and the document arrive as data.
-}
module Conformance.Extent
    ( ExtentClass (..)
    , Listed (..)
    , committedClasses
    , ExtentCount (..)
    , extentProblems
    , extentCount
    ) where

import Conformance.Receipt (Outcome (..), Receipt (..))
import Conformance.Replay (acceptingControlGaps)
import Control.Applicative ((<|>))
import Control.Monad (foldM)
import Data.Aeson (Value (..))
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KM
import Data.Foldable (find, toList)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, isJust, isNothing, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as T

-- | A class the committed table gives a refusal no model reason was executed for.
data ExtentClass
    = -- | Lean returns a reason; no consumer executes the model on the behavior
      ClassB
    | -- | Lean cannot express the behavior
      ClassC
    | -- | Lean's outcome differs from the chain's or the consumer model's
      ClassD
    deriving stock (Int -> ExtentClass -> ShowS
[ExtentClass] -> ShowS
ExtentClass -> String
(Int -> ExtentClass -> ShowS)
-> (ExtentClass -> String)
-> ([ExtentClass] -> ShowS)
-> Show ExtentClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtentClass -> ShowS
showsPrec :: Int -> ExtentClass -> ShowS
$cshow :: ExtentClass -> String
show :: ExtentClass -> String
$cshowList :: [ExtentClass] -> ShowS
showList :: [ExtentClass] -> ShowS
Show, ExtentClass -> ExtentClass -> Bool
(ExtentClass -> ExtentClass -> Bool)
-> (ExtentClass -> ExtentClass -> Bool) -> Eq ExtentClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExtentClass -> ExtentClass -> Bool
== :: ExtentClass -> ExtentClass -> Bool
$c/= :: ExtentClass -> ExtentClass -> Bool
/= :: ExtentClass -> ExtentClass -> Bool
Eq, Eq ExtentClass
Eq ExtentClass =>
(ExtentClass -> ExtentClass -> Ordering)
-> (ExtentClass -> ExtentClass -> Bool)
-> (ExtentClass -> ExtentClass -> Bool)
-> (ExtentClass -> ExtentClass -> Bool)
-> (ExtentClass -> ExtentClass -> Bool)
-> (ExtentClass -> ExtentClass -> ExtentClass)
-> (ExtentClass -> ExtentClass -> ExtentClass)
-> Ord ExtentClass
ExtentClass -> ExtentClass -> Bool
ExtentClass -> ExtentClass -> Ordering
ExtentClass -> ExtentClass -> ExtentClass
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExtentClass -> ExtentClass -> Ordering
compare :: ExtentClass -> ExtentClass -> Ordering
$c< :: ExtentClass -> ExtentClass -> Bool
< :: ExtentClass -> ExtentClass -> Bool
$c<= :: ExtentClass -> ExtentClass -> Bool
<= :: ExtentClass -> ExtentClass -> Bool
$c> :: ExtentClass -> ExtentClass -> Bool
> :: ExtentClass -> ExtentClass -> Bool
$c>= :: ExtentClass -> ExtentClass -> Bool
>= :: ExtentClass -> ExtentClass -> Bool
$cmax :: ExtentClass -> ExtentClass -> ExtentClass
max :: ExtentClass -> ExtentClass -> ExtentClass
$cmin :: ExtentClass -> ExtentClass -> ExtentClass
min :: ExtentClass -> ExtentClass -> ExtentClass
Ord)

{- | What the committed table says of one row: its class, and the traced
reasons and unobserved causes its refusals may carry, the backquoted names of
its traced-reason cell. A refusal of a listed row whose replay records any
other reason or cause is not the refusal the table classified.
-}
data Listed = Listed
    { Listed -> ExtentClass
listedClass :: ExtentClass
    , Listed -> [Text]
listedTraces :: [Text]
    }
    deriving stock (Int -> Listed -> ShowS
[Listed] -> ShowS
Listed -> String
(Int -> Listed -> ShowS)
-> (Listed -> String) -> ([Listed] -> ShowS) -> Show Listed
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Listed -> ShowS
showsPrec :: Int -> Listed -> ShowS
$cshow :: Listed -> String
show :: Listed -> String
$cshowList :: [Listed] -> ShowS
showList :: [Listed] -> ShowS
Show, Listed -> Listed -> Bool
(Listed -> Listed -> Bool)
-> (Listed -> Listed -> Bool) -> Eq Listed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Listed -> Listed -> Bool
== :: Listed -> Listed -> Bool
$c/= :: Listed -> Listed -> Bool
/= :: Listed -> Listed -> Bool
Eq)

{- | The committed table of the extent document — the section headed
@Discovered table@ — as what it lists of each row. A class cell must start with
B, C or D; a row listed twice must keep its class, and its traces accumulate.
-}
committedClasses :: Text -> Either String (Map Text Listed)
committedClasses :: Text -> Either String (Map Text Listed)
committedClasses Text
document = case (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
discovered (Text -> [Text]
T.lines Text
document) of
    ([Text]
_, []) -> String -> Either String (Map Text Listed)
forall a b. a -> Either a b
Left String
"the document has no discovered table"
    ([Text]
_, Text
_ : [Text]
section) -> do
        let rows :: [[Text]]
rows =
                [ Text -> [Text]
cells Text
line
                | Text
line <- (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"## " Text -> Text -> Bool
`T.isPrefixOf`)) [Text]
section
                , Text
"|" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.strip Text
line
                , Bool -> Bool
not (Text
"|---" Text -> Text -> Bool
`T.isPrefixOf` Text -> Text
T.strip Text
line)
                ]
        classes <- ([Text] -> Either String (Text, Listed))
-> [[Text]] -> Either String [(Text, Listed)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse [Text] -> Either String (Text, Listed)
classOf (Int -> [[Text]] -> [[Text]]
forall a. Int -> [a] -> [a]
drop Int
1 [[Text]]
rows)
        if null classes
            then Left "the discovered table lists no row"
            else foldM insertOnce Map.empty classes
  where
    discovered :: Text -> Bool
discovered = (Text
"## Discovered table" Text -> Text -> Bool
`T.isPrefixOf`)
    cells :: Text -> [Text]
cells =
        (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1
            ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"|"
            (Text -> [Text]) -> (Text -> Text) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip
    classOf :: [Text] -> Either String (Text, Listed)
classOf [Text]
row = case ([Text]
row, [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
row) of
        (Text
name : [Text]
_, Text
cell : [Text]
_) -> case Text -> Maybe (Char, Text)
T.uncons Text
cell of
            Just (Char
'B', Text
_) -> (Text, Listed) -> Either String (Text, Listed)
forall a b. b -> Either a b
Right (Text
name, ExtentClass -> [Text] -> Listed
Listed ExtentClass
ClassB ([Text] -> [Text]
traces [Text]
row))
            Just (Char
'C', Text
_) -> (Text, Listed) -> Either String (Text, Listed)
forall a b. b -> Either a b
Right (Text
name, ExtentClass -> [Text] -> Listed
Listed ExtentClass
ClassC ([Text] -> [Text]
traces [Text]
row))
            Just (Char
'D', Text
_) -> (Text, Listed) -> Either String (Text, Listed)
forall a b. b -> Either a b
Right (Text
name, ExtentClass -> [Text] -> Listed
Listed ExtentClass
ClassD ([Text] -> [Text]
traces [Text]
row))
            Maybe (Char, Text)
_ ->
                String -> Either String (Text, Listed)
forall a b. a -> Either a b
Left
                    ( String
"row "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": class "
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a. Show a => a -> String
show Text
cell
                        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not B, C or D"
                    )
        ([Text], [Text])
_ -> String -> Either String (Text, Listed)
forall a b. a -> Either a b
Left String
"a table row with no cells"
    -- The backquoted names of the traced-reason cell, the third.
    traces :: [Text] -> [Text]
traces = \case
        Text
_ : Text
_ : Text
cell : [Text]
_ ->
            [Text
name | (Int
i, Text
name) <- [Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"`" Text
cell), Int -> Bool
forall a. Integral a => a -> Bool
odd Int
i]
        [Text]
_ -> []
    insertOnce :: Map Text Listed
-> (Text, Listed) -> Either String (Map Text Listed)
insertOnce Map Text Listed
acc (Text
name, Listed
listed) = case Text -> Map Text Listed -> Maybe Listed
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text Listed
acc of
        Just Listed
other
            | Listed -> ExtentClass
listedClass Listed
other ExtentClass -> ExtentClass -> Bool
forall a. Eq a => a -> a -> Bool
/= Listed -> ExtentClass
listedClass Listed
listed ->
                String -> Either String (Map Text Listed)
forall a b. a -> Either a b
Left (String
"row " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is listed with two classes")
            | Bool
otherwise ->
                Map Text Listed -> Either String (Map Text Listed)
forall a b. b -> Either a b
Right
                    ( Text -> Listed -> Map Text Listed -> Map Text Listed
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                        Text
name
                        Listed
other{listedTraces = listedTraces other <> listedTraces listed}
                        Map Text Listed
acc
                    )
        Maybe Listed
Nothing -> Map Text Listed -> Either String (Map Text Listed)
forall a b. b -> Either a b
Right (Text -> Listed -> Map Text Listed -> Map Text Listed
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
name Listed
listed Map Text Listed
acc)

-- | How many refusals of a run fall in each class.
data ExtentCount = ExtentCount
    { ExtentCount -> Int
countA :: Int
    , ExtentCount -> Map ExtentClass Int
countTable :: Map ExtentClass Int
    }
    deriving stock (Int -> ExtentCount -> ShowS
[ExtentCount] -> ShowS
ExtentCount -> String
(Int -> ExtentCount -> ShowS)
-> (ExtentCount -> String)
-> ([ExtentCount] -> ShowS)
-> Show ExtentCount
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExtentCount -> ShowS
showsPrec :: Int -> ExtentCount -> ShowS
$cshow :: ExtentCount -> String
show :: ExtentCount -> String
$cshowList :: [ExtentCount] -> ShowS
showList :: [ExtentCount] -> ShowS
Show, ExtentCount -> ExtentCount -> Bool
(ExtentCount -> ExtentCount -> Bool)
-> (ExtentCount -> ExtentCount -> Bool) -> Eq ExtentCount
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExtentCount -> ExtentCount -> Bool
== :: ExtentCount -> ExtentCount -> Bool
$c/= :: ExtentCount -> ExtentCount -> Bool
/= :: ExtentCount -> ExtentCount -> Bool
Eq)

-- | The refusals of a run, by class: A by fact, the others by the table.
extentCount :: Map Text Listed -> [Value] -> ExtentCount
extentCount :: Map Text Listed -> [Value] -> ExtentCount
extentCount Map Text Listed
table [Value]
entries =
    ExtentCount
        { countA :: Int
countA = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | Value
e <- [Value] -> [Value]
refusals [Value]
entries, Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Value -> Maybe Text
modelReasonOf Value
e)]
        , countTable :: Map ExtentClass Int
countTable =
            (Int -> Int -> Int) -> [(ExtentClass, Int)] -> Map ExtentClass Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
                Int -> Int -> Int
forall a. Num a => a -> a -> a
(+)
                [ (ExtentClass
cls, Int
1)
                | Value
e <- [Value] -> [Value]
refusals [Value]
entries
                , Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Value -> Maybe Text
modelReasonOf Value
e)
                , Just ExtentClass
cls <-
                    [Listed -> ExtentClass
listedClass (Listed -> ExtentClass) -> Maybe Listed -> Maybe ExtentClass
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Text -> Map Text Listed -> Maybe Listed)
-> Map Text Listed -> Text -> Maybe Listed
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text Listed -> Maybe Listed
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Map Text Listed
table (Text -> Maybe Listed) -> Maybe Text -> Maybe Listed
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Text
textOf Key
"row" Value
e)]
                ]
        }

{- | What a run's replay index and receipts lack for the extent: one line per
problem, none when every refusal is accounted for.
-}
extentProblems
    :: Map Text Listed -> [Value] -> [Receipt] -> [Text]
extentProblems :: Map Text Listed -> [Value] -> [Receipt] -> [Text]
extentProblems Map Text Listed
table [Value]
entries [Receipt]
receipts =
    [ Text
"no refusal in the replay index: the run proves nothing"
    | [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
indexed
    ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"refusal "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txid
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is named "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
n)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" times in the replay index"
           | (Text
txid, Int
n) <-
                Map Text Int -> [(Text, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList ((Int -> Int -> Int) -> [(Text, Int)] -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) [(Text
t, Int
1 :: Int) | Text
t <- [Text]
txids])
           , Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
           ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"refusal "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txid
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Receipt -> Text
receiptRow Receipt
r
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is in its receipt but not in the replay index"
           | (Receipt
r, Text
txid, Maybe Text
_) <- [(Receipt, Text, Maybe Text)]
recorded
           , Text
txid Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
txids
           ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [ Text
"refusal "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txid
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Receipt -> Text
receiptRow Receipt
r
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": its step carries the model's reason "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", the replay index records "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"none" (Value -> Maybe Text
modelReasonOf (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Value
entryOf Text
txid)
           | (Receipt
r, Text
txid, Just Text
reason) <- [(Receipt, Text, Maybe Text)]
recorded
           , Text
txid Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
txids
           , (Value -> Maybe Text
modelReasonOf (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> Maybe Value
entryOf Text
txid) Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
reason
           ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Value -> [Text]) -> [Value] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Value -> [Text]
classProblems [Value]
indexed
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Value] -> [Text]
acceptingControlGaps [Value]
entries
  where
    indexed :: [Value]
indexed = [Value] -> [Value]
refusals [Value]
entries
    txids :: [Text]
txids = (Value -> Maybe Text) -> [Value] -> [Text]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Key -> Value -> Maybe Text
textOf Key
"rejectedTxId") [Value]
indexed
    entryOf :: Text -> Maybe Value
entryOf Text
txid = (Value -> Bool) -> [Value] -> Maybe Value
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txid) (Maybe Text -> Bool) -> (Value -> Maybe Text) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Maybe Text
textOf Key
"rejectedTxId") [Value]
indexed
    recorded :: [(Receipt, Text, Maybe Text)]
recorded =
        [[(Receipt, Text, Maybe Text)]] -> [(Receipt, Text, Maybe Text)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ case Receipt -> Maybe [Value]
receiptSteps Receipt
r of
                Just [Value]
steps ->
                    [ (Receipt
r, Text
txid, Value -> Maybe Text
stepReason Value
step)
                    | Value
step <- [Value]
steps
                    , (Key -> Value -> Maybe Text
jsonText Key
"outcome" (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
jsonField Key
"chain" Value
step)
                        Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"refused"
                    , Just Text
txid <- [Key -> Value -> Maybe Text
jsonText Key
"txid" (Value -> Maybe Text) -> Maybe Value -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Key -> Value -> Maybe Value
jsonField Key
"chain" Value
step]
                    ]
                Maybe [Value]
Nothing ->
                    [ (Receipt
r, Text
txid, Maybe Text
forall a. Maybe a
Nothing)
                    | Receipt -> Outcome
receiptOutcome Receipt
r Outcome -> Outcome -> Bool
forall a. Eq a => a -> a -> Bool
== Outcome
Refused
                    , Just Text
txid <- [Receipt -> Maybe Text
receiptRejected Receipt
r]
                    ]
            | Receipt
r <- [Receipt]
receipts
            ]
    stepReason :: Value -> Maybe Text
stepReason Value
step = case Key -> Value -> Maybe Value
jsonField Key
"model" Value
step of
        Just Value
model
            | Key -> Value -> Maybe Text
jsonText Key
"outcome" Value
model Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"refused" ->
                Key -> Value -> Maybe Text
jsonText Key
"reason" Value
model
        Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing
    classProblems :: Value -> [Text]
classProblems Value
e =
        let txid :: Text
txid = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"?" (Key -> Value -> Maybe Text
textOf Key
"rejectedTxId" Value
e)
            row :: Text
row = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"?" (Key -> Value -> Maybe Text
textOf Key
"row" Value
e)
            name :: Text
name = Text
"refusal " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txid Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
row
            label :: Maybe Text
label = Key -> Value -> Maybe Text
textOf Key
"extentClass" Value
e
        in  case Value -> Maybe Text
modelReasonOf Value
e of
                Just Text
reason
                    | Maybe Text
label Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"A" ->
                        [ Text
name
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" carries the executed model reason "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but is labelled "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"nothing" Maybe Text
label
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", not A"
                        ]
                    | Bool
otherwise -> case Key -> Value -> Maybe Text
textOf Key
"comparison" Value
e of
                        Just Text
"agrees" -> []
                        Just Text
"uncompared"
                            | Value -> Bool
namesCause Value
e -> []
                            | Bool
otherwise -> [Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is uncompared without a named cause"]
                        Just Text
"differs" ->
                            [Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": the replay's reason differs from the model's"]
                        Maybe Text
other ->
                            [ Text
name
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is class A with no comparison ("
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"none" Maybe Text
other
                                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
                            ]
                Maybe Text
Nothing
                    | Maybe Text
label Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"A" ->
                        [Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is labelled A without an executed model reason"]
                    | Just Listed
listed <- Text -> Map Text Listed -> Maybe Listed
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
row Map Text Listed
table ->
                        [ Text
name
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" records "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
trace
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", which the committed table does not list for "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
row
                        | Text
trace <- Value -> [Text]
recordedTraces Value
e
                        , Text
trace Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` Listed -> [Text]
listedTraces Listed
listed
                        ]
                    | Bool
otherwise ->
                        [ Text
name
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is unclassified: "
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
row
                            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not in the committed table"
                        ]
    -- What a refusal's replay recorded, purpose by purpose: the reason it
    -- admitted or the cause it admits none.
    recordedTraces :: Value -> [Text]
recordedTraces Value
e = case Key -> Value -> Maybe Value
jsonField Key
"classes" Value
e of
        Just (Array Array
classes) ->
            [ Text
t
            | Value
c <- Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
classes
            , Just Text
t <- [Key -> Value -> Maybe Text
jsonText Key
"admitted" Value
c Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key -> Value -> Maybe Text
jsonText Key
"unobserved" Value
c]
            ]
        Maybe Value
_ -> [Text
"no replay"]
    namesCause :: Value -> Bool
namesCause Value
e = case Key -> Value -> Maybe Value
jsonField Key
"classes" Value
e of
        Just (Array Array
classes) ->
            (Value -> Bool) -> Array -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Text -> Bool) -> (Value -> Maybe Text) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Maybe Text
jsonText Key
"unobserved") Array
classes
        Maybe Value
_ -> Bool
False

refusals :: [Value] -> [Value]
refusals :: [Value] -> [Value]
refusals = (Value -> Bool) -> [Value] -> [Value]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"refusal") (Maybe Text -> Bool) -> (Value -> Maybe Text) -> Value -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key -> Value -> Maybe Text
textOf Key
"kind")

modelReasonOf :: Value -> Maybe Text
modelReasonOf :: Value -> Maybe Text
modelReasonOf = Key -> Value -> Maybe Text
textOf Key
"modelReason"

textOf :: Key.Key -> Value -> Maybe Text
textOf :: Key -> Value -> Maybe Text
textOf = Key -> Value -> Maybe Text
jsonText

jsonText :: Key.Key -> Value -> Maybe Text
jsonText :: Key -> Value -> Maybe Text
jsonText Key
name Value
value = case Key -> Value -> Maybe Value
jsonField Key
name Value
value of
    Just (String Text
t) -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
    Maybe Value
_ -> Maybe Text
forall a. Maybe a
Nothing

jsonField :: Key.Key -> Value -> Maybe Value
jsonField :: Key -> Value -> Maybe Value
jsonField Key
name = \case
    Object Object
fields -> Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
name Object
fields
    Value
_ -> Maybe Value
forall a. Maybe a
Nothing