formalise optimiser auditing with relation ledgers and shrunk semantic counterexamples

README.md

@@ -6,11 +6,11 @@ this project models a small typed source calculus and then lowers it into an exp
 
 the target language makes representation explicit and forces each transition to be spelled out in the term. values are either boxed or unboxed and can be projected from products or injected into sums as well as unpacked when needed and moved across worker wrapper boundaries as part of calling convention shifts
 
-the target calculus is intentionally lower level than the source and trades abstraction for control over layout and calling. it has decent tuple and sum representations and uses explicit box and unbox operations to mediate between them. equality on integers and booleans is primitive rather than encoded as well as recursive binding being built in rather than derived
+the target calculus is intentionally lower level than the source and trades abstraction for control over layout and calling. it has tuple and sum representations and uses explicit box and unbox operations to mediate between them. equality on integers and booleans is primitive rather than encoded as well as recursive binding being built in rather than derived
 
-the audit path now records pass-boundary observations for source, specialisation, inlining, effect rewriting, and representation lowering. each corpus case is checked against relation preservation, target arity/shape validation, termination class preservation, and effect trace preservation. unsafe profiles intentionally refute these invariants so optimiser bugs show up as small source/target deltas rather than vague failures.
+the audit path records pass boundary observations and each corpus case is checked against relation preservation, target arity and shape validation, termination class preservation and effect trace preservation. unsafe profiles intentionally refute the invariants so that  optimiser bugs show up as small source target deltas rather than vague failures
 
-the source calculus also has an explicit `tick` effect. this is enough to expose unsound dce-style rewrites: eliminating a dead binding is only valid when the eliminated term is effect free.
+the source calculus also has an explicit `tick` effect which is enough to expose unsound dce style rewrites. eliminating a dead binding is only valid when the eliminated term is effect free
 
 ## example(s)
 
@@ -20,15 +20,15 @@ a representation exposure witness starts from a polymorphic constant false term
 forall a. function a function a bool
 ```
 
-under a safe profile instantiating this term at `bool` preserves the baseline relation. under an unsafe inline profile instantiating at `int` can expose integer equality and refute the abstraction theorem
+under a safe profile instantiating this  preserves the baseline relation. under an unsafe inline profile instantiating can expose integer equality and refute the abstraction theorem
 
-a strictness witness places a divergent recursive computation under `roll`
+a strictness witness places a divergent recursive computation
 
 ```ocaml
 roll mu a. int loop
 ```
 
-the source observation can keep the recursive payload latent. a strict lowering path may force it during construction and change termination.
+the source observation can keep the recursive payload latent and a strict lowering path can force it during construction and change termination
 
 a worker wrapper witness uses the explicit source type representation
 
@@ -36,4 +36,4 @@ a worker wrapper witness uses the explicit source type representation
 TArrow (TPair (TInt, TBool), TPair (TInt, TBool))
 ```
 
-the target worker receives `RInt` and `RBool` while the wrapper preserves the boxed source interface
+the target worker receives `RInt` and `RBool` while the wrapper preserves the boxed source interface IRs

bin/main.ml

@@ -6,6 +6,10 @@ type profile = {
   relation : Relation.relation;
 }
 
+type output_mode =
+  | Text
+  | Json
+
 let safe_flags =
   { Pipeline.default_flags with unsafe_repr_eq = false; unsafe_strict_unroll = false; unsafe_effect_drop = false }
 
@@ -20,37 +24,272 @@ let profiles =
     { name = "unsafe-effects"; flags = { safe_flags with unsafe_effect_drop = true }; relation = Relation.Boxed_unboxed };
   ]
 
