{- | Bounded node diagnostics retain failure constructors and CEK causes.
Script binaries, serialized contexts and cost models are not explanations.
Attribution still uses the original node text; this module only renders it.
-}
module Conformance.NodeRejection (boundedNodeReason) where

import Data.Char (isAlphaNum)
import Data.List (nub)
import Data.Text (Text)
import Data.Text qualified as T

{- | Select the failure path and each machine error before applying the bound.
Both literal and Show-escaped newlines occur in node/evaluator diagnostics.
Trace lines take priority over the machine's generic explanatory prose.
-}
boundedNodeReason :: Int -> Text -> Text
boundedNodeReason :: Int -> Text -> Text
boundedNodeReason Int
limit Text
original
    | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
causes = Int -> Text -> Text
clip Int
limit (Text -> Text
oneLine (Text -> Text
elidePayload Text
text))
    | Bool
otherwise =
        Int -> Text -> Text
clip Int
limit (Text -> [Text] -> Text
T.intercalate Text
" | " (Text
path Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Text -> Text
clip Int
causeLimit) [Text]
causes))
  where
    text :: Text
text = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\n" Text
"\n" (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\\\n" Text
"\n" Text
original)
    causes :: [Text]
causes = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub ((Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
machineCause (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"CekError " Text
text)))
    header :: Text
header = [Text] -> Text -> Text
beforeAny [Text
"The PlutusV3 script failed:", Text
"CekError "] Text
text
    constructors :: [Text]
constructors = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isFailure ((Char -> Bool) -> Text -> [Text]
T.split (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAlphaNum) Text
header)
    isFailure :: Text -> Bool
isFailure Text
word =
        (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isSuffixOf` Text
word) [Text
"Failure", Text
"Error"]
            Bool -> Bool -> Bool
&& (Text
word Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"ConwayApplyTxError")
            Bool -> Bool -> Bool
|| Text
word Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ValidationTagMismatch", Text
"FailedUnexpectedly"]
    path :: Text
path =
        Int -> Text -> Text
clip
            (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
120 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 Int
limit Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2))
            (Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub [Text]
constructors))
    causeLimit :: Int
causeLimit =
        Int -> Int -> Int
forall a. Ord a => a -> a -> a
max
            Int
0
            ( (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
path Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
causes)
                Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
1 ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
causes)
            )

machineCause :: Text -> Text
machineCause :: Text -> Text
machineCause Text
raw = Text
"CekError: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
oneLine Text
detail
  where
    body :: Text
body =
        [Text] -> Text -> Text
beforeAny
            [ Text
"The protocol version is:"
            , Text
"ScriptInfo:"
            , Text
") []"
            , Text
"PlutusWithContext"
            ]
            Text
raw
    linesOfCause :: [Text]
linesOfCause = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip (Text -> [Text]
T.lines Text
body)
    named :: [Text]
named = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
T.isPrefixOf Text
"Caused by:") [Text]
linesOfCause
    traces :: [Text]
traces =
        (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (\Text
line -> (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
`T.isPrefixOf` Text
line) [Text
"Trace:", Text
"Logs:"])
            [Text]
linesOfCause
    detail :: Text
detail = case [Text]
named [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
traces of
        [] ->
            [Text] -> Text -> Text
beforeAny
                [Text
"The budget when", Text
"Negative numbers indicate"]
                (HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"An error has occurred:" Text
"" Text
body)
        [Text]
selected -> Text -> [Text] -> Text
T.intercalate Text
" | " [Text]
selected

-- | Unknown/phase-1 diagnostics retain their text, but never an embedded blob.
elidePayload :: Text -> Text
elidePayload :: Text -> Text
elidePayload Text
text = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"Base64-encoded script bytes:" Text
text of
    (Text
prefix, Text
rest)
        | Bool -> Bool
not (Text -> Bool
T.null Text
rest) ->
            Text
prefix
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[script bytes elided] "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"The script hash is:" Text
rest of
                    (Text
_, Text
suffix) | Bool -> Bool
not (Text -> Bool
T.null Text
suffix) -> Text -> Text
elidePayload Text
suffix
                    (Text, Text)
_ -> Text
""
    (Text, Text)
_ ->
        [Text] -> Text -> Text
beforeAny
            [Text
"PlutusWithContext", Text
"ScriptInfo:", Text
"plutusBinary", Text
"pwcCostModel"]
            Text
text

beforeAny :: [Text] -> Text -> Text
beforeAny :: [Text] -> Text -> Text
beforeAny [Text]
markers Text
text = (Text -> Text -> Text) -> Text -> [Text] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Text
body Text
marker -> (Text, Text) -> Text
forall a b. (a, b) -> a
fst (HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
marker Text
body)) Text
text [Text]
markers

oneLine :: Text -> Text
oneLine :: Text -> Text
oneLine = [Text] -> Text
T.unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words

clip :: Int -> Text -> Text
clip :: Int -> Text -> Text
clip Int
limit Text
text
    | Int
limit Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Text
""
    | Text -> Int
T.length Text
text Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
limit = Text
text
    | Bool
otherwise = Int -> Text -> Text
T.take (Int
limit Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Text
text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"…"