82 lines
3.2 KiB
OCaml
82 lines
3.2 KiB
OCaml
let obligation_kind_to_string = function
|
|
| Pipeline.Preserve_relation -> "preserve_relation"
|
|
| Pipeline.Exposed_representation -> "exposed_representation"
|
|
| Pipeline.Strictness_risk -> "strictness_risk"
|
|
| Pipeline.Worker_wrapper_proof -> "worker_wrapper_proof"
|
|
|
|
let string_of_source_outcome = function
|
|
| Source.Value v -> "value " ^ Source.string_of_value v
|
|
| Source.Stuck msg -> "stuck " ^ msg
|
|
| Source.Diverged n -> "diverged after " ^ string_of_int n ^ " steps"
|
|
|
|
let string_of_target_outcome = function
|
|
| Target.Value v -> "value " ^ Target.string_of_value v
|
|
| Target.Stuck msg -> "stuck " ^ msg
|
|
| Target.Diverged n -> "diverged after " ^ string_of_int n ^ " steps"
|
|
|
|
let string_of_relation = function
|
|
| Relation.Baseline -> "baseline"
|
|
| Relation.Boxed_unboxed -> "boxed_unboxed"
|
|
| Relation.Ground_only -> "ground_only"
|
|
|
|
let verdict_to_string = function
|
|
| Relation.Related -> "related"
|
|
| Relation.Unrelated msg -> "unrelated: " ^ msg
|
|
|
|
let take_steps limit steps =
|
|
let rec go acc n rest =
|
|
match rest with
|
|
| [] -> (List.rev acc, 0)
|
|
| _ when n = 0 -> (List.rev acc, List.length rest)
|
|
| x :: xs -> go (x :: acc) (n - 1) xs
|
|
in
|
|
go [] limit steps
|
|
|
|
let emit_obligations (obligations : Pipeline.obligation list) =
|
|
if obligations = [] then "- none"
|
|
else
|
|
obligations
|
|
|> List.map (fun o ->
|
|
"- [" ^ obligation_kind_to_string o.Pipeline.kind ^ "] " ^ o.Pipeline.pass ^
|
|
" / " ^ o.Pipeline.subject ^ ": " ^ o.Pipeline.detail)
|
|
|> String.concat "\n"
|
|
|
|
let emit_case_header (case : Corpus.case) (comparison : Relation.comparison) (compiled : Pipeline.compiled) =
|
|
String.concat "\n"
|
|
[
|
|
"## " ^ case.Corpus.name;
|
|
"";
|
|
"| field | value |";
|
|
"| --- | --- |";
|
|
"| summary | " ^ case.Corpus.summary ^ " |";
|
|
"| claim | " ^ case.Corpus.claim ^ " |";
|
|
"| relation | `" ^ string_of_relation case.Corpus.relation ^ "` |";
|
|
"| source type | `" ^ Types.string_of_typ case.Corpus.ty ^ "` |";
|
|
"| verdict | `" ^ verdict_to_string comparison.Relation.verdict ^ "` |";
|
|
"| obligations | " ^ string_of_int (List.length compiled.Pipeline.obligations) ^ " |";
|
|
"";
|
|
]
|
|
|
|
let emit_steps pp steps =
|
|
steps
|
|
|> List.mapi (fun i t -> string_of_int i ^ ": " ^ pp t)
|
|
|> String.concat "\n"
|
|
|
|
let emit_counterexample title (src_trace : Source.trace) (tgt_trace : Target.trace) (obligations : Pipeline.obligation list) =
|
|
let _ = title in
|
|
let src_steps, src_hidden = take_steps 32 src_trace.Source.steps in
|
|
let tgt_steps, tgt_hidden = take_steps 48 tgt_trace.Target.steps in
|
|
let src_suffix =
|
|
if src_hidden = 0 then ""
|
|
else "\n... " ^ string_of_int src_hidden ^ " more source steps omitted"
|
|
in
|
|
let tgt_suffix =
|
|
if tgt_hidden = 0 then ""
|
|
else "\n... " ^ string_of_int tgt_hidden ^ " more target steps omitted"
|
|
in
|
|
"source trace:\n" ^ emit_steps Source.string_of_term src_steps ^
|
|
src_suffix ^ "\n\nsource outcome: " ^ string_of_source_outcome src_trace.Source.outcome ^
|
|
"\n\ntarget trace:\n" ^ emit_steps Target.string_of_term tgt_steps ^
|
|
tgt_suffix ^ "\n\ntarget outcome: " ^ string_of_target_outcome tgt_trace.Target.outcome ^
|
|
"\n\nobligations:\n" ^ emit_obligations obligations ^ "\n"
|