-let run_case (case : Corpus.case) =
+let json_escape s =
-  let audit = Audit.audit_case case in
+  let b = Buffer.create (String.length s + 16) in
-  let failed_invariants =
+  String.iter
+    (function
+      | '"' -> Buffer.add_string b "\\\""
+      | '\\' -> Buffer.add_string b "\\\\"
+      | '\n' -> Buffer.add_string b "\\n"
+      | '\r' -> Buffer.add_string b "\\r"
+      | '\t' -> Buffer.add_string b "\\t"
+      | c -> Buffer.add_char b c)
+    s;
+  Buffer.contents b
+
+let json_string s = "\"" ^ json_escape s ^ "\""
+let json_bool b = if b then "true" else "false"
+let json_list xs = "[" ^ String.concat "," xs ^ "]"
+
+let json_field name value =
+  json_string name ^ ":" ^ value
+
+let json_object fields =
+  "{" ^ String.concat "," fields ^ "}"
+
+let option_default all selected =
+  match selected with
+  | [] -> all
+  | _ -> List.rev selected
+
+let find_named kind name xs get_name =
+  match List.find_opt (fun x -> String.equal (get_name x) name) xs with
+  | Some x -> x
+  | None ->
+      prerr_endline ("unknown " ^ kind ^ " " ^ name);
+      exit 2
+
+let selected_cases names =
+  option_default Corpus.all (List.map (fun name -> find_named "case" name Corpus.all (fun c -> c.Corpus.name)) names)
+
+let selected_profiles names =
+  option_default profiles (List.map (fun name -> find_named "profile" name profiles (fun p -> p.name)) names)
+
+let failed_invariants audit =
   audit.Audit.invariants
   |> List.filter (fun result -> not result.Audit.passed)
   |> List.map (fun result -> Audit.invariant_kind_to_string result.Audit.kind)
-  in
+
+let emit_plain_obligations audit =
+  if audit.Audit.obligations = [] then "obligations none"
+  else
+    "obligations\n" ^
+    (audit.Audit.obligations
+     |> List.map (fun result ->
+            let o = result.Audit.obligation in
+            o.Pipeline.pass ^ "  " ^
+            Reporting.obligation_kind_to_string o.Pipeline.kind ^ "  " ^
+            Audit.obligation_status_to_string result.Audit.status ^ "  " ^
+            result.Audit.note)
+     |> String.concat "\n")
+
+let emit_plain_invariants audit =
+  "invariants\n" ^
+  (audit.Audit.invariants
+   |> List.map (fun result ->
+          Audit.invariant_kind_to_string result.Audit.kind ^ "  " ^
+          (if result.Audit.passed then "ok" else "failed") ^ "  " ^
+          result.Audit.detail)
+   |> String.concat "\n")
+
+let emit_plain_boundaries audit =
+  "pass observations\n" ^
+  (audit.Audit.pass_boundaries
+   |> List.map (fun (boundary : Audit.pass_boundary) -> boundary.Audit.pass ^ "  " ^ boundary.Audit.verdict)
+   |> String.concat "\n")
+
+let run_case_text ~details case =
+  let audit = Audit.audit_case case in
+  let failed = failed_invariants audit in
   Printf.printf
-    "case %s\nclassification %s\nverdict %s\nsource %s\ntarget %s\nfailed invariants %s\n\n"
+    "case %s\nclassification %s\nverdict %s\nsource %s\ntarget %s\nfailed invariants %s\n"
     case.Corpus.name
     (Audit.failure_mode_to_string audit.Audit.failure_mode)
     (Reporting.verdict_to_string audit.Audit.comparison.Relation.verdict)
     (Reporting.string_of_source_trace audit.Audit.source_trace)
     (Reporting.string_of_target_trace audit.Audit.target_trace)
-    (if failed_invariants = [] then "none" else String.concat ", " failed_invariants);
+    (if failed = [] then "none" else String.concat ", " failed);
-  if audit.Audit.failure_mode <> Audit.Preserved then begin
+  if details || audit.Audit.failure_mode <> Audit.Preserved then begin
-    Printf.printf "%s\n\n" (Reporting.emit_pipeline_visualisation audit.Audit.compiled);
+    Printf.printf "\n%s\n\n" (Reporting.emit_pipeline_visualisation audit.Audit.compiled);
-    Printf.printf "%s\n\n" (Audit.emit_pass_boundaries audit)
+    Printf.printf "%s\n\n" (emit_plain_boundaries audit);
-  end
+    Printf.printf "%s\n\n" (emit_plain_invariants audit);
+    Printf.printf "%s\n" (emit_plain_obligations audit)
+  end;
+  Printf.printf "\n"
 
-let run_profile profile =
+let outcome_json_source outcome =
-  let result = Gen.run_campaign profile.flags profile.relation ~count:160 ~max_depth:4 () in
+  json_string (Reporting.string_of_source_outcome outcome)
+
+let outcome_json_target outcome =
+  json_string (Reporting.string_of_target_outcome outcome)
+
+let obligation_json result =
+  let o = result.Audit.obligation in
+  json_object
+    [
+      json_field "pass" (json_string o.Pipeline.pass);
+      json_field "kind" (json_string (Reporting.obligation_kind_to_string o.Pipeline.kind));
+      json_field "status" (json_string (Audit.obligation_status_to_string result.Audit.status));
+      json_field "subject" (json_string o.Pipeline.subject);
+      json_field "detail" (json_string o.Pipeline.detail);
+      json_field "note" (json_string result.Audit.note);
+    ]
+
+let invariant_json result =
+  json_object
+    [
+      json_field "kind" (json_string (Audit.invariant_kind_to_string result.Audit.kind));
+      json_field "passed" (json_bool result.Audit.passed);
+      json_field "detail" (json_string result.Audit.detail);
+    ]
+
+let boundary_json (boundary : Audit.pass_boundary) =
+  json_object
+    [
+      json_field "pass" (json_string boundary.Audit.pass);
+      json_field "observation" (json_string boundary.Audit.verdict);
+      json_field "effects" (string_of_int boundary.Audit.effects);
+    ]
+
+let audit_json audit =
+  json_object
+    [
+      json_field "case" (json_string audit.Audit.case.Corpus.name);
+      json_field "summary" (json_string audit.Audit.case.Corpus.summary);
+      json_field "classification" (json_string (Audit.failure_mode_to_string audit.Audit.failure_mode));
+      json_field "verdict" (json_string (Reporting.verdict_to_string audit.Audit.comparison.Relation.verdict));
+      json_field "source" (json_string (Reporting.string_of_source_trace audit.Audit.source_trace));
+      json_field "target" (json_string (Reporting.string_of_target_trace audit.Audit.target_trace));
+      json_field "pipeline"
+        (json_object
+           [
+             json_field "source" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.source_program));
+             json_field "specialise" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.specialised));
+             json_field "inline" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.inlined));
+             json_field "effect" (json_string (Source.string_of_term audit.Audit.compiled.Pipeline.effect_rewritten));
+             json_field "repr_lower" (json_string (Target.string_of_term audit.Audit.compiled.Pipeline.target_program));
+           ]);
+      json_field "pass_boundaries" (json_list (List.map boundary_json audit.Audit.pass_boundaries));
+      json_field "invariants" (json_list (List.map invariant_json audit.Audit.invariants));
+      json_field "obligations" (json_list (List.map obligation_json audit.Audit.obligations));
+    ]
+
+let run_case_json case =
+  audit_json (Audit.audit_case case)
+
+let failure_json failure =
+  json_object
+    [
+      json_field "original_type" (json_string (Types.string_of_typ failure.Gen.original.Gen.ty));
+      json_field "original_term" (json_string (Source.string_of_term failure.Gen.original.Gen.term));
+      json_field "minimal_type" (json_string (Types.string_of_typ failure.Gen.minimal.Gen.ty));
+      json_field "minimal_term" (json_string (Source.string_of_term failure.Gen.minimal.Gen.term));
+      json_field "verdict" (json_string (Reporting.verdict_to_string failure.Gen.comparison.Relation.verdict));
+      json_field "source_effects" (string_of_int failure.Gen.comparison.Relation.source_effects);
+      json_field "target_effects" (string_of_int failure.Gen.comparison.Relation.target_effects);
+    ]
+
+let run_profile_text ~details ~count ~max_depth profile =
+  let result = Gen.run_campaign profile.flags profile.relation ~count ~max_depth () in
   Printf.printf
-    "profile %s\nrelated %d/%d\nviolations %d\n\n"
+    "profile %s\nrelation %s\nrelated %d/%d\nviolations %d\n"
     profile.name
+    (Reporting.string_of_relation profile.relation)
     result.Gen.related
     result.Gen.total
-    (result.Gen.total - result.Gen.related)
+    (result.Gen.total - result.Gen.related);
+  if details && result.Gen.failures <> [] then begin
+    Printf.printf "minimal failures\n";
+    result.Gen.failures
+    |> List.to_seq
+    |> Seq.take 5
+    |> Seq.iter (fun failure ->
+           Printf.printf
+             "type %s\nterm %s\nverdict %s\n\n"
+             (Types.string_of_typ failure.Gen.minimal.Gen.ty)
+             (Source.string_of_term failure.Gen.minimal.Gen.term)
+             (Reporting.verdict_to_string failure.Gen.comparison.Relation.verdict))
+  end;
+  Printf.printf "\n"
+
+let run_profile_json ~count ~max_depth profile =
+  let result = Gen.run_campaign profile.flags profile.relation ~count ~max_depth () in
+  json_object
+    [
+      json_field "profile" (json_string profile.name);
+      json_field "relation" (json_string (Reporting.string_of_relation profile.relation));
+      json_field "total" (string_of_int result.Gen.total);
+      json_field "related" (string_of_int result.Gen.related);
+      json_field "violations" (string_of_int (result.Gen.total - result.Gen.related));
+      json_field "failures" (json_list (List.map failure_json result.Gen.failures));
+    ]
+
+let list_available () =
+  print_endline "cases";
+  List.iter (fun case -> print_endline ("  " ^ case.Corpus.name)) Corpus.all;
+  print_endline "";
+  print_endline "profiles";
+  List.iter (fun profile -> print_endline ("  " ^ profile.name)) profiles
 
 let () =
+  let mode = ref Text in
+  let details = ref false in
+  let list_only = ref false in
+  let run_corpus = ref true in
+  let run_profiles = ref true in
+  let case_names = ref [] in
+  let profile_names = ref [] in
+  let count = ref 160 in
+  let max_depth = ref 4 in
+  let add_case name = case_names := name :: !case_names in
+  let add_profile name = profile_names := name :: !profile_names in
+  let specs =
+    [
+      ("--case", Arg.String add_case, "run one corpus case by name; repeatable");
+      ("--profile", Arg.String add_profile, "run one campaign profile by name; repeatable");
+      ("--cases", Arg.Clear run_profiles, "run selected corpus cases without campaign profiles");
+      ("--profiles", Arg.Clear run_corpus, "run selected campaign profiles without corpus cases");
+      ("--count", Arg.Set_int count, "set generated campaign specimen count");
+      ("--max-depth", Arg.Set_int max_depth, "set generated campaign term/type depth");
+      ("--details", Arg.Set details, "print pass observations, invariants, obligations, and shrunk failures");
+      ("--json", Arg.Unit (fun () -> mode := Json), "emit machine-readable JSON");
+      ("--list", Arg.Set list_only, "list available cases and profiles");
+    ]
+  in
+  Arg.parse specs (fun name -> add_case name) "vanity [--case name] [--profile name] [--details] [--json]";
+  if !list_only then list_available ()
+  else
+    let cases = if !run_corpus then selected_cases !case_names else [] in
+    let selected_profiles = if !run_profiles then selected_profiles !profile_names else [] in
+    match !mode with
+    | Text ->
+        if !details then Printf.printf "%s\n\n" (Audit.emit_relation_ledger ());
+        if cases <> [] then begin
           Printf.printf "corpus\n\n";
-  List.iter run_case Corpus.all;
+          List.iter (run_case_text ~details:!details) cases
+        end;
+        if selected_profiles <> [] then begin
           Printf.printf "profiles\n\n";
-  List.iter run_profile profiles
+          List.iter (run_profile_text ~details:!details ~count:!count ~max_depth:!max_depth) selected_profiles
+        end
+    | Json ->
+        let case_json = List.map run_case_json cases in
+        let profile_json = List.map (run_profile_json ~count:!count ~max_depth:!max_depth) selected_profiles in
+        print_endline
+          (json_object
+             [
+               json_field "version" (json_string Project.version);
+               json_field "relation_ledger"
+                 (json_list
+                    (List.map
+                       (fun entry ->
+                          json_object
+                            [
+                              json_field "pass" (json_string entry.Audit.pass);
+                              json_field "relation" (json_string entry.Audit.relation);
+                              json_field "condition" (json_string entry.Audit.condition);
+                            ])
+                       Audit.relation_ledger));
+               json_field "cases" (json_list case_json);
+               json_field "profiles" (json_list profile_json);
+             ])

src/audit.ml

@@ -26,6 +26,12 @@ type pass_boundary = {
   verdict : string;
 }
 
+type relation_entry = {
+  pass : string;
+  relation : string;
+  condition : string;
+}
+
 type obligation_status =
   | Discharged
   | Assumed
@@ -71,6 +77,46 @@ let obligation_status_to_string = function
   | Assumed -> "assumed"
   | Refuted -> "refuted"
 
+let relation_ledger =
+  [
+    {
+      pass = "specialise";
+      relation = "baseline";
+      condition = "type instantiation clones code without adding observers for abstract values";
+    };
+    {
+      pass = "inline";
+      relation = "baseline";
+      condition = "beta rewriting preserves uniformity and does not expose representation primitives";
+    };
+    {
+      pass = "effect";
+      relation = "effect_trace";
+      condition = "rewrites preserve the ordered count of observable source effects";
+    };
+    {
+      pass = "repr_lower";
+      relation = "boxed_unboxed";
+      condition = "source values relate pointwise to explicit target representations";
+    };
+    {
+      pass = "worker_wrapper";
+      relation = "boxed_unboxed";
+      condition = "wrapper projections and worker arguments preserve pointwise correspondence";
+    };
+    {
+      pass = "roll/unroll";
+      relation = "termination_sensitive";
+      condition = "lowering does not force payloads earlier than source evaluation";
+    };
+  ]
+
+let emit_relation_entry entry =
+  entry.pass ^ "  relation " ^ entry.relation ^ "  condition " ^ entry.condition
+
+let emit_relation_ledger () =
+  "relation ledger\n" ^ String.concat "\n" (List.map emit_relation_entry relation_ledger)
+
 let has_obligation kind obligations =
   List.exists (fun (o : Pipeline.obligation) -> o.Pipeline.kind = kind) obligations
 
@@ -228,7 +274,7 @@ let emit_invariant_result result =
   "| `" ^ invariant_kind_to_string result.kind ^ "` | `" ^
   (if result.passed then "ok" else "failed") ^ "` | " ^ result.detail ^ " |"
 
-let emit_boundary boundary =
+let emit_boundary (boundary : pass_boundary) =
   "| `" ^ boundary.pass ^ "` | `" ^ boundary.verdict ^ "` |"
 
 let emit_invariants audit =

src/audit.mli

@@ -26,6 +26,12 @@ type pass_boundary = {
   verdict : string;
 }
 
+type relation_entry = {
+  pass : string;
+  relation : string;
+  condition : string;
+}
+
 type obligation_status =
   | Discharged
   | Assumed
@@ -56,6 +62,8 @@ val audit_case : Corpus.case -> case_audit
 val failure_mode_to_string : failure_mode -> string
 val obligation_status_to_string : obligation_status -> string
 val invariant_kind_to_string : invariant_kind -> string
+val relation_ledger : relation_entry list
+val emit_relation_ledger : unit -> string
 val emit_pass_boundaries : case_audit -> string
 val emit_invariants : case_audit -> string
 val emit_case_audit : case_audit -> string

src/framework.ml

@@ -0,0 +1,71 @@
+type observation = {
+  outcome : string;
+  effects : int;
+  terminated : bool;
+}
+
+type obligation = {
+  pass : string;
+  kind : string;
+  subject : string;
+  detail : string;
+}
+
+module type LANGUAGE = sig
+  type typ
+  type source
+  type target
+
+  val name : string
+  val string_of_typ : typ -> string
+  val string_of_source : source -> string
+  val string_of_target : target -> string
+
+  val typecheck : typ -> source -> (unit, string) result
+  val observe_source : source -> observation
+  val observe_target : target -> observation
+  val validate_target : target -> (unit, string list) result
+end
+
+module type SOURCE_PASS = sig
+  type term
+
+  val name : string
+  val run : term -> term * obligation list
+end
+
+module type LOWERING = sig
+  type source
+  type target
+
+  val name : string
+  val run : source -> target * obligation list
+end
+
+type invariant_result = {
+  name : string;
+  passed : bool;
+  detail : string;
+}
+
+let invariant name passed detail = { name; passed; detail }
+
+let check_observation_invariants ~source ~target ~relation_preserved ~target_valid =
+  [
+    invariant
+      "relation_preservation"
+      relation_preserved
+      (if relation_preserved then "source and target observations are related" else "source and target observations diverge");
+    invariant
+      "target_arity"
+      (match target_valid with Ok () -> true | Error _ -> false)
+      (match target_valid with Ok () -> "target validates" | Error errors -> String.concat "; " errors);
+    invariant
+      "termination_class"
+      (Bool.equal source.terminated target.terminated)
+      ("source " ^ source.outcome ^ ", target " ^ target.outcome);
+    invariant
+      "effect_trace"
+      (source.effects = target.effects)
+      ("source effects " ^ string_of_int source.effects ^ ", target effects " ^ string_of_int target.effects);
+  ]

src/framework.mli

@@ -0,0 +1,56 @@
+type observation = {
+  outcome : string;
+  effects : int;
+  terminated : bool;
+}
+
+type obligation = {
+  pass : string;
+  kind : string;
+  subject : string;
+  detail : string;
+}
+
+module type LANGUAGE = sig
+  type typ
+  type source
+  type target
+
+  val name : string
+  val string_of_typ : typ -> string
+  val string_of_source : source -> string
+  val string_of_target : target -> string
+
+  val typecheck : typ -> source -> (unit, string) result
+  val observe_source : source -> observation
+  val observe_target : target -> observation
+  val validate_target : target -> (unit, string list) result
+end
+
+module type SOURCE_PASS = sig
+  type term
+
+  val name : string
+  val run : term -> term * obligation list
+end
+
+module type LOWERING = sig
+  type source
+  type target
+
+  val name : string
+  val run : source -> target * obligation list
+end
+
+type invariant_result = {
+  name : string;
+  passed : bool;
+  detail : string;
+}
+
+val check_observation_invariants :
+  source:observation ->
+  target:observation ->
+  relation_preserved:bool ->
+  target_valid:(unit, string list) result ->
+  invariant_result list

src/gen.ml

@@ -5,10 +5,16 @@ type specimen = {
   term : Source.term;
 }
 
+type failure = {
+  original : specimen;
+  minimal : specimen;
+  comparison : Relation.comparison;
+}
+
 type result = {
   total : int;
   related : int;
-  failures : (specimen * Relation.comparison) list;
+  failures : failure list;
 }
 
 let rng = Random.State.make [| 0x51; 0x17; 0x2b |]
@@ -106,22 +112,105 @@ let sample_terms ~count ~max_depth () =
   in
   fill [] 0 0
 
-let shrink specimen =
+let rec shrink_term ty term =
-  match specimen.term, specimen.ty with
+  let self = shrink_term in
-  | Source.Pair (a, _), ty -> [{ term = a; ty }]
+  let typ_or fallback term =
-  | Source.If (_, t, e), _ -> [{ specimen with term = t }; { specimen with term = e }]
+    match Typecheck.type_of term with
+    | Ok ty -> ty
+    | Error _ -> fallback
+  in
+  let rebuild f sub_ty sub =
+    List.map (fun sub' -> { ty; term = f sub'.term }) (self sub_ty sub)
+  in
+  match ty, term with
+  | TInt, Source.Int n when n <> 0 -> [{ ty; term = Source.Int 0 }]
+  | TBool, Source.Bool true -> [{ ty; term = Source.Bool false }]
+  | _, Source.Tick (_, t) -> { ty; term = t } :: rebuild (fun t' -> Source.Tick ("shrunk", t')) ty t
+  | _, Source.Let (_, a, b) ->
+      { ty; term = b } ::
+      rebuild (fun a' -> Source.Let ("_", a', b)) (typ_or ty a) a @
+      rebuild (fun b' -> Source.Let ("_", a, b')) ty b
+  | _, Source.If (c, t, e) ->
+      { ty; term = t } :: { ty; term = e } ::
+      rebuild (fun c' -> Source.If (c', t, e)) TBool c @
+      rebuild (fun t' -> Source.If (c, t', e)) ty t @
+      rebuild (fun e' -> Source.If (c, t, e')) ty e
+  | TPair (a_ty, b_ty), Source.Pair (a, b) ->
+      rebuild (fun a' -> Source.Pair (a', b)) a_ty a @
+      rebuild (fun b' -> Source.Pair (a, b')) b_ty b
+  | TSum (a_ty, _), Source.Inl (sum_ty, t) ->
+      rebuild (fun t' -> Source.Inl (sum_ty, t')) a_ty t
+  | TSum (_, b_ty), Source.Inr (sum_ty, t) ->
+      rebuild (fun t' -> Source.Inr (sum_ty, t')) b_ty t
+  | _, Source.App (f, a) ->
+      let f_ty = typ_or (TArrow (ty, ty)) f in
+      let a_ty = typ_or ty a in
+      rebuild (fun f' -> Source.App (f', a)) f_ty f @
+      rebuild (fun a' -> Source.App (f, a')) a_ty a
+  | _, Source.TyApp (t, app_ty) ->
+      let t_ty = typ_or (TForall ("a", ty)) t in
+      rebuild (fun t' -> Source.TyApp (t', app_ty)) t_ty t
+  | _, Source.Eq (g, a, b) ->
+      let ground_ty = match g with GInt -> TInt | GBool -> TBool in
+      rebuild (fun a' -> Source.Eq (g, a', b)) ground_ty a @
+      rebuild (fun b' -> Source.Eq (g, a, b')) ground_ty b
+  | _, Source.LetPair (x, y, scrut, body) ->
+      let scrut_ty = typ_or (TPair (ty, ty)) scrut in
+      rebuild (fun scrut' -> Source.LetPair (x, y, scrut', body)) scrut_ty scrut @
+      rebuild (fun body' -> Source.LetPair (x, y, scrut, body')) ty body
+  | _, Source.Case (scrut, (x, l), (y, r)) ->
+      let scrut_ty = typ_or (TSum (ty, ty)) scrut in
+      rebuild (fun scrut' -> Source.Case (scrut', (x, l), (y, r))) scrut_ty scrut @
+      rebuild (fun l' -> Source.Case (scrut, (x, l'), (y, r))) ty l @
+      rebuild (fun r' -> Source.Case (scrut, (x, l), (y, r'))) ty r
+  | TMu (_, _), Source.Roll (roll_ty, t) ->
+      let payload_ty = typ_or ty t in
+      rebuild (fun t' -> Source.Roll (roll_ty, t')) payload_ty t
+  | _, Source.Unroll t ->
+      let t_ty = typ_or (TMu ("a", ty)) t in
+      rebuild (fun t' -> Source.Unroll t') t_ty t
   | _ -> []
 
+let shrink specimen =
+  shrink_term specimen.ty specimen.term
+  |> List.filter (fun candidate -> Typecheck.is_well_typed candidate.ty candidate.term)
+
+let comparison_for ?(fuel = 256) flags relation specimen =
+  let compiled = Pipeline.compile flags specimen.ty specimen.term in
+  Relation.compare_programs ~fuel relation specimen.ty specimen.term compiled.target_program
+
+let is_failure cmp =
+  match cmp.Relation.verdict with
+  | Relation.Related -> false
+  | Relation.Unrelated _ -> true
+
+let shrink_failure ?(fuel = 256) flags relation specimen =
+  let rec improve current =
+    let current_cmp = comparison_for ~fuel flags relation current in
+    let candidates =
+      shrink current
+      |> List.filter_map (fun candidate ->
+             let cmp = comparison_for ~fuel flags relation candidate in
+             if is_failure cmp then Some (candidate, cmp) else None)
+    in
+    match candidates with
+    | (candidate, _) :: _ when Source.string_of_term candidate.term <> Source.string_of_term current.term ->
+        improve candidate
+    | _ -> (current, current_cmp)
+  in
+  improve specimen
+
 let run_campaign ?(fuel = 256) flags relation ~count ~max_depth () =
   let specimens = sample_terms ~count ~max_depth () in
   let failures, related =
     List.fold_left
       (fun (fails, ok) specimen ->
-        let compiled = Pipeline.compile flags specimen.ty specimen.term in
+        let cmp = comparison_for ~fuel flags relation specimen in
-        let cmp = Relation.compare_programs ~fuel relation specimen.ty specimen.term compiled.target_program in
         match cmp.verdict with
         | Relation.Related -> (fails, ok + 1)
-        | Relation.Unrelated _ -> ((specimen, cmp) :: fails, ok))
+        | Relation.Unrelated _ ->
+            let minimal, minimal_cmp = shrink_failure ~fuel flags relation specimen in
+            ({ original = specimen; minimal; comparison = minimal_cmp } :: fails, ok))
       ([], 0)
       specimens
   in

src/gen.mli

@@ -5,14 +5,26 @@ type specimen = {
   term : Source.term;
 }
 
+type failure = {
+  original : specimen;
+  minimal : specimen;
+  comparison : Relation.comparison;
+}
+
 type result = {
   total : int;
   related : int;
-  failures : (specimen * Relation.comparison) list;
+  failures : failure list;
 }
 
 val sample_terms : count:int -> max_depth:int -> unit -> specimen list
 val shrink : specimen -> specimen list
+val shrink_failure :
+  ?fuel:int ->
+  Pipeline.optimisation_flags ->
+  Relation.relation ->
+  specimen ->
+  specimen * Relation.comparison
 val run_campaign :
   ?fuel:int ->
   Pipeline.optimisation_flags ->
@@ -21,4 +33,3 @@ val run_campaign :
   max_depth:int ->
   unit ->
   result
-

src/vanity.ml

@@ -10,3 +10,4 @@ module Gen = Gen
 module Corpus = Corpus
 module Reporting = Reporting
 module Project = Project
+module Framework = Framework