From 1375a4cb037605097431ab1759d2afbf603301af Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Sun, 7 Dec 2025 14:26:23 -0800 Subject: [PATCH 01/85] Added parser backend CLI parameter Expose ability to use SANY Signed-off-by: Andrew Helwer --- src/params.ml | 3 +++ src/params.mli | 2 ++ src/tlapm_args.ml | 7 +++++++ 3 files changed, 12 insertions(+) diff --git a/src/params.ml b/src/params.ml index 0894bdea..f6ddfd6a 100644 --- a/src/params.ml +++ b/src/params.ml @@ -56,6 +56,9 @@ let prefer_stdlib = ref false (* If set to true, the TLAPM will prefer the modules from the STDLIB instead of modules with the same names in the search path. *) +type parser = | Tlapm | Sany +let parser_backend = ref Tlapm + let noproving = ref false (* Don't send any obligation to the back-ends. *) let printallobs = ref false diff --git a/src/params.mli b/src/params.mli index adf1ed3e..517d1d50 100644 --- a/src/params.mli +++ b/src/params.mli @@ -7,6 +7,8 @@ val toolbox: bool ref val toolbox_vsn: int ref val use_stdin: bool ref val prefer_stdlib: bool ref +type parser = | Tlapm | Sany +val parser_backend: parser ref (* expr/fmt.ml *) val debugging: string -> bool diff --git a/src/tlapm_args.ml b/src/tlapm_args.ml index 63acc4a5..374db660 100644 --- a/src/tlapm_args.ml +++ b/src/tlapm_args.ml @@ -49,6 +49,11 @@ let set_default_method meth = try set_default_method meth with Failure msg -> raise (Arg.Bad ("--method: " ^ msg)) +let set_parser_backend parser_str = + match String.lowercase_ascii parser_str with + | "sany" -> Params.parser_backend := Sany + | "tlapm" -> Params.parser_backend := Tlapm + | _ -> raise (Arg.Bad ("--parser: " ^ parser_str)) let parse_args executable_name args opts mods usage_fmt err terminate = try @@ -200,6 +205,8 @@ let init ?(out=Format.std_formatter) ?(err=Format.err_formatter) ?(terminate=exi "--prefer-stdlib", Arg.Set prefer_stdlib, " \ prefer built-in standard modules if the module search path \ contains files with the same names as modules in stdlib."; + "--parser", Arg.String set_parser_backend, " \ + Set parser backend to use: SANY or TLAPM."; "--noproving", Arg.Set noproving, " do not prove, report fingerprinted results only"; blank; From 4f0dae49bd3e2adc1e4ff9ee7d248cf7cb08ffbc Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Sun, 7 Dec 2025 16:57:17 -0800 Subject: [PATCH 02/85] Use SANY parse backend when indicated Propagate CLI parameter to Tlapm_lib Signed-off-by: Andrew Helwer --- src/sany.ml | 1 + src/sany.mli | 1 + src/tlapm_lib.ml | 10 ++++++++-- 3 files changed, 10 insertions(+), 2 deletions(-) create mode 100644 src/sany.ml create mode 100644 src/sany.mli diff --git a/src/sany.ml b/src/sany.ml new file mode 100644 index 00000000..c35697c2 --- /dev/null +++ b/src/sany.ml @@ -0,0 +1 @@ +let parse module_path = Result.Error (None, "TODO") diff --git a/src/sany.mli b/src/sany.mli new file mode 100644 index 00000000..fbbc51b2 --- /dev/null +++ b/src/sany.mli @@ -0,0 +1 @@ +val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result \ No newline at end of file diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index 4bd57a16..9a40f012 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -616,8 +616,7 @@ let init () = end; exit 3 -(* Access to this function has to be synchronized. *) -let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~prefer_stdlib : (modctx * Module.T.mule, string option * string) result = +let tlapm_modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~prefer_stdlib : (modctx * Module.T.mule, string option * string) result = let parse_it () = Errors.reset (); Params.prefer_stdlib := prefer_stdlib; @@ -652,6 +651,13 @@ let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~pre | Some l, None -> Error (Some l, Printexc.to_string e) | None, None -> Error (None, Printexc.to_string e)) + +(* Access to this function has to be synchronized. *) +let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~prefer_stdlib : (modctx * Module.T.mule, string option * string) result = + match !Params.parser_backend with + | Tlapm -> tlapm_modctx_of_string ~content ~filename ~loader_paths ~prefer_stdlib + | Sany -> Sany.parse filename + let module_of_string module_str = let hparse = Tla_parser.P.use Module.Parser.parse in let (flex, _) = Alexer.lex_string module_str in From 2973c8fcb8601d0d498c24c4dff41ec1412764bf Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Sun, 7 Dec 2025 18:00:22 -0800 Subject: [PATCH 03/85] Stubbed out SANY parse architecture Signed-off-by: Andrew Helwer --- src/sany.ml | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src/sany.ml b/src/sany.ml index c35697c2..6e0ab430 100644 --- a/src/sany.ml +++ b/src/sany.ml @@ -1 +1,24 @@ -let parse module_path = Result.Error (None, "TODO") +let source_to_sany_xml (module_path : string) : (string, int) result = + Error 1 + +type parsed_xml = unit +let parse_xml (xml_ast : string) : parsed_xml = () + +let convert_ast (ast : parsed_xml) : Module.T.modctx * Module.T.mule = + let open Util.Coll in + let open Property in + let open Module.T in + (Sm.empty, noprops { + name = noprops "Placeholder"; + extendees = []; + instancees = []; + body = []; + defdepth = 0; + stage = Parsed; + important = true + }) + +let parse module_path = + match module_path |> source_to_sany_xml with + | Error exit_code -> Error (None, Int.to_string exit_code) + | Ok xml_ast -> xml_ast |> parse_xml |> convert_ast |> Result.ok From f58b5d33b0a688f26119b7400af777fb52e39b2e Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Sun, 7 Dec 2025 19:30:13 -0800 Subject: [PATCH 04/85] Download tla2tools.jar during build Signed-off-by: Andrew Helwer --- deps/tla2tools.jar/Makefile | 11 +++++++++++ deps/tla2tools.jar/dune | 9 +++++++++ 2 files changed, 20 insertions(+) create mode 100644 deps/tla2tools.jar/Makefile create mode 100644 deps/tla2tools.jar/dune diff --git a/deps/tla2tools.jar/Makefile b/deps/tla2tools.jar/Makefile new file mode 100644 index 00000000..76a80f1f --- /dev/null +++ b/deps/tla2tools.jar/Makefile @@ -0,0 +1,11 @@ +TLA_TOOLS_JAR_URL=https://github.com/tlaplus/tlaplus/releases/download/v1.8.0/tla2tools.jar + +tla2tools.jar: + wget --progress=dot:giga $(TLA_TOOLS_JAR_URL) + +clean: + rm tla2sany.jar + +sany: tla2tools.jar + +.PHONY: sany clean diff --git a/deps/tla2tools.jar/dune b/deps/tla2tools.jar/dune new file mode 100644 index 00000000..1a580bfc --- /dev/null +++ b/deps/tla2tools.jar/dune @@ -0,0 +1,9 @@ +; Download SANY +(rule + (deps "Makefile") + (targets tla2tools.jar) + (action (run "make" "-C" "." "sany"))) + +(install + (section (site (tlapm backends))) + (files (tla2tools.jar as bin/tla2tools.jar))) From 408dc8e631d6c6c42c48dfa44cc645d4bacd4242 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 8 Dec 2025 16:27:51 -0800 Subject: [PATCH 05/85] Call SANY XML Exporter and capture XML output Signed-off-by: Andrew Helwer --- src/paths.ml | 20 +++++++++++++++----- src/paths.mli | 1 + src/sany.ml | 17 ++++++++++++++--- 3 files changed, 30 insertions(+), 8 deletions(-) diff --git a/src/paths.ml b/src/paths.ml index 7d03a34c..a48fa1e6 100644 --- a/src/paths.ml +++ b/src/paths.ml @@ -15,15 +15,25 @@ let backend_paths = let stdlib_paths = site_paths Setup_paths.Sites.stdlib [ "lib"; "tlapm"; "stdlib" ] +let backend_path_elems = + let site_bin bs = Filename.concat bs "bin" in + let site_isa bs = List.fold_left Filename.concat bs [ "Isabelle"; "bin" ] in + let site_paths bs = [ site_bin bs; site_isa bs ] in + List.concat (List.map site_paths backend_paths) + (** If the backends site is not available ([]), then look for executables in the PATH, otherwise we are in the dune-based build and should look for the backends in the specified site locations. *) let backend_path_string = - let site_bin bs = Filename.concat bs "bin" in - let site_isa bs = List.fold_left Filename.concat bs [ "Isabelle"; "bin" ] in - let site_paths bs = [ site_bin bs; site_isa bs ] in - let path_elems = List.concat (List.map site_paths backend_paths) in - Printf.sprintf "%s:%s" (String.concat ":" path_elems) (Sys.getenv "PATH") + let paths = String.concat ":" backend_path_elems in + try Printf.sprintf "%s:%s" paths (Sys.getenv "PATH") + with Not_found -> paths + + +let backend_classpath_string jar_file = + let classpath = List.map (fun path -> Filename.concat path jar_file) backend_path_elems |> String.concat ":" in + try Printf.sprintf "%s:%s" classpath (Sys.getenv "CLASSPATH") + with Not_found -> classpath let find_path_containing paths file = let find_actual path = Sys.file_exists (Filename.concat path file) in diff --git a/src/paths.mli b/src/paths.mli index c3cdab3a..54cc59f2 100644 --- a/src/paths.mli +++ b/src/paths.mli @@ -1,4 +1,5 @@ val backend_path_string : string +val backend_classpath_string : string -> string val backend_paths : string list val stdlib_paths : string list val find_path_containing : string list -> string -> string option diff --git a/src/sany.ml b/src/sany.ml index 6e0ab430..b98afed6 100644 --- a/src/sany.ml +++ b/src/sany.ml @@ -1,5 +1,16 @@ -let source_to_sany_xml (module_path : string) : (string, int) result = - Error 1 +let source_to_sany_xml (module_path : string) : (string, (string * int)) result = + let open Unix in + let open Paths in + let (stdout, stdin, stderr) = + Unix.open_process_args_full + "java" + [|"java"; "-cp"; backend_classpath_string "tla2tools.jar"; "tla2sany.xml.XMLExporter"; "-t"; module_path|] + (Unix.environment ()) + in let (output, err_output) = (In_channel.input_all stdout, In_channel.input_all stderr) in + match Unix.close_process_full (stdout, stdin, stderr) with + | WEXITED 0 -> Ok output + | WEXITED exit_code -> Error (output ^ err_output, exit_code) + | _ -> failwith "Process terminated abnormally" type parsed_xml = unit let parse_xml (xml_ast : string) : parsed_xml = () @@ -20,5 +31,5 @@ let convert_ast (ast : parsed_xml) : Module.T.modctx * Module.T.mule = let parse module_path = match module_path |> source_to_sany_xml with - | Error exit_code -> Error (None, Int.to_string exit_code) + | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) | Ok xml_ast -> xml_ast |> parse_xml |> convert_ast |> Result.ok From 7425938c738c8ee463cb88087f58512c4cf2c92c Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 8 Dec 2025 17:11:40 -0800 Subject: [PATCH 06/85] Integrate SANY XML processing code Added Xmlm library dependency Signed-off-by: Andrew Helwer --- dune-project | 1 + src/dune | 1 + src/sany.ml | 583 ++++++++++++++++++++++++++++++++++++++++++++++++++- tlapm.opam | 1 + 4 files changed, 580 insertions(+), 6 deletions(-) diff --git a/dune-project b/dune-project index 63304037..7ce0e2f0 100644 --- a/dune-project +++ b/dune-project @@ -51,6 +51,7 @@ ppx_inline_test ppx_assert ppx_deriving + xmlm ounit2) (depopts lsp ; https://github.com/ocaml/ocaml-lsp diff --git a/src/dune b/src/dune index 25ab6ca9..a52f191d 100644 --- a/src/dune +++ b/src/dune @@ -22,6 +22,7 @@ dune-site dune-build-info camlzip ; main deps. + xmlm sexplib) ; for inline tests only (ppx_assert). (foreign_stubs diff --git a/src/sany.ml b/src/sany.ml index b98afed6..bc28e314 100644 --- a/src/sany.ml +++ b/src/sany.ml @@ -9,13 +9,581 @@ let source_to_sany_xml (module_path : string) : (string, (string * int)) result in let (output, err_output) = (In_channel.input_all stdout, In_channel.input_all stderr) in match Unix.close_process_full (stdout, stdin, stderr) with | WEXITED 0 -> Ok output - | WEXITED exit_code -> Error (output ^ err_output, exit_code) + | WEXITED exit_code -> Error (output ^ "\n" ^ err_output, exit_code) | _ -> failwith "Process terminated abnormally" + +open Xmlm;; -type parsed_xml = unit -let parse_xml (xml_ast : string) : parsed_xml = () +type tree = + | Node of Xmlm.tag * tree list + | Value of string +[@@deriving show] -let convert_ast (ast : parsed_xml) : Module.T.modctx * Module.T.mule = +let parse_xml_str (xml_str: string) : tree = + let xml = Xmlm.make_input (`String (0, xml_str)) in + let el tag childs = Node (tag, childs) in + let data d = Value d in + Xmlm.input_doc_tree ~el ~data xml |> snd + +let conversion_failure fn_name xml = + let err_msg = Printf.sprintf "%s conversion failure on %s" fn_name (show_tree xml) in + Invalid_argument err_msg |> raise + +let is_tag (tag_name : string) (node : tree) = + match node with + | Node (((_, name), _), _) -> String.equal name tag_name + | _ -> false + +let children_of (xml : tree) = + match xml with + | Node (_, children) -> children + | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise + +let child_of (xml : tree) = + match xml with + | Node (_, [child]) -> child + | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise + | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise + +let show_tree_list (xs : tree list) = + Printf.sprintf "[%s]" (xs |> List.map show_tree |> String.concat "; ") + +let find_tag (tag_name : string) (children : tree list) = + match List.find_opt (is_tag tag_name) children with + | Some v -> v + | None -> Invalid_argument (Printf.sprintf "Unable to find tag %s in children %s" tag_name (show_tree_list children)) |> raise + +let xml_to_tagged_string (tag_name : string) (children : tree list) = + match find_tag tag_name children with + | (Node (_, [Value d])) -> d + | xml -> conversion_failure __FUNCTION__ xml + +let xml_child_to_int xml = + match xml with + | (Node (_, [Value d])) -> int_of_string d + | _ -> conversion_failure __FUNCTION__ xml + +let xml_to_tagged_int (tag_name : string) (children : tree list) = + find_tag tag_name children |> xml_child_to_int + +type range = { + start : int; + finish : int; +} +[@@deriving show] + +let xml_to_range xml = + match xml with + | Node (((_, _), _), children) -> { + start = children |> xml_to_tagged_int "begin"; + finish = children |> xml_to_tagged_int "end"; + } + | _ -> conversion_failure __FUNCTION__ xml + +type location = { + column : range; + line : range; + filename : string; +} +[@@deriving show] + +let xml_to_location xml = + match xml with + | Node (((_, "location"), _), children) -> { + column = children |> find_tag "column" |> xml_to_range; + line = children |> find_tag "line" |> xml_to_range; + filename = children |> xml_to_tagged_string "filename"; + } + | _ -> conversion_failure __FUNCTION__ xml + +type node = { + location : location option; + level : int option; +} +[@@deriving show] + +let xml_to_inline_node (children : tree list) = { + location = children |> List.find_opt (is_tag "location") |> Option.map xml_to_location; + level = children |> List.find_opt (is_tag "level") |> Option.map xml_child_to_int; +} + +type numeral_node = { + node : node; + value : int; +} +[@@deriving show] + +let xml_to_numeral_node (xml : tree) = + match xml with + | Node (((_, "NumeralNode"), _), children) -> { + node = children |> xml_to_inline_node; + value = children |> xml_to_tagged_int "IntValue" + } + | _ -> conversion_failure __FUNCTION__ xml + +type formal_param_node_ref = { + uid : int +} +[@@deriving show] + +let xml_to_formal_param_node_ref xml = + match xml with + | Node (((_, "FormalParamNodeRef"), _), children) -> { + uid = children |> xml_to_tagged_int "UID"; + } + | _ -> conversion_failure __FUNCTION__ xml + +type formal_param_node = { + node : node; + uniquename : string; + arity : int; +} +[@@deriving show] + +let xml_to_formal_param_node xml = + match xml with + | Node (((_, "FormalParamNode"), _), children) -> { + node = xml_to_inline_node children; + uniquename = xml_to_tagged_string "uniquename" children; + arity = xml_to_tagged_int "arity" children; + } + | _ -> conversion_failure __FUNCTION__ xml + +type unbound_symbol = { + formal_param_node_ref : formal_param_node_ref; + is_tuple : bool; +} +[@@deriving show] + +let xml_to_unbound_symbol xml = + match xml with + | Node (((_, "unbound"), _), children) -> { + formal_param_node_ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; + is_tuple = children |> List.exists (is_tag "tuple") + } + | _ -> conversion_failure __FUNCTION__ xml + +type op_appl_node = { + node : node; + operands : expr_or_op_arg list; + bound_symbols : symbols list; +} +[@@deriving show] + +and expression = +(*| AtNode of at_node*) +(*| DecimalNode of decimal_node*) +(*| LabelNode of label_node*) +(*| LetInNode of let_in_node*) + | NumeralNode of numeral_node + | OpApplNode of op_appl_node +(*| StringNode of string_node*) +(*| SubstInNode of subst_in_node*) +(*| TheoremDefRef of theorem_def_ref*) +(*| AssumeDefRef of assume_def_ref*) + +and expr_or_op_arg = + | Expression of expression +(*| OpArg of operator_arg*) + +and bound_symbol = { + formal_param_node_refs : formal_param_node_ref list; + is_tuple : bool; + expression : expression +} + +and symbols = + | Unbound of unbound_symbol + | Bound of bound_symbol +[@@deriving show] + +let rec xml_to_symbols xml = + match xml with + | Node (((_, "unbound"), _), _) -> Unbound (xml_to_unbound_symbol xml) + | Node (((_, "bound"), _), _) -> Bound (xml_to_bound_symbol xml) + | _ -> conversion_failure __FUNCTION__ xml + +and xml_to_bound_symbol xml = + match xml with + | Node (((_, "bound"), _), children) -> { + formal_param_node_refs = children |> List.filter (is_tag "FormalParamNodeRef") |> List.map xml_to_formal_param_node_ref; + is_tuple = children |> List.exists (is_tag "tuple"); + expression = children |> xml_to_inline_expression |> Option.get; + } + | _ -> conversion_failure __FUNCTION__ xml + +and xml_to_expr_or_op_arg xml = + try Expression (xml_to_expression xml) +with Invalid_argument _ -> conversion_failure __FUNCTION__ xml + +and xml_to_op_appl_node xml = + match xml with + | Node (((_, "OpApplNode"), _), children) -> { + node = children |> xml_to_inline_node; + operands = children |> find_tag "operands" |> children_of |> List.map xml_to_expr_or_op_arg; + bound_symbols = children |> List.find_opt (is_tag "boundSymbols") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; + } + | _ -> conversion_failure __FUNCTION__ xml + +and xml_to_expression xml = + match xml with + | Node (((_, "NumeralNode"), _), _) -> NumeralNode (xml_to_numeral_node xml) + | Node (((_, "OpApplNode"), _), _) -> OpApplNode (xml_to_op_appl_node xml) + | _ -> conversion_failure __FUNCTION__ xml + +and xml_to_inline_expression children = + children + |> List.find_opt (fun xml -> is_tag "NumeralNode" xml || is_tag "OpApplNode" xml) + |> Option.map xml_to_expression + +type module_node_ref = { + uid : int +} +[@@deriving show] + +let xml_to_module_node_ref xml = + match xml with + | Node (((_, "ModuleNodeRef"), _), children) -> { + uid = children |> xml_to_tagged_int "UID"; + } + | _ -> conversion_failure __FUNCTION__ xml + +type module_node = { + location : location; + uniquename : string +} +[@@deriving show] + +let xml_to_module_node xml = + match xml with + | Node (((_, "ModuleNode"), _), children) -> { + uniquename = children |> xml_to_tagged_string "uniquename"; + location = children |> find_tag "location" |> xml_to_location; + } + | _ -> conversion_failure __FUNCTION__ xml + +type op_decl_node = { + uniquename : string +} +[@@deriving show] + +let xml_to_op_decl_node (xml : tree) : op_decl_node = + match xml with + | Node (((_, "OpDeclNode"), _), children) -> ({ + uniquename = children |> xml_to_tagged_string "uniquename"; + } : op_decl_node) + | _ -> conversion_failure __FUNCTION__ xml + +type leibniz_param = { + ref : formal_param_node_ref; + is_leibniz : bool; +} +[@@deriving show] + +let xml_to_leibniz_param xml = + match xml with + | Node (((_, "leibnizparam"), _), children) -> { + ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; + is_leibniz = children |> List.exists (is_tag "leibniz"); + } + | _ -> conversion_failure __FUNCTION__ xml + +type user_defined_op_kind = { + node : node; + uniquename : string; + arity : int; + body : expression; + params : leibniz_param list; + recursive : bool; +} +[@@deriving show] + +let xml_to_user_defined_op_kind xml : user_defined_op_kind = + match xml with + | Node (((_, "UserDefinedOpKind"), _), children) -> { + node = children |> xml_to_inline_node; + uniquename = children |> xml_to_tagged_string "uniquename"; + arity = children |> xml_to_tagged_int "arity"; + body = children |> find_tag "body" |> child_of |> xml_to_expression; + params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; + recursive = children |> List.exists (is_tag "recursive"); + } + | _ -> conversion_failure __FUNCTION__ xml + +type user_defined_op_kind_ref = { + uid : int +} +[@@deriving show] + +let xml_to_user_defined_op_kind_ref xml = + match xml with + | Node (((_, "UserDefinedOpKindRef"), _), children) -> { + uid = children |> xml_to_tagged_int "UID"; + } + | _ -> conversion_failure __FUNCTION__ xml + + +type built_in_kind = { + uniquename : string +} +[@@deriving show] + +let xml_to_built_in_kind xml : built_in_kind = + match xml with + | Node (((_, "BuiltInKind"), _), children) -> { + uniquename = children |> xml_to_tagged_string "uniquename"; + } + | _ -> conversion_failure __FUNCTION__ xml + +type expr_or_assume_prove = + | Expression of expression +(*| AssumeProveLike of assume_prove_like*) +[@@deriving show] + +let xml_to_inline_expr_or_assume_prove children = + match xml_to_inline_expression children with + | Option.Some expr -> Option.Some (Expression expr) + | Option.None -> (*TODO: try-match assume-prove*) Option.None + +type theorem_def_node = { + node : node; + uniquename : string; + body : expr_or_assume_prove; +} +[@@deriving show] + +let xml_to_theorem_def_node xml = + match xml with + | Node (((_, "TheoremDefNode"), _), children) -> { + node = children |> xml_to_inline_node; + uniquename = children |> xml_to_tagged_string "uniquename"; + body = children |> xml_to_inline_expr_or_assume_prove |> Option.get ; + } + | _ -> conversion_failure __FUNCTION__ xml + +type theorem_def_ref = { + uid : int +} +[@@deriving show] + +let xml_to_theorem_def_ref xml = + match xml with + | Node (((_, "TheoremDefRef"), _), children) -> { + uid = xml_to_tagged_int "UID" children + } + | _ -> conversion_failure __FUNCTION__ xml + +type theorem_node_ref = { + uid : int +} +[@@deriving show] + +let xml_to_theorem_node_ref xml = + match xml with + | Node (((_, "TheoremNodeRef"), _), children) -> { + uid = xml_to_tagged_int "UID" children + } + | _ -> conversion_failure __FUNCTION__ xml + + +type omitted_proof_node = { + node : node +} +[@@deriving show] + +let xml_to_omitted_proof_node xml = + match xml with + | Node (((_, "omitted"), _), children) -> { + node = children |> xml_to_inline_node; + } + | _ -> conversion_failure __FUNCTION__ xml + +type obvious_proof_node = { + node : node +} +[@@deriving show] + +let xml_to_obvious_proof_node xml = + match xml with + | Node (((_, "obvious"), _), children) -> { + node = children |> xml_to_inline_node; + } + | _ -> conversion_failure __FUNCTION__ xml + +type definition_reference = + | UserDefinedOpKindRef of user_defined_op_kind_ref + | TheoremDefRef of theorem_def_ref +[@@deriving show] + +let xml_to_definition_reference xml = + match xml with + | Node (((_, "UserDefinedOpKindRef"), _), _) -> UserDefinedOpKindRef (xml_to_user_defined_op_kind_ref xml) + | Node (((_, "TheoremDefRef"), _), _) -> TheoremDefRef (xml_to_theorem_def_ref xml) + | _ -> conversion_failure __FUNCTION__ xml + +type by_proof_node = { + node : node; + facts : expression list; + defs : definition_reference list; +} +[@@deriving show] + +let xml_to_by_proof_node xml = + match xml with + | Node (((_, "by"), _), children) -> { + node = children |> xml_to_inline_node; + facts = children |> List.find_opt (is_tag "facts") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_expression; + defs = children |> List.find_opt (is_tag "defs") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_definition_reference; + } + | _ -> conversion_failure __FUNCTION__ xml + +type proof_step_group = + | TheoremNodeRef of theorem_node_ref +[@@deriving show] + +let xml_to_inline_list_proof_step_group children = + children + |> List.filter (is_tag "TheoremNodeRef") + |> List.map xml_to_theorem_node_ref + |> List.map (fun node -> TheoremNodeRef node) + +type steps_proof_node = { + node : node; + steps : proof_step_group list; +} +[@@deriving show] + +let xml_to_steps_proof_node xml = + match xml with + | Node (((_, "steps"), _), children) -> { + node = children |> xml_to_inline_node; + steps = children |> xml_to_inline_list_proof_step_group; + } + | _ -> conversion_failure __FUNCTION__ xml + +type proof_node_group = + | Omitted of omitted_proof_node + | Obvious of obvious_proof_node + | By of by_proof_node + | Steps of steps_proof_node +[@@deriving show] + +let xml_to_inline_proof_node_group children = + let rec search_children ls = + match ls with + | x::xs -> ( + match x with + | Node (((_, "omitted"), _), _) -> Omitted (xml_to_omitted_proof_node x) + | Node (((_, "obvious"), _), _) -> Obvious (xml_to_obvious_proof_node x) + | Node (((_, "by"), _), _) -> By (xml_to_by_proof_node x) + | Node (((_, "steps"), _), _) -> Steps (xml_to_steps_proof_node x) + | _ -> search_children xs + ) + | _ -> conversion_failure __FUNCTION__ (List.hd children) + in search_children children + +type theorem_node = { + node : node; + definition : theorem_def_ref option; + body : expr_or_assume_prove; + proof : proof_node_group; +} +[@@deriving show] + +let xml_to_theorem_node xml = + match xml with + | Node (((_, "TheoremNode"), _), children) -> { + node = children |> xml_to_inline_node; + definition = children |> List.find_opt (is_tag "definition") |> Option.map child_of |> Option.map xml_to_theorem_def_ref; + body = children |> find_tag "body" |> children_of |> xml_to_inline_expr_or_assume_prove |> Option.get; + proof = children |> xml_to_inline_proof_node_group; + } + | _ -> conversion_failure __FUNCTION__ xml + +type entry_kind = + | ModuleNode of module_node + | OpDeclNode of op_decl_node + | UserDefinedOpKind of user_defined_op_kind + | BuiltInKind of built_in_kind + | FormalParamNode of formal_param_node + | TheoremDefNode of theorem_def_node + | TheoremNode of theorem_node +[@@deriving show] + +let xml_to_entry_kind (children : tree list) = + let rec find_variant (candidates : tree list) = + match candidates with + | x :: xs -> ( + match x with + | Node (((_, "ModuleNode"), _), _) -> ModuleNode (xml_to_module_node x) + | Node (((_, "OpDeclNode"), _), _) -> OpDeclNode (xml_to_op_decl_node x) + | Node (((_, "UserDefinedOpKind"), _), _) -> UserDefinedOpKind (xml_to_user_defined_op_kind x) + | Node (((_, "BuiltInKind"), _), _) -> BuiltInKind (xml_to_built_in_kind x) + | Node (((_, "FormalParamNode"), _), _) -> FormalParamNode (xml_to_formal_param_node x) + | Node (((_, "TheoremDefNode"), _), _) -> TheoremDefNode (xml_to_theorem_def_node x) + | Node (((_, "TheoremNode"), _), _) -> TheoremNode (xml_to_theorem_node x) + | _ -> find_variant xs + ) + | [] -> Invalid_argument (Printf.sprintf "Unable to find entry_kind variant in children %s" (show_tree_list children)) |> raise + in find_variant children + +type entry = { + uid : int; + kind : entry_kind; +} +[@@deriving show] + +let xml_to_entry xml = + match xml with + | Node (((_, "entry"), _), children) -> { + uid = children |> xml_to_tagged_int "UID"; + kind = xml_to_entry_kind children; + } + | _ -> conversion_failure __FUNCTION__ xml + +type context = { + entry : entry list +} +[@@deriving show] + +let xml_to_context xml = + match xml with + | Node (((_, "context"), _), children) -> { + entry = children |> List.find_all (is_tag "entry") |> List.map xml_to_entry; + } + | _ -> conversion_failure __FUNCTION__ xml + +type modules = { + root_module: string; + context: context; + module_node_ref : module_node_ref list; + module_node : module_node list; +} +[@@deriving show] + +let xml_to_modules xml = + match xml with + | Node (((_, "modules"), _), children) -> { + root_module = xml_to_tagged_string "RootModule" children; + context = children |> find_tag "context" |> xml_to_context; + module_node_ref = children |> List.find_all (is_tag "ModuleNodeRef") |> List.map xml_to_module_node_ref; + module_node = children |> List.find_all (is_tag "ModuleNode") |> List.map xml_to_module_node; + } + | _ -> conversion_failure __FUNCTION__ xml + +let parse_xml (ast : tree) : (modules, (string * string)) result = + let prev_backtrace = Printexc.backtrace_status () in + if Params.debugging "sany" then Printexc.record_backtrace true; + try + let modules = xml_to_modules ast in + Printexc.record_backtrace prev_backtrace; + Result.ok modules + with Invalid_argument e -> + let trace = Printexc.get_backtrace () in + Printexc.record_backtrace prev_backtrace; + Result.error (e, trace) + +let convert_ast (ast : modules) : Module.T.modctx * Module.T.mule = let open Util.Coll in let open Property in let open Module.T in @@ -29,7 +597,10 @@ let convert_ast (ast : parsed_xml) : Module.T.modctx * Module.T.mule = important = true }) -let parse module_path = +let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = match module_path |> source_to_sany_xml with | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) - | Ok xml_ast -> xml_ast |> parse_xml |> convert_ast |> Result.ok + | Ok xml_str -> + match xml_str |> parse_xml_str |> parse_xml with + | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) + | Ok ast -> ast |> convert_ast |> Result.ok diff --git a/tlapm.opam b/tlapm.opam index 872eb93f..b3fcbe68 100644 --- a/tlapm.opam +++ b/tlapm.opam @@ -38,6 +38,7 @@ depends: [ "ppx_inline_test" "ppx_assert" "ppx_deriving" + "xmlm" "ounit2" "odoc" {with-doc} ] From fb1aff0640df5a68d38437bb549e718ff8c2ccfc Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 18 Dec 2025 15:54:22 -0800 Subject: [PATCH 07/85] Write some tests to explore prototype Signed-off-by: Andrew Helwer --- test/sany/Test.tla | 4 ++++ test/sany/dune | 7 +++++++ test/sany/sany_tests.ml | 9 +++++++++ test/semantics/Test.tla | 4 ++++ test/semantics/dune | 7 +++++++ test/semantics/semantic_tests.ml | 21 +++++++++++++++++++++ 6 files changed, 52 insertions(+) create mode 100644 test/sany/Test.tla create mode 100644 test/sany/dune create mode 100644 test/sany/sany_tests.ml create mode 100644 test/semantics/Test.tla create mode 100644 test/semantics/dune create mode 100644 test/semantics/semantic_tests.ml diff --git a/test/sany/Test.tla b/test/sany/Test.tla new file mode 100644 index 00000000..896f7532 --- /dev/null +++ b/test/sany/Test.tla @@ -0,0 +1,4 @@ +---- MODULE Test ---- +EXTENDS Naturals +==== + diff --git a/test/sany/dune b/test/sany/dune new file mode 100644 index 00000000..759e9504 --- /dev/null +++ b/test/sany/dune @@ -0,0 +1,7 @@ +(test + (name sany_tests) + (modes exe) + (libraries tlapm_lib ounit2 sexplib sexp_diff) + (deps Test.tla) + (preprocess (pps ppx_deriving.show)) +) diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml new file mode 100644 index 00000000..33d80659 --- /dev/null +++ b/test/sany/sany_tests.ml @@ -0,0 +1,9 @@ +open Tlapm_lib;; +open Tlapm_lib__Params;; + +let _ = + parser_backend := Sany; + add_debug_flag "sany"; + match modctx_of_string ~content:"" ~filename:"Test.tla" ~loader_paths:[] ~prefer_stdlib:true with + | Error (_, msg) -> print_endline msg + | Ok _ -> print_endline "success" diff --git a/test/semantics/Test.tla b/test/semantics/Test.tla new file mode 100644 index 00000000..896f7532 --- /dev/null +++ b/test/semantics/Test.tla @@ -0,0 +1,4 @@ +---- MODULE Test ---- +EXTENDS Naturals +==== + diff --git a/test/semantics/dune b/test/semantics/dune new file mode 100644 index 00000000..33fe921a --- /dev/null +++ b/test/semantics/dune @@ -0,0 +1,7 @@ +(test + (name semantic_tests) + (modes exe) + (libraries tlapm_lib ounit2) + (deps Test.tla) + (preprocess (pps ppx_deriving.show)) +) diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml new file mode 100644 index 00000000..84ab77f6 --- /dev/null +++ b/test/semantics/semantic_tests.ml @@ -0,0 +1,21 @@ +open Tlapm_lib;; +open Tlapm_lib__Util;; + +let _ = + let filename = "Test.tla" in + let file_channel = open_in filename in + let content = In_channel.input_all file_channel in + close_in file_channel; + match modctx_of_string + ~content + ~filename + ~loader_paths:[] + ~prefer_stdlib:true + with + | Ok (mcx, _mule) -> + Coll.Sm.iter (fun modname _modtree -> print_endline modname) mcx; + | Error (Some msg, msg2) -> + print_endline msg; + print_endline msg2; + | Error (None, msg) -> + print_endline msg; \ No newline at end of file From 04ab246877be94fa175c075650725b9b85a0ac2d Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 26 Dec 2025 11:40:54 -0800 Subject: [PATCH 08/85] Reorganized SANY code into its own module Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 18 ++++++++++++++++++ src/{ => sany}/sany.mli | 0 src/{sany.ml => sany/xml.ml} | 37 +++++++++++------------------------- 3 files changed, 29 insertions(+), 26 deletions(-) create mode 100644 src/sany/sany.ml rename src/{ => sany}/sany.mli (100%) rename src/{sany.ml => sany/xml.ml} (94%) diff --git a/src/sany/sany.ml b/src/sany/sany.ml new file mode 100644 index 00000000..dbc01cc3 --- /dev/null +++ b/src/sany/sany.ml @@ -0,0 +1,18 @@ +let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = + let open Util.Coll in + let open Property in + let open Module.T in + (Sm.empty, noprops { + name = noprops "Placeholder"; + extendees = []; + instancees = []; + body = []; + defdepth = 0; + stage = Parsed; + important = true + }) + +let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = + match module_path |> Xml.get_module_ast_xml with + | Error msg -> Error (None, msg) + | Ok ast -> ast |> convert_ast |> Result.ok diff --git a/src/sany.mli b/src/sany/sany.mli similarity index 100% rename from src/sany.mli rename to src/sany/sany.mli diff --git a/src/sany.ml b/src/sany/xml.ml similarity index 94% rename from src/sany.ml rename to src/sany/xml.ml index bc28e314..63dc652d 100644 --- a/src/sany.ml +++ b/src/sany/xml.ml @@ -1,4 +1,4 @@ -let source_to_sany_xml (module_path : string) : (string, (string * int)) result = +let source_to_sany_xml_str (module_path : string) : (string, (string * int)) result = let open Unix in let open Paths in let (stdout, stdin, stderr) = @@ -11,7 +11,7 @@ let source_to_sany_xml (module_path : string) : (string, (string * int)) result | WEXITED 0 -> Ok output | WEXITED exit_code -> Error (output ^ "\n" ^ err_output, exit_code) | _ -> failwith "Process terminated abnormally" - + open Xmlm;; type tree = @@ -19,7 +19,7 @@ type tree = | Value of string [@@deriving show] -let parse_xml_str (xml_str: string) : tree = +let str_to_xml (xml_str: string) : tree = let xml = Xmlm.make_input (`String (0, xml_str)) in let el tag childs = Node (tag, childs) in let data d = Value d in @@ -321,7 +321,6 @@ let xml_to_user_defined_op_kind_ref xml = uid = children |> xml_to_tagged_int "UID"; } | _ -> conversion_failure __FUNCTION__ xml - type built_in_kind = { uniquename : string @@ -571,11 +570,11 @@ let xml_to_modules xml = } | _ -> conversion_failure __FUNCTION__ xml -let parse_xml (ast : tree) : (modules, (string * string)) result = +let xml_to_ast (xml : tree) : (modules, (string * string)) result = let prev_backtrace = Printexc.backtrace_status () in if Params.debugging "sany" then Printexc.record_backtrace true; try - let modules = xml_to_modules ast in + let modules = xml_to_modules xml in Printexc.record_backtrace prev_backtrace; Result.ok modules with Invalid_argument e -> @@ -583,24 +582,10 @@ let parse_xml (ast : tree) : (modules, (string * string)) result = Printexc.record_backtrace prev_backtrace; Result.error (e, trace) -let convert_ast (ast : modules) : Module.T.modctx * Module.T.mule = - let open Util.Coll in - let open Property in - let open Module.T in - (Sm.empty, noprops { - name = noprops "Placeholder"; - extendees = []; - instancees = []; - body = []; - defdepth = 0; - stage = Parsed; - important = true - }) - -let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - match module_path |> source_to_sany_xml with - | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) +let get_module_ast_xml (module_path : string) : (modules, string) result = + match module_path |> source_to_sany_xml_str with + | Error (output, exit_code) -> Error (Printf.sprintf "%d\n%s" exit_code output) | Ok xml_str -> - match xml_str |> parse_xml_str |> parse_xml with - | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) - | Ok ast -> ast |> convert_ast |> Result.ok + match xml_str |> str_to_xml |> xml_to_ast with + | Error (msg, trace) -> Error (Printf.sprintf "%s\n%s" msg trace) + | Ok ast -> ast |> Result.ok From ff84fb03267649196349d271dc4f51d48df17464 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 30 Dec 2025 12:32:00 -0800 Subject: [PATCH 09/85] Started conversion code Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 36 +++++++++++++++++++++++++++++++----- 1 file changed, 31 insertions(+), 5 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index dbc01cc3..44a5bb7d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,16 +1,42 @@ -let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = - let open Util.Coll in +let convert_module_node (mule : Xml.module_node) : Module.T.mule = let open Property in let open Module.T in - (Sm.empty, noprops { - name = noprops "Placeholder"; + noprops { + name = noprops mule.uniquename; extendees = []; instancees = []; body = []; defdepth = 0; stage = Parsed; important = true - }) + } + +let convert_entry (entry : Xml.entry) : Module.T.modunit = + let open Property in + let open Module.T in + match entry.kind with + | ModuleNode mule -> () + | OpDeclNode op_decl_node -> () + | UserDefinedOpKind user_defined_op_kind -> () + | BuiltInKind built_in_kind -> () + | FormalParamNode formal_param_node -> () + | TheoremDefNode theorem_def_node -> () + | TheoremNode theorem_node -> () + +let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = + let open Property in + let open Module.T in + let context = Util.Coll.Sm.empty in + let _root_module_location = (List.find (fun (m : Xml.module_node) -> m.uniquename = ast.root_module) ast.module_node).location in + let root_module = noprops { + name = noprops ast.root_module; + extendees = []; + instancees = []; + body = List.map convert_entry ast.context.entry; + defdepth = 0; + stage = Parsed; + important = true + } in (context, root_module) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = match module_path |> Xml.get_module_ast_xml with From d08e56764175990f9293ff4a127ac487c4248296 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 30 Dec 2025 17:05:15 -0800 Subject: [PATCH 10/85] Translation cont'd Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 70 +- src/sany/xml.ml | 33 +- test/sany/AddTwo.tla | 30 + test/sany/AddTwo.xml | 9492 ++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 9604 insertions(+), 21 deletions(-) create mode 100644 test/sany/AddTwo.tla create mode 100644 test/sany/AddTwo.xml diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 44a5bb7d..1012aa73 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,38 +1,70 @@ -let convert_module_node (mule : Xml.module_node) : Module.T.mule = - let open Property in - let open Module.T in - noprops { +open Property;; +open Module.T;; + +let convert_location (location : Xml.location) : Loc.locus = { + start = Actual { + line = location.line.start; + bol = 0; + col = location.column.start; + }; + stop = Actual { + line = location.line.finish; + bol = 0; + col = location.column.finish; + }; + file = location.filename; +} + +let convert_unit_ref (entry_map : Xml.entry_kind Util.Coll.Im.t) (unit_ref : Xml.unit_kind) : modunit = () + +let convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.modunit = + let loc = convert_location mule.location in + Util.locate (Submod (Util.locate { name = noprops mule.uniquename; extendees = []; instancees = []; - body = []; + body = List.map (convert_unit_ref entry_map) mule.units; defdepth = 0; stage = Parsed; important = true - } + } loc)) loc + +let convert_op_decl_node (op_decl_node : Xml.op_decl_node) : Module.T.modunit = () + +let convert_user_defined_op_kind (user_defined_op_kind : Xml.user_defined_op_kind) : Module.T.modunit = () + +let convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = () + +let convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = () + +let convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = () + +let convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = () -let convert_entry (entry : Xml.entry) : Module.T.modunit = - let open Property in - let open Module.T in +let convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = match entry.kind with - | ModuleNode mule -> () - | OpDeclNode op_decl_node -> () - | UserDefinedOpKind user_defined_op_kind -> () - | BuiltInKind built_in_kind -> () - | FormalParamNode formal_param_node -> () - | TheoremDefNode theorem_def_node -> () - | TheoremNode theorem_node -> () + | ModuleNode mule -> convert_module_node entry_map mule + | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node + | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind + | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind + | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node + | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node + | TheoremNode theorem_node -> convert_theorem_node theorem_node let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = - let open Property in - let open Module.T in + let entry_map = + List.fold_left + (fun m (e : Xml.entry) -> Util.Coll.Im.add e.uid e.kind m) + Util.Coll.Im.empty + ast.context.entry + in let context = Util.Coll.Sm.empty in let _root_module_location = (List.find (fun (m : Xml.module_node) -> m.uniquename = ast.root_module) ast.module_node).location in let root_module = noprops { name = noprops ast.root_module; extendees = []; instancees = []; - body = List.map convert_entry ast.context.entry; + body = List.map (convert_entry entry_map) ast.context.entry; defdepth = 0; stage = Parsed; important = true diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 63dc652d..5d159643 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -63,7 +63,7 @@ let xml_child_to_int xml = | (Node (_, [Value d])) -> int_of_string d | _ -> conversion_failure __FUNCTION__ xml -let xml_to_tagged_int (tag_name : string) (children : tree list) = +let xml_to_tagged_int (tag_name : string) (children : tree list) : int = find_tag tag_name children |> xml_child_to_int type range = { @@ -248,9 +248,37 @@ let xml_to_module_node_ref xml = } | _ -> conversion_failure __FUNCTION__ xml +type unit_kind = + | OpDeclNodeRef of int + | ModuleInstanceKindRef of int + | UserDefinedOpKindRef of int + | BuiltInKindRef of int + | TheoremDefRef of int + | AssumeDefRef of int + | AssumeNodeRef of int + (* TODO + | InstanceNode + | UseOrHideNode + *) + | TheoremNodeRef of int +[@@deriving show] + +let xml_to_unit_kind (xml : tree) : unit_kind = + match xml with + | Node (((_, "OpDeclNodeRef"), _), children) -> OpDeclNodeRef (children |> xml_to_tagged_int "UID") + | Node (((_, "ModuleInstanceKindRef"), _), children) -> ModuleInstanceKindRef (children |> xml_to_tagged_int "UID") + | Node (((_, "UserDefinedOpKindRef"), _), children) -> UserDefinedOpKindRef (children |> xml_to_tagged_int "UID") + | Node (((_, "BuiltInKindRef"), _), children) -> BuiltInKindRef (children |> xml_to_tagged_int "UID") + | Node (((_, "TheoremDefRef"), _), children) -> TheoremDefRef (children |> xml_to_tagged_int "UID") + | Node (((_, "AssumeDefRef"), _), children) -> AssumeDefRef (children |> xml_to_tagged_int "UID") + | Node (((_, "AssumeNodeRef"), _), children) -> AssumeNodeRef (children |> xml_to_tagged_int "UID") + | Node (((_, "TheoremNodeRef"), _), children) -> TheoremNodeRef (children |> xml_to_tagged_int "UID") + | _ -> conversion_failure __FUNCTION__ xml + type module_node = { location : location; - uniquename : string + uniquename : string; + units : unit_kind list; } [@@deriving show] @@ -259,6 +287,7 @@ let xml_to_module_node xml = | Node (((_, "ModuleNode"), _), children) -> { uniquename = children |> xml_to_tagged_string "uniquename"; location = children |> find_tag "location" |> xml_to_location; + units = List.map xml_to_unit_kind children } | _ -> conversion_failure __FUNCTION__ xml diff --git a/test/sany/AddTwo.tla b/test/sany/AddTwo.tla new file mode 100644 index 00000000..fffa3796 --- /dev/null +++ b/test/sany/AddTwo.tla @@ -0,0 +1,30 @@ +------------------------------ MODULE AddTwo -------------------------------- +EXTENDS Naturals, TLAPS + +VARIABLE x + +vars == <> + +TypeOK == x \in Nat + +Init == x = 0 + +Next == x' = x + 2 + +Spec == Init /\ [][Next]_vars + +a|b == \E c \in Nat : a*c = b + +Even == 2|x + +THEOREM Spec => []Even + <1>a. Init => Even + BY DEF Init, Even, | + <1>b. Even /\ UNCHANGED vars => Even' + BY DEF Even, vars + <1>c. Even /\ Next => Even' + BY \A c \in Nat : c+1 \in Nat /\ 2*(c+1) = 2*c + 2, Zenon + DEF TypeOK, Even, Next, | + <1> QED BY PTL, <1>a, <1>b, <1>c DEF Spec + +============================================================================= diff --git a/test/sany/AddTwo.xml b/test/sany/AddTwo.xml new file mode 100644 index 00000000..da872f07 --- /dev/null +++ b/test/sany/AddTwo.xml @@ -0,0 +1,9492 @@ + + + AddTwo + + + 512 + + + + 1 + 26 + + + 229 + 229 + + TLAPS + + 0 + SlowSimplification + 0 + + + + + 23 + 26 + + + 229 + 229 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 514 + + + + 1 + 29 + + + 231 + 231 + + TLAPS + + 0 + SlowerSimplification + 0 + + + + + 26 + 29 + + + 231 + 231 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 516 + + + + 1 + 29 + + + 233 + 233 + + TLAPS + + 0 + SlowestSimplification + 0 + + + + + 26 + 29 + + + 233 + 233 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 518 + + + + 1 + 13 + + + 246 + 246 + + TLAPS + + 0 + Blast + 0 + + + + + 10 + 13 + + + 246 + 246 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 520 + + + + 1 + 17 + + + 247 + 247 + + TLAPS + + 0 + SlowBlast + 0 + + + + + 14 + 17 + + + 247 + 247 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 522 + + + + 1 + 19 + + + 248 + 248 + + TLAPS + + 0 + SlowerBlast + 0 + + + + + 16 + 19 + + + 248 + 248 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 524 + + + + 1 + 20 + + + 249 + 249 + + TLAPS + + 0 + SlowestBlast + 0 + + + + + 17 + 20 + + + 249 + 249 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 526 + + + + 1 + 17 + + + 251 + 251 + + TLAPS + + 0 + AutoBlast + 0 + + + + + 14 + 17 + + + 251 + 251 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 528 + + + + 1 + 18 + + + 265 + 265 + + TLAPS + + 0 + AllProvers + 0 + + + + + 15 + 18 + + + 265 + 265 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 529 + + + + 13 + 13 + + + 280 + 280 + + TLAPS + + X + 0 + + + + 531 + + + + 1 + 22 + + + 280 + 280 + + TLAPS + + 0 + AllProversT + 1 + + + + + 19 + 22 + + + 280 + 280 + + TLAPS + + 0 + + + 152 + + + + + + + + + 529 + + + + + + + + 533 + + + + 1 + 14 + + + 296 + 296 + + TLAPS + + 0 + AllSMT + 0 + + + + + 11 + 14 + + + 296 + 296 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 534 + + + + 9 + 9 + + + 303 + 303 + + TLAPS + + X + 0 + + + + 536 + + + + 1 + 18 + + + 303 + 303 + + TLAPS + + 0 + AllSMTT + 1 + + + + + 15 + 18 + + + 303 + 303 + + TLAPS + + 0 + + + 152 + + + + + + + + + 534 + + + + + + + + 538 + + + + 1 + 14 + + + 311 + 311 + + TLAPS + + 0 + AllIsa + 0 + + + + + 11 + 14 + + + 311 + 311 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 539 + + + + 9 + 9 + + + 319 + 319 + + TLAPS + + X + 0 + + + + 541 + + + + 1 + 18 + + + 319 + 319 + + TLAPS + + 0 + AllIsaT + 1 + + + + + 15 + 18 + + + 319 + 319 + + TLAPS + + 0 + + + 152 + + + + + + + + + 539 + + + + + + + + 543 + + + + 1 + 21 + + + 343 + 343 + + TLAPS + + 0 + ExpandENABLED + 0 + + + + + 18 + 21 + + + 343 + 343 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 545 + + + + 1 + 18 + + + 344 + 344 + + TLAPS + + 0 + ExpandCdot + 0 + + + + + 15 + 18 + + + 344 + 344 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 547 + + + + 1 + 15 + + + 345 + 345 + + TLAPS + + 0 + AutoUSE + 0 + + + + + 12 + 15 + + + 345 + 345 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 549 + + + + 1 + 16 + + + 346 + 346 + + TLAPS + + 0 + Lambdify + 0 + + + + + 13 + 16 + + + 346 + 346 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 551 + + + + 1 + 21 + + + 347 + 347 + + TLAPS + + 0 + ENABLEDaxioms + 0 + + + + + 18 + 21 + + + 347 + 347 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 553 + + + + 1 + 23 + + + 348 + 348 + + TLAPS + + 0 + LevelComparison + 0 + + + + + 20 + 23 + + + 348 + 348 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 554 + + + + 16 + 20 + + + 352 + 352 + + TLAPS + + Op + 1 + + + + 556 + + + + 1 + 30 + + + 352 + 352 + + TLAPS + + 0 + EnabledWrapper + 1 + + + + + 26 + 30 + + + 352 + 352 + + TLAPS + + 0 + + + 151 + + + + + + + + + 554 + + + + + + + + 557 + + + + 13 + 17 + + + 353 + 353 + + TLAPS + + Op + 1 + + + + 559 + + + + 1 + 27 + + + 353 + 353 + + TLAPS + + 0 + CdotWrapper + 1 + + + + + 23 + 27 + + + 353 + 353 + + TLAPS + + 0 + + + 151 + + + + + + + + + 557 + + + + + + + + 561 + + + + 1 + 15 + + + 359 + 359 + + TLAPS + + 0 + Trivial + 0 + + + + + 12 + 15 + + + 359 + 359 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 566 + + + + 1 + 77 + + + 1 + 30 + + AddTwo + + AddTwo + + 567 + + + 306 + + + 312 + + + 322 + + + 326 + + + 332 + + + 338 + + + 344 + + + 350 + + + 356 + + + 362 + + + 368 + + + 374 + + + 381 + + + 383 + + + 386 + + + 388 + + + 391 + + + 393 + + + 396 + + + 398 + + + 401 + + + 403 + + + 406 + + + 408 + + + 411 + + + 413 + + + 416 + + + 418 + + + 421 + + + 423 + + + 426 + + + 428 + + + 430 + + + 433 + + + 435 + + + 438 + + + 441 + + + 445 + + + 447 + + + 478 + + + 480 + + + 482 + + + 484 + + + 486 + + + 488 + + + 490 + + + 492 + + + 494 + + + 496 + + + 498 + + + 500 + + + 502 + + + 504 + + + 506 + + + 508 + + + 510 + + + 512 + + + 514 + + + 516 + + + 518 + + + 520 + + + 522 + + + 524 + + + 526 + + + 528 + + + 531 + + + 533 + + + 536 + + + 538 + + + 541 + + + 543 + + + 545 + + + 547 + + + 549 + + + 551 + + + 553 + + + 556 + + + 559 + + + 561 + + + 570 + + + 574 + + + 578 + + + 585 + + + 592 + + + 603 + + + 607 + + + 466 + + + 476 + + + 670 + + + + + 567 + + + + 10 + 10 + + + 4 + 4 + + AddTwo + + 1 + x + 0 + 3 + + + + 570 + + + + 1 + 13 + + + 6 + 6 + + AddTwo + + 1 + vars + 0 + + + + + 9 + 13 + + + 6 + 6 + + AddTwo + + 1 + + + 275 + + + + + + + 11 + 11 + + + 6 + 6 + + AddTwo + + 1 + + + 567 + + + + + + + + + + + + 574 + + + + 1 + 19 + + + 8 + 8 + + AddTwo + + 1 + TypeOK + 0 + + + + + 11 + 19 + + + 8 + 8 + + AddTwo + + 1 + + + 190 + + + + + + + 11 + 11 + + + 8 + 8 + + AddTwo + + 1 + + + 567 + + + + + + + + 17 + 19 + + + 8 + 8 + + AddTwo + + 0 + + + 306 + + + + + + + + + + + + 578 + + + + 1 + 13 + + + 10 + 10 + + AddTwo + + 1 + Init + 0 + + + + + 9 + 13 + + + 10 + 10 + + AddTwo + + 1 + + + 154 + + + + + + + 9 + 9 + + + 10 + 10 + + AddTwo + + 1 + + + 567 + + + + + + + + 13 + 13 + + + 10 + 10 + + AddTwo + + 0 + 0 + + + + + + + + + 585 + + + + 1 + 18 + + + 12 + 12 + + AddTwo + + 2 + Next + 0 + + + + + 9 + 18 + + + 12 + 12 + + AddTwo + + 2 + + + 154 + + + + + + + 9 + 10 + + + 12 + 12 + + AddTwo + + 2 + + + 163 + + + + + + + 9 + 9 + + + 12 + 12 + + AddTwo + + 1 + + + 567 + + + + + + + + + + 14 + 18 + + + 12 + 12 + + AddTwo + + 1 + + + 312 + + + + + + + 14 + 14 + + + 12 + 12 + + AddTwo + + 1 + + + 567 + + + + + + + + 18 + 18 + + + 12 + 12 + + AddTwo + + 0 + 2 + + + + + + + + + + + 592 + + + + 1 + 29 + + + 14 + 14 + + AddTwo + + 3 + Spec + 0 + + + + + 9 + 29 + + + 14 + 14 + + AddTwo + + 3 + + + 169 + + + + + + + 9 + 12 + + + 14 + 14 + + AddTwo + + 1 + + + 578 + + + + + + + + 17 + 29 + + + 14 + 14 + + AddTwo + + 3 + + + 211 + + + + + + + 19 + 29 + + + 14 + 14 + + AddTwo + + 2 + + + 263 + + + + + + + 20 + 23 + + + 14 + 14 + + AddTwo + + 2 + + + 585 + + + + + + + + 26 + 29 + + + 14 + 14 + + AddTwo + + 1 + + + 570 + + + + + + + + + + + + + + + + 593 + + + + 1 + 1 + + + 16 + 16 + + AddTwo + + 0 + a + 0 + + + + 594 + + + + 3 + 3 + + + 16 + 16 + + AddTwo + + 0 + b + 0 + + + + 596 + + + + 11 + 11 + + + 16 + 16 + + AddTwo + + 0 + c + 0 + + + + 603 + + + + 1 + 29 + + + 16 + 16 + + AddTwo + + 0 + | + 2 + + + + + 8 + 29 + + + 16 + 16 + + AddTwo + + 0 + + + 229 + + + + + + + 23 + 29 + + + 16 + 16 + + AddTwo + + 0 + + + 154 + + + + + + + 23 + 25 + + + 16 + 16 + + AddTwo + + 0 + + + 326 + + + + + + + 23 + 23 + + + 16 + 16 + + AddTwo + + 0 + + + 593 + + + + + + + + 25 + 25 + + + 16 + 16 + + AddTwo + + 0 + + + 596 + + + + + + + + + + 29 + 29 + + + 16 + 16 + + AddTwo + + 0 + + + 594 + + + + + + + + + + + 596 + + + + + 17 + 19 + + + 16 + 16 + + AddTwo + + 0 + + + 306 + + + + + + + + + + + + 593 + + + + + + 594 + + + + + + + + 607 + + + + 1 + 11 + + + 18 + 18 + + AddTwo + + 1 + Even + 0 + + + + + 9 + 11 + + + 18 + 18 + + AddTwo + + 1 + + + 603 + + + + + + + 9 + 9 + + + 18 + 18 + + AddTwo + + 0 + 2 + + + + + 11 + 11 + + + 18 + 18 + + AddTwo + + 1 + + + 567 + + + + + + + + + + + + 612 + + + + 3 + 7 + + + 21 + 21 + + AddTwo + + 1 + <1>a + + + + 9 + 20 + + + 21 + 21 + + AddTwo + + 1 + + + 178 + + + + + + + 9 + 12 + + + 21 + 21 + + AddTwo + + 1 + + + 578 + + + + + + + + 17 + 20 + + + 21 + 21 + + AddTwo + + 1 + + + 607 + + + + + + + + + + 618 + + + + 3 + 24 + + + 21 + 22 + + AddTwo + + 1 + + + 612 + + + + + + + 9 + 20 + + + 21 + 21 + + AddTwo + + 1 + + + 178 + + + + + + + 9 + 12 + + + 21 + 21 + + AddTwo + + 1 + + + 578 + + + + + + + + 17 + 20 + + + 21 + 21 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + 5 + 24 + + + 22 + 22 + + AddTwo + + 0 + + + + 578 + + + 607 + + + 603 + + + + + + + 619 + + + + 3 + 7 + + + 23 + 23 + + AddTwo + + 2 + <1>b + + + + 9 + 39 + + + 23 + 23 + + AddTwo + + 2 + + + 178 + + + + + + + 9 + 30 + + + 23 + 23 + + AddTwo + + 2 + + + 169 + + + + + + + 9 + 12 + + + 23 + 23 + + AddTwo + + 1 + + + 607 + + + + + + + + 17 + 30 + + + 23 + 23 + + AddTwo + + 2 + + + 217 + + + + + + + 27 + 30 + + + 23 + 23 + + AddTwo + + 1 + + + 570 + + + + + + + + + + + + 35 + 39 + + + 23 + 23 + + AddTwo + + 2 + + + 163 + + + + + + + 35 + 38 + + + 23 + 23 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + 629 + + + + 3 + 21 + + + 23 + 24 + + AddTwo + + 2 + + + 619 + + + + + + + 9 + 39 + + + 23 + 23 + + AddTwo + + 2 + + + 178 + + + + + + + 9 + 30 + + + 23 + 23 + + AddTwo + + 2 + + + 169 + + + + + + + 9 + 12 + + + 23 + 23 + + AddTwo + + 1 + + + 607 + + + + + + + + 17 + 30 + + + 23 + 23 + + AddTwo + + 2 + + + 217 + + + + + + + 27 + 30 + + + 23 + 23 + + AddTwo + + 1 + + + 570 + + + + + + + + + + + + 35 + 39 + + + 23 + 23 + + AddTwo + + 2 + + + 163 + + + + + + + 35 + 38 + + + 23 + 23 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + + 5 + 21 + + + 24 + 24 + + AddTwo + + 0 + + + + 607 + + + 570 + + + + + + + 630 + + + + 3 + 7 + + + 25 + 25 + + AddTwo + + 2 + <1>c + + + + 9 + 29 + + + 25 + 25 + + AddTwo + + 2 + + + 178 + + + + + + + 9 + 20 + + + 25 + 25 + + AddTwo + + 2 + + + 169 + + + + + + + 9 + 12 + + + 25 + 25 + + AddTwo + + 1 + + + 607 + + + + + + + + 17 + 20 + + + 25 + 25 + + AddTwo + + 2 + + + 585 + + + + + + + + + + 25 + 29 + + + 25 + 25 + + AddTwo + + 2 + + + 163 + + + + + + + 25 + 28 + + + 25 + 25 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + 638 + + + + 11 + 11 + + + 26 + 26 + + AddTwo + + 0 + c + 0 + + + + 660 + + + + 3 + 29 + + + 25 + 27 + + AddTwo + + 2 + + + 630 + + + + + + + 9 + 29 + + + 25 + 25 + + AddTwo + + 2 + + + 178 + + + + + + + 9 + 20 + + + 25 + 25 + + AddTwo + + 2 + + + 169 + + + + + + + 9 + 12 + + + 25 + 25 + + AddTwo + + 1 + + + 607 + + + + + + + + 17 + 20 + + + 25 + 25 + + AddTwo + + 2 + + + 585 + + + + + + + + + + 25 + 29 + + + 25 + 25 + + AddTwo + + 2 + + + 163 + + + + + + + 25 + 28 + + + 25 + 25 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + + 5 + 29 + + + 26 + 27 + + AddTwo + + 0 + + + + + 8 + 54 + + + 26 + 26 + + AddTwo + + 0 + + + 230 + + + + + + + 23 + 54 + + + 26 + 26 + + AddTwo + + 0 + + + 169 + + + + + + + 23 + 33 + + + 26 + 26 + + AddTwo + + 0 + + + 190 + + + + + + + 23 + 25 + + + 26 + 26 + + AddTwo + + 0 + + + 312 + + + + + + + 23 + 23 + + + 26 + 26 + + AddTwo + + 0 + + + 638 + + + + + + + + 25 + 25 + + + 26 + 26 + + AddTwo + + 0 + 1 + + + + + + + 31 + 33 + + + 26 + 26 + + AddTwo + + 0 + + + 306 + + + + + + + + + + 38 + 54 + + + 26 + 26 + + AddTwo + + 0 + + + 154 + + + + + + + 38 + 44 + + + 26 + 26 + + AddTwo + + 0 + + + 326 + + + + + + + 38 + 38 + + + 26 + 26 + + AddTwo + + 0 + 2 + + + + + 41 + 43 + + + 26 + 26 + + AddTwo + + 0 + + + 312 + + + + + + + 41 + 41 + + + 26 + 26 + + AddTwo + + 0 + + + 638 + + + + + + + + 43 + 43 + + + 26 + 26 + + AddTwo + + 0 + 1 + + + + + + + + + 48 + 54 + + + 26 + 26 + + AddTwo + + 0 + + + 312 + + + + + + + 48 + 50 + + + 26 + 26 + + AddTwo + + 0 + + + 326 + + + + + + + 48 + 48 + + + 26 + 26 + + AddTwo + + 0 + 2 + + + + + 50 + 50 + + + 26 + 26 + + AddTwo + + 0 + + + 638 + + + + + + + + + + 54 + 54 + + + 26 + 26 + + AddTwo + + 0 + 2 + + + + + + + + + + + + 638 + + + + + 17 + 19 + + + 26 + 26 + + AddTwo + + 0 + + + 306 + + + + + + + + + + + 57 + 61 + + + 26 + 26 + + AddTwo + + 0 + + + 430 + + + + + + + + 574 + + + 607 + + + 585 + + + 603 + + + + + + + 151 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + FALSE + 0 + + + + + 152 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + TRUE + 0 + + + + + 154 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + = + 2 + + + + 155 + + + + + + 156 + + + + + + + + 155 + + Formal_0 + 0 + + + + 156 + + Formal_1 + 0 + + + + 668 + + + + 3 + 43 + + + 28 + 28 + + AddTwo + + 2 + + + + + 7 + 9 + + + 28 + 28 + + AddTwo + + 0 + + + 287 + + + + + + + + + 11 + 43 + + + 28 + 28 + + AddTwo + + 2 + + + + + 14 + 16 + + + 28 + 28 + + AddTwo + + 0 + + + 428 + + + + + + + + 19 + 22 + + + 28 + 28 + + AddTwo + + 1 + + + 612 + + + + + + + + 25 + 28 + + + 28 + 28 + + AddTwo + + 2 + + + 619 + + + + + + + + 31 + 34 + + + 28 + 28 + + AddTwo + + 2 + + + 630 + + + + + + + + 592 + + + + + + + 670 + + + + 1 + 43 + + + 20 + 28 + + AddTwo + + 3 + + + + + 9 + 22 + + + 20 + 20 + + AddTwo + + 3 + + + 178 + + + + + + + 9 + 12 + + + 20 + 20 + + AddTwo + + 3 + + + 592 + + + + + + + + 17 + 22 + + + 20 + 20 + + AddTwo + + 3 + + + 211 + + + + + + + 19 + 22 + + + 20 + 20 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + + 3 + 43 + + + 21 + 28 + + AddTwo + + 2 + + 618 + + + 629 + + + 660 + + + 668 + + + + + + 163 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 2 + ' + 1 + + + + 164 + + + + + + + 164 + + Formal_0 + 0 + + + + 169 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + \land + 2 + + + + 170 + + + + + + 171 + + + + + + + + 170 + + Formal_0 + 0 + + + + 171 + + Formal_1 + 0 + + + + 175 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + \equiv + 2 + + + + 176 + + + + + + 177 + + + + + + + + 176 + + Formal_0 + 0 + + + + 177 + + Formal_1 + 0 + + + + 178 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + => + 2 + + + + 179 + + + + + + 180 + + + + + + + + 179 + + Formal_0 + 0 + + + + 180 + + Formal_1 + 0 + + + + 190 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + \in + 2 + + + + 191 + + + + + + 192 + + + + + + + + 191 + + Formal_0 + 0 + + + + 192 + + Formal_1 + 0 + + + + 193 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + \notin + 2 + + + + 194 + + + + + + 195 + + + + + + + + 194 + + Formal_0 + 0 + + + + 195 + + Formal_1 + 0 + + + + 211 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 3 + [] + 1 + + + + 212 + + + + + + + 212 + + Formal_0 + 0 + + + + 217 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 2 + UNCHANGED + 1 + + + + 218 + + + + + + + 218 + + Formal_0 + 0 + + + + 229 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $BoundedExists + -1 + + + + 230 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $BoundedForall + -1 + + + + 256 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $SetEnumerate + -1 + + + + 263 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 2 + $SquareAct + 2 + + + + 264 + + + + + 265 + + + + + + + 264 + + Formal_0 + 0 + + + + 265 + + Formal_1 + 0 + + + + 275 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $Tuple + -1 + + + + 276 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $UnboundedChoose + 1 + + + + 277 + + + + + + + + 277 + + Formal_0 + 0 + + + + 278 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $UnboundedExists + 1 + + + + 279 + + + + + + + + 279 + + Formal_0 + 0 + + + + 280 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $UnboundedForall + 1 + + + + 281 + + + + + + + + 281 + + Formal_0 + 0 + + + + 287 + + + + 0 + 0 + + + 0 + 0 + + --TLA+ BUILTINS-- + + 0 + $Qed + 0 + + + + + 304 + + + + 1 + 77 + + + 1 + 36 + + Naturals + + Naturals + + 306 + + + 312 + + + 322 + + + 326 + + + 332 + + + 338 + + + 344 + + + 350 + + + 356 + + + 362 + + + 368 + + + 374 + + + + + 306 + + + + 1 + 16 + + + 14 + 14 + + Naturals + + 0 + Nat + 0 + + + + + 14 + 16 + + + 14 + 14 + + Naturals + + 0 + + + 256 + + + + + + + + + + 307 + + + + 1 + 1 + + + 15 + 15 + + Naturals + + 0 + a + 0 + + + + 308 + + + + 3 + 3 + + + 15 + 15 + + Naturals + + 0 + b + 0 + + + + 312 + + + + 1 + 19 + + + 15 + 15 + + Naturals + + 0 + + + 2 + + + + + 14 + 19 + + + 15 + 15 + + Naturals + + 0 + + + 256 + + + + + + + 15 + 15 + + + 15 + 15 + + Naturals + + 0 + + + 307 + + + + + + + + 18 + 18 + + + 15 + 15 + + Naturals + + 0 + + + 308 + + + + + + + + + + + 307 + + + + + + 308 + + + + + + + + 313 + + + + 1 + 1 + + + 17 + 17 + + Naturals + + 0 + a + 0 + + + + 314 + + + + 3 + 3 + + + 17 + 17 + + Naturals + + 0 + b + 0 + + + + 315 + + + + 14 + 19 + + + 17 + 17 + + Naturals + + 0 + n + 0 + + + + 322 + + + + 1 + 33 + + + 17 + 17 + + Naturals + + 0 + - + 2 + + + + + 14 + 33 + + + 17 + 17 + + Naturals + + 0 + + + 276 + + + + + + + 25 + 33 + + + 17 + 17 + + Naturals + + 0 + + + 154 + + + + + + + 25 + 29 + + + 17 + 17 + + Naturals + + 0 + + + 312 + + + + + + + 25 + 25 + + + 17 + 17 + + Naturals + + 0 + + + 314 + + + + + + + + 29 + 29 + + + 17 + 17 + + Naturals + + 0 + + + 315 + + + + + + + + + + 33 + 33 + + + 17 + 17 + + Naturals + + 0 + + + 313 + + + + + + + + + + + 315 + + + + + + + + + 313 + + + + + + 314 + + + + + + + + 323 + + + + 1 + 1 + + + 18 + 18 + + Naturals + + a + 0 + + + + 324 + + + + 3 + 3 + + + 18 + 18 + + Naturals + + b + 0 + + + + 326 + + + + 1 + 17 + + + 18 + 18 + + Naturals + + 0 + * + 2 + + + + + 14 + 17 + + + 18 + 18 + + Naturals + + 0 + + + 152 + + + + + + + + + 323 + + + + + + 324 + + + + + + + + 327 + + + + 1 + 1 + + + 19 + 19 + + Naturals + + 0 + a + 0 + + + + 328 + + + + 3 + 3 + + + 19 + 19 + + Naturals + + 0 + b + 0 + + + + 332 + + + + 1 + 19 + + + 19 + 19 + + Naturals + + 0 + ^ + 2 + + + + + 14 + 19 + + + 19 + 19 + + Naturals + + 0 + + + 256 + + + + + + + 15 + 15 + + + 19 + 19 + + Naturals + + 0 + + + 327 + + + + + + + + 18 + 18 + + + 19 + 19 + + Naturals + + 0 + + + 328 + + + + + + + + + + + 327 + + + + + + 328 + + + + + + + + 333 + + + + 1 + 1 + + + 20 + 20 + + Naturals + + 0 + a + 0 + + + + 334 + + + + 3 + 3 + + + 20 + 20 + + Naturals + + 0 + b + 0 + + + + 338 + + + + 1 + 19 + + + 20 + 20 + + Naturals + + 0 + < + 2 + + + + + 15 + 19 + + + 20 + 20 + + Naturals + + 0 + + + 154 + + + + + + + 15 + 15 + + + 20 + 20 + + Naturals + + 0 + + + 333 + + + + + + + + 19 + 19 + + + 20 + 20 + + Naturals + + 0 + + + 334 + + + + + + + + + + + 333 + + + + + + 334 + + + + + + + + 339 + + + + 1 + 1 + + + 21 + 21 + + Naturals + + 0 + a + 0 + + + + 340 + + + + 3 + 3 + + + 21 + 21 + + Naturals + + 0 + b + 0 + + + + 344 + + + + 1 + 19 + + + 21 + 21 + + Naturals + + 0 + > + 2 + + + + + 15 + 19 + + + 21 + 21 + + Naturals + + 0 + + + 154 + + + + + + + 15 + 15 + + + 21 + 21 + + Naturals + + 0 + + + 339 + + + + + + + + 19 + 19 + + + 21 + 21 + + Naturals + + 0 + + + 340 + + + + + + + + + + + 339 + + + + + + 340 + + + + + + + + 345 + + + + 1 + 1 + + + 22 + 22 + + Naturals + + 0 + a + 0 + + + + 346 + + + + 8 + 8 + + + 22 + 22 + + Naturals + + 0 + b + 0 + + + + 350 + + + + 1 + 19 + + + 22 + 22 + + Naturals + + 0 + \leq + 2 + + + + + 15 + 19 + + + 22 + 22 + + Naturals + + 0 + + + 154 + + + + + + + 15 + 15 + + + 22 + 22 + + Naturals + + 0 + + + 345 + + + + + + + + 19 + 19 + + + 22 + 22 + + Naturals + + 0 + + + 346 + + + + + + + + + + + 345 + + + + + + 346 + + + + + + + + 351 + + + + 1 + 1 + + + 23 + 23 + + Naturals + + 0 + a + 0 + + + + 352 + + + + 8 + 8 + + + 23 + 23 + + Naturals + + 0 + b + 0 + + + + 356 + + + + 1 + 19 + + + 23 + 23 + + Naturals + + 0 + \geq + 2 + + + + + 15 + 19 + + + 23 + 23 + + Naturals + + 0 + + + 154 + + + + + + + 15 + 15 + + + 23 + 23 + + Naturals + + 0 + + + 351 + + + + + + + + 19 + 19 + + + 23 + 23 + + Naturals + + 0 + + + 352 + + + + + + + + + + + 351 + + + + + + 352 + + + + + + + + 357 + + + + 1 + 1 + + + 33 + 33 + + Naturals + + 0 + a + 0 + + + + 358 + + + + 5 + 5 + + + 33 + 33 + + Naturals + + 0 + b + 0 + + + + 362 + + + + 1 + 20 + + + 33 + 33 + + Naturals + + 0 + % + 2 + + + + + 15 + 20 + + + 33 + 33 + + Naturals + + 0 + + + 256 + + + + + + + 16 + 16 + + + 33 + 33 + + Naturals + + 0 + + + 357 + + + + + + + + 19 + 19 + + + 33 + 33 + + Naturals + + 0 + + + 358 + + + + + + + + + + + 357 + + + + + + 358 + + + + + + + + 363 + + + + 1 + 1 + + + 34 + 34 + + Naturals + + 0 + a + 0 + + + + 364 + + + + 8 + 8 + + + 34 + 34 + + Naturals + + 0 + b + 0 + + + + 368 + + + + 1 + 20 + + + 34 + 34 + + Naturals + + 0 + \div + 2 + + + + + 15 + 20 + + + 34 + 34 + + Naturals + + 0 + + + 256 + + + + + + + 16 + 16 + + + 34 + 34 + + Naturals + + 0 + + + 363 + + + + + + + + 19 + 19 + + + 34 + 34 + + Naturals + + 0 + + + 364 + + + + + + + + + + + 363 + + + + + + 364 + + + + + + + + 369 + + + + 1 + 1 + + + 35 + 35 + + Naturals + + 0 + a + 0 + + + + 370 + + + + 6 + 6 + + + 35 + 35 + + Naturals + + 0 + b + 0 + + + + 374 + + + + 1 + 20 + + + 35 + 35 + + Naturals + + 0 + .. + 2 + + + + + 15 + 20 + + + 35 + 35 + + Naturals + + 0 + + + 256 + + + + + + + 16 + 16 + + + 35 + 35 + + Naturals + + 0 + + + 369 + + + + + + + + 19 + 19 + + + 35 + 35 + + Naturals + + 0 + + + 370 + + + + + + + + + + + 369 + + + + + + 370 + + + + + + + + 379 + + + + 1 + 77 + + + 1 + 362 + + TLAPS + + TLAPS + + 381 + + + 383 + + + 386 + + + 388 + + + 391 + + + 393 + + + 396 + + + 398 + + + 401 + + + 403 + + + 406 + + + 408 + + + 411 + + + 413 + + + 416 + + + 418 + + + 421 + + + 423 + + + 426 + + + 428 + + + 430 + + + 433 + + + 435 + + + 438 + + + 441 + + + 445 + + + 447 + + + 478 + + + 480 + + + 482 + + + 484 + + + 486 + + + 488 + + + 490 + + + 492 + + + 494 + + + 496 + + + 498 + + + 500 + + + 502 + + + 504 + + + 506 + + + 508 + + + 510 + + + 512 + + + 514 + + + 516 + + + 518 + + + 520 + + + 522 + + + 524 + + + 526 + + + 528 + + + 531 + + + 533 + + + 536 + + + 538 + + + 541 + + + 543 + + + 545 + + + 547 + + + 549 + + + 551 + + + 553 + + + 556 + + + 559 + + + 561 + + + 466 + + + 476 + + + + + 381 + + + + 1 + 24 + + + 26 + 26 + + TLAPS + + 0 + SimpleArithmetic + 0 + + + + + 21 + 24 + + + 26 + 26 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 383 + + + + 1 + 11 + + + 39 + 39 + + TLAPS + + 0 + SMT + 0 + + + + + 8 + 11 + + + 39 + 39 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 384 + + + + 6 + 6 + + + 40 + 40 + + TLAPS + + X + 0 + + + + 386 + + + + 1 + 15 + + + 40 + 40 + + TLAPS + + 0 + SMTT + 1 + + + + + 12 + 15 + + + 40 + 40 + + TLAPS + + 0 + + + 152 + + + + + + + + + 384 + + + + + + + + 388 + + + + 1 + 12 + + + 50 + 50 + + TLAPS + + 0 + CVC3 + 0 + + + + + 9 + 12 + + + 50 + 50 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 389 + + + + 7 + 7 + + + 51 + 51 + + TLAPS + + X + 0 + + + + 391 + + + + 1 + 16 + + + 51 + 51 + + TLAPS + + 0 + CVC3T + 1 + + + + + 13 + 16 + + + 51 + 51 + + TLAPS + + 0 + + + 152 + + + + + + + + + 389 + + + + + + + + 393 + + + + 1 + 12 + + + 53 + 53 + + TLAPS + + 0 + CVC4 + 0 + + + + + 9 + 12 + + + 53 + 53 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 394 + + + + 7 + 7 + + + 54 + 54 + + TLAPS + + X + 0 + + + + 396 + + + + 1 + 16 + + + 54 + 54 + + TLAPS + + 0 + CVC4T + 1 + + + + + 13 + 16 + + + 54 + 54 + + TLAPS + + 0 + + + 152 + + + + + + + + + 394 + + + + + + + + 398 + + + + 1 + 13 + + + 63 + 63 + + TLAPS + + 0 + Yices + 0 + + + + + 10 + 13 + + + 63 + 63 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 399 + + + + 8 + 8 + + + 64 + 64 + + TLAPS + + X + 0 + + + + 401 + + + + 1 + 17 + + + 64 + 64 + + TLAPS + + 0 + YicesT + 1 + + + + + 14 + 17 + + + 64 + 64 + + TLAPS + + 0 + + + 152 + + + + + + + + + 399 + + + + + + + + 403 + + + + 1 + 13 + + + 72 + 72 + + TLAPS + + 0 + veriT + 0 + + + + + 10 + 13 + + + 72 + 72 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 404 + + + + 8 + 8 + + + 73 + 73 + + TLAPS + + X + 0 + + + + 406 + + + + 1 + 17 + + + 73 + 73 + + TLAPS + + 0 + veriTT + 1 + + + + + 14 + 17 + + + 73 + 73 + + TLAPS + + 0 + + + 152 + + + + + + + + + 404 + + + + + + + + 408 + + + + 1 + 14 + + + 82 + 82 + + TLAPS + + 0 + Zipper + 0 + + + + + 11 + 14 + + + 82 + 82 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 409 + + + + 9 + 9 + + + 83 + 83 + + TLAPS + + X + 0 + + + + 411 + + + + 1 + 18 + + + 83 + 83 + + TLAPS + + 0 + ZipperT + 1 + + + + + 15 + 18 + + + 83 + 83 + + TLAPS + + 0 + + + 152 + + + + + + + + + 409 + + + + + + + + 413 + + + + 1 + 10 + + + 92 + 92 + + TLAPS + + 0 + Z3 + 0 + + + + + 7 + 10 + + + 92 + 92 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 414 + + + + 5 + 5 + + + 93 + 93 + + TLAPS + + X + 0 + + + + 416 + + + + 1 + 14 + + + 93 + 93 + + TLAPS + + 0 + Z3T + 1 + + + + + 11 + 14 + + + 93 + 93 + + TLAPS + + 0 + + + 152 + + + + + + + + + 414 + + + + + + + + 418 + + + + 1 + 13 + + + 102 + 102 + + TLAPS + + 0 + Spass + 0 + + + + + 10 + 13 + + + 102 + 102 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 419 + + + + 8 + 8 + + + 103 + 103 + + TLAPS + + X + 0 + + + + 421 + + + + 1 + 17 + + + 103 + 103 + + TLAPS + + 0 + SpassT + 1 + + + + + 14 + 17 + + + 103 + 103 + + TLAPS + + 0 + + + 152 + + + + + + + + + 419 + + + + + + + + 423 + + + + 1 + 11 + + + 113 + 113 + + TLAPS + + 0 + LS4 + 0 + + + + + 8 + 11 + + + 113 + 113 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 424 + + + + 6 + 6 + + + 114 + 114 + + TLAPS + + X + 0 + + + + 426 + + + + 1 + 15 + + + 114 + 114 + + TLAPS + + 0 + LS4T + 1 + + + + + 12 + 15 + + + 114 + 114 + + TLAPS + + 0 + + + 152 + + + + + + + + + 424 + + + + + + + + 428 + + + + 1 + 11 + + + 115 + 115 + + TLAPS + + 0 + PTL + 0 + + + + + 8 + 11 + + + 115 + 115 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 430 + + + + 1 + 13 + + + 122 + 122 + + TLAPS + + 0 + Zenon + 0 + + + + + 10 + 13 + + + 122 + 122 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 431 + + + + 8 + 8 + + + 123 + 123 + + TLAPS + + X + 0 + + + + 433 + + + + 1 + 17 + + + 123 + 123 + + TLAPS + + 0 + ZenonT + 1 + + + + + 14 + 17 + + + 123 + 123 + + TLAPS + + 0 + + + 152 + + + + + + + + + 431 + + + + + + + + 435 + + + + 1 + 11 + + + 130 + 130 + + TLAPS + + 0 + Isa + 0 + + + + + 8 + 11 + + + 130 + 130 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 436 + + + + 6 + 6 + + + 131 + 131 + + TLAPS + + X + 0 + + + + 438 + + + + 1 + 16 + + + 131 + 131 + + TLAPS + + 0 + IsaT + 1 + + + + + 13 + 16 + + + 131 + 131 + + TLAPS + + 0 + + + 152 + + + + + + + + + 436 + + + + + + + + 439 + + + + 6 + 6 + + + 132 + 132 + + TLAPS + + X + 0 + + + + 441 + + + + 1 + 16 + + + 132 + 132 + + TLAPS + + 0 + IsaM + 1 + + + + + 13 + 16 + + + 132 + 132 + + TLAPS + + 0 + + + 152 + + + + + + + + + 439 + + + + + + + + 442 + + + + 7 + 7 + + + 133 + 133 + + TLAPS + + X + 0 + + + + 443 + + + + 9 + 9 + + + 133 + 133 + + TLAPS + + Y + 0 + + + + 445 + + + + 1 + 19 + + + 133 + 133 + + TLAPS + + 0 + IsaMT + 2 + + + + + 16 + 19 + + + 133 + 133 + + TLAPS + + 0 + + + 152 + + + + + + + + + 442 + + + + + + 443 + + + + + + + + 447 + + + + 1 + 32 + + + 147 + 147 + + TLAPS + + 0 + IsaWithSetExtensionality + 0 + + + + + 29 + 32 + + + 147 + 147 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 448 + + + + 1 + 7 + + + 150 + 151 + + TLAPS + + 0 + SetExtensionality + + + + 30 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 280 + + + + + + + 39 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 178 + + + + + + + 40 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 280 + + + + + + + 47 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 175 + + + + + + + 47 + 53 + + + 150 + 150 + + TLAPS + + 0 + + + 190 + + + + + + + 47 + 47 + + + 150 + 150 + + TLAPS + + 0 + + + 451 + + + + + + + + 53 + 53 + + + 150 + 150 + + TLAPS + + 0 + + + 449 + + + + + + + + + + 59 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 190 + + + + + + + 59 + 59 + + + 150 + 150 + + TLAPS + + 0 + + + 451 + + + + + + + + 65 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 450 + + + + + + + + + + + + + 451 + + + + + + + + 71 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 154 + + + + + + + 71 + 71 + + + 150 + 150 + + TLAPS + + 0 + + + 449 + + + + + + + + 75 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 450 + + + + + + + + + + + + + 449 + + + + + 450 + + + + + + + + 449 + + + + 33 + 33 + + + 150 + 150 + + TLAPS + + 0 + S + 0 + + + + 450 + + + + 35 + 35 + + + 150 + 150 + + TLAPS + + 0 + T + 0 + + + + 451 + + + + 43 + 43 + + + 150 + 150 + + TLAPS + + 0 + x + 0 + + + + 466 + + + + 1 + 7 + + + 150 + 151 + + TLAPS + + 0 + + + 448 + + + + + + + 30 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 280 + + + + + + + 39 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 178 + + + + + + + 40 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 280 + + + + + + + 47 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 175 + + + + + + + 47 + 53 + + + 150 + 150 + + TLAPS + + 0 + + + 190 + + + + + + + 47 + 47 + + + 150 + 150 + + TLAPS + + 0 + + + 451 + + + + + + + + 53 + 53 + + + 150 + 150 + + TLAPS + + 0 + + + 449 + + + + + + + + + + 59 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 190 + + + + + + + 59 + 59 + + + 150 + 150 + + TLAPS + + 0 + + + 451 + + + + + + + + 65 + 65 + + + 150 + 150 + + TLAPS + + 0 + + + 450 + + + + + + + + + + + + + 451 + + + + + + + + 71 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 154 + + + + + + + 71 + 71 + + + 150 + 150 + + TLAPS + + 0 + + + 449 + + + + + + + + 75 + 75 + + + 150 + 150 + + TLAPS + + 0 + + + 450 + + + + + + + + + + + + + 449 + + + + + 450 + + + + + + + + + 1 + 7 + + + 151 + 151 + + TLAPS + + 0 + + + + + 467 + + + + 1 + 7 + + + 159 + 160 + + TLAPS + + 0 + NoSetContainsEverything + + + + 36 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 280 + + + + + + + 43 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 278 + + + + + + + 50 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 193 + + + + + + + 50 + 50 + + + 159 + 159 + + TLAPS + + 0 + + + 469 + + + + + + + + 59 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 468 + + + + + + + + + + + 469 + + + + + + + + + 468 + + + + + + + + 468 + + + + 39 + 39 + + + 159 + 159 + + TLAPS + + 0 + S + 0 + + + + 469 + + + + 46 + 46 + + + 159 + 159 + + TLAPS + + 0 + x + 0 + + + + 476 + + + + 1 + 7 + + + 159 + 160 + + TLAPS + + 0 + + + 467 + + + + + + + 36 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 280 + + + + + + + 43 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 278 + + + + + + + 50 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 193 + + + + + + + 50 + 50 + + + 159 + 159 + + TLAPS + + 0 + + + 469 + + + + + + + + 59 + 59 + + + 159 + 159 + + TLAPS + + 0 + + + 468 + + + + + + + + + + + 469 + + + + + + + + + 468 + + + + + + + + + 1 + 7 + + + 160 + 160 + + TLAPS + + 0 + + + + + 478 + + + + 1 + 17 + + + 181 + 181 + + TLAPS + + 0 + SlowZenon + 0 + + + + + 14 + 17 + + + 181 + 181 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 480 + + + + 1 + 19 + + + 182 + 182 + + TLAPS + + 0 + SlowerZenon + 0 + + + + + 16 + 19 + + + 182 + 182 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 482 + + + + 1 + 21 + + + 183 + 183 + + TLAPS + + 0 + VerySlowZenon + 0 + + + + + 18 + 21 + + + 183 + 183 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 484 + + + + 1 + 20 + + + 184 + 184 + + TLAPS + + 0 + SlowestZenon + 0 + + + + + 17 + 20 + + + 184 + 184 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 486 + + + + 1 + 12 + + + 195 + 195 + + TLAPS + + 0 + Auto + 0 + + + + + 9 + 12 + + + 195 + 195 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 488 + + + + 1 + 16 + + + 196 + 196 + + TLAPS + + 0 + SlowAuto + 0 + + + + + 13 + 16 + + + 196 + 196 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 490 + + + + 1 + 18 + + + 197 + 197 + + TLAPS + + 0 + SlowerAuto + 0 + + + + + 15 + 18 + + + 197 + 197 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 492 + + + + 1 + 19 + + + 198 + 198 + + TLAPS + + 0 + SlowestAuto + 0 + + + + + 16 + 19 + + + 198 + 198 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 494 + + + + 1 + 13 + + + 206 + 206 + + TLAPS + + 0 + Force + 0 + + + + + 10 + 13 + + + 206 + 206 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 496 + + + + 1 + 17 + + + 207 + 207 + + TLAPS + + 0 + SlowForce + 0 + + + + + 14 + 17 + + + 207 + 207 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 498 + + + + 1 + 19 + + + 208 + 208 + + TLAPS + + 0 + SlowerForce + 0 + + + + + 16 + 19 + + + 208 + 208 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 500 + + + + 1 + 20 + + + 209 + 209 + + TLAPS + + 0 + SlowestForce + 0 + + + + + 17 + 20 + + + 209 + 209 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 502 + + + + 1 + 31 + + + 219 + 219 + + TLAPS + + 0 + SimplifyAndSolve + 0 + + + + + 28 + 31 + + + 219 + 219 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 504 + + + + 1 + 31 + + + 221 + 221 + + TLAPS + + 0 + SlowSimplifyAndSolve + 0 + + + + + 28 + 31 + + + 221 + 221 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 506 + + + + 1 + 31 + + + 223 + 223 + + TLAPS + + 0 + SlowerSimplifyAndSolve + 0 + + + + + 28 + 31 + + + 223 + 223 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 508 + + + + 1 + 31 + + + 225 + 225 + + TLAPS + + 0 + SlowestSimplifyAndSolve + 0 + + + + + 28 + 31 + + + 225 + 225 + + TLAPS + + 0 + + + 152 + + + + + + + + + + 510 + + + + 1 + 22 + + + 228 + 228 + + TLAPS + + 0 + Simplification + 0 + + + + + 19 + 22 + + + 228 + 228 + + TLAPS + + 0 + + + 152 + + + + + + + + + + + 304 + + + 379 + + + 566 + + From 06f4fc02c6e175f17a5f2f8af2b06b3d809b386d Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 31 Dec 2025 12:10:36 -0800 Subject: [PATCH 11/85] Translations runnable in test Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 52 ++++++++++++++++++++++------------- src/sany/xml.ml | 60 +++++++++++++++++------------------------ test/sany/dune | 2 +- test/sany/sany_tests.ml | 2 +- 4 files changed, 59 insertions(+), 57 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 1012aa73..760be757 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -15,33 +15,46 @@ let convert_location (location : Xml.location) : Loc.locus = { file = location.filename; } -let convert_unit_ref (entry_map : Xml.entry_kind Util.Coll.Im.t) (unit_ref : Xml.unit_kind) : modunit = () +let resolve_ref (entry_map : Xml.entry_kind Util.Coll.Im.t) (uid : int) : Xml.entry = + match Util.Coll.Im.find_opt uid entry_map with + | Some kind -> {uid; kind} + | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) -let convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.modunit = - let loc = convert_location mule.location in +let rec convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.modunit = + let inline_unit unit = + match unit with + | `Ref uid -> resolve_ref entry_map uid + | `OtherTODO name -> failwith (name ^ " unit not yet supported") + in let loc = convert_location mule.location in Util.locate (Submod (Util.locate { name = noprops mule.uniquename; extendees = []; instancees = []; - body = List.map (convert_unit_ref entry_map) mule.units; + body = mule.units |> List.map inline_unit |> List.map (convert_entry entry_map); defdepth = 0; stage = Parsed; important = true } loc)) loc -let convert_op_decl_node (op_decl_node : Xml.op_decl_node) : Module.T.modunit = () +and convert_op_decl_node (op_decl_node : Xml.op_decl_node) : Module.T.modunit = + failwith "OpDeclNode conversion not yet supported" -let convert_user_defined_op_kind (user_defined_op_kind : Xml.user_defined_op_kind) : Module.T.modunit = () +and convert_user_defined_op_kind (user_defined_op_kind : Xml.user_defined_op_kind) : Module.T.modunit = + failwith "UserDefinedOpKind conversion not yet supported" -let convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = () +and convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = + failwith "BuiltInKind conversion not yet supported" -let convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = () +and convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = + failwith "FormalParamNode conversion not yet supported" -let convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = () +and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = + failwith "TheoremDefNode conversion not yet supported" -let convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = () +and convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = + failwith "TheoremNode conversion not yet supported" -let convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = +and convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = match entry.kind with | ModuleNode mule -> convert_module_node entry_map mule | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node @@ -51,9 +64,9 @@ let convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node | TheoremNode theorem_node -> convert_theorem_node theorem_node -let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = - let entry_map = - List.fold_left +let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = + let entry_map = + List.fold_left (fun m (e : Xml.entry) -> Util.Coll.Im.add e.uid e.kind m) Util.Coll.Im.empty ast.context.entry @@ -68,9 +81,10 @@ let convert_ast (ast : Xml.modules) : Module.T.modctx * Module.T.mule = defdepth = 0; stage = Parsed; important = true - } in (context, root_module) - + } in Ok (context, root_module) + let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - match module_path |> Xml.get_module_ast_xml with - | Error msg -> Error (None, msg) - | Ok ast -> ast |> convert_ast |> Result.ok + let ( >>= ) = Result.bind in + Option.to_result ~none:(None, "TLAPS standard library cannot be found") Params.stdlib_path + >>= (Xml.get_module_ast_xml module_path) + >>= convert_ast diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 5d159643..c5472497 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -1,10 +1,10 @@ -let source_to_sany_xml_str (module_path : string) : (string, (string * int)) result = +let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in let (stdout, stdin, stderr) = Unix.open_process_args_full "java" - [|"java"; "-cp"; backend_classpath_string "tla2tools.jar"; "tla2sany.xml.XMLExporter"; "-t"; module_path|] + [|"java"; "-cp"; backend_classpath_string "tla2tools.jar"; "tla2sany.xml.XMLExporter"; "-I"; stdlib_path; "-t"; module_path|] (Unix.environment ()) in let (output, err_output) = (In_channel.input_all stdout, In_channel.input_all stderr) in match Unix.close_process_full (stdout, stdin, stderr) with @@ -248,46 +248,32 @@ let xml_to_module_node_ref xml = } | _ -> conversion_failure __FUNCTION__ xml -type unit_kind = - | OpDeclNodeRef of int - | ModuleInstanceKindRef of int - | UserDefinedOpKindRef of int - | BuiltInKindRef of int - | TheoremDefRef of int - | AssumeDefRef of int - | AssumeNodeRef of int - (* TODO - | InstanceNode - | UseOrHideNode - *) - | TheoremNodeRef of int -[@@deriving show] - -let xml_to_unit_kind (xml : tree) : unit_kind = - match xml with - | Node (((_, "OpDeclNodeRef"), _), children) -> OpDeclNodeRef (children |> xml_to_tagged_int "UID") - | Node (((_, "ModuleInstanceKindRef"), _), children) -> ModuleInstanceKindRef (children |> xml_to_tagged_int "UID") - | Node (((_, "UserDefinedOpKindRef"), _), children) -> UserDefinedOpKindRef (children |> xml_to_tagged_int "UID") - | Node (((_, "BuiltInKindRef"), _), children) -> BuiltInKindRef (children |> xml_to_tagged_int "UID") - | Node (((_, "TheoremDefRef"), _), children) -> TheoremDefRef (children |> xml_to_tagged_int "UID") - | Node (((_, "AssumeDefRef"), _), children) -> AssumeDefRef (children |> xml_to_tagged_int "UID") - | Node (((_, "AssumeNodeRef"), _), children) -> AssumeNodeRef (children |> xml_to_tagged_int "UID") - | Node (((_, "TheoremNodeRef"), _), children) -> TheoremNodeRef (children |> xml_to_tagged_int "UID") - | _ -> conversion_failure __FUNCTION__ xml - type module_node = { location : location; uniquename : string; - units : unit_kind list; + units : [`Ref of int | `OtherTODO of string] list; } [@@deriving show] let xml_to_module_node xml = - match xml with + let ref_child child = + match child with + | Node (((_, "OpDeclNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "ModuleInstanceKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "UserDefinedOpKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "BuiltInKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "TheoremDefRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "AssumeDefRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "AssumeNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "TheoremNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node (((_, "InstanceNode"), _), children) -> Some (`OtherTODO "InstanceNode") + | Node (((_, "UseOrHideNode"), _), children) -> Some (`OtherTODO "UseOrHideNode") + | _ -> None + in match xml with | Node (((_, "ModuleNode"), _), children) -> { uniquename = children |> xml_to_tagged_string "uniquename"; location = children |> find_tag "location" |> xml_to_location; - units = List.map xml_to_unit_kind children + units = List.filter_map ref_child children } | _ -> conversion_failure __FUNCTION__ xml @@ -611,10 +597,12 @@ let xml_to_ast (xml : tree) : (modules, (string * string)) result = Printexc.record_backtrace prev_backtrace; Result.error (e, trace) -let get_module_ast_xml (module_path : string) : (modules, string) result = - match module_path |> source_to_sany_xml_str with - | Error (output, exit_code) -> Error (Printf.sprintf "%d\n%s" exit_code output) +let ( >>= ) = Result.bind + +let get_module_ast_xml (module_path : string) (stdlib_path : string) : (modules, (string option * string)) result = + match source_to_sany_xml_str module_path stdlib_path with + | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) | Ok xml_str -> match xml_str |> str_to_xml |> xml_to_ast with - | Error (msg, trace) -> Error (Printf.sprintf "%s\n%s" msg trace) + | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) | Ok ast -> ast |> Result.ok diff --git a/test/sany/dune b/test/sany/dune index 759e9504..d372b677 100644 --- a/test/sany/dune +++ b/test/sany/dune @@ -2,6 +2,6 @@ (name sany_tests) (modes exe) (libraries tlapm_lib ounit2 sexplib sexp_diff) - (deps Test.tla) + (deps Test.tla AddTwo.tla) (preprocess (pps ppx_deriving.show)) ) diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 33d80659..21928c2d 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -4,6 +4,6 @@ open Tlapm_lib__Params;; let _ = parser_backend := Sany; add_debug_flag "sany"; - match modctx_of_string ~content:"" ~filename:"Test.tla" ~loader_paths:[] ~prefer_stdlib:true with + match modctx_of_string ~content:"" ~filename:"AddTwo.tla" ~loader_paths:[] ~prefer_stdlib:true with | Error (_, msg) -> print_endline msg | Ok _ -> print_endline "success" From 9067e4dce1399271e60477c518d29b000dca7730 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 31 Dec 2025 14:16:10 -0800 Subject: [PATCH 12/85] Fix deadlocked SANY call Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 26 +++++++++++------------- src/sany/xml.ml | 45 ++++++++++++++++++----------------------- test/sany/sany_tests.ml | 1 + 3 files changed, 33 insertions(+), 39 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 760be757..eec2c602 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -20,13 +20,13 @@ let resolve_ref (entry_map : Xml.entry_kind Util.Coll.Im.t) (uid : int) : Xml.en | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) -let rec convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.modunit = +let rec convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.mule = let inline_unit unit = match unit with | `Ref uid -> resolve_ref entry_map uid | `OtherTODO name -> failwith (name ^ " unit not yet supported") in let loc = convert_location mule.location in - Util.locate (Submod (Util.locate { + Util.locate { name = noprops mule.uniquename; extendees = []; instancees = []; @@ -34,7 +34,7 @@ let rec convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : defdepth = 0; stage = Parsed; important = true - } loc)) loc + } loc and convert_op_decl_node (op_decl_node : Xml.op_decl_node) : Module.T.modunit = failwith "OpDeclNode conversion not yet supported" @@ -56,7 +56,7 @@ and convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = and convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = match entry.kind with - | ModuleNode mule -> convert_module_node entry_map mule + | ModuleNode mule -> noprops (Submod (convert_module_node entry_map mule)) | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind @@ -65,23 +65,21 @@ and convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry | TheoremNode theorem_node -> convert_theorem_node theorem_node let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = + print_endline "Starting SANY conversion"; let entry_map = List.fold_left (fun m (e : Xml.entry) -> Util.Coll.Im.add e.uid e.kind m) Util.Coll.Im.empty ast.context.entry in + let module_entries = List.map (fun uid -> + match Util.Coll.Im.find uid entry_map with + | Xml.ModuleNode mule -> mule + | _ -> assert false + ) ast.module_node_ref in + let root_module_entry = List.find (fun (m : Xml.module_node) -> String.equal m.uniquename ast.root_module) module_entries in let context = Util.Coll.Sm.empty in - let _root_module_location = (List.find (fun (m : Xml.module_node) -> m.uniquename = ast.root_module) ast.module_node).location in - let root_module = noprops { - name = noprops ast.root_module; - extendees = []; - instancees = []; - body = List.map (convert_entry entry_map) ast.context.entry; - defdepth = 0; - stage = Parsed; - important = true - } in Ok (context, root_module) + Ok (context, convert_module_node entry_map root_module_entry) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in diff --git a/src/sany/xml.ml b/src/sany/xml.ml index c5472497..3e9069d7 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -1,15 +1,17 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in - let (stdout, stdin, stderr) = - Unix.open_process_args_full - "java" - [|"java"; "-cp"; backend_classpath_string "tla2tools.jar"; "tla2sany.xml.XMLExporter"; "-I"; stdlib_path; "-t"; module_path|] - (Unix.environment ()) - in let (output, err_output) = (In_channel.input_all stdout, In_channel.input_all stderr) in - match Unix.close_process_full (stdout, stdin, stderr) with - | WEXITED 0 -> Ok output - | WEXITED exit_code -> Error (output ^ "\n" ^ err_output, exit_code) + let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -t %s" + (backend_classpath_string "tla2tools.jar") + (Filename.quote stdlib_path) + (Filename.quote module_path) in + let (pid, out_fd) = System.launch_process cmd in + let in_chan = Unix.in_channel_of_descr out_fd in + let output = In_channel.input_all in_chan in + In_channel.close in_chan; + match Unix.waitpid [] pid with + | (_, WEXITED 0) -> Ok output + | (_, WEXITED exit_code) -> Error (output, exit_code) | _ -> failwith "Process terminated abnormally" open Xmlm;; @@ -66,6 +68,11 @@ let xml_child_to_int xml = let xml_to_tagged_int (tag_name : string) (children : tree list) : int = find_tag tag_name children |> xml_child_to_int +let xml_ref_to_int (xml : tree) : int = + match xml with + | Node (((_, _), _), children) -> xml_to_tagged_int "UID" children + | _ -> conversion_failure __FUNCTION__ xml + type range = { start : int; finish : int; @@ -236,18 +243,6 @@ and xml_to_inline_expression children = |> List.find_opt (fun xml -> is_tag "NumeralNode" xml || is_tag "OpApplNode" xml) |> Option.map xml_to_expression -type module_node_ref = { - uid : int -} -[@@deriving show] - -let xml_to_module_node_ref xml = - match xml with - | Node (((_, "ModuleNodeRef"), _), children) -> { - uid = children |> xml_to_tagged_int "UID"; - } - | _ -> conversion_failure __FUNCTION__ xml - type module_node = { location : location; uniquename : string; @@ -570,8 +565,7 @@ let xml_to_context xml = type modules = { root_module: string; context: context; - module_node_ref : module_node_ref list; - module_node : module_node list; + module_node_ref : int list; } [@@deriving show] @@ -580,8 +574,7 @@ let xml_to_modules xml = | Node (((_, "modules"), _), children) -> { root_module = xml_to_tagged_string "RootModule" children; context = children |> find_tag "context" |> xml_to_context; - module_node_ref = children |> List.find_all (is_tag "ModuleNodeRef") |> List.map xml_to_module_node_ref; - module_node = children |> List.find_all (is_tag "ModuleNode") |> List.map xml_to_module_node; + module_node_ref = children |> List.filter (is_tag "ModuleNodeRef") |> List.map xml_ref_to_int; } | _ -> conversion_failure __FUNCTION__ xml @@ -600,9 +593,11 @@ let xml_to_ast (xml : tree) : (modules, (string * string)) result = let ( >>= ) = Result.bind let get_module_ast_xml (module_path : string) (stdlib_path : string) : (modules, (string option * string)) result = + print_endline ("Parsing file " ^ module_path); match source_to_sany_xml_str module_path stdlib_path with | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) | Ok xml_str -> + print_endline "Retrieved XML from SANY"; match xml_str |> str_to_xml |> xml_to_ast with | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) | Ok ast -> ast |> Result.ok diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 21928c2d..384704ff 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -2,6 +2,7 @@ open Tlapm_lib;; open Tlapm_lib__Params;; let _ = + print_endline "RUNNING TEST"; parser_backend := Sany; add_debug_flag "sany"; match modctx_of_string ~content:"" ~filename:"AddTwo.tla" ~loader_paths:[] ~prefer_stdlib:true with From 64b557dbf8d993a57279dfb03d3c0a2e093a62ab Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 31 Dec 2025 14:59:46 -0800 Subject: [PATCH 13/85] Use maps instead of lists Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 35 ++++++++++++++++++----------------- src/sany/xml.ml | 23 +++++++---------------- test/sany/sany_tests.ml | 1 - 3 files changed, 25 insertions(+), 34 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index eec2c602..069494ee 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,5 +1,6 @@ open Property;; open Module.T;; +open Util;; let convert_location (location : Xml.location) : Loc.locus = { start = Actual { @@ -15,18 +16,18 @@ let convert_location (location : Xml.location) : Loc.locus = { file = location.filename; } -let resolve_ref (entry_map : Xml.entry_kind Util.Coll.Im.t) (uid : int) : Xml.entry = - match Util.Coll.Im.find_opt uid entry_map with +let resolve_ref (entry_map : Xml.entry_kind Coll.Im.t) (uid : int) : Xml.entry = + match Coll.Im.find_opt uid entry_map with | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) -let rec convert_module_node (entry_map : Xml.entry_kind Util.Coll.Im.t) (mule : Xml.module_node) : Module.T.mule = +let rec convert_module_node (entry_map : Xml.entry_kind Coll.Im.t) (mule : Xml.module_node) : Module.T.mule = let inline_unit unit = match unit with | `Ref uid -> resolve_ref entry_map uid | `OtherTODO name -> failwith (name ^ " unit not yet supported") in let loc = convert_location mule.location in - Util.locate { + locate { name = noprops mule.uniquename; extendees = []; instancees = []; @@ -54,7 +55,7 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = failwith "TheoremNode conversion not yet supported" -and convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = +and convert_entry (entry_map : Xml.entry_kind Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = match entry.kind with | ModuleNode mule -> noprops (Submod (convert_module_node entry_map mule)) | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node @@ -65,21 +66,21 @@ and convert_entry (entry_map : Xml.entry_kind Util.Coll.Im.t) (entry : Xml.entry | TheoremNode theorem_node -> convert_theorem_node theorem_node let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - print_endline "Starting SANY conversion"; let entry_map = List.fold_left - (fun m (e : Xml.entry) -> Util.Coll.Im.add e.uid e.kind m) - Util.Coll.Im.empty - ast.context.entry + (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) + Coll.Im.empty + ast.context + in let context = Coll.Im.fold + (fun uid kind acc -> + match kind with + | Xml.ModuleNode mule -> Coll.Sm.add mule.uniquename (convert_module_node entry_map mule) acc + | _ -> acc + ) + entry_map + Coll.Sm.empty in - let module_entries = List.map (fun uid -> - match Util.Coll.Im.find uid entry_map with - | Xml.ModuleNode mule -> mule - | _ -> assert false - ) ast.module_node_ref in - let root_module_entry = List.find (fun (m : Xml.module_node) -> String.equal m.uniquename ast.root_module) module_entries in - let context = Util.Coll.Sm.empty in - Ok (context, convert_module_node entry_map root_module_entry) + Ok (context, Coll.Sm.find ast.root_module context) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 3e9069d7..d9061d38 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -550,27 +550,20 @@ let xml_to_entry xml = } | _ -> conversion_failure __FUNCTION__ xml -type context = { - entry : entry list -} -[@@deriving show] - -let xml_to_context xml = - match xml with - | Node (((_, "context"), _), children) -> { - entry = children |> List.find_all (is_tag "entry") |> List.map xml_to_entry; - } - | _ -> conversion_failure __FUNCTION__ xml - type modules = { root_module: string; - context: context; + context: entry list; module_node_ref : int list; } [@@deriving show] let xml_to_modules xml = - match xml with + let xml_to_context xml = + match xml with + | Node (((_, "context"), _), children) -> + children |> List.find_all (is_tag "entry") |> List.map xml_to_entry; + | _ -> conversion_failure __FUNCTION__ xml + in match xml with | Node (((_, "modules"), _), children) -> { root_module = xml_to_tagged_string "RootModule" children; context = children |> find_tag "context" |> xml_to_context; @@ -593,11 +586,9 @@ let xml_to_ast (xml : tree) : (modules, (string * string)) result = let ( >>= ) = Result.bind let get_module_ast_xml (module_path : string) (stdlib_path : string) : (modules, (string option * string)) result = - print_endline ("Parsing file " ^ module_path); match source_to_sany_xml_str module_path stdlib_path with | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) | Ok xml_str -> - print_endline "Retrieved XML from SANY"; match xml_str |> str_to_xml |> xml_to_ast with | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) | Ok ast -> ast |> Result.ok diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 384704ff..21928c2d 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -2,7 +2,6 @@ open Tlapm_lib;; open Tlapm_lib__Params;; let _ = - print_endline "RUNNING TEST"; parser_backend := Sany; add_debug_flag "sany"; match modctx_of_string ~content:"" ~filename:"AddTwo.tla" ~loader_paths:[] ~prefer_stdlib:true with From cbbf7351765938227f7db653bfcb8592aa351229 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 31 Dec 2025 17:11:39 -0800 Subject: [PATCH 14/85] Variable conversion supported Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 64 ++++++++++++++++++++++++++++++------------------ src/sany/xml.ml | 36 ++++++++++++++++++++++++--- 2 files changed, 73 insertions(+), 27 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 069494ee..c19dc342 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -2,6 +2,12 @@ open Property;; open Module.T;; open Util;; +let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty + +let converted_modules : Module.T.mule Coll.Im.t ref = ref Coll.Im.empty + +let converted_units : Module.T.modunit Coll.Im.t ref = ref Coll.Im.empty + let convert_location (location : Xml.location) : Loc.locus = { start = Actual { line = location.line.start; @@ -16,29 +22,40 @@ let convert_location (location : Xml.location) : Loc.locus = { file = location.filename; } -let resolve_ref (entry_map : Xml.entry_kind Coll.Im.t) (uid : int) : Xml.entry = - match Coll.Im.find_opt uid entry_map with +let locate_opt (value : 'a) (location : Xml.location option) : 'a wrapped = + match location with + | Some loc -> Util.locate value (convert_location loc) + | None -> noprops value + +let locate (value : 'a) (location : Xml.location) : 'a wrapped = + Util.locate value (convert_location location) + +let resolve_ref (uid : int) : Xml.entry = + match Coll.Im.find_opt uid !entries with | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) -let rec convert_module_node (entry_map : Xml.entry_kind Coll.Im.t) (mule : Xml.module_node) : Module.T.mule = +let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = + match Coll.Im.find_opt uid !converted_modules with + | Some kind -> kind + | None -> let inline_unit unit = match unit with - | `Ref uid -> resolve_ref entry_map uid + | `Ref uid -> resolve_ref uid | `OtherTODO name -> failwith (name ^ " unit not yet supported") - in let loc = convert_location mule.location in - locate { + in locate { name = noprops mule.uniquename; extendees = []; instancees = []; - body = mule.units |> List.map inline_unit |> List.map (convert_entry entry_map); + body = mule.units |> List.map inline_unit |> List.map convert_entry; defdepth = 0; stage = Parsed; important = true - } loc + } mule.location -and convert_op_decl_node (op_decl_node : Xml.op_decl_node) : Module.T.modunit = - failwith "OpDeclNode conversion not yet supported" +and convert_op_decl_node (node : Xml.op_decl_node) : Module.T.modunit = + match node.kind with + | Variable -> noprops (Variables [(locate_opt node.uniquename node.node.location)]) and convert_user_defined_op_kind (user_defined_op_kind : Xml.user_defined_op_kind) : Module.T.modunit = failwith "UserDefinedOpKind conversion not yet supported" @@ -55,9 +72,9 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = failwith "TheoremNode conversion not yet supported" -and convert_entry (entry_map : Xml.entry_kind Coll.Im.t) (entry : Xml.entry) : Module.T.modunit = +and convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with - | ModuleNode mule -> noprops (Submod (convert_module_node entry_map mule)) + | ModuleNode mule -> noprops (Submod (convert_module_node entry.uid mule)) | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind @@ -66,21 +83,20 @@ and convert_entry (entry_map : Xml.entry_kind Coll.Im.t) (entry : Xml.entry) : M | TheoremNode theorem_node -> convert_theorem_node theorem_node let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - let entry_map = + entries := List.fold_left (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) Coll.Im.empty - ast.context - in let context = Coll.Im.fold - (fun uid kind acc -> - match kind with - | Xml.ModuleNode mule -> Coll.Sm.add mule.uniquename (convert_module_node entry_map mule) acc - | _ -> acc - ) - entry_map - Coll.Sm.empty - in - Ok (context, Coll.Sm.find ast.root_module context) + ast.context; + converted_modules := Coll.Im.empty; + converted_units := Coll.Im.empty; + let root_module_id, root_module = List.find_map (fun (entry : Xml.entry) -> + match entry.kind with + | Xml.ModuleNode mule -> if mule.uniquename = ast.root_module then Some (entry.uid, mule) else None + | _ -> None) ast.context |> Option.get + in let root = convert_module_node root_module_id root_module in + converted_modules := Coll.Im.add root_module_id root !converted_modules; + Ok (Coll.Sm.empty, root) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in diff --git a/src/sany/xml.ml b/src/sany/xml.ml index d9061d38..b9835409 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -103,15 +103,30 @@ let xml_to_location xml = } | _ -> conversion_failure __FUNCTION__ xml +type level = + | Constant + | Variable + | Action + | Temporal +[@@deriving show] + +let int_to_level (n : int) : level = + match n with + | 0 -> Constant + | 1 -> Variable + | 2 -> Action + | 3 -> Temporal + | _ -> Invalid_argument (Printf.sprintf "Invalid level value: %d" n) |> raise + type node = { location : location option; - level : int option; + level : level option; } [@@deriving show] let xml_to_inline_node (children : tree list) = { location = children |> List.find_opt (is_tag "location") |> Option.map xml_to_location; - level = children |> List.find_opt (is_tag "level") |> Option.map xml_child_to_int; + level = children |> List.find_opt (is_tag "level") |> Option.map xml_child_to_int |> Option.map int_to_level; } type numeral_node = { @@ -271,9 +286,21 @@ let xml_to_module_node xml = units = List.filter_map ref_child children } | _ -> conversion_failure __FUNCTION__ xml + +type declaration_kind = + | Variable +[@@deriving show] + +let int_to_declaration_kind (n : int) : declaration_kind = + match n with + | 3 -> Variable + | _ -> Invalid_argument (Printf.sprintf "Invalid declaration kind value: %d" n) |> raise type op_decl_node = { - uniquename : string + uniquename : string; + node : node; + arity : int; + kind : declaration_kind; } [@@deriving show] @@ -281,6 +308,9 @@ let xml_to_op_decl_node (xml : tree) : op_decl_node = match xml with | Node (((_, "OpDeclNode"), _), children) -> ({ uniquename = children |> xml_to_tagged_string "uniquename"; + node = children |> xml_to_inline_node; + arity = children |> xml_to_tagged_int "arity"; + kind = children |> xml_to_tagged_int "kind" |> int_to_declaration_kind; } : op_decl_node) | _ -> conversion_failure __FUNCTION__ xml From 886da6a00d0938c3f7a9f66e6d89f680d800bc38 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 31 Dec 2025 19:20:18 -0800 Subject: [PATCH 15/85] Basic operator definition conversion supported Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 41 +++++++++++++++++++++++++++++++++++------ 1 file changed, 35 insertions(+), 6 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c19dc342..7f319c3d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,5 +1,6 @@ open Property;; open Module.T;; +open Expr.T;; open Util;; let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty @@ -35,6 +36,16 @@ let resolve_ref (uid : int) : Xml.entry = | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) +let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = + match Coll.Im.find_opt param.ref.uid !entries with + | Some (Xml.FormalParamNode xml) -> ( + locate_opt xml.uniquename xml.node.location, + match xml.arity with + | 0 -> Shape_expr + | n -> Shape_op n + ) + | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref.uid) + let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = match Coll.Im.find_opt uid !converted_modules with | Some kind -> kind @@ -53,12 +64,30 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule important = true } mule.location -and convert_op_decl_node (node : Xml.op_decl_node) : Module.T.modunit = - match node.kind with - | Variable -> noprops (Variables [(locate_opt node.uniquename node.node.location)]) - -and convert_user_defined_op_kind (user_defined_op_kind : Xml.user_defined_op_kind) : Module.T.modunit = - failwith "UserDefinedOpKind conversion not yet supported" +and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = + match xml.kind with + | Variable -> noprops (Variables [(locate_opt xml.uniquename xml.node.location)]) + +and convert_expression (xml : Xml.expression) : Expr.T.expr = + match xml with + | NumeralNode xml -> failwith "NumeralNode conversion not yet supported" + | OpApplNode xml -> failwith "OpApplNode conversion not yet supported" + +and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = + match xml.recursive with + | true -> failwith "TLAPS does not yet support recursive operators" + | false -> noprops (Definition ( + Operator ( + locate_opt xml.uniquename xml.node.location, + let expr = xml.body |> convert_expression in + match xml.params with + | [] -> expr + | params -> Lambda (List.map resolve_formal_param_node params, expr) |> noprops + ) |> noprops, + User, + Visible, + Export + )) and convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = failwith "BuiltInKind conversion not yet supported" From 36a0d0339237a0ff9e1b65805ccff87c0b52fc3a Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 1 Jan 2026 15:17:26 -0800 Subject: [PATCH 16/85] Convert many expressions Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 102 ++++++++++++++++++++++++++++++++++++++++++----- src/sany/xml.ml | 14 +++++-- 2 files changed, 104 insertions(+), 12 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 7f319c3d..ecf1a733 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -23,7 +23,7 @@ let convert_location (location : Xml.location) : Loc.locus = { file = location.filename; } -let locate_opt (value : 'a) (location : Xml.location option) : 'a wrapped = +let locate_opt (location : Xml.location option) (value : 'a) : 'a wrapped = match location with | Some loc -> Util.locate value (convert_location loc) | None -> noprops value @@ -39,13 +39,24 @@ let resolve_ref (uid : int) : Xml.entry = let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = match Coll.Im.find_opt param.ref.uid !entries with | Some (Xml.FormalParamNode xml) -> ( - locate_opt xml.uniquename xml.node.location, + locate_opt xml.node.location xml.uniquename, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n ) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref.uid) +let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = + match builtin.uniquename with + | "=" -> Some Builtin.Eq + | "TRUE" -> Some Builtin.TRUE + | "FALSE" -> Some Builtin.FALSE + | "\\in" -> Some Builtin.Mem + | "'" -> Some Builtin.Prime + | "\\land" -> Some Builtin.Conj + | "[]" -> Some (Builtin.Box false) + | _ -> None + let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = match Coll.Im.find_opt uid !converted_modules with | Some kind -> kind @@ -66,22 +77,95 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | Variable -> noprops (Variables [(locate_opt xml.uniquename xml.node.location)]) - -and convert_expression (xml : Xml.expression) : Expr.T.expr = - match xml with - | NumeralNode xml -> failwith "NumeralNode conversion not yet supported" - | OpApplNode xml -> failwith "OpApplNode conversion not yet supported" + | Variable -> noprops (Variables [locate_opt xml.node.location xml.uniquename]) + +(** Conversion of application of all traditional built-in operators like = or + \cup but also things like CHOOSE and \A which one would ordinarily not + view as built-in operators. However, the +*) +and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( + match try_convert_builtin op with + (* Traditional built-in operators *) + | Some builtin -> Apply ( + Internal builtin |> locate_opt op.node.location, + List.map convert_expression_or_operator_argument apply.operands + ) + (* More abstract kinds of built-in operators *) + | None -> ( + match op.uniquename with + | "$SetEnumerate" -> SetEnum (List.map convert_expression_or_operator_argument apply.operands) + | "$UnboundedChoose" -> Choose (noprops "TODO", None, apply.operands |> List.hd |> convert_expression_or_operator_argument) + | "$Tuple" -> Tuple (List.map convert_expression_or_operator_argument apply.operands) + | s -> failwith ("Built-in operator application not yet supported: " ^ s) + ) + ) |> locate_opt apply.node.location + +(** Conversion of application of user-defined operators, including operators + defined in the standard modules. +*) +and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = + Apply ( + Opaque "TODO" |> noprops, + List.map convert_expression_or_operator_argument apply.operands + ) |> locate_opt apply.node.location + +(** Conversion of reference to in-scope operator parameters. +*) +and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.formal_param_node) : Expr.T.expr = + match param.arity with + | 0 -> Opaque param.uniquename |> locate_opt param.node.location + | n -> Apply ( + Opaque param.uniquename |> locate_opt param.node.location, + List.map convert_expression_or_operator_argument apply.operands + ) |> locate_opt apply.node.location + +(** Conversion of reference to constants or variables. *) +and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_node) : Expr.T.expr = + match decl.arity with + | 0 -> Opaque decl.uniquename |> locate_opt decl.node.location + | n -> Apply ( + Opaque decl.uniquename |> locate_opt decl.node.location, + List.map convert_expression_or_operator_argument apply.operands + ) |> locate_opt apply.node.location + +(** OpApplNode is a very general node used by SANY to represent essentially + all expression types. Things like \A x \in S : P are represented as an + application of the built-in "forall" operator, with argument P and symbol + x bound by S. This complicated method de-abstracts this into the more + detailed Expr.T.expr type used by TLAPS. +*) +and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = + let op_kind = (resolve_ref apply.operator).kind in + match op_kind with + (* Operators like = and \cup but also CHOOSE and \A *) + | BuiltInKind op -> convert_built_in_op_appl apply op + (* An operator defined by the user, including operators in the standard modules *) + | UserDefinedOpKind userdef -> convert_user_defined_op_appl apply userdef + (* A reference to an in-scope operator parameter *) + | FormalParamNode param -> convert_formal_param_node_op_appl apply param + (* A reference to a CONSTANT or VARIABLE identifier *) + | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl + | _ -> failwith ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind) ) + +and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Expr.T.expr = + match op_expr with + | Expression expr -> convert_expression expr + +and convert_expression (expr : Xml.expression) : Expr.T.expr = + match expr with + | NumeralNode expr -> Num (Int.to_string expr.value, "") |> locate_opt expr.node.location + | OpApplNode apply -> convert_op_appl_node apply and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = match xml.recursive with | true -> failwith "TLAPS does not yet support recursive operators" | false -> noprops (Definition ( Operator ( - locate_opt xml.uniquename xml.node.location, + locate_opt xml.node.location xml.uniquename, let expr = xml.body |> convert_expression in match xml.params with | [] -> expr + (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) | params -> Lambda (List.map resolve_formal_param_node params, expr) |> noprops ) |> noprops, User, diff --git a/src/sany/xml.ml b/src/sany/xml.ml index b9835409..61130304 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -187,8 +187,9 @@ let xml_to_unbound_symbol xml = type op_appl_node = { node : node; + operator : int; operands : expr_or_op_arg list; - bound_symbols : symbols list; + bound_symbols : symbol list; } [@@deriving show] @@ -214,7 +215,7 @@ and bound_symbol = { expression : expression } -and symbols = +and symbol = | Unbound of unbound_symbol | Bound of bound_symbol [@@deriving show] @@ -242,6 +243,7 @@ and xml_to_op_appl_node xml = match xml with | Node (((_, "OpApplNode"), _), children) -> { node = children |> xml_to_inline_node; + operator = children |> find_tag "operator" |> child_of |> xml_ref_to_int; operands = children |> find_tag "operands" |> children_of |> List.map xml_to_expr_or_op_arg; bound_symbols = children |> List.find_opt (is_tag "boundSymbols") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; } @@ -363,14 +365,20 @@ let xml_to_user_defined_op_kind_ref xml = | _ -> conversion_failure __FUNCTION__ xml type built_in_kind = { - uniquename : string + node : node; + uniquename : string; + arity : int; + params : leibniz_param list; } [@@deriving show] let xml_to_built_in_kind xml : built_in_kind = match xml with | Node (((_, "BuiltInKind"), _), children) -> { + node = children |> xml_to_inline_node; uniquename = children |> xml_to_tagged_string "uniquename"; + arity = children |> xml_to_tagged_int "arity"; + params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; } | _ -> conversion_failure __FUNCTION__ xml From 194f2db7d005973d8189a532bb2fc1ae634d2b97 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 7 Jan 2026 19:43:00 -0800 Subject: [PATCH 17/85] Converted CHOOSE Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 134 ++++++++++++++++++++++++++++++++++++++++------- 1 file changed, 116 insertions(+), 18 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index ecf1a733..529c9e6d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,8 +1,15 @@ open Property;; open Module.T;; open Expr.T;; +open Proof.T;; open Util;; +let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = + let loc = match loc with + | Some loc -> Xml.show_location loc + | None -> "Unknown location" + in failwith (Printf.sprintf "%s not yet implemented: %s\n%s" category msg loc) + let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty let converted_modules : Module.T.mule Coll.Im.t ref = ref Coll.Im.empty @@ -46,15 +53,22 @@ let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = ) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref.uid) +let resolve_bound_symbol (symbol : Xml.formal_param_node_ref) : hint = + match Coll.Im.find_opt symbol.uid !entries with + | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> locate_opt xml.node.location xml.uniquename + | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int symbol.uid) + | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int symbol.uid) + let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.uniquename with - | "=" -> Some Builtin.Eq | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE - | "\\in" -> Some Builtin.Mem | "'" -> Some Builtin.Prime - | "\\land" -> Some Builtin.Conj | "[]" -> Some (Builtin.Box false) + | "=" -> Some Builtin.Eq + | "\\in" -> Some Builtin.Mem + | "\\land" -> Some Builtin.Conj + | "=>" -> Some Builtin.Implies | _ -> None let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = @@ -64,7 +78,7 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule let inline_unit unit = match unit with | `Ref uid -> resolve_ref uid - | `OtherTODO name -> failwith (name ^ " unit not yet supported") + | `OtherTODO name -> todo "Module unit" (name ^ " unit not yet supported") None in locate { name = noprops mule.uniquename; extendees = []; @@ -79,26 +93,103 @@ and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with | Variable -> noprops (Variables [locate_opt xml.node.location xml.uniquename]) +and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr = + match apply.operands with + | [expr; sub] -> Sub ( + op, + convert_expression_or_operator_argument expr, + convert_expression_or_operator_argument sub + ) |> locate_opt apply.node.location + | _ -> failwith "Wrong number of operands to $SquareAct" + +(** This method handles conversion of four cases: + 1. Bounded non-tuple choice like CHOOSE x \in S : P + 2. Bounded tuple choice like CHOOSE <> \in S : P + 3. Unbounded non-tuple choice like CHOOSE x : P + 4. Unbounded tuple choice like CHOOSE <> : P + + The XML representation of these does not really adhere very well to the + principle of making invalid state unrepresentable, so there is a range of + possible input data that theoretically should never occur but nonetheless + must be handled in OCaml match statements. +*) +and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = + let convert_bounded_choose (symbol : Xml.formal_param_node_ref) (set : Xml.expression) (body : Xml.expr_or_op_arg) : Expr.T.expr = + Choose ( + resolve_bound_symbol symbol, + Some (convert_expression set), + convert_expression_or_operator_argument body + ) |> locate_opt apply.node.location + in let convert_bounded_tuple_choose (symbols : Xml.formal_param_node_ref list) (set : Xml.expression) (body : Xml.expr_or_op_arg) : Expr.T.expr = + ChooseTuply ( + List.map resolve_bound_symbol symbols, + Some (convert_expression set), + convert_expression_or_operator_argument body + ) |> locate_opt apply.node.location + in let convert_unbounded_choose (symbol : Xml.formal_param_node_ref) (body : Xml.expr_or_op_arg) : Expr.T.expr = + Choose ( + resolve_bound_symbol symbol, + None, + convert_expression_or_operator_argument body + ) |> locate_opt apply.node.location + in let convert_unbounded_tuple_choose (symbols : Xml.formal_param_node_ref list) (body : Xml.expr_or_op_arg) : Expr.T.expr = + ChooseTuply ( + List.map resolve_bound_symbol symbols, + None, + convert_expression_or_operator_argument body + ) |> locate_opt apply.node.location + in match (apply.bound_symbols, apply.operands) with + | ([Bound ({is_tuple = false; formal_param_node_refs = [param]} as symbol)], [body]) -> + convert_bounded_choose param symbol.expression body + | ([Bound ({is_tuple = true} as symbol)], [body]) -> + convert_bounded_tuple_choose symbol.formal_param_node_refs symbol.expression body + | ([Unbound ({is_tuple = false} as symbol)], [body]) -> + convert_unbounded_choose symbol.formal_param_node_ref body + | (Unbound {is_tuple = true} :: _, [body]) -> + let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in + if List.length symbols <> List.length apply.bound_symbols + then failwith "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" + else convert_unbounded_tuple_choose (List.map (fun (s : Xml.unbound_symbol) -> s.formal_param_node_ref) symbols) body + | _ -> failwith "Invalid number of bounds or operands to CHOOSE" + +and convert_bounded_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = + match apply.operands with + | [body] -> Opaque "TODO_bounded_quantification" |> locate_opt apply.node.location + | _ -> failwith "Wrong number of operands to bounded exists" + +and convert_unbounded_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = + match apply.operands with + | [body] -> Opaque "TODO_unbounded_quantification" |> locate_opt apply.node.location + | _ -> failwith "Wrong number of operands to unbounded quantification" + (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not - view as built-in operators. However, the + view as built-in operators. *) -and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( +and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = match try_convert_builtin op with (* Traditional built-in operators *) | Some builtin -> Apply ( Internal builtin |> locate_opt op.node.location, List.map convert_expression_or_operator_argument apply.operands - ) + ) |> locate_opt apply.node.location (* More abstract kinds of built-in operators *) | None -> ( match op.uniquename with - | "$SetEnumerate" -> SetEnum (List.map convert_expression_or_operator_argument apply.operands) - | "$UnboundedChoose" -> Choose (noprops "TODO", None, apply.operands |> List.hd |> convert_expression_or_operator_argument) - | "$Tuple" -> Tuple (List.map convert_expression_or_operator_argument apply.operands) - | s -> failwith ("Built-in operator application not yet supported: " ^ s) + | "$SetEnumerate" -> SetEnum ( + List.map convert_expression_or_operator_argument apply.operands + ) |> locate_opt apply.node.location + | "$Tuple" -> Tuple ( + List.map convert_expression_or_operator_argument apply.operands + ) |> locate_opt apply.node.location + | "$UnboundedChoose" -> convert_choose apply + | "$SquareAct" -> convert_action_expr Box apply + | "$BoundedExists" -> convert_bounded_quantification Exists apply op + | "$BoundedForall" -> convert_bounded_quantification Forall apply op + | "$UnboundedExists" -> convert_unbounded_quantification Exists apply op + | "$UnboundedForall" -> convert_unbounded_quantification Forall apply op + | s -> todo "Built-in operator" s apply.node.location ) - ) |> locate_opt apply.node.location (** Conversion of application of user-defined operators, including operators defined in the standard modules. @@ -174,16 +265,23 @@ and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modu )) and convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = - failwith "BuiltInKind conversion not yet supported" + todo "BuiltInKind" "" built_in_kind.node.location and convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = - failwith "FormalParamNode conversion not yet supported" + todo "FormalParamNode" "" formal_param_node.node.location and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = - failwith "TheoremDefNode conversion not yet supported" + todo "TheoremDefNode" "" theorem_def_node.node.location -and convert_theorem_node (theorem_node : Xml.theorem_node) : Module.T.modunit = - failwith "TheoremNode conversion not yet supported" +and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = Theorem ( + Some (noprops "TODO_thm_name"), + (match thm.body with + | Expression expr -> { context = Deque.empty; active = convert_expression expr}), + 0 (* TODO figure out what this integer parameter means *), + noprops Obvious, (* TODO convert proof *) + noprops Obvious, (* TODO figure out why there are two proofs *) + empty_summary (* TODO figure out purpose of summary *) +) |> locate_opt thm.node.location and convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with @@ -210,7 +308,7 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string in let root = convert_module_node root_module_id root_module in converted_modules := Coll.Im.add root_module_id root !converted_modules; Ok (Coll.Sm.empty, root) - + let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in Option.to_result ~none:(None, "TLAPS standard library cannot be found") Params.stdlib_path From 905e48281eef70e5ddbe74645cc41fabc099fd8a Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 7 Jan 2026 21:35:12 -0800 Subject: [PATCH 18/85] Quantification conversion begin Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 97 ++++++++++++++++++++++++++++++------------------ 1 file changed, 61 insertions(+), 36 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 529c9e6d..d8d4f544 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -67,8 +67,10 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "[]" -> Some (Builtin.Box false) | "=" -> Some Builtin.Eq | "\\in" -> Some Builtin.Mem + | "\\notin" -> Some Builtin.Notmem | "\\land" -> Some Builtin.Conj | "=>" -> Some Builtin.Implies + | "\\equiv" -> Some Builtin.Equiv | _ -> None let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = @@ -114,53 +116,75 @@ and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr must be handled in OCaml match statements. *) and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = - let convert_bounded_choose (symbol : Xml.formal_param_node_ref) (set : Xml.expression) (body : Xml.expr_or_op_arg) : Expr.T.expr = + match apply.bound_symbols, apply.operands with + (* Case 1: Bounded non-tuple CHOOSE expression *) + | [Bound {is_tuple = false; formal_param_node_refs = [param]; expression}], [body] -> Choose ( - resolve_bound_symbol symbol, - Some (convert_expression set), + resolve_bound_symbol param, + Some (convert_expression expression), convert_expression_or_operator_argument body ) |> locate_opt apply.node.location - in let convert_bounded_tuple_choose (symbols : Xml.formal_param_node_ref list) (set : Xml.expression) (body : Xml.expr_or_op_arg) : Expr.T.expr = + (* Case 2: Bounded tuple CHOOSE expression *) + | [Bound ({is_tuple = true} as symbol)], [body] -> ChooseTuply ( - List.map resolve_bound_symbol symbols, - Some (convert_expression set), + List.map resolve_bound_symbol symbol.formal_param_node_refs, + Some (convert_expression symbol.expression), convert_expression_or_operator_argument body ) |> locate_opt apply.node.location - in let convert_unbounded_choose (symbol : Xml.formal_param_node_ref) (body : Xml.expr_or_op_arg) : Expr.T.expr = + (* Case 3: Unbounded non-tuple CHOOSE expression *) + | [Unbound ({is_tuple = false} as symbol)], [body] -> Choose ( - resolve_bound_symbol symbol, + resolve_bound_symbol symbol.formal_param_node_ref, None, convert_expression_or_operator_argument body ) |> locate_opt apply.node.location - in let convert_unbounded_tuple_choose (symbols : Xml.formal_param_node_ref list) (body : Xml.expr_or_op_arg) : Expr.T.expr = - ChooseTuply ( - List.map resolve_bound_symbol symbols, - None, - convert_expression_or_operator_argument body - ) |> locate_opt apply.node.location - in match (apply.bound_symbols, apply.operands) with - | ([Bound ({is_tuple = false; formal_param_node_refs = [param]} as symbol)], [body]) -> - convert_bounded_choose param symbol.expression body - | ([Bound ({is_tuple = true} as symbol)], [body]) -> - convert_bounded_tuple_choose symbol.formal_param_node_refs symbol.expression body - | ([Unbound ({is_tuple = false} as symbol)], [body]) -> - convert_unbounded_choose symbol.formal_param_node_ref body - | (Unbound {is_tuple = true} :: _, [body]) -> + (* Case 4: Unbounded tuple CHOOSE expression *) + | Unbound {is_tuple = true} :: _, [body] -> let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in if List.length symbols <> List.length apply.bound_symbols then failwith "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" - else convert_unbounded_tuple_choose (List.map (fun (s : Xml.unbound_symbol) -> s.formal_param_node_ref) symbols) body + else ChooseTuply ( + List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.formal_param_node_ref) symbols, + None, + convert_expression_or_operator_argument body + ) |> locate_opt apply.node.location | _ -> failwith "Invalid number of bounds or operands to CHOOSE" -and convert_bounded_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = - match apply.operands with - | [body] -> Opaque "TODO_bounded_quantification" |> locate_opt apply.node.location - | _ -> failwith "Wrong number of operands to bounded exists" - -and convert_unbounded_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = - match apply.operands with - | [body] -> Opaque "TODO_unbounded_quantification" |> locate_opt apply.node.location - | _ -> failwith "Wrong number of operands to unbounded quantification" +(** Handles conversion of both bounded & unbounded quantification. Both sides + of the conversion here are fairly weird. The SANY AST has the same issues + as in the CHOOSE conversion where many invalid states are unrepresentable + although at least the troublesome unbounded tuple case does not exist. + The TLAPM AST has an artificial distinction between tuple and non-tuple + quantification due to support for tuple quantification being added at a + later date. In reality, mixed tuple/non-tuple quantification is a regular + feature of TLA+ so ideally these would be folded into a single variant. + This is perhaps a good target for future refactoring. TLAPM's method of + representing bounds is also very odd (and that oddity is, unfortunately, + made worse by its duplication in the tuply_bounds type). Of particular + note is the bound_domain type, a variant which encompasses an ordinary + domain expression, no domain, and also "ditto". The latter is used to + indicate that the domain of a bound is the same as the previous bound's + domain. At a functional level this is complex to deal with as it means + each bound must be processed in sequence with knowledge of the previous + bound's domain, necessitating use of fold instead of map. The resulting + code never fails to be mind-bending. +*) +and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = + match apply.bound_symbols, apply.operands with + | _ :: _, [body] -> ( + if List.exists (fun (b : Xml.symbol) -> match b with | Bound {is_tuple = true} -> true | _ -> false) apply.bound_symbols + then QuantTuply ( + quant, + [], + convert_expression_or_operator_argument body + ) + else Quant ( + quant, + [], + convert_expression_or_operator_argument body + ) + ) |> locate_opt apply.node.location + | _ -> failwith "Invalid number of bounds or operands to quantification" (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not @@ -182,12 +206,13 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) | "$Tuple" -> Tuple ( List.map convert_expression_or_operator_argument apply.operands ) |> locate_opt apply.node.location + | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply - | "$BoundedExists" -> convert_bounded_quantification Exists apply op - | "$BoundedForall" -> convert_bounded_quantification Forall apply op - | "$UnboundedExists" -> convert_unbounded_quantification Exists apply op - | "$UnboundedForall" -> convert_unbounded_quantification Forall apply op + | "$BoundedExists" -> convert_quantification Exists apply op + | "$BoundedForall" -> convert_quantification Forall apply op + | "$UnboundedExists" -> convert_quantification Exists apply op + | "$UnboundedForall" -> convert_quantification Forall apply op | s -> todo "Built-in operator" s apply.node.location ) From ea19f3615537356818d488df40a523edfc01d254 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 8 Jan 2026 14:44:38 -0800 Subject: [PATCH 19/85] Quantification conversion complete Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 71 ++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 56 insertions(+), 15 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index d8d4f544..e00a531d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -115,7 +115,7 @@ and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr possible input data that theoretically should never occur but nonetheless must be handled in OCaml match statements. *) -and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = +and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with (* Case 1: Bounded non-tuple CHOOSE expression *) | [Bound {is_tuple = false; formal_param_node_refs = [param]; expression}], [body] -> @@ -123,21 +123,21 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = resolve_bound_symbol param, Some (convert_expression expression), convert_expression_or_operator_argument body - ) |> locate_opt apply.node.location + ) (* Case 2: Bounded tuple CHOOSE expression *) | [Bound ({is_tuple = true} as symbol)], [body] -> ChooseTuply ( List.map resolve_bound_symbol symbol.formal_param_node_refs, Some (convert_expression symbol.expression), convert_expression_or_operator_argument body - ) |> locate_opt apply.node.location + ) (* Case 3: Unbounded non-tuple CHOOSE expression *) | [Unbound ({is_tuple = false} as symbol)], [body] -> Choose ( resolve_bound_symbol symbol.formal_param_node_ref, None, convert_expression_or_operator_argument body - ) |> locate_opt apply.node.location + ) (* Case 4: Unbounded tuple CHOOSE expression *) | Unbound {is_tuple = true} :: _, [body] -> let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in @@ -147,12 +147,13 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.formal_param_node_ref) symbols, None, convert_expression_or_operator_argument body - ) |> locate_opt apply.node.location + ) | _ -> failwith "Invalid number of bounds or operands to CHOOSE" +) |> locate_opt apply.node.location (** Handles conversion of both bounded & unbounded quantification. Both sides of the conversion here are fairly weird. The SANY AST has the same issues - as in the CHOOSE conversion where many invalid states are unrepresentable + as in the CHOOSE conversion where many invalid states are representable although at least the troublesome unbounded tuple case does not exist. The TLAPM AST has an artificial distinction between tuple and non-tuple quantification due to support for tuple quantification being added at a @@ -167,24 +168,64 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = domain. At a functional level this is complex to deal with as it means each bound must be processed in sequence with knowledge of the previous bound's domain, necessitating use of fold instead of map. The resulting - code never fails to be mind-bending. + code never fails to be mind-bending. It also allows representation of + invalid states, as bound & unbound quantification cannot be mixed in + valid TLA⁺ syntax. Ideally quantification would be split at the top level + between bound & unbound, where the bound case has a nonempty list of + bounds, each of which is either tuple or non-tuple and consists of a + nonempty list of symbols and a domain expression. The unbound case would + be a simple nonempty list of symbols. *) -and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = +and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | _ :: _, [body] -> ( - if List.exists (fun (b : Xml.symbol) -> match b with | Bound {is_tuple = true} -> true | _ -> false) apply.bound_symbols - then QuantTuply ( + | _ :: _, [body] -> + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in + let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) apply.bound_symbols in + if unbound_symbols <> [] + then + if bound_symbols <> [] + then failwith "Cannot mix bound and unbound symbols in quantification" + else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols + then failwith "Unbounded tuple quantification is not supported" + (* Unbounded quantification *) + else let mk_bound (bound : Xml.unbound_symbol) : bound = ( + resolve_bound_symbol bound.formal_param_node_ref, + Unknown, (* TODO: figure out purpose of this parameter *) + No_domain + ) in Quant ( + quant, + List.map mk_bound unbound_symbols, + convert_expression_or_operator_argument body + ) + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + (* Bounded quantification that includes at least one tuple *) + then let mk_bounds (bound : Xml.bound_symbol) : tuply_bounds = + if bound.is_tuple + then match List.map resolve_bound_symbol bound.formal_param_node_refs with + | (_ :: _ as symbols) -> [(Bound_names symbols, Domain (convert_expression bound.expression))] + | [] -> failwith "Tuple bound symbol groups must have at least one symbol" + else match List.map resolve_bound_symbol bound.formal_param_node_refs with + | hd :: tl -> (Bound_name hd, Domain (convert_expression bound.expression)) + :: List.map (fun s -> (Bound_name s, Ditto)) tl + | [] -> failwith "Bound symbol groups must have at least one symbol" + in QuantTuply ( quant, - [], + List.map mk_bounds bound_symbols |> List.flatten, convert_expression_or_operator_argument body ) - else Quant ( + (* Bounded quantification without any tuples *) + else let mk_bounds (bound : Xml.bound_symbol) : bounds = + match List.map resolve_bound_symbol bound.formal_param_node_refs with + | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) + :: List.map (fun s -> (s, Unknown, Ditto)) tl + | [] -> failwith "Bound symbol groups must have at least one symbol" + in Quant ( quant, - [], + List.map mk_bounds bound_symbols |> List.flatten, convert_expression_or_operator_argument body ) - ) |> locate_opt apply.node.location | _ -> failwith "Invalid number of bounds or operands to quantification" +) |> locate_opt apply.node.location (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not From 86c46bb3102eb9e689bc4d9ffb8cebf92de85e32 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 8 Jan 2026 17:03:00 -0800 Subject: [PATCH 20/85] Theorem name conversion Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 31 ++- test/sany/AddTwo.tla | 2 +- test/sany/AddTwo.xml | 466 ++++++++++++++++++++++++++++++++++++++++--- 3 files changed, 456 insertions(+), 43 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index e00a531d..9488ee53 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -262,7 +262,7 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) *) and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = Apply ( - Opaque "TODO" |> noprops, + Opaque op.uniquename |> locate_opt op.node.location, List.map convert_expression_or_operator_argument apply.operands ) |> locate_opt apply.node.location @@ -339,15 +339,26 @@ and convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Modu and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = todo "TheoremDefNode" "" theorem_def_node.node.location -and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = Theorem ( - Some (noprops "TODO_thm_name"), - (match thm.body with - | Expression expr -> { context = Deque.empty; active = convert_expression expr}), - 0 (* TODO figure out what this integer parameter means *), - noprops Obvious, (* TODO convert proof *) - noprops Obvious, (* TODO figure out why there are two proofs *) - empty_summary (* TODO figure out purpose of summary *) -) |> locate_opt thm.node.location +(** Converts theorem nodes. Oddly, SANY has two different theorem node types + containing identical information except TheoremDefNode contains the name + and TheoremNode does not. TLAPM's theorem node construction has some + oddities in the form of additional metadata. +*) +and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = + let get_thm_name (thm : Xml.theorem_def_ref) : hint = + match (resolve_ref thm.uid).kind with + | TheoremDefNode def -> locate_opt def.node.location def.uniquename + | _ -> failwith ("Unresolved theorem definition UID: " ^ string_of_int thm.uid) + in Theorem ( + Option.map get_thm_name thm.definition, + (match thm.body with + | Expression expr -> { context = Deque.empty; active = convert_expression expr}), + (* TODO handle assume/prove *) + 0 (* TODO figure out what this integer parameter means *), + noprops Obvious, (* TODO convert proof *) + noprops Obvious, (* TODO figure out why there are two proofs *) + empty_summary (* TODO figure out purpose of summary *) + ) |> locate_opt thm.node.location and convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with diff --git a/test/sany/AddTwo.tla b/test/sany/AddTwo.tla index fffa3796..d5c1385e 100644 --- a/test/sany/AddTwo.tla +++ b/test/sany/AddTwo.tla @@ -17,7 +17,7 @@ a|b == \E c \in Nat : a*c = b Even == 2|x -THEOREM Spec => []Even +THEOREM thm == Spec => []Even <1>a. Init => Even BY DEF Init, Even, | <1>b. Even /\ UNCHANGED vars => Even' diff --git a/test/sany/AddTwo.xml b/test/sany/AddTwo.xml index da872f07..47d63c1b 100644 --- a/test/sany/AddTwo.xml +++ b/test/sany/AddTwo.xml @@ -19,6 +19,7 @@ 0 SlowSimplification 0 + @@ -61,6 +62,7 @@ 0 SlowerSimplification 0 + @@ -103,6 +105,7 @@ 0 SlowestSimplification 0 + @@ -145,6 +148,17 @@ 0 Blast 0 + @@ -187,6 +201,7 @@ 0 SlowBlast 0 + @@ -229,6 +244,7 @@ 0 SlowerBlast 0 + @@ -271,6 +287,7 @@ 0 SlowestBlast 0 + @@ -313,6 +330,7 @@ 0 AutoBlast 0 + @@ -355,6 +373,17 @@ 0 AllProvers 0 + @@ -415,6 +444,21 @@ 0 AllProversT 1 + @@ -464,6 +508,21 @@ 0 AllSMT 0 + @@ -524,6 +583,13 @@ 0 AllSMTT 1 + @@ -573,6 +639,13 @@ 0 AllIsa 0 + @@ -633,6 +706,14 @@ 0 AllIsaT 1 + @@ -682,6 +763,28 @@ 0 ExpandENABLED 0 + @@ -724,6 +827,7 @@ 0 ExpandCdot 0 + @@ -766,6 +870,7 @@ 0 AutoUSE 0 + @@ -808,6 +913,7 @@ 0 Lambdify 0 + @@ -850,6 +956,7 @@ 0 ENABLEDaxioms 0 + @@ -892,6 +999,7 @@ 0 LevelComparison 0 + @@ -952,6 +1060,9 @@ 0 EnabledWrapper 1 + @@ -1068,6 +1179,10 @@ 0 Trivial 0 + @@ -1376,7 +1491,7 @@ 476 - 670 + 671 @@ -2230,7 +2345,107 @@ - 612 + 608 + + + + 1 + 43 + + + 20 + 28 + + AddTwo + + 3 + thm + + + + 16 + 29 + + + 20 + 20 + + AddTwo + + 3 + + + 178 + + + + + + + 16 + 19 + + + 20 + 20 + + AddTwo + + 3 + + + 592 + + + + + + + + 24 + 29 + + + 20 + 20 + + AddTwo + + 3 + + + 211 + + + + + + + 26 + 29 + + + 20 + 20 + + AddTwo + + 1 + + + 607 + + + + + + + + + + + + 613 @@ -2309,7 +2524,7 @@ - 618 + 619 @@ -2325,7 +2540,7 @@ 1 - 612 + 613 @@ -2420,7 +2635,7 @@ - 619 + 620 @@ -2582,7 +2797,7 @@ - 629 + 630 @@ -2598,7 +2813,7 @@ 2 - 619 + 620 @@ -2773,7 +2988,7 @@ - 630 + 631 @@ -2914,7 +3129,7 @@ - 638 + 639 @@ -2933,7 +3148,7 @@ - 660 + 661 @@ -2949,7 +3164,7 @@ 2 - 630 + 631 @@ -3182,7 +3397,7 @@ 0 - 638 + 639 @@ -3313,7 +3528,7 @@ 0 - 638 + 639 @@ -3405,7 +3620,7 @@ 0 - 638 + 639 @@ -3437,7 +3652,7 @@ - 638 + 639 @@ -3588,7 +3803,7 @@ - 668 + 669 @@ -3673,7 +3888,7 @@ 1 - 612 + 613 @@ -3693,7 +3908,7 @@ 2 - 619 + 620 @@ -3713,7 +3928,7 @@ 2 - 630 + 631 @@ -3728,7 +3943,7 @@ - 670 + 671 @@ -3742,12 +3957,17 @@ AddTwo 3 + + + 608 + + - 9 - 22 + 16 + 29 20 @@ -3765,8 +3985,8 @@ - 9 - 12 + 16 + 19 20 @@ -3785,8 +4005,8 @@ - 17 - 22 + 24 + 29 20 @@ -3804,8 +4024,8 @@ - 19 - 22 + 26 + 29 20 @@ -3840,16 +4060,16 @@ 2 - 618 + 619 - 629 + 630 - 660 + 661 - 668 + 669 @@ -4501,6 +4721,18 @@ 0 Nat 0 + @@ -5698,6 +5930,15 @@ 0 % 2 + 0 , the following formula is true: *) +(* *) +(* a = b * (a \div b) + (a % b) *) +(***************************************************************************)]]> @@ -6286,6 +6527,23 @@ 0 SimpleArithmetic 0 + @@ -6328,6 +6586,16 @@ 0 SMT 0 + @@ -6388,6 +6656,7 @@ 0 SMTT 1 + @@ -6437,6 +6706,13 @@ 0 CVC3 0 + @@ -6497,6 +6773,7 @@ 0 CVC3T 1 + @@ -6546,6 +6823,7 @@ 0 CVC4 0 + @@ -6606,6 +6884,7 @@ 0 CVC4T 1 + @@ -6655,6 +6934,12 @@ 0 Yices 0 + @@ -6715,6 +7000,7 @@ 0 YicesT 1 + @@ -6764,6 +7050,12 @@ 0 veriT 0 + @@ -6824,6 +7116,7 @@ 0 veriTT 1 + @@ -6873,6 +7166,13 @@ 0 Zipper 0 + @@ -6933,6 +7233,7 @@ 0 ZipperT 1 + @@ -6982,6 +7283,13 @@ 0 Z3 0 + @@ -7042,6 +7350,7 @@ 0 Z3T 1 + @@ -7091,6 +7400,13 @@ 0 Spass 0 + @@ -7151,6 +7467,7 @@ 0 SpassT 1 + @@ -7200,6 +7517,14 @@ 0 LS4 0 + @@ -7260,6 +7585,7 @@ 0 LS4T 1 + @@ -7309,6 +7635,7 @@ 0 PTL 0 + @@ -7351,6 +7678,11 @@ 0 Zenon 0 + @@ -7411,6 +7743,7 @@ 0 ZenonT 1 + @@ -7460,6 +7793,11 @@ 0 Isa 0 + @@ -7520,6 +7858,7 @@ 0 IsaT 1 + @@ -7587,6 +7926,7 @@ 0 IsaM 1 + @@ -7672,6 +8012,7 @@ 0 IsaMT 2 + @@ -7727,6 +8068,19 @@ 0 IsaWithSetExtensionality 0 + (\A x : (x \in S) <=> (x \in T)) *) +(* *) +(* Theorem SetExtensionality is sometimes required by the SMT backend for *) +(* reasoning about sets. It is usually counterproductive to include *) +(* theorem SetExtensionality in a BY clause for the Zenon or Isabelle *) +(* backends. Instead, use the pragma IsaWithSetExtensionality to instruct *) +(* the Isabelle backend to use the rule of set extensionality. *) +(***************************************************************************)]]> @@ -8782,6 +9136,17 @@ 0 SlowZenon 0 + @@ -8824,6 +9189,7 @@ 0 SlowerZenon 0 + @@ -8866,6 +9232,7 @@ 0 VerySlowZenon 0 + @@ -8908,6 +9275,7 @@ 0 SlowestZenon 0 + @@ -8950,6 +9318,14 @@ 0 Auto 0 + @@ -8992,6 +9368,7 @@ 0 SlowAuto 0 + @@ -9034,6 +9411,7 @@ 0 SlowerAuto 0 + @@ -9076,6 +9454,7 @@ 0 SlowestAuto 0 + @@ -9118,6 +9497,13 @@ 0 Force 0 + @@ -9160,6 +9546,7 @@ 0 SlowForce 0 + @@ -9202,6 +9589,7 @@ 0 SlowerForce 0 + @@ -9244,6 +9632,7 @@ 0 SlowestForce 0 + @@ -9286,6 +9675,15 @@ 0 SimplifyAndSolve 0 + @@ -9328,6 +9726,7 @@ 0 SlowSimplifyAndSolve 0 + @@ -9370,6 +9769,7 @@ 0 SlowerSimplifyAndSolve 0 + @@ -9412,6 +9812,7 @@ 0 SlowestSimplifyAndSolve 0 + @@ -9454,6 +9855,7 @@ 0 Simplification 0 + From 22fc0fcea9bca433243d0cb66d31bb509addf9be Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 9 Jan 2026 12:02:08 -0800 Subject: [PATCH 21/85] Added comments Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 133 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 93 insertions(+), 40 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 9488ee53..e606ce05 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -16,6 +16,9 @@ let converted_modules : Module.T.mule Coll.Im.t ref = ref Coll.Im.empty let converted_units : Module.T.modunit Coll.Im.t ref = ref Coll.Im.empty +(** Converts SANY's location format to TLAPM's, for attachment to node + metadata. +*) let convert_location (location : Xml.location) : Loc.locus = { start = Actual { line = location.line.start; @@ -30,14 +33,16 @@ let convert_location (location : Xml.location) : Loc.locus = { file = location.filename; } -let locate_opt (location : Xml.location option) (value : 'a) : 'a wrapped = - match location with - | Some loc -> Util.locate value (convert_location loc) - | None -> noprops value - let locate (value : 'a) (location : Xml.location) : 'a wrapped = Util.locate value (convert_location location) +(** Wrap the given object in location and (eventually) level information. +*) +let attach_props (props : Xml.node) (value : 'a) : 'a wrapped = + match props.location with + | Some loc -> Util.locate value (convert_location loc) + | None -> noprops value + let resolve_ref (uid : int) : Xml.entry = match Coll.Im.find_opt uid !entries with | Some kind -> {uid; kind} @@ -46,7 +51,7 @@ let resolve_ref (uid : int) : Xml.entry = let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = match Coll.Im.find_opt param.ref.uid !entries with | Some (Xml.FormalParamNode xml) -> ( - locate_opt xml.node.location xml.uniquename, + attach_props xml.node xml.uniquename, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n @@ -55,10 +60,12 @@ let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = let resolve_bound_symbol (symbol : Xml.formal_param_node_ref) : hint = match Coll.Im.find_opt symbol.uid !entries with - | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> locate_opt xml.node.location xml.uniquename + | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.uniquename | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int symbol.uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int symbol.uid) +(** Converts built-in prefix, infix, and postfix operators along with keywords. +*) let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.uniquename with | "TRUE" -> Some Builtin.TRUE @@ -73,6 +80,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "\\equiv" -> Some Builtin.Equiv | _ -> None +(** Converts a top-level module node. *) let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = match Coll.Im.find_opt uid !converted_modules with | Some kind -> kind @@ -81,6 +89,22 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule match unit with | `Ref uid -> resolve_ref uid | `OtherTODO name -> todo "Module unit" (name ^ " unit not yet supported") None + (** Converts an entry, which is an abstract type that can be all sorts of + things; SANY heavily uses GUIDs to reference one entity from another and + those GUIDs are resolved in a global table with no real type information. + Thus in-scope operator parameters coexist alongside entire modules, and + here we branch out to the appropriate conversion method. Some types are + invalid here at the global scope, and we avoid handling them. + *) + in let convert_entry (entry : Xml.entry) : Module.T.modunit = + match entry.kind with + | ModuleNode mule -> noprops (Submod (convert_module_node entry.uid mule)) + | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node + | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind + | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind + | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node + | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node + | TheoremNode theorem_node -> convert_theorem_node theorem_node in locate { name = noprops mule.uniquename; extendees = []; @@ -91,18 +115,22 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule important = true } mule.location +(** Converts operator declarations such as CONSTANTS and VARIABLES. +*) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | Variable -> noprops (Variables [locate_opt xml.node.location xml.uniquename]) + | Variable -> noprops (Variables [attach_props xml.node xml.uniquename]) +(** Converts action-level expressions such as [][expr]_sub and <><>_sub. +*) and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr = match apply.operands with | [expr; sub] -> Sub ( op, convert_expression_or_operator_argument expr, convert_expression_or_operator_argument sub - ) |> locate_opt apply.node.location - | _ -> failwith "Wrong number of operands to $SquareAct" + ) |> attach_props apply.node + | _ -> failwith "Wrong number of operands to action expression" (** This method handles conversion of four cases: 1. Bounded non-tuple choice like CHOOSE x \in S : P @@ -149,7 +177,7 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( convert_expression_or_operator_argument body ) | _ -> failwith "Invalid number of bounds or operands to CHOOSE" -) |> locate_opt apply.node.location +) |> attach_props apply.node (** Handles conversion of both bounded & unbounded quantification. Both sides of the conversion here are fairly weird. The SANY AST has the same issues @@ -225,7 +253,7 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node convert_expression_or_operator_argument body ) | _ -> failwith "Invalid number of bounds or operands to quantification" -) |> locate_opt apply.node.location +) |> attach_props apply.node (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not @@ -235,18 +263,18 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) match try_convert_builtin op with (* Traditional built-in operators *) | Some builtin -> Apply ( - Internal builtin |> locate_opt op.node.location, + Internal builtin |> attach_props op.node, List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node (* More abstract kinds of built-in operators *) | None -> ( match op.uniquename with | "$SetEnumerate" -> SetEnum ( List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node | "$Tuple" -> Tuple ( List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply @@ -262,28 +290,35 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) *) and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = Apply ( - Opaque op.uniquename |> locate_opt op.node.location, + Opaque op.uniquename |> attach_props op.node, List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node -(** Conversion of reference to in-scope operator parameters. +(** Conversion of reference to in-scope operator parameters, such as in + op(a, b, c) == a. This is a case where information is actually lost, + since the reference is converted to a simple string that will be resolved + again later on by turning it into a De Bruijn index (Ix) type. It might + be possible to convert the reference into a De Bruijn index directly. *) and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.formal_param_node) : Expr.T.expr = match param.arity with - | 0 -> Opaque param.uniquename |> locate_opt param.node.location + | 0 -> Opaque param.uniquename |> attach_props param.node | n -> Apply ( - Opaque param.uniquename |> locate_opt param.node.location, + Opaque param.uniquename |> attach_props param.node, List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node -(** Conversion of reference to constants or variables. *) +(** Conversion of reference to module-level constants or variables. Again + information is lost and the string will need to be resolved into a De + Bruijn index later on. +*) and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_node) : Expr.T.expr = match decl.arity with - | 0 -> Opaque decl.uniquename |> locate_opt decl.node.location + | 0 -> Opaque decl.uniquename |> attach_props decl.node | n -> Apply ( - Opaque decl.uniquename |> locate_opt decl.node.location, + Opaque decl.uniquename |> attach_props decl.node, List.map convert_expression_or_operator_argument apply.operands - ) |> locate_opt apply.node.location + ) |> attach_props apply.node (** OpApplNode is a very general node used by SANY to represent essentially all expression types. Things like \A x \in S : P are represented as an @@ -304,21 +339,34 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl | _ -> failwith ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind) ) +(** Some places in TLA⁺ syntax allow both normal expressions and also + operators. Mainly this occurs when applying an operator that could accept + another operator as a parameter. So any time the user calls an operator + like op(x, y, z), x, y, and z can each be either expressions or operator + references. LAMBDA operators can also appear here. +*) and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Expr.T.expr = match op_expr with | Expression expr -> convert_expression expr + (* TODO: add support for operators here *) +(** Converts a basic expression type, which will be either a primitive value + or an operator application. +*) and convert_expression (expr : Xml.expression) : Expr.T.expr = match expr with - | NumeralNode expr -> Num (Int.to_string expr.value, "") |> locate_opt expr.node.location + | NumeralNode expr -> Num (Int.to_string expr.value, "") |> attach_props expr.node | OpApplNode apply -> convert_op_appl_node apply +(** Converts user-defined operators defined in a module top-level or within + LET/IN expressions. +*) and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = match xml.recursive with | true -> failwith "TLAPS does not yet support recursive operators" | false -> noprops (Definition ( Operator ( - locate_opt xml.node.location xml.uniquename, + attach_props xml.node xml.uniquename, let expr = xml.body |> convert_expression in match xml.params with | [] -> expr @@ -336,6 +384,12 @@ and convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit and convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = todo "FormalParamNode" "" formal_param_node.node.location +(** This type is redundant with the below TheoremNode type and its conversion + does not need to be handled. Probably the SANY XML exporter should be + refactored to combine these two types. The only difference is that this + type contains the name of the theorem, like in THEOREM thm == expr, while + the other does not. +*) and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module.T.modunit = todo "TheoremDefNode" "" theorem_def_node.node.location @@ -347,7 +401,7 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = let get_thm_name (thm : Xml.theorem_def_ref) : hint = match (resolve_ref thm.uid).kind with - | TheoremDefNode def -> locate_opt def.node.location def.uniquename + | TheoremDefNode def -> attach_props def.node def.uniquename | _ -> failwith ("Unresolved theorem definition UID: " ^ string_of_int thm.uid) in Theorem ( Option.map get_thm_name thm.definition, @@ -358,18 +412,14 @@ and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = noprops Obvious, (* TODO convert proof *) noprops Obvious, (* TODO figure out why there are two proofs *) empty_summary (* TODO figure out purpose of summary *) - ) |> locate_opt thm.node.location - -and convert_entry (entry : Xml.entry) : Module.T.modunit = - match entry.kind with - | ModuleNode mule -> noprops (Submod (convert_module_node entry.uid mule)) - | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node - | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind - | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind - | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node - | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node - | TheoremNode theorem_node -> convert_theorem_node theorem_node + ) |> attach_props thm.node +(** The top-level method converting the entire SANY AST to TLAPM's AST. SANY + uses a lot of GUIDs for one entity to reference another, so we load those + into a global table for fast lookup. This table would have to be a + parameter to every conversion method in this file; for simplicity we make + it a module-level mutable variable instead. +*) let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = entries := List.fold_left @@ -386,6 +436,9 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string converted_modules := Coll.Im.add root_module_id root !converted_modules; Ok (Coll.Sm.empty, root) +(** Calls SANY to parse the given module, then converts SANY's AST into the + TLAPM AST format. +*) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in Option.to_result ~none:(None, "TLAPS standard library cannot be found") Params.stdlib_path From 92ca26b5117c1cdf4c26c4a1d52d105b6b041044 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 9 Jan 2026 12:51:53 -0800 Subject: [PATCH 22/85] Proof conversion started Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index e606ce05..087fbb6a 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -409,11 +409,23 @@ and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = | Expression expr -> { context = Deque.empty; active = convert_expression expr}), (* TODO handle assume/prove *) 0 (* TODO figure out what this integer parameter means *), - noprops Obvious, (* TODO convert proof *) + convert_proof thm.proof, noprops Obvious, (* TODO figure out why there are two proofs *) empty_summary (* TODO figure out purpose of summary *) ) |> attach_props thm.node +(** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series + of individual proof steps culminated in a QED step. +*) +and convert_proof (proof : Xml.proof_node_group) : Proof.T.proof = + match proof with + | Omitted {node} -> Omitted Explicit |> attach_props node + | Obvious {node} -> Obvious |> attach_props node + | By proof -> todo "Proof" "By" proof.node.location + | Steps proof -> convert_proof_steps proof + +and convert_proof_steps (proof : Xml.steps_proof_node) : Proof.T.proof = todo "Proof" "Steps" proof.node.location + (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those into a global table for fast lookup. This table would have to be a From 45ce2194fdd9eea07fd6bf5282b6c035a2b653ee Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 13 Jan 2026 15:41:19 -0800 Subject: [PATCH 23/85] Basic proof conversion complete Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 73 ++++++++++++++++++++++++++++++++++++++++++------ src/sany/xml.ml | 22 ++++++--------- 2 files changed, 74 insertions(+), 21 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 087fbb6a..73fd6f1a 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -58,6 +58,16 @@ let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = ) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref.uid) +let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = + match (resolve_ref uid).kind with + | TheoremDefNode xml -> xml + | _ -> failwith ("Expected theorem definition node for UID: " ^ string_of_int uid) + +let resolve_theorem_node (uid : int) : Xml.theorem_node = + match (resolve_ref uid).kind with + | TheoremNode xml -> xml + | _ -> failwith ("Expected theorem node for UID: " ^ string_of_int uid) + let resolve_bound_symbol (symbol : Xml.formal_param_node_ref) : hint = match Coll.Im.find_opt symbol.uid !entries with | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.uniquename @@ -70,6 +80,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.uniquename with | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE + | "UNCHANGED" -> Some Builtin.UNCHANGED | "'" -> Some Builtin.Prime | "[]" -> Some (Builtin.Box false) | "=" -> Some Builtin.Eq @@ -337,6 +348,8 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = | FormalParamNode param -> convert_formal_param_node_op_appl apply param (* A reference to a CONSTANT or VARIABLE identifier *) | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl + (* A reference to a named THEOREM or a proof step *) + | TheoremDefNode thm -> Opaque thm.uniquename |> attach_props thm.node | _ -> failwith ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind) ) (** Some places in TLA⁺ syntax allow both normal expressions and also @@ -399,14 +412,12 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. oddities in the form of additional metadata. *) and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = - let get_thm_name (thm : Xml.theorem_def_ref) : hint = - match (resolve_ref thm.uid).kind with - | TheoremDefNode def -> attach_props def.node def.uniquename - | _ -> failwith ("Unresolved theorem definition UID: " ^ string_of_int thm.uid) + let get_thm_name ({uid} : Xml.theorem_def_ref) : hint = + let def = resolve_theorem_def_node uid in + attach_props def.node def.uniquename in Theorem ( Option.map get_thm_name thm.definition, - (match thm.body with - | Expression expr -> { context = Deque.empty; active = convert_expression expr}), + convert_sequent thm.body, (* TODO handle assume/prove *) 0 (* TODO figure out what this integer parameter means *), convert_proof thm.proof, @@ -414,6 +425,13 @@ and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = empty_summary (* TODO figure out purpose of summary *) ) |> attach_props thm.node +(** Sequents are theorem bodies, which are either simple expressions or + ASSUME/PROVE constructs. +*) +and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = + match seq with + | Expression expr -> {context = Deque.empty; active = convert_expression expr} + (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. *) @@ -421,10 +439,49 @@ and convert_proof (proof : Xml.proof_node_group) : Proof.T.proof = match proof with | Omitted {node} -> Omitted Explicit |> attach_props node | Obvious {node} -> Obvious |> attach_props node - | By proof -> todo "Proof" "By" proof.node.location + | By proof -> convert_by_proof proof | Steps proof -> convert_proof_steps proof -and convert_proof_steps (proof : Xml.steps_proof_node) : Proof.T.proof = todo "Proof" "Steps" proof.node.location +(** One possible proof form is a series of steps, culminating in a QED step. + This method converts that structure. +*) +and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = ( + let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = + match List.rev steps with + | [] -> failwith "Step-based proofs must have at least one step" + | last :: rest -> (List.rev rest, last) + in let convert_proof_step (step : Xml.proof_step_group) : Proof.T.step = + match step with + (* TODO: handle other proof step types *) + | TheoremNodeRef {uid} -> + let thm = resolve_theorem_node uid in + Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node + in let convert_qed_step (step : Xml.proof_step_group) : Proof.T.qed_step = + match step with + (* TODO: handle other proof step types *) + | TheoremNodeRef {uid} -> + let thm = resolve_theorem_node uid in + Qed (convert_proof thm.proof) |> attach_props thm.node + in let steps, qed = split_steps steps + in Steps (List.map convert_proof_step steps, convert_qed_step qed) +) |> attach_props node + +(** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place + where information is lost, as the facts and definitions are converted to + strings that will need to be resolved later on. +*) +and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = + let resolve_def (ref : int) : use_def wrapped = + match (resolve_ref ref).kind with + | UserDefinedOpKind op -> Dvar op.uniquename |> attach_props op.node + | TheoremDefNode thm -> Dvar thm.uniquename |> attach_props thm.node + | other -> failwith ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) + in By ({ + facts = List.map convert_expression facts; + defs = List.map resolve_def defs; + }, + true (* TODO: figure out meaning of this parameter *) +) |> attach_props node (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 61130304..3bc1a1e7 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -457,21 +457,10 @@ let xml_to_obvious_proof_node xml = } | _ -> conversion_failure __FUNCTION__ xml -type definition_reference = - | UserDefinedOpKindRef of user_defined_op_kind_ref - | TheoremDefRef of theorem_def_ref -[@@deriving show] - -let xml_to_definition_reference xml = - match xml with - | Node (((_, "UserDefinedOpKindRef"), _), _) -> UserDefinedOpKindRef (xml_to_user_defined_op_kind_ref xml) - | Node (((_, "TheoremDefRef"), _), _) -> TheoremDefRef (xml_to_theorem_def_ref xml) - | _ -> conversion_failure __FUNCTION__ xml - type by_proof_node = { node : node; facts : expression list; - defs : definition_reference list; + defs : int list; } [@@deriving show] @@ -480,12 +469,19 @@ let xml_to_by_proof_node xml = | Node (((_, "by"), _), children) -> { node = children |> xml_to_inline_node; facts = children |> List.find_opt (is_tag "facts") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_expression; - defs = children |> List.find_opt (is_tag "defs") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_definition_reference; + defs = children |> List.find_opt (is_tag "defs") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_ref_to_int; } | _ -> conversion_failure __FUNCTION__ xml type proof_step_group = | TheoremNodeRef of theorem_node_ref + (* + | DefStepNode + | UseOrHideNode + | InstanceNode + | TheoremNodeRef + | TheoremNode + *) [@@deriving show] let xml_to_inline_list_proof_step_group children = From 3728b62c8337d11dfbdf2bbb6da404f30d40ce5b Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 14 Jan 2026 15:56:13 -0800 Subject: [PATCH 24/85] Simplified XML representation Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 2 +- src/sany/xml.ml | 156 ++++++++++++++++++++++++++++------------------- 2 files changed, 94 insertions(+), 64 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 73fd6f1a..5c3fd7a4 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -418,7 +418,6 @@ and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = in Theorem ( Option.map get_thm_name thm.definition, convert_sequent thm.body, - (* TODO handle assume/prove *) 0 (* TODO figure out what this integer parameter means *), convert_proof thm.proof, noprops Obvious, (* TODO figure out why there are two proofs *) @@ -427,6 +426,7 @@ and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = (** Sequents are theorem bodies, which are either simple expressions or ASSUME/PROVE constructs. + TODO: handle ASSUME/PROVE *) and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 3bc1a1e7..f17a4124 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -16,15 +16,21 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (stri open Xmlm;; +(** This simple XML representation only consists of nodes and values, where + node is a tag with a list of children. For example, the XML snippet + "value" would be Node ("SomeName", [Value "value"]). + XML can also have attributes on tags, like , but + these are not used in SANY's XML format. +*) type tree = - | Node of Xmlm.tag * tree list + | Node of string * tree list | Value of string [@@deriving show] let str_to_xml (xml_str: string) : tree = let xml = Xmlm.make_input (`String (0, xml_str)) in - let el tag childs = Node (tag, childs) in - let data d = Value d in + let el (((_, name), _) : tag) (children : tree list) = Node (name, children) in + let data (d : string) = Value d in Xmlm.input_doc_tree ~el ~data xml |> snd let conversion_failure fn_name xml = @@ -33,7 +39,7 @@ let conversion_failure fn_name xml = let is_tag (tag_name : string) (node : tree) = match node with - | Node (((_, name), _), _) -> String.equal name tag_name + | Node (name, _) -> String.equal name tag_name | _ -> false let children_of (xml : tree) = @@ -68,9 +74,29 @@ let xml_child_to_int xml = let xml_to_tagged_int (tag_name : string) (children : tree list) : int = find_tag tag_name children |> xml_child_to_int -let xml_ref_to_int (xml : tree) : int = +(** Use this in conjunction with List.filter_map on children of a node to get + all references of various types. +*) +let get_ref_opt (xml : tree) : int option = match xml with - | Node (((_, _), _), children) -> xml_to_tagged_int "UID" children + | Node ("AssumeDefRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("BuiltInKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("ModuleInstanceKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("ModuleNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("OpDeclNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("TheoremDefRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("UserDefinedOpKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | _ -> None + +(** Use this either on a single node that must have a UID child, or in + conjunction with List.map on children of a node that all must have UID + children. +*) +let get_ref (xml : tree) : int = + match get_ref_opt xml with + | Some uid -> uid | _ -> conversion_failure __FUNCTION__ xml type range = { @@ -81,7 +107,7 @@ type range = { let xml_to_range xml = match xml with - | Node (((_, _), _), children) -> { + | Node (_, children) -> { start = children |> xml_to_tagged_int "begin"; finish = children |> xml_to_tagged_int "end"; } @@ -96,10 +122,14 @@ type location = { let xml_to_location xml = match xml with - | Node (((_, "location"), _), children) -> { - column = children |> find_tag "column" |> xml_to_range; - line = children |> find_tag "line" |> xml_to_range; - filename = children |> xml_to_tagged_string "filename"; + | Node ("location", [ + Node ("column", [Node ("begin", [Value column_begin]); Node ("end", [Value column_end])]); + Node ("line", [Node ("begin", [Value line_begin]); Node ("end", [Value line_end])]); + Node ("filename", [Value filename]) + ]) -> { + column = {start = int_of_string column_begin; finish = int_of_string column_end}; + line = {start = int_of_string line_begin; finish = int_of_string line_end}; + filename; } | _ -> conversion_failure __FUNCTION__ xml @@ -137,7 +167,7 @@ type numeral_node = { let xml_to_numeral_node (xml : tree) = match xml with - | Node (((_, "NumeralNode"), _), children) -> { + | Node ("NumeralNode", children) -> { node = children |> xml_to_inline_node; value = children |> xml_to_tagged_int "IntValue" } @@ -150,7 +180,7 @@ type formal_param_node_ref = { let xml_to_formal_param_node_ref xml = match xml with - | Node (((_, "FormalParamNodeRef"), _), children) -> { + | Node ("FormalParamNodeRef", children) -> { uid = children |> xml_to_tagged_int "UID"; } | _ -> conversion_failure __FUNCTION__ xml @@ -164,7 +194,7 @@ type formal_param_node = { let xml_to_formal_param_node xml = match xml with - | Node (((_, "FormalParamNode"), _), children) -> { + | Node ("FormalParamNode", children) -> { node = xml_to_inline_node children; uniquename = xml_to_tagged_string "uniquename" children; arity = xml_to_tagged_int "arity" children; @@ -179,7 +209,7 @@ type unbound_symbol = { let xml_to_unbound_symbol xml = match xml with - | Node (((_, "unbound"), _), children) -> { + | Node ("unbound", children) -> { formal_param_node_ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; is_tuple = children |> List.exists (is_tag "tuple") } @@ -222,13 +252,13 @@ and symbol = let rec xml_to_symbols xml = match xml with - | Node (((_, "unbound"), _), _) -> Unbound (xml_to_unbound_symbol xml) - | Node (((_, "bound"), _), _) -> Bound (xml_to_bound_symbol xml) + | Node ("unbound", _) -> Unbound (xml_to_unbound_symbol xml) + | Node ("bound", _) -> Bound (xml_to_bound_symbol xml) | _ -> conversion_failure __FUNCTION__ xml and xml_to_bound_symbol xml = match xml with - | Node (((_, "bound"), _), children) -> { + | Node ("bound", children) -> { formal_param_node_refs = children |> List.filter (is_tag "FormalParamNodeRef") |> List.map xml_to_formal_param_node_ref; is_tuple = children |> List.exists (is_tag "tuple"); expression = children |> xml_to_inline_expression |> Option.get; @@ -241,9 +271,9 @@ with Invalid_argument _ -> conversion_failure __FUNCTION__ xml and xml_to_op_appl_node xml = match xml with - | Node (((_, "OpApplNode"), _), children) -> { + | Node ("OpApplNode", children) -> { node = children |> xml_to_inline_node; - operator = children |> find_tag "operator" |> child_of |> xml_ref_to_int; + operator = children |> find_tag "operator" |> child_of |> get_ref; operands = children |> find_tag "operands" |> children_of |> List.map xml_to_expr_or_op_arg; bound_symbols = children |> List.find_opt (is_tag "boundSymbols") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; } @@ -251,8 +281,8 @@ and xml_to_op_appl_node xml = and xml_to_expression xml = match xml with - | Node (((_, "NumeralNode"), _), _) -> NumeralNode (xml_to_numeral_node xml) - | Node (((_, "OpApplNode"), _), _) -> OpApplNode (xml_to_op_appl_node xml) + | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) + | Node ("OpApplNode", _) -> OpApplNode (xml_to_op_appl_node xml) | _ -> conversion_failure __FUNCTION__ xml and xml_to_inline_expression children = @@ -270,19 +300,19 @@ type module_node = { let xml_to_module_node xml = let ref_child child = match child with - | Node (((_, "OpDeclNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "ModuleInstanceKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "UserDefinedOpKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "BuiltInKindRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "TheoremDefRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "AssumeDefRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "AssumeNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "TheoremNodeRef"), _), children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node (((_, "InstanceNode"), _), children) -> Some (`OtherTODO "InstanceNode") - | Node (((_, "UseOrHideNode"), _), children) -> Some (`OtherTODO "UseOrHideNode") + | Node ("OpDeclNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("ModuleInstanceKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("UserDefinedOpKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("BuiltInKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("TheoremDefRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("AssumeDefRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("AssumeNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("TheoremNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("InstanceNode", children) -> Some (`OtherTODO "InstanceNode") + | Node ("UseOrHideNode", children) -> Some (`OtherTODO "UseOrHideNode") | _ -> None in match xml with - | Node (((_, "ModuleNode"), _), children) -> { + | Node ("ModuleNode", children) -> { uniquename = children |> xml_to_tagged_string "uniquename"; location = children |> find_tag "location" |> xml_to_location; units = List.filter_map ref_child children @@ -308,7 +338,7 @@ type op_decl_node = { let xml_to_op_decl_node (xml : tree) : op_decl_node = match xml with - | Node (((_, "OpDeclNode"), _), children) -> ({ + | Node ("OpDeclNode", children) -> ({ uniquename = children |> xml_to_tagged_string "uniquename"; node = children |> xml_to_inline_node; arity = children |> xml_to_tagged_int "arity"; @@ -324,7 +354,7 @@ type leibniz_param = { let xml_to_leibniz_param xml = match xml with - | Node (((_, "leibnizparam"), _), children) -> { + | Node ("leibnizparam", children) -> { ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; is_leibniz = children |> List.exists (is_tag "leibniz"); } @@ -342,7 +372,7 @@ type user_defined_op_kind = { let xml_to_user_defined_op_kind xml : user_defined_op_kind = match xml with - | Node (((_, "UserDefinedOpKind"), _), children) -> { + | Node ("UserDefinedOpKind", children) -> { node = children |> xml_to_inline_node; uniquename = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; @@ -359,7 +389,7 @@ type user_defined_op_kind_ref = { let xml_to_user_defined_op_kind_ref xml = match xml with - | Node (((_, "UserDefinedOpKindRef"), _), children) -> { + | Node ("UserDefinedOpKindRef", children) -> { uid = children |> xml_to_tagged_int "UID"; } | _ -> conversion_failure __FUNCTION__ xml @@ -374,7 +404,7 @@ type built_in_kind = { let xml_to_built_in_kind xml : built_in_kind = match xml with - | Node (((_, "BuiltInKind"), _), children) -> { + | Node ("BuiltInKind", children) -> { node = children |> xml_to_inline_node; uniquename = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; @@ -401,7 +431,7 @@ type theorem_def_node = { let xml_to_theorem_def_node xml = match xml with - | Node (((_, "TheoremDefNode"), _), children) -> { + | Node ("TheoremDefNode", children) -> { node = children |> xml_to_inline_node; uniquename = children |> xml_to_tagged_string "uniquename"; body = children |> xml_to_inline_expr_or_assume_prove |> Option.get ; @@ -415,7 +445,7 @@ type theorem_def_ref = { let xml_to_theorem_def_ref xml = match xml with - | Node (((_, "TheoremDefRef"), _), children) -> { + | Node ("TheoremDefRef", children) -> { uid = xml_to_tagged_int "UID" children } | _ -> conversion_failure __FUNCTION__ xml @@ -427,7 +457,7 @@ type theorem_node_ref = { let xml_to_theorem_node_ref xml = match xml with - | Node (((_, "TheoremNodeRef"), _), children) -> { + | Node ("TheoremNodeRef", children) -> { uid = xml_to_tagged_int "UID" children } | _ -> conversion_failure __FUNCTION__ xml @@ -440,7 +470,7 @@ type omitted_proof_node = { let xml_to_omitted_proof_node xml = match xml with - | Node (((_, "omitted"), _), children) -> { + | Node ("omitted", children) -> { node = children |> xml_to_inline_node; } | _ -> conversion_failure __FUNCTION__ xml @@ -452,7 +482,7 @@ type obvious_proof_node = { let xml_to_obvious_proof_node xml = match xml with - | Node (((_, "obvious"), _), children) -> { + | Node ("obvious", children) -> { node = children |> xml_to_inline_node; } | _ -> conversion_failure __FUNCTION__ xml @@ -466,10 +496,10 @@ type by_proof_node = { let xml_to_by_proof_node xml = match xml with - | Node (((_, "by"), _), children) -> { + | Node ("by", children) -> { node = children |> xml_to_inline_node; - facts = children |> List.find_opt (is_tag "facts") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_expression; - defs = children |> List.find_opt (is_tag "defs") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_ref_to_int; + facts = children |> find_tag "facts" |> children_of |> List.map xml_to_expression; + defs = children |> find_tag "defs" |> children_of |> List.filter_map get_ref_opt } | _ -> conversion_failure __FUNCTION__ xml @@ -498,7 +528,7 @@ type steps_proof_node = { let xml_to_steps_proof_node xml = match xml with - | Node (((_, "steps"), _), children) -> { + | Node ("steps", children) -> { node = children |> xml_to_inline_node; steps = children |> xml_to_inline_list_proof_step_group; } @@ -516,10 +546,10 @@ let xml_to_inline_proof_node_group children = match ls with | x::xs -> ( match x with - | Node (((_, "omitted"), _), _) -> Omitted (xml_to_omitted_proof_node x) - | Node (((_, "obvious"), _), _) -> Obvious (xml_to_obvious_proof_node x) - | Node (((_, "by"), _), _) -> By (xml_to_by_proof_node x) - | Node (((_, "steps"), _), _) -> Steps (xml_to_steps_proof_node x) + | Node ("omitted", _) -> Omitted (xml_to_omitted_proof_node x) + | Node ("obvious", _) -> Obvious (xml_to_obvious_proof_node x) + | Node ("by", _) -> By (xml_to_by_proof_node x) + | Node ("steps", _) -> Steps (xml_to_steps_proof_node x) | _ -> search_children xs ) | _ -> conversion_failure __FUNCTION__ (List.hd children) @@ -535,7 +565,7 @@ type theorem_node = { let xml_to_theorem_node xml = match xml with - | Node (((_, "TheoremNode"), _), children) -> { + | Node ("TheoremNode", children) -> { node = children |> xml_to_inline_node; definition = children |> List.find_opt (is_tag "definition") |> Option.map child_of |> Option.map xml_to_theorem_def_ref; body = children |> find_tag "body" |> children_of |> xml_to_inline_expr_or_assume_prove |> Option.get; @@ -558,13 +588,13 @@ let xml_to_entry_kind (children : tree list) = match candidates with | x :: xs -> ( match x with - | Node (((_, "ModuleNode"), _), _) -> ModuleNode (xml_to_module_node x) - | Node (((_, "OpDeclNode"), _), _) -> OpDeclNode (xml_to_op_decl_node x) - | Node (((_, "UserDefinedOpKind"), _), _) -> UserDefinedOpKind (xml_to_user_defined_op_kind x) - | Node (((_, "BuiltInKind"), _), _) -> BuiltInKind (xml_to_built_in_kind x) - | Node (((_, "FormalParamNode"), _), _) -> FormalParamNode (xml_to_formal_param_node x) - | Node (((_, "TheoremDefNode"), _), _) -> TheoremDefNode (xml_to_theorem_def_node x) - | Node (((_, "TheoremNode"), _), _) -> TheoremNode (xml_to_theorem_node x) + | Node ("ModuleNode", _) -> ModuleNode (xml_to_module_node x) + | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node x) + | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind x) + | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind x) + | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node x) + | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node x) + | Node ("TheoremNode", _) -> TheoremNode (xml_to_theorem_node x) | _ -> find_variant xs ) | [] -> Invalid_argument (Printf.sprintf "Unable to find entry_kind variant in children %s" (show_tree_list children)) |> raise @@ -578,7 +608,7 @@ type entry = { let xml_to_entry xml = match xml with - | Node (((_, "entry"), _), children) -> { + | Node ("entry", children) -> { uid = children |> xml_to_tagged_int "UID"; kind = xml_to_entry_kind children; } @@ -594,14 +624,14 @@ type modules = { let xml_to_modules xml = let xml_to_context xml = match xml with - | Node (((_, "context"), _), children) -> + | Node ("context", children) -> children |> List.find_all (is_tag "entry") |> List.map xml_to_entry; | _ -> conversion_failure __FUNCTION__ xml in match xml with - | Node (((_, "modules"), _), children) -> { + | Node ("modules", children) -> { root_module = xml_to_tagged_string "RootModule" children; context = children |> find_tag "context" |> xml_to_context; - module_node_ref = children |> List.filter (is_tag "ModuleNodeRef") |> List.map xml_ref_to_int; + module_node_ref = children |> List.filter_map get_ref_opt } | _ -> conversion_failure __FUNCTION__ xml From b6611a56333c0da44156d8cb3d0a2b6062a402a2 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 15 Jan 2026 11:48:06 -0800 Subject: [PATCH 25/85] Improved XML parsing Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 55 ++++++----- src/sany/xml.ml | 232 ++++++++++++++++------------------------------- 2 files changed, 106 insertions(+), 181 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 5c3fd7a4..90245c1d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -19,18 +19,18 @@ let converted_units : Module.T.modunit Coll.Im.t ref = ref Coll.Im.empty (** Converts SANY's location format to TLAPM's, for attachment to node metadata. *) -let convert_location (location : Xml.location) : Loc.locus = { +let convert_location ({column = (col_start, col_finish); line = (line_start, line_finish); filename} : Xml.location) : Loc.locus = { start = Actual { - line = location.line.start; + line = line_start; bol = 0; - col = location.column.start; + col = col_start; }; stop = Actual { - line = location.line.finish; + line = line_finish; bol = 0; - col = location.column.finish; + col = col_finish; }; - file = location.filename; + file = filename; } let locate (value : 'a) (location : Xml.location) : 'a wrapped = @@ -49,14 +49,14 @@ let resolve_ref (uid : int) : Xml.entry = | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = - match Coll.Im.find_opt param.ref.uid !entries with + match Coll.Im.find_opt param.ref !entries with | Some (Xml.FormalParamNode xml) -> ( attach_props xml.node xml.uniquename, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n ) - | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref.uid) + | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref) let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = match (resolve_ref uid).kind with @@ -68,11 +68,11 @@ let resolve_theorem_node (uid : int) : Xml.theorem_node = | TheoremNode xml -> xml | _ -> failwith ("Expected theorem node for UID: " ^ string_of_int uid) -let resolve_bound_symbol (symbol : Xml.formal_param_node_ref) : hint = - match Coll.Im.find_opt symbol.uid !entries with +let resolve_bound_symbol (uid : int) : hint = + match Coll.Im.find_opt uid !entries with | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.uniquename - | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int symbol.uid) - | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int symbol.uid) + | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) + | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) (** Converts built-in prefix, infix, and postfix operators along with keywords. *) @@ -157,7 +157,7 @@ and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with (* Case 1: Bounded non-tuple CHOOSE expression *) - | [Bound {is_tuple = false; formal_param_node_refs = [param]; expression}], [body] -> + | [Bound {is_tuple = false; symbol_refs = [param]; expression}], [body] -> Choose ( resolve_bound_symbol param, Some (convert_expression expression), @@ -166,14 +166,14 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( (* Case 2: Bounded tuple CHOOSE expression *) | [Bound ({is_tuple = true} as symbol)], [body] -> ChooseTuply ( - List.map resolve_bound_symbol symbol.formal_param_node_refs, + List.map resolve_bound_symbol symbol.symbol_refs, Some (convert_expression symbol.expression), convert_expression_or_operator_argument body ) (* Case 3: Unbounded non-tuple CHOOSE expression *) | [Unbound ({is_tuple = false} as symbol)], [body] -> Choose ( - resolve_bound_symbol symbol.formal_param_node_ref, + resolve_bound_symbol symbol.symbol_ref, None, convert_expression_or_operator_argument body ) @@ -183,7 +183,7 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( if List.length symbols <> List.length apply.bound_symbols then failwith "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" else ChooseTuply ( - List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.formal_param_node_ref) symbols, + List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.symbol_ref) symbols, None, convert_expression_or_operator_argument body ) @@ -228,7 +228,7 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node then failwith "Unbounded tuple quantification is not supported" (* Unbounded quantification *) else let mk_bound (bound : Xml.unbound_symbol) : bound = ( - resolve_bound_symbol bound.formal_param_node_ref, + resolve_bound_symbol bound.symbol_ref, Unknown, (* TODO: figure out purpose of this parameter *) No_domain ) in Quant ( @@ -240,10 +240,10 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node (* Bounded quantification that includes at least one tuple *) then let mk_bounds (bound : Xml.bound_symbol) : tuply_bounds = if bound.is_tuple - then match List.map resolve_bound_symbol bound.formal_param_node_refs with + then match List.map resolve_bound_symbol bound.symbol_refs with | (_ :: _ as symbols) -> [(Bound_names symbols, Domain (convert_expression bound.expression))] | [] -> failwith "Tuple bound symbol groups must have at least one symbol" - else match List.map resolve_bound_symbol bound.formal_param_node_refs with + else match List.map resolve_bound_symbol bound.symbol_refs with | hd :: tl -> (Bound_name hd, Domain (convert_expression bound.expression)) :: List.map (fun s -> (Bound_name s, Ditto)) tl | [] -> failwith "Bound symbol groups must have at least one symbol" @@ -254,7 +254,7 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node ) (* Bounded quantification without any tuples *) else let mk_bounds (bound : Xml.bound_symbol) : bounds = - match List.map resolve_bound_symbol bound.formal_param_node_refs with + match List.map resolve_bound_symbol bound.symbol_refs with | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) :: List.map (fun s -> (s, Unknown, Ditto)) tl | [] -> failwith "Bound symbol groups must have at least one symbol" @@ -412,11 +412,8 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. oddities in the form of additional metadata. *) and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = - let get_thm_name ({uid} : Xml.theorem_def_ref) : hint = - let def = resolve_theorem_def_node uid in - attach_props def.node def.uniquename - in Theorem ( - Option.map get_thm_name thm.definition, + Theorem ( + Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.uniquename) thm.definition, convert_sequent thm.body, 0 (* TODO figure out what this integer parameter means *), convert_proof thm.proof, @@ -437,8 +434,8 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = *) and convert_proof (proof : Xml.proof_node_group) : Proof.T.proof = match proof with - | Omitted {node} -> Omitted Explicit |> attach_props node - | Obvious {node} -> Obvious |> attach_props node + | Omitted node -> Omitted Explicit |> attach_props node + | Obvious node -> Obvious |> attach_props node | By proof -> convert_by_proof proof | Steps proof -> convert_proof_steps proof @@ -453,13 +450,13 @@ and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = in let convert_proof_step (step : Xml.proof_step_group) : Proof.T.step = match step with (* TODO: handle other proof step types *) - | TheoremNodeRef {uid} -> + | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node in let convert_qed_step (step : Xml.proof_step_group) : Proof.T.qed_step = match step with (* TODO: handle other proof step types *) - | TheoremNodeRef {uid} -> + | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in Qed (convert_proof thm.proof) |> attach_props thm.node in let steps, qed = split_steps steps diff --git a/src/sany/xml.ml b/src/sany/xml.ml index f17a4124..3598a3e2 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -33,40 +33,40 @@ let str_to_xml (xml_str: string) : tree = let data (d : string) = Value d in Xmlm.input_doc_tree ~el ~data xml |> snd -let conversion_failure fn_name xml = +let conversion_failure (fn_name : string) (xml : tree) : 'a = let err_msg = Printf.sprintf "%s conversion failure on %s" fn_name (show_tree xml) in Invalid_argument err_msg |> raise -let is_tag (tag_name : string) (node : tree) = +let is_tag (tag_name : string) (node : tree) : bool = match node with | Node (name, _) -> String.equal name tag_name | _ -> false -let children_of (xml : tree) = +let children_of (xml : tree) : tree list = match xml with | Node (_, children) -> children | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise -let child_of (xml : tree) = +let child_of (xml : tree) : tree = match xml with | Node (_, [child]) -> child | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise -let show_tree_list (xs : tree list) = +let show_tree_list (xs : tree list) : string = Printf.sprintf "[%s]" (xs |> List.map show_tree |> String.concat "; ") -let find_tag (tag_name : string) (children : tree list) = +let find_tag (tag_name : string) (children : tree list) : tree = match List.find_opt (is_tag tag_name) children with | Some v -> v | None -> Invalid_argument (Printf.sprintf "Unable to find tag %s in children %s" tag_name (show_tree_list children)) |> raise -let xml_to_tagged_string (tag_name : string) (children : tree list) = +let xml_to_tagged_string (tag_name : string) (children : tree list) : string = match find_tag tag_name children with | (Node (_, [Value d])) -> d | xml -> conversion_failure __FUNCTION__ xml -let xml_child_to_int xml = +let xml_child_to_int (xml : tree) : int = match xml with | (Node (_, [Value d])) -> int_of_string d | _ -> conversion_failure __FUNCTION__ xml @@ -99,36 +99,22 @@ let get_ref (xml : tree) : int = | Some uid -> uid | _ -> conversion_failure __FUNCTION__ xml -type range = { - start : int; - finish : int; -} -[@@deriving show] - -let xml_to_range xml = - match xml with - | Node (_, children) -> { - start = children |> xml_to_tagged_int "begin"; - finish = children |> xml_to_tagged_int "end"; - } - | _ -> conversion_failure __FUNCTION__ xml - type location = { - column : range; - line : range; + column : int * int; + line : int * int; filename : string; } [@@deriving show] -let xml_to_location xml = +let xml_to_location (xml : tree) : location = match xml with | Node ("location", [ Node ("column", [Node ("begin", [Value column_begin]); Node ("end", [Value column_end])]); Node ("line", [Node ("begin", [Value line_begin]); Node ("end", [Value line_end])]); Node ("filename", [Value filename]) ]) -> { - column = {start = int_of_string column_begin; finish = int_of_string column_end}; - line = {start = int_of_string line_begin; finish = int_of_string line_end}; + column = (int_of_string column_begin, int_of_string column_end); + line = (int_of_string line_begin, int_of_string line_end); filename; } | _ -> conversion_failure __FUNCTION__ xml @@ -154,10 +140,17 @@ type node = { } [@@deriving show] -let xml_to_inline_node (children : tree list) = { - location = children |> List.find_opt (is_tag "location") |> Option.map xml_to_location; - level = children |> List.find_opt (is_tag "level") |> Option.map xml_child_to_int |> Option.map int_to_level; -} +(** Many XML nodes have children that start with some optional "location" and + "level" tags, followed by other tags specific to that node. This function + extracts the location and level information from such a list of children, + then returns the remaining children for further processing. +*) +let extract_inline_node (children : tree list) : (node * tree list) = + match children with + | Node ("location", _) as loc :: Node ("level", [Value lvl]) :: rest -> {location = Some (xml_to_location loc); level = Some (lvl |> int_of_string |> int_to_level)}, rest + | Node ("location", _) as loc :: rest -> {location = Some (xml_to_location loc); level = None}, rest + | Node ("level", [Value lvl]) :: rest -> {location = None; level = Some (lvl |> int_of_string |> int_to_level)}, rest + | rest -> {location = None; level = None}, rest type numeral_node = { node : node; @@ -167,24 +160,13 @@ type numeral_node = { let xml_to_numeral_node (xml : tree) = match xml with - | Node ("NumeralNode", children) -> { - node = children |> xml_to_inline_node; + | Node ("NumeralNode", children) -> + let (node, children) = extract_inline_node children in { + node; value = children |> xml_to_tagged_int "IntValue" } | _ -> conversion_failure __FUNCTION__ xml -type formal_param_node_ref = { - uid : int -} -[@@deriving show] - -let xml_to_formal_param_node_ref xml = - match xml with - | Node ("FormalParamNodeRef", children) -> { - uid = children |> xml_to_tagged_int "UID"; - } - | _ -> conversion_failure __FUNCTION__ xml - type formal_param_node = { node : node; uniquename : string; @@ -194,24 +176,25 @@ type formal_param_node = { let xml_to_formal_param_node xml = match xml with - | Node ("FormalParamNode", children) -> { - node = xml_to_inline_node children; + | Node ("FormalParamNode", children) -> + let (node, children) = extract_inline_node children in { + node; uniquename = xml_to_tagged_string "uniquename" children; arity = xml_to_tagged_int "arity" children; } | _ -> conversion_failure __FUNCTION__ xml type unbound_symbol = { - formal_param_node_ref : formal_param_node_ref; + symbol_ref : int; is_tuple : bool; } [@@deriving show] let xml_to_unbound_symbol xml = match xml with - | Node ("unbound", children) -> { - formal_param_node_ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; - is_tuple = children |> List.exists (is_tag "tuple") + | Node ("unbound", Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) :: tuple_tag_opt) -> { + symbol_ref = int_of_string uid; + is_tuple = match tuple_tag_opt with | [Node ("tuple", [])] -> true | _ -> false; } | _ -> conversion_failure __FUNCTION__ xml @@ -240,7 +223,7 @@ and expr_or_op_arg = (*| OpArg of operator_arg*) and bound_symbol = { - formal_param_node_refs : formal_param_node_ref list; + symbol_refs : int list; is_tuple : bool; expression : expression } @@ -259,7 +242,7 @@ let rec xml_to_symbols xml = and xml_to_bound_symbol xml = match xml with | Node ("bound", children) -> { - formal_param_node_refs = children |> List.filter (is_tag "FormalParamNodeRef") |> List.map xml_to_formal_param_node_ref; + symbol_refs = children |> List.filter_map get_ref_opt; is_tuple = children |> List.exists (is_tag "tuple"); expression = children |> xml_to_inline_expression |> Option.get; } @@ -271,8 +254,9 @@ with Invalid_argument _ -> conversion_failure __FUNCTION__ xml and xml_to_op_appl_node xml = match xml with - | Node ("OpApplNode", children) -> { - node = children |> xml_to_inline_node; + | Node ("OpApplNode", children) -> + let (node, children) = extract_inline_node children in { + node; operator = children |> find_tag "operator" |> child_of |> get_ref; operands = children |> find_tag "operands" |> children_of |> List.map xml_to_expr_or_op_arg; bound_symbols = children |> List.find_opt (is_tag "boundSymbols") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; @@ -329,8 +313,8 @@ let int_to_declaration_kind (n : int) : declaration_kind = | _ -> Invalid_argument (Printf.sprintf "Invalid declaration kind value: %d" n) |> raise type op_decl_node = { - uniquename : string; node : node; + uniquename : string; arity : int; kind : declaration_kind; } @@ -338,25 +322,26 @@ type op_decl_node = { let xml_to_op_decl_node (xml : tree) : op_decl_node = match xml with - | Node ("OpDeclNode", children) -> ({ + | Node ("OpDeclNode", children) -> + let (node, children) = extract_inline_node children in { + node; uniquename = children |> xml_to_tagged_string "uniquename"; - node = children |> xml_to_inline_node; arity = children |> xml_to_tagged_int "arity"; kind = children |> xml_to_tagged_int "kind" |> int_to_declaration_kind; - } : op_decl_node) + } | _ -> conversion_failure __FUNCTION__ xml type leibniz_param = { - ref : formal_param_node_ref; + ref : int; is_leibniz : bool; } [@@deriving show] let xml_to_leibniz_param xml = match xml with - | Node ("leibnizparam", children) -> { - ref = children |> find_tag "FormalParamNodeRef" |> xml_to_formal_param_node_ref; - is_leibniz = children |> List.exists (is_tag "leibniz"); + | Node ("leibnizparam", Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) :: is_leibniz_opt) -> { + ref = int_of_string uid; + is_leibniz = match is_leibniz_opt with | [Node ("leibniz", [])] -> true | _ -> false; } | _ -> conversion_failure __FUNCTION__ xml @@ -372,8 +357,9 @@ type user_defined_op_kind = { let xml_to_user_defined_op_kind xml : user_defined_op_kind = match xml with - | Node ("UserDefinedOpKind", children) -> { - node = children |> xml_to_inline_node; + | Node ("UserDefinedOpKind", children) -> + let (node, children) = extract_inline_node children in { + node; uniquename = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; body = children |> find_tag "body" |> child_of |> xml_to_expression; @@ -382,18 +368,6 @@ let xml_to_user_defined_op_kind xml : user_defined_op_kind = } | _ -> conversion_failure __FUNCTION__ xml -type user_defined_op_kind_ref = { - uid : int -} -[@@deriving show] - -let xml_to_user_defined_op_kind_ref xml = - match xml with - | Node ("UserDefinedOpKindRef", children) -> { - uid = children |> xml_to_tagged_int "UID"; - } - | _ -> conversion_failure __FUNCTION__ xml - type built_in_kind = { node : node; uniquename : string; @@ -404,8 +378,9 @@ type built_in_kind = { let xml_to_built_in_kind xml : built_in_kind = match xml with - | Node ("BuiltInKind", children) -> { - node = children |> xml_to_inline_node; + | Node ("BuiltInKind", children) -> + let (node, children) = extract_inline_node children in { + node; uniquename = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; @@ -431,62 +406,14 @@ type theorem_def_node = { let xml_to_theorem_def_node xml = match xml with - | Node ("TheoremDefNode", children) -> { - node = children |> xml_to_inline_node; + | Node ("TheoremDefNode", children) -> + let (node, children) = extract_inline_node children in { + node; uniquename = children |> xml_to_tagged_string "uniquename"; body = children |> xml_to_inline_expr_or_assume_prove |> Option.get ; } | _ -> conversion_failure __FUNCTION__ xml -type theorem_def_ref = { - uid : int -} -[@@deriving show] - -let xml_to_theorem_def_ref xml = - match xml with - | Node ("TheoremDefRef", children) -> { - uid = xml_to_tagged_int "UID" children - } - | _ -> conversion_failure __FUNCTION__ xml - -type theorem_node_ref = { - uid : int -} -[@@deriving show] - -let xml_to_theorem_node_ref xml = - match xml with - | Node ("TheoremNodeRef", children) -> { - uid = xml_to_tagged_int "UID" children - } - | _ -> conversion_failure __FUNCTION__ xml - - -type omitted_proof_node = { - node : node -} -[@@deriving show] - -let xml_to_omitted_proof_node xml = - match xml with - | Node ("omitted", children) -> { - node = children |> xml_to_inline_node; - } - | _ -> conversion_failure __FUNCTION__ xml - -type obvious_proof_node = { - node : node -} -[@@deriving show] - -let xml_to_obvious_proof_node xml = - match xml with - | Node ("obvious", children) -> { - node = children |> xml_to_inline_node; - } - | _ -> conversion_failure __FUNCTION__ xml - type by_proof_node = { node : node; facts : expression list; @@ -496,29 +423,28 @@ type by_proof_node = { let xml_to_by_proof_node xml = match xml with - | Node ("by", children) -> { - node = children |> xml_to_inline_node; + | Node ("by", children) -> + let (node, children) = extract_inline_node children in { + node; facts = children |> find_tag "facts" |> children_of |> List.map xml_to_expression; defs = children |> find_tag "defs" |> children_of |> List.filter_map get_ref_opt } | _ -> conversion_failure __FUNCTION__ xml type proof_step_group = - | TheoremNodeRef of theorem_node_ref - (* + | TheoremNodeRef of int + (* TODO | DefStepNode | UseOrHideNode | InstanceNode - | TheoremNodeRef | TheoremNode *) [@@deriving show] -let xml_to_inline_list_proof_step_group children = - children - |> List.filter (is_tag "TheoremNodeRef") - |> List.map xml_to_theorem_node_ref - |> List.map (fun node -> TheoremNodeRef node) +let xml_to_proof_step_group xml = + match xml with + | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> TheoremNodeRef (int_of_string uid) + | _ -> conversion_failure __FUNCTION__ xml type steps_proof_node = { node : node; @@ -528,15 +454,16 @@ type steps_proof_node = { let xml_to_steps_proof_node xml = match xml with - | Node ("steps", children) -> { - node = children |> xml_to_inline_node; - steps = children |> xml_to_inline_list_proof_step_group; + | Node ("steps", children) -> + let (node, steps) = extract_inline_node children in { + node; + steps = List.map xml_to_proof_step_group steps } | _ -> conversion_failure __FUNCTION__ xml type proof_node_group = - | Omitted of omitted_proof_node - | Obvious of obvious_proof_node + | Omitted of node + | Obvious of node | By of by_proof_node | Steps of steps_proof_node [@@deriving show] @@ -546,8 +473,8 @@ let xml_to_inline_proof_node_group children = match ls with | x::xs -> ( match x with - | Node ("omitted", _) -> Omitted (xml_to_omitted_proof_node x) - | Node ("obvious", _) -> Obvious (xml_to_obvious_proof_node x) + | Node ("omitted", children) -> let (node, _) = extract_inline_node children in Omitted node + | Node ("obvious", children) -> let (node, _) = extract_inline_node children in Obvious node | Node ("by", _) -> By (xml_to_by_proof_node x) | Node ("steps", _) -> Steps (xml_to_steps_proof_node x) | _ -> search_children xs @@ -557,7 +484,7 @@ let xml_to_inline_proof_node_group children = type theorem_node = { node : node; - definition : theorem_def_ref option; + definition : int option; body : expr_or_assume_prove; proof : proof_node_group; } @@ -565,9 +492,10 @@ type theorem_node = { let xml_to_theorem_node xml = match xml with - | Node ("TheoremNode", children) -> { - node = children |> xml_to_inline_node; - definition = children |> List.find_opt (is_tag "definition") |> Option.map child_of |> Option.map xml_to_theorem_def_ref; + | Node ("TheoremNode", children) -> + let (node, children) = extract_inline_node children in { + node; + definition = children |> List.find_opt (is_tag "definition") |> Option.map child_of |> Option.map get_ref; body = children |> find_tag "body" |> children_of |> xml_to_inline_expr_or_assume_prove |> Option.get; proof = children |> xml_to_inline_proof_node_group; } @@ -583,7 +511,7 @@ type entry_kind = | TheoremNode of theorem_node [@@deriving show] -let xml_to_entry_kind (children : tree list) = +let xml_to_entry_kind (children : tree list) : entry_kind = let rec find_variant (candidates : tree list) = match candidates with | x :: xs -> ( From bfcb8c14af86f1775a8d15fef6ada3d264c92a0b Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 15 Jan 2026 17:09:35 -0800 Subject: [PATCH 26/85] Start elaboration process Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 43 ++++++++++++++++++------------------ src/sany/xml.ml | 57 +++++++++++++++++++++++++++++++++++++++--------- src/tlapm_lib.ml | 4 +++- 3 files changed, 71 insertions(+), 33 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 90245c1d..6e84b2fa 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -12,10 +12,6 @@ let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty -let converted_modules : Module.T.mule Coll.Im.t ref = ref Coll.Im.empty - -let converted_units : Module.T.modunit Coll.Im.t ref = ref Coll.Im.empty - (** Converts SANY's location format to TLAPM's, for attachment to node metadata. *) @@ -48,15 +44,20 @@ let resolve_ref (uid : int) : Xml.entry = | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) +let resolve_module_node (uid : int) : Xml.module_node = + match (resolve_ref uid).kind with + | ModuleNode mule -> mule + | _ -> failwith ("Expected module node for UID: " ^ string_of_int uid) + let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = - match Coll.Im.find_opt param.ref !entries with - | Some (Xml.FormalParamNode xml) -> ( + match (resolve_ref param.ref).kind with + | Xml.FormalParamNode xml -> ( attach_props xml.node xml.uniquename, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n ) - | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int param.ref) + | _ -> failwith ("Expected formal parameter node for UID: " ^ string_of_int param.ref) let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = match (resolve_ref uid).kind with @@ -92,10 +93,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | _ -> None (** Converts a top-level module node. *) -let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule = - match Coll.Im.find_opt uid !converted_modules with - | Some kind -> kind - | None -> +let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = let inline_unit unit = match unit with | `Ref uid -> resolve_ref uid @@ -109,7 +107,7 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule *) in let convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with - | ModuleNode mule -> noprops (Submod (convert_module_node entry.uid mule)) + | ModuleNode xml_mule -> locate (Submod (convert_module_node mule)) xml_mule.location | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind @@ -126,7 +124,10 @@ let rec convert_module_node (uid : int) (mule : Xml.module_node) : Module.T.mule important = true } mule.location -(** Converts operator declarations such as CONSTANTS and VARIABLES. +(** Converts operator declarations such as CONSTANTS and VARIABLES. In a + declaration like VARIABLES x, y, z, each of x, y, and z are given as + separate OpDeclNode entries. In contrast, TLAPM wraps all of these in a + single Variables modunit. *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with @@ -492,15 +493,13 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) Coll.Im.empty ast.context; - converted_modules := Coll.Im.empty; - converted_units := Coll.Im.empty; - let root_module_id, root_module = List.find_map (fun (entry : Xml.entry) -> - match entry.kind with - | Xml.ModuleNode mule -> if mule.uniquename = ast.root_module then Some (entry.uid, mule) else None - | _ -> None) ast.context |> Option.get - in let root = convert_module_node root_module_id root_module in - converted_modules := Coll.Im.add root_module_id root !converted_modules; - Ok (Coll.Sm.empty, root) + let ctx = List.fold_left + (fun m mule_ref -> + let mule = mule_ref |> resolve_module_node |> convert_module_node in + Coll.Sm.add mule.core.name.core mule m) + Coll.Sm.empty + ast.module_node_ref + in Ok (ctx, Coll.Sm.find ast.root_module ctx) (** Calls SANY to parse the given module, then converts SANY's AST into the TLAPM AST format. diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 3598a3e2..689e3a8c 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -1,3 +1,11 @@ +(** This module provides functions to interact with SANY to parse TLA+ source + files into an XML representation, and then convert that XML representation + into something with a semblance of a type system. +*) + +(** Calls SANY in another process to parse the given TLA+ file, then collects + the XML parse tree output. +*) let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in @@ -27,45 +35,76 @@ type tree = | Value of string [@@deriving show] +(** Uses the Xmlm library to parse an XML string into the simple XML tree + representation defined above. +*) let str_to_xml (xml_str: string) : tree = let xml = Xmlm.make_input (`String (0, xml_str)) in let el (((_, name), _) : tag) (children : tree list) = Node (name, children) in let data (d : string) = Value d in Xmlm.input_doc_tree ~el ~data xml |> snd +(** Error method which raises an exception when parsing the SANY XML output + fails. If this is ever triggered it indicates a bug either in this code + (most likely) or in the SANY XML output. It is also possible this could + be triggered if SANY's XML output format changes in a future version. +*) let conversion_failure (fn_name : string) (xml : tree) : 'a = let err_msg = Printf.sprintf "%s conversion failure on %s" fn_name (show_tree xml) in Invalid_argument err_msg |> raise +(** Utility function most often used with List.find or List.exists to search + for a tag in the children of an XML node. +*) let is_tag (tag_name : string) (node : tree) : bool = match node with | Node (name, _) -> String.equal name tag_name | _ -> false +(** Utility function that simply returns the children of an XML node. Raises + an exception if called on a leaf node. +*) let children_of (xml : tree) : tree list = match xml with | Node (_, children) -> children | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise +(** Utility function that returns the single child of an XML node. Raises an + exception if there is not exactly one child. +*) let child_of (xml : tree) : tree = match xml with | Node (_, [child]) -> child | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise +(** Utility function to print a list of XML trees for debugging or error + message purposes. +*) let show_tree_list (xs : tree list) : string = Printf.sprintf "[%s]" (xs |> List.map show_tree |> String.concat "; ") +(** Searches for a tag in the children of an XML node, and raises a detailed + exception if it is not found. +*) let find_tag (tag_name : string) (children : tree list) : tree = match List.find_opt (is_tag tag_name) children with | Some v -> v | None -> Invalid_argument (Printf.sprintf "Unable to find tag %s in children %s" tag_name (show_tree_list children)) |> raise +(** Utility function to extract the string value from a tagged XML node. + Raises a detailed exception if the tag is not found or if the tagged node + does not contain a single string value. +*) let xml_to_tagged_string (tag_name : string) (children : tree list) : string = match find_tag tag_name children with | (Node (_, [Value d])) -> d | xml -> conversion_failure __FUNCTION__ xml +(** Utility function to extract the int value from a tagged XML node. + Raises a detailed exception if the tag is not found or if the tagged node + does not contain a single int value. +*) let xml_child_to_int (xml : tree) : int = match xml with | (Node (_, [Value d])) -> int_of_string d @@ -284,14 +323,14 @@ type module_node = { let xml_to_module_node xml = let ref_child child = match child with - | Node ("OpDeclNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("ModuleInstanceKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("UserDefinedOpKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("BuiltInKindRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("TheoremDefRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("AssumeDefRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("AssumeNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) - | Node ("TheoremNodeRef", children) -> Some (`Ref (xml_to_tagged_int "UID" children)) + | Node ("OpDeclNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("ModuleInstanceKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("UserDefinedOpKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("BuiltInKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("TheoremDefRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("AssumeDefRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("AssumeNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) + | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) | Node ("InstanceNode", children) -> Some (`OtherTODO "InstanceNode") | Node ("UseOrHideNode", children) -> Some (`OtherTODO "UseOrHideNode") | _ -> None @@ -575,8 +614,6 @@ let xml_to_ast (xml : tree) : (modules, (string * string)) result = Printexc.record_backtrace prev_backtrace; Result.error (e, trace) -let ( >>= ) = Result.bind - let get_module_ast_xml (module_path : string) (stdlib_path : string) : (modules, (string option * string)) result = match source_to_sany_xml_str module_path stdlib_path with | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index 9a40f012..e5dd444f 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -656,7 +656,9 @@ let tlapm_modctx_of_string ~(content : string) ~(filename : string) ~loader_path let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~prefer_stdlib : (modctx * Module.T.mule, string option * string) result = match !Params.parser_backend with | Tlapm -> tlapm_modctx_of_string ~content ~filename ~loader_paths ~prefer_stdlib - | Sany -> Sany.parse filename + | Sany -> let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = + let (mcx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (mcx, m) + in Result.bind (Sany.parse filename) transform let module_of_string module_str = let hparse = Tla_parser.P.use Module.Parser.parse in From 25c839620793f2b460a25b0ccb64d9cbfb70d01a Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 16 Jan 2026 13:43:01 -0800 Subject: [PATCH 27/85] XML parsing: added data subtypes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 8 ++-- src/sany/xml.ml | 114 +++++++++++++++++++++-------------------------- 2 files changed, 54 insertions(+), 68 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 6e84b2fa..c9d60ae6 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -107,22 +107,22 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = *) in let convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with - | ModuleNode xml_mule -> locate (Submod (convert_module_node mule)) xml_mule.location + | ModuleNode submod -> Submod (convert_module_node submod) |> attach_props submod.node | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node | TheoremNode theorem_node -> convert_theorem_node theorem_node - in locate { - name = noprops mule.uniquename; + in { + name = noprops mule.name; extendees = []; instancees = []; body = mule.units |> List.map inline_unit |> List.map convert_entry; defdepth = 0; stage = Parsed; important = true - } mule.location + } |> attach_props mule.node (** Converts operator declarations such as CONSTANTS and VARIABLES. In a declaration like VARIABLES x, y, z, each of x, y, and z are given as diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 689e3a8c..b473a9f3 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -26,22 +26,25 @@ open Xmlm;; (** This simple XML representation only consists of nodes and values, where node is a tag with a list of children. For example, the XML snippet - "value" would be Node ("SomeName", [Value "value"]). + "value" would be Node ("SomeName", [SValue "value"]). XML can also have attributes on tags, like , but these are not used in SANY's XML format. *) type tree = | Node of string * tree list - | Value of string + | SValue of string + | IValue of int [@@deriving show] (** Uses the Xmlm library to parse an XML string into the simple XML tree - representation defined above. + representation defined above. If SANY's XML output format is ever changed + to make use of attributes or namespaces, this function and the tree type + will both need to be updated accordingly. *) let str_to_xml (xml_str: string) : tree = let xml = Xmlm.make_input (`String (0, xml_str)) in - let el (((_, name), _) : tag) (children : tree list) = Node (name, children) in - let data (d : string) = Value d in + let el (((_namespace, name), _attributes) : tag) (children : tree list) = Node (name, children) in + let data (s : string) = match int_of_string_opt s with | Some n -> IValue n | None -> SValue s in Xmlm.input_doc_tree ~el ~data xml |> snd (** Error method which raises an exception when parsing the SANY XML output @@ -67,7 +70,7 @@ let is_tag (tag_name : string) (node : tree) : bool = let children_of (xml : tree) : tree list = match xml with | Node (_, children) -> children - | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise + | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise (** Utility function that returns the single child of an XML node. Raises an exception if there is not exactly one child. @@ -76,7 +79,7 @@ let child_of (xml : tree) : tree = match xml with | Node (_, [child]) -> child | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise - | Value _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise + | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise (** Utility function to print a list of XML trees for debugging or error message purposes. @@ -98,7 +101,7 @@ let find_tag (tag_name : string) (children : tree list) : tree = *) let xml_to_tagged_string (tag_name : string) (children : tree list) : string = match find_tag tag_name children with - | (Node (_, [Value d])) -> d + | (Node (_, [SValue s])) -> s | xml -> conversion_failure __FUNCTION__ xml (** Utility function to extract the int value from a tagged XML node. @@ -107,7 +110,7 @@ let xml_to_tagged_string (tag_name : string) (children : tree list) : string = *) let xml_child_to_int (xml : tree) : int = match xml with - | (Node (_, [Value d])) -> int_of_string d + | (Node (_, [IValue n])) -> n | _ -> conversion_failure __FUNCTION__ xml let xml_to_tagged_int (tag_name : string) (children : tree list) : int = @@ -118,15 +121,15 @@ let xml_to_tagged_int (tag_name : string) (children : tree list) : int = *) let get_ref_opt (xml : tree) : int option = match xml with - | Node ("AssumeDefRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("BuiltInKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("ModuleInstanceKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("ModuleNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("OpDeclNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("TheoremDefRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) - | Node ("UserDefinedOpKindRef", [Node ("UID", [Value uid])]) -> Some (int_of_string uid) + | Node ("AssumeDefRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("BuiltInKindRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("FormalParamNodeRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("ModuleInstanceKindRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("ModuleNodeRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("OpDeclNodeRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("TheoremDefRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> Some uid + | Node ("UserDefinedOpKindRef", [Node ("UID", [IValue uid])]) -> Some uid | _ -> None (** Use this either on a single node that must have a UID child, or in @@ -148,34 +151,19 @@ type location = { let xml_to_location (xml : tree) : location = match xml with | Node ("location", [ - Node ("column", [Node ("begin", [Value column_begin]); Node ("end", [Value column_end])]); - Node ("line", [Node ("begin", [Value line_begin]); Node ("end", [Value line_end])]); - Node ("filename", [Value filename]) + Node ("column", [Node ("begin", [IValue column_begin]); Node ("end", [IValue column_end])]); + Node ("line", [Node ("begin", [IValue line_begin]); Node ("end", [IValue line_end])]); + Node ("filename", [SValue filename]) ]) -> { - column = (int_of_string column_begin, int_of_string column_end); - line = (int_of_string line_begin, int_of_string line_end); + column = (column_begin, column_end); + line = (line_begin, line_end); filename; } | _ -> conversion_failure __FUNCTION__ xml -type level = - | Constant - | Variable - | Action - | Temporal -[@@deriving show] - -let int_to_level (n : int) : level = - match n with - | 0 -> Constant - | 1 -> Variable - | 2 -> Action - | 3 -> Temporal - | _ -> Invalid_argument (Printf.sprintf "Invalid level value: %d" n) |> raise - type node = { location : location option; - level : level option; + level : int option; } [@@deriving show] @@ -186,9 +174,9 @@ type node = { *) let extract_inline_node (children : tree list) : (node * tree list) = match children with - | Node ("location", _) as loc :: Node ("level", [Value lvl]) :: rest -> {location = Some (xml_to_location loc); level = Some (lvl |> int_of_string |> int_to_level)}, rest + | Node ("location", _) as loc :: Node ("level", [IValue lvl]) :: rest -> {location = Some (xml_to_location loc); level = Some lvl}, rest | Node ("location", _) as loc :: rest -> {location = Some (xml_to_location loc); level = None}, rest - | Node ("level", [Value lvl]) :: rest -> {location = None; level = Some (lvl |> int_of_string |> int_to_level)}, rest + | Node ("level", [IValue lvl]) :: rest -> {location = None; level = Some lvl}, rest | rest -> {location = None; level = None}, rest type numeral_node = { @@ -231,8 +219,8 @@ type unbound_symbol = { let xml_to_unbound_symbol xml = match xml with - | Node ("unbound", Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) :: tuple_tag_opt) -> { - symbol_ref = int_of_string uid; + | Node ("unbound", Node ("FormalParamNodeRef", [Node ("UID", [IValue symbol_ref])]) :: tuple_tag_opt) -> { + symbol_ref; is_tuple = match tuple_tag_opt with | [Node ("tuple", [])] -> true | _ -> false; } | _ -> conversion_failure __FUNCTION__ xml @@ -314,32 +302,30 @@ and xml_to_inline_expression children = |> Option.map xml_to_expression type module_node = { - location : location; - uniquename : string; + node : node; + name : string; units : [`Ref of int | `OtherTODO of string] list; } [@@deriving show] let xml_to_module_node xml = let ref_child child = - match child with - | Node ("OpDeclNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("ModuleInstanceKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("UserDefinedOpKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("BuiltInKindRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("TheoremDefRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("AssumeDefRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("AssumeNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> Some (`Ref (int_of_string uid)) - | Node ("InstanceNode", children) -> Some (`OtherTODO "InstanceNode") - | Node ("UseOrHideNode", children) -> Some (`OtherTODO "UseOrHideNode") - | _ -> None + match get_ref_opt child with + | Some uid -> `Ref uid + | None -> match child with + | Node ("InstanceNode", children) -> `OtherTODO "InstanceNode" + | Node ("UseOrHideNode", children) -> `OtherTODO "UseOrHideNode" + | _ -> conversion_failure __FUNCTION__ child in match xml with - | Node ("ModuleNode", children) -> { - uniquename = children |> xml_to_tagged_string "uniquename"; - location = children |> find_tag "location" |> xml_to_location; - units = List.filter_map ref_child children + | Node ("ModuleNode", children) -> + let (node, children) = extract_inline_node children in ( + match children with + | Node ("uniquename", [SValue name]) :: units -> { + node; + name; + units = List.map ref_child units } + | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml type declaration_kind = @@ -378,8 +364,8 @@ type leibniz_param = { let xml_to_leibniz_param xml = match xml with - | Node ("leibnizparam", Node ("FormalParamNodeRef", [Node ("UID", [Value uid])]) :: is_leibniz_opt) -> { - ref = int_of_string uid; + | Node ("leibnizparam", Node ("FormalParamNodeRef", [Node ("UID", [IValue ref])]) :: is_leibniz_opt) -> { + ref; is_leibniz = match is_leibniz_opt with | [Node ("leibniz", [])] -> true | _ -> false; } | _ -> conversion_failure __FUNCTION__ xml @@ -482,7 +468,7 @@ type proof_step_group = let xml_to_proof_step_group xml = match xml with - | Node ("TheoremNodeRef", [Node ("UID", [Value uid])]) -> TheoremNodeRef (int_of_string uid) + | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> TheoremNodeRef uid | _ -> conversion_failure __FUNCTION__ xml type steps_proof_node = { From c0e4f2d8d12ecb39081ba43b39f6259d1a261bfe Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 16 Jan 2026 17:21:51 -0800 Subject: [PATCH 28/85] Figuring out propertiesto attach to proof steps Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 121 +++++++++++++++++++++++++++++----------- src/sany/xml.ml | 140 ++++++++++++++++++++++++----------------------- 2 files changed, 162 insertions(+), 99 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c9d60ae6..885da235 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1,3 +1,44 @@ +(** This module converts SANY's abstract syntax tree (AST) into TLAPM's AST. + The two trees are quite different. SANY makes great use of globally unique + identifiers to reference one entity from another; for example, when the + symbol "x" is declared in a module, it is given a unique integer ID, and + all subsequent references to "x" use that ID. TLAPM, in contrast, uses De + Bruijn indices to represent variable references and has no equivalent to + a global symbol table. TLAPM also makes greater use of variants, as would + be expected in OCaml code; SANY is written in Java, so has a greater focus + on abstracting different AST nodes into a single AST node type. Nowhere is + this more apparent than in SANY's OpApplNode type, which is used for + everything from simple expressions like 1 + 3 to complex constructs like + \A x, y, z \in S : P. + + Much of the challenge of this module, in addition to the sheer number of + TLA+ syntax node types it has to convert, is the difficulty in mapping + the information in each SANY AST node to the fields expected in each + TLAPM node type. Often, TLAPM fields have no obvious use at this point in + the parsing process; they are clearly set up to be used later on during + proof elaboration or level-checking. TLAPM also wraps many AST nodes with + a generic key-value map used to store all kinds of things, most + prominently location & level information. SANY does not have an + equivalent, and prefers to store such information directly as fields in + each AST node. Internally, SANY actually has two different AST formats: + a very low-level one with close conformance to TLA+ syntax, and a more + abstract which is presented to us here. Thus the SANY AST has already + been processed significantly, and we are translating it to a form that is + comparatively much rougher & earlier in the parse process. + + Given these challenges, much SANY information such as identifier reference + IDs and levels are attached as metadata to TLAPM AST nodes for use later + on: not as the basis for final calculations, but rather to cross-check + them with TLAPM's own internal calculations. In particular, the difference + between UIDs and De Bruijn indices is so large that it is not feasible to + directly translate the logic without significant risk of introducing bugs. + Instead, the conversion to De Bruijn indices is modified to check that the + calculation matches the original UID-based reference, and error if not. + While this does not alleviate TLAPM maintenance costs as much as hoped, + it at least provides a strong safeguard against bugs. Future work can + possibly at least remove level-checking from TLAPM. +*) + open Property;; open Module.T;; open Expr.T;; @@ -10,6 +51,8 @@ let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = | None -> "Unknown location" in failwith (Printf.sprintf "%s not yet implemented: %s\n%s" category msg loc) +(** A module-global table of SANY AST entities, indexed by UID. +*) let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty (** Converts SANY's location format to TLAPM's, for attachment to node @@ -29,56 +72,71 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin file = filename; } -let locate (value : 'a) (location : Xml.location) : 'a wrapped = - Util.locate value (convert_location location) - -(** Wrap the given object in location and (eventually) level information. +(** Wrap the given object in location data. + TODO: also wrap with level data. *) let attach_props (props : Xml.node) (value : 'a) : 'a wrapped = match props.location with | Some loc -> Util.locate value (convert_location loc) | None -> noprops value +(** Look up the given ref in the global entries table, failing if not found. +*) let resolve_ref (uid : int) : Xml.entry = match Coll.Im.find_opt uid !entries with | Some kind -> {uid; kind} | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) +(** A typed version of resolve_ref for module nodes. +*) let resolve_module_node (uid : int) : Xml.module_node = match (resolve_ref uid).kind with | ModuleNode mule -> mule | _ -> failwith ("Expected module node for UID: " ^ string_of_int uid) +(** A typed version of resolve_ref for operator parameter nodes. +*) let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = match (resolve_ref param.ref).kind with | Xml.FormalParamNode xml -> ( - attach_props xml.node xml.uniquename, + attach_props xml.node xml.name, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n ) | _ -> failwith ("Expected formal parameter node for UID: " ^ string_of_int param.ref) +(** A typed version of resolve_ref for theorem definition nodes. +*) let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = match (resolve_ref uid).kind with | TheoremDefNode xml -> xml | _ -> failwith ("Expected theorem definition node for UID: " ^ string_of_int uid) +(** A typed version of resolve_ref for theorem nodes. +*) let resolve_theorem_node (uid : int) : Xml.theorem_node = match (resolve_ref uid).kind with | TheoremNode xml -> xml | _ -> failwith ("Expected theorem node for UID: " ^ string_of_int uid) +(** A typed version of resolve_ref for bound symbols. +*) let resolve_bound_symbol (uid : int) : hint = match Coll.Im.find_opt uid !entries with - | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.uniquename + | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.name | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) +let convert_proof_step_name (step_number : int) (theorem_def_ref : int option) : stepno = + match theorem_def_ref with + | Some uid -> let _name = (resolve_theorem_def_node uid).name in Unnamed (1, step_number) + | None -> failwith "Proof steps must have a name" + (** Converts built-in prefix, infix, and postfix operators along with keywords. *) let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = - match builtin.uniquename with + match builtin.name with | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE | "UNCHANGED" -> Some Builtin.UNCHANGED @@ -102,8 +160,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = things; SANY heavily uses GUIDs to reference one entity from another and those GUIDs are resolved in a global table with no real type information. Thus in-scope operator parameters coexist alongside entire modules, and - here we branch out to the appropriate conversion method. Some types are - invalid here at the global scope, and we avoid handling them. + here we branch out to the appropriate conversion method. *) in let convert_entry (entry : Xml.entry) : Module.T.modunit = match entry.kind with @@ -131,7 +188,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | Variable -> noprops (Variables [attach_props xml.node xml.uniquename]) + | Variable -> noprops (Variables [attach_props xml.node xml.name]) (** Converts action-level expressions such as [][expr]_sub and <><>_sub. *) @@ -280,7 +337,7 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) ) |> attach_props apply.node (* More abstract kinds of built-in operators *) | None -> ( - match op.uniquename with + match op.name with | "$SetEnumerate" -> SetEnum ( List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node @@ -302,21 +359,20 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) *) and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = Apply ( - Opaque op.uniquename |> attach_props op.node, + Opaque op.name |> attach_props op.node, List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node (** Conversion of reference to in-scope operator parameters, such as in op(a, b, c) == a. This is a case where information is actually lost, since the reference is converted to a simple string that will be resolved - again later on by turning it into a De Bruijn index (Ix) type. It might - be possible to convert the reference into a De Bruijn index directly. + again later on by turning it into a De Bruijn index (Ix) type. *) and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.formal_param_node) : Expr.T.expr = match param.arity with - | 0 -> Opaque param.uniquename |> attach_props param.node + | 0 -> Opaque param.name |> attach_props param.node | n -> Apply ( - Opaque param.uniquename |> attach_props param.node, + Opaque param.name |> attach_props param.node, List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node @@ -326,9 +382,9 @@ and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.fo *) and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_node) : Expr.T.expr = match decl.arity with - | 0 -> Opaque decl.uniquename |> attach_props decl.node + | 0 -> Opaque decl.name |> attach_props decl.node | n -> Apply ( - Opaque decl.uniquename |> attach_props decl.node, + Opaque decl.name |> attach_props decl.node, List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node @@ -336,7 +392,7 @@ and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_ all expression types. Things like \A x \in S : P are represented as an application of the built-in "forall" operator, with argument P and symbol x bound by S. This complicated method de-abstracts this into the more - detailed Expr.T.expr type used by TLAPS. + detailed Expr.T.expr variant type used by TLAPS. *) and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = let op_kind = (resolve_ref apply.operator).kind in @@ -350,7 +406,7 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = (* A reference to a CONSTANT or VARIABLE identifier *) | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl (* A reference to a named THEOREM or a proof step *) - | TheoremDefNode thm -> Opaque thm.uniquename |> attach_props thm.node + | TheoremDefNode thm -> Opaque thm.name |> attach_props thm.node | _ -> failwith ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind) ) (** Some places in TLA⁺ syntax allow both normal expressions and also @@ -380,7 +436,7 @@ and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modu | true -> failwith "TLAPS does not yet support recursive operators" | false -> noprops (Definition ( Operator ( - attach_props xml.node xml.uniquename, + attach_props xml.node xml.name, let expr = xml.body |> convert_expression in match xml.params with | [] -> expr @@ -414,7 +470,7 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. *) and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = Theorem ( - Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.uniquename) thm.definition, + Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, 0 (* TODO figure out what this integer parameter means *), convert_proof thm.proof, @@ -448,31 +504,33 @@ and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = match List.rev steps with | [] -> failwith "Step-based proofs must have at least one step" | last :: rest -> (List.rev rest, last) - in let convert_proof_step (step : Xml.proof_step_group) : Proof.T.step = + in let convert_proof_step (step_number : int) (step : Xml.proof_step_group) : Proof.T.step = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node - in let convert_qed_step (step : Xml.proof_step_group) : Proof.T.qed_step = + let step = Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node in + assign step Props.step (convert_proof_step_name step_number thm.definition) + in let convert_qed_step (step_number : int) (step : Xml.proof_step_group) : Proof.T.qed_step = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - Qed (convert_proof thm.proof) |> attach_props thm.node + let step = Qed (convert_proof thm.proof) |> attach_props thm.node in + assign step Props.step (Unnamed (1, step_number)) in let steps, qed = split_steps steps - in Steps (List.map convert_proof_step steps, convert_qed_step qed) + in Steps (List.mapi convert_proof_step steps, convert_qed_step (List.length steps) qed) ) |> attach_props node (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place where information is lost, as the facts and definitions are converted to - strings that will need to be resolved later on. + strings that will need to be resolved to De Bruijn indices later on. *) and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = let resolve_def (ref : int) : use_def wrapped = match (resolve_ref ref).kind with - | UserDefinedOpKind op -> Dvar op.uniquename |> attach_props op.node - | TheoremDefNode thm -> Dvar thm.uniquename |> attach_props thm.node + | UserDefinedOpKind op -> Dvar op.name |> attach_props op.node + | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node | other -> failwith ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) in By ({ facts = List.map convert_expression facts; @@ -488,6 +546,7 @@ and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = it a module-level mutable variable instead. *) let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = + if ast.modules <> [] then failwith "SANY AST cannot have multiple top-level modules"; entries := List.fold_left (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) @@ -498,7 +557,7 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string let mule = mule_ref |> resolve_module_node |> convert_module_node in Coll.Sm.add mule.core.name.core mule m) Coll.Sm.empty - ast.module_node_ref + ast.module_refs in Ok (ctx, Coll.Sm.find ast.root_module ctx) (** Calls SANY to parse the given module, then converts SANY's AST into the diff --git a/src/sany/xml.ml b/src/sany/xml.ml index b473a9f3..dbd108c4 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -56,6 +56,13 @@ let conversion_failure (fn_name : string) (xml : tree) : 'a = let err_msg = Printf.sprintf "%s conversion failure on %s" fn_name (show_tree xml) in Invalid_argument err_msg |> raise +(** Error method which raises an exception when parsing a list of XML + children fails. +*) +let ls_conversion_failure (fn_name : string) (children : tree list) : 'a = + let err_msg = Printf.sprintf "%s conversion failure on [%s]" fn_name (children |> List.map show_tree |> String.concat "; ") in + Invalid_argument err_msg |> raise + (** Utility function most often used with List.find or List.exists to search for a tag in the children of an XML node. *) @@ -81,19 +88,13 @@ let child_of (xml : tree) : tree = | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise -(** Utility function to print a list of XML trees for debugging or error - message purposes. -*) -let show_tree_list (xs : tree list) : string = - Printf.sprintf "[%s]" (xs |> List.map show_tree |> String.concat "; ") - (** Searches for a tag in the children of an XML node, and raises a detailed exception if it is not found. *) let find_tag (tag_name : string) (children : tree list) : tree = match List.find_opt (is_tag tag_name) children with | Some v -> v - | None -> Invalid_argument (Printf.sprintf "Unable to find tag %s in children %s" tag_name (show_tree_list children)) |> raise + | None -> ls_conversion_failure __FUNCTION__ children (** Utility function to extract the string value from a tagged XML node. Raises a detailed exception if the tag is not found or if the tagged node @@ -187,28 +188,25 @@ type numeral_node = { let xml_to_numeral_node (xml : tree) = match xml with - | Node ("NumeralNode", children) -> - let (node, children) = extract_inline_node children in { - node; - value = children |> xml_to_tagged_int "IntValue" - } + | Node ("NumeralNode", children) -> ( + match extract_inline_node children with + | node, [Node ("IntValue", [IValue value])] -> {node; value} + | _ -> ls_conversion_failure __FUNCTION__ children) | _ -> conversion_failure __FUNCTION__ xml type formal_param_node = { node : node; - uniquename : string; + name : string; arity : int; } [@@deriving show] let xml_to_formal_param_node xml = match xml with - | Node ("FormalParamNode", children) -> - let (node, children) = extract_inline_node children in { - node; - uniquename = xml_to_tagged_string "uniquename" children; - arity = xml_to_tagged_int "arity" children; - } + | Node ("FormalParamNode", children) -> ( + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> {node; name; arity} + | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml type unbound_symbol = { @@ -338,10 +336,10 @@ let int_to_declaration_kind (n : int) : declaration_kind = | _ -> Invalid_argument (Printf.sprintf "Invalid declaration kind value: %d" n) |> raise type op_decl_node = { - node : node; - uniquename : string; - arity : int; - kind : declaration_kind; + node : node; + name : string; + arity : int; + kind : declaration_kind; } [@@deriving show] @@ -350,7 +348,7 @@ let xml_to_op_decl_node (xml : tree) : op_decl_node = | Node ("OpDeclNode", children) -> let (node, children) = extract_inline_node children in { node; - uniquename = children |> xml_to_tagged_string "uniquename"; + name = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; kind = children |> xml_to_tagged_int "kind" |> int_to_declaration_kind; } @@ -372,7 +370,7 @@ let xml_to_leibniz_param xml = type user_defined_op_kind = { node : node; - uniquename : string; + name : string; arity : int; body : expression; params : leibniz_param list; @@ -385,7 +383,7 @@ let xml_to_user_defined_op_kind xml : user_defined_op_kind = | Node ("UserDefinedOpKind", children) -> let (node, children) = extract_inline_node children in { node; - uniquename = children |> xml_to_tagged_string "uniquename"; + name = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; body = children |> find_tag "body" |> child_of |> xml_to_expression; params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; @@ -395,7 +393,7 @@ let xml_to_user_defined_op_kind xml : user_defined_op_kind = type built_in_kind = { node : node; - uniquename : string; + name : string; arity : int; params : leibniz_param list; } @@ -406,7 +404,7 @@ let xml_to_built_in_kind xml : built_in_kind = | Node ("BuiltInKind", children) -> let (node, children) = extract_inline_node children in { node; - uniquename = children |> xml_to_tagged_string "uniquename"; + name = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; } @@ -424,19 +422,21 @@ let xml_to_inline_expr_or_assume_prove children = type theorem_def_node = { node : node; - uniquename : string; + name : string; body : expr_or_assume_prove; } [@@deriving show] let xml_to_theorem_def_node xml = match xml with - | Node ("TheoremDefNode", children) -> - let (node, children) = extract_inline_node children in { + | Node ("TheoremDefNode", children) -> ( + match extract_inline_node children with + | node, Node ("uniquename", [SValue name]) :: body -> { node; - uniquename = children |> xml_to_tagged_string "uniquename"; - body = children |> xml_to_inline_expr_or_assume_prove |> Option.get ; + name; + body = body |> xml_to_inline_expr_or_assume_prove |> Option.get; } + | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml type by_proof_node = { @@ -448,12 +448,14 @@ type by_proof_node = { let xml_to_by_proof_node xml = match xml with - | Node ("by", children) -> - let (node, children) = extract_inline_node children in { + | Node ("by", children) -> ( + match extract_inline_node children with + | node, [Node ("facts", facts); Node ("defs", defs)] -> { node; - facts = children |> find_tag "facts" |> children_of |> List.map xml_to_expression; - defs = children |> find_tag "defs" |> children_of |> List.filter_map get_ref_opt + facts = List.map xml_to_expression facts; + defs = List.filter_map get_ref_opt defs; } + | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml type proof_step_group = @@ -536,22 +538,16 @@ type entry_kind = | TheoremNode of theorem_node [@@deriving show] -let xml_to_entry_kind (children : tree list) : entry_kind = - let rec find_variant (candidates : tree list) = - match candidates with - | x :: xs -> ( - match x with - | Node ("ModuleNode", _) -> ModuleNode (xml_to_module_node x) - | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node x) - | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind x) - | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind x) - | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node x) - | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node x) - | Node ("TheoremNode", _) -> TheoremNode (xml_to_theorem_node x) - | _ -> find_variant xs - ) - | [] -> Invalid_argument (Printf.sprintf "Unable to find entry_kind variant in children %s" (show_tree_list children)) |> raise - in find_variant children +let xml_to_entry_kind (xml : tree) : entry_kind = + match xml with + | Node ("ModuleNode", _) -> ModuleNode (xml_to_module_node xml) + | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node xml) + | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind xml) + | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) + | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node xml) + | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node xml) + | Node ("TheoremNode", _) -> TheoremNode (xml_to_theorem_node xml) + | _ -> conversion_failure __FUNCTION__ xml type entry = { uid : int; @@ -561,31 +557,39 @@ type entry = { let xml_to_entry xml = match xml with - | Node ("entry", children) -> { - uid = children |> xml_to_tagged_int "UID"; - kind = xml_to_entry_kind children; + | Node ("entry", [Node ("UID", [IValue uid]); entry]) -> { + uid; + kind = xml_to_entry_kind entry; } | _ -> conversion_failure __FUNCTION__ xml type modules = { root_module: string; context: entry list; - module_node_ref : int list; + modules: module_node list; + module_refs : int list; } [@@deriving show] -let xml_to_modules xml = - let xml_to_context xml = - match xml with - | Node ("context", children) -> - children |> List.find_all (is_tag "entry") |> List.map xml_to_entry; - | _ -> conversion_failure __FUNCTION__ xml - in match xml with - | Node ("modules", children) -> { - root_module = xml_to_tagged_string "RootModule" children; - context = children |> find_tag "context" |> xml_to_context; - module_node_ref = children |> List.filter_map get_ref_opt +let xml_to_modules (xml : tree) : modules = + match xml with + | Node ("modules", children) -> ( + match children with + | Node ("RootModule", [SValue root_module]) :: Node ("context", entries) :: modules -> { + root_module; + context = List.map xml_to_entry entries; + modules = modules |> List.filter_map (fun entry -> + match entry with + | Node ("ModuleNode", _) -> Some (xml_to_module_node entry) + | _ -> None + ); + module_refs = List.filter_map (fun entry -> + match entry with + | Node ("ModuleNodeRef", [Node ("UID", [IValue uid])]) -> Some uid + | _ -> None + ) modules; } + | _ -> ls_conversion_failure __FUNCTION__ children) | _ -> conversion_failure __FUNCTION__ xml let xml_to_ast (xml : tree) : (modules, (string * string)) result = From be84a1123238c818086c605466dfdba91879c44b Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 19 Jan 2026 12:26:52 -0800 Subject: [PATCH 29/85] Parsed proof step names Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 35 +++++++++++++++++++++++++++++++++-- 1 file changed, 33 insertions(+), 2 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 885da235..563b1c6e 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -56,7 +56,8 @@ let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty (** Converts SANY's location format to TLAPM's, for attachment to node - metadata. + metadata. Since the SANY location does not include data for byte offsets + from beginning of file, we set those to 0 here. *) let convert_location ({column = (col_start, col_finish); line = (line_start, line_finish); filename} : Xml.location) : Loc.locus = { start = Actual { @@ -72,6 +73,36 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin file = filename; } +(** Parses proof step names like <1>a as given in SANY's XML output, where + they are escaped using < and &rt; for < and > respectively. +*) +let parse_proof_step_name (proof_name : string) (index : int) : stepno = + let parse_name (parse_state, level, name : int * int list * char list ) (c : char) : int * int list * char list = + match parse_state, c with + | 0, '<' -> (4, level, name) + | 0, '&' -> (1, level, name) + | 1, 'l' -> (2, level, name) + | 2, 't' -> (3, level, name) + | 3, ';' -> (4, level, name) + | 4, '0' .. '9' -> (4, int_of_char c - int_of_char '0' :: level, name) + | 4, '>' -> (8, level, name) + | 4, '&' -> (5, level, name) + | 5, 'r' -> (6, level, name) + | 6, 't' -> (7, level, name) + | 7, ';' -> (8, level, name) + | 8, 'a' .. 'z' -> (8, level, c :: name) + | 8, 'A' .. 'Z' -> (8, level, c :: name) + | 8, '0' .. '9' -> (8, level, c :: name) + | 8, '_' -> (8, level, c :: name) + | 8, '.' -> (9, level, name) + | 9, '.' -> (9, level, name) + | _ -> failwith (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) + in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name in + if level = [] then failwith (Format.sprintf "Proof step name '%s' missing level information" proof_name) else + let level = List.fold_right (fun (d : int) (acc : int) : int -> d + acc * 10) level 0 in + if name = [] then Unnamed (level, index) else + Named (level, name |> List.rev |> List.to_seq |> String.of_seq, true) + (** Wrap the given object in location data. TODO: also wrap with level data. *) @@ -130,7 +161,7 @@ let resolve_bound_symbol (uid : int) : hint = let convert_proof_step_name (step_number : int) (theorem_def_ref : int option) : stepno = match theorem_def_ref with - | Some uid -> let _name = (resolve_theorem_def_node uid).name in Unnamed (1, step_number) + | Some uid -> parse_proof_step_name (resolve_theorem_def_node uid).name step_number | None -> failwith "Proof steps must have a name" (** Converts built-in prefix, infix, and postfix operators along with keywords. From 9f47fe1909a398aa66ee1aab8e2738cc194c1fe7 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 19 Jan 2026 14:43:08 -0800 Subject: [PATCH 30/85] Extract proof level from step names Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 29 ++++++++++++++++++++++------- 1 file changed, 22 insertions(+), 7 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 563b1c6e..7636ed24 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -103,6 +103,18 @@ let parse_proof_step_name (proof_name : string) (index : int) : stepno = if name = [] then Unnamed (level, index) else Named (level, name |> List.rev |> List.to_seq |> String.of_seq, true) +(** Wraps the given proof step with its name in the metadata. +*) +let attach_proof_step_name (step : 'a) (proof_name : stepno) : 'a = + assign step Props.step proof_name + +(** Extracts the proof step level from its metadata. +*) +let get_proof_step_level (step : 'a) : int = + match get step Props.step with + | Unnamed (level, _) -> level + | Named (level, _, _) -> level + (** Wrap the given object in location data. TODO: also wrap with level data. *) @@ -159,10 +171,10 @@ let resolve_bound_symbol (uid : int) : hint = | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) -let convert_proof_step_name (step_number : int) (theorem_def_ref : int option) : stepno = +let convert_proof_step_name (proof_level : int option) (step_number : int) (theorem_def_ref : int option) : stepno = match theorem_def_ref with | Some uid -> parse_proof_step_name (resolve_theorem_def_node uid).name step_number - | None -> failwith "Proof steps must have a name" + | None -> Unnamed (Option.get proof_level, step_number) (** Converts built-in prefix, infix, and postfix operators along with keywords. *) @@ -535,22 +547,25 @@ and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = match List.rev steps with | [] -> failwith "Step-based proofs must have at least one step" | last :: rest -> (List.rev rest, last) - in let convert_proof_step (step_number : int) (step : Xml.proof_step_group) : Proof.T.step = + in let convert_proof_step (steps, level, number : Proof.T.step list * int option * int) (step : Xml.proof_step_group) : Proof.T.step list * int option * int = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in let step = Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node in - assign step Props.step (convert_proof_step_name step_number thm.definition) - in let convert_qed_step (step_number : int) (step : Xml.proof_step_group) : Proof.T.qed_step = + let step = assign step Props.step (convert_proof_step_name level number thm.definition) in + let level = match level with | Some l -> Some l | None -> Some (get_proof_step_level step) in + (step :: steps, level, number + 1) + in let convert_qed_step (proof_level : int option) (step_number : int) (step : Xml.proof_step_group) : Proof.T.qed_step = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in let step = Qed (convert_proof thm.proof) |> attach_props thm.node in - assign step Props.step (Unnamed (1, step_number)) + attach_proof_step_name step (convert_proof_step_name proof_level step_number thm.definition) in let steps, qed = split_steps steps - in Steps (List.mapi convert_proof_step steps, convert_qed_step (List.length steps) qed) + in let (steps, level, number) = List.fold_left convert_proof_step ([], None, 0) steps in + Steps (List.rev steps, convert_qed_step level number qed) ) |> attach_props node (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place From 4dc60f2da969ba82ac0411f85d9cadebf6125a4f Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 20 Jan 2026 14:15:46 -0800 Subject: [PATCH 31/85] Finish attaching proof name metadata Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 80 ++++++++++++++++++++++++++++-------------------- 1 file changed, 47 insertions(+), 33 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 7636ed24..e3028037 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -74,38 +74,51 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin } (** Parses proof step names like <1>a as given in SANY's XML output, where - they are escaped using < and &rt; for < and > respectively. + they are escaped using < and &rt; for < and > respectively. Proof step + name can also be <+>, meaning one more than the previous proof level, or + <*>, meaning same as the current proof level. *) -let parse_proof_step_name (proof_name : string) (index : int) : stepno = - let parse_name (parse_state, level, name : int * int list * char list ) (c : char) : int * int list * char list = +let parse_proof_step_name (previous_proof_level : int option) (current_proof_level : int option) (uid : int) (proof_name : string) : stepno = + let parse_name (parse_state, level, name : int * char list * char list ) (c : char) : int * char list * char list = match parse_state, c with + (* Start state: expect < or < *) | 0, '<' -> (4, level, name) | 0, '&' -> (1, level, name) | 1, 'l' -> (2, level, name) | 2, 't' -> (3, level, name) | 3, ';' -> (4, level, name) - | 4, '0' .. '9' -> (4, int_of_char c - int_of_char '0' :: level, name) - | 4, '>' -> (8, level, name) - | 4, '&' -> (5, level, name) - | 5, 'r' -> (6, level, name) - | 6, 't' -> (7, level, name) - | 7, ';' -> (8, level, name) - | 8, 'a' .. 'z' -> (8, level, c :: name) - | 8, 'A' .. 'Z' -> (8, level, c :: name) - | 8, '0' .. '9' -> (8, level, c :: name) - | 8, '_' -> (8, level, c :: name) - | 8, '.' -> (9, level, name) - | 9, '.' -> (9, level, name) + (* Level parsing state: expect '+', '*', or digit *) + | 4, '+' | 4, '*' -> (6, [c], name) + (* Parse at least one digit then consume another digit, >, or &rt; *) + | 4, '0' .. '9' | 5, '0' .. '9' -> (5, c :: level, name) + | 5, '>' -> (10, level, name) + | 5, '&' -> (7, level, name) + (* Have seen + or *, expect > or &rt; *) + | 6, '>' -> (10, level, name) + | 6, '&' -> (7, level, name) + | 7, 'r' -> (8, level, name) + | 8, 't' -> (9, level, name) + | 9, ';' -> (10, level, name) + (* Proof name parsing state: read in zero or more a-zA-Z0-9_ *) + | 10, 'a' .. 'z' | 10, 'A' .. 'Z' | 10, '0' .. '9' | 10, '_' -> (10, level, c :: name) + (* Terminating '.' state; consume & ignore *) + | 10, '.' | 11, '.' -> (11, level, name) | _ -> failwith (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name in - if level = [] then failwith (Format.sprintf "Proof step name '%s' missing level information" proof_name) else - let level = List.fold_right (fun (d : int) (acc : int) : int -> d + acc * 10) level 0 in - if name = [] then Unnamed (level, index) else - Named (level, name |> List.rev |> List.to_seq |> String.of_seq, true) + let level = match level, previous_proof_level, current_proof_level with + | ['+'], None, None -> 0 + | ['+'], Some previous_proof_level, None -> previous_proof_level + 1 + | ['+'], _, Some _ -> failwith "Cannot have explicit proof level followed by <+>" + | ['*'], None, None -> 0 + | ['*'], Some previous_proof_level, None -> previous_proof_level + 1 + | ['*'], _, Some current_proof_level -> current_proof_level + | _ -> List.fold_right (fun (d : char) (acc : int) : int -> (int_of_char d - int_of_char '0') + acc * 10) level 0 in + if name = [] then Unnamed (level, uid) else + Named (level, name |> List.rev |> List.to_seq |> String.of_seq, false) (** Wraps the given proof step with its name in the metadata. *) -let attach_proof_step_name (step : 'a) (proof_name : stepno) : 'a = +let attach_proof_step_name (proof_name : stepno) (step : 'a) : 'a = assign step Props.step proof_name (** Extracts the proof step level from its metadata. @@ -171,10 +184,10 @@ let resolve_bound_symbol (uid : int) : hint = | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) -let convert_proof_step_name (proof_level : int option) (step_number : int) (theorem_def_ref : int option) : stepno = +let convert_proof_step_name (proof_level : int option) (theorem_def_ref : int option) : stepno = match theorem_def_ref with - | Some uid -> parse_proof_step_name (resolve_theorem_def_node uid).name step_number - | None -> Unnamed (Option.get proof_level, step_number) + | Some uid -> parse_proof_step_name None proof_level uid (resolve_theorem_def_node uid).name + | None -> Unnamed (Option.get proof_level, let open Ext in Std.unique ()) (** Converts built-in prefix, infix, and postfix operators along with keywords. *) @@ -542,31 +555,32 @@ and convert_proof (proof : Xml.proof_node_group) : Proof.T.proof = (** One possible proof form is a series of steps, culminating in a QED step. This method converts that structure. *) -and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = ( +and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = match List.rev steps with | [] -> failwith "Step-based proofs must have at least one step" | last :: rest -> (List.rev rest, last) - in let convert_proof_step (steps, level, number : Proof.T.step list * int option * int) (step : Xml.proof_step_group) : Proof.T.step list * int option * int = + in let convert_proof_step (steps, level : Proof.T.step list * int option) (step : Xml.proof_step_group) : Proof.T.step list * int option = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in let step = Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node in - let step = assign step Props.step (convert_proof_step_name level number thm.definition) in + let step = attach_proof_step_name (convert_proof_step_name level thm.definition) step in let level = match level with | Some l -> Some l | None -> Some (get_proof_step_level step) in - (step :: steps, level, number + 1) - in let convert_qed_step (proof_level : int option) (step_number : int) (step : Xml.proof_step_group) : Proof.T.qed_step = + (step :: steps, level) + in let convert_qed_step (proof_level : int option) (step : Xml.proof_step_group) : Proof.T.qed_step = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - let step = Qed (convert_proof thm.proof) |> attach_props thm.node in - attach_proof_step_name step (convert_proof_step_name proof_level step_number thm.definition) + Qed (convert_proof thm.proof) |> attach_props thm.node + |> attach_proof_step_name (convert_proof_step_name proof_level thm.definition) in let steps, qed = split_steps steps - in let (steps, level, number) = List.fold_left convert_proof_step ([], None, 0) steps in - Steps (List.rev steps, convert_qed_step level number qed) -) |> attach_props node + in let (steps, level) = List.fold_left convert_proof_step ([], None) steps in + Steps (List.rev steps, convert_qed_step level qed) + |> attach_props node + |> attach_proof_step_name (Unnamed (Option.get level, let open Ext in Std.unique ())) (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place where information is lost, as the facts and definitions are converted to From 1a1a17dcae3a04a08e9ae3bb40b27b8b5c0a9ae1 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 20 Jan 2026 17:03:46 -0800 Subject: [PATCH 32/85] Propagate assumption/discovery of proof levels up and down tree Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 90 ++++++++++++++++++++++++++---------------------- 1 file changed, 49 insertions(+), 41 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index e3028037..3d229cf6 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -73,12 +73,16 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin file = filename; } +type proof_level = + | Previous of int + | Known of int + (** Parses proof step names like <1>a as given in SANY's XML output, where they are escaped using < and &rt; for < and > respectively. Proof step name can also be <+>, meaning one more than the previous proof level, or <*>, meaning same as the current proof level. *) -let parse_proof_step_name (previous_proof_level : int option) (current_proof_level : int option) (uid : int) (proof_name : string) : stepno = +let parse_proof_step_name (proof_level : proof_level) (uid : int) (proof_name : string) : stepno = let parse_name (parse_state, level, name : int * char list * char list ) (c : char) : int * char list * char list = match parse_state, c with (* Start state: expect < or < *) @@ -104,16 +108,20 @@ let parse_proof_step_name (previous_proof_level : int option) (current_proof_lev (* Terminating '.' state; consume & ignore *) | 10, '.' | 11, '.' -> (11, level, name) | _ -> failwith (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) - in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name in - let level = match level, previous_proof_level, current_proof_level with - | ['+'], None, None -> 0 - | ['+'], Some previous_proof_level, None -> previous_proof_level + 1 - | ['+'], _, Some _ -> failwith "Cannot have explicit proof level followed by <+>" - | ['*'], None, None -> 0 - | ['*'], Some previous_proof_level, None -> previous_proof_level + 1 - | ['*'], _, Some current_proof_level -> current_proof_level - | _ -> List.fold_right (fun (d : char) (acc : int) : int -> (int_of_char d - int_of_char '0') + acc * 10) level 0 in - if name = [] then Unnamed (level, uid) else + in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name + in let digits_to_int (digits : char list) : int = + List.fold_right (fun (d : char) (acc : int) : int -> (int_of_char d - int_of_char '0') + acc * 10) digits 0 + in let level = match level, proof_level with + | ['+'], Previous n -> n + 1 + | ['+'], Known _ -> failwith "Cannot have explicit proof level followed by <+>" + | ['*'], Previous n -> n + 1 + | ['*'], Known n -> n + | digits, Previous _ -> digits_to_int digits + | digits, Known n -> + let level = digits_to_int digits in + if level <> n then failwith ("Mismatched proof level: expected " ^ string_of_int n ^ " but got " ^ string_of_int level) + else level + in if name = [] then Unnamed (level, uid) else Named (level, name |> List.rev |> List.to_seq |> String.of_seq, false) (** Wraps the given proof step with its name in the metadata. @@ -121,13 +129,6 @@ let parse_proof_step_name (previous_proof_level : int option) (current_proof_lev let attach_proof_step_name (proof_name : stepno) (step : 'a) : 'a = assign step Props.step proof_name -(** Extracts the proof step level from its metadata. -*) -let get_proof_step_level (step : 'a) : int = - match get step Props.step with - | Unnamed (level, _) -> level - | Named (level, _, _) -> level - (** Wrap the given object in location data. TODO: also wrap with level data. *) @@ -184,10 +185,12 @@ let resolve_bound_symbol (uid : int) : hint = | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) -let convert_proof_step_name (proof_level : int option) (theorem_def_ref : int option) : stepno = +let convert_proof_step_name (proof_level : proof_level) (theorem_def_ref : int option) : stepno = match theorem_def_ref with - | Some uid -> parse_proof_step_name None proof_level uid (resolve_theorem_def_node uid).name - | None -> Unnamed (Option.get proof_level, let open Ext in Std.unique ()) + | Some uid -> parse_proof_step_name proof_level uid (resolve_theorem_def_node uid).name + | None -> match proof_level with + | Previous n -> Unnamed (n + 1, let open Ext in Std.unique ()) + | Known n -> Unnamed (n, let open Ext in Std.unique ()) (** Converts built-in prefix, infix, and postfix operators along with keywords. *) @@ -226,7 +229,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node - | TheoremNode theorem_node -> convert_theorem_node theorem_node + | TheoremNode theorem_node -> convert_theorem_node 0 theorem_node in { name = noprops mule.name; extendees = []; @@ -524,12 +527,12 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and TheoremNode does not. TLAPM's theorem node construction has some oddities in the form of additional metadata. *) -and convert_theorem_node (thm : Xml.theorem_node) : Module.T.modunit = +and convert_theorem_node (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = Theorem ( Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, 0 (* TODO figure out what this integer parameter means *), - convert_proof thm.proof, + convert_proof previous_proof_level thm.proof, noprops Obvious, (* TODO figure out why there are two proofs *) empty_summary (* TODO figure out purpose of summary *) ) |> attach_props thm.node @@ -545,42 +548,47 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. *) -and convert_proof (proof : Xml.proof_node_group) : Proof.T.proof = +and convert_proof (previous_proof_level : int) (proof : Xml.proof_node_group) : Proof.T.proof = + let open Ext in match proof with - | Omitted node -> Omitted Explicit |> attach_props node - | Obvious node -> Obvious |> attach_props node - | By proof -> convert_by_proof proof - | Steps proof -> convert_proof_steps proof + | Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) + | Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) + | By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) + | Steps proof -> convert_proof_steps previous_proof_level proof (** One possible proof form is a series of steps, culminating in a QED step. This method converts that structure. *) -and convert_proof_steps ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = +and convert_proof_steps (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = match List.rev steps with | [] -> failwith "Step-based proofs must have at least one step" | last :: rest -> (List.rev rest, last) - in let convert_proof_step (steps, level : Proof.T.step list * int option) (step : Xml.proof_step_group) : Proof.T.step list * int option = + in let convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (step : Xml.proof_step_group) : Proof.T.step list * proof_level = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - let step = Suffices (convert_sequent thm.body, convert_proof thm.proof) |> attach_props thm.node in - let step = attach_proof_step_name (convert_proof_step_name level thm.definition) step in - let level = match level with | Some l -> Some l | None -> Some (get_proof_step_level step) in - (step :: steps, level) - in let convert_qed_step (proof_level : int option) (step : Xml.proof_step_group) : Proof.T.qed_step = + let step_name = convert_proof_step_name proof_level thm.definition in + let step = Suffices (convert_sequent thm.body, convert_proof (step_number step_name) thm.proof) |> attach_props thm.node in + (attach_proof_step_name step_name step :: steps, Known (step_number step_name)) + in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - Qed (convert_proof thm.proof) |> attach_props thm.node - |> attach_proof_step_name (convert_proof_step_name proof_level thm.definition) + let step_name = convert_proof_step_name proof_level thm.definition in + let qed_step = Qed (convert_proof (step_number step_name) thm.proof) |> attach_props thm.node in + (attach_proof_step_name step_name qed_step, Known (step_number step_name)) in let steps, qed = split_steps steps - in let (steps, level) = List.fold_left convert_proof_step ([], None) steps in - Steps (List.rev steps, convert_qed_step level qed) + in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps + in let qed_step, proof_level = convert_qed_step proof_level qed + in let proof_level = match proof_level with + | Previous _ -> failwith "Current proof level should be known after processing all steps" + | Known n -> n + in Steps (List.rev steps, qed_step) |> attach_props node - |> attach_proof_step_name (Unnamed (Option.get level, let open Ext in Std.unique ())) + |> attach_proof_step_name (Unnamed (proof_level, let open Ext in Std.unique ())) (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place where information is lost, as the facts and definitions are converted to From 9cf2c07c599409f94548b6d8d1e2bf366c0ed573 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 21 Jan 2026 15:23:31 -0800 Subject: [PATCH 33/85] Flatten module Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 51 ++++++++++++++++++++++++++++-------------------- src/tlapm_lib.ml | 3 ++- 2 files changed, 32 insertions(+), 22 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 3d229cf6..d5e328f3 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -185,12 +185,12 @@ let resolve_bound_symbol (uid : int) : hint = | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) -let convert_proof_step_name (proof_level : proof_level) (theorem_def_ref : int option) : stepno = +let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def_ref : int option) : stepno = match theorem_def_ref with | Some uid -> parse_proof_step_name proof_level uid (resolve_theorem_def_node uid).name | None -> match proof_level with - | Previous n -> Unnamed (n + 1, let open Ext in Std.unique ()) - | Known n -> Unnamed (n, let open Ext in Std.unique ()) + | Previous n -> Unnamed (n + 1, uid) + | Known n -> Unnamed (n, uid) (** Converts built-in prefix, infix, and postfix operators along with keywords. *) @@ -229,7 +229,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node - | TheoremNode theorem_node -> convert_theorem_node 0 theorem_node + | TheoremNode theorem_node -> convert_theorem_node entry.uid 0 theorem_node in { name = noprops mule.name; extendees = []; @@ -237,7 +237,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = body = mule.units |> List.map inline_unit |> List.map convert_entry; defdepth = 0; stage = Parsed; - important = true + important = false } |> attach_props mule.node (** Converts operator declarations such as CONSTANTS and VARIABLES. In a @@ -527,12 +527,12 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and TheoremNode does not. TLAPM's theorem node construction has some oddities in the form of additional metadata. *) -and convert_theorem_node (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = +and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = Theorem ( Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, 0 (* TODO figure out what this integer parameter means *), - convert_proof previous_proof_level thm.proof, + convert_proof uid previous_proof_level thm.proof, noprops Obvious, (* TODO figure out why there are two proofs *) empty_summary (* TODO figure out purpose of summary *) ) |> attach_props thm.node @@ -548,18 +548,27 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. *) -and convert_proof (previous_proof_level : int) (proof : Xml.proof_node_group) : Proof.T.proof = - let open Ext in +and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group) : Proof.T.proof = match proof with - | Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) - | Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) - | By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, Std.unique ())) - | Steps proof -> convert_proof_steps previous_proof_level proof + | Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Steps proof -> convert_proof_steps uid previous_proof_level proof (** One possible proof form is a series of steps, culminating in a QED step. - This method converts that structure. -*) -and convert_proof_steps (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = + This method converts that structure. This is the most complex part of the + proof conversion, primarily due to the necessity of appending proof step + names and levels to each step and overall proof. SANY does not export the + proof level in its parse tree, and looking at the code on that side there + does not seem to be an easy method of doing so. Thus we have to parse the + first proof step name to get the initial proof level, which might be <*> + or <+> and thus relative to the previous proof level. This information is + propagated both up & down the parse tree to assign correct proof levels + elsewhere. Proof names can be either named or unnamed; in the latter case + TLAPM requires a unique ID to be assigned, so we use the UID of the SANY + AST node. +*) +and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = match List.rev steps with | [] -> failwith "Step-based proofs must have at least one step" @@ -569,16 +578,16 @@ and convert_proof_steps (previous_proof_level : int) ({node; steps} : Xml.steps_ (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name proof_level thm.definition in - let step = Suffices (convert_sequent thm.body, convert_proof (step_number step_name) thm.proof) |> attach_props thm.node in + let step_name = convert_proof_step_name uid proof_level thm.definition in + let step = Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name step :: steps, Known (step_number step_name)) in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = match step with (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name proof_level thm.definition in - let qed_step = Qed (convert_proof (step_number step_name) thm.proof) |> attach_props thm.node in + let step_name = convert_proof_step_name uid proof_level thm.definition in + let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name qed_step, Known (step_number step_name)) in let steps, qed = split_steps steps in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps @@ -588,7 +597,7 @@ and convert_proof_steps (previous_proof_level : int) ({node; steps} : Xml.steps_ | Known n -> n in Steps (List.rev steps, qed_step) |> attach_props node - |> attach_proof_step_name (Unnamed (proof_level, let open Ext in Std.unique ())) + |> attach_proof_step_name (Unnamed (proof_level, uid)) (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place where information is lost, as the facts and definitions are converted to diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index e5dd444f..018d6a82 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -657,7 +657,8 @@ let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~pre match !Params.parser_backend with | Tlapm -> tlapm_modctx_of_string ~content ~filename ~loader_paths ~prefer_stdlib | Sany -> let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = - let (mcx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (mcx, m) + let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in + let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) in Result.bind (Sany.parse filename) transform let module_of_string module_str = From fff604ee57358a448463e8742ff3b329c77930b4 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 22 Jan 2026 17:13:01 -0800 Subject: [PATCH 34/85] Now stuck on proof expansion Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 18 +++++++++++------- src/tlapm_lib.ml | 21 ++++++++++++++++----- 2 files changed, 27 insertions(+), 12 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index d5e328f3..c07727e6 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -70,7 +70,7 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin bol = 0; col = col_finish; }; - file = filename; + file = filename ^ ".tla"; } type proof_level = @@ -629,13 +629,17 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) Coll.Im.empty ast.context; - let ctx = List.fold_left - (fun m mule_ref -> - let mule = mule_ref |> resolve_module_node |> convert_module_node in - Coll.Sm.add mule.core.name.core mule m) - Coll.Sm.empty + let ctx : Module.T.modctx = List.fold_left + (fun (map : Module.T.modctx) (mule_ref : int) -> + let mule : Xml.module_node = mule_ref |> resolve_module_node in + if Coll.Sm.mem mule.name map then map + else Coll.Sm.add mule.name (convert_module_node mule) map + ) + Module.Standard.initctx ast.module_refs - in Ok (ctx, Coll.Sm.find ast.root_module ctx) + in let root_module = Coll.Sm.find ast.root_module ctx in + root_module.core.important <- true; + Ok (ctx, root_module) (** Calls SANY to parse the given module, then converts SANY's AST into the TLAPM AST format. diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index 018d6a82..2ff10824 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -544,7 +544,22 @@ let setup_loader fs loader_paths = let loader_paths = List.fold_left add_if_new loader_paths fs in Loader.Global.setup loader_paths +let sany_modctx_of_string filename = + let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = + Params.input_files := [Filename.basename filename]; + Params.set_search_path [Filename.basename filename]; + let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in + let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) + in Result.bind (Sany.parse filename) transform + let main fs = + match !Params.parser_backend, fs with + | Sany, [root_module_path] -> (match sany_modctx_of_string root_module_path with + | Ok (mcx, mule) -> process_module mcx mule |> ignore + | Error (_, msg) -> failwith ("Error parsing module using Sany backend: " ^ msg) + ) + | Sany, _ -> failwith "When using Sany parser backend, exactly one input file must be provided." + | Tlapm, _ -> setup_loader fs !Params.rev_search_path; Params.input_files := map_paths_to_filenames fs; let () = @@ -651,15 +666,11 @@ let tlapm_modctx_of_string ~(content : string) ~(filename : string) ~loader_path | Some l, None -> Error (Some l, Printexc.to_string e) | None, None -> Error (None, Printexc.to_string e)) - (* Access to this function has to be synchronized. *) let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~prefer_stdlib : (modctx * Module.T.mule, string option * string) result = match !Params.parser_backend with | Tlapm -> tlapm_modctx_of_string ~content ~filename ~loader_paths ~prefer_stdlib - | Sany -> let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = - let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in - let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) - in Result.bind (Sany.parse filename) transform + | Sany -> sany_modctx_of_string filename let module_of_string module_str = let hparse = Tla_parser.P.use Module.Parser.parse in From c2fd0734e7baedc7c438886089064c4dfb2a5da6 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 22 Jan 2026 20:35:58 -0800 Subject: [PATCH 35/85] Proof expansion progress Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c07727e6..baad9b34 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -503,7 +503,7 @@ and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modu | params -> Lambda (List.map resolve_formal_param_node params, expr) |> noprops ) |> noprops, User, - Visible, + Hidden, (* If Visible, will be auto-included in all BY proofs *) Export )) @@ -613,7 +613,7 @@ and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = facts = List.map convert_expression facts; defs = List.map resolve_def defs; }, - true (* TODO: figure out meaning of this parameter *) + true (* This should be true if the ONLY keyword is present *) ) |> attach_props node (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY From 1bb38401b7cfa4a7b5bececb3d64cd46be15a96d Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 23 Jan 2026 18:48:34 -0800 Subject: [PATCH 36/85] Translating Examples specs Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 77 ++++++++++++--------- src/sany/xml.ml | 149 +++++++++++++++++++++++++--------------- src/tlapm_args.ml | 2 +- test/sany/sany_tests.ml | 23 ++++++- 4 files changed, 158 insertions(+), 93 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index baad9b34..e5643005 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -225,14 +225,14 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = match entry.kind with | ModuleNode submod -> Submod (convert_module_node submod) |> attach_props submod.node | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node - | UserDefinedOpKind user_defined_op_kind -> convert_user_defined_op_kind user_defined_op_kind - | BuiltInKind built_in_kind -> convert_built_in_kind built_in_kind - | FormalParamNode formal_param_node -> convert_formal_param_node formal_param_node + | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node | TheoremNode theorem_node -> convert_theorem_node entry.uid 0 theorem_node + | BuiltInKind _ -> failwith "BuiltInKind not expected at module top-level" + | FormalParamNode _ -> failwith "FormalParamNode not expected at module top-level" in { name = noprops mule.name; - extendees = []; + extendees = []; (* TODO: figure out how to get list of modules imported by this module *) instancees = []; body = mule.units |> List.map inline_unit |> List.map convert_entry; defdepth = 0; @@ -247,7 +247,7 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | Variable -> noprops (Variables [attach_props xml.node xml.name]) + | Variable -> attach_props xml.node (Variables [attach_props xml.node xml.name]) (** Converts action-level expressions such as [][expr]_sub and <><>_sub. *) @@ -484,34 +484,41 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp *) and convert_expression (expr : Xml.expression) : Expr.T.expr = match expr with - | NumeralNode expr -> Num (Int.to_string expr.value, "") |> attach_props expr.node + | NumeralNode n -> Num (Int.to_string n.value, "") |> attach_props n.node + | StringNode s -> String s.value |> attach_props s.node | OpApplNode apply -> convert_op_appl_node apply + | LetInNode let_in -> convert_let_in_node let_in -(** Converts user-defined operators defined in a module top-level or within - LET/IN expressions. +and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = + let definitions = List.map (fun ref -> + match (resolve_ref ref).kind with + | UserDefinedOpKind op -> convert_user_defined_op_kind op + | _ -> todo "LET/IN definition" "Probably an instance" None + ) def_refs in + Let (definitions, convert_expression body) |> attach_props node + +(** Converts user-defined operators defined within LET/IN expressions. +*) +and convert_user_defined_op_kind (xml : Xml.user_defined_op_kind) : Expr.T.defn = + let name = attach_props xml.node xml.name in + let body = xml.body |> convert_expression in + (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) + let expr = match xml.params with + | [] -> body + | params -> Lambda (List.map resolve_formal_param_node params, body) |> attach_props xml.node + in Operator (name, expr) |> attach_props xml.node + +(** Converts user-defined operators defined in a module top-level. *) -and convert_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = +and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = match xml.recursive with | true -> failwith "TLAPS does not yet support recursive operators" - | false -> noprops (Definition ( - Operator ( - attach_props xml.node xml.name, - let expr = xml.body |> convert_expression in - match xml.params with - | [] -> expr - (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) - | params -> Lambda (List.map resolve_formal_param_node params, expr) |> noprops - ) |> noprops, + | false -> (Definition ( + convert_user_defined_op_kind xml, User, Hidden, (* If Visible, will be auto-included in all BY proofs *) - Export - )) - -and convert_built_in_kind (built_in_kind : Xml.built_in_kind) : Module.T.modunit = - todo "BuiltInKind" "" built_in_kind.node.location - -and convert_formal_param_node (formal_param_node : Xml.formal_param_node) : Module.T.modunit = - todo "FormalParamNode" "" formal_param_node.node.location + Export (* Whether definition is declared LOCAL *) + )) |> attach_props xml.node (** This type is redundant with the below TheoremNode type and its conversion does not need to be handled. Probably the SANY XML exporter should be @@ -525,16 +532,19 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. (** Converts theorem nodes. Oddly, SANY has two different theorem node types containing identical information except TheoremDefNode contains the name and TheoremNode does not. TLAPM's theorem node construction has some - oddities in the form of additional metadata. + oddities in the form of additional metadata. The proof is stored twice, + as one copy is rewritten during proof elaboration while the other remains + unchanged for error message purposes. *) and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = + let proof = convert_proof uid previous_proof_level thm.proof in Theorem ( Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, - 0 (* TODO figure out what this integer parameter means *), - convert_proof uid previous_proof_level thm.proof, - noprops Obvious, (* TODO figure out why there are two proofs *) - empty_summary (* TODO figure out purpose of summary *) + 0 (* The purpose of this integer parameter is unknown. *), + proof, + proof, + empty_summary ) |> attach_props thm.node (** Sequents are theorem bodies, which are either simple expressions or @@ -620,7 +630,10 @@ and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = uses a lot of GUIDs for one entity to reference another, so we load those into a global table for fast lookup. This table would have to be a parameter to every conversion method in this file; for simplicity we make - it a module-level mutable variable instead. + it a module-level mutable variable instead. This method returns both the + converted root module and a context, which is a mapping from module names + to module structures for the transitive closure of modules imported from + root. *) let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = if ast.modules <> [] then failwith "SANY AST cannot have multiple top-level modules"; diff --git a/src/sany/xml.ml b/src/sany/xml.ml index dbd108c4..f171b0f5 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -9,9 +9,10 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in - let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -t %s" + let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -I %s -t %s" (backend_classpath_string "tla2tools.jar") (Filename.quote stdlib_path) + (Filename.dirname module_path) (Filename.quote module_path) in let (pid, out_fd) = System.launch_process cmd in let in_chan = Unix.in_channel_of_descr out_fd in @@ -180,13 +181,13 @@ let extract_inline_node (children : tree list) : (node * tree list) = | Node ("level", [IValue lvl]) :: rest -> {location = None; level = Some lvl}, rest | rest -> {location = None; level = None}, rest -type numeral_node = { +type 'a literal = { node : node; - value : int; + value : 'a } [@@deriving show] -let xml_to_numeral_node (xml : tree) = +let xml_to_numeral_node (xml : tree) : int literal = match xml with | Node ("NumeralNode", children) -> ( match extract_inline_node children with @@ -194,10 +195,32 @@ let xml_to_numeral_node (xml : tree) = | _ -> ls_conversion_failure __FUNCTION__ children) | _ -> conversion_failure __FUNCTION__ xml +let xml_to_string_node (xml : tree) : string literal = + match xml with + | Node ("StringNode", children) -> ( + match extract_inline_node children with + | node, [Node ("StringValue", [SValue value])] -> {node; value} + | _ -> ls_conversion_failure __FUNCTION__ children) + | _ -> conversion_failure __FUNCTION__ xml + +type leibniz_param = { + ref : int; + is_leibniz : bool; +} +[@@deriving show] + +let xml_to_leibniz_param xml = + match xml with + | Node ("leibnizparam", Node ("FormalParamNodeRef", [Node ("UID", [IValue ref])]) :: is_leibniz_opt) -> { + ref; + is_leibniz = match is_leibniz_opt with | [Node ("leibniz", [])] -> true | _ -> false; + } + | _ -> conversion_failure __FUNCTION__ xml + type formal_param_node = { - node : node; + node : node; name : string; - arity : int; + arity : int; } [@@deriving show] @@ -231,14 +254,21 @@ type op_appl_node = { } [@@deriving show] +and let_in_node = { + node : node; + def_refs : int list; + body : expression; +} +[@@deriving show] + and expression = (*| AtNode of at_node*) (*| DecimalNode of decimal_node*) (*| LabelNode of label_node*) -(*| LetInNode of let_in_node*) - | NumeralNode of numeral_node + | LetInNode of let_in_node + | NumeralNode of int literal | OpApplNode of op_appl_node -(*| StringNode of string_node*) + | StringNode of string literal (*| SubstInNode of subst_in_node*) (*| TheoremDefRef of theorem_def_ref*) (*| AssumeDefRef of assume_def_ref*) @@ -258,6 +288,16 @@ and symbol = | Bound of bound_symbol [@@deriving show] +and user_defined_op_kind = { + node : node; + name : string; + arity : int; + body : expression; + params : leibniz_param list; + recursive : bool; +} +[@@deriving show] + let rec xml_to_symbols xml = match xml with | Node ("unbound", _) -> Unbound (xml_to_unbound_symbol xml) @@ -273,25 +313,44 @@ and xml_to_bound_symbol xml = } | _ -> conversion_failure __FUNCTION__ xml -and xml_to_expr_or_op_arg xml = - try Expression (xml_to_expression xml) -with Invalid_argument _ -> conversion_failure __FUNCTION__ xml +and xml_to_expr_or_op_arg (xml : tree) : expr_or_op_arg = + match xml with + | Node ("LambdaNode", _) -> conversion_failure __FUNCTION__ xml + | _ -> Expression (xml_to_expression xml) and xml_to_op_appl_node xml = match xml with - | Node ("OpApplNode", children) -> - let (node, children) = extract_inline_node children in { - node; - operator = children |> find_tag "operator" |> child_of |> get_ref; - operands = children |> find_tag "operands" |> children_of |> List.map xml_to_expr_or_op_arg; - bound_symbols = children |> List.find_opt (is_tag "boundSymbols") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; - } + | Node ("OpApplNode", children) -> ( + match extract_inline_node children with + | node, Node ("operator", [ref_node]) :: + Node ("operands", operand_nodes) :: + bound_symbols -> { + node; + operator = get_ref ref_node; + operands = List.map xml_to_expr_or_op_arg operand_nodes; + bound_symbols = List.nth_opt bound_symbols 0 |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; + } + | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml -and xml_to_expression xml = +and xml_to_let_in_node (xml : tree) : let_in_node = + match xml with + | Node ("LetInNode", children) -> ( + match extract_inline_node children with + | node, [Node ("body", [body]); Node ("opDefs", op_defs)]-> { + node; + body = xml_to_expression body; + def_refs = List.map get_ref op_defs; + } + | _ -> conversion_failure __FUNCTION__ xml) + | _ -> conversion_failure __FUNCTION__ xml + +and xml_to_expression (xml : tree) : expression = match xml with | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) + | Node ("StringNode", _) -> StringNode (xml_to_string_node xml) | Node ("OpApplNode", _) -> OpApplNode (xml_to_op_appl_node xml) + | Node ("LetInNode", _) -> LetInNode (xml_to_let_in_node xml) | _ -> conversion_failure __FUNCTION__ xml and xml_to_inline_expression children = @@ -299,6 +358,19 @@ and xml_to_inline_expression children = |> List.find_opt (fun xml -> is_tag "NumeralNode" xml || is_tag "OpApplNode" xml) |> Option.map xml_to_expression +and xml_to_user_defined_op_kind xml : user_defined_op_kind = + match xml with + | Node ("UserDefinedOpKind", children) -> + let (node, children) = extract_inline_node children in { + node; + name = children |> xml_to_tagged_string "uniquename"; + arity = children |> xml_to_tagged_int "arity"; + body = children |> find_tag "body" |> child_of |> xml_to_expression; + params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; + recursive = children |> List.exists (is_tag "recursive"); + } + | _ -> conversion_failure __FUNCTION__ xml + type module_node = { node : node; name : string; @@ -354,43 +426,6 @@ let xml_to_op_decl_node (xml : tree) : op_decl_node = } | _ -> conversion_failure __FUNCTION__ xml -type leibniz_param = { - ref : int; - is_leibniz : bool; -} -[@@deriving show] - -let xml_to_leibniz_param xml = - match xml with - | Node ("leibnizparam", Node ("FormalParamNodeRef", [Node ("UID", [IValue ref])]) :: is_leibniz_opt) -> { - ref; - is_leibniz = match is_leibniz_opt with | [Node ("leibniz", [])] -> true | _ -> false; - } - | _ -> conversion_failure __FUNCTION__ xml - -type user_defined_op_kind = { - node : node; - name : string; - arity : int; - body : expression; - params : leibniz_param list; - recursive : bool; -} -[@@deriving show] - -let xml_to_user_defined_op_kind xml : user_defined_op_kind = - match xml with - | Node ("UserDefinedOpKind", children) -> - let (node, children) = extract_inline_node children in { - node; - name = children |> xml_to_tagged_string "uniquename"; - arity = children |> xml_to_tagged_int "arity"; - body = children |> find_tag "body" |> child_of |> xml_to_expression; - params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; - recursive = children |> List.exists (is_tag "recursive"); - } - | _ -> conversion_failure __FUNCTION__ xml - type built_in_kind = { node : node; name : string; diff --git a/src/tlapm_args.ml b/src/tlapm_args.ml index 374db660..afcf5f65 100644 --- a/src/tlapm_args.ml +++ b/src/tlapm_args.ml @@ -206,7 +206,7 @@ let init ?(out=Format.std_formatter) ?(err=Format.err_formatter) ?(terminate=exi prefer built-in standard modules if the module search path \ contains files with the same names as modules in stdlib."; "--parser", Arg.String set_parser_backend, " \ - Set parser backend to use: SANY or TLAPM."; + Set parser backend to use: TLAPM (default) or SANY."; "--noproving", Arg.Set noproving, " do not prove, report fingerprinted results only"; blank; diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 21928c2d..8f1fed1f 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -1,9 +1,26 @@ open Tlapm_lib;; open Tlapm_lib__Params;; +let find_tla_files dir = + let cmd = Printf.sprintf "find %s -name '*.tla'" (Filename.quote dir) in + let ic = Unix.open_process_in cmd in + let rec loop acc = + match input_line ic with + | line -> loop (line :: acc) + | exception End_of_file -> + ignore (Unix.close_process_in ic); + List.rev acc + in + loop [] + +let parse_tla_file filename = + print_endline ("Parsing " ^ filename ^ " ..."); + match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with + | Error (_, msg) -> Printf.eprintf "%s\n" msg; failwith "Parsing failed" + | Ok _ -> print_endline (filename ^ " success") + let _ = parser_backend := Sany; add_debug_flag "sany"; - match modctx_of_string ~content:"" ~filename:"AddTwo.tla" ~loader_paths:[] ~prefer_stdlib:true with - | Error (_, msg) -> print_endline msg - | Ok _ -> print_endline "success" + let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" in + List.map parse_tla_file tla_files From a178534fce7e707e9a116b1a67d18cc3b74c19e3 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 26 Jan 2026 17:22:16 -0800 Subject: [PATCH 37/85] Fix theorem node translation Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 23 ++++-- src/sany/xml.ml | 188 ++++++++++++++++++++++++----------------------- 2 files changed, 111 insertions(+), 100 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index e5643005..bd59b575 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -247,7 +247,8 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | Variable -> attach_props xml.node (Variables [attach_props xml.node xml.name]) + | 3 -> attach_props xml.node (Variables [attach_props xml.node xml.name]) + | _ -> todo "Operator declaration" (string_of_int xml.kind) xml.node.location (** Converts action-level expressions such as [][expr]_sub and <><>_sub. *) @@ -477,7 +478,13 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Expr.T.expr = match op_expr with | Expression expr -> convert_expression expr - (* TODO: add support for operators here *) + | OpArg uid -> match (resolve_ref uid).kind with + | FormalParamNode param -> Opaque param.name |> attach_props param.node + | UserDefinedOpKind userdef -> Opaque userdef.name |> attach_props userdef.node + | BuiltInKind builtin -> (match try_convert_builtin builtin with + | Some b -> Internal b |> attach_props builtin.node + | None -> todo "Built-in operator argument" builtin.name builtin.node.location) + | _ -> failwith ("Invalid operator argument reference: " ^ string_of_int uid) (** Converts a basic expression type, which will be either a primitive value or an operator application. @@ -488,6 +495,7 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | StringNode s -> String s.value |> attach_props s.node | OpApplNode apply -> convert_op_appl_node apply | LetInNode let_in -> convert_let_in_node let_in + | AtNode at_node -> todo "AtNode" "@" at_node.node.location and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = let definitions = List.map (fun ref -> @@ -558,12 +566,13 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. *) -and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group) : Proof.T.proof = +and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group option) : Proof.T.proof = match proof with - | Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Steps proof -> convert_proof_steps uid previous_proof_level proof + | None -> Omitted Implicit |> noprops |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Some By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Some Steps proof -> convert_proof_steps uid previous_proof_level proof (** One possible proof form is a series of steps, culminating in a QED step. This method converts that structure. This is the most complex part of the diff --git a/src/sany/xml.ml b/src/sany/xml.ml index f171b0f5..69f6cad9 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -261,8 +261,13 @@ and let_in_node = { } [@@deriving show] +and at_node = { + node : node; +} +[@@deriving show] + and expression = -(*| AtNode of at_node*) + | AtNode of at_node (*| DecimalNode of decimal_node*) (*| LabelNode of label_node*) | LetInNode of let_in_node @@ -275,7 +280,7 @@ and expression = and expr_or_op_arg = | Expression of expression -(*| OpArg of operator_arg*) + | OpArg of int and bound_symbol = { symbol_refs : int list; @@ -315,7 +320,15 @@ and xml_to_bound_symbol xml = and xml_to_expr_or_op_arg (xml : tree) : expr_or_op_arg = match xml with - | Node ("LambdaNode", _) -> conversion_failure __FUNCTION__ xml + | Node ("OpArgNode", children) -> ( + match extract_inline_node children with + | node, [Node ("argument", [argument])] -> ( + match get_ref_opt argument with + | Some uid -> OpArg uid + | None -> conversion_failure __FUNCTION__ argument + ) + | _ -> conversion_failure __FUNCTION__ xml + ) | _ -> Expression (xml_to_expression xml) and xml_to_op_appl_node xml = @@ -333,24 +346,26 @@ and xml_to_op_appl_node xml = | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml -and xml_to_let_in_node (xml : tree) : let_in_node = - match xml with - | Node ("LetInNode", children) -> ( - match extract_inline_node children with - | node, [Node ("body", [body]); Node ("opDefs", op_defs)]-> { - node; - body = xml_to_expression body; - def_refs = List.map get_ref op_defs; - } - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml +and xml_to_let_in_node (children : tree list) : let_in_node = + match extract_inline_node children with + | node, [Node ("body", [body]); Node ("opDefs", op_defs)]-> { + node; + body = xml_to_expression body; + def_refs = List.map get_ref op_defs; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +and xml_to_at_node (children : tree list) : at_node = + match extract_inline_node children with + | node, _ -> {node} and xml_to_expression (xml : tree) : expression = match xml with | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) | Node ("StringNode", _) -> StringNode (xml_to_string_node xml) | Node ("OpApplNode", _) -> OpApplNode (xml_to_op_appl_node xml) - | Node ("LetInNode", _) -> LetInNode (xml_to_let_in_node xml) + | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) + | Node ("AtNode", children) -> AtNode (xml_to_at_node children) | _ -> conversion_failure __FUNCTION__ xml and xml_to_inline_expression children = @@ -378,40 +393,28 @@ type module_node = { } [@@deriving show] -let xml_to_module_node xml = +let xml_to_module_node (children : tree list) : module_node = let ref_child child = match get_ref_opt child with | Some uid -> `Ref uid | None -> match child with | Node ("InstanceNode", children) -> `OtherTODO "InstanceNode" | Node ("UseOrHideNode", children) -> `OtherTODO "UseOrHideNode" + | Node ("AssumeNodeRef", children) -> `OtherTODO "AssumeNodeRef" | _ -> conversion_failure __FUNCTION__ child - in match xml with - | Node ("ModuleNode", children) -> - let (node, children) = extract_inline_node children in ( - match children with - | Node ("uniquename", [SValue name]) :: units -> { - node; - name; - units = List.map ref_child units - } - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml + in match extract_inline_node children with + | node, Node ("uniquename", [SValue name]) :: units -> { + node; + name; + units = List.map ref_child units + } + | _ -> ls_conversion_failure __FUNCTION__ children -type declaration_kind = - | Variable -[@@deriving show] - -let int_to_declaration_kind (n : int) : declaration_kind = - match n with - | 3 -> Variable - | _ -> Invalid_argument (Printf.sprintf "Invalid declaration kind value: %d" n) |> raise - type op_decl_node = { node : node; name : string; arity : int; - kind : declaration_kind; + kind : int; } [@@deriving show] @@ -422,7 +425,7 @@ let xml_to_op_decl_node (xml : tree) : op_decl_node = node; name = children |> xml_to_tagged_string "uniquename"; arity = children |> xml_to_tagged_int "arity"; - kind = children |> xml_to_tagged_int "kind" |> int_to_declaration_kind; + kind = children |> xml_to_tagged_int "kind"; } | _ -> conversion_failure __FUNCTION__ xml @@ -450,10 +453,11 @@ type expr_or_assume_prove = (*| AssumeProveLike of assume_prove_like*) [@@deriving show] -let xml_to_inline_expr_or_assume_prove children = - match xml_to_inline_expression children with - | Option.Some expr -> Option.Some (Expression expr) - | Option.None -> (*TODO: try-match assume-prove*) Option.None +let xml_to_inline_expr_or_assume_prove (children : tree list) : expr_or_assume_prove = + match children with + | Node ("AssumeProveLike", _) :: _ -> ls_conversion_failure __FUNCTION__ children + | expr :: _ -> Expression (xml_to_expression expr) + | _ -> ls_conversion_failure __FUNCTION__ children type theorem_def_node = { node : node; @@ -469,7 +473,7 @@ let xml_to_theorem_def_node xml = | node, Node ("uniquename", [SValue name]) :: body -> { node; name; - body = body |> xml_to_inline_expr_or_assume_prove |> Option.get; + body = xml_to_inline_expr_or_assume_prove body } | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml @@ -481,17 +485,14 @@ type by_proof_node = { } [@@deriving show] -let xml_to_by_proof_node xml = - match xml with - | Node ("by", children) -> ( - match extract_inline_node children with - | node, [Node ("facts", facts); Node ("defs", defs)] -> { - node; - facts = List.map xml_to_expression facts; - defs = List.filter_map get_ref_opt defs; - } - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_by_proof_node (children : tree list) : by_proof_node = + match extract_inline_node children with + | node, [Node ("facts", facts); Node ("defs", defs)] -> { + node; + facts = List.map xml_to_expression facts; + defs = List.filter_map get_ref_opt defs; + } + | _ -> ls_conversion_failure __FUNCTION__ children type proof_step_group = | TheoremNodeRef of int @@ -503,25 +504,22 @@ type proof_step_group = *) [@@deriving show] -let xml_to_proof_step_group xml = - match xml with - | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> TheoremNodeRef uid - | _ -> conversion_failure __FUNCTION__ xml - type steps_proof_node = { node : node; steps : proof_step_group list; } [@@deriving show] -let xml_to_steps_proof_node xml = - match xml with - | Node ("steps", children) -> - let (node, steps) = extract_inline_node children in { - node; - steps = List.map xml_to_proof_step_group steps - } - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_steps_proof_node (children : tree list) : steps_proof_node = + let xml_to_proof_step_group xml = + match xml with + | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> TheoremNodeRef uid + | _ -> conversion_failure __FUNCTION__ xml + in match extract_inline_node children with + | node, steps ->{ + node; + steps = List.map xml_to_proof_step_group steps + } type proof_node_group = | Omitted of node @@ -530,38 +528,41 @@ type proof_node_group = | Steps of steps_proof_node [@@deriving show] -let xml_to_inline_proof_node_group children = - let rec search_children ls = - match ls with - | x::xs -> ( - match x with - | Node ("omitted", children) -> let (node, _) = extract_inline_node children in Omitted node - | Node ("obvious", children) -> let (node, _) = extract_inline_node children in Obvious node - | Node ("by", _) -> By (xml_to_by_proof_node x) - | Node ("steps", _) -> Steps (xml_to_steps_proof_node x) - | _ -> search_children xs - ) - | _ -> conversion_failure __FUNCTION__ (List.hd children) - in search_children children +let xml_to_inline_proof_node_group (children : tree list) : proof_node_group option = + match children with + | Node ("omitted", children) :: _ -> let (node, _) = extract_inline_node children in Some (Omitted node) + | Node ("obvious", children) :: _ -> let (node, _) = extract_inline_node children in Some (Obvious node) + | Node ("by", children) :: _ -> Some (By (xml_to_by_proof_node children)) + | Node ("steps", children) :: _ -> Some (Steps (xml_to_steps_proof_node children)) + | [] -> None + | _ -> ls_conversion_failure __FUNCTION__ children type theorem_node = { node : node; definition : int option; body : expr_or_assume_prove; - proof : proof_node_group; + proof : proof_node_group option; } [@@deriving show] -let xml_to_theorem_node xml = - match xml with - | Node ("TheoremNode", children) -> - let (node, children) = extract_inline_node children in { +let xml_to_theorem_node (children : tree list) : theorem_node = + + match extract_inline_node children with + | node, + Node ("definition", [Node ("TheoremDefRef", [Node ("UID", [IValue uid])])]) :: + Node ("body", body) :: proof -> { node; - definition = children |> List.find_opt (is_tag "definition") |> Option.map child_of |> Option.map get_ref; - body = children |> find_tag "body" |> children_of |> xml_to_inline_expr_or_assume_prove |> Option.get; - proof = children |> xml_to_inline_proof_node_group; + definition = Some uid; + body = xml_to_inline_expr_or_assume_prove body; + proof = xml_to_inline_proof_node_group proof; } - | _ -> conversion_failure __FUNCTION__ xml + | node, Node ("body", body) :: proof -> { + node; + definition = None; + body = xml_to_inline_expr_or_assume_prove body; + proof = xml_to_inline_proof_node_group proof; + } + | _ -> ls_conversion_failure __FUNCTION__ children type entry_kind = | ModuleNode of module_node @@ -575,13 +576,14 @@ type entry_kind = let xml_to_entry_kind (xml : tree) : entry_kind = match xml with - | Node ("ModuleNode", _) -> ModuleNode (xml_to_module_node xml) + | Node ("AssumeNode", children) -> ModuleNode (xml_to_assume_node children) + | Node ("ModuleNode", children) -> ModuleNode (xml_to_module_node children) | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node xml) | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind xml) | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node xml) | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node xml) - | Node ("TheoremNode", _) -> TheoremNode (xml_to_theorem_node xml) + | Node ("TheoremNode", children)-> TheoremNode (xml_to_theorem_node children) | _ -> conversion_failure __FUNCTION__ xml type entry = { @@ -590,7 +592,7 @@ type entry = { } [@@deriving show] -let xml_to_entry xml = +let xml_to_entry (xml : tree) : entry = match xml with | Node ("entry", [Node ("UID", [IValue uid]); entry]) -> { uid; @@ -615,7 +617,7 @@ let xml_to_modules (xml : tree) : modules = context = List.map xml_to_entry entries; modules = modules |> List.filter_map (fun entry -> match entry with - | Node ("ModuleNode", _) -> Some (xml_to_module_node entry) + | Node ("ModuleNode", children) -> Some (xml_to_module_node children) | _ -> None ); module_refs = List.filter_map (fun entry -> From 1a19ad364716051af527eeaa47349ff2a7b87a31 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 27 Jan 2026 16:14:25 -0800 Subject: [PATCH 38/85] Parse instance units Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 35 ++++++++--- src/sany/xml.ml | 133 +++++++++++++++++++++++++++++++++------- test/sany/sany_tests.ml | 8 ++- 3 files changed, 146 insertions(+), 30 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index bd59b575..c1f75358 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -170,6 +170,13 @@ let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = | TheoremDefNode xml -> xml | _ -> failwith ("Expected theorem definition node for UID: " ^ string_of_int uid) +(** A typed version of resolve_ref for assume definition nodes. +*) +let resolve_assume_def_node (uid : int) : Xml.assume_def_node = + match (resolve_ref uid).kind with + | AssumeDefNode xml -> xml + | _ -> failwith ("Expected assume definition node for UID: " ^ string_of_int uid) + (** A typed version of resolve_ref for theorem nodes. *) let resolve_theorem_node (uid : int) : Xml.theorem_node = @@ -211,35 +218,49 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = (** Converts a top-level module node. *) let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = - let inline_unit unit = - match unit with - | `Ref uid -> resolve_ref uid - | `OtherTODO name -> todo "Module unit" (name ^ " unit not yet supported") None (** Converts an entry, which is an abstract type that can be all sorts of things; SANY heavily uses GUIDs to reference one entity from another and those GUIDs are resolved in a global table with no real type information. Thus in-scope operator parameters coexist alongside entire modules, and here we branch out to the appropriate conversion method. *) - in let convert_entry (entry : Xml.entry) : Module.T.modunit = + let convert_entry (unit : Xml.unit_kind) : Module.T.modunit = + match unit with + | Instance instance -> convert_instance instance + | UseOrHide use_or_hide -> convert_use_or_hide use_or_hide + | Ref uid -> let entry = resolve_ref uid in match entry.kind with | ModuleNode submod -> Submod (convert_module_node submod) |> attach_props submod.node + | AssumeNode assume -> convert_assume_node assume | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind - | TheoremDefNode theorem_def_node -> convert_theorem_def_node theorem_def_node | TheoremNode theorem_node -> convert_theorem_node entry.uid 0 theorem_node | BuiltInKind _ -> failwith "BuiltInKind not expected at module top-level" | FormalParamNode _ -> failwith "FormalParamNode not expected at module top-level" + | AssumeDefNode assume -> failwith "AssumeDefNode should not be converted directly" + | TheoremDefNode theorem_def_node -> failwith "TheoremDefNode should not be converted directly" in { name = noprops mule.name; extendees = []; (* TODO: figure out how to get list of modules imported by this module *) instancees = []; - body = mule.units |> List.map inline_unit |> List.map convert_entry; + body = List.map convert_entry mule.units; defdepth = 0; stage = Parsed; important = false } |> attach_props mule.node +and convert_instance (instance : Xml.instance_node) : Module.T.modunit = + todo "Instance" "" instance.node.location + +and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = + todo "UseOrHide" "" use_or_hide.node.location + +and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = + Module.T.Axiom ( + Option.map (fun uid -> let def = resolve_assume_def_node uid in attach_props def.node def.name) assume.definition, + convert_expression assume.body + ) |> attach_props assume.node + (** Converts operator declarations such as CONSTANTS and VARIABLES. In a declaration like VARIABLES x, y, z, each of x, y, and z are given as separate OpDeclNode entries. In contrast, TLAPM wraps all of these in a diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 69f6cad9..55870c13 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -123,6 +123,7 @@ let xml_to_tagged_int (tag_name : string) (children : tree list) : int = *) let get_ref_opt (xml : tree) : int option = match xml with + | Node ("AssumeNodeRef", [Node ("UID", [IValue uid])]) -> Some uid | Node ("AssumeDefRef", [Node ("UID", [IValue uid])]) -> Some uid | Node ("BuiltInKindRef", [Node ("UID", [IValue uid])]) -> Some uid | Node ("FormalParamNodeRef", [Node ("UID", [IValue uid])]) -> Some uid @@ -181,6 +182,18 @@ let extract_inline_node (children : tree list) : (node * tree list) = | Node ("level", [IValue lvl]) :: rest -> {location = None; level = Some lvl}, rest | rest -> {location = None; level = None}, rest + +(** A few XML nodes have an inline definition reference as their first child + after the location and level tags. This function is meant to be chained + after extract_inline_node to extract that definition reference if it + exists. +*) +let extract_inline_definition_opt (node, children : node * tree list) : (node * int option * tree list) = + match children with + | Node ("definition", [Node ("AssumeDefRef", [Node ("UID", [IValue uid])])]) :: children -> (node, Some uid, children); + | Node ("definition", [Node ("TheoremDefRef", [Node ("UID", [IValue uid])])]) :: children -> (node, Some uid, children); + | _ -> (node, None, children) + type 'a literal = { node : node; value : 'a @@ -385,22 +398,74 @@ and xml_to_user_defined_op_kind xml : user_defined_op_kind = recursive = children |> List.exists (is_tag "recursive"); } | _ -> conversion_failure __FUNCTION__ xml + +type substitution = { + target_uid : int; + substitute : expr_or_op_arg; +} +[@@deriving show] + +let xml_to_substitution (xml : tree) : substitution = + match xml with + | Node ("Subst", [Node ("OpDeclNodeRef", [Node ("UID", [IValue target_uid])]); substitute]) -> { + target_uid; + substitute = xml_to_expr_or_op_arg substitute; + } + | _ -> conversion_failure __FUNCTION__ xml + +type instance_node = { + node : node; + name : string option; + module_name : string; + substitutions : substitution list; + parameters : int list; +} +[@@deriving show] + +let xml_to_instance_node (children : tree list) : instance_node = + let extract_inline_name_opt (node, children : node * tree list) : (node * string option * tree list) = + match children with + | Node ("uniquename", [SValue name]) :: children -> (node, Some name, children) + | _ -> (node, None, children) + in match children |> extract_inline_node |> extract_inline_name_opt with + | node, name, [Node ("module", [SValue module_name]); Node ("substs", substitutions); Node ("params", params)] -> { + node; + name; + module_name; + substitutions = List.map xml_to_substitution substitutions; + parameters = List.map get_ref params; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +type use_or_hide_node = { + node : node; +} +[@@deriving show] + +let xml_to_use_or_hide_node (children : tree list) : use_or_hide_node = + match extract_inline_node children with + | node, _ -> {node} + +type unit_kind = +| Ref of int +| Instance of instance_node +| UseOrHide of use_or_hide_node +[@@deriving show] type module_node = { node : node; name : string; - units : [`Ref of int | `OtherTODO of string] list; + units : unit_kind list; } [@@deriving show] let xml_to_module_node (children : tree list) : module_node = let ref_child child = match get_ref_opt child with - | Some uid -> `Ref uid + | Some uid -> Ref uid | None -> match child with - | Node ("InstanceNode", children) -> `OtherTODO "InstanceNode" - | Node ("UseOrHideNode", children) -> `OtherTODO "UseOrHideNode" - | Node ("AssumeNodeRef", children) -> `OtherTODO "AssumeNodeRef" + | Node ("InstanceNode", children) -> Instance (xml_to_instance_node children) + | Node ("UseOrHideNode", children) -> UseOrHide (xml_to_use_or_hide_node children) | _ -> conversion_failure __FUNCTION__ child in match extract_inline_node children with | node, Node ("uniquename", [SValue name]) :: units -> { @@ -448,12 +513,44 @@ let xml_to_built_in_kind xml : built_in_kind = } | _ -> conversion_failure __FUNCTION__ xml +type assume_def_node = { + node : node; + name : string; + body : expression; +} +[@@deriving show] + +let xml_to_assume_def_node (children : tree list) : assume_def_node = + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("body", [body])] -> { + node; + name; + body = xml_to_expression body; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +type assume_node = { + node : node; + definition : int option; + body : expression; +} +[@@deriving show] + +let xml_to_assume_node (children : tree list) : assume_node = + match children |> extract_inline_node |> extract_inline_definition_opt with + | node, definition, [Node ("body", [body])] -> { + node; + definition; + body = xml_to_expression body; + } + | _ -> ls_conversion_failure __FUNCTION__ children + type expr_or_assume_prove = | Expression of expression (*| AssumeProveLike of assume_prove_like*) [@@deriving show] -let xml_to_inline_expr_or_assume_prove (children : tree list) : expr_or_assume_prove = +let xml_to_expr_or_assume_prove (children : tree list) : expr_or_assume_prove = match children with | Node ("AssumeProveLike", _) :: _ -> ls_conversion_failure __FUNCTION__ children | expr :: _ -> Expression (xml_to_expression expr) @@ -473,7 +570,7 @@ let xml_to_theorem_def_node xml = | node, Node ("uniquename", [SValue name]) :: body -> { node; name; - body = xml_to_inline_expr_or_assume_prove body + body = xml_to_expr_or_assume_prove body } | _ -> conversion_failure __FUNCTION__ xml) | _ -> conversion_failure __FUNCTION__ xml @@ -546,26 +643,19 @@ type theorem_node = { [@@deriving show] let xml_to_theorem_node (children : tree list) : theorem_node = - - match extract_inline_node children with - | node, - Node ("definition", [Node ("TheoremDefRef", [Node ("UID", [IValue uid])])]) :: - Node ("body", body) :: proof -> { + match children |> extract_inline_node |> extract_inline_definition_opt with + | node, definition, Node ("body", body) :: proof -> { node; - definition = Some uid; - body = xml_to_inline_expr_or_assume_prove body; + definition; + body = xml_to_expr_or_assume_prove body; proof = xml_to_inline_proof_node_group proof; } - | node, Node ("body", body) :: proof -> { - node; - definition = None; - body = xml_to_inline_expr_or_assume_prove body; - proof = xml_to_inline_proof_node_group proof; - } | _ -> ls_conversion_failure __FUNCTION__ children type entry_kind = | ModuleNode of module_node + | AssumeNode of assume_node + | AssumeDefNode of assume_def_node | OpDeclNode of op_decl_node | UserDefinedOpKind of user_defined_op_kind | BuiltInKind of built_in_kind @@ -576,8 +666,9 @@ type entry_kind = let xml_to_entry_kind (xml : tree) : entry_kind = match xml with - | Node ("AssumeNode", children) -> ModuleNode (xml_to_assume_node children) | Node ("ModuleNode", children) -> ModuleNode (xml_to_module_node children) + | Node ("AssumeNode", children) -> AssumeNode (xml_to_assume_node children) + | Node ("AssumeDefNode", children) -> AssumeDefNode (xml_to_assume_def_node children) | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node xml) | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind xml) | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 8f1fed1f..dbb96372 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -13,11 +13,15 @@ let find_tla_files dir = in loop [] -let parse_tla_file filename = +let parse_tla_file filename = + let open Stdlib in print_endline ("Parsing " ^ filename ^ " ..."); - match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with + try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with | Error (_, msg) -> Printf.eprintf "%s\n" msg; failwith "Parsing failed" | Ok _ -> print_endline (filename ^ " success") + with Failure (e : string) -> + Printf.eprintf "%s\n" e; + failwith "Parsing failed" let _ = parser_backend := Sany; From 7a50609d0f12bdba994e7f0d7260aaf6e4e2a2f7 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 28 Jan 2026 15:03:05 -0800 Subject: [PATCH 39/85] Translate recursive functions Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 129 +++++++++++++++++++++++++++++------------------ src/sany/xml.ml | 37 ++++++++------ 2 files changed, 101 insertions(+), 65 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c1f75358..d2df4e0e 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -51,6 +51,12 @@ let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = | None -> "Unknown location" in failwith (Printf.sprintf "%s not yet implemented: %s\n%s" category msg loc) +let conversion_failure (msg : string) (loc : Xml.location option) : 'a = + let loc = match loc with + | Some loc -> Xml.show_location loc + | None -> "Unknown location" + in failwith (Printf.sprintf "Conversion failure:\n%s\n%s" msg loc) + (** A module-global table of SANY AST entities, indexed by UID. *) let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty @@ -107,19 +113,19 @@ let parse_proof_step_name (proof_level : proof_level) (uid : int) (proof_name : | 10, 'a' .. 'z' | 10, 'A' .. 'Z' | 10, '0' .. '9' | 10, '_' -> (10, level, c :: name) (* Terminating '.' state; consume & ignore *) | 10, '.' | 11, '.' -> (11, level, name) - | _ -> failwith (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) + | _ -> conversion_failure (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) None in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name in let digits_to_int (digits : char list) : int = List.fold_right (fun (d : char) (acc : int) : int -> (int_of_char d - int_of_char '0') + acc * 10) digits 0 in let level = match level, proof_level with | ['+'], Previous n -> n + 1 - | ['+'], Known _ -> failwith "Cannot have explicit proof level followed by <+>" + | ['+'], Known _ -> conversion_failure "Cannot have explicit proof level followed by <+>" None | ['*'], Previous n -> n + 1 | ['*'], Known n -> n | digits, Previous _ -> digits_to_int digits | digits, Known n -> let level = digits_to_int digits in - if level <> n then failwith ("Mismatched proof level: expected " ^ string_of_int n ^ " but got " ^ string_of_int level) + if level <> n then conversion_failure ("Mismatched proof level: expected " ^ string_of_int n ^ " but got " ^ string_of_int level) None else level in if name = [] then Unnamed (level, uid) else Named (level, name |> List.rev |> List.to_seq |> String.of_seq, false) @@ -142,14 +148,14 @@ let attach_props (props : Xml.node) (value : 'a) : 'a wrapped = let resolve_ref (uid : int) : Xml.entry = match Coll.Im.find_opt uid !entries with | Some kind -> {uid; kind} - | None -> failwith ("Unresolved reference to entry UID: " ^ string_of_int uid) + | None -> conversion_failure ("Unresolved reference to entry UID: " ^ string_of_int uid) None (** A typed version of resolve_ref for module nodes. *) let resolve_module_node (uid : int) : Xml.module_node = match (resolve_ref uid).kind with | ModuleNode mule -> mule - | _ -> failwith ("Expected module node for UID: " ^ string_of_int uid) + | _ -> conversion_failure ("Expected module node for UID: " ^ string_of_int uid) None (** A typed version of resolve_ref for operator parameter nodes. *) @@ -161,36 +167,36 @@ let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = | 0 -> Shape_expr | n -> Shape_op n ) - | _ -> failwith ("Expected formal parameter node for UID: " ^ string_of_int param.ref) + | _ -> conversion_failure ("Expected formal parameter node for UID: " ^ string_of_int param.ref) None (** A typed version of resolve_ref for theorem definition nodes. *) let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = match (resolve_ref uid).kind with | TheoremDefNode xml -> xml - | _ -> failwith ("Expected theorem definition node for UID: " ^ string_of_int uid) + | _ -> conversion_failure ("Expected theorem definition node for UID: " ^ string_of_int uid) None (** A typed version of resolve_ref for assume definition nodes. *) let resolve_assume_def_node (uid : int) : Xml.assume_def_node = match (resolve_ref uid).kind with | AssumeDefNode xml -> xml - | _ -> failwith ("Expected assume definition node for UID: " ^ string_of_int uid) + | _ -> conversion_failure ("Expected assume definition node for UID: " ^ string_of_int uid) None (** A typed version of resolve_ref for theorem nodes. *) let resolve_theorem_node (uid : int) : Xml.theorem_node = match (resolve_ref uid).kind with | TheoremNode xml -> xml - | _ -> failwith ("Expected theorem node for UID: " ^ string_of_int uid) + | _ -> conversion_failure ("Expected theorem node for UID: " ^ string_of_int uid) None (** A typed version of resolve_ref for bound symbols. *) let resolve_bound_symbol (uid : int) : hint = match Coll.Im.find_opt uid !entries with | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.name - | Some (Xml.FormalParamNode _) -> failwith ("Bound symbol cannot be an operator: " ^ string_of_int uid) - | _ -> failwith ("Unresolved formal parameter node UID: " ^ string_of_int uid) + | Some (Xml.FormalParamNode _) -> conversion_failure ("Bound symbol cannot be an operator: " ^ string_of_int uid) None + | _ -> conversion_failure ("Unresolved formal parameter node UID: " ^ string_of_int uid) None let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def_ref : int option) : stepno = match theorem_def_ref with @@ -235,10 +241,10 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind | TheoremNode theorem_node -> convert_theorem_node entry.uid 0 theorem_node - | BuiltInKind _ -> failwith "BuiltInKind not expected at module top-level" - | FormalParamNode _ -> failwith "FormalParamNode not expected at module top-level" - | AssumeDefNode assume -> failwith "AssumeDefNode should not be converted directly" - | TheoremDefNode theorem_def_node -> failwith "TheoremDefNode should not be converted directly" + | BuiltInKind _ -> conversion_failure "BuiltInKind not expected at module top-level" None + | FormalParamNode _ -> conversion_failure "FormalParamNode not expected at module top-level" None + | AssumeDefNode assume -> conversion_failure "AssumeDefNode should not be converted directly" None + | TheoremDefNode theorem_def_node -> conversion_failure "TheoremDefNode should not be converted directly" None in { name = noprops mule.name; extendees = []; (* TODO: figure out how to get list of modules imported by this module *) @@ -280,7 +286,7 @@ and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr convert_expression_or_operator_argument expr, convert_expression_or_operator_argument sub ) |> attach_props apply.node - | _ -> failwith "Wrong number of operands to action expression" + | _ -> conversion_failure "Wrong number of operands to action expression" apply.node.location (** This method handles conversion of four cases: 1. Bounded non-tuple choice like CHOOSE x \in S : P @@ -320,15 +326,31 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( | Unbound {is_tuple = true} :: _, [body] -> let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in if List.length symbols <> List.length apply.bound_symbols - then failwith "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" + then conversion_failure "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" apply.node.location else ChooseTuply ( List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.symbol_ref) symbols, None, convert_expression_or_operator_argument body ) - | _ -> failwith "Invalid number of bounds or operands to CHOOSE" + | _ -> conversion_failure "Invalid number of bounds or operands to CHOOSE" apply.node.location ) |> attach_props apply.node +and convert_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : tuply_bounds = + if bound.is_tuple + then match List.map resolve_bound_symbol bound.symbol_refs with + | (_ :: _ as symbols) -> [(Bound_names symbols, Domain (convert_expression bound.expression))] + | [] -> conversion_failure "Tuple bound symbol groups must have at least one symbol" node.location + else match List.map resolve_bound_symbol bound.symbol_refs with + | hd :: tl -> (Bound_name hd, Domain (convert_expression bound.expression)) + :: List.map (fun s -> (Bound_name s, Ditto)) tl + | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location + +and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : bounds = + match List.map resolve_bound_symbol bound.symbol_refs with + | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) + :: List.map (fun s -> (s, Unknown, Ditto)) tl + | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location + (** Handles conversion of both bounded & unbounded quantification. Both sides of the conversion here are fairly weird. The SANY AST has the same issues as in the CHOOSE conversion where many invalid states are representable @@ -356,15 +378,15 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( *) and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | _ :: _, [body] -> + | _ :: _, [Expression body] -> let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) apply.bound_symbols in if unbound_symbols <> [] then if bound_symbols <> [] - then failwith "Cannot mix bound and unbound symbols in quantification" + then conversion_failure "Cannot mix bound and unbound symbols in quantification" apply.node.location else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols - then failwith "Unbounded tuple quantification is not supported" + then conversion_failure "Unbounded tuple quantification is not supported" apply.node.location (* Unbounded quantification *) else let mk_bound (bound : Xml.unbound_symbol) : bound = ( resolve_bound_symbol bound.symbol_ref, @@ -373,36 +395,42 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node ) in Quant ( quant, List.map mk_bound unbound_symbols, - convert_expression_or_operator_argument body + convert_expression body ) else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols (* Bounded quantification that includes at least one tuple *) - then let mk_bounds (bound : Xml.bound_symbol) : tuply_bounds = - if bound.is_tuple - then match List.map resolve_bound_symbol bound.symbol_refs with - | (_ :: _ as symbols) -> [(Bound_names symbols, Domain (convert_expression bound.expression))] - | [] -> failwith "Tuple bound symbol groups must have at least one symbol" - else match List.map resolve_bound_symbol bound.symbol_refs with - | hd :: tl -> (Bound_name hd, Domain (convert_expression bound.expression)) - :: List.map (fun s -> (Bound_name s, Ditto)) tl - | [] -> failwith "Bound symbol groups must have at least one symbol" - in QuantTuply ( + then QuantTuply ( quant, - List.map mk_bounds bound_symbols |> List.flatten, - convert_expression_or_operator_argument body + List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, + convert_expression body ) (* Bounded quantification without any tuples *) - else let mk_bounds (bound : Xml.bound_symbol) : bounds = - match List.map resolve_bound_symbol bound.symbol_refs with - | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) - :: List.map (fun s -> (s, Unknown, Ditto)) tl - | [] -> failwith "Bound symbol groups must have at least one symbol" - in Quant ( + else Quant ( quant, - List.map mk_bounds bound_symbols |> List.flatten, - convert_expression_or_operator_argument body + List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, + convert_expression body ) - | _ -> failwith "Invalid number of bounds or operands to quantification" + | _ -> conversion_failure "Invalid number of bounds or operands to quantification" apply.node.location +) |> attach_props apply.node + +(** Conversion of recursive functions where the function body refers to the + function definition, for example f[x \in Nat] == f[x - 1]. Both SANY and + TLAPM represent these as f == [x \in Nat |-> f[x - 1]], and here we + convert the right-hand side of this definition. The function name is + introduced as the first symbol, unbound. +*) +and convert_recursive_function (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) all_bound_symbols in + if List.length bound_symbols <> List.length all_bound_symbols + then conversion_failure "Function definitions cannot have unbound symbols" apply.node.location + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + (* Function definition bounds that include at least one tuple *) + then FcnTuply (List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) + (* Function definition bounds without any tuples *) + else Fcn (List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) + | _ -> conversion_failure "Invalid number of bounds or operands to function definition" apply.node.location ) |> attach_props apply.node (** Conversion of application of all traditional built-in operators like = or @@ -432,6 +460,7 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) | "$BoundedForall" -> convert_quantification Forall apply op | "$UnboundedExists" -> convert_quantification Exists apply op | "$UnboundedForall" -> convert_quantification Forall apply op + | "$RecursiveFcnSpec" -> convert_recursive_function apply op | s -> todo "Built-in operator" s apply.node.location ) @@ -488,7 +517,7 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl (* A reference to a named THEOREM or a proof step *) | TheoremDefNode thm -> Opaque thm.name |> attach_props thm.node - | _ -> failwith ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind) ) + | _ -> conversion_failure ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind)) apply.node.location (** Some places in TLA⁺ syntax allow both normal expressions and also operators. Mainly this occurs when applying an operator that could accept @@ -505,7 +534,7 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp | BuiltInKind builtin -> (match try_convert_builtin builtin with | Some b -> Internal b |> attach_props builtin.node | None -> todo "Built-in operator argument" builtin.name builtin.node.location) - | _ -> failwith ("Invalid operator argument reference: " ^ string_of_int uid) + | _ -> conversion_failure ("Invalid operator argument reference: " ^ string_of_int uid) None (** Converts a basic expression type, which will be either a primitive value or an operator application. @@ -541,7 +570,7 @@ and convert_user_defined_op_kind (xml : Xml.user_defined_op_kind) : Expr.T.defn *) and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = match xml.recursive with - | true -> failwith "TLAPS does not yet support recursive operators" + | true -> conversion_failure "TLAPS does not yet support recursive operators" xml.node.location | false -> (Definition ( convert_user_defined_op_kind xml, User, @@ -611,7 +640,7 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = match List.rev steps with - | [] -> failwith "Step-based proofs must have at least one step" + | [] -> conversion_failure "Step-based proofs must have at least one step" node.location | last :: rest -> (List.rev rest, last) in let convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (step : Xml.proof_step_group) : Proof.T.step list * proof_level = match step with @@ -633,7 +662,7 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps in let qed_step, proof_level = convert_qed_step proof_level qed in let proof_level = match proof_level with - | Previous _ -> failwith "Current proof level should be known after processing all steps" + | Previous _ -> conversion_failure "Current proof level should be known after processing all steps" node.location | Known n -> n in Steps (List.rev steps, qed_step) |> attach_props node @@ -648,7 +677,7 @@ and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = match (resolve_ref ref).kind with | UserDefinedOpKind op -> Dvar op.name |> attach_props op.node | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node - | other -> failwith ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) + | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location in By ({ facts = List.map convert_expression facts; defs = List.map resolve_def defs; @@ -666,7 +695,7 @@ and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = root. *) let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - if ast.modules <> [] then failwith "SANY AST cannot have multiple top-level modules"; + if ast.modules <> [] then conversion_failure "SANY AST cannot have multiple top-level modules" None; entries := List.fold_left (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 55870c13..6a2121cc 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -151,6 +151,12 @@ type location = { } [@@deriving show] +let show_location (loc : location) : string = + Printf.sprintf "Location: %s module, line %d column %d to line %d column %d" + loc.filename + (fst loc.line) (fst loc.column) + (snd loc.line) (snd loc.column) + let xml_to_location (xml : tree) : location = match xml with | Node ("location", [ @@ -344,20 +350,21 @@ and xml_to_expr_or_op_arg (xml : tree) : expr_or_op_arg = ) | _ -> Expression (xml_to_expression xml) -and xml_to_op_appl_node xml = - match xml with - | Node ("OpApplNode", children) -> ( - match extract_inline_node children with - | node, Node ("operator", [ref_node]) :: - Node ("operands", operand_nodes) :: - bound_symbols -> { - node; - operator = get_ref ref_node; - operands = List.map xml_to_expr_or_op_arg operand_nodes; - bound_symbols = List.nth_opt bound_symbols 0 |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_symbols; - } - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml +and xml_to_op_appl_node (children : tree list) : op_appl_node = + match extract_inline_node children with + | node, [Node ("operator", [ref_node]); Node ("operands", operands); Node ("boundSymbols", bound_symbols)] -> { + node; + operator = get_ref ref_node; + operands = List.map xml_to_expr_or_op_arg operands; + bound_symbols = List.map xml_to_symbols bound_symbols; + } + | node, [Node ("operator", [ref_node]); Node ("operands", operands)] -> { + node; + operator = get_ref ref_node; + operands = List.map xml_to_expr_or_op_arg operands; + bound_symbols = [] + } + | _ -> ls_conversion_failure __FUNCTION__ children and xml_to_let_in_node (children : tree list) : let_in_node = match extract_inline_node children with @@ -376,7 +383,7 @@ and xml_to_expression (xml : tree) : expression = match xml with | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) | Node ("StringNode", _) -> StringNode (xml_to_string_node xml) - | Node ("OpApplNode", _) -> OpApplNode (xml_to_op_appl_node xml) + | Node ("OpApplNode", children) -> OpApplNode (xml_to_op_appl_node children) | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) | Node ("AtNode", children) -> AtNode (xml_to_at_node children) | _ -> conversion_failure __FUNCTION__ xml From e38625e2feb91aace3464d71d6e5de2aecff1c10 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 28 Jan 2026 17:19:18 -0800 Subject: [PATCH 40/85] Translate functions, ITE, and case Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 108 +++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 100 insertions(+), 8 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index d2df4e0e..20f4511a 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -212,6 +212,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE | "UNCHANGED" -> Some Builtin.UNCHANGED + | "UNION" -> Some Builtin.UNION | "'" -> Some Builtin.Prime | "[]" -> Some (Builtin.Box false) | "=" -> Some Builtin.Eq @@ -376,7 +377,7 @@ and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : boun nonempty list of symbols and a domain expression. The unbound case would be a simple nonempty list of symbols. *) -and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( +and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | _ :: _, [Expression body] -> let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in @@ -413,13 +414,35 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node | _ -> conversion_failure "Invalid number of bounds or operands to quantification" apply.node.location ) |> attach_props apply.node +(** Conversion of expressions of the form {f(x, y) : x \in S, y \in Z} +*) +and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | _ :: _, [Expression body] -> + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in + if List.length bound_symbols <> List.length apply.bound_symbols + then conversion_failure "Set mappings cannot have unbound symbols" apply.node.location + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + (* Set mapping that includes at least one tuple *) + then SetOfTuply ( + convert_expression body, + List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten + ) + (* Set mapping without any tuples *) + else SetOf ( + convert_expression body, + List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten + ) + | _ -> conversion_failure "Invalid number of bounds or operands to set mapping" apply.node.location +) |> attach_props apply.node + (** Conversion of recursive functions where the function body refers to the function definition, for example f[x \in Nat] == f[x - 1]. Both SANY and TLAPM represent these as f == [x \in Nat |-> f[x - 1]], and here we convert the right-hand side of this definition. The function name is introduced as the first symbol, unbound. *) -and convert_recursive_function (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = ( +and convert_recursive_function (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) all_bound_symbols in @@ -430,7 +453,44 @@ and convert_recursive_function (apply : Xml.op_appl_node) (op : Xml.built_in_kin then FcnTuply (List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) (* Function definition bounds without any tuples *) else Fcn (List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) - | _ -> conversion_failure "Invalid number of bounds or operands to function definition" apply.node.location + | _ -> conversion_failure "Invalid number of bounds or operands to recursive function definition" apply.node.location +) |> attach_props apply.node + +(** Converts function construction expressions like [x \in S, y \in P |-> x + y] +*) +and convert_function_constructor (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | _ :: _, [Expression body] -> + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in + if List.length bound_symbols <> List.length apply.bound_symbols + then conversion_failure "Function definitions cannot have unbound symbols" apply.node.location + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + (* Function definition bounds that include at least one tuple *) + then FcnTuply (List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) + (* Function definition bounds without any tuples *) + else Fcn (List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) + | _ -> conversion_failure "Invalid operands to function constructor" apply.node.location +) |> attach_props apply.node + +(** Converts function set expressions of the form [P -> Q] +*) +and convert_function_set (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], [Expression domain; Expression range] -> + Arrow (convert_expression domain, convert_expression range) + | _ -> conversion_failure "Invalid operands to function set expression" apply.node.location +) |> attach_props apply.node + +(** Conversion of function application, like f[x, y, z]. +*) +and convert_function_application (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], Expression fn :: all_args -> + let args = List.filter_map (fun (arg: Xml.expr_or_op_arg) -> match arg with | Expression e -> Some (convert_expression e) | _ -> None) all_args in + if List.length args <> List.length all_args + then conversion_failure "Function application arguments must all be expressions" apply.node.location + else FcnApp (convert_expression fn, args) + | _ -> conversion_failure "Invalid operands to function application" apply.node.location ) |> attach_props apply.node (** Conversion of application of all traditional built-in operators like = or @@ -456,14 +516,46 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply - | "$BoundedExists" -> convert_quantification Exists apply op - | "$BoundedForall" -> convert_quantification Forall apply op - | "$UnboundedExists" -> convert_quantification Exists apply op - | "$UnboundedForall" -> convert_quantification Forall apply op - | "$RecursiveFcnSpec" -> convert_recursive_function apply op + | "$BoundedExists" -> convert_quantification Exists apply + | "$BoundedForall" -> convert_quantification Forall apply + | "$UnboundedExists" -> convert_quantification Exists apply + | "$UnboundedForall" -> convert_quantification Forall apply + | "$SetOfAll" -> convert_set_map apply + | "$SetOfFcns" -> convert_function_set apply + | "$FcnConstructor" -> convert_function_constructor apply + | "$RecursiveFcnSpec" -> convert_recursive_function apply + | "$FcnApply" -> convert_function_application apply + | "$IfThenElse" -> convert_if_then_else apply + | "$Case" -> convert_case apply | s -> todo "Built-in operator" s apply.node.location ) +(** Conversion of expression IF predicate THEN A ELSE B +*) +and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], [Expression cond; Expression then_branch; Expression else_branch] -> + If (convert_expression cond, convert_expression then_branch, convert_expression else_branch) + | _ -> conversion_failure "Invalid operands to IF/THEN/ELSE" apply.node.location +) |> attach_props apply.node + +(** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e +*) +and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], cases -> + let rec group_expr (exprs : Xml.expr_or_op_arg list) : ((Expr.T.expr * Expr.T.expr) list * expr option) = + match exprs with + | [Expression other] -> ([], Some (convert_expression other)) + | [Expression pred; Expression expr] -> ([(convert_expression pred, convert_expression expr)], None) + | Expression pred :: Expression expr :: rest -> + let cases, other = group_expr rest in + (cases @ [(convert_expression pred, convert_expression expr)], other) + | _ -> conversion_failure "Invalid operands of CASE expression" apply.node.location + in let cases, other = group_expr apply.operands in Case (cases, other) + | _ -> conversion_failure "Invalid operands to CASE" apply.node.location +) |> attach_props apply.node + (** Conversion of application of user-defined operators, including operators defined in the standard modules. *) From 60db57ed899e6d8d7217afbc4c73fae1f152ce2f Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 12:07:22 -0800 Subject: [PATCH 41/85] Translate INSTANCE substitutions Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 59 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 50 insertions(+), 9 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 20f4511a..ae801d80 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -157,17 +157,27 @@ let resolve_module_node (uid : int) : Xml.module_node = | ModuleNode mule -> mule | _ -> conversion_failure ("Expected module node for UID: " ^ string_of_int uid) None +let resolve_op_decl_node (uid : int) : Xml.op_decl_node = + match (resolve_ref uid).kind with + | OpDeclNode odn -> odn + | _ -> conversion_failure ("Expected operator declaration node for UID: " ^ string_of_int uid) None + (** A typed version of resolve_ref for operator parameter nodes. *) -let resolve_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = - match (resolve_ref param.ref).kind with - | Xml.FormalParamNode xml -> ( - attach_props xml.node xml.name, - match xml.arity with +let resolve_formal_param_node (uid : int) : Xml.formal_param_node = + match (resolve_ref uid).kind with + | Xml.FormalParamNode xml -> xml + | _ -> conversion_failure ("Expected formal parameter node for UID: " ^ string_of_int uid) None + +(** A typed version of resolve_ref for Leibniz operator parameter nodes. +*) +let resolve_leibniz_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = + let fpn = resolve_formal_param_node param.ref in ( + attach_props fpn.node fpn.name, + match fpn.arity with | 0 -> Shape_expr | n -> Shape_op n ) - | _ -> conversion_failure ("Expected formal parameter node for UID: " ^ string_of_int param.ref) None (** A typed version of resolve_ref for theorem definition nodes. *) @@ -211,14 +221,19 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.name with | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE + | "DOMAIN" -> Some Builtin.DOMAIN + | "SUBSET" -> Some Builtin.SUBSET | "UNCHANGED" -> Some Builtin.UNCHANGED | "UNION" -> Some Builtin.UNION | "'" -> Some Builtin.Prime | "[]" -> Some (Builtin.Box false) | "=" -> Some Builtin.Eq + | "/=" -> Some Builtin.Neq | "\\in" -> Some Builtin.Mem | "\\notin" -> Some Builtin.Notmem + | "\\" -> Some Builtin.Setminus | "\\land" -> Some Builtin.Conj + | "$Pair" -> Some Builtin.Range | "=>" -> Some Builtin.Implies | "\\equiv" -> Some Builtin.Equiv | _ -> None @@ -256,8 +271,34 @@ let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = important = false } |> attach_props mule.node -and convert_instance (instance : Xml.instance_node) : Module.T.modunit = - todo "Instance" "" instance.node.location +(** Converts M(x, y) == INSTANCE ModuleName WITH op <- x, op2 <- y. Also + converts non-named (anonymous) unit-level instances. + + TODO: SANY can handle named instances accepting an operator as a + parameter, but TLAPM does not seem to be able to represent this; it uses + a simple 'hint' for the parameter name instead of a hint * shape tuple + which would capture arity. This doesn't *necessarily* mean that TLAPM + does not handle operator parameters, but it is odd that arity info is not + captured. For now we will just error in that case. +*) +and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( + let mk_arg (param : Xml.formal_param_node) : hint = + match param.arity with + | 0 -> attach_props param.node param.name + | _ -> conversion_failure "TLAPM cannot handle operators as instance arguments" param.node.location + in let mk_substitution (sub : Xml.substitution) : (hint * Expr.T.expr) = + let target = resolve_op_decl_node sub.target_uid in ( + attach_props target.node target.name, + convert_expression_or_operator_argument sub.substitute + ) + in let instantiation : Expr.T.instance = { + inst_args = instance.parameters |> List.map resolve_formal_param_node |> List.map mk_arg; + inst_mod = instance.module_name; + inst_sub = List.map mk_substitution instance.substitutions; + } in match instance.name with + | Some name -> Definition (Instance (noprops name, instantiation) |> noprops, User, Hidden, Export) + | None -> Anoninst (instantiation, Export) +) |> attach_props instance.node and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = todo "UseOrHide" "" use_or_hide.node.location @@ -655,7 +696,7 @@ and convert_user_defined_op_kind (xml : Xml.user_defined_op_kind) : Expr.T.defn (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) let expr = match xml.params with | [] -> body - | params -> Lambda (List.map resolve_formal_param_node params, body) |> attach_props xml.node + | params -> Lambda (List.map resolve_leibniz_formal_param_node params, body) |> attach_props xml.node in Operator (name, expr) |> attach_props xml.node (** Converts user-defined operators defined in a module top-level. From e57318faf5d2687100dc99388b657ae1edf8b652 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 12:12:00 -0800 Subject: [PATCH 42/85] Translated CONSTANTS Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index ae801d80..3fde2b92 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -316,8 +316,9 @@ and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with + | 2 -> attach_props xml.node (Constants [attach_props xml.node xml.name, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n]) | 3 -> attach_props xml.node (Variables [attach_props xml.node xml.name]) - | _ -> todo "Operator declaration" (string_of_int xml.kind) xml.node.location + | _ -> todo "Operator declaration kind" (string_of_int xml.kind) xml.node.location (** Converts action-level expressions such as [][expr]_sub and <><>_sub. *) From f581aaa92c138f3d9cf39444a21a5c245d307bd0 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 12:21:19 -0800 Subject: [PATCH 43/85] Translated set filter Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 3fde2b92..d1d815b6 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -232,6 +232,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "\\in" -> Some Builtin.Mem | "\\notin" -> Some Builtin.Notmem | "\\" -> Some Builtin.Setminus + | "\\union" -> Some Builtin.Cup | "\\land" -> Some Builtin.Conj | "$Pair" -> Some Builtin.Range | "=>" -> Some Builtin.Implies @@ -478,6 +479,23 @@ and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid number of bounds or operands to set mapping" apply.node.location ) |> attach_props apply.node +(** Conversion of expressions of the form {x \in S : P(x)} or {<> \in S \X T : P(x, y)} +*) +and convert_set_filter (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [Bound {symbol_refs = [symbol_ref]; is_tuple = false; expression}], [Expression predicate] -> SetSt ( + resolve_bound_symbol symbol_ref, + convert_expression expression, + convert_expression predicate + ) + | [Bound {symbol_refs = (_ :: _) as symbol_refs; is_tuple = true; expression}], [Expression predicate] -> SetStTuply ( + List.map resolve_bound_symbol symbol_refs, + convert_expression expression, + convert_expression predicate + ) + | _ -> conversion_failure "Invalid bounds or operands to set filter" apply.node.location +) |> attach_props apply.node + (** Conversion of recursive functions where the function body refers to the function definition, for example f[x \in Nat] == f[x - 1]. Both SANY and TLAPM represent these as f == [x \in Nat |-> f[x - 1]], and here we @@ -563,6 +581,7 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) | "$UnboundedExists" -> convert_quantification Exists apply | "$UnboundedForall" -> convert_quantification Forall apply | "$SetOfAll" -> convert_set_map apply + | "$SubsetOf" -> convert_set_filter apply | "$SetOfFcns" -> convert_function_set apply | "$FcnConstructor" -> convert_function_constructor apply | "$RecursiveFcnSpec" -> convert_recursive_function apply From 3afc66ffe023c4b8fb6c99e2a6450ae8f1d14a8e Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 15:06:58 -0800 Subject: [PATCH 44/85] Translated record sets Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 61 +++++++++++++++++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 13 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index d1d815b6..b8107076 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -234,7 +234,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "\\" -> Some Builtin.Setminus | "\\union" -> Some Builtin.Cup | "\\land" -> Some Builtin.Conj - | "$Pair" -> Some Builtin.Range + | "\\lor" -> Some Builtin.Disj | "=>" -> Some Builtin.Implies | "\\equiv" -> Some Builtin.Equiv | _ -> None @@ -516,7 +516,8 @@ and convert_recursive_function (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid number of bounds or operands to recursive function definition" apply.node.location ) |> attach_props apply.node -(** Converts function construction expressions like [x \in S, y \in P |-> x + y] +(** Converts function construction expressions like [x \in S, y \in P |-> x + y]; + also handles record construction, like [x |-> expr1, y |-> expr2]. *) and convert_function_constructor (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with @@ -553,6 +554,33 @@ and convert_function_application (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid operands to function application" apply.node.location ) |> attach_props apply.node +(** Conversion of record selection expressions like r.fieldName +*) +and convert_record_select (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], [Expression record; Expression (StringNode {value})] -> Dot (convert_expression record, value) + | _ -> conversion_failure "Invalid operands to record selection" apply.node.location +) |> attach_props apply.node + +(** Conversion of record set expressions like [field1 : expr1, field2 : expr2, ...] +*) +and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], (_ :: _ as pairs) -> + let mk_field (operand : Xml.expr_or_op_arg) : (string * Expr.T.expr) option = + match operand with + | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression StringNode {value}; Expression right]} -> ( + match (resolve_ref operator).kind with + | BuiltInKind {name = "$Pair"} -> Some (value, convert_expression right) + | _ -> None + ) | _ -> None + in let fields = List.filter_map mk_field pairs in + if List.length fields <> List.length pairs + then conversion_failure "Invalid operands to record set; expected pairs of expressions" apply.node.location + else Rect (fields) + | _ -> conversion_failure "Invalid operands to record set" apply.node.location +) |> attach_props apply.node + (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not view as built-in operators. @@ -586,6 +614,8 @@ and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) | "$FcnConstructor" -> convert_function_constructor apply | "$RecursiveFcnSpec" -> convert_recursive_function apply | "$FcnApply" -> convert_function_application apply + | "$RcdSelect" -> convert_record_select apply + | "$SetOfRcds" -> convert_record_set apply | "$IfThenElse" -> convert_if_then_else apply | "$Case" -> convert_case apply | s -> todo "Built-in operator" s apply.node.location @@ -601,20 +631,25 @@ and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( ) |> attach_props apply.node (** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e + + TODO: SANY XML exporter cannot currently handle OTHER branches; see: + https://github.com/tlaplus/tlaplus/issues/1291 *) and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | [], cases -> - let rec group_expr (exprs : Xml.expr_or_op_arg list) : ((Expr.T.expr * Expr.T.expr) list * expr option) = - match exprs with - | [Expression other] -> ([], Some (convert_expression other)) - | [Expression pred; Expression expr] -> ([(convert_expression pred, convert_expression expr)], None) - | Expression pred :: Expression expr :: rest -> - let cases, other = group_expr rest in - (cases @ [(convert_expression pred, convert_expression expr)], other) - | _ -> conversion_failure "Invalid operands of CASE expression" apply.node.location - in let cases, other = group_expr apply.operands in Case (cases, other) - | _ -> conversion_failure "Invalid operands to CASE" apply.node.location + | [], (_ :: _ as pairs) -> + let mk_case (operand : Xml.expr_or_op_arg) : (Expr.T.expr * Expr.T.expr) option = + match operand with + | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression cond; Expression result]} -> ( + match (resolve_ref operator).kind with + | BuiltInKind {name = "$Pair"} -> Some (convert_expression cond, convert_expression result) + | _ -> None + ) | _ -> None + in let cases = List.filter_map mk_case pairs in + if List.length cases <> List.length pairs + then conversion_failure "Invalid operands to CASE; expected pairs of expressions" apply.node.location + else Case (cases, None) + | _ -> conversion_failure "Invalid bound symbols or operands to CASE" apply.node.location ) |> attach_props apply.node (** Conversion of application of user-defined operators, including operators From 83203f7d8708b294440c4da8ab63540a6bd13aac Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 15:19:02 -0800 Subject: [PATCH 45/85] Translated record constructor Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 106 +++++++++++++++++++++++++++-------------------- 1 file changed, 61 insertions(+), 45 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index b8107076..bbec1b7f 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -221,6 +221,7 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.name with | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE + | "STRING" -> Some Builtin.STRING | "DOMAIN" -> Some Builtin.DOMAIN | "SUBSET" -> Some Builtin.SUBSET | "UNCHANGED" -> Some Builtin.UNCHANGED @@ -239,8 +240,51 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "\\equiv" -> Some Builtin.Equiv | _ -> None +(** Conversion of application of all traditional built-in operators like = or + \cup but also things like CHOOSE and \A which one would ordinarily not + view as built-in operators. +*) +let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = + match try_convert_builtin op with + (* Traditional built-in operators *) + | Some builtin -> Apply ( + Internal builtin |> attach_props op.node, + List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node + (* More abstract kinds of built-in operators *) + | None -> + match op.name with + | "$SetEnumerate" -> SetEnum ( + List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node + | "$Tuple" -> Tuple ( + List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node + | "$ConjList" -> List ( + And, List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node + | "$BoundedChoose" -> convert_choose apply + | "$UnboundedChoose" -> convert_choose apply + | "$SquareAct" -> convert_action_expr Box apply + | "$BoundedExists" -> convert_quantification Exists apply + | "$BoundedForall" -> convert_quantification Forall apply + | "$UnboundedExists" -> convert_quantification Exists apply + | "$UnboundedForall" -> convert_quantification Forall apply + | "$SetOfAll" -> convert_set_map apply + | "$SubsetOf" -> convert_set_filter apply + | "$SetOfFcns" -> convert_function_set apply + | "$FcnConstructor" -> convert_function_constructor apply + | "$RecursiveFcnSpec" -> convert_recursive_function apply + | "$FcnApply" -> convert_function_application apply + | "$SetOfRcds" -> convert_record_set apply + | "$RcdConstructor" -> convert_record_constructor apply + | "$RcdSelect" -> convert_record_select apply + | "$IfThenElse" -> convert_if_then_else apply + | "$Case" -> convert_case apply + | s -> todo "Built-in operator" s apply.node.location + (** Converts a top-level module node. *) -let rec convert_module_node (mule : Xml.module_node) : Module.T.mule = +and convert_module_node (mule : Xml.module_node) : Module.T.mule = (** Converts an entry, which is an abstract type that can be all sorts of things; SANY heavily uses GUIDs to reference one entity from another and those GUIDs are resolved in a global table with no real type information. @@ -564,7 +608,19 @@ and convert_record_select (apply : Xml.op_appl_node) : Expr.T.expr = ( (** Conversion of record set expressions like [field1 : expr1, field2 : expr2, ...] *) -and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = ( +and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = + convert_record_operator apply (fun arg -> Rect arg) + +(** Conversion of record construction expressions like [field1 |-> expr1, field2 |-> expr2, ...] +*) +and convert_record_constructor (apply : Xml.op_appl_node) : Expr.T.expr = + convert_record_operator apply (fun arg -> Record arg) + +(** The conversion logic for both record sets and record constructors is + identical except for the wrapping constructor (Rect vs Record). This + method captures that shared logic, taking the constructor as a parameter. +*) +and convert_record_operator (apply : Xml.op_appl_node) (constructor : (string * Expr.T.expr) list -> Expr.T.expr_) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [], (_ :: _ as pairs) -> let mk_field (operand : Xml.expr_or_op_arg) : (string * Expr.T.expr) option = @@ -576,51 +632,11 @@ and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = ( ) | _ -> None in let fields = List.filter_map mk_field pairs in if List.length fields <> List.length pairs - then conversion_failure "Invalid operands to record set; expected pairs of expressions" apply.node.location - else Rect (fields) - | _ -> conversion_failure "Invalid operands to record set" apply.node.location + then conversion_failure "Invalid operands to record operator; expected pairs of expressions" apply.node.location + else constructor fields + | _ -> conversion_failure "Invalid operands to record operator" apply.node.location ) |> attach_props apply.node -(** Conversion of application of all traditional built-in operators like = or - \cup but also things like CHOOSE and \A which one would ordinarily not - view as built-in operators. -*) -and convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = - match try_convert_builtin op with - (* Traditional built-in operators *) - | Some builtin -> Apply ( - Internal builtin |> attach_props op.node, - List.map convert_expression_or_operator_argument apply.operands - ) |> attach_props apply.node - (* More abstract kinds of built-in operators *) - | None -> ( - match op.name with - | "$SetEnumerate" -> SetEnum ( - List.map convert_expression_or_operator_argument apply.operands - ) |> attach_props apply.node - | "$Tuple" -> Tuple ( - List.map convert_expression_or_operator_argument apply.operands - ) |> attach_props apply.node - | "$BoundedChoose" -> convert_choose apply - | "$UnboundedChoose" -> convert_choose apply - | "$SquareAct" -> convert_action_expr Box apply - | "$BoundedExists" -> convert_quantification Exists apply - | "$BoundedForall" -> convert_quantification Forall apply - | "$UnboundedExists" -> convert_quantification Exists apply - | "$UnboundedForall" -> convert_quantification Forall apply - | "$SetOfAll" -> convert_set_map apply - | "$SubsetOf" -> convert_set_filter apply - | "$SetOfFcns" -> convert_function_set apply - | "$FcnConstructor" -> convert_function_constructor apply - | "$RecursiveFcnSpec" -> convert_recursive_function apply - | "$FcnApply" -> convert_function_application apply - | "$RcdSelect" -> convert_record_select apply - | "$SetOfRcds" -> convert_record_set apply - | "$IfThenElse" -> convert_if_then_else apply - | "$Case" -> convert_case apply - | s -> todo "Built-in operator" s apply.node.location - ) - (** Conversion of expression IF predicate THEN A ELSE B *) and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( From 7110ebbc077b16b0aca5034880afb7b3260a97cc Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 29 Jan 2026 15:40:22 -0800 Subject: [PATCH 46/85] Translated cartesian product Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index bbec1b7f..e260514f 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -263,6 +263,9 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | "$ConjList" -> List ( And, List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node + | "$CartesianProd" -> Product ( + List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply From 8f287e4acf2c05fd430b3666b29ebd7eaffbbcf5 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 30 Jan 2026 16:04:29 -0800 Subject: [PATCH 47/85] Translated EXCEPT Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 41 +++++++++++++++++++++++++++++++++++++---- src/sany/xml.ml | 12 ++++++------ 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index e260514f..78c13e09 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -10,7 +10,7 @@ this more apparent than in SANY's OpApplNode type, which is used for everything from simple expressions like 1 + 3 to complex constructs like \A x, y, z \in S : P. - + Much of the challenge of this module, in addition to the sheer number of TLA+ syntax node types it has to convert, is the difficulty in mapping the information in each SANY AST node to the fields expected in each @@ -25,7 +25,7 @@ abstract which is presented to us here. Thus the SANY AST has already been processed significantly, and we are translating it to a form that is comparatively much rougher & earlier in the parse process. - + Given these challenges, much SANY information such as identifier reference IDs and levels are attached as metadata to TLAPM AST nodes for use later on: not as the basis for final calculations, but rather to cross-check @@ -282,6 +282,7 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | "$SetOfRcds" -> convert_record_set apply | "$RcdConstructor" -> convert_record_constructor apply | "$RcdSelect" -> convert_record_select apply + | "$Except" -> convert_except apply | "$IfThenElse" -> convert_if_then_else apply | "$Case" -> convert_case apply | s -> todo "Built-in operator" s apply.node.location @@ -640,6 +641,38 @@ and convert_record_operator (apply : Xml.op_appl_node) (constructor : (string * | _ -> conversion_failure "Invalid operands to record operator" apply.node.location ) |> attach_props apply.node +(** Converts expressions of the form [f EXCEPT ![1].2[<<3, 4>>] = val, ![2] = val2, ...] + Note that SANY does not distinguish between function and record EXCEPT; + the expression [f EXCEPT !["field"] = val] is the same as [f EXCEPT !.field = val]. + TLAPM *does* distinguish these with the Except_dot and Except_apply variants, + so we make a best-effort attempt to determine which is which. Whether this + leads to buggy behavior is currently unknown (TODO). +*) +and convert_except (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], Expression base :: (_ :: _ as updates) -> + let mk_path (path_item : Expr.T.expr) : Expr.T.expoint = + match path_item.core with + | String s -> Except_dot s + | _ -> Except_apply path_item + in let mk_update (operand : Xml.expr_or_op_arg) : (Expr.T.expoint list * Expr.T.expr) option = + match operand with + | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression OpApplNode {operator = update_op; bound_symbols = []; operands = update_path}; Expression new_value]} -> ( + match (resolve_ref operator).kind, (resolve_ref update_op).kind with + | BuiltInKind {name = "$Pair"}, BuiltInKind {name = "$Seq"} -> + let path = List.filter_map (fun (p : Xml.expr_or_op_arg) -> match p with | Expression e -> Some (convert_expression e) | _ -> None) update_path in + if List.length path <> List.length update_path + then conversion_failure "Invalid path in EXCEPT update; expected sequence of expressions" apply.node.location + else Some (List.map mk_path path, convert_expression new_value) + | _ -> None + ) | _ -> None + in let updates_converted = List.filter_map mk_update updates in + if List.length updates_converted <> List.length updates + then conversion_failure "Invalid operands to EXCEPT; expected pairs of update paths and new values" apply.node.location + else Except (convert_expression base, updates_converted) + | _ -> conversion_failure "Invalid operands to EXCEPT" apply.node.location +) |> attach_props apply.node + (** Conversion of expression IF predicate THEN A ELSE B *) and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( @@ -650,7 +683,7 @@ and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( ) |> attach_props apply.node (** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e - + TODO: SANY XML exporter cannot currently handle OTHER branches; see: https://github.com/tlaplus/tlaplus/issues/1291 *) @@ -827,7 +860,7 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no match proof with | None -> Omitted Implicit |> noprops |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some Steps proof -> convert_proof_steps uid previous_proof_level proof diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 6a2121cc..6115a80a 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -9,10 +9,10 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in - let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -I %s -t %s" - (backend_classpath_string "tla2tools.jar") - (Filename.quote stdlib_path) + let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -I %s -t %s" + (backend_classpath_string "tla2tools.jar") (Filename.dirname module_path) + (Filename.quote stdlib_path) (Filename.quote module_path) in let (pid, out_fd) = System.launch_process cmd in let in_chan = Unix.in_channel_of_descr out_fd in @@ -114,7 +114,7 @@ let xml_child_to_int (xml : tree) : int = match xml with | (Node (_, [IValue n])) -> n | _ -> conversion_failure __FUNCTION__ xml - + let xml_to_tagged_int (tag_name : string) (children : tree list) : int = find_tag tag_name children |> xml_child_to_int @@ -405,7 +405,7 @@ and xml_to_user_defined_op_kind xml : user_defined_op_kind = recursive = children |> List.exists (is_tag "recursive"); } | _ -> conversion_failure __FUNCTION__ xml - + type substitution = { target_uid : int; substitute : expr_or_op_arg; @@ -481,7 +481,7 @@ let xml_to_module_node (children : tree list) : module_node = units = List.map ref_child units } | _ -> ls_conversion_failure __FUNCTION__ children - + type op_decl_node = { node : node; name : string; From 0ff4bea048f8090ea07bd3df296aafae56eaa572 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 30 Jan 2026 16:45:51 -0800 Subject: [PATCH 48/85] Translate fairness Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 21 +++++++++++++++++++-- src/tlapm_lib.ml | 9 +++++---- test/sany/sany_tests.ml | 11 ++++++++++- 3 files changed, 34 insertions(+), 7 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 78c13e09..07819535 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -226,14 +226,18 @@ let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = | "SUBSET" -> Some Builtin.SUBSET | "UNCHANGED" -> Some Builtin.UNCHANGED | "UNION" -> Some Builtin.UNION + | "\\lnot" -> Some Builtin.Neg | "'" -> Some Builtin.Prime | "[]" -> Some (Builtin.Box false) + | "<>" -> Some Builtin.Diamond | "=" -> Some Builtin.Eq | "/=" -> Some Builtin.Neq | "\\in" -> Some Builtin.Mem | "\\notin" -> Some Builtin.Notmem | "\\" -> Some Builtin.Setminus | "\\union" -> Some Builtin.Cup + | "\\intersect" -> Some Builtin.Cap + | "\\subseteq" -> Some Builtin.Subseteq | "\\land" -> Some Builtin.Conj | "\\lor" -> Some Builtin.Disj | "=>" -> Some Builtin.Implies @@ -263,9 +267,13 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | "$ConjList" -> List ( And, List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node + | "$DisjList" -> List ( + Or, List.map convert_expression_or_operator_argument apply.operands + ) |> attach_props apply.node | "$CartesianProd" -> Product ( List.map convert_expression_or_operator_argument apply.operands ) |> attach_props apply.node + | "$WF" -> convert_fairness Weak apply | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply @@ -369,6 +377,14 @@ and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = | 3 -> attach_props xml.node (Variables [attach_props xml.node xml.name]) | _ -> todo "Operator declaration kind" (string_of_int xml.kind) xml.node.location +(** Converts fairness expressions such as WF_sub(expr) and SF_sub(expr). +*) +and convert_fairness (fairness : fairness_op) (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | [], [Expression sub; Expression expr] -> Fair (fairness, convert_expression sub, convert_expression expr) + | _ -> conversion_failure "Wrong number of operands to fairness expression" apply.node.location +) |> attach_props apply.node + (** Converts action-level expressions such as [][expr]_sub and <><>_sub. *) and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr = @@ -785,7 +801,8 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | StringNode s -> String s.value |> attach_props s.node | OpApplNode apply -> convert_op_appl_node apply | LetInNode let_in -> convert_let_in_node let_in - | AtNode at_node -> todo "AtNode" "@" at_node.node.location + (* TODO: true means @ from EXCEPT, false means @ from proof step (???) *) + | AtNode at_node -> At true |> attach_props at_node.node and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = let definitions = List.map (fun ref -> @@ -947,7 +964,7 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string if Coll.Sm.mem mule.name map then map else Coll.Sm.add mule.name (convert_module_node mule) map ) - Module.Standard.initctx + Coll.Sm.empty ast.module_refs in let root_module = Coll.Sm.find ast.root_module ctx in root_module.core.important <- true; diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index 2ff10824..e8dbce7e 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -545,12 +545,13 @@ let setup_loader fs loader_paths = Loader.Global.setup loader_paths let sany_modctx_of_string filename = - let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = + (*let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = Params.input_files := [Filename.basename filename]; Params.set_search_path [Filename.basename filename]; - let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in - let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) - in Result.bind (Sany.parse filename) transform + let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty + in let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) + in Result.bind (Sany.parse filename) transform*) + Sany.parse filename let main fs = match !Params.parser_backend, fs with diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index dbb96372..74250dc7 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -13,6 +13,15 @@ let find_tla_files dir = in loop [] +let should_run (path : string) : bool = + let preds = [ + (* RECURSIVE operators *) + String.ends_with ~suffix:"Chameneos.tla"; + (* Community modules *) + String.ends_with ~suffix:"MCtcp.tla"; + String.ends_with ~suffix:"tcp.tla"; + ] in not (List.exists (fun pred -> pred path) preds) + let parse_tla_file filename = let open Stdlib in print_endline ("Parsing " ^ filename ^ " ..."); @@ -26,5 +35,5 @@ let parse_tla_file filename = let _ = parser_backend := Sany; add_debug_flag "sany"; - let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" in + let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run in List.map parse_tla_file tla_files From 935712aec8f24e20e5e1fd14fc7c9d5642592cb1 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Feb 2026 13:52:16 -0800 Subject: [PATCH 49/85] Parse assume/prove and new symbol nodes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 68 ++++++++++++++++++++++++----------------- src/sany/xml.ml | 78 +++++++++++++++++++++++++++++++++++++----------- 2 files changed, 101 insertions(+), 45 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 07819535..1547c6e0 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -135,6 +135,18 @@ let parse_proof_step_name (proof_level : proof_level) (uid : int) (proof_name : let attach_proof_step_name (proof_name : stepno) (step : 'a) : 'a = assign step Props.step proof_name +(** An OpApplNode's operands can be either expressions or operator arguments. + Often we only want them to be expressions. This function coerces the list + items into expressions, raising an error if they are operators. +*) +let as_expr_ls (name : string) (loc : Xml.location option) (operands : Xml.expr_or_op_arg list) : Xml.expression list = + let exprs = List.filter_map + (fun (operand : Xml.expr_or_op_arg) -> match operand with Expression e -> Some e | _ -> None) + operands + in if List.length exprs <> List.length operands + then conversion_failure (Format.sprintf "Expected all operands to be expressions in %s" name) loc + else exprs + (** Wrap the given object in location data. TODO: also wrap with level data. *) @@ -253,25 +265,25 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k (* Traditional built-in operators *) | Some builtin -> Apply ( Internal builtin |> attach_props op.node, - List.map convert_expression_or_operator_argument apply.operands + apply.operands |> as_expr_ls (Builtin.builtin_to_string builtin) apply.node.location |> List.map convert_expression ) |> attach_props apply.node (* More abstract kinds of built-in operators *) | None -> match op.name with | "$SetEnumerate" -> SetEnum ( - List.map convert_expression_or_operator_argument apply.operands + apply.operands |> as_expr_ls "$SetEnumerate" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$Tuple" -> Tuple ( - List.map convert_expression_or_operator_argument apply.operands + apply.operands |> as_expr_ls "$Tuple" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$ConjList" -> List ( - And, List.map convert_expression_or_operator_argument apply.operands + And, apply.operands |> as_expr_ls "$ConjList" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$DisjList" -> List ( - Or, List.map convert_expression_or_operator_argument apply.operands + Or, apply.operands |> as_expr_ls "$DisjList" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$CartesianProd" -> Product ( - List.map convert_expression_or_operator_argument apply.operands + apply.operands |> as_expr_ls "$CartesianProd" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$WF" -> convert_fairness Weak apply | "$BoundedChoose" -> convert_choose apply @@ -389,10 +401,10 @@ and convert_fairness (fairness : fairness_op) (apply : Xml.op_appl_node) : Expr. *) and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr = match apply.operands with - | [expr; sub] -> Sub ( + | [Expression expr; Expression sub] -> Sub ( op, - convert_expression_or_operator_argument expr, - convert_expression_or_operator_argument sub + convert_expression expr, + convert_expression sub ) |> attach_props apply.node | _ -> conversion_failure "Wrong number of operands to action expression" apply.node.location @@ -410,35 +422,35 @@ and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with (* Case 1: Bounded non-tuple CHOOSE expression *) - | [Bound {is_tuple = false; symbol_refs = [param]; expression}], [body] -> + | [Bound {is_tuple = false; symbol_refs = [param]; expression}], [Expression body] -> Choose ( resolve_bound_symbol param, Some (convert_expression expression), - convert_expression_or_operator_argument body + convert_expression body ) (* Case 2: Bounded tuple CHOOSE expression *) - | [Bound ({is_tuple = true} as symbol)], [body] -> + | [Bound ({is_tuple = true} as symbol)], [Expression body] -> ChooseTuply ( List.map resolve_bound_symbol symbol.symbol_refs, Some (convert_expression symbol.expression), - convert_expression_or_operator_argument body + convert_expression body ) (* Case 3: Unbounded non-tuple CHOOSE expression *) - | [Unbound ({is_tuple = false} as symbol)], [body] -> + | [Unbound ({is_tuple = false} as symbol)], [Expression body] -> Choose ( resolve_bound_symbol symbol.symbol_ref, None, - convert_expression_or_operator_argument body + convert_expression body ) (* Case 4: Unbounded tuple CHOOSE expression *) - | Unbound {is_tuple = true} :: _, [body] -> + | Unbound {is_tuple = true} :: _, [Expression body] -> let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in if List.length symbols <> List.length apply.bound_symbols then conversion_failure "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" apply.node.location else ChooseTuply ( List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.symbol_ref) symbols, None, - convert_expression_or_operator_argument body + convert_expression body ) | _ -> conversion_failure "Invalid number of bounds or operands to CHOOSE" apply.node.location ) |> attach_props apply.node @@ -611,10 +623,8 @@ and convert_function_set (apply : Xml.op_appl_node) : Expr.T.expr = ( and convert_function_application (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [], Expression fn :: all_args -> - let args = List.filter_map (fun (arg: Xml.expr_or_op_arg) -> match arg with | Expression e -> Some (convert_expression e) | _ -> None) all_args in - if List.length args <> List.length all_args - then conversion_failure "Function application arguments must all be expressions" apply.node.location - else FcnApp (convert_expression fn, args) + let args = apply.operands |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression in + FcnApp (convert_expression fn, args) | _ -> conversion_failure "Invalid operands to function application" apply.node.location ) |> attach_props apply.node @@ -643,14 +653,14 @@ and convert_record_constructor (apply : Xml.op_appl_node) : Expr.T.expr = and convert_record_operator (apply : Xml.op_appl_node) (constructor : (string * Expr.T.expr) list -> Expr.T.expr_) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [], (_ :: _ as pairs) -> - let mk_field (operand : Xml.expr_or_op_arg) : (string * Expr.T.expr) option = + let mk_field (operand : Xml.expression) : (string * Expr.T.expr) option = match operand with - | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression StringNode {value}; Expression right]} -> ( + | OpApplNode {operator; bound_symbols = []; operands = [Expression StringNode {value}; Expression right]} -> ( match (resolve_ref operator).kind with | BuiltInKind {name = "$Pair"} -> Some (value, convert_expression right) | _ -> None ) | _ -> None - in let fields = List.filter_map mk_field pairs in + in let fields = pairs |> as_expr_ls __FUNCTION__ apply.node.location |> List.filter_map mk_field in if List.length fields <> List.length pairs then conversion_failure "Invalid operands to record operator; expected pairs of expressions" apply.node.location else constructor fields @@ -676,10 +686,8 @@ and convert_except (apply : Xml.op_appl_node) : Expr.T.expr = ( | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression OpApplNode {operator = update_op; bound_symbols = []; operands = update_path}; Expression new_value]} -> ( match (resolve_ref operator).kind, (resolve_ref update_op).kind with | BuiltInKind {name = "$Pair"}, BuiltInKind {name = "$Seq"} -> - let path = List.filter_map (fun (p : Xml.expr_or_op_arg) -> match p with | Expression e -> Some (convert_expression e) | _ -> None) update_path in - if List.length path <> List.length update_path - then conversion_failure "Invalid path in EXCEPT update; expected sequence of expressions" apply.node.location - else Some (List.map mk_path path, convert_expression new_value) + let path = update_path |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression in + Some (List.map mk_path path, convert_expression new_value) | _ -> None ) | _ -> None in let updates_converted = List.filter_map mk_update updates in @@ -869,6 +877,10 @@ and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.the and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with | Expression expr -> {context = Deque.empty; active = convert_expression expr} + | AssumeProve ap -> { + context = Deque.empty; (* TODO: fill in context from ASSUME part *) + active = convert_expression ap.prove; + } (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 6115a80a..e556e5b5 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -520,19 +520,74 @@ let xml_to_built_in_kind xml : built_in_kind = } | _ -> conversion_failure __FUNCTION__ xml +type new_symbol_node = { + node : node; + symbol_ref : int; + domain : expression option; +} +[@@deriving show] + +let xml_to_new_symbol_node (children : tree list) : new_symbol_node = + match extract_inline_node children with + | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue uid])])] -> { + node; + symbol_ref = uid; + domain = None; + } + | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue uid])]); domain] -> { + node; + symbol_ref = uid; + domain = Some (xml_to_expression domain); + } + | _ -> ls_conversion_failure __FUNCTION__ children + +type assume_prove_node = { + node : node; + assumptions : assumption_kind list; + prove : expression; +} +and assumption_kind = + | Expression of expression + | AssumeProve of assume_prove_node + | NewSymbol of new_symbol_node +and expr_or_assume_prove = + | Expression of expression + | AssumeProve of assume_prove_node +[@@deriving show] + +let rec xml_to_assume_prove_node (children : tree list) : assume_prove_node = + match extract_inline_node children with + | node, Node ("assumes", assumptions) :: Node ("prove", [prove]) :: _ -> { + node; + assumptions = List.map xml_to_assumption_kind assumptions; + prove = xml_to_expression prove; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +and xml_to_assumption_kind (xml : tree) : assumption_kind = + match xml with + | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | Node ("NewSymbNode", children) -> NewSymbol (xml_to_new_symbol_node children) + | expr -> Expression (xml_to_expression expr) + +and xml_to_expr_or_assume_prove (xml : tree) : expr_or_assume_prove = + match xml with + | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | expr -> Expression (xml_to_expression expr) + type assume_def_node = { node : node; name : string; - body : expression; + body : expr_or_assume_prove; } [@@deriving show] let xml_to_assume_def_node (children : tree list) : assume_def_node = match extract_inline_node children with - | node, [Node ("uniquename", [SValue name]); Node ("body", [body])] -> { + | node, [Node ("uniquename", [SValue name]); body] -> { node; name; - body = xml_to_expression body; + body = xml_to_expr_or_assume_prove body; } | _ -> ls_conversion_failure __FUNCTION__ children @@ -552,17 +607,6 @@ let xml_to_assume_node (children : tree list) : assume_node = } | _ -> ls_conversion_failure __FUNCTION__ children -type expr_or_assume_prove = - | Expression of expression -(*| AssumeProveLike of assume_prove_like*) -[@@deriving show] - -let xml_to_expr_or_assume_prove (children : tree list) : expr_or_assume_prove = - match children with - | Node ("AssumeProveLike", _) :: _ -> ls_conversion_failure __FUNCTION__ children - | expr :: _ -> Expression (xml_to_expression expr) - | _ -> ls_conversion_failure __FUNCTION__ children - type theorem_def_node = { node : node; name : string; @@ -574,7 +618,7 @@ let xml_to_theorem_def_node xml = match xml with | Node ("TheoremDefNode", children) -> ( match extract_inline_node children with - | node, Node ("uniquename", [SValue name]) :: body -> { + | node, [Node ("uniquename", [SValue name]); body] -> { node; name; body = xml_to_expr_or_assume_prove body @@ -651,7 +695,7 @@ type theorem_node = { let xml_to_theorem_node (children : tree list) : theorem_node = match children |> extract_inline_node |> extract_inline_definition_opt with - | node, definition, Node ("body", body) :: proof -> { + | node, definition, Node ("body", [body]) :: proof -> { node; definition; body = xml_to_expr_or_assume_prove body; @@ -675,7 +719,7 @@ let xml_to_entry_kind (xml : tree) : entry_kind = match xml with | Node ("ModuleNode", children) -> ModuleNode (xml_to_module_node children) | Node ("AssumeNode", children) -> AssumeNode (xml_to_assume_node children) - | Node ("AssumeDefNode", children) -> AssumeDefNode (xml_to_assume_def_node children) + | Node ("AssumeDef", children) -> AssumeDefNode (xml_to_assume_def_node children) | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node xml) | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind xml) | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) From 02622c15f9cff68b971fd4fe661a619a3709f0e1 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Feb 2026 15:09:10 -0800 Subject: [PATCH 50/85] Parsed use-or-hide Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 28 ++++++-- src/sany/xml.ml | 180 ++++++++++++++++++++++++++++++----------------- 2 files changed, 139 insertions(+), 69 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 1547c6e0..32bc298e 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -798,7 +798,12 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp | BuiltInKind builtin -> (match try_convert_builtin builtin with | Some b -> Internal b |> attach_props builtin.node | None -> todo "Built-in operator argument" builtin.name builtin.node.location) - | _ -> conversion_failure ("Invalid operator argument reference: " ^ string_of_int uid) None + | OpDeclNode decl -> Opaque decl.name |> attach_props decl.node + | AssumeNode assume -> conversion_failure "Invalid operator argument reference to ASSUME" assume.node.location + | AssumeDefNode assume -> conversion_failure ("Invalid operator argument reference to ASSUME: " ^ assume.name) assume.node.location + | TheoremNode thm -> conversion_failure "Invalid operator argument reference to THEOREM" thm.node.location + | TheoremDefNode thm -> conversion_failure ("Invalid operator argument reference to THEOREM: " ^ thm.name) thm.node.location + | ModuleNode mule -> conversion_failure ("Invalid operator argument reference to MODULE: " ^ mule.name) mule.node.location (** Converts a basic expression type, which will be either a primitive value or an operator application. @@ -809,9 +814,16 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | StringNode s -> String s.value |> attach_props s.node | OpApplNode apply -> convert_op_appl_node apply | LetInNode let_in -> convert_let_in_node let_in + | LabelNode label -> convert_label label (* TODO: true means @ from EXCEPT, false means @ from proof step (???) *) | AtNode at_node -> At true |> attach_props at_node.node +and convert_label (label : Xml.label_node) : Expr.T.expr = ( + match label.body with + | Expression expr -> Parens (convert_expression expr, noprops Syntax) + | AssumeProve ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) +) |> attach_props label.node + and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = let definitions = List.map (fun ref -> match (resolve_ref ref).kind with @@ -870,6 +882,11 @@ and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.the empty_summary ) |> attach_props thm.node +and convert_assume_prove (ap : Xml.assume_prove_node) : sequent = { + context = Deque.empty; (* TODO: fill in context from ASSUME part *) + active = convert_expression ap.prove; +} + (** Sequents are theorem bodies, which are either simple expressions or ASSUME/PROVE constructs. TODO: handle ASSUME/PROVE @@ -877,10 +894,7 @@ and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.the and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with | Expression expr -> {context = Deque.empty; active = convert_expression expr} - | AssumeProve ap -> { - context = Deque.empty; (* TODO: fill in context from ASSUME part *) - active = convert_expression ap.prove; - } + | AssumeProve ap -> convert_assume_prove ap (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. @@ -919,6 +933,8 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} let step_name = convert_proof_step_name uid proof_level thm.definition in let step = Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name step :: steps, Known (step_number step_name)) + | DefStep _ -> todo "Proof Step" "DefStepNode" None + | UseOrHide _ -> todo "Proof Step" "UseOrHide" None in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = match step with (* TODO: handle other proof step types *) @@ -927,6 +943,8 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} let step_name = convert_proof_step_name uid proof_level thm.definition in let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name qed_step, Known (step_number step_name)) + | DefStep _ -> todo "QED" "DefStepNode" None + | UseOrHide _ -> todo "QED" "UseOrHide" None in let steps, qed = split_steps steps in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps in let qed_step, proof_level = convert_qed_step proof_level qed diff --git a/src/sany/xml.ml b/src/sany/xml.ml index e556e5b5..ab7fd74a 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -271,24 +271,28 @@ type op_appl_node = { operands : expr_or_op_arg list; bound_symbols : symbol list; } -[@@deriving show] and let_in_node = { node : node; def_refs : int list; body : expression; } -[@@deriving show] and at_node = { node : node; } -[@@deriving show] + +and label_node = { + node : node; + arity : int; + body : expr_or_assume_prove; + parameters : int list +} and expression = | AtNode of at_node (*| DecimalNode of decimal_node*) -(*| LabelNode of label_node*) + | LabelNode of label_node | LetInNode of let_in_node | NumeralNode of int literal | OpApplNode of op_appl_node @@ -310,7 +314,6 @@ and bound_symbol = { and symbol = | Unbound of unbound_symbol | Bound of bound_symbol -[@@deriving show] and user_defined_op_kind = { node : node; @@ -320,6 +323,27 @@ and user_defined_op_kind = { params : leibniz_param list; recursive : bool; } + +and assume_prove_node = { + node : node; + assumptions : assumption_kind list; + prove : expression; +} + +and new_symbol_node = { + node : node; + symbol_ref : int; + domain : expression option; +} + +and assumption_kind = + | Expression of expression + | AssumeProve of assume_prove_node + | NewSymbol of new_symbol_node + +and expr_or_assume_prove = + | Expression of expression + | AssumeProve of assume_prove_node [@@deriving show] let rec xml_to_symbols xml = @@ -379,6 +403,55 @@ and xml_to_at_node (children : tree list) : at_node = match extract_inline_node children with | node, _ -> {node} +and xml_to_label_node (children : tree list) : label_node = + match extract_inline_node children with + | node, [ + Node ("uniquename", [SValue name]); + Node ("arity", [IValue arity]); + Node ("body", [body]); + Node ("params", parameters) + ] -> { + node; + arity; + body = xml_to_expr_or_assume_prove body; + parameters = List.map get_ref parameters; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +and xml_to_assume_prove_node (children : tree list) : assume_prove_node = + match extract_inline_node children with + | node, Node ("assumes", assumptions) :: Node ("prove", [prove]) :: _ -> { + node; + assumptions = List.map xml_to_assumption_kind assumptions; + prove = xml_to_expression prove; + } + | _ -> ls_conversion_failure __FUNCTION__ children + +and xml_to_assumption_kind (xml : tree) : assumption_kind = + match xml with + | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | Node ("NewSymbNode", children) -> NewSymbol (xml_to_new_symbol_node children) + | expr -> Expression (xml_to_expression expr) + +and xml_to_new_symbol_node (children : tree list) : new_symbol_node = + match extract_inline_node children with + | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue symbol_ref])])] -> { + node; + symbol_ref; + domain = None; + } + | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue symbol_ref])]); domain] -> { + node; + symbol_ref; + domain = Some (xml_to_expression domain); + } + | _ -> ls_conversion_failure __FUNCTION__ children + +and xml_to_expr_or_assume_prove (xml : tree) : expr_or_assume_prove = + match xml with + | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | expr -> Expression (xml_to_expression expr) + and xml_to_expression (xml : tree) : expression = match xml with | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) @@ -386,6 +459,7 @@ and xml_to_expression (xml : tree) : expression = | Node ("OpApplNode", children) -> OpApplNode (xml_to_op_appl_node children) | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) | Node ("AtNode", children) -> AtNode (xml_to_at_node children) + | Node ("LabelNode", children) -> LabelNode (xml_to_label_node children) | _ -> conversion_failure __FUNCTION__ xml and xml_to_inline_expression children = @@ -445,13 +519,31 @@ let xml_to_instance_node (children : tree list) : instance_node = | _ -> ls_conversion_failure __FUNCTION__ children type use_or_hide_node = { - node : node; + node : node; + facts : expression list; + def_refs : int list; + only : bool; + hide : bool; } [@@deriving show] let xml_to_use_or_hide_node (children : tree list) : use_or_hide_node = match extract_inline_node children with - | node, _ -> {node} + | node, Node ("facts", facts) :: Node ("defs", defs) :: children -> + let (only, hide) = match children with + | [Node ("only", _); Node ("hide", _)] -> (true, true) + | [Node ("only", _)] -> (true, false) + | [Node ("hide", _)] -> (false, true) + | [] -> (false, false) + | _ -> ls_conversion_failure __FUNCTION__ children + in { + node; + facts = List.map xml_to_expression facts; + def_refs = List.map get_ref defs; + only; + hide; + } + | _ -> ls_conversion_failure __FUNCTION__ children type unit_kind = | Ref of int @@ -520,61 +612,6 @@ let xml_to_built_in_kind xml : built_in_kind = } | _ -> conversion_failure __FUNCTION__ xml -type new_symbol_node = { - node : node; - symbol_ref : int; - domain : expression option; -} -[@@deriving show] - -let xml_to_new_symbol_node (children : tree list) : new_symbol_node = - match extract_inline_node children with - | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue uid])])] -> { - node; - symbol_ref = uid; - domain = None; - } - | node, [Node ("OpDeclNodeRef", [Node ("UID", [IValue uid])]); domain] -> { - node; - symbol_ref = uid; - domain = Some (xml_to_expression domain); - } - | _ -> ls_conversion_failure __FUNCTION__ children - -type assume_prove_node = { - node : node; - assumptions : assumption_kind list; - prove : expression; -} -and assumption_kind = - | Expression of expression - | AssumeProve of assume_prove_node - | NewSymbol of new_symbol_node -and expr_or_assume_prove = - | Expression of expression - | AssumeProve of assume_prove_node -[@@deriving show] - -let rec xml_to_assume_prove_node (children : tree list) : assume_prove_node = - match extract_inline_node children with - | node, Node ("assumes", assumptions) :: Node ("prove", [prove]) :: _ -> { - node; - assumptions = List.map xml_to_assumption_kind assumptions; - prove = xml_to_expression prove; - } - | _ -> ls_conversion_failure __FUNCTION__ children - -and xml_to_assumption_kind (xml : tree) : assumption_kind = - match xml with - | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) - | Node ("NewSymbNode", children) -> NewSymbol (xml_to_new_symbol_node children) - | expr -> Expression (xml_to_expression expr) - -and xml_to_expr_or_assume_prove (xml : tree) : expr_or_assume_prove = - match xml with - | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) - | expr -> Expression (xml_to_expression expr) - type assume_def_node = { node : node; name : string; @@ -642,11 +679,24 @@ let xml_to_by_proof_node (children : tree list) : by_proof_node = } | _ -> ls_conversion_failure __FUNCTION__ children +type def_proof_step = { + node : node; + def_refs : int list; +} +[@@deriving show] + +let xml_to_def_proof_step (children : tree list) : def_proof_step = + match extract_inline_node children with + | node, defs -> { + node; + def_refs = List.map get_ref defs; + } + type proof_step_group = | TheoremNodeRef of int + | DefStep of def_proof_step + | UseOrHide of use_or_hide_node (* TODO - | DefStepNode - | UseOrHideNode | InstanceNode | TheoremNode *) @@ -662,6 +712,8 @@ let xml_to_steps_proof_node (children : tree list) : steps_proof_node = let xml_to_proof_step_group xml = match xml with | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> TheoremNodeRef uid + | Node ("DefStepNode", children) -> DefStep (xml_to_def_proof_step children) + | Node ("UseOrHideNode", children) -> UseOrHide (xml_to_use_or_hide_node children) | _ -> conversion_failure __FUNCTION__ xml in match extract_inline_node children with | node, steps ->{ From a5511642cdbd22e9e4d4c4bdcecd040f7848b1ff Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 4 Feb 2026 17:39:30 -0800 Subject: [PATCH 51/85] Converted use-or-hide Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 32bc298e..023bc522 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -220,6 +220,14 @@ let resolve_bound_symbol (uid : int) : hint = | Some (Xml.FormalParamNode _) -> conversion_failure ("Bound symbol cannot be an operator: " ^ string_of_int uid) None | _ -> conversion_failure ("Unresolved formal parameter node UID: " ^ string_of_int uid) None +(** Resolves definitions referenced in BY proofs or USE/HIDE statements. +*) +let resolve_def (node : Xml.node) (ref : int) : use_def wrapped = + match (resolve_ref ref).kind with + | UserDefinedOpKind op -> Dvar op.name |> attach_props op.node + | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node + | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location + let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def_ref : int option) : stepno = match theorem_def_ref with | Some uid -> parse_proof_step_name proof_level uid (resolve_theorem_def_node uid).name @@ -369,8 +377,15 @@ and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( | None -> Anoninst (instantiation, Export) ) |> attach_props instance.node +and convert_usable (use_or_hide : Xml.use_or_hide_node) : Proof.T.usable = { + facts = List.map convert_expression use_or_hide.facts; + defs = List.map (resolve_def use_or_hide.node) use_or_hide.def_refs; +} + and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = - todo "UseOrHide" "" use_or_hide.node.location + (* TODO: confirm `Use boolean parameter really is the ONLY keyword *) + let action = if use_or_hide.hide then `Hide else `Use use_or_hide.only in + Mutate (action, convert_usable use_or_hide) |> attach_props use_or_hide.node and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = Module.T.Axiom ( @@ -933,8 +948,9 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} let step_name = convert_proof_step_name uid proof_level thm.definition in let step = Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name step :: steps, Known (step_number step_name)) - | DefStep _ -> todo "Proof Step" "DefStepNode" None - | UseOrHide _ -> todo "Proof Step" "UseOrHide" None + | DefStep def -> todo "Proof Step" "DefStepNode" None + (* TODO: confirm boolean parameter corresponds to ONLY keyword *) + | UseOrHide use_or_hide -> ((Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level) in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = match step with (* TODO: handle other proof step types *) @@ -960,14 +976,9 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} strings that will need to be resolved to De Bruijn indices later on. *) and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = - let resolve_def (ref : int) : use_def wrapped = - match (resolve_ref ref).kind with - | UserDefinedOpKind op -> Dvar op.name |> attach_props op.node - | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node - | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location - in By ({ + By ({ facts = List.map convert_expression facts; - defs = List.map resolve_def defs; + defs = List.map (resolve_def node) defs; }, true (* This should be true if the ONLY keyword is present *) ) |> attach_props node From 4892ec66fedbbfa2da67dfae50aaa0ef1665bc40 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 6 Feb 2026 12:19:07 -0800 Subject: [PATCH 52/85] XML parsing improved for BoundSymbol, OpDeclNode, UserDefinedOpNode Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 16 +++---- src/sany/xml.ml | 117 ++++++++++++++++++++++++++++++++--------------- 2 files changed, 86 insertions(+), 47 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 023bc522..59279c0c 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -400,9 +400,9 @@ and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = *) and convert_op_decl_node (xml : Xml.op_decl_node) : Module.T.modunit = match xml.kind with - | 2 -> attach_props xml.node (Constants [attach_props xml.node xml.name, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n]) - | 3 -> attach_props xml.node (Variables [attach_props xml.node xml.name]) - | _ -> todo "Operator declaration kind" (string_of_int xml.kind) xml.node.location + | Constant -> attach_props xml.node (Constants [attach_props xml.node xml.name, match xml.arity with | 0 -> Shape_expr | n -> Shape_op n]) + | Variable -> attach_props xml.node (Variables [attach_props xml.node xml.name]) + | _ -> todo "Operator declaration kind" (Xml.show_declaration_kind xml.kind) xml.node.location (** Converts fairness expressions such as WF_sub(expr) and SF_sub(expr). *) @@ -947,20 +947,18 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in let step = Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in - (attach_proof_step_name step_name step :: steps, Known (step_number step_name)) - | DefStep def -> todo "Proof Step" "DefStepNode" None + attach_proof_step_name step_name step :: steps, Known (step_number step_name) + | DefStep {node; def_refs} -> todo "Proof Step" "DefStepNode" node.location (* TODO: confirm boolean parameter corresponds to ONLY keyword *) - | UseOrHide use_or_hide -> ((Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level) + | UseOrHide use_or_hide -> (Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = match step with - (* TODO: handle other proof step types *) | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in (attach_proof_step_name step_name qed_step, Known (step_number step_name)) - | DefStep _ -> todo "QED" "DefStepNode" None - | UseOrHide _ -> todo "QED" "UseOrHide" None + | _ -> conversion_failure "Final proof step must be a theorem reference (QED)" node.location in let steps, qed = split_steps steps in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps in let qed_step, proof_level = convert_qed_step proof_level qed diff --git a/src/sany/xml.ml b/src/sany/xml.ml index ab7fd74a..ef9331e2 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -69,7 +69,7 @@ let ls_conversion_failure (fn_name : string) (children : tree list) : 'a = *) let is_tag (tag_name : string) (node : tree) : bool = match node with - | Node (name, _) -> String.equal name tag_name + | Node (name, _) when name = tag_name -> true | _ -> false (** Utility function that simply returns the children of an XML node. Raises @@ -89,22 +89,35 @@ let child_of (xml : tree) : tree = | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise +(** Searches for an optional tag in the children of an XML node. +*) +let find_tag_opt (tag_name : string) (children : tree list) : tree option = + List.find_opt (is_tag tag_name) children + (** Searches for a tag in the children of an XML node, and raises a detailed exception if it is not found. *) let find_tag (tag_name : string) (children : tree list) : tree = - match List.find_opt (is_tag tag_name) children with + match find_tag_opt tag_name children with | Some v -> v | None -> ls_conversion_failure __FUNCTION__ children +(** Utility function to extract the string value from a tagged XML node which + may or may not be present. +*) +let xml_to_tagged_string_opt (tag_name : string) (children : tree list) : string option = + match find_tag_opt tag_name children with + | Some (Node (_, [SValue s])) -> Some s + | _ -> None + (** Utility function to extract the string value from a tagged XML node. Raises a detailed exception if the tag is not found or if the tagged node does not contain a single string value. *) let xml_to_tagged_string (tag_name : string) (children : tree list) : string = - match find_tag tag_name children with - | (Node (_, [SValue s])) -> s - | xml -> conversion_failure __FUNCTION__ xml + match xml_to_tagged_string_opt tag_name children with + | Some s -> s + | None -> ls_conversion_failure __FUNCTION__ children (** Utility function to extract the int value from a tagged XML node. Raises a detailed exception if the tag is not found or if the tagged node @@ -319,6 +332,7 @@ and user_defined_op_kind = { node : node; name : string; arity : int; + precomments : string option; body : expression; params : leibniz_param list; recursive : bool; @@ -349,17 +363,27 @@ and expr_or_assume_prove = let rec xml_to_symbols xml = match xml with | Node ("unbound", _) -> Unbound (xml_to_unbound_symbol xml) - | Node ("bound", _) -> Bound (xml_to_bound_symbol xml) + | Node ("bound", children) -> Bound (xml_to_bound_symbol children) | _ -> conversion_failure __FUNCTION__ xml -and xml_to_bound_symbol xml = - match xml with - | Node ("bound", children) -> { - symbol_refs = children |> List.filter_map get_ref_opt; - is_tuple = children |> List.exists (is_tag "tuple"); - expression = children |> xml_to_inline_expression |> Option.get; - } - | _ -> conversion_failure __FUNCTION__ xml +and xml_to_bound_symbol (children : tree list) : bound_symbol = + let rec consume_symbol_refs (acc : int list) (children : tree list) : int list * tree list = + match children with + | Node ("FormalParamNodeRef", [Node ("UID", [IValue symbol_ref])]) :: rest -> + consume_symbol_refs (symbol_ref :: acc) rest + | _ -> (List.rev acc, children) + in match consume_symbol_refs [] children with + | symbol_refs, [Node ("tuple", _); expression] -> { + symbol_refs; + is_tuple = true; + expression = xml_to_expression expression; + } + | symbol_refs, [expression] -> { + symbol_refs; + is_tuple = false; + expression = xml_to_expression expression; + } + | _ -> ls_conversion_failure __FUNCTION__ children and xml_to_expr_or_op_arg (xml : tree) : expr_or_op_arg = match xml with @@ -462,23 +486,18 @@ and xml_to_expression (xml : tree) : expression = | Node ("LabelNode", children) -> LabelNode (xml_to_label_node children) | _ -> conversion_failure __FUNCTION__ xml -and xml_to_inline_expression children = - children - |> List.find_opt (fun xml -> is_tag "NumeralNode" xml || is_tag "OpApplNode" xml) - |> Option.map xml_to_expression - -and xml_to_user_defined_op_kind xml : user_defined_op_kind = - match xml with - | Node ("UserDefinedOpKind", children) -> - let (node, children) = extract_inline_node children in { +and xml_to_user_defined_op_kind (children : tree list) : user_defined_op_kind = + match extract_inline_node children with + | node, Node ("uniquename", [SValue name]) :: Node ("arity", [IValue arity]) :: children -> { node; - name = children |> xml_to_tagged_string "uniquename"; - arity = children |> xml_to_tagged_int "arity"; + name; + arity; + precomments = children |> xml_to_tagged_string_opt "pre-comments"; body = children |> find_tag "body" |> child_of |> xml_to_expression; - params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; + params = children |> find_tag "params" |> children_of |> List.map xml_to_leibniz_param; recursive = children |> List.exists (is_tag "recursive"); } - | _ -> conversion_failure __FUNCTION__ xml + | _ -> ls_conversion_failure __FUNCTION__ children type substitution = { target_uid : int; @@ -574,24 +593,46 @@ let xml_to_module_node (children : tree list) : module_node = } | _ -> ls_conversion_failure __FUNCTION__ children +type declaration_kind = + | Constant + | Variable + | BoundSymbol + | NewConstant + | NewVariable + | NewState + | NewAction + | NewTemporal +[@@deriving show] + +let xml_to_declaration_kind (kind : int) : declaration_kind = + match kind with + | 2 -> Constant + | 3 -> Variable + | 4 -> BoundSymbol + | 24 -> NewConstant + | 25 -> NewVariable + | 26 -> NewState + | 27 -> NewAction + | 28 -> NewTemporal + | _ -> conversion_failure __FUNCTION__ (IValue kind) + type op_decl_node = { node : node; name : string; arity : int; - kind : int; + kind : declaration_kind; } [@@deriving show] -let xml_to_op_decl_node (xml : tree) : op_decl_node = - match xml with - | Node ("OpDeclNode", children) -> - let (node, children) = extract_inline_node children in { +let xml_to_op_decl_node (children : tree list) : op_decl_node = + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity]); Node ("kind", [IValue kind])] -> { node; - name = children |> xml_to_tagged_string "uniquename"; - arity = children |> xml_to_tagged_int "arity"; - kind = children |> xml_to_tagged_int "kind"; + name; + arity; + kind = xml_to_declaration_kind kind; } - | _ -> conversion_failure __FUNCTION__ xml + | _ -> ls_conversion_failure __FUNCTION__ children type built_in_kind = { node : node; @@ -772,8 +813,8 @@ let xml_to_entry_kind (xml : tree) : entry_kind = | Node ("ModuleNode", children) -> ModuleNode (xml_to_module_node children) | Node ("AssumeNode", children) -> AssumeNode (xml_to_assume_node children) | Node ("AssumeDef", children) -> AssumeDefNode (xml_to_assume_def_node children) - | Node ("OpDeclNode", _) -> OpDeclNode (xml_to_op_decl_node xml) - | Node ("UserDefinedOpKind", _) -> UserDefinedOpKind (xml_to_user_defined_op_kind xml) + | Node ("OpDeclNode", children) -> OpDeclNode (xml_to_op_decl_node children) + | Node ("UserDefinedOpKind", children) -> UserDefinedOpKind (xml_to_user_defined_op_kind children) | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node xml) | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node xml) From 45e4b4fd2330701c463d652a5293d7f4158f604d Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 6 Feb 2026 14:48:15 -0800 Subject: [PATCH 53/85] Convert CASE proof step Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 101 +++++++++++++++++++++++++++++++-------------- src/sany/xml.ml | 104 ++++++++++++++++++++--------------------------- 2 files changed, 114 insertions(+), 91 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 59279c0c..5392a254 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -169,11 +169,20 @@ let resolve_module_node (uid : int) : Xml.module_node = | ModuleNode mule -> mule | _ -> conversion_failure ("Expected module node for UID: " ^ string_of_int uid) None +(** A typed version of resolve_ref for operator declaration nodes. +*) let resolve_op_decl_node (uid : int) : Xml.op_decl_node = match (resolve_ref uid).kind with | OpDeclNode odn -> odn | _ -> conversion_failure ("Expected operator declaration node for UID: " ^ string_of_int uid) None +(** A typed version of resolve_ref for user-defined operators. +*) +let resolve_user_defined_op_kind (uid : int) : Xml.user_defined_op_kind = + match (resolve_ref uid).kind with + | UserDefinedOpKind udok -> udok + | _ -> conversion_failure ("Expected user defined operator for UID: " ^ string_of_int uid) None + (** A typed version of resolve_ref for operator parameter nodes. *) let resolve_formal_param_node (uid : int) : Xml.formal_param_node = @@ -922,6 +931,18 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no | Some By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some Steps proof -> convert_proof_steps uid previous_proof_level proof +(** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place + where information is lost, as the facts and definitions are converted to + strings that will need to be resolved to De Bruijn indices later on. +*) +and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = + By ({ + facts = List.map convert_expression facts; + defs = List.map (resolve_def node) defs; + }, + true (* This should be true if the ONLY keyword is present *) +) |> attach_props node + (** One possible proof form is a series of steps, culminating in a QED step. This method converts that structure. This is the most complex part of the proof conversion, primarily due to the necessity of appending proof step @@ -936,29 +957,17 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no AST node. *) and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = - let rec split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * Xml.proof_step_group) = + (* Splits the proof steps into ordinary proof steps and a final QED step. *) + let split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * int) = match List.rev steps with | [] -> conversion_failure "Step-based proofs must have at least one step" node.location - | last :: rest -> (List.rev rest, last) - in let convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (step : Xml.proof_step_group) : Proof.T.step list * proof_level = - match step with - (* TODO: handle other proof step types *) - | TheoremNodeRef uid -> - let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name uid proof_level thm.definition in - let step = Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in - attach_proof_step_name step_name step :: steps, Known (step_number step_name) - | DefStep {node; def_refs} -> todo "Proof Step" "DefStepNode" node.location - (* TODO: confirm boolean parameter corresponds to ONLY keyword *) - | UseOrHide use_or_hide -> (Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level - in let convert_qed_step (proof_level : proof_level) (step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = - match step with - | TheoremNodeRef uid -> - let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name uid proof_level thm.definition in - let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in - (attach_proof_step_name step_name qed_step, Known (step_number step_name)) - | _ -> conversion_failure "Final proof step must be a theorem reference (QED)" node.location + | TheoremNodeRef uid :: rest -> (List.rev rest, uid) + | _ -> conversion_failure "Final (QED) step of a step-based proof must be a theorem reference" node.location + in let convert_qed_step (proof_level : proof_level) (uid : int) : Proof.T.qed_step * proof_level = + let thm = resolve_theorem_node uid in + let step_name = convert_proof_step_name uid proof_level thm.definition in + let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in + attach_proof_step_name step_name qed_step, Known (step_number step_name) in let steps, qed = split_steps steps in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps in let qed_step, proof_level = convert_qed_step proof_level qed @@ -969,17 +978,47 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} |> attach_props node |> attach_proof_step_name (Unnamed (proof_level, uid)) -(** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place - where information is lost, as the facts and definitions are converted to - strings that will need to be resolved to De Bruijn indices later on. +(** Converts a specific proof step into the Proof.T.step variant expected by + TLAPM. While TLAPM has thirteen proof variants as of this writing, SANY + bundles everything into only five: DefStepNode (where the user introduces + new operator definitions into scope), UseOrHideNode, InstanceNode (removed + from TLA+; see https://github.com/tlaplus/rfcs/issues/18), TheoremNodeRef, + and TheoremNode. In keeping with the odd duplication of purpose between + TheoremDefNode and TheoremNode, the TheoremNode type is not believed to be + used. TheoremNodeRef is the real workhorse proof step type, as it is used + for all proof step types that can have sub-proofs. The specific proof step + subtype is identified by a special built-in operator as the theorem body. + + This function has an odd type signature because it's intended for use in + a List.fold_left over the list of proof steps; the reason we need to do + this is to identify the proof level of this proof by parsing the actual + proof step names, then propagating this knowledge forward in the fold. + The resulting list of proof steps is returned in reverse order, and must + be reversed to be in the correct order for TLAPM. *) -and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = - By ({ - facts = List.map convert_expression facts; - defs = List.map (resolve_def node) defs; - }, - true (* This should be true if the ONLY keyword is present *) -) |> attach_props node +and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (step : Xml.proof_step_group) : Proof.T.step list * proof_level = + match step with + | InstanceNode {node} -> conversion_failure "INSTANCE proof steps are deprecated from the TLA+ language standard" node.location + | TheoremNode -> todo "TheoremNode proof step" "" None + (* TODO: attach name to DefStep step *) + | DefStep {node; def_refs} -> + let step = Define (def_refs |> List.map resolve_user_defined_op_kind |> List.map convert_user_defined_op_kind) |> attach_props node in + step :: steps, proof_level + (* TODO: confirm boolean parameter corresponds to ONLY keyword *) + (* TODO: attach name to UseOrHide step *) + | UseOrHide use_or_hide -> (Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level + | TheoremNodeRef uid -> + let is_op (uid : int) (op_name : string) : bool = + match (resolve_ref uid).kind with + | BuiltInKind op when op.name = op_name -> true + | _ -> false + in let thm = resolve_theorem_node uid in + let step_name = convert_proof_step_name uid proof_level thm.definition in + let step = match thm.body with + | Expression OpApplNode {operands = [Expression expr]; operator} when is_op operator "$Pfcase" -> + Pcase (convert_expression expr, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node + | _ -> Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node + in attach_proof_step_name step_name step :: steps, Known (step_number step_name) (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those diff --git a/src/sany/xml.ml b/src/sany/xml.ml index ef9331e2..070001d2 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -1,6 +1,9 @@ (** This module provides functions to interact with SANY to parse TLA+ source files into an XML representation, and then convert that XML representation - into something with a semblance of a type system. + into something with a semblance of a type system. For example, different + node types will have fields of type int or string or even a variant. This + makes it much more tractable to convert SANY's XML output into the format + expected by TLAPM. *) (** Calls SANY in another process to parse the given TLA+ file, then collects @@ -119,18 +122,6 @@ let xml_to_tagged_string (tag_name : string) (children : tree list) : string = | Some s -> s | None -> ls_conversion_failure __FUNCTION__ children -(** Utility function to extract the int value from a tagged XML node. - Raises a detailed exception if the tag is not found or if the tagged node - does not contain a single int value. -*) -let xml_child_to_int (xml : tree) : int = - match xml with - | (Node (_, [IValue n])) -> n - | _ -> conversion_failure __FUNCTION__ xml - -let xml_to_tagged_int (tag_name : string) (children : tree list) : int = - find_tag tag_name children |> xml_child_to_int - (** Use this in conjunction with List.filter_map on children of a node to get all references of various types. *) @@ -256,13 +247,10 @@ type formal_param_node = { } [@@deriving show] -let xml_to_formal_param_node xml = - match xml with - | Node ("FormalParamNode", children) -> ( - match extract_inline_node children with - | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> {node; name; arity} - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_formal_param_node (children : tree list) : formal_param_node = + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> {node; name; arity} + | _ -> ls_conversion_failure __FUNCTION__ children type unbound_symbol = { symbol_ref : int; @@ -389,11 +377,7 @@ and xml_to_expr_or_op_arg (xml : tree) : expr_or_op_arg = match xml with | Node ("OpArgNode", children) -> ( match extract_inline_node children with - | node, [Node ("argument", [argument])] -> ( - match get_ref_opt argument with - | Some uid -> OpArg uid - | None -> conversion_failure __FUNCTION__ argument - ) + | node, [Node ("argument", [argument])] -> OpArg (get_ref argument) | _ -> conversion_failure __FUNCTION__ xml ) | _ -> Expression (xml_to_expression xml) @@ -642,16 +626,21 @@ type built_in_kind = { } [@@deriving show] -let xml_to_built_in_kind xml : built_in_kind = - match xml with - | Node ("BuiltInKind", children) -> - let (node, children) = extract_inline_node children in { +let xml_to_built_in_kind (children : tree list) : built_in_kind = + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity]); Node ("params", params)] -> { node; - name = children |> xml_to_tagged_string "uniquename"; - arity = children |> xml_to_tagged_int "arity"; - params = children |> List.find_opt (is_tag "params") |> Option.map children_of |> Option.value ~default:[] |> List.map xml_to_leibniz_param; + name; + arity; + params = List.map xml_to_leibniz_param params; } - | _ -> conversion_failure __FUNCTION__ xml + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> { + node; + name; + arity; + params = []; + } + | _ -> ls_conversion_failure __FUNCTION__ children type assume_def_node = { node : node; @@ -692,17 +681,14 @@ type theorem_def_node = { } [@@deriving show] -let xml_to_theorem_def_node xml = - match xml with - | Node ("TheoremDefNode", children) -> ( - match extract_inline_node children with - | node, [Node ("uniquename", [SValue name]); body] -> { - node; - name; - body = xml_to_expr_or_assume_prove body - } - | _ -> conversion_failure __FUNCTION__ xml) - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_theorem_def_node (children : tree list) : theorem_def_node = + match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); body] -> { + node; + name; + body = xml_to_expr_or_assume_prove body + } +| _ -> ls_conversion_failure __FUNCTION__ children type by_proof_node = { node : node; @@ -737,10 +723,8 @@ type proof_step_group = | TheoremNodeRef of int | DefStep of def_proof_step | UseOrHide of use_or_hide_node - (* TODO - | InstanceNode + | InstanceNode of instance_node | TheoremNode - *) [@@deriving show] type steps_proof_node = { @@ -755,6 +739,7 @@ let xml_to_steps_proof_node (children : tree list) : steps_proof_node = | Node ("TheoremNodeRef", [Node ("UID", [IValue uid])]) -> TheoremNodeRef uid | Node ("DefStepNode", children) -> DefStep (xml_to_def_proof_step children) | Node ("UseOrHideNode", children) -> UseOrHide (xml_to_use_or_hide_node children) + | Node ("InstanceNode", children) -> InstanceNode (xml_to_instance_node children) | _ -> conversion_failure __FUNCTION__ xml in match extract_inline_node children with | node, steps ->{ @@ -769,15 +754,6 @@ type proof_node_group = | Steps of steps_proof_node [@@deriving show] -let xml_to_inline_proof_node_group (children : tree list) : proof_node_group option = - match children with - | Node ("omitted", children) :: _ -> let (node, _) = extract_inline_node children in Some (Omitted node) - | Node ("obvious", children) :: _ -> let (node, _) = extract_inline_node children in Some (Obvious node) - | Node ("by", children) :: _ -> Some (By (xml_to_by_proof_node children)) - | Node ("steps", children) :: _ -> Some (Steps (xml_to_steps_proof_node children)) - | [] -> None - | _ -> ls_conversion_failure __FUNCTION__ children - type theorem_node = { node : node; definition : int option; @@ -787,7 +763,15 @@ type theorem_node = { [@@deriving show] let xml_to_theorem_node (children : tree list) : theorem_node = - match children |> extract_inline_node |> extract_inline_definition_opt with + let xml_to_inline_proof_node_group (children : tree list) : proof_node_group option = + match children with + | Node ("omitted", children) :: _ -> let (node, _) = extract_inline_node children in Some (Omitted node) + | Node ("obvious", children) :: _ -> let (node, _) = extract_inline_node children in Some (Obvious node) + | Node ("by", children) :: _ -> Some (By (xml_to_by_proof_node children)) + | Node ("steps", children) :: _ -> Some (Steps (xml_to_steps_proof_node children)) + | [] -> None + | _ -> ls_conversion_failure __FUNCTION__ children + in match children |> extract_inline_node |> extract_inline_definition_opt with | node, definition, Node ("body", [body]) :: proof -> { node; definition; @@ -815,9 +799,9 @@ let xml_to_entry_kind (xml : tree) : entry_kind = | Node ("AssumeDef", children) -> AssumeDefNode (xml_to_assume_def_node children) | Node ("OpDeclNode", children) -> OpDeclNode (xml_to_op_decl_node children) | Node ("UserDefinedOpKind", children) -> UserDefinedOpKind (xml_to_user_defined_op_kind children) - | Node ("BuiltInKind", _) -> BuiltInKind (xml_to_built_in_kind xml) - | Node ("FormalParamNode", _) -> FormalParamNode (xml_to_formal_param_node xml) - | Node ("TheoremDefNode", _) -> TheoremDefNode (xml_to_theorem_def_node xml) + | Node ("BuiltInKind", children) -> BuiltInKind (xml_to_built_in_kind children) + | Node ("FormalParamNode", children) -> FormalParamNode (xml_to_formal_param_node children) + | Node ("TheoremDefNode", children) -> TheoremDefNode (xml_to_theorem_def_node children) | Node ("TheoremNode", children)-> TheoremNode (xml_to_theorem_node children) | _ -> conversion_failure __FUNCTION__ xml From c1f19e2c736619043746cdfb18d6638f67e7e813 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 6 Feb 2026 15:29:11 -0800 Subject: [PATCH 54/85] Convert PICK proof step Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 31 +++++++++++++++++++++++++++---- 1 file changed, 27 insertions(+), 4 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 5392a254..f4c9c196 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1014,11 +1014,34 @@ and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (s | _ -> false in let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in + let proof = convert_proof uid (step_number step_name) thm.proof in let step = match thm.body with - | Expression OpApplNode {operands = [Expression expr]; operator} when is_op operator "$Pfcase" -> - Pcase (convert_expression expr, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node - | _ -> Suffices (convert_sequent thm.body, convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node - in attach_proof_step_name step_name step :: steps, Known (step_number step_name) + | Expression OpApplNode ({operator} as apply) when is_op operator "$Pfcase" -> + convert_case_proof_step apply proof + | Expression OpApplNode ({operator} as apply) when is_op operator "$Pick" -> + convert_pick_proof_step apply proof + | _ -> Suffices (convert_sequent thm.body, proof) + in (step |> attach_props thm.node |> attach_proof_step_name step_name) :: steps, Known (step_number step_name) + +(** Converts CASE proof steps, like: <2>7. CASE UNCHANGED vars +*) +and convert_case_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = + match apply.bound_symbols, apply.operands with + | [], [Expression expr] -> Pcase (convert_expression expr, proof) + | _ -> conversion_failure "Invalid operands to CASE proof step" apply.node.location + +(** Converts PICK proofs steps, like PICK i \in 1 .. Len(s) : P(i) + This is yet another conversion where quantifiers rear their tedious head. + In this case, only a single bound is supported. +*) +and convert_pick_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = ( + match apply.bound_symbols, apply.operands with + | [Bound ({is_tuple = false} as bound)], [Expression predicate] -> + Pick (convert_non_tuply_bounds apply.node bound, convert_expression predicate, proof) + | [Bound ({is_tuple = true} as bound)], [Expression predicate] -> + PickTuply (convert_tuply_bounds apply.node bound, convert_expression predicate, proof) + | _ -> conversion_failure "Invalid bounds or operands to PICK proof step" apply.node.location; +) (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those From 35ec791990fe3c1c09928494b489e68b26aee9cf Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 6 Feb 2026 16:33:40 -0800 Subject: [PATCH 55/85] Parse XML for all expression types Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 21 ++++++++++++-------- src/sany/xml.ml | 50 +++++++++++++++++++++++++++--------------------- 2 files changed, 41 insertions(+), 30 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index f4c9c196..1faa8375 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -805,6 +805,8 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl (* A reference to a named THEOREM or a proof step *) | TheoremDefNode thm -> Opaque thm.name |> attach_props thm.node + (* A reference to a named ASSUME node *) + | AssumeDefNode assume -> Opaque assume.name |> attach_props assume.node | _ -> conversion_failure ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind)) apply.node.location (** Some places in TLA⁺ syntax allow both normal expressions and also @@ -834,13 +836,17 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp *) and convert_expression (expr : Xml.expression) : Expr.T.expr = match expr with - | NumeralNode n -> Num (Int.to_string n.value, "") |> attach_props n.node - | StringNode s -> String s.value |> attach_props s.node - | OpApplNode apply -> convert_op_appl_node apply - | LetInNode let_in -> convert_let_in_node let_in - | LabelNode label -> convert_label label (* TODO: true means @ from EXCEPT, false means @ from proof step (???) *) | AtNode at_node -> At true |> attach_props at_node.node + | DecimalNode (mantissa, exponent) -> todo "Decimal literals" (Int.to_string mantissa ^ "e" ^ Int.to_string exponent) None + | LabelNode label -> convert_label label + | LetInNode let_in -> convert_let_in_node let_in + | NumeralNode n -> Num (Int.to_string n.value, "") |> attach_props n.node + | OpApplNode apply -> convert_op_appl_node apply + | StringNode s -> String s.value |> attach_props s.node + | SubstInNode subst -> todo "SubstInNode" "" subst.node.location + | TheoremDefRef uid -> todo "Expression" "TheoremDefRef" None + | AssumeDefRef uid -> todo "Expression" "AssumeDefRef" None and convert_label (label : Xml.label_node) : Expr.T.expr = ( match label.body with @@ -1034,14 +1040,13 @@ and convert_case_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : This is yet another conversion where quantifiers rear their tedious head. In this case, only a single bound is supported. *) -and convert_pick_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = ( +and convert_pick_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = match apply.bound_symbols, apply.operands with | [Bound ({is_tuple = false} as bound)], [Expression predicate] -> Pick (convert_non_tuply_bounds apply.node bound, convert_expression predicate, proof) | [Bound ({is_tuple = true} as bound)], [Expression predicate] -> PickTuply (convert_tuply_bounds apply.node bound, convert_expression predicate, proof) - | _ -> conversion_failure "Invalid bounds or operands to PICK proof step" apply.node.location; -) + | _ -> conversion_failure "Invalid bounds or operands to PICK proof step" apply.node.location (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 070001d2..174ab370 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -210,21 +210,15 @@ type 'a literal = { } [@@deriving show] -let xml_to_numeral_node (xml : tree) : int literal = - match xml with - | Node ("NumeralNode", children) -> ( - match extract_inline_node children with - | node, [Node ("IntValue", [IValue value])] -> {node; value} - | _ -> ls_conversion_failure __FUNCTION__ children) - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_numeral_node (children : tree list) : int literal = + match extract_inline_node children with + | node, [Node ("IntValue", [IValue value])] -> {node; value} + | _ -> ls_conversion_failure __FUNCTION__ children -let xml_to_string_node (xml : tree) : string literal = - match xml with - | Node ("StringNode", children) -> ( - match extract_inline_node children with - | node, [Node ("StringValue", [SValue value])] -> {node; value} - | _ -> ls_conversion_failure __FUNCTION__ children) - | _ -> conversion_failure __FUNCTION__ xml +let xml_to_string_node (children : tree list) : string literal = + match extract_inline_node children with + | node, [Node ("StringValue", [SValue value])] -> {node; value} + | _ -> ls_conversion_failure __FUNCTION__ children type leibniz_param = { ref : int; @@ -290,17 +284,21 @@ and label_node = { parameters : int list } +and subst_in_node = { + node : node; +} + and expression = | AtNode of at_node -(*| DecimalNode of decimal_node*) + | DecimalNode of int * int | LabelNode of label_node | LetInNode of let_in_node | NumeralNode of int literal | OpApplNode of op_appl_node | StringNode of string literal -(*| SubstInNode of subst_in_node*) -(*| TheoremDefRef of theorem_def_ref*) -(*| AssumeDefRef of assume_def_ref*) + | SubstInNode of subst_in_node + | TheoremDefRef of int + | AssumeDefRef of int and expr_or_op_arg = | Expression of expression @@ -460,14 +458,22 @@ and xml_to_expr_or_assume_prove (xml : tree) : expr_or_assume_prove = | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) | expr -> Expression (xml_to_expression expr) +and xml_to_subst_in_node (children : tree list) : subst_in_node = + match extract_inline_node children with + | node, _ -> {node} + and xml_to_expression (xml : tree) : expression = match xml with - | Node ("NumeralNode", _) -> NumeralNode (xml_to_numeral_node xml) - | Node ("StringNode", _) -> StringNode (xml_to_string_node xml) - | Node ("OpApplNode", children) -> OpApplNode (xml_to_op_appl_node children) - | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) | Node ("AtNode", children) -> AtNode (xml_to_at_node children) + | Node ("DecimalNode", [Node ("mantissa", [IValue mantissa]); Node ("exponent", [IValue exponent])]) -> DecimalNode (mantissa, exponent) | Node ("LabelNode", children) -> LabelNode (xml_to_label_node children) + | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) + | Node ("NumeralNode", children) -> NumeralNode (xml_to_numeral_node children) + | Node ("OpApplNode", children) -> OpApplNode (xml_to_op_appl_node children) + | Node ("StringNode", children) -> StringNode (xml_to_string_node children) + | Node ("SubstInNode", children) -> SubstInNode (xml_to_subst_in_node children) + | Node ("TheoremDefRef", [Node ("UID", [IValue uid])]) -> TheoremDefRef uid + | Node ("AssumeDefRef", [Node ("UID", [IValue uid])]) -> AssumeDefRef uid | _ -> conversion_failure __FUNCTION__ xml and xml_to_user_defined_op_kind (children : tree list) : user_defined_op_kind = From dba893283259390271bb4e86142152a4f6a922bb Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 9 Feb 2026 14:19:54 -0800 Subject: [PATCH 56/85] Convert PICK and TAKE proof steps properly Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 330 +++++++++++++++++++++++++++------------- src/sany/xml.ml | 63 +++++--- test/sany/sany_tests.ml | 17 +++ 3 files changed, 285 insertions(+), 125 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 1faa8375..dae53182 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -25,6 +25,24 @@ abstract which is presented to us here. Thus the SANY AST has already been processed significantly, and we are translating it to a form that is comparatively much rougher & earlier in the parse process. + + There are two places in this conversion code where we revert to actually + just parsing the underlying "raw" TLA+ syntax from SANY's AST: proof names + and references to named instanced modules. We need to parse proof names + because we have to extract the proof level, which TLAPM expects as some + metadata attached to proof objects. SANY could possibly be modified to + export proof level data with its XML, but for now we just extract the + level from the proof name. We need to parse references to named instanced + modules because if a module is imported with M == INSTANCE Modname, all + definitions from Modname will be inlined in the importing module while + prefixed like M!Defname. This is mostly fine because TLAPM runs its own + De Bruijn-index-based name resolution algorithm, except for the case where + Defname == OtherDefname. Then when analyzing M!Defname, TLAPM will search + for OtherDefname instead of M!OtherDefname. Thus we need to "undo" the + SANY name resolution process further by filtering out all inlined operators + and breaking references like M!Defname down into [M; Defname] components. + We crudely do this by splitting on !, making allowances for the possibility + that the !! operator is used. Given these challenges, much SANY information such as identifier reference IDs and levels are attached as metadata to TLAPM AST nodes for use later @@ -79,6 +97,12 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin file = filename ^ ".tla"; } +type bounds_kind = + | Tuply of tuply_bounds + | NonTuply of bounds + +type bound_ + type proof_level = | Previous of int | Known of int @@ -245,32 +269,49 @@ let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def | Known n -> Unnamed (n, uid) (** Converts built-in prefix, infix, and postfix operators along with keywords. + Also includes some standard module operators like + and -. + TODO: handle case where user overrides a standard module operator name. *) let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = match builtin.name with + (* Reserved words *) | "TRUE" -> Some Builtin.TRUE | "FALSE" -> Some Builtin.FALSE + | "BOOLEAN" -> Some Builtin.BOOLEAN | "STRING" -> Some Builtin.STRING - | "DOMAIN" -> Some Builtin.DOMAIN + + (* Prefix operators *) + | "\\lnot" -> Some Builtin.Neg + | "UNION" -> Some Builtin.UNION | "SUBSET" -> Some Builtin.SUBSET + | "DOMAIN" -> Some Builtin.DOMAIN + | "ENABLED" -> Some Builtin.ENABLED | "UNCHANGED" -> Some Builtin.UNCHANGED - | "UNION" -> Some Builtin.UNION - | "\\lnot" -> Some Builtin.Neg - | "'" -> Some Builtin.Prime | "[]" -> Some (Builtin.Box false) | "<>" -> Some Builtin.Diamond - | "=" -> Some Builtin.Eq - | "/=" -> Some Builtin.Neq + + (* Postfix operators *) + | "'" -> Some Builtin.Prime + + (* Infix operators *) + | "+" -> Some Builtin.Plus + | "-" -> Some Builtin.Minus + | "*" -> Some Builtin.Times | "\\in" -> Some Builtin.Mem | "\\notin" -> Some Builtin.Notmem + | "=>" -> Some Builtin.Implies + | "\\equiv" -> Some Builtin.Equiv + | "\\land" -> Some Builtin.Conj + | "\\lor" -> Some Builtin.Disj + | "=" -> Some Builtin.Eq + | "/=" -> Some Builtin.Neq | "\\" -> Some Builtin.Setminus - | "\\union" -> Some Builtin.Cup | "\\intersect" -> Some Builtin.Cap + | "\\union" -> Some Builtin.Cup | "\\subseteq" -> Some Builtin.Subseteq - | "\\land" -> Some Builtin.Conj - | "\\lor" -> Some Builtin.Disj - | "=>" -> Some Builtin.Implies - | "\\equiv" -> Some Builtin.Equiv + | "~>" -> Some Builtin.Leadsto + | "\\cdot" -> Some Builtin.Cdot + | "-+->" -> Some Builtin.Actplus | _ -> None (** Conversion of application of all traditional built-in operators like = or @@ -303,9 +344,11 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k apply.operands |> as_expr_ls "$CartesianProd" apply.node.location |> List.map convert_expression ) |> attach_props apply.node | "$WF" -> convert_fairness Weak apply + | "$SF" -> convert_fairness Strong apply | "$BoundedChoose" -> convert_choose apply | "$UnboundedChoose" -> convert_choose apply | "$SquareAct" -> convert_action_expr Box apply + | "$AngleAct" -> convert_action_expr Dia apply | "$BoundedExists" -> convert_quantification Exists apply | "$BoundedForall" -> convert_quantification Forall apply | "$UnboundedExists" -> convert_quantification Exists apply @@ -314,7 +357,8 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | "$SubsetOf" -> convert_set_filter apply | "$SetOfFcns" -> convert_function_set apply | "$FcnConstructor" -> convert_function_constructor apply - | "$RecursiveFcnSpec" -> convert_recursive_function apply + | "$RecursiveFcnSpec" -> convert_function_definition true apply + | "$NonRecursiveFcnSpec" -> convert_function_definition false apply | "$FcnApply" -> convert_function_application apply | "$SetOfRcds" -> convert_record_set apply | "$RcdConstructor" -> convert_record_constructor apply @@ -479,6 +523,23 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid number of bounds or operands to CHOOSE" apply.node.location ) |> attach_props apply.node +(** General utility function to convert the given bound symbol into a non- + tuple bound type. +*) +and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : bounds = + if bound.is_tuple then conversion_failure "Tuple bound passed to non-tuple bound conversion" node.location else + match List.map resolve_bound_symbol bound.symbol_refs with + (* TODO: figure out meaning of "Unknown" parameter *) + | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) + :: List.map (fun s -> (s, Unknown, Ditto)) tl + | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location + +(** General utility function to convert the given bound symbol into a tuply + bound type, regardless of whether it is of the form <> \in S. If + even one quantifier bound in a list of quantifier bounds has tuple form, + then all must be put in the tuply_bounds type; see comment on the + convert_quantification function for more info. +*) and convert_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : tuply_bounds = if bound.is_tuple then match List.map resolve_bound_symbol bound.symbol_refs with @@ -489,11 +550,48 @@ and convert_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : tuply_bo :: List.map (fun s -> (Bound_name s, Ditto)) tl | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location -and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : bounds = - match List.map resolve_bound_symbol bound.symbol_refs with - | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) - :: List.map (fun s -> (s, Unknown, Ditto)) tl - | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location +(** General utility function to convert a list of quantifier bounds either to + tuple or non-tuple type. If even one quantifier bound in a list of quantifier + bounds has tuple form, then all must be put in the tuply_bounds type; see + comment on the convert_quantification function for more info. This function + requires all bounds to actually have a set bound, and will error if given + an unbounded quantifier bound. +*) +and convert_bounds (node : Xml.node) (all_bound_symbols : Xml.symbol list) : bounds_kind = + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) all_bound_symbols in + if List.length bound_symbols <> List.length all_bound_symbols + then conversion_failure "Cannot have unbound symbols" node.location + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + then Tuply (List.map (convert_tuply_bounds node) bound_symbols |> List.flatten) + else NonTuply (List.map (convert_non_tuply_bounds node) bound_symbols |> List.flatten) + +(** General utility function to convert a list of quantifier bounds either to + tuple or non-tuple type. As above, one tuple bound means all are given as + tuple bounds. The difference between this and the convert_bounds function + is that unbounded symbols are accepted here, albeit not unbounded tuple + bounds (those are only acceptable within a CHOOSE expression). However, + if one quantifier bound is unbounded, then all must be unbounded. +*) +and convert_bound_or_unbound_symbols (node : Xml.node) (all_symbols : Xml.symbol list) : bounds_kind = + let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) all_symbols in + let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) all_symbols in + if unbound_symbols <> [] + then + if bound_symbols <> [] + then conversion_failure "Cannot mix bound and unbound symbols" node.location + else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols + then conversion_failure "Unbounded tuple quantification is not supported" node.location + (* Unbounded *) + else let mk_bound (bound : Xml.unbound_symbol) : bound = ( + resolve_bound_symbol bound.symbol_ref, + Unknown, (* TODO: figure out purpose of this parameter *) + No_domain + ) in NonTuply (List.map mk_bound unbound_symbols) + else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols + (* Bounded, includes at least one tuple *) + then Tuply (List.map (convert_tuply_bounds node) bound_symbols |> List.flatten) + (* Bounded, no tuples *) + else NonTuply (List.map (convert_non_tuply_bounds node) bound_symbols |> List.flatten) (** Handles conversion of both bounded & unbounded quantification. Both sides of the conversion here are fairly weird. The SANY AST has the same issues @@ -522,62 +620,24 @@ and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : boun *) and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | _ :: _, [Expression body] -> - let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in - let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) apply.bound_symbols in - if unbound_symbols <> [] - then - if bound_symbols <> [] - then conversion_failure "Cannot mix bound and unbound symbols in quantification" apply.node.location - else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols - then conversion_failure "Unbounded tuple quantification is not supported" apply.node.location - (* Unbounded quantification *) - else let mk_bound (bound : Xml.unbound_symbol) : bound = ( - resolve_bound_symbol bound.symbol_ref, - Unknown, (* TODO: figure out purpose of this parameter *) - No_domain - ) in Quant ( - quant, - List.map mk_bound unbound_symbols, - convert_expression body - ) - else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols - (* Bounded quantification that includes at least one tuple *) - then QuantTuply ( - quant, - List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, - convert_expression body - ) - (* Bounded quantification without any tuples *) - else Quant ( - quant, - List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, - convert_expression body + | _ :: _, [Expression body] -> ( + match convert_bound_or_unbound_symbols apply.node apply.bound_symbols with + | Tuply tuply_bounds -> QuantTuply (quant, tuply_bounds, convert_expression body) + | NonTuply bounds -> Quant (quant, bounds, convert_expression body) ) | _ -> conversion_failure "Invalid number of bounds or operands to quantification" apply.node.location ) |> attach_props apply.node (** Conversion of expressions of the form {f(x, y) : x \in S, y \in Z} *) -and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = ( +and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = match apply.bound_symbols, apply.operands with - | _ :: _, [Expression body] -> - let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in - if List.length bound_symbols <> List.length apply.bound_symbols - then conversion_failure "Set mappings cannot have unbound symbols" apply.node.location - else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols - (* Set mapping that includes at least one tuple *) - then SetOfTuply ( - convert_expression body, - List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten - ) - (* Set mapping without any tuples *) - else SetOf ( - convert_expression body, - List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten - ) + | _ :: _, [Expression body] -> ( + match convert_bounds apply.node apply.bound_symbols with + | Tuply tuply_bounds -> SetOfTuply (convert_expression body, tuply_bounds) + | NonTuply bounds -> SetOf (convert_expression body, bounds) + ) |> attach_props apply.node | _ -> conversion_failure "Invalid number of bounds or operands to set mapping" apply.node.location -) |> attach_props apply.node (** Conversion of expressions of the form {x \in S : P(x)} or {<> \in S \X T : P(x, y)} *) @@ -596,42 +656,38 @@ and convert_set_filter (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid bounds or operands to set filter" apply.node.location ) |> attach_props apply.node -(** Conversion of recursive functions where the function body refers to the +(** Conversion of function definitions where the function body does not refer + to the function definition. + + Conversion of recursive functions where the function body refers to the function definition, for example f[x \in Nat] == f[x - 1]. Both SANY and TLAPM represent these as f == [x \in Nat |-> f[x - 1]], and here we convert the right-hand side of this definition. The function name is introduced as the first symbol, unbound. *) -and convert_recursive_function (apply : Xml.op_appl_node) : Expr.T.expr = ( - match apply.bound_symbols, apply.operands with - | Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> - let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) all_bound_symbols in - if List.length bound_symbols <> List.length all_bound_symbols - then conversion_failure "Function definitions cannot have unbound symbols" apply.node.location - else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols - (* Function definition bounds that include at least one tuple *) - then FcnTuply (List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) - (* Function definition bounds without any tuples *) - else Fcn (List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) - | _ -> conversion_failure "Invalid number of bounds or operands to recursive function definition" apply.node.location +and convert_function_definition (is_recursive : bool) (apply : Xml.op_appl_node) : Expr.T.expr = ( + let bounds, body = match is_recursive, apply.bound_symbols, apply.operands with + | true, Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> + all_bound_symbols, convert_expression body + | false, (_ :: _), [Expression body] -> + apply.bound_symbols, convert_expression body + | _ -> conversion_failure "Invalid number of bounds or operands to function definition" apply.node.location + in match convert_bounds apply.node bounds with + | Tuply tuply_bounds -> FcnTuply (tuply_bounds, body) + | NonTuply bounds -> Fcn (bounds, body) ) |> attach_props apply.node (** Converts function construction expressions like [x \in S, y \in P |-> x + y]; also handles record construction, like [x |-> expr1, y |-> expr2]. *) -and convert_function_constructor (apply : Xml.op_appl_node) : Expr.T.expr = ( +and convert_function_constructor (apply : Xml.op_appl_node) : Expr.T.expr = match apply.bound_symbols, apply.operands with - | _ :: _, [Expression body] -> - let bound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Bound b -> Some b | _ -> None) apply.bound_symbols in - if List.length bound_symbols <> List.length apply.bound_symbols - then conversion_failure "Function definitions cannot have unbound symbols" apply.node.location - else if List.exists (fun (b : Xml.bound_symbol) -> b.is_tuple) bound_symbols - (* Function definition bounds that include at least one tuple *) - then FcnTuply (List.map (convert_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) - (* Function definition bounds without any tuples *) - else Fcn (List.map (convert_non_tuply_bounds apply.node) bound_symbols |> List.flatten, convert_expression body) + | _ :: _, [Expression body] -> ( + match convert_bounds apply.node apply.bound_symbols with + | Tuply tuply_bounds -> FcnTuply (tuply_bounds, convert_expression body) + | NonTuply bounds -> Fcn (bounds, convert_expression body) + ) |> attach_props apply.node | _ -> conversion_failure "Invalid operands to function constructor" apply.node.location -) |> attach_props apply.node (** Converts function set expressions of the form [P -> Q] *) @@ -844,23 +900,56 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | NumeralNode n -> Num (Int.to_string n.value, "") |> attach_props n.node | OpApplNode apply -> convert_op_appl_node apply | StringNode s -> String s.value |> attach_props s.node - | SubstInNode subst -> todo "SubstInNode" "" subst.node.location + | SubstInNode subst -> convert_substitution_in subst | TheoremDefRef uid -> todo "Expression" "TheoremDefRef" None | AssumeDefRef uid -> todo "Expression" "AssumeDefRef" None +(** When a module has been imported using INSTANCE along with one or more + substitutions, and then an expression referencing an operator or definition + from that module is used, that reference is given as a subst_in_node by + SANY. This provides various details on the substitutions necessary in the + given expression to properly evaluate it. Here, we throw away all of that + information and let TLAPM re-derive the substitutions later on in the parse + process. + + Example: + + M == INSTANCE Mod WITH x <- y + op == M!op + + Here, the expression M!op is given as a subst_in_node. Compare this with + an INSTANCE import that does not use substitution: + + M == INSTANCE Naturals + op == M!Nat + + In this case, M!Nat is actually introduced as a new operator named M!Nat + in the importing module, and directly referenced with the usual uid-based + resolution mechanism. This might spell trouble for TLAPM as M!Nat is not + a valid TLA+ identifier name; TODO check whether this causes trouble. +*) +and convert_substitution_in (subst : Xml.subst_in_node) : Expr.T.expr = + convert_expression subst.body + +(** Converts lbl(a, b, c) :: expr + TODO: Handle conversion in all cases +*) and convert_label (label : Xml.label_node) : Expr.T.expr = ( match label.body with | Expression expr -> Parens (convert_expression expr, noprops Syntax) - | AssumeProve ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) + | AssumeProveLike AssumeProveNode ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) + | AssumeProveLike AssumeProveSubstitution aps -> todo "Label" "AssumeProveSubstitution" aps.node.location ) |> attach_props label.node +(** Converts LET/IN definition sets, consisting of one or more definitions + followed by a body expression in which the definitions are available. +*) and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = - let definitions = List.map (fun ref -> - match (resolve_ref ref).kind with + let convert_definition (def_ref : int) : Expr.T.defn = + match (resolve_ref def_ref).kind with | UserDefinedOpKind op -> convert_user_defined_op_kind op | _ -> todo "LET/IN definition" "Probably an instance" None - ) def_refs in - Let (definitions, convert_expression body) |> attach_props node + in Let (List.map convert_definition def_refs, convert_expression body) |> attach_props node (** Converts user-defined operators defined within LET/IN expressions. *) @@ -924,7 +1013,8 @@ and convert_assume_prove (ap : Xml.assume_prove_node) : sequent = { and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with | Expression expr -> {context = Deque.empty; active = convert_expression expr} - | AssumeProve ap -> convert_assume_prove ap + | AssumeProveLike AssumeProveNode ap -> convert_assume_prove ap + | AssumeProveLike AssumeProveSubstitution aps -> todo "Sequent" "AssumeProveSubstitution" aps.node.location (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series of individual proof steps culminated in a QED step. @@ -1026,6 +1116,12 @@ and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (s convert_case_proof_step apply proof | Expression OpApplNode ({operator} as apply) when is_op operator "$Pick" -> convert_pick_proof_step apply proof + | Expression OpApplNode ({operator} as apply) when is_op operator "$Take" -> + convert_take_proof_step apply + | Expression OpApplNode ({operator} as apply) when is_op operator "$Witness" -> + convert_witness_proof_step apply + | Expression OpApplNode ({operator} as apply) when is_op operator "$Suffices" -> + convert_suffices_proof_step apply proof | _ -> Suffices (convert_sequent thm.body, proof) in (step |> attach_props thm.node |> attach_proof_step_name step_name) :: steps, Known (step_number step_name) @@ -1036,17 +1132,43 @@ and convert_case_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : | [], [Expression expr] -> Pcase (convert_expression expr, proof) | _ -> conversion_failure "Invalid operands to CASE proof step" apply.node.location -(** Converts PICK proofs steps, like PICK i \in 1 .. Len(s) : P(i) - This is yet another conversion where quantifiers rear their tedious head. - In this case, only a single bound is supported. +(** Converts PICK proofs steps, like PICK a, b, c : P *) and convert_pick_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = match apply.bound_symbols, apply.operands with - | [Bound ({is_tuple = false} as bound)], [Expression predicate] -> - Pick (convert_non_tuply_bounds apply.node bound, convert_expression predicate, proof) - | [Bound ({is_tuple = true} as bound)], [Expression predicate] -> - PickTuply (convert_tuply_bounds apply.node bound, convert_expression predicate, proof) - | _ -> conversion_failure "Invalid bounds or operands to PICK proof step" apply.node.location + | _ :: _, [Expression body] -> ( + match convert_bound_or_unbound_symbols apply.node apply.bound_symbols with + | Tuply tuply_bounds -> PickTuply (tuply_bounds, convert_expression body, proof) + | NonTuply bounds -> Pick (bounds, convert_expression body, proof) + ) + | _ -> conversion_failure "Invalid number of bounds or operands to PICK proof step" apply.node.location + +(** Converts TAKE a, b, c, d or TAKE a, b \in S, c \in P, <> \in Q + proof step type. +*) +and convert_take_proof_step (apply : Xml.op_appl_node) : Proof.T.step_ = + match apply.bound_symbols, apply.operands with + | _ :: _, [] -> ( + match convert_bound_or_unbound_symbols apply.node apply.bound_symbols with + | Tuply tuply_bounds -> TakeTuply tuply_bounds + | NonTuply bounds -> Take bounds + ) + | _ -> conversion_failure "Invalid number of bounds or operands to TAKE proof step" apply.node.location + +(** Converts WITNESS x, y, z proof steps. +*) +and convert_witness_proof_step (apply : Xml.op_appl_node) : Proof.T.step_ = + match apply.bound_symbols, apply.operands with + | [], expressions -> + Witness (expressions |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression) + | _ -> conversion_failure "Invalid bounds or operands to WITNESS proof step" apply.node.location + +(** Converts SUFFICES P PROOF BY x, y, z proof steps. +*) +and convert_suffices_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = + match apply.bound_symbols, apply.operands with + | [], [Expression expr] -> Suffices (convert_sequent (Expression expr), proof) + | _ -> conversion_failure "Invalid bounds or operands to SUFFICES proof step" apply.node.location (** The top-level method converting the entire SANY AST to TLAPM's AST. SANY uses a lot of GUIDs for one entity to reference another, so we load those diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 174ab370..7e291d84 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -286,6 +286,15 @@ and label_node = { and subst_in_node = { node : node; + substitutions : substitution list; + body : expression; + instance_from_mule_ref : int; + instance_to_mule_ref : int; +} + +and substitution = { + target_uid : int; + substitute : expr_or_op_arg; } and expression = @@ -330,6 +339,10 @@ and assume_prove_node = { prove : expression; } +and assume_prove_like = + | AssumeProveNode of assume_prove_node + | AssumeProveSubstitution of subst_in_node + and new_symbol_node = { node : node; symbol_ref : int; @@ -338,12 +351,12 @@ and new_symbol_node = { and assumption_kind = | Expression of expression - | AssumeProve of assume_prove_node + | AssumeProveLike of assume_prove_like | NewSymbol of new_symbol_node and expr_or_assume_prove = | Expression of expression - | AssumeProve of assume_prove_node + | AssumeProveLike of assume_prove_like [@@deriving show] let rec xml_to_symbols xml = @@ -435,7 +448,7 @@ and xml_to_assume_prove_node (children : tree list) : assume_prove_node = and xml_to_assumption_kind (xml : tree) : assumption_kind = match xml with - | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | Node ("AssumeProveNode", children) -> AssumeProveLike (AssumeProveNode (xml_to_assume_prove_node children)) | Node ("NewSymbNode", children) -> NewSymbol (xml_to_new_symbol_node children) | expr -> Expression (xml_to_expression expr) @@ -455,12 +468,32 @@ and xml_to_new_symbol_node (children : tree list) : new_symbol_node = and xml_to_expr_or_assume_prove (xml : tree) : expr_or_assume_prove = match xml with - | Node ("AssumeProveNode", children) -> AssumeProve (xml_to_assume_prove_node children) + | Node ("AssumeProveNode", children) -> AssumeProveLike (AssumeProveNode (xml_to_assume_prove_node children)) + | Node ("APSubstInNode", children) -> AssumeProveLike (AssumeProveSubstitution (xml_to_subst_in_node children)) | expr -> Expression (xml_to_expression expr) +and xml_to_substitution (xml : tree) : substitution = + match xml with + | Node ("Subst", [Node ("OpDeclNodeRef", [Node ("UID", [IValue target_uid])]); substitute]) -> { + target_uid; + substitute = xml_to_expr_or_op_arg substitute; + } + | _ -> conversion_failure __FUNCTION__ xml + and xml_to_subst_in_node (children : tree list) : subst_in_node = match extract_inline_node children with - | node, _ -> {node} + | node, [ + Node ("substs", substitutions); + Node ("body", [body]); + Node ("instFrom", [Node ("ModuleNodeRef", [Node ("UID", [IValue instance_from_mule_ref])])]); + Node ("instTo", [Node ("ModuleNodeRef", [Node ("UID", [IValue instance_to_mule_ref])])])] -> { + node; + substitutions = List.map xml_to_substitution substitutions; + body = xml_to_expression body; + instance_from_mule_ref; + instance_to_mule_ref + } + | _ -> ls_conversion_failure __FUNCTION__ children and xml_to_expression (xml : tree) : expression = match xml with @@ -489,20 +522,8 @@ and xml_to_user_defined_op_kind (children : tree list) : user_defined_op_kind = } | _ -> ls_conversion_failure __FUNCTION__ children -type substitution = { - target_uid : int; - substitute : expr_or_op_arg; -} [@@deriving show] -let xml_to_substitution (xml : tree) : substitution = - match xml with - | Node ("Subst", [Node ("OpDeclNodeRef", [Node ("UID", [IValue target_uid])]); substitute]) -> { - target_uid; - substitute = xml_to_expr_or_op_arg substitute; - } - | _ -> conversion_failure __FUNCTION__ xml - type instance_node = { node : node; name : string option; @@ -787,15 +808,15 @@ let xml_to_theorem_node (children : tree list) : theorem_node = | _ -> ls_conversion_failure __FUNCTION__ children type entry_kind = + | FormalParamNode of formal_param_node | ModuleNode of module_node - | AssumeNode of assume_node - | AssumeDefNode of assume_def_node | OpDeclNode of op_decl_node + | AssumeNode of assume_node | UserDefinedOpKind of user_defined_op_kind | BuiltInKind of built_in_kind - | FormalParamNode of formal_param_node - | TheoremDefNode of theorem_def_node | TheoremNode of theorem_node + | TheoremDefNode of theorem_def_node + | AssumeDefNode of assume_def_node [@@deriving show] let xml_to_entry_kind (xml : tree) : entry_kind = diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 74250dc7..f13cca6e 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -13,13 +13,30 @@ let find_tla_files dir = in loop [] +let has_substring needle haystack = + match Str.search_forward (Str.regexp_string needle) haystack 0 with + | _ -> true + | exception Not_found -> false + let should_run (path : string) : bool = let preds = [ (* RECURSIVE operators *) String.ends_with ~suffix:"Chameneos.tla"; + String.ends_with ~suffix:"Stones.tla"; + String.ends_with ~suffix:"glowingRaccoon/product.tla"; + (* Subexpressions *) + String.ends_with ~suffix:"MCPaxos.tla"; + String.ends_with ~suffix:"MCVoting.tla"; (* Community modules *) String.ends_with ~suffix:"MCtcp.tla"; String.ends_with ~suffix:"tcp.tla"; + String.ends_with ~suffix:"MCReplicatedLog.tla"; + String.ends_with ~suffix:"MCCRDT.tla"; + String.ends_with ~suffix:"DistributedReplicatedLog.tla"; + String.ends_with ~suffix:"SimTokenRing.tla"; + String.ends_with ~suffix:"EWD687a_anim.tla"; + String.ends_with ~suffix:"EWD687a.tla"; + has_substring "/ewd998/"; ] in not (List.exists (fun pred -> pred path) preds) let parse_tla_file filename = From 4161e7ca0ae45365288c196c4cdb6c69ec06d771 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 9 Feb 2026 15:16:09 -0800 Subject: [PATCH 57/85] Convert CASE OTHER Signed-off-by: Andrew Helwer --- test/sany/AddTwo.tla => AddTwo.tla | 0 src/sany/sany.ml | 34 +- src/sany/xml.ml | 4 +- test/sany/AddTwo.xml | 9894 ---------------------------- test/sany/dune | 1 - test/sany/sany_tests.ml | 30 +- 6 files changed, 54 insertions(+), 9909 deletions(-) rename test/sany/AddTwo.tla => AddTwo.tla (100%) delete mode 100644 test/sany/AddTwo.xml diff --git a/test/sany/AddTwo.tla b/AddTwo.tla similarity index 100% rename from test/sany/AddTwo.tla rename to AddTwo.tla diff --git a/src/sany/sany.ml b/src/sany/sany.ml index dae53182..95e6789f 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -75,6 +75,15 @@ let conversion_failure (msg : string) (loc : Xml.location option) : 'a = | None -> "Unknown location" in failwith (Printf.sprintf "Conversion failure:\n%s\n%s" msg loc) +(** Several places require special handling of the last element of a list, + for example proof steps which end in a QED and CASE pairs which end + (possibly) in an OTHER statement. This utility function helps with that. +*) +let split_last_ls (node : Xml.node) (ls : 'a list) : 'a list * 'a = + match List.rev ls with + | [] -> conversion_failure "Cannot get last element of empty list" node.location + | hd :: tl -> (List.rev tl, hd) + (** A module-global table of SANY AST entities, indexed by UID. *) let entries : Xml.entry_kind Coll.Im.t ref = ref Coll.Im.empty @@ -787,24 +796,27 @@ and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( ) |> attach_props apply.node (** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e - - TODO: SANY XML exporter cannot currently handle OTHER branches; see: - https://github.com/tlaplus/tlaplus/issues/1291 *) and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | [], (_ :: _ as pairs) -> - let mk_case (operand : Xml.expr_or_op_arg) : (Expr.T.expr * Expr.T.expr) option = + | [], _ :: _ -> ( + let as_pair (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) option = match operand with | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression cond; Expression result]} -> ( match (resolve_ref operator).kind with - | BuiltInKind {name = "$Pair"} -> Some (convert_expression cond, convert_expression result) + | BuiltInKind {name = "$Pair"} -> Some (cond, result) | _ -> None ) | _ -> None - in let cases = List.filter_map mk_case pairs in - if List.length cases <> List.length pairs + in let cases = List.filter_map as_pair apply.operands in + if List.length cases <> List.length apply.operands then conversion_failure "Invalid operands to CASE; expected pairs of expressions" apply.node.location - else Case (cases, None) + else + let mk_case ((predicate, expr) : Xml.expression * Xml.expression) : (Expr.T.expr * Expr.T.expr) = + (convert_expression predicate, convert_expression expr) + in match split_last_ls apply.node cases with + | prefix, (StringNode {value = "$Other"}, other) -> Case (List.map mk_case prefix, Some (convert_expression other)) + | _ -> Case (List.map mk_case cases, None) + ) | _ -> conversion_failure "Invalid bound symbols or operands to CASE" apply.node.location ) |> attach_props apply.node @@ -1031,12 +1043,12 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no where information is lost, as the facts and definitions are converted to strings that will need to be resolved to De Bruijn indices later on. *) -and convert_by_proof ({node; facts; defs} : Xml.by_proof_node) : Proof.T.proof = +and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.proof = By ({ facts = List.map convert_expression facts; defs = List.map (resolve_def node) defs; }, - true (* This should be true if the ONLY keyword is present *) + only ) |> attach_props node (** One possible proof form is a series of steps, culminating in a QED step. diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 7e291d84..5f20e179 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -721,15 +721,17 @@ type by_proof_node = { node : node; facts : expression list; defs : int list; + only : bool; } [@@deriving show] let xml_to_by_proof_node (children : tree list) : by_proof_node = match extract_inline_node children with - | node, [Node ("facts", facts); Node ("defs", defs)] -> { + | node, Node ("facts", facts) :: Node ("defs", defs) :: children -> { node; facts = List.map xml_to_expression facts; defs = List.filter_map get_ref_opt defs; + only = match children with | [Node ("only", _)] -> true | _ -> false } | _ -> ls_conversion_failure __FUNCTION__ children diff --git a/test/sany/AddTwo.xml b/test/sany/AddTwo.xml deleted file mode 100644 index 47d63c1b..00000000 --- a/test/sany/AddTwo.xml +++ /dev/null @@ -1,9894 +0,0 @@ - - - AddTwo - - - 512 - - - - 1 - 26 - - - 229 - 229 - - TLAPS - - 0 - SlowSimplification - 0 - - - - - - 23 - 26 - - - 229 - 229 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 514 - - - - 1 - 29 - - - 231 - 231 - - TLAPS - - 0 - SlowerSimplification - 0 - - - - - - 26 - 29 - - - 231 - 231 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 516 - - - - 1 - 29 - - - 233 - 233 - - TLAPS - - 0 - SlowestSimplification - 0 - - - - - - 26 - 29 - - - 233 - 233 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 518 - - - - 1 - 13 - - - 246 - 246 - - TLAPS - - 0 - Blast - 0 - - - - - - 10 - 13 - - - 246 - 246 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 520 - - - - 1 - 17 - - - 247 - 247 - - TLAPS - - 0 - SlowBlast - 0 - - - - - - 14 - 17 - - - 247 - 247 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 522 - - - - 1 - 19 - - - 248 - 248 - - TLAPS - - 0 - SlowerBlast - 0 - - - - - - 16 - 19 - - - 248 - 248 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 524 - - - - 1 - 20 - - - 249 - 249 - - TLAPS - - 0 - SlowestBlast - 0 - - - - - - 17 - 20 - - - 249 - 249 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 526 - - - - 1 - 17 - - - 251 - 251 - - TLAPS - - 0 - AutoBlast - 0 - - - - - - 14 - 17 - - - 251 - 251 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 528 - - - - 1 - 18 - - - 265 - 265 - - TLAPS - - 0 - AllProvers - 0 - - - - - - 15 - 18 - - - 265 - 265 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 529 - - - - 13 - 13 - - - 280 - 280 - - TLAPS - - X - 0 - - - - 531 - - - - 1 - 22 - - - 280 - 280 - - TLAPS - - 0 - AllProversT - 1 - - - - - - 19 - 22 - - - 280 - 280 - - TLAPS - - 0 - - - 152 - - - - - - - - - 529 - - - - - - - - 533 - - - - 1 - 14 - - - 296 - 296 - - TLAPS - - 0 - AllSMT - 0 - - - - - - 11 - 14 - - - 296 - 296 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 534 - - - - 9 - 9 - - - 303 - 303 - - TLAPS - - X - 0 - - - - 536 - - - - 1 - 18 - - - 303 - 303 - - TLAPS - - 0 - AllSMTT - 1 - - - - - - 15 - 18 - - - 303 - 303 - - TLAPS - - 0 - - - 152 - - - - - - - - - 534 - - - - - - - - 538 - - - - 1 - 14 - - - 311 - 311 - - TLAPS - - 0 - AllIsa - 0 - - - - - - 11 - 14 - - - 311 - 311 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 539 - - - - 9 - 9 - - - 319 - 319 - - TLAPS - - X - 0 - - - - 541 - - - - 1 - 18 - - - 319 - 319 - - TLAPS - - 0 - AllIsaT - 1 - - - - - - 15 - 18 - - - 319 - 319 - - TLAPS - - 0 - - - 152 - - - - - - - - - 539 - - - - - - - - 543 - - - - 1 - 21 - - - 343 - 343 - - TLAPS - - 0 - ExpandENABLED - 0 - - - - - - 18 - 21 - - - 343 - 343 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 545 - - - - 1 - 18 - - - 344 - 344 - - TLAPS - - 0 - ExpandCdot - 0 - - - - - - 15 - 18 - - - 344 - 344 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 547 - - - - 1 - 15 - - - 345 - 345 - - TLAPS - - 0 - AutoUSE - 0 - - - - - - 12 - 15 - - - 345 - 345 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 549 - - - - 1 - 16 - - - 346 - 346 - - TLAPS - - 0 - Lambdify - 0 - - - - - - 13 - 16 - - - 346 - 346 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 551 - - - - 1 - 21 - - - 347 - 347 - - TLAPS - - 0 - ENABLEDaxioms - 0 - - - - - - 18 - 21 - - - 347 - 347 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 553 - - - - 1 - 23 - - - 348 - 348 - - TLAPS - - 0 - LevelComparison - 0 - - - - - - 20 - 23 - - - 348 - 348 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 554 - - - - 16 - 20 - - - 352 - 352 - - TLAPS - - Op - 1 - - - - 556 - - - - 1 - 30 - - - 352 - 352 - - TLAPS - - 0 - EnabledWrapper - 1 - - - - - - 26 - 30 - - - 352 - 352 - - TLAPS - - 0 - - - 151 - - - - - - - - - 554 - - - - - - - - 557 - - - - 13 - 17 - - - 353 - 353 - - TLAPS - - Op - 1 - - - - 559 - - - - 1 - 27 - - - 353 - 353 - - TLAPS - - 0 - CdotWrapper - 1 - - - - - 23 - 27 - - - 353 - 353 - - TLAPS - - 0 - - - 151 - - - - - - - - - 557 - - - - - - - - 561 - - - - 1 - 15 - - - 359 - 359 - - TLAPS - - 0 - Trivial - 0 - - - - - - 12 - 15 - - - 359 - 359 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 566 - - - - 1 - 77 - - - 1 - 30 - - AddTwo - - AddTwo - - 567 - - - 306 - - - 312 - - - 322 - - - 326 - - - 332 - - - 338 - - - 344 - - - 350 - - - 356 - - - 362 - - - 368 - - - 374 - - - 381 - - - 383 - - - 386 - - - 388 - - - 391 - - - 393 - - - 396 - - - 398 - - - 401 - - - 403 - - - 406 - - - 408 - - - 411 - - - 413 - - - 416 - - - 418 - - - 421 - - - 423 - - - 426 - - - 428 - - - 430 - - - 433 - - - 435 - - - 438 - - - 441 - - - 445 - - - 447 - - - 478 - - - 480 - - - 482 - - - 484 - - - 486 - - - 488 - - - 490 - - - 492 - - - 494 - - - 496 - - - 498 - - - 500 - - - 502 - - - 504 - - - 506 - - - 508 - - - 510 - - - 512 - - - 514 - - - 516 - - - 518 - - - 520 - - - 522 - - - 524 - - - 526 - - - 528 - - - 531 - - - 533 - - - 536 - - - 538 - - - 541 - - - 543 - - - 545 - - - 547 - - - 549 - - - 551 - - - 553 - - - 556 - - - 559 - - - 561 - - - 570 - - - 574 - - - 578 - - - 585 - - - 592 - - - 603 - - - 607 - - - 466 - - - 476 - - - 671 - - - - - 567 - - - - 10 - 10 - - - 4 - 4 - - AddTwo - - 1 - x - 0 - 3 - - - - 570 - - - - 1 - 13 - - - 6 - 6 - - AddTwo - - 1 - vars - 0 - - - - - 9 - 13 - - - 6 - 6 - - AddTwo - - 1 - - - 275 - - - - - - - 11 - 11 - - - 6 - 6 - - AddTwo - - 1 - - - 567 - - - - - - - - - - - - 574 - - - - 1 - 19 - - - 8 - 8 - - AddTwo - - 1 - TypeOK - 0 - - - - - 11 - 19 - - - 8 - 8 - - AddTwo - - 1 - - - 190 - - - - - - - 11 - 11 - - - 8 - 8 - - AddTwo - - 1 - - - 567 - - - - - - - - 17 - 19 - - - 8 - 8 - - AddTwo - - 0 - - - 306 - - - - - - - - - - - - 578 - - - - 1 - 13 - - - 10 - 10 - - AddTwo - - 1 - Init - 0 - - - - - 9 - 13 - - - 10 - 10 - - AddTwo - - 1 - - - 154 - - - - - - - 9 - 9 - - - 10 - 10 - - AddTwo - - 1 - - - 567 - - - - - - - - 13 - 13 - - - 10 - 10 - - AddTwo - - 0 - 0 - - - - - - - - - 585 - - - - 1 - 18 - - - 12 - 12 - - AddTwo - - 2 - Next - 0 - - - - - 9 - 18 - - - 12 - 12 - - AddTwo - - 2 - - - 154 - - - - - - - 9 - 10 - - - 12 - 12 - - AddTwo - - 2 - - - 163 - - - - - - - 9 - 9 - - - 12 - 12 - - AddTwo - - 1 - - - 567 - - - - - - - - - - 14 - 18 - - - 12 - 12 - - AddTwo - - 1 - - - 312 - - - - - - - 14 - 14 - - - 12 - 12 - - AddTwo - - 1 - - - 567 - - - - - - - - 18 - 18 - - - 12 - 12 - - AddTwo - - 0 - 2 - - - - - - - - - - - 592 - - - - 1 - 29 - - - 14 - 14 - - AddTwo - - 3 - Spec - 0 - - - - - 9 - 29 - - - 14 - 14 - - AddTwo - - 3 - - - 169 - - - - - - - 9 - 12 - - - 14 - 14 - - AddTwo - - 1 - - - 578 - - - - - - - - 17 - 29 - - - 14 - 14 - - AddTwo - - 3 - - - 211 - - - - - - - 19 - 29 - - - 14 - 14 - - AddTwo - - 2 - - - 263 - - - - - - - 20 - 23 - - - 14 - 14 - - AddTwo - - 2 - - - 585 - - - - - - - - 26 - 29 - - - 14 - 14 - - AddTwo - - 1 - - - 570 - - - - - - - - - - - - - - - - 593 - - - - 1 - 1 - - - 16 - 16 - - AddTwo - - 0 - a - 0 - - - - 594 - - - - 3 - 3 - - - 16 - 16 - - AddTwo - - 0 - b - 0 - - - - 596 - - - - 11 - 11 - - - 16 - 16 - - AddTwo - - 0 - c - 0 - - - - 603 - - - - 1 - 29 - - - 16 - 16 - - AddTwo - - 0 - | - 2 - - - - - 8 - 29 - - - 16 - 16 - - AddTwo - - 0 - - - 229 - - - - - - - 23 - 29 - - - 16 - 16 - - AddTwo - - 0 - - - 154 - - - - - - - 23 - 25 - - - 16 - 16 - - AddTwo - - 0 - - - 326 - - - - - - - 23 - 23 - - - 16 - 16 - - AddTwo - - 0 - - - 593 - - - - - - - - 25 - 25 - - - 16 - 16 - - AddTwo - - 0 - - - 596 - - - - - - - - - - 29 - 29 - - - 16 - 16 - - AddTwo - - 0 - - - 594 - - - - - - - - - - - 596 - - - - - 17 - 19 - - - 16 - 16 - - AddTwo - - 0 - - - 306 - - - - - - - - - - - - 593 - - - - - - 594 - - - - - - - - 607 - - - - 1 - 11 - - - 18 - 18 - - AddTwo - - 1 - Even - 0 - - - - - 9 - 11 - - - 18 - 18 - - AddTwo - - 1 - - - 603 - - - - - - - 9 - 9 - - - 18 - 18 - - AddTwo - - 0 - 2 - - - - - 11 - 11 - - - 18 - 18 - - AddTwo - - 1 - - - 567 - - - - - - - - - - - - 608 - - - - 1 - 43 - - - 20 - 28 - - AddTwo - - 3 - thm - - - - 16 - 29 - - - 20 - 20 - - AddTwo - - 3 - - - 178 - - - - - - - 16 - 19 - - - 20 - 20 - - AddTwo - - 3 - - - 592 - - - - - - - - 24 - 29 - - - 20 - 20 - - AddTwo - - 3 - - - 211 - - - - - - - 26 - 29 - - - 20 - 20 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - 613 - - - - 3 - 7 - - - 21 - 21 - - AddTwo - - 1 - <1>a - - - - 9 - 20 - - - 21 - 21 - - AddTwo - - 1 - - - 178 - - - - - - - 9 - 12 - - - 21 - 21 - - AddTwo - - 1 - - - 578 - - - - - - - - 17 - 20 - - - 21 - 21 - - AddTwo - - 1 - - - 607 - - - - - - - - - - 619 - - - - 3 - 24 - - - 21 - 22 - - AddTwo - - 1 - - - 613 - - - - - - - 9 - 20 - - - 21 - 21 - - AddTwo - - 1 - - - 178 - - - - - - - 9 - 12 - - - 21 - 21 - - AddTwo - - 1 - - - 578 - - - - - - - - 17 - 20 - - - 21 - 21 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - 5 - 24 - - - 22 - 22 - - AddTwo - - 0 - - - - 578 - - - 607 - - - 603 - - - - - - - 620 - - - - 3 - 7 - - - 23 - 23 - - AddTwo - - 2 - <1>b - - - - 9 - 39 - - - 23 - 23 - - AddTwo - - 2 - - - 178 - - - - - - - 9 - 30 - - - 23 - 23 - - AddTwo - - 2 - - - 169 - - - - - - - 9 - 12 - - - 23 - 23 - - AddTwo - - 1 - - - 607 - - - - - - - - 17 - 30 - - - 23 - 23 - - AddTwo - - 2 - - - 217 - - - - - - - 27 - 30 - - - 23 - 23 - - AddTwo - - 1 - - - 570 - - - - - - - - - - - - 35 - 39 - - - 23 - 23 - - AddTwo - - 2 - - - 163 - - - - - - - 35 - 38 - - - 23 - 23 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - 630 - - - - 3 - 21 - - - 23 - 24 - - AddTwo - - 2 - - - 620 - - - - - - - 9 - 39 - - - 23 - 23 - - AddTwo - - 2 - - - 178 - - - - - - - 9 - 30 - - - 23 - 23 - - AddTwo - - 2 - - - 169 - - - - - - - 9 - 12 - - - 23 - 23 - - AddTwo - - 1 - - - 607 - - - - - - - - 17 - 30 - - - 23 - 23 - - AddTwo - - 2 - - - 217 - - - - - - - 27 - 30 - - - 23 - 23 - - AddTwo - - 1 - - - 570 - - - - - - - - - - - - 35 - 39 - - - 23 - 23 - - AddTwo - - 2 - - - 163 - - - - - - - 35 - 38 - - - 23 - 23 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - - 5 - 21 - - - 24 - 24 - - AddTwo - - 0 - - - - 607 - - - 570 - - - - - - - 631 - - - - 3 - 7 - - - 25 - 25 - - AddTwo - - 2 - <1>c - - - - 9 - 29 - - - 25 - 25 - - AddTwo - - 2 - - - 178 - - - - - - - 9 - 20 - - - 25 - 25 - - AddTwo - - 2 - - - 169 - - - - - - - 9 - 12 - - - 25 - 25 - - AddTwo - - 1 - - - 607 - - - - - - - - 17 - 20 - - - 25 - 25 - - AddTwo - - 2 - - - 585 - - - - - - - - - - 25 - 29 - - - 25 - 25 - - AddTwo - - 2 - - - 163 - - - - - - - 25 - 28 - - - 25 - 25 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - 639 - - - - 11 - 11 - - - 26 - 26 - - AddTwo - - 0 - c - 0 - - - - 661 - - - - 3 - 29 - - - 25 - 27 - - AddTwo - - 2 - - - 631 - - - - - - - 9 - 29 - - - 25 - 25 - - AddTwo - - 2 - - - 178 - - - - - - - 9 - 20 - - - 25 - 25 - - AddTwo - - 2 - - - 169 - - - - - - - 9 - 12 - - - 25 - 25 - - AddTwo - - 1 - - - 607 - - - - - - - - 17 - 20 - - - 25 - 25 - - AddTwo - - 2 - - - 585 - - - - - - - - - - 25 - 29 - - - 25 - 25 - - AddTwo - - 2 - - - 163 - - - - - - - 25 - 28 - - - 25 - 25 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - - 5 - 29 - - - 26 - 27 - - AddTwo - - 0 - - - - - 8 - 54 - - - 26 - 26 - - AddTwo - - 0 - - - 230 - - - - - - - 23 - 54 - - - 26 - 26 - - AddTwo - - 0 - - - 169 - - - - - - - 23 - 33 - - - 26 - 26 - - AddTwo - - 0 - - - 190 - - - - - - - 23 - 25 - - - 26 - 26 - - AddTwo - - 0 - - - 312 - - - - - - - 23 - 23 - - - 26 - 26 - - AddTwo - - 0 - - - 639 - - - - - - - - 25 - 25 - - - 26 - 26 - - AddTwo - - 0 - 1 - - - - - - - 31 - 33 - - - 26 - 26 - - AddTwo - - 0 - - - 306 - - - - - - - - - - 38 - 54 - - - 26 - 26 - - AddTwo - - 0 - - - 154 - - - - - - - 38 - 44 - - - 26 - 26 - - AddTwo - - 0 - - - 326 - - - - - - - 38 - 38 - - - 26 - 26 - - AddTwo - - 0 - 2 - - - - - 41 - 43 - - - 26 - 26 - - AddTwo - - 0 - - - 312 - - - - - - - 41 - 41 - - - 26 - 26 - - AddTwo - - 0 - - - 639 - - - - - - - - 43 - 43 - - - 26 - 26 - - AddTwo - - 0 - 1 - - - - - - - - - 48 - 54 - - - 26 - 26 - - AddTwo - - 0 - - - 312 - - - - - - - 48 - 50 - - - 26 - 26 - - AddTwo - - 0 - - - 326 - - - - - - - 48 - 48 - - - 26 - 26 - - AddTwo - - 0 - 2 - - - - - 50 - 50 - - - 26 - 26 - - AddTwo - - 0 - - - 639 - - - - - - - - - - 54 - 54 - - - 26 - 26 - - AddTwo - - 0 - 2 - - - - - - - - - - - - 639 - - - - - 17 - 19 - - - 26 - 26 - - AddTwo - - 0 - - - 306 - - - - - - - - - - - 57 - 61 - - - 26 - 26 - - AddTwo - - 0 - - - 430 - - - - - - - - 574 - - - 607 - - - 585 - - - 603 - - - - - - - 151 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - FALSE - 0 - - - - - 152 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - TRUE - 0 - - - - - 154 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - = - 2 - - - - 155 - - - - - - 156 - - - - - - - - 155 - - Formal_0 - 0 - - - - 156 - - Formal_1 - 0 - - - - 669 - - - - 3 - 43 - - - 28 - 28 - - AddTwo - - 2 - - - - - 7 - 9 - - - 28 - 28 - - AddTwo - - 0 - - - 287 - - - - - - - - - 11 - 43 - - - 28 - 28 - - AddTwo - - 2 - - - - - 14 - 16 - - - 28 - 28 - - AddTwo - - 0 - - - 428 - - - - - - - - 19 - 22 - - - 28 - 28 - - AddTwo - - 1 - - - 613 - - - - - - - - 25 - 28 - - - 28 - 28 - - AddTwo - - 2 - - - 620 - - - - - - - - 31 - 34 - - - 28 - 28 - - AddTwo - - 2 - - - 631 - - - - - - - - 592 - - - - - - - 671 - - - - 1 - 43 - - - 20 - 28 - - AddTwo - - 3 - - - 608 - - - - - - - 16 - 29 - - - 20 - 20 - - AddTwo - - 3 - - - 178 - - - - - - - 16 - 19 - - - 20 - 20 - - AddTwo - - 3 - - - 592 - - - - - - - - 24 - 29 - - - 20 - 20 - - AddTwo - - 3 - - - 211 - - - - - - - 26 - 29 - - - 20 - 20 - - AddTwo - - 1 - - - 607 - - - - - - - - - - - - - 3 - 43 - - - 21 - 28 - - AddTwo - - 2 - - 619 - - - 630 - - - 661 - - - 669 - - - - - - 163 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 2 - ' - 1 - - - - 164 - - - - - - - 164 - - Formal_0 - 0 - - - - 169 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - \land - 2 - - - - 170 - - - - - - 171 - - - - - - - - 170 - - Formal_0 - 0 - - - - 171 - - Formal_1 - 0 - - - - 175 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - \equiv - 2 - - - - 176 - - - - - - 177 - - - - - - - - 176 - - Formal_0 - 0 - - - - 177 - - Formal_1 - 0 - - - - 178 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - => - 2 - - - - 179 - - - - - - 180 - - - - - - - - 179 - - Formal_0 - 0 - - - - 180 - - Formal_1 - 0 - - - - 190 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - \in - 2 - - - - 191 - - - - - - 192 - - - - - - - - 191 - - Formal_0 - 0 - - - - 192 - - Formal_1 - 0 - - - - 193 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - \notin - 2 - - - - 194 - - - - - - 195 - - - - - - - - 194 - - Formal_0 - 0 - - - - 195 - - Formal_1 - 0 - - - - 211 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 3 - [] - 1 - - - - 212 - - - - - - - 212 - - Formal_0 - 0 - - - - 217 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 2 - UNCHANGED - 1 - - - - 218 - - - - - - - 218 - - Formal_0 - 0 - - - - 229 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $BoundedExists - -1 - - - - 230 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $BoundedForall - -1 - - - - 256 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $SetEnumerate - -1 - - - - 263 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 2 - $SquareAct - 2 - - - - 264 - - - - - 265 - - - - - - - 264 - - Formal_0 - 0 - - - - 265 - - Formal_1 - 0 - - - - 275 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $Tuple - -1 - - - - 276 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $UnboundedChoose - 1 - - - - 277 - - - - - - - - 277 - - Formal_0 - 0 - - - - 278 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $UnboundedExists - 1 - - - - 279 - - - - - - - - 279 - - Formal_0 - 0 - - - - 280 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $UnboundedForall - 1 - - - - 281 - - - - - - - - 281 - - Formal_0 - 0 - - - - 287 - - - - 0 - 0 - - - 0 - 0 - - --TLA+ BUILTINS-- - - 0 - $Qed - 0 - - - - - 304 - - - - 1 - 77 - - - 1 - 36 - - Naturals - - Naturals - - 306 - - - 312 - - - 322 - - - 326 - - - 332 - - - 338 - - - 344 - - - 350 - - - 356 - - - 362 - - - 368 - - - 374 - - - - - 306 - - - - 1 - 16 - - - 14 - 14 - - Naturals - - 0 - Nat - 0 - - - - - - 14 - 16 - - - 14 - 14 - - Naturals - - 0 - - - 256 - - - - - - - - - - 307 - - - - 1 - 1 - - - 15 - 15 - - Naturals - - 0 - a - 0 - - - - 308 - - - - 3 - 3 - - - 15 - 15 - - Naturals - - 0 - b - 0 - - - - 312 - - - - 1 - 19 - - - 15 - 15 - - Naturals - - 0 - + - 2 - - - - - 14 - 19 - - - 15 - 15 - - Naturals - - 0 - - - 256 - - - - - - - 15 - 15 - - - 15 - 15 - - Naturals - - 0 - - - 307 - - - - - - - - 18 - 18 - - - 15 - 15 - - Naturals - - 0 - - - 308 - - - - - - - - - - - 307 - - - - - - 308 - - - - - - - - 313 - - - - 1 - 1 - - - 17 - 17 - - Naturals - - 0 - a - 0 - - - - 314 - - - - 3 - 3 - - - 17 - 17 - - Naturals - - 0 - b - 0 - - - - 315 - - - - 14 - 19 - - - 17 - 17 - - Naturals - - 0 - n - 0 - - - - 322 - - - - 1 - 33 - - - 17 - 17 - - Naturals - - 0 - - - 2 - - - - - 14 - 33 - - - 17 - 17 - - Naturals - - 0 - - - 276 - - - - - - - 25 - 33 - - - 17 - 17 - - Naturals - - 0 - - - 154 - - - - - - - 25 - 29 - - - 17 - 17 - - Naturals - - 0 - - - 312 - - - - - - - 25 - 25 - - - 17 - 17 - - Naturals - - 0 - - - 314 - - - - - - - - 29 - 29 - - - 17 - 17 - - Naturals - - 0 - - - 315 - - - - - - - - - - 33 - 33 - - - 17 - 17 - - Naturals - - 0 - - - 313 - - - - - - - - - - - 315 - - - - - - - - - 313 - - - - - - 314 - - - - - - - - 323 - - - - 1 - 1 - - - 18 - 18 - - Naturals - - a - 0 - - - - 324 - - - - 3 - 3 - - - 18 - 18 - - Naturals - - b - 0 - - - - 326 - - - - 1 - 17 - - - 18 - 18 - - Naturals - - 0 - * - 2 - - - - - 14 - 17 - - - 18 - 18 - - Naturals - - 0 - - - 152 - - - - - - - - - 323 - - - - - - 324 - - - - - - - - 327 - - - - 1 - 1 - - - 19 - 19 - - Naturals - - 0 - a - 0 - - - - 328 - - - - 3 - 3 - - - 19 - 19 - - Naturals - - 0 - b - 0 - - - - 332 - - - - 1 - 19 - - - 19 - 19 - - Naturals - - 0 - ^ - 2 - - - - - 14 - 19 - - - 19 - 19 - - Naturals - - 0 - - - 256 - - - - - - - 15 - 15 - - - 19 - 19 - - Naturals - - 0 - - - 327 - - - - - - - - 18 - 18 - - - 19 - 19 - - Naturals - - 0 - - - 328 - - - - - - - - - - - 327 - - - - - - 328 - - - - - - - - 333 - - - - 1 - 1 - - - 20 - 20 - - Naturals - - 0 - a - 0 - - - - 334 - - - - 3 - 3 - - - 20 - 20 - - Naturals - - 0 - b - 0 - - - - 338 - - - - 1 - 19 - - - 20 - 20 - - Naturals - - 0 - < - 2 - - - - - 15 - 19 - - - 20 - 20 - - Naturals - - 0 - - - 154 - - - - - - - 15 - 15 - - - 20 - 20 - - Naturals - - 0 - - - 333 - - - - - - - - 19 - 19 - - - 20 - 20 - - Naturals - - 0 - - - 334 - - - - - - - - - - - 333 - - - - - - 334 - - - - - - - - 339 - - - - 1 - 1 - - - 21 - 21 - - Naturals - - 0 - a - 0 - - - - 340 - - - - 3 - 3 - - - 21 - 21 - - Naturals - - 0 - b - 0 - - - - 344 - - - - 1 - 19 - - - 21 - 21 - - Naturals - - 0 - > - 2 - - - - - 15 - 19 - - - 21 - 21 - - Naturals - - 0 - - - 154 - - - - - - - 15 - 15 - - - 21 - 21 - - Naturals - - 0 - - - 339 - - - - - - - - 19 - 19 - - - 21 - 21 - - Naturals - - 0 - - - 340 - - - - - - - - - - - 339 - - - - - - 340 - - - - - - - - 345 - - - - 1 - 1 - - - 22 - 22 - - Naturals - - 0 - a - 0 - - - - 346 - - - - 8 - 8 - - - 22 - 22 - - Naturals - - 0 - b - 0 - - - - 350 - - - - 1 - 19 - - - 22 - 22 - - Naturals - - 0 - \leq - 2 - - - - - 15 - 19 - - - 22 - 22 - - Naturals - - 0 - - - 154 - - - - - - - 15 - 15 - - - 22 - 22 - - Naturals - - 0 - - - 345 - - - - - - - - 19 - 19 - - - 22 - 22 - - Naturals - - 0 - - - 346 - - - - - - - - - - - 345 - - - - - - 346 - - - - - - - - 351 - - - - 1 - 1 - - - 23 - 23 - - Naturals - - 0 - a - 0 - - - - 352 - - - - 8 - 8 - - - 23 - 23 - - Naturals - - 0 - b - 0 - - - - 356 - - - - 1 - 19 - - - 23 - 23 - - Naturals - - 0 - \geq - 2 - - - - - 15 - 19 - - - 23 - 23 - - Naturals - - 0 - - - 154 - - - - - - - 15 - 15 - - - 23 - 23 - - Naturals - - 0 - - - 351 - - - - - - - - 19 - 19 - - - 23 - 23 - - Naturals - - 0 - - - 352 - - - - - - - - - - - 351 - - - - - - 352 - - - - - - - - 357 - - - - 1 - 1 - - - 33 - 33 - - Naturals - - 0 - a - 0 - - - - 358 - - - - 5 - 5 - - - 33 - 33 - - Naturals - - 0 - b - 0 - - - - 362 - - - - 1 - 20 - - - 33 - 33 - - Naturals - - 0 - % - 2 - 0 , the following formula is true: *) -(* *) -(* a = b * (a \div b) + (a % b) *) -(***************************************************************************)]]> - - - - - 15 - 20 - - - 33 - 33 - - Naturals - - 0 - - - 256 - - - - - - - 16 - 16 - - - 33 - 33 - - Naturals - - 0 - - - 357 - - - - - - - - 19 - 19 - - - 33 - 33 - - Naturals - - 0 - - - 358 - - - - - - - - - - - 357 - - - - - - 358 - - - - - - - - 363 - - - - 1 - 1 - - - 34 - 34 - - Naturals - - 0 - a - 0 - - - - 364 - - - - 8 - 8 - - - 34 - 34 - - Naturals - - 0 - b - 0 - - - - 368 - - - - 1 - 20 - - - 34 - 34 - - Naturals - - 0 - \div - 2 - - - - - 15 - 20 - - - 34 - 34 - - Naturals - - 0 - - - 256 - - - - - - - 16 - 16 - - - 34 - 34 - - Naturals - - 0 - - - 363 - - - - - - - - 19 - 19 - - - 34 - 34 - - Naturals - - 0 - - - 364 - - - - - - - - - - - 363 - - - - - - 364 - - - - - - - - 369 - - - - 1 - 1 - - - 35 - 35 - - Naturals - - 0 - a - 0 - - - - 370 - - - - 6 - 6 - - - 35 - 35 - - Naturals - - 0 - b - 0 - - - - 374 - - - - 1 - 20 - - - 35 - 35 - - Naturals - - 0 - .. - 2 - - - - - 15 - 20 - - - 35 - 35 - - Naturals - - 0 - - - 256 - - - - - - - 16 - 16 - - - 35 - 35 - - Naturals - - 0 - - - 369 - - - - - - - - 19 - 19 - - - 35 - 35 - - Naturals - - 0 - - - 370 - - - - - - - - - - - 369 - - - - - - 370 - - - - - - - - 379 - - - - 1 - 77 - - - 1 - 362 - - TLAPS - - TLAPS - - 381 - - - 383 - - - 386 - - - 388 - - - 391 - - - 393 - - - 396 - - - 398 - - - 401 - - - 403 - - - 406 - - - 408 - - - 411 - - - 413 - - - 416 - - - 418 - - - 421 - - - 423 - - - 426 - - - 428 - - - 430 - - - 433 - - - 435 - - - 438 - - - 441 - - - 445 - - - 447 - - - 478 - - - 480 - - - 482 - - - 484 - - - 486 - - - 488 - - - 490 - - - 492 - - - 494 - - - 496 - - - 498 - - - 500 - - - 502 - - - 504 - - - 506 - - - 508 - - - 510 - - - 512 - - - 514 - - - 516 - - - 518 - - - 520 - - - 522 - - - 524 - - - 526 - - - 528 - - - 531 - - - 533 - - - 536 - - - 538 - - - 541 - - - 543 - - - 545 - - - 547 - - - 549 - - - 551 - - - 553 - - - 556 - - - 559 - - - 561 - - - 466 - - - 476 - - - - - 381 - - - - 1 - 24 - - - 26 - 26 - - TLAPS - - 0 - SimpleArithmetic - 0 - - - - - - 21 - 24 - - - 26 - 26 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 383 - - - - 1 - 11 - - - 39 - 39 - - TLAPS - - 0 - SMT - 0 - - - - - - 8 - 11 - - - 39 - 39 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 384 - - - - 6 - 6 - - - 40 - 40 - - TLAPS - - X - 0 - - - - 386 - - - - 1 - 15 - - - 40 - 40 - - TLAPS - - 0 - SMTT - 1 - - - - - - 12 - 15 - - - 40 - 40 - - TLAPS - - 0 - - - 152 - - - - - - - - - 384 - - - - - - - - 388 - - - - 1 - 12 - - - 50 - 50 - - TLAPS - - 0 - CVC3 - 0 - - - - - - 9 - 12 - - - 50 - 50 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 389 - - - - 7 - 7 - - - 51 - 51 - - TLAPS - - X - 0 - - - - 391 - - - - 1 - 16 - - - 51 - 51 - - TLAPS - - 0 - CVC3T - 1 - - - - - - 13 - 16 - - - 51 - 51 - - TLAPS - - 0 - - - 152 - - - - - - - - - 389 - - - - - - - - 393 - - - - 1 - 12 - - - 53 - 53 - - TLAPS - - 0 - CVC4 - 0 - - - - - - 9 - 12 - - - 53 - 53 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 394 - - - - 7 - 7 - - - 54 - 54 - - TLAPS - - X - 0 - - - - 396 - - - - 1 - 16 - - - 54 - 54 - - TLAPS - - 0 - CVC4T - 1 - - - - - - 13 - 16 - - - 54 - 54 - - TLAPS - - 0 - - - 152 - - - - - - - - - 394 - - - - - - - - 398 - - - - 1 - 13 - - - 63 - 63 - - TLAPS - - 0 - Yices - 0 - - - - - - 10 - 13 - - - 63 - 63 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 399 - - - - 8 - 8 - - - 64 - 64 - - TLAPS - - X - 0 - - - - 401 - - - - 1 - 17 - - - 64 - 64 - - TLAPS - - 0 - YicesT - 1 - - - - - - 14 - 17 - - - 64 - 64 - - TLAPS - - 0 - - - 152 - - - - - - - - - 399 - - - - - - - - 403 - - - - 1 - 13 - - - 72 - 72 - - TLAPS - - 0 - veriT - 0 - - - - - - 10 - 13 - - - 72 - 72 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 404 - - - - 8 - 8 - - - 73 - 73 - - TLAPS - - X - 0 - - - - 406 - - - - 1 - 17 - - - 73 - 73 - - TLAPS - - 0 - veriTT - 1 - - - - - - 14 - 17 - - - 73 - 73 - - TLAPS - - 0 - - - 152 - - - - - - - - - 404 - - - - - - - - 408 - - - - 1 - 14 - - - 82 - 82 - - TLAPS - - 0 - Zipper - 0 - - - - - - 11 - 14 - - - 82 - 82 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 409 - - - - 9 - 9 - - - 83 - 83 - - TLAPS - - X - 0 - - - - 411 - - - - 1 - 18 - - - 83 - 83 - - TLAPS - - 0 - ZipperT - 1 - - - - - - 15 - 18 - - - 83 - 83 - - TLAPS - - 0 - - - 152 - - - - - - - - - 409 - - - - - - - - 413 - - - - 1 - 10 - - - 92 - 92 - - TLAPS - - 0 - Z3 - 0 - - - - - - 7 - 10 - - - 92 - 92 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 414 - - - - 5 - 5 - - - 93 - 93 - - TLAPS - - X - 0 - - - - 416 - - - - 1 - 14 - - - 93 - 93 - - TLAPS - - 0 - Z3T - 1 - - - - - - 11 - 14 - - - 93 - 93 - - TLAPS - - 0 - - - 152 - - - - - - - - - 414 - - - - - - - - 418 - - - - 1 - 13 - - - 102 - 102 - - TLAPS - - 0 - Spass - 0 - - - - - - 10 - 13 - - - 102 - 102 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 419 - - - - 8 - 8 - - - 103 - 103 - - TLAPS - - X - 0 - - - - 421 - - - - 1 - 17 - - - 103 - 103 - - TLAPS - - 0 - SpassT - 1 - - - - - - 14 - 17 - - - 103 - 103 - - TLAPS - - 0 - - - 152 - - - - - - - - - 419 - - - - - - - - 423 - - - - 1 - 11 - - - 113 - 113 - - TLAPS - - 0 - LS4 - 0 - - - - - - 8 - 11 - - - 113 - 113 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 424 - - - - 6 - 6 - - - 114 - 114 - - TLAPS - - X - 0 - - - - 426 - - - - 1 - 15 - - - 114 - 114 - - TLAPS - - 0 - LS4T - 1 - - - - - - 12 - 15 - - - 114 - 114 - - TLAPS - - 0 - - - 152 - - - - - - - - - 424 - - - - - - - - 428 - - - - 1 - 11 - - - 115 - 115 - - TLAPS - - 0 - PTL - 0 - - - - - - 8 - 11 - - - 115 - 115 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 430 - - - - 1 - 13 - - - 122 - 122 - - TLAPS - - 0 - Zenon - 0 - - - - - - 10 - 13 - - - 122 - 122 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 431 - - - - 8 - 8 - - - 123 - 123 - - TLAPS - - X - 0 - - - - 433 - - - - 1 - 17 - - - 123 - 123 - - TLAPS - - 0 - ZenonT - 1 - - - - - - 14 - 17 - - - 123 - 123 - - TLAPS - - 0 - - - 152 - - - - - - - - - 431 - - - - - - - - 435 - - - - 1 - 11 - - - 130 - 130 - - TLAPS - - 0 - Isa - 0 - - - - - - 8 - 11 - - - 130 - 130 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 436 - - - - 6 - 6 - - - 131 - 131 - - TLAPS - - X - 0 - - - - 438 - - - - 1 - 16 - - - 131 - 131 - - TLAPS - - 0 - IsaT - 1 - - - - - - 13 - 16 - - - 131 - 131 - - TLAPS - - 0 - - - 152 - - - - - - - - - 436 - - - - - - - - 439 - - - - 6 - 6 - - - 132 - 132 - - TLAPS - - X - 0 - - - - 441 - - - - 1 - 16 - - - 132 - 132 - - TLAPS - - 0 - IsaM - 1 - - - - - - 13 - 16 - - - 132 - 132 - - TLAPS - - 0 - - - 152 - - - - - - - - - 439 - - - - - - - - 442 - - - - 7 - 7 - - - 133 - 133 - - TLAPS - - X - 0 - - - - 443 - - - - 9 - 9 - - - 133 - 133 - - TLAPS - - Y - 0 - - - - 445 - - - - 1 - 19 - - - 133 - 133 - - TLAPS - - 0 - IsaMT - 2 - - - - - - 16 - 19 - - - 133 - 133 - - TLAPS - - 0 - - - 152 - - - - - - - - - 442 - - - - - - 443 - - - - - - - - 447 - - - - 1 - 32 - - - 147 - 147 - - TLAPS - - 0 - IsaWithSetExtensionality - 0 - (\A x : (x \in S) <=> (x \in T)) *) -(* *) -(* Theorem SetExtensionality is sometimes required by the SMT backend for *) -(* reasoning about sets. It is usually counterproductive to include *) -(* theorem SetExtensionality in a BY clause for the Zenon or Isabelle *) -(* backends. Instead, use the pragma IsaWithSetExtensionality to instruct *) -(* the Isabelle backend to use the rule of set extensionality. *) -(***************************************************************************)]]> - - - - - 29 - 32 - - - 147 - 147 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 448 - - - - 1 - 7 - - - 150 - 151 - - TLAPS - - 0 - SetExtensionality - - - - 30 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 280 - - - - - - - 39 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 178 - - - - - - - 40 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 280 - - - - - - - 47 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 175 - - - - - - - 47 - 53 - - - 150 - 150 - - TLAPS - - 0 - - - 190 - - - - - - - 47 - 47 - - - 150 - 150 - - TLAPS - - 0 - - - 451 - - - - - - - - 53 - 53 - - - 150 - 150 - - TLAPS - - 0 - - - 449 - - - - - - - - - - 59 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 190 - - - - - - - 59 - 59 - - - 150 - 150 - - TLAPS - - 0 - - - 451 - - - - - - - - 65 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 450 - - - - - - - - - - - - - 451 - - - - - - - - 71 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 154 - - - - - - - 71 - 71 - - - 150 - 150 - - TLAPS - - 0 - - - 449 - - - - - - - - 75 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 450 - - - - - - - - - - - - - 449 - - - - - 450 - - - - - - - - 449 - - - - 33 - 33 - - - 150 - 150 - - TLAPS - - 0 - S - 0 - - - - 450 - - - - 35 - 35 - - - 150 - 150 - - TLAPS - - 0 - T - 0 - - - - 451 - - - - 43 - 43 - - - 150 - 150 - - TLAPS - - 0 - x - 0 - - - - 466 - - - - 1 - 7 - - - 150 - 151 - - TLAPS - - 0 - - - 448 - - - - - - - 30 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 280 - - - - - - - 39 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 178 - - - - - - - 40 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 280 - - - - - - - 47 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 175 - - - - - - - 47 - 53 - - - 150 - 150 - - TLAPS - - 0 - - - 190 - - - - - - - 47 - 47 - - - 150 - 150 - - TLAPS - - 0 - - - 451 - - - - - - - - 53 - 53 - - - 150 - 150 - - TLAPS - - 0 - - - 449 - - - - - - - - - - 59 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 190 - - - - - - - 59 - 59 - - - 150 - 150 - - TLAPS - - 0 - - - 451 - - - - - - - - 65 - 65 - - - 150 - 150 - - TLAPS - - 0 - - - 450 - - - - - - - - - - - - - 451 - - - - - - - - 71 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 154 - - - - - - - 71 - 71 - - - 150 - 150 - - TLAPS - - 0 - - - 449 - - - - - - - - 75 - 75 - - - 150 - 150 - - TLAPS - - 0 - - - 450 - - - - - - - - - - - - - 449 - - - - - 450 - - - - - - - - - 1 - 7 - - - 151 - 151 - - TLAPS - - 0 - - - - - 467 - - - - 1 - 7 - - - 159 - 160 - - TLAPS - - 0 - NoSetContainsEverything - - - - 36 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 280 - - - - - - - 43 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 278 - - - - - - - 50 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 193 - - - - - - - 50 - 50 - - - 159 - 159 - - TLAPS - - 0 - - - 469 - - - - - - - - 59 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 468 - - - - - - - - - - - 469 - - - - - - - - - 468 - - - - - - - - 468 - - - - 39 - 39 - - - 159 - 159 - - TLAPS - - 0 - S - 0 - - - - 469 - - - - 46 - 46 - - - 159 - 159 - - TLAPS - - 0 - x - 0 - - - - 476 - - - - 1 - 7 - - - 159 - 160 - - TLAPS - - 0 - - - 467 - - - - - - - 36 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 280 - - - - - - - 43 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 278 - - - - - - - 50 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 193 - - - - - - - 50 - 50 - - - 159 - 159 - - TLAPS - - 0 - - - 469 - - - - - - - - 59 - 59 - - - 159 - 159 - - TLAPS - - 0 - - - 468 - - - - - - - - - - - 469 - - - - - - - - - 468 - - - - - - - - - 1 - 7 - - - 160 - 160 - - TLAPS - - 0 - - - - - 478 - - - - 1 - 17 - - - 181 - 181 - - TLAPS - - 0 - SlowZenon - 0 - - - - - - 14 - 17 - - - 181 - 181 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 480 - - - - 1 - 19 - - - 182 - 182 - - TLAPS - - 0 - SlowerZenon - 0 - - - - - - 16 - 19 - - - 182 - 182 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 482 - - - - 1 - 21 - - - 183 - 183 - - TLAPS - - 0 - VerySlowZenon - 0 - - - - - - 18 - 21 - - - 183 - 183 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 484 - - - - 1 - 20 - - - 184 - 184 - - TLAPS - - 0 - SlowestZenon - 0 - - - - - - 17 - 20 - - - 184 - 184 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 486 - - - - 1 - 12 - - - 195 - 195 - - TLAPS - - 0 - Auto - 0 - - - - - - 9 - 12 - - - 195 - 195 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 488 - - - - 1 - 16 - - - 196 - 196 - - TLAPS - - 0 - SlowAuto - 0 - - - - - - 13 - 16 - - - 196 - 196 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 490 - - - - 1 - 18 - - - 197 - 197 - - TLAPS - - 0 - SlowerAuto - 0 - - - - - - 15 - 18 - - - 197 - 197 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 492 - - - - 1 - 19 - - - 198 - 198 - - TLAPS - - 0 - SlowestAuto - 0 - - - - - - 16 - 19 - - - 198 - 198 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 494 - - - - 1 - 13 - - - 206 - 206 - - TLAPS - - 0 - Force - 0 - - - - - - 10 - 13 - - - 206 - 206 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 496 - - - - 1 - 17 - - - 207 - 207 - - TLAPS - - 0 - SlowForce - 0 - - - - - - 14 - 17 - - - 207 - 207 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 498 - - - - 1 - 19 - - - 208 - 208 - - TLAPS - - 0 - SlowerForce - 0 - - - - - - 16 - 19 - - - 208 - 208 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 500 - - - - 1 - 20 - - - 209 - 209 - - TLAPS - - 0 - SlowestForce - 0 - - - - - - 17 - 20 - - - 209 - 209 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 502 - - - - 1 - 31 - - - 219 - 219 - - TLAPS - - 0 - SimplifyAndSolve - 0 - - - - - - 28 - 31 - - - 219 - 219 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 504 - - - - 1 - 31 - - - 221 - 221 - - TLAPS - - 0 - SlowSimplifyAndSolve - 0 - - - - - - 28 - 31 - - - 221 - 221 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 506 - - - - 1 - 31 - - - 223 - 223 - - TLAPS - - 0 - SlowerSimplifyAndSolve - 0 - - - - - - 28 - 31 - - - 223 - 223 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 508 - - - - 1 - 31 - - - 225 - 225 - - TLAPS - - 0 - SlowestSimplifyAndSolve - 0 - - - - - - 28 - 31 - - - 225 - 225 - - TLAPS - - 0 - - - 152 - - - - - - - - - - 510 - - - - 1 - 22 - - - 228 - 228 - - TLAPS - - 0 - Simplification - 0 - - - - - - 19 - 22 - - - 228 - 228 - - TLAPS - - 0 - - - 152 - - - - - - - - - - - 304 - - - 379 - - - 566 - - diff --git a/test/sany/dune b/test/sany/dune index d372b677..fe0609ab 100644 --- a/test/sany/dune +++ b/test/sany/dune @@ -2,6 +2,5 @@ (name sany_tests) (modes exe) (libraries tlapm_lib ounit2 sexplib sexp_diff) - (deps Test.tla AddTwo.tla) (preprocess (pps ppx_deriving.show)) ) diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index f13cca6e..3b804047 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -24,9 +24,18 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"Chameneos.tla"; String.ends_with ~suffix:"Stones.tla"; String.ends_with ~suffix:"glowingRaccoon/product.tla"; + String.ends_with ~suffix:"CarTalkPuzzle.tla"; + String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_1/MC.tla"; + String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_2/MC.tla"; + String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_3/MC.tla"; + String.ends_with ~suffix:"EWD840_json.tla"; + String.ends_with ~suffix:"SingleLaneBridge.tla"; + String.ends_with ~suffix:"SingleLaneBridge/MC.tla"; + has_substring "/tower_of_hanoi/"; (* Subexpressions *) String.ends_with ~suffix:"MCPaxos.tla"; String.ends_with ~suffix:"MCVoting.tla"; + String.ends_with ~suffix:"EWD840_proof.tla"; (* Community modules *) String.ends_with ~suffix:"MCtcp.tla"; String.ends_with ~suffix:"tcp.tla"; @@ -36,9 +45,23 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"SimTokenRing.tla"; String.ends_with ~suffix:"EWD687a_anim.tla"; String.ends_with ~suffix:"EWD687a.tla"; + String.ends_with ~suffix:"Huang.tla"; + String.ends_with ~suffix:"EWD840_anim.tla"; + String.ends_with ~suffix:"KnuthYao.tla"; has_substring "/ewd998/"; + (* PlusCal? *) + String.ends_with ~suffix:"AddTwo.tla"; ] in not (List.exists (fun pred -> pred path) preds) +let start_at (filename : string) (files : string list) : string list = + let rec drop_until (paths : string list) : string list = + match paths with + | [] -> [] + | hd :: tl -> + if String.ends_with ~suffix:filename hd then tl + else drop_until tl + in drop_until files + let parse_tla_file filename = let open Stdlib in print_endline ("Parsing " ^ filename ^ " ..."); @@ -52,5 +75,8 @@ let parse_tla_file filename = let _ = parser_backend := Sany; add_debug_flag "sany"; - let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run in - List.map parse_tla_file tla_files + let tla_files = + find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" + |> List.filter should_run + |> start_at "EWD840.tla" + in List.map parse_tla_file tla_files From e7d6e2a5deeba6fd73fb967faf09c0bd08872c43 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 9 Feb 2026 15:36:07 -0800 Subject: [PATCH 58/85] Convert all examples specs Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 17 +++++++++++++++++ src/sany/xml.ml | 4 +++- test/sany/sany_tests.ml | 21 +++++++++++++++++++-- 3 files changed, 39 insertions(+), 3 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 95e6789f..c1ed6a33 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -362,6 +362,8 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | "$BoundedForall" -> convert_quantification Forall apply | "$UnboundedExists" -> convert_quantification Exists apply | "$UnboundedForall" -> convert_quantification Forall apply + | "$TemporalExists" -> convert_temporal_quantification Exists apply + | "$TemporalForall" -> convert_temporal_quantification Forall apply | "$SetOfAll" -> convert_set_map apply | "$SubsetOf" -> convert_set_filter apply | "$SetOfFcns" -> convert_function_set apply @@ -637,6 +639,21 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node | _ -> conversion_failure "Invalid number of bounds or operands to quantification" apply.node.location ) |> attach_props apply.node +(** Temporal quantification; these symbols are always unbound. +*) +and convert_temporal_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) : Expr.T.expr = ( + match apply.bound_symbols, apply.operands with + | _ :: _, [Expression body] -> + let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) apply.bound_symbols in + if List.length unbound_symbols <> List.length apply.bound_symbols + then conversion_failure "Temporal quantification requires unbound symbols" apply.node.location + else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols + then conversion_failure "Unbounded tuple quantification is not supported" apply.node.location + else let bounds = List.map (fun (b : Xml.unbound_symbol) -> resolve_bound_symbol b.symbol_ref) unbound_symbols in + Tquant (quant, bounds, convert_expression body) + | _ -> conversion_failure "Invalid number of bounds or operands to temporal quantification" apply.node.location +) |> attach_props apply.node + (** Conversion of expressions of the form {f(x, y) : x \in S, y \in Z} *) and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 5f20e179..4857a12c 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -218,7 +218,9 @@ let xml_to_numeral_node (children : tree list) : int literal = let xml_to_string_node (children : tree list) : string literal = match extract_inline_node children with | node, [Node ("StringValue", [SValue value])] -> {node; value} - | _ -> ls_conversion_failure __FUNCTION__ children + (* Sometimes strings can accidentally be converted into integers! *) + | node, [Node ("StringValue", [IValue value])] -> {node; value = Int.to_string value} + | node, children -> ls_conversion_failure __FUNCTION__ children type leibniz_param = { ref : int; diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 3b804047..0d1c040d 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -31,11 +31,17 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"EWD840_json.tla"; String.ends_with ~suffix:"SingleLaneBridge.tla"; String.ends_with ~suffix:"SingleLaneBridge/MC.tla"; + String.ends_with ~suffix:"GameOfLife.tla"; + String.ends_with ~suffix:"btree.tla"; + String.ends_with ~suffix:"Nano.tla"; has_substring "/tower_of_hanoi/"; (* Subexpressions *) String.ends_with ~suffix:"MCPaxos.tla"; String.ends_with ~suffix:"MCVoting.tla"; String.ends_with ~suffix:"EWD840_proof.tla"; + String.ends_with ~suffix:"BPConProof.tla"; + String.ends_with ~suffix:"PConProof.tla"; + String.ends_with ~suffix:"VoteProof.tla"; (* Community modules *) String.ends_with ~suffix:"MCtcp.tla"; String.ends_with ~suffix:"tcp.tla"; @@ -48,12 +54,23 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"Huang.tla"; String.ends_with ~suffix:"EWD840_anim.tla"; String.ends_with ~suffix:"KnuthYao.tla"; + String.ends_with ~suffix:"TransitiveClosure.tla"; + String.ends_with ~suffix:"ClientCentric.tla"; + String.ends_with ~suffix:"KVsnap.tla"; + String.ends_with ~suffix:"KeyValueStore/Util.tla"; + String.ends_with ~suffix:"YoYoNoPruning.tla"; + String.ends_with ~suffix:"YoYoPruning.tla"; + String.ends_with ~suffix:"YoYoAllGraphs.tla"; + has_substring "/SDP_Attack_New_Solution_Spec/"; + has_substring "/SDP_Attack_Spec/"; has_substring "/ewd998/"; + (* Apalache *) + String.ends_with ~suffix:"Einstein.tla"; (* PlusCal? *) String.ends_with ~suffix:"AddTwo.tla"; ] in not (List.exists (fun pred -> pred path) preds) -let start_at (filename : string) (files : string list) : string list = +let _start_at (filename : string) (files : string list) : string list = let rec drop_until (paths : string list) : string list = match paths with | [] -> [] @@ -78,5 +95,5 @@ let _ = let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run - |> start_at "EWD840.tla" + (*|> _start_at "SimpleAllocator.tla"*) in List.map parse_tla_file tla_files From 486974af724f1bb214283376333013a92f66675b Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 16 Feb 2026 16:39:37 -0800 Subject: [PATCH 59/85] Enumerate SANY's built-in operators Signed-off-by: Andrew Helwer --- AddTwo.tla => AddTwoRenamed.tla | 0 src/sany/sany.ml | 302 +++++++++++++++++--------------- src/sany/xml.ml | 172 ++++++++++++++++-- test/sany/sany_tests.ml | 6 +- 4 files changed, 319 insertions(+), 161 deletions(-) rename AddTwo.tla => AddTwoRenamed.tla (100%) diff --git a/AddTwo.tla b/AddTwoRenamed.tla similarity index 100% rename from AddTwo.tla rename to AddTwoRenamed.tla diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c1ed6a33..4b762ae4 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -25,7 +25,7 @@ abstract which is presented to us here. Thus the SANY AST has already been processed significantly, and we are translating it to a form that is comparatively much rougher & earlier in the parse process. - + There are two places in this conversion code where we revert to actually just parsing the underlying "raw" TLA+ syntax from SANY's AST: proof names and references to named instanced modules. We need to parse proof names @@ -277,107 +277,134 @@ let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def | Previous n -> Unnamed (n + 1, uid) | Known n -> Unnamed (n, uid) -(** Converts built-in prefix, infix, and postfix operators along with keywords. - Also includes some standard module operators like + and -. - TODO: handle case where user overrides a standard module operator name. -*) -let try_convert_builtin (builtin : Xml.built_in_kind) : Builtin.builtin option = - match builtin.name with +let sany_to_tlapm_builtin (node : Xml.node) (builtin : Xml.built_in_operator) : Builtin.builtin = + match builtin with (* Reserved words *) - | "TRUE" -> Some Builtin.TRUE - | "FALSE" -> Some Builtin.FALSE - | "BOOLEAN" -> Some Builtin.BOOLEAN - | "STRING" -> Some Builtin.STRING - + | TRUE -> Builtin.TRUE + | FALSE -> Builtin.FALSE + | BOOLEAN -> Builtin.BOOLEAN + | STRING -> Builtin.STRING (* Prefix operators *) - | "\\lnot" -> Some Builtin.Neg - | "UNION" -> Some Builtin.UNION - | "SUBSET" -> Some Builtin.SUBSET - | "DOMAIN" -> Some Builtin.DOMAIN - | "ENABLED" -> Some Builtin.ENABLED - | "UNCHANGED" -> Some Builtin.UNCHANGED - | "[]" -> Some (Builtin.Box false) - | "<>" -> Some Builtin.Diamond - + | LogicalNegation -> Builtin.Neg + | UNION -> Builtin.UNION + | SUBSET -> Builtin.SUBSET + | DOMAIN -> Builtin.DOMAIN + | ENABLED -> Builtin.ENABLED + | UNCHANGED -> Builtin.UNCHANGED + | Always -> (Builtin.Box false) (* TODO: figure out meaning of false parameter *) + | Eventually -> Builtin.Diamond (* Postfix operators *) - | "'" -> Some Builtin.Prime - + | Prime -> Builtin.Prime (* Infix operators *) - | "+" -> Some Builtin.Plus - | "-" -> Some Builtin.Minus - | "*" -> Some Builtin.Times - | "\\in" -> Some Builtin.Mem - | "\\notin" -> Some Builtin.Notmem - | "=>" -> Some Builtin.Implies - | "\\equiv" -> Some Builtin.Equiv - | "\\land" -> Some Builtin.Conj - | "\\lor" -> Some Builtin.Disj - | "=" -> Some Builtin.Eq - | "/=" -> Some Builtin.Neq - | "\\" -> Some Builtin.Setminus - | "\\intersect" -> Some Builtin.Cap - | "\\union" -> Some Builtin.Cup - | "\\subseteq" -> Some Builtin.Subseteq - | "~>" -> Some Builtin.Leadsto - | "\\cdot" -> Some Builtin.Cdot - | "-+->" -> Some Builtin.Actplus - | _ -> None + | SetIn -> Builtin.Mem + | SetNotIn -> Builtin.Notmem + | Implies -> Builtin.Implies + | Equivalent -> Builtin.Equiv + | Conjunction -> Builtin.Conj + | Disjunction -> Builtin.Disj + | Equals -> Builtin.Eq + | NotEquals -> Builtin.Neq + | SetMinus -> Builtin.Setminus + | Union -> Builtin.Cup + | Intersect -> Builtin.Cap + | SubsetEq -> Builtin.Subseteq + | LeadsTo -> Builtin.Leadsto + | ActionComposition -> Builtin.Cdot + | PlusArrow -> Builtin.Actplus + | _ -> conversion_failure ("SANY built-in operator cannot be translated to TLAPM built-in operator: " ^ Xml.show_built_in_operator builtin) node.location (** Conversion of application of all traditional built-in operators like = or \cup but also things like CHOOSE and \A which one would ordinarily not view as built-in operators. *) let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_kind) : Expr.T.expr = - match try_convert_builtin op with - (* Traditional built-in operators *) - | Some builtin -> Apply ( + (** TLAPM has a specific set of operators it considers "built in" which is + different from the set that SANY consideres "built-in"; this function + constructs operators for the TLAPM built-in operator set. + *) + let mk (builtin : Builtin.builtin) : Expr.T.expr = Apply ( Internal builtin |> attach_props op.node, apply.operands |> as_expr_ls (Builtin.builtin_to_string builtin) apply.node.location |> List.map convert_expression ) |> attach_props apply.node - (* More abstract kinds of built-in operators *) - | None -> - match op.name with - | "$SetEnumerate" -> SetEnum ( - apply.operands |> as_expr_ls "$SetEnumerate" apply.node.location |> List.map convert_expression + in match op.operator with + (* Reserved words *) + | TRUE -> mk Builtin.TRUE + | FALSE -> mk Builtin.FALSE + | BOOLEAN -> mk Builtin.BOOLEAN + | STRING -> mk Builtin.STRING + (* Prefix operators *) + | LogicalNegation -> mk Builtin.Neg + | UNION -> mk Builtin.UNION + | SUBSET -> mk Builtin.SUBSET + | DOMAIN -> mk Builtin.DOMAIN + | ENABLED -> mk Builtin.ENABLED + | UNCHANGED -> mk Builtin.UNCHANGED + | Always -> mk (Builtin.Box false) (* TODO: figure out meaning of false parameter *) + | Eventually -> mk Builtin.Diamond + (* Postfix operators *) + | Prime -> mk Builtin.Prime + (* Infix operators *) + | SetIn -> mk Builtin.Mem + | SetNotIn -> mk Builtin.Notmem + | Implies -> mk Builtin.Implies + | Equivalent -> mk Builtin.Equiv + | Conjunction -> mk Builtin.Conj + | Disjunction -> mk Builtin.Disj + | Equals -> mk Builtin.Eq + | NotEquals -> mk Builtin.Neq + | SetMinus -> mk Builtin.Setminus + | Union -> mk Builtin.Cup + | Intersect -> mk Builtin.Cap + | SubsetEq -> mk Builtin.Subseteq + | LeadsTo -> mk Builtin.Leadsto + | ActionComposition -> mk Builtin.Cdot + | PlusArrow -> mk Builtin.Actplus + (* Language operators *) + | FiniteSetLiteral -> SetEnum ( + apply.operands |> as_expr_ls "FiniteSetLiteral" apply.node.location |> List.map convert_expression ) |> attach_props apply.node - | "$Tuple" -> Tuple ( - apply.operands |> as_expr_ls "$Tuple" apply.node.location |> List.map convert_expression + | TupleLiteral -> Tuple ( + apply.operands |> as_expr_ls "TupleLiteral" apply.node.location |> List.map convert_expression ) |> attach_props apply.node - | "$ConjList" -> List ( - And, apply.operands |> as_expr_ls "$ConjList" apply.node.location |> List.map convert_expression + | ConjunctionList -> List ( + And, apply.operands |> as_expr_ls "ConjunctionList" apply.node.location |> List.map convert_expression ) |> attach_props apply.node - | "$DisjList" -> List ( - Or, apply.operands |> as_expr_ls "$DisjList" apply.node.location |> List.map convert_expression + | DisjunctionList -> List ( + Or, apply.operands |> as_expr_ls "DisjunctionList" apply.node.location |> List.map convert_expression ) |> attach_props apply.node - | "$CartesianProd" -> Product ( - apply.operands |> as_expr_ls "$CartesianProd" apply.node.location |> List.map convert_expression + | CartesianProduct -> Product ( + apply.operands |> as_expr_ls "CartesianProduct" apply.node.location |> List.map convert_expression ) |> attach_props apply.node - | "$WF" -> convert_fairness Weak apply - | "$SF" -> convert_fairness Strong apply - | "$BoundedChoose" -> convert_choose apply - | "$UnboundedChoose" -> convert_choose apply - | "$SquareAct" -> convert_action_expr Box apply - | "$AngleAct" -> convert_action_expr Dia apply - | "$BoundedExists" -> convert_quantification Exists apply - | "$BoundedForall" -> convert_quantification Forall apply - | "$UnboundedExists" -> convert_quantification Exists apply - | "$UnboundedForall" -> convert_quantification Forall apply - | "$TemporalExists" -> convert_temporal_quantification Exists apply - | "$TemporalForall" -> convert_temporal_quantification Forall apply - | "$SetOfAll" -> convert_set_map apply - | "$SubsetOf" -> convert_set_filter apply - | "$SetOfFcns" -> convert_function_set apply - | "$FcnConstructor" -> convert_function_constructor apply - | "$RecursiveFcnSpec" -> convert_function_definition true apply - | "$NonRecursiveFcnSpec" -> convert_function_definition false apply - | "$FcnApply" -> convert_function_application apply - | "$SetOfRcds" -> convert_record_set apply - | "$RcdConstructor" -> convert_record_constructor apply - | "$RcdSelect" -> convert_record_select apply - | "$Except" -> convert_except apply - | "$IfThenElse" -> convert_if_then_else apply - | "$Case" -> convert_case apply - | s -> todo "Built-in operator" s apply.node.location + | WeakFairness -> convert_fairness Weak apply + | StrongFairness -> convert_fairness Strong apply + | BoundedChoose -> convert_choose apply + | UnboundedChoose -> convert_choose apply + | ActionOrStutter -> convert_action_expr Box apply + | ActionNoStutter -> convert_action_expr Dia apply + | BoundedExists -> convert_quantification Exists apply + | BoundedForAll -> convert_quantification Forall apply + | UnboundedExists -> convert_quantification Exists apply + | UnboundedForAll -> convert_quantification Forall apply + | TemporalExists -> convert_temporal_quantification Exists apply + | TemporalForAll -> convert_temporal_quantification Forall apply + | FiniteSetMap -> convert_set_map apply + | FiniteSetFilter -> convert_set_filter apply + | FunctionSet -> convert_function_set apply + | FunctionConstructor -> convert_function_constructor apply + | FunctionDefinition -> convert_function_definition false apply + | RecursiveFunctionDefinition -> convert_function_definition true apply + | FunctionApplication -> convert_function_application apply + | RecordSet -> convert_record_set apply + | RecordConstructor -> convert_record_constructor apply + | RecordSelect -> convert_record_select apply + | Except -> convert_except apply + | IfThenElse -> convert_if_then_else apply + | Case -> convert_case apply + (* Grouping operators *) + | Pair | Sequence + (* Proof step operators *) + | CaseProofStep | PickProofStep | TakeProofStep | WitnessProofStep | SufficesProofStep | QedProofStep + -> conversion_failure ("Operator invalid at this location : " ^ Xml.show_built_in_operator op.operator) apply.node.location (** Converts a top-level module node. *) and convert_module_node (mule : Xml.module_node) : Module.T.mule = @@ -592,7 +619,6 @@ and convert_bound_or_unbound_symbols (node : Xml.node) (all_symbols : Xml.symbol then conversion_failure "Cannot mix bound and unbound symbols" node.location else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols then conversion_failure "Unbounded tuple quantification is not supported" node.location - (* Unbounded *) else let mk_bound (bound : Xml.unbound_symbol) : bound = ( resolve_bound_symbol bound.symbol_ref, Unknown, (* TODO: figure out purpose of this parameter *) @@ -643,7 +669,7 @@ and convert_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node *) and convert_temporal_quantification (quant : Expr.T.quantifier) (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | _ :: _, [Expression body] -> + | _ :: _, [Expression body] -> let unbound_symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound b -> Some b | _ -> None) apply.bound_symbols in if List.length unbound_symbols <> List.length apply.bound_symbols then conversion_failure "Temporal quantification requires unbound symbols" apply.node.location @@ -752,24 +778,28 @@ and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = and convert_record_constructor (apply : Xml.op_appl_node) : Expr.T.expr = convert_record_operator apply (fun arg -> Record arg) +(** Utility function to convert a list of operands to a list of expression pairs. +*) +and as_pair (node : Xml.node) (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) = + match operand with + | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression left; Expression right]} -> ( + match (resolve_ref operator).kind with + | BuiltInKind {operator = Pair} -> (left, right) + | _ -> conversion_failure "Expected pair of expressions" node.location + ) | _ -> conversion_failure "Expected pair of expressions" node.location + (** The conversion logic for both record sets and record constructors is identical except for the wrapping constructor (Rect vs Record). This method captures that shared logic, taking the constructor as a parameter. *) and convert_record_operator (apply : Xml.op_appl_node) (constructor : (string * Expr.T.expr) list -> Expr.T.expr_) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | [], (_ :: _ as pairs) -> - let mk_field (operand : Xml.expression) : (string * Expr.T.expr) option = - match operand with - | OpApplNode {operator; bound_symbols = []; operands = [Expression StringNode {value}; Expression right]} -> ( - match (resolve_ref operator).kind with - | BuiltInKind {name = "$Pair"} -> Some (value, convert_expression right) - | _ -> None - ) | _ -> None - in let fields = pairs |> as_expr_ls __FUNCTION__ apply.node.location |> List.filter_map mk_field in - if List.length fields <> List.length pairs - then conversion_failure "Invalid operands to record operator; expected pairs of expressions" apply.node.location - else constructor fields + | [], _ :: _ -> + let mk_field (left, right : Xml.expression * Xml.expression) : (string * Expr.T.expr) = + match left, right with + | StringNode {value}, expr -> (value, convert_expression expr) + | _ -> conversion_failure "Expected field name to be a string" apply.node.location + in apply.operands |> List.map (as_pair apply.node) |> List.map mk_field |> constructor | _ -> conversion_failure "Invalid operands to record operator" apply.node.location ) |> attach_props apply.node @@ -791,7 +821,7 @@ and convert_except (apply : Xml.op_appl_node) : Expr.T.expr = ( match operand with | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression OpApplNode {operator = update_op; bound_symbols = []; operands = update_path}; Expression new_value]} -> ( match (resolve_ref operator).kind, (resolve_ref update_op).kind with - | BuiltInKind {name = "$Pair"}, BuiltInKind {name = "$Seq"} -> + | BuiltInKind {operator = Pair}, BuiltInKind {operator = Sequence} -> let path = update_path |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression in Some (List.map mk_path path, convert_expression new_value) | _ -> None @@ -817,17 +847,7 @@ and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [], _ :: _ -> ( - let as_pair (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) option = - match operand with - | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression cond; Expression result]} -> ( - match (resolve_ref operator).kind with - | BuiltInKind {name = "$Pair"} -> Some (cond, result) - | _ -> None - ) | _ -> None - in let cases = List.filter_map as_pair apply.operands in - if List.length cases <> List.length apply.operands - then conversion_failure "Invalid operands to CASE; expected pairs of expressions" apply.node.location - else + let cases = List.map (as_pair apply.node) apply.operands in let mk_case ((predicate, expr) : Xml.expression * Xml.expression) : (Expr.T.expr * Expr.T.expr) = (convert_expression predicate, convert_expression expr) in match split_last_ls apply.node cases with @@ -906,9 +926,9 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp | OpArg uid -> match (resolve_ref uid).kind with | FormalParamNode param -> Opaque param.name |> attach_props param.node | UserDefinedOpKind userdef -> Opaque userdef.name |> attach_props userdef.node - | BuiltInKind builtin -> (match try_convert_builtin builtin with - | Some b -> Internal b |> attach_props builtin.node - | None -> todo "Built-in operator argument" builtin.name builtin.node.location) + | BuiltInKind builtin -> + let op = sany_to_tlapm_builtin builtin.node builtin.operator in + Internal op |> attach_props builtin.node | OpDeclNode decl -> Opaque decl.name |> attach_props decl.node | AssumeNode assume -> conversion_failure "Invalid operator argument reference to ASSUME" assume.node.location | AssumeDefNode assume -> conversion_failure ("Invalid operator argument reference to ASSUME: " ^ assume.name) assume.node.location @@ -940,18 +960,18 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = given expression to properly evaluate it. Here, we throw away all of that information and let TLAPM re-derive the substitutions later on in the parse process. - + Example: M == INSTANCE Mod WITH x <- y op == M!op - + Here, the expression M!op is given as a subst_in_node. Compare this with an INSTANCE import that does not use substitution: - + M == INSTANCE Naturals op == M!Nat - + In this case, M!Nat is actually introduced as a new operator named M!Nat in the importing module, and directly referenced with the usual uid-based resolution mechanism. This might spell trouble for TLAPM as M!Nat is not @@ -982,14 +1002,13 @@ and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr (** Converts user-defined operators defined within LET/IN expressions. *) -and convert_user_defined_op_kind (xml : Xml.user_defined_op_kind) : Expr.T.defn = - let name = attach_props xml.node xml.name in - let body = xml.body |> convert_expression in +and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = + let body = convert_expression op.body in (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) - let expr = match xml.params with + let expr = match op.params with | [] -> body - | params -> Lambda (List.map resolve_leibniz_formal_param_node params, body) |> attach_props xml.node - in Operator (name, expr) |> attach_props xml.node + | params -> Lambda (List.map resolve_leibniz_formal_param_node params, body) |> attach_props op.node + in Operator (attach_props op.node op.name, expr) |> attach_props op.node (** Converts user-defined operators defined in a module top-level. *) @@ -1082,18 +1101,15 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p AST node. *) and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = - (* Splits the proof steps into ordinary proof steps and a final QED step. *) - let split_steps (steps : Xml.proof_step_group list) : (Xml.proof_step_group list * int) = - match List.rev steps with - | [] -> conversion_failure "Step-based proofs must have at least one step" node.location - | TheoremNodeRef uid :: rest -> (List.rev rest, uid) - | _ -> conversion_failure "Final (QED) step of a step-based proof must be a theorem reference" node.location - in let convert_qed_step (proof_level : proof_level) (uid : int) : Proof.T.qed_step * proof_level = - let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name uid proof_level thm.definition in - let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in - attach_proof_step_name step_name qed_step, Known (step_number step_name) - in let steps, qed = split_steps steps + let convert_qed_step (proof_level : proof_level) (qed_proof_step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = + match qed_proof_step with + | TheoremNodeRef uid -> + let thm = resolve_theorem_node uid in + let step_name = convert_proof_step_name uid proof_level thm.definition in + let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in + attach_proof_step_name step_name qed_step, Known (step_number step_name) + | _ -> conversion_failure "QED step must be a theorem node" node.location + in let steps, qed = split_last_ls node steps in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps in let qed_step, proof_level = convert_qed_step proof_level qed in let proof_level = match proof_level with @@ -1105,7 +1121,7 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} (** Converts a specific proof step into the Proof.T.step variant expected by TLAPM. While TLAPM has thirteen proof variants as of this writing, SANY - bundles everything into only five: DefStepNode (where the user introduces + bundles everything into only five: DefStepNode (where the user introduces new operator definitions into scope), UseOrHideNode, InstanceNode (removed from TLA+; see https://github.com/tlaplus/rfcs/issues/18), TheoremNodeRef, and TheoremNode. In keeping with the odd duplication of purpose between @@ -1133,23 +1149,23 @@ and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (s (* TODO: attach name to UseOrHide step *) | UseOrHide use_or_hide -> (Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level | TheoremNodeRef uid -> - let is_op (uid : int) (op_name : string) : bool = + let is_op (uid : int) (op : Xml.built_in_operator) : bool = match (resolve_ref uid).kind with - | BuiltInKind op when op.name = op_name -> true + | BuiltInKind {operator} when operator = op -> true | _ -> false in let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in let proof = convert_proof uid (step_number step_name) thm.proof in let step = match thm.body with - | Expression OpApplNode ({operator} as apply) when is_op operator "$Pfcase" -> + | Expression OpApplNode ({operator} as apply) when is_op operator CaseProofStep -> convert_case_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_op operator "$Pick" -> + | Expression OpApplNode ({operator} as apply) when is_op operator PickProofStep -> convert_pick_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_op operator "$Take" -> + | Expression OpApplNode ({operator} as apply) when is_op operator TakeProofStep -> convert_take_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_op operator "$Witness" -> + | Expression OpApplNode ({operator} as apply) when is_op operator WitnessProofStep -> convert_witness_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_op operator "$Suffices" -> + | Expression OpApplNode ({operator} as apply) when is_op operator SufficesProofStep -> convert_suffices_proof_step apply proof | _ -> Suffices (convert_sequent thm.body, proof) in (step |> attach_props thm.node |> attach_proof_step_name step_name) :: steps, Known (step_number step_name) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 4857a12c..8599078d 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -647,29 +647,171 @@ let xml_to_op_decl_node (children : tree list) : op_decl_node = } | _ -> ls_conversion_failure __FUNCTION__ children +type built_in_operator = + (* Reserved words *) + | TRUE + | FALSE + | BOOLEAN + | STRING + (* Prefix operators *) + | LogicalNegation + | UNION + | SUBSET + | DOMAIN + | ENABLED + | UNCHANGED + | Always + | Eventually + (* Postfix operators *) + | Prime + (* Infix operators *) + | SetIn + | SetNotIn + | Implies + | Equivalent + | Conjunction + | Disjunction + | Equals + | NotEquals + | SetMinus + | Union + | Intersect + | SubsetEq + | LeadsTo + | ActionComposition + | PlusArrow + (* Language operators *) + | FiniteSetLiteral + | TupleLiteral + | ConjunctionList + | DisjunctionList + | CartesianProduct + | WeakFairness + | StrongFairness + | BoundedChoose + | UnboundedChoose + | ActionOrStutter + | ActionNoStutter + | BoundedExists + | BoundedForAll + | UnboundedExists + | UnboundedForAll + | TemporalExists + | TemporalForAll + | FiniteSetMap + | FiniteSetFilter + | FunctionSet + | FunctionConstructor + | FunctionDefinition + | RecursiveFunctionDefinition + | FunctionApplication + | RecordSet + | RecordConstructor + | RecordSelect + | Except + | IfThenElse + | Case + | Pair + | Sequence + | CaseProofStep + | PickProofStep + | TakeProofStep + | WitnessProofStep + | SufficesProofStep + | QedProofStep +[@@deriving show] + +let xml_to_built_in_operator (name : string) : built_in_operator = + match name with + | "TRUE" -> TRUE + | "FALSE" -> FALSE + | "BOOLEAN" -> BOOLEAN + | "STRING" -> STRING + | "\\lnot" -> LogicalNegation + | "UNION" -> UNION + | "SUBSET" -> SUBSET + | "DOMAIN" -> DOMAIN + | "ENABLED" -> ENABLED + | "UNCHANGED" -> UNCHANGED + | "[]" -> Always + | "<>" -> Eventually + | "'" -> Prime + | "\\in" -> SetIn + | "\\notin" -> SetNotIn + | "=>" -> Implies + | "\\equiv" -> Equivalent + | "\\land" -> Conjunction + | "\\lor" -> Disjunction + | "=" -> Equals + | "/=" -> NotEquals + | "\\" -> SetMinus + | "\\union" -> Union + | "\\intersect" -> Intersect + | "\\subseteq" -> SubsetEq + | "~>" -> LeadsTo + | "\\cdot" -> ActionComposition + | "-+->" -> PlusArrow + | "$SetEnumerate" -> FiniteSetLiteral + | "$Tuple" -> TupleLiteral + | "$ConjList" -> ConjunctionList + | "$DisjList" -> DisjunctionList + | "$CartesianProd" -> CartesianProduct + | "$WF" -> WeakFairness + | "$SF" -> StrongFairness + | "$BoundedChoose" -> BoundedChoose + | "$UnboundedChoose" -> UnboundedChoose + | "$SquareAct" -> ActionOrStutter + | "$AngleAct" -> ActionNoStutter + | "$BoundedExists" -> BoundedExists + | "$BoundedForall" -> BoundedForAll + | "$UnboundedExists" -> UnboundedExists + | "$UnboundedForall" -> UnboundedForAll + | "$TemporalExists" -> TemporalExists + | "$TemporalForall" -> TemporalForAll + | "$SetOfAll" -> FiniteSetMap + | "$SubsetOf" -> FiniteSetFilter + | "$SetOfFcns" -> FunctionSet + | "$FcnConstructor" -> FunctionConstructor + | "$NonRecursiveFcnSpec" -> FunctionDefinition + | "$RecursiveFcnSpec" -> RecursiveFunctionDefinition + | "$FcnApply" -> FunctionApplication + | "$SetOfRcds" -> RecordSet + | "$RcdConstructor" -> RecordConstructor + | "$RcdSelect" -> RecordSelect + | "$Except" -> Except + | "$IfThenElse" -> IfThenElse + | "$Case" -> Case + | "$Pair" -> Pair + | "$Seq" -> Sequence + | "$Pfcase" -> CaseProofStep + | "$Pick" -> PickProofStep + | "$Take" -> TakeProofStep + | "$Witness" -> WitnessProofStep + | "$Suffices" -> SufficesProofStep + | "$Qed" -> QedProofStep + | name -> conversion_failure __FUNCTION__ (SValue name) + type built_in_kind = { node : node; - name : string; + operator : built_in_operator; arity : int; params : leibniz_param list; } [@@deriving show] let xml_to_built_in_kind (children : tree list) : built_in_kind = - match extract_inline_node children with - | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity]); Node ("params", params)] -> { - node; - name; - arity; - params = List.map xml_to_leibniz_param params; - } - | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> { - node; - name; - arity; - params = []; - } - | _ -> ls_conversion_failure __FUNCTION__ children + let node, name, arity, params = match extract_inline_node children with + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity]); Node ("params", params)] -> + node, name, arity, List.map xml_to_leibniz_param params + | node, [Node ("uniquename", [SValue name]); Node ("arity", [IValue arity])] -> + node, name, arity, [] + | _ -> ls_conversion_failure __FUNCTION__ children + in { + node; + operator = xml_to_built_in_operator name; + arity; + params + } type assume_def_node = { node : node; diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 0d1c040d..092c82dd 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -66,7 +66,7 @@ let should_run (path : string) : bool = has_substring "/ewd998/"; (* Apalache *) String.ends_with ~suffix:"Einstein.tla"; - (* PlusCal? *) + (* PlusCal validation output bug *) String.ends_with ~suffix:"AddTwo.tla"; ] in not (List.exists (fun pred -> pred path) preds) @@ -75,7 +75,7 @@ let _start_at (filename : string) (files : string list) : string list = match paths with | [] -> [] | hd :: tl -> - if String.ends_with ~suffix:filename hd then tl + if String.ends_with ~suffix:filename hd then paths else drop_until tl in drop_until files @@ -95,5 +95,5 @@ let _ = let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run - (*|> _start_at "SimpleAllocator.tla"*) + (*|> _start_at "AddTwo.tla"*) in List.map parse_tla_file tla_files From c4a93616e74752a1cfee3f8cc4936221b09ff31d Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 19 Feb 2026 14:52:25 -0800 Subject: [PATCH 60/85] Support using community modules & apalache jars when parsing Signed-off-by: Andrew Helwer --- src/params.ml | 2 ++ src/params.mli | 1 + src/sany/sany.ml | 15 +++++++++++++-- src/sany/sany.mli | 3 +++ src/sany/xml.ml | 13 +++++++++++-- src/tlapm_args.ml | 6 ++++++ test/sany/sany_tests.ml | 40 ++++++++++++++-------------------------- 7 files changed, 50 insertions(+), 30 deletions(-) diff --git a/src/params.ml b/src/params.ml index f6ddfd6a..677f7fb9 100644 --- a/src/params.ml +++ b/src/params.ml @@ -59,6 +59,8 @@ let prefer_stdlib = ref false type parser = | Tlapm | Sany let parser_backend = ref Tlapm +let module_jar_paths = ref [] + let noproving = ref false (* Don't send any obligation to the back-ends. *) let printallobs = ref false diff --git a/src/params.mli b/src/params.mli index 517d1d50..ac8344ea 100644 --- a/src/params.mli +++ b/src/params.mli @@ -9,6 +9,7 @@ val use_stdin: bool ref val prefer_stdlib: bool ref type parser = | Tlapm | Sany val parser_backend: parser ref +val module_jar_paths : string list ref (* expr/fmt.ml *) val debugging: string -> bool diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 4b762ae4..b9d1d184 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -63,6 +63,11 @@ open Expr.T;; open Proof.T;; open Util;; +type language_feature = + | RecursiveOperator + +exception Unsupported_language_feature of Loc.locus option * language_feature + let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = let loc = match loc with | Some loc -> Xml.show_location loc @@ -277,6 +282,12 @@ let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def | Previous n -> Unnamed (n + 1, uid) | Known n -> Unnamed (n, uid) +(** Converts a SANY built-in operator to a TLAPM built-in operator. This is + only defined for a subset of the operators that SANY considers built-in, + and not all operators that TLAPM considers built-in are represented in + the SANY built-in operators. TLAPM also considers all the standard module + operators to be built-in operators. +*) let sany_to_tlapm_builtin (node : Xml.node) (builtin : Xml.built_in_operator) : Builtin.builtin = match builtin with (* Reserved words *) @@ -400,7 +411,7 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | Except -> convert_except apply | IfThenElse -> convert_if_then_else apply | Case -> convert_case apply - (* Grouping operators *) + (* Grouping operators used within other operators *) | Pair | Sequence (* Proof step operators *) | CaseProofStep | PickProofStep | TakeProofStep | WitnessProofStep | SufficesProofStep | QedProofStep @@ -1014,7 +1025,7 @@ and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = *) and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = match xml.recursive with - | true -> conversion_failure "TLAPS does not yet support recursive operators" xml.node.location + | true -> raise (Unsupported_language_feature (Option.map convert_location xml.node.location, RecursiveOperator)) | false -> (Definition ( convert_user_defined_op_kind xml, User, diff --git a/src/sany/sany.mli b/src/sany/sany.mli index fbbc51b2..7fcdf087 100644 --- a/src/sany/sany.mli +++ b/src/sany/sany.mli @@ -1 +1,4 @@ +type language_feature = + | RecursiveOperator +exception Unsupported_language_feature of Loc.locus option * language_feature val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result \ No newline at end of file diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 8599078d..de142ce1 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -12,11 +12,18 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = let open Unix in let open Paths in + (** Module jars must be appended at the end of the classpath; the reason + for this is that some commonly-used jars like Apalache's embed SANY + along with the XMLExporter class, so we accidentally use Apalache's + (old) embedded version instead of the one from tla2tools.jar if we put + Apalache earlier in the classpath. + *) let cmd = Printf.sprintf "java -cp %s tla2sany.xml.XMLExporter -I %s -I %s -t %s" - (backend_classpath_string "tla2tools.jar") + ((backend_classpath_string "tla2tools.jar") ^ (String.concat ":" !Params.module_jar_paths)) (Filename.dirname module_path) (Filename.quote stdlib_path) (Filename.quote module_path) in + print_endline cmd; let (pid, out_fd) = System.launch_process cmd in let in_chan = Unix.in_channel_of_descr out_fd in let output = In_channel.input_all in_chan in @@ -218,9 +225,11 @@ let xml_to_numeral_node (children : tree list) : int literal = let xml_to_string_node (children : tree list) : string literal = match extract_inline_node children with | node, [Node ("StringValue", [SValue value])] -> {node; value} + (* In the case of an empty string "", node has no children *) + | node, [Node ("StringValue", [])] -> {node; value = ""} (* Sometimes strings can accidentally be converted into integers! *) | node, [Node ("StringValue", [IValue value])] -> {node; value = Int.to_string value} - | node, children -> ls_conversion_failure __FUNCTION__ children + | node, _ -> ls_conversion_failure __FUNCTION__ children type leibniz_param = { ref : int; diff --git a/src/tlapm_args.ml b/src/tlapm_args.ml index afcf5f65..ddebafd0 100644 --- a/src/tlapm_args.ml +++ b/src/tlapm_args.ml @@ -55,6 +55,8 @@ let set_parser_backend parser_str = | "tlapm" -> Params.parser_backend := Tlapm | _ -> raise (Arg.Bad ("--parser: " ^ parser_str)) +let add_module_jar_path jar_path = + Params.module_jar_paths := jar_path :: !Params.module_jar_paths let parse_args executable_name args opts mods usage_fmt err terminate = try Arg.current := 0; @@ -207,6 +209,10 @@ let init ?(out=Format.std_formatter) ?(err=Format.err_formatter) ?(terminate=exi contains files with the same names as modules in stdlib."; "--parser", Arg.String set_parser_backend, " \ Set parser backend to use: TLAPM (default) or SANY."; + "--module-jar", Arg.String add_module_jar_path, " \ + Add a path to a .jar file containing additional TLA+ modules, such + as the community modules. Multiple .jar files can be added by using + this option multiple times."; "--noproving", Arg.Set noproving, " do not prove, report fingerprinted results only"; blank; diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 092c82dd..2b5f3f3e 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -21,6 +21,7 @@ let has_substring needle haystack = let should_run (path : string) : bool = let preds = [ (* RECURSIVE operators *) + (* String.ends_with ~suffix:"Chameneos.tla"; String.ends_with ~suffix:"Stones.tla"; String.ends_with ~suffix:"glowingRaccoon/product.tla"; @@ -34,7 +35,9 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"GameOfLife.tla"; String.ends_with ~suffix:"btree.tla"; String.ends_with ~suffix:"Nano.tla"; + String.ends_with ~suffix:"Huang.tla"; has_substring "/tower_of_hanoi/"; + *) (* Subexpressions *) String.ends_with ~suffix:"MCPaxos.tla"; String.ends_with ~suffix:"MCVoting.tla"; @@ -42,32 +45,9 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"BPConProof.tla"; String.ends_with ~suffix:"PConProof.tla"; String.ends_with ~suffix:"VoteProof.tla"; - (* Community modules *) - String.ends_with ~suffix:"MCtcp.tla"; - String.ends_with ~suffix:"tcp.tla"; - String.ends_with ~suffix:"MCReplicatedLog.tla"; - String.ends_with ~suffix:"MCCRDT.tla"; - String.ends_with ~suffix:"DistributedReplicatedLog.tla"; - String.ends_with ~suffix:"SimTokenRing.tla"; - String.ends_with ~suffix:"EWD687a_anim.tla"; - String.ends_with ~suffix:"EWD687a.tla"; - String.ends_with ~suffix:"Huang.tla"; - String.ends_with ~suffix:"EWD840_anim.tla"; - String.ends_with ~suffix:"KnuthYao.tla"; - String.ends_with ~suffix:"TransitiveClosure.tla"; - String.ends_with ~suffix:"ClientCentric.tla"; - String.ends_with ~suffix:"KVsnap.tla"; - String.ends_with ~suffix:"KeyValueStore/Util.tla"; - String.ends_with ~suffix:"YoYoNoPruning.tla"; - String.ends_with ~suffix:"YoYoPruning.tla"; - String.ends_with ~suffix:"YoYoAllGraphs.tla"; - has_substring "/SDP_Attack_New_Solution_Spec/"; - has_substring "/SDP_Attack_Spec/"; - has_substring "/ewd998/"; - (* Apalache *) - String.ends_with ~suffix:"Einstein.tla"; (* PlusCal validation output bug *) String.ends_with ~suffix:"AddTwo.tla"; + has_substring "/ewd998/"; ] in not (List.exists (fun pred -> pred path) preds) let _start_at (filename : string) (files : string list) : string list = @@ -81,19 +61,27 @@ let _start_at (filename : string) (files : string list) : string list = let parse_tla_file filename = let open Stdlib in + let open Tlapm_lib__Sany in print_endline ("Parsing " ^ filename ^ " ..."); try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with | Error (_, msg) -> Printf.eprintf "%s\n" msg; failwith "Parsing failed" | Ok _ -> print_endline (filename ^ " success") - with Failure (e : string) -> + with + (* This is okay, we just don't support recursive operators *) + | Unsupported_language_feature (_, RecursiveOperator) -> () + | Failure (e : string) -> Printf.eprintf "%s\n" e; failwith "Parsing failed" let _ = parser_backend := Sany; + module_jar_paths := [ + "/mnt/data/ahelwer/src/tlaplus/examples/deps/apalache/lib/apalache.jar"; + "/mnt/data/ahelwer/src/tlaplus/examples/deps/community/modules.jar"; + ]; add_debug_flag "sany"; let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run - (*|> _start_at "AddTwo.tla"*) + (*|> _start_at "SimTokenRing.tla"*) in List.map parse_tla_file tla_files From e41a76d59f60c08090d29ce304cfb8dd399c95a5 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 19 Feb 2026 15:08:40 -0800 Subject: [PATCH 61/85] Upstream SANY DecimalNode fixes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 2 +- src/sany/xml.ml | 29 +++++++++++++++++++++++++++-- test/sany/sany_tests.ml | 18 ------------------ 3 files changed, 28 insertions(+), 21 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index b9d1d184..15fac9cb 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -954,7 +954,7 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = match expr with (* TODO: true means @ from EXCEPT, false means @ from proof step (???) *) | AtNode at_node -> At true |> attach_props at_node.node - | DecimalNode (mantissa, exponent) -> todo "Decimal literals" (Int.to_string mantissa ^ "e" ^ Int.to_string exponent) None + | DecimalNode {node; integralPart; fractionalPart} -> Num (Int.to_string integralPart, Int.to_string fractionalPart) |> attach_props node | LabelNode label -> convert_label label | LetInNode let_in -> convert_let_in_node let_in | NumeralNode n -> Num (Int.to_string n.value, "") |> attach_props n.node diff --git a/src/sany/xml.ml b/src/sany/xml.ml index de142ce1..3735aa74 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -211,6 +211,31 @@ let extract_inline_definition_opt (node, children : node * tree list) : (node * | Node ("definition", [Node ("TheoremDefRef", [Node ("UID", [IValue uid])])]) :: children -> (node, Some uid, children); | _ -> (node, None, children) +type decimal_node = { + node : node; + mantissa : int; + exponent : int; + integralPart : int; + fractionalPart : int +} +[@@deriving show] + +let xml_to_decimal_node (children : tree list) : decimal_node = + match extract_inline_node children with + | node, [ + Node ("mantissa", [IValue mantissa]); + Node ("exponent", [IValue exponent]); + Node ("integralPart", [IValue integralPart]); + Node ("fractionalPart", [IValue fractionalPart]); + ] -> { + node; + mantissa; + exponent; + integralPart; + fractionalPart; + } + | _ -> ls_conversion_failure __FUNCTION__ children + type 'a literal = { node : node; value : 'a @@ -310,7 +335,7 @@ and substitution = { and expression = | AtNode of at_node - | DecimalNode of int * int + | DecimalNode of decimal_node | LabelNode of label_node | LetInNode of let_in_node | NumeralNode of int literal @@ -509,7 +534,7 @@ and xml_to_subst_in_node (children : tree list) : subst_in_node = and xml_to_expression (xml : tree) : expression = match xml with | Node ("AtNode", children) -> AtNode (xml_to_at_node children) - | Node ("DecimalNode", [Node ("mantissa", [IValue mantissa]); Node ("exponent", [IValue exponent])]) -> DecimalNode (mantissa, exponent) + | Node ("DecimalNode", children) -> DecimalNode (xml_to_decimal_node children) | Node ("LabelNode", children) -> LabelNode (xml_to_label_node children) | Node ("LetInNode", children) -> LetInNode (xml_to_let_in_node children) | Node ("NumeralNode", children) -> NumeralNode (xml_to_numeral_node children) diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 2b5f3f3e..bc2ec056 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -20,24 +20,6 @@ let has_substring needle haystack = let should_run (path : string) : bool = let preds = [ - (* RECURSIVE operators *) - (* - String.ends_with ~suffix:"Chameneos.tla"; - String.ends_with ~suffix:"Stones.tla"; - String.ends_with ~suffix:"glowingRaccoon/product.tla"; - String.ends_with ~suffix:"CarTalkPuzzle.tla"; - String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_1/MC.tla"; - String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_2/MC.tla"; - String.ends_with ~suffix:"CarTalkPuzzle.toolbox/Model_3/MC.tla"; - String.ends_with ~suffix:"EWD840_json.tla"; - String.ends_with ~suffix:"SingleLaneBridge.tla"; - String.ends_with ~suffix:"SingleLaneBridge/MC.tla"; - String.ends_with ~suffix:"GameOfLife.tla"; - String.ends_with ~suffix:"btree.tla"; - String.ends_with ~suffix:"Nano.tla"; - String.ends_with ~suffix:"Huang.tla"; - has_substring "/tower_of_hanoi/"; - *) (* Subexpressions *) String.ends_with ~suffix:"MCPaxos.tla"; String.ends_with ~suffix:"MCVoting.tla"; From 17306b508e1e4662d32117e59fd6d3b453d1782a Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 19 Feb 2026 15:20:56 -0800 Subject: [PATCH 62/85] Upstream SANY LOCAL changes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 4 ++-- src/sany/xml.ml | 6 +++++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 15fac9cb..1635a4b6 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -476,7 +476,7 @@ and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( inst_sub = List.map mk_substitution instance.substitutions; } in match instance.name with | Some name -> Definition (Instance (noprops name, instantiation) |> noprops, User, Hidden, Export) - | None -> Anoninst (instantiation, Export) + | None -> Anoninst (instantiation, if instance.local then Local else Export) ) |> attach_props instance.node and convert_usable (use_or_hide : Xml.use_or_hide_node) : Proof.T.usable = { @@ -1030,7 +1030,7 @@ and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T convert_user_defined_op_kind xml, User, Hidden, (* If Visible, will be auto-included in all BY proofs *) - Export (* Whether definition is declared LOCAL *) + if xml.local then Local else Export )) |> attach_props xml.node (** This type is redundant with the below TheoremNode type and its conversion diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 3735aa74..d50ba360 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -367,6 +367,7 @@ and user_defined_op_kind = { body : expression; params : leibniz_param list; recursive : bool; + local : bool; } and assume_prove_node = { @@ -555,6 +556,7 @@ and xml_to_user_defined_op_kind (children : tree list) : user_defined_op_kind = body = children |> find_tag "body" |> child_of |> xml_to_expression; params = children |> find_tag "params" |> children_of |> List.map xml_to_leibniz_param; recursive = children |> List.exists (is_tag "recursive"); + local = children |> List.exists (is_tag "local"); } | _ -> ls_conversion_failure __FUNCTION__ children @@ -566,6 +568,7 @@ type instance_node = { module_name : string; substitutions : substitution list; parameters : int list; + local : bool; } [@@deriving show] @@ -575,12 +578,13 @@ let xml_to_instance_node (children : tree list) : instance_node = | Node ("uniquename", [SValue name]) :: children -> (node, Some name, children) | _ -> (node, None, children) in match children |> extract_inline_node |> extract_inline_name_opt with - | node, name, [Node ("module", [SValue module_name]); Node ("substs", substitutions); Node ("params", params)] -> { + | node, name, Node ("module", [SValue module_name]) :: Node ("substs", substitutions) :: Node ("params", params) :: local -> { node; name; module_name; substitutions = List.map xml_to_substitution substitutions; parameters = List.map get_ref params; + local = match local with | [Node ("local", _)] -> true | _ -> false; } | _ -> ls_conversion_failure __FUNCTION__ children From 35841fc44e3ebbd651de02cf6ca553ec204523eb Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 19 Feb 2026 15:36:18 -0800 Subject: [PATCH 63/85] Upstream SANY proof level changes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 96 ++++++++++++------------------------------------ src/sany/xml.ml | 12 +++--- 2 files changed, 31 insertions(+), 77 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 1635a4b6..85b0bc3b 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -117,56 +117,14 @@ type bounds_kind = type bound_ -type proof_level = - | Previous of int - | Known of int - -(** Parses proof step names like <1>a as given in SANY's XML output, where - they are escaped using < and &rt; for < and > respectively. Proof step - name can also be <+>, meaning one more than the previous proof level, or - <*>, meaning same as the current proof level. -*) -let parse_proof_step_name (proof_level : proof_level) (uid : int) (proof_name : string) : stepno = - let parse_name (parse_state, level, name : int * char list * char list ) (c : char) : int * char list * char list = - match parse_state, c with - (* Start state: expect < or < *) - | 0, '<' -> (4, level, name) - | 0, '&' -> (1, level, name) - | 1, 'l' -> (2, level, name) - | 2, 't' -> (3, level, name) - | 3, ';' -> (4, level, name) - (* Level parsing state: expect '+', '*', or digit *) - | 4, '+' | 4, '*' -> (6, [c], name) - (* Parse at least one digit then consume another digit, >, or &rt; *) - | 4, '0' .. '9' | 5, '0' .. '9' -> (5, c :: level, name) - | 5, '>' -> (10, level, name) - | 5, '&' -> (7, level, name) - (* Have seen + or *, expect > or &rt; *) - | 6, '>' -> (10, level, name) - | 6, '&' -> (7, level, name) - | 7, 'r' -> (8, level, name) - | 8, 't' -> (9, level, name) - | 9, ';' -> (10, level, name) - (* Proof name parsing state: read in zero or more a-zA-Z0-9_ *) - | 10, 'a' .. 'z' | 10, 'A' .. 'Z' | 10, '0' .. '9' | 10, '_' -> (10, level, c :: name) - (* Terminating '.' state; consume & ignore *) - | 10, '.' | 11, '.' -> (11, level, name) - | _ -> conversion_failure (Format.sprintf "Invalid character '%c' in proof step name '%s' at parsing state %d" c proof_name parse_state) None - in let (_, level, name) = String.fold_left parse_name (0, [], []) proof_name - in let digits_to_int (digits : char list) : int = - List.fold_right (fun (d : char) (acc : int) : int -> (int_of_char d - int_of_char '0') + acc * 10) digits 0 - in let level = match level, proof_level with - | ['+'], Previous n -> n + 1 - | ['+'], Known _ -> conversion_failure "Cannot have explicit proof level followed by <+>" None - | ['*'], Previous n -> n + 1 - | ['*'], Known n -> n - | digits, Previous _ -> digits_to_int digits - | digits, Known n -> - let level = digits_to_int digits in - if level <> n then conversion_failure ("Mismatched proof level: expected " ^ string_of_int n ^ " but got " ^ string_of_int level) None - else level - in if name = [] then Unnamed (level, uid) else - Named (level, name |> List.rev |> List.to_seq |> String.of_seq, false) +(** Extracts the name from named proof steps like <1>abc. +*) +let parse_proof_step_name (proof_level : int) (proof_name : string) : stepno = + let name_start = String.index proof_name '>' in + let name_end = match String.index_opt proof_name '.' with | Some n -> n | None -> String.length proof_name in + let name_len = name_end - name_start in + let name = String.sub proof_name name_start name_len in + Named (proof_level, name, false) (** Wraps the given proof step with its name in the metadata. *) @@ -275,13 +233,6 @@ let resolve_def (node : Xml.node) (ref : int) : use_def wrapped = | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location -let convert_proof_step_name (uid : int) (proof_level : proof_level) (theorem_def_ref : int option) : stepno = - match theorem_def_ref with - | Some uid -> parse_proof_step_name proof_level uid (resolve_theorem_def_node uid).name - | None -> match proof_level with - | Previous n -> Unnamed (n + 1, uid) - | Known n -> Unnamed (n, uid) - (** Converts a SANY built-in operator to a TLAPM built-in operator. This is only defined for a subset of the operators that SANY considers built-in, and not all operators that TLAPM considers built-in are represented in @@ -1084,7 +1035,7 @@ and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_no | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) | Some By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Some Steps proof -> convert_proof_steps uid previous_proof_level proof + | Some Steps proof -> convert_proof_steps uid proof (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place where information is lost, as the facts and definitions are converted to @@ -1098,6 +1049,11 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p only ) |> attach_props node +and convert_proof_step_name (uid : int) (proof_level : int) (theorem_def_ref : int option) : stepno = + match theorem_def_ref with + | Some uid -> parse_proof_step_name proof_level (resolve_theorem_def_node uid).name + | None -> Unnamed (proof_level, uid) + (** One possible proof form is a series of steps, culminating in a QED step. This method converts that structure. This is the most complex part of the proof conversion, primarily due to the necessity of appending proof step @@ -1111,21 +1067,18 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p TLAPM requires a unique ID to be assigned, so we use the UID of the SANY AST node. *) -and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} : Xml.steps_proof_node) : Proof.T.proof = - let convert_qed_step (proof_level : proof_level) (qed_proof_step : Xml.proof_step_group) : Proof.T.qed_step * proof_level = +and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proof_node) : Proof.T.proof = + let convert_qed_step (qed_proof_step : Xml.proof_step_group) : Proof.T.qed_step = match qed_proof_step with | TheoremNodeRef uid -> let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in - let qed_step = Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node in - attach_proof_step_name step_name qed_step, Known (step_number step_name) + Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node + |> attach_proof_step_name step_name | _ -> conversion_failure "QED step must be a theorem node" node.location in let steps, qed = split_last_ls node steps - in let steps, proof_level = List.fold_left convert_proof_step ([], Previous previous_proof_level) steps - in let qed_step, proof_level = convert_qed_step proof_level qed - in let proof_level = match proof_level with - | Previous _ -> conversion_failure "Current proof level should be known after processing all steps" node.location - | Known n -> n + in let steps = List.map (convert_proof_step proof_level) steps + in let qed_step = convert_qed_step qed in Steps (List.rev steps, qed_step) |> attach_props node |> attach_proof_step_name (Unnamed (proof_level, uid)) @@ -1148,17 +1101,16 @@ and convert_proof_steps (uid : int) (previous_proof_level : int) ({node; steps} The resulting list of proof steps is returned in reverse order, and must be reversed to be in the correct order for TLAPM. *) -and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (step : Xml.proof_step_group) : Proof.T.step list * proof_level = +and convert_proof_step (proof_level : int) (step : Xml.proof_step_group) : Proof.T.step = match step with | InstanceNode {node} -> conversion_failure "INSTANCE proof steps are deprecated from the TLA+ language standard" node.location | TheoremNode -> todo "TheoremNode proof step" "" None (* TODO: attach name to DefStep step *) | DefStep {node; def_refs} -> - let step = Define (def_refs |> List.map resolve_user_defined_op_kind |> List.map convert_user_defined_op_kind) |> attach_props node in - step :: steps, proof_level + Define (def_refs |> List.map resolve_user_defined_op_kind |> List.map convert_user_defined_op_kind) |> attach_props node (* TODO: confirm boolean parameter corresponds to ONLY keyword *) (* TODO: attach name to UseOrHide step *) - | UseOrHide use_or_hide -> (Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node) :: steps, proof_level + | UseOrHide use_or_hide -> Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node | TheoremNodeRef uid -> let is_op (uid : int) (op : Xml.built_in_operator) : bool = match (resolve_ref uid).kind with @@ -1179,7 +1131,7 @@ and convert_proof_step (steps, proof_level : Proof.T.step list * proof_level) (s | Expression OpApplNode ({operator} as apply) when is_op operator SufficesProofStep -> convert_suffices_proof_step apply proof | _ -> Suffices (convert_sequent thm.body, proof) - in (step |> attach_props thm.node |> attach_proof_step_name step_name) :: steps, Known (step_number step_name) + in step |> attach_props thm.node |> attach_proof_step_name step_name (** Converts CASE proof steps, like: <2>7. CASE UNCHANGED vars *) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index d50ba360..47bcddd4 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -23,7 +23,6 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (stri (Filename.dirname module_path) (Filename.quote stdlib_path) (Filename.quote module_path) in - print_endline cmd; let (pid, out_fd) = System.launch_process cmd in let in_chan = Unix.in_channel_of_descr out_fd in let output = In_channel.input_all in_chan in @@ -940,6 +939,7 @@ type proof_step_group = type steps_proof_node = { node : node; + proof_level : int; steps : proof_step_group list; } [@@deriving show] @@ -953,10 +953,12 @@ let xml_to_steps_proof_node (children : tree list) : steps_proof_node = | Node ("InstanceNode", children) -> InstanceNode (xml_to_instance_node children) | _ -> conversion_failure __FUNCTION__ xml in match extract_inline_node children with - | node, steps ->{ - node; - steps = List.map xml_to_proof_step_group steps - } + | node, Node ("proofLevel", [IValue proof_level]) :: steps -> { + node; + proof_level; + steps = List.map xml_to_proof_step_group steps + } + | _ -> ls_conversion_failure __FUNCTION__ children type proof_node_group = | Omitted of node From c0004eb0253c7c934009f06dd89973b29d731d1c Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 19 Feb 2026 15:44:51 -0800 Subject: [PATCH 64/85] Upstream SANY EXTENDS addition Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 6 +++--- src/sany/xml.ml | 10 ++++++++-- 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 85b0bc3b..3e2b5c6d 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -393,8 +393,8 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = | TheoremDefNode theorem_def_node -> conversion_failure "TheoremDefNode should not be converted directly" None in { name = noprops mule.name; - extendees = []; (* TODO: figure out how to get list of modules imported by this module *) - instancees = []; + extendees = List.map (fun name -> noprops name) mule.extends; + instancees = []; (* TODO: collate list of instancees from units *) body = List.map convert_entry mule.units; defdepth = 0; stage = Parsed; @@ -1200,7 +1200,7 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string if Coll.Sm.mem mule.name map then map else Coll.Sm.add mule.name (convert_module_node mule) map ) - Coll.Sm.empty + Coll.Sm.empty (* TODO: use standard modules here *) ast.module_refs in let root_module = Coll.Sm.find ast.root_module ctx in root_module.core.important <- true; diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 47bcddd4..f1a1717e 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -623,12 +623,17 @@ type unit_kind = type module_node = { node : node; name : string; + extends : string list; units : unit_kind list; } [@@deriving show] let xml_to_module_node (children : tree list) : module_node = - let ref_child child = + let extract_extends (xml : tree) : string = + match xml with + | Node ("uniquename", [SValue name]) -> name + | _ -> conversion_failure __FUNCTION__ xml + in let ref_child child = match get_ref_opt child with | Some uid -> Ref uid | None -> match child with @@ -636,9 +641,10 @@ let xml_to_module_node (children : tree list) : module_node = | Node ("UseOrHideNode", children) -> UseOrHide (xml_to_use_or_hide_node children) | _ -> conversion_failure __FUNCTION__ child in match extract_inline_node children with - | node, Node ("uniquename", [SValue name]) :: units -> { + | node, Node ("uniquename", [SValue name]) :: Node ("extends", extends) :: units -> { node; name; + extends = List.map extract_extends extends; units = List.map ref_child units } | _ -> ls_conversion_failure __FUNCTION__ children From 5b1167eb7236b153eaf5f91d2942dceb6cf0d0f6 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 20 Feb 2026 16:11:06 -0800 Subject: [PATCH 65/85] Handle subexpressions (or rather don't) Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 8 ++++++++ src/sany/sany.mli | 2 ++ src/sany/xml.ml | 2 ++ test/sany/sany_tests.ml | 10 +++++++--- 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 3e2b5c6d..3e9b4d50 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -65,6 +65,7 @@ open Util;; type language_feature = | RecursiveOperator + | Subexpression exception Unsupported_language_feature of Loc.locus option * language_feature @@ -362,6 +363,7 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | Except -> convert_except apply | IfThenElse -> convert_if_then_else apply | Case -> convert_case apply + | Subexpression -> convert_subexpression apply (* Grouping operators used within other operators *) | Pair | Sequence (* Proof step operators *) @@ -819,6 +821,12 @@ and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid bound symbols or operands to CASE" apply.node.location ) |> attach_props apply.node +(** Subexpressions like M!N!op(expr)!1. + TODO: SANY currently does not export all the info needed for this. +*) +and convert_subexpression (apply : Xml.op_appl_node) : Expr.T.expr = ( + raise (Unsupported_language_feature (Option.map convert_location apply.node.location, Subexpression))) + (** Conversion of application of user-defined operators, including operators defined in the standard modules. *) diff --git a/src/sany/sany.mli b/src/sany/sany.mli index 7fcdf087..32c6a3e7 100644 --- a/src/sany/sany.mli +++ b/src/sany/sany.mli @@ -1,4 +1,6 @@ type language_feature = | RecursiveOperator + | Subexpression + exception Unsupported_language_feature of Loc.locus option * language_feature val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result \ No newline at end of file diff --git a/src/sany/xml.ml b/src/sany/xml.ml index f1a1717e..aca0a77b 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -754,6 +754,7 @@ type built_in_operator = | Except | IfThenElse | Case + | Subexpression | Pair | Sequence | CaseProofStep @@ -824,6 +825,7 @@ let xml_to_built_in_operator (name : string) : built_in_operator = | "$Except" -> Except | "$IfThenElse" -> IfThenElse | "$Case" -> Case + | "$Nop" -> Subexpression | "$Pair" -> Pair | "$Seq" -> Sequence | "$Pfcase" -> CaseProofStep diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index bc2ec056..6ac965c4 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -13,7 +13,7 @@ let find_tla_files dir = in loop [] -let has_substring needle haystack = +let _has_substring needle haystack = match Str.search_forward (Str.regexp_string needle) haystack 0 with | _ -> true | exception Not_found -> false @@ -21,15 +21,17 @@ let has_substring needle haystack = let should_run (path : string) : bool = let preds = [ (* Subexpressions *) + (* String.ends_with ~suffix:"MCPaxos.tla"; String.ends_with ~suffix:"MCVoting.tla"; String.ends_with ~suffix:"EWD840_proof.tla"; String.ends_with ~suffix:"BPConProof.tla"; String.ends_with ~suffix:"PConProof.tla"; String.ends_with ~suffix:"VoteProof.tla"; + *) (* PlusCal validation output bug *) String.ends_with ~suffix:"AddTwo.tla"; - has_substring "/ewd998/"; + _has_substring "/ewd998/"; ] in not (List.exists (fun pred -> pred path) preds) let _start_at (filename : string) (files : string list) : string list = @@ -51,6 +53,8 @@ let parse_tla_file filename = with (* This is okay, we just don't support recursive operators *) | Unsupported_language_feature (_, RecursiveOperator) -> () + (* This is okay, we just don't support subexpressions *) + | Unsupported_language_feature (_, Subexpression) -> () | Failure (e : string) -> Printf.eprintf "%s\n" e; failwith "Parsing failed" @@ -65,5 +69,5 @@ let _ = let tla_files = find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" |> List.filter should_run - (*|> _start_at "SimTokenRing.tla"*) + |> _start_at "MCPaxos.tla" in List.map parse_tla_file tla_files From 77e66edb1151394b0d995546e1f145475bfed865 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 25 Feb 2026 17:24:23 -0800 Subject: [PATCH 66/85] Convert HAVE proof steps Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 83 +++++++++++++++++++++++++++-------------- src/sany/xml.ml | 9 ++++- test/sany/sany_tests.ml | 22 ++++------- 3 files changed, 68 insertions(+), 46 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 3e9b4d50..c3a26e61 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -234,6 +234,14 @@ let resolve_def (node : Xml.node) (ref : int) : use_def wrapped = | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location +(** Predicate for quickly checking whether a given UID corresponds to the + given built-in operator. +*) +let is_builtin_op (uid : int) (op : Xml.built_in_operator) : bool = + match (resolve_ref uid).kind with + | BuiltInKind {operator} when operator = op -> true + | _ -> false + (** Converts a SANY built-in operator to a TLAPM built-in operator. This is only defined for a subset of the operators that SANY considers built-in, and not all operators that TLAPM considers built-in are represented in @@ -354,8 +362,8 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k | FiniteSetFilter -> convert_set_filter apply | FunctionSet -> convert_function_set apply | FunctionConstructor -> convert_function_constructor apply - | FunctionDefinition -> convert_function_definition false apply - | RecursiveFunctionDefinition -> convert_function_definition true apply + | FunctionDefinition -> convert_function_constructor apply + | RecursiveFunctionDefinition -> convert_recursive_function_definition apply | FunctionApplication -> convert_function_application apply | RecordSet -> convert_record_set apply | RecordConstructor -> convert_record_constructor apply @@ -367,7 +375,7 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k (* Grouping operators used within other operators *) | Pair | Sequence (* Proof step operators *) - | CaseProofStep | PickProofStep | TakeProofStep | WitnessProofStep | SufficesProofStep | QedProofStep + | CaseProofStep | PickProofStep | TakeProofStep | HaveProofStep | WitnessProofStep | SufficesProofStep | QedProofStep -> conversion_failure ("Operator invalid at this location : " ^ Xml.show_built_in_operator op.operator) apply.node.location (** Converts a top-level module node. *) @@ -438,7 +446,6 @@ and convert_usable (use_or_hide : Xml.use_or_hide_node) : Proof.T.usable = { } and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = - (* TODO: confirm `Use boolean parameter really is the ONLY keyword *) let action = if use_or_hide.hide then `Hide else `Use use_or_hide.only in Mutate (action, convert_usable use_or_hide) |> attach_props use_or_hide.node @@ -672,29 +679,24 @@ and convert_set_filter (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid bounds or operands to set filter" apply.node.location ) |> attach_props apply.node -(** Conversion of function definitions where the function body does not refer - to the function definition. - - Conversion of recursive functions where the function body refers to the +(** Conversion of recursive functions where the function body refers to the function definition, for example f[x \in Nat] == f[x - 1]. Both SANY and TLAPM represent these as f == [x \in Nat |-> f[x - 1]], and here we convert the right-hand side of this definition. The function name is introduced as the first symbol, unbound. *) -and convert_function_definition (is_recursive : bool) (apply : Xml.op_appl_node) : Expr.T.expr = ( - let bounds, body = match is_recursive, apply.bound_symbols, apply.operands with - | true, Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> +and convert_recursive_function_definition (apply : Xml.op_appl_node) : Expr.T.expr = ( + let bounds, body = match apply.bound_symbols, apply.operands with + | Unbound function_name :: (_ :: _ as all_bound_symbols), [Expression body] -> all_bound_symbols, convert_expression body - | false, (_ :: _), [Expression body] -> - apply.bound_symbols, convert_expression body | _ -> conversion_failure "Invalid number of bounds or operands to function definition" apply.node.location in match convert_bounds apply.node bounds with | Tuply tuply_bounds -> FcnTuply (tuply_bounds, body) | NonTuply bounds -> Fcn (bounds, body) ) |> attach_props apply.node -(** Converts function construction expressions like [x \in S, y \in P |-> x + y]; - also handles record construction, like [x |-> expr1, y |-> expr2]. +(** Converts function construction expressions like [x \in S, y \in P |-> x + y] + and also f[x \in S, y \in P] == x + y. *) and convert_function_constructor (apply : Xml.op_appl_node) : Expr.T.expr = match apply.bound_symbols, apply.operands with @@ -714,13 +716,31 @@ and convert_function_set (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid operands to function set expression" apply.node.location ) |> attach_props apply.node -(** Conversion of function application, like f[x, y, z]. +(** Conversion of function application, like f[x, y, z]. Function application + with multiple arguments is represented using a tuple, with the special + case of a tuple with a single element being just that tuple itself as an + argument instead of the argument being destructured from it. The empty + tuple argument is also a weird one which must be handled. So: + - f[x] args given as expression x, transformed into list [x] + - f[x, y] args given as a tuple <>, transformed into list [x; y] + - f[<>] args given as tuple <>, transformed into list [<>] + - f[<<>>] args given as tuple <<>>, transformed into list [<<>>] + + TODO: validate all of these cases *) and convert_function_application (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with - | [], Expression fn :: all_args -> - let args = apply.operands |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression in - FcnApp (convert_expression fn, args) + | [], [Expression fn; Expression args] -> ( + let args = match args with + | OpApplNode {node; operator; operands} when is_builtin_op operator TupleLiteral -> ( + match operands with + | [] -> [args] (* Empty tuple *) + | [Expression single_arg] -> [args] (* Tuple with single element *) + | _ -> as_expr_ls __FUNCTION__ node.location operands (* Tuple with multiple elements *) + ) + | _ -> [args] (* Not a tuple; single expression *) + in FcnApp (convert_expression fn, List.map convert_expression args) + ) | _ -> conversion_failure "Invalid operands to function application" apply.node.location ) |> attach_props apply.node @@ -1120,23 +1140,21 @@ and convert_proof_step (proof_level : int) (step : Xml.proof_step_group) : Proof (* TODO: attach name to UseOrHide step *) | UseOrHide use_or_hide -> Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node | TheoremNodeRef uid -> - let is_op (uid : int) (op : Xml.built_in_operator) : bool = - match (resolve_ref uid).kind with - | BuiltInKind {operator} when operator = op -> true - | _ -> false - in let thm = resolve_theorem_node uid in + let thm = resolve_theorem_node uid in let step_name = convert_proof_step_name uid proof_level thm.definition in let proof = convert_proof uid (step_number step_name) thm.proof in let step = match thm.body with - | Expression OpApplNode ({operator} as apply) when is_op operator CaseProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator CaseProofStep -> convert_case_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_op operator PickProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator PickProofStep -> convert_pick_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_op operator TakeProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator TakeProofStep -> convert_take_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_op operator WitnessProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator HaveProofStep -> + convert_have_proof_step apply + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator WitnessProofStep -> convert_witness_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_op operator SufficesProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op operator SufficesProofStep -> convert_suffices_proof_step apply proof | _ -> Suffices (convert_sequent thm.body, proof) in step |> attach_props thm.node |> attach_proof_step_name step_name @@ -1171,6 +1189,13 @@ and convert_take_proof_step (apply : Xml.op_appl_node) : Proof.T.step_ = ) | _ -> conversion_failure "Invalid number of bounds or operands to TAKE proof step" apply.node.location +(** Converts HAVE P proof steps. +*) +and convert_have_proof_step (apply : Xml.op_appl_node) : Proof.T.step_ = + match apply.bound_symbols, apply.operands with + | [], [Expression expr] -> Have (convert_expression expr) + | _ -> conversion_failure "Invalid bounds or operands to HAVE proof step" apply.node.location + (** Converts WITNESS x, y, z proof steps. *) and convert_witness_proof_step (apply : Xml.op_appl_node) : Proof.T.step_ = diff --git a/src/sany/xml.ml b/src/sany/xml.ml index aca0a77b..62ee8332 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -23,6 +23,7 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (stri (Filename.dirname module_path) (Filename.quote stdlib_path) (Filename.quote module_path) in + if Params.debugging "sany" then print_endline cmd else (); let (pid, out_fd) = System.launch_process cmd in let in_chan = Unix.in_channel_of_descr out_fd in let output = In_channel.input_all in_chan in @@ -454,6 +455,8 @@ and xml_to_let_in_node (children : tree list) : let_in_node = } | _ -> ls_conversion_failure __FUNCTION__ children +(** TODO: there are more fields to parse in this structure +*) and xml_to_at_node (children : tree list) : at_node = match extract_inline_node children with | node, _ -> {node} @@ -760,6 +763,7 @@ type built_in_operator = | CaseProofStep | PickProofStep | TakeProofStep + | HaveProofStep | WitnessProofStep | SufficesProofStep | QedProofStep @@ -826,14 +830,15 @@ let xml_to_built_in_operator (name : string) : built_in_operator = | "$IfThenElse" -> IfThenElse | "$Case" -> Case | "$Nop" -> Subexpression - | "$Pair" -> Pair - | "$Seq" -> Sequence | "$Pfcase" -> CaseProofStep | "$Pick" -> PickProofStep | "$Take" -> TakeProofStep + | "$Have" -> HaveProofStep | "$Witness" -> WitnessProofStep | "$Suffices" -> SufficesProofStep | "$Qed" -> QedProofStep + | "$Pair" -> Pair + | "$Seq" -> Sequence | name -> conversion_failure __FUNCTION__ (SValue name) type built_in_kind = { diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 6ac965c4..25116ad3 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -20,18 +20,7 @@ let _has_substring needle haystack = let should_run (path : string) : bool = let preds = [ - (* Subexpressions *) - (* - String.ends_with ~suffix:"MCPaxos.tla"; - String.ends_with ~suffix:"MCVoting.tla"; - String.ends_with ~suffix:"EWD840_proof.tla"; - String.ends_with ~suffix:"BPConProof.tla"; - String.ends_with ~suffix:"PConProof.tla"; - String.ends_with ~suffix:"VoteProof.tla"; - *) - (* PlusCal validation output bug *) - String.ends_with ~suffix:"AddTwo.tla"; - _has_substring "/ewd998/"; + (* String.ends_with ~suffix:"NameOfSpecToSkip.tla"; *) ] in not (List.exists (fun pred -> pred path) preds) let _start_at (filename : string) (files : string list) : string list = @@ -66,8 +55,11 @@ let _ = "/mnt/data/ahelwer/src/tlaplus/examples/deps/community/modules.jar"; ]; add_debug_flag "sany"; - let tla_files = - find_tla_files "/mnt/data/ahelwer/src/tlaplus/examples/specifications" + let tla_files = [ + "/mnt/data/ahelwer/src/tlaplus/examples/specifications"; + "/mnt/data/ahelwer/src/tlaplus/proofs/examples"; + "/mnt/data/ahelwer/src/tlaplus/proofs/library" + ] |> List.map find_tla_files |> List.flatten |> List.filter should_run - |> _start_at "MCPaxos.tla" + (*|> _start_at "MCPaxos.tla"*) in List.map parse_tla_file tla_files From 34ab24e1faa21efa737a3b783361b7f6b26da4a4 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Feb 2026 13:54:36 -0800 Subject: [PATCH 67/85] Parse M!op type references Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 94 +++++++++++++++++++++++++---------------- src/tlapm_args.ml | 1 + test/sany/sany_tests.ml | 10 +++-- 3 files changed, 64 insertions(+), 41 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index c3a26e61..982d4b34 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -118,15 +118,6 @@ type bounds_kind = type bound_ -(** Extracts the name from named proof steps like <1>abc. -*) -let parse_proof_step_name (proof_level : int) (proof_name : string) : stepno = - let name_start = String.index proof_name '>' in - let name_end = match String.index_opt proof_name '.' with | Some n -> n | None -> String.length proof_name in - let name_len = name_end - name_start in - let name = String.sub proof_name name_start name_len in - Named (proof_level, name, false) - (** Wraps the given proof step with its name in the metadata. *) let attach_proof_step_name (proof_name : stepno) (step : 'a) : 'a = @@ -386,17 +377,17 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = Thus in-scope operator parameters coexist alongside entire modules, and here we branch out to the appropriate conversion method. *) - let convert_entry (unit : Xml.unit_kind) : Module.T.modunit = + let convert_entry (unit : Xml.unit_kind) : Module.T.modunit option = match unit with - | Instance instance -> convert_instance instance - | UseOrHide use_or_hide -> convert_use_or_hide use_or_hide + | Instance instance -> Some (convert_instance instance) + | UseOrHide use_or_hide -> Some (convert_use_or_hide use_or_hide) | Ref uid -> let entry = resolve_ref uid in match entry.kind with - | ModuleNode submod -> Submod (convert_module_node submod) |> attach_props submod.node - | AssumeNode assume -> convert_assume_node assume - | OpDeclNode op_decl_node -> convert_op_decl_node op_decl_node - | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind - | TheoremNode theorem_node -> convert_theorem_node entry.uid 0 theorem_node + | ModuleNode submod -> Some (Submod (convert_module_node submod) |> attach_props submod.node) + | AssumeNode assume -> Some (convert_assume_node assume) + | OpDeclNode op_decl_node -> Some (convert_op_decl_node op_decl_node) + | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind mule.name + | TheoremNode theorem_node -> Some (convert_theorem_node entry.uid 0 theorem_node) | BuiltInKind _ -> conversion_failure "BuiltInKind not expected at module top-level" None | FormalParamNode _ -> conversion_failure "FormalParamNode not expected at module top-level" None | AssumeDefNode assume -> conversion_failure "AssumeDefNode should not be converted directly" None @@ -405,7 +396,7 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = name = noprops mule.name; extendees = List.map (fun name -> noprops name) mule.extends; instancees = []; (* TODO: collate list of instancees from units *) - body = List.map convert_entry mule.units; + body = List.filter_map convert_entry mule.units; defdepth = 0; stage = Parsed; important = false @@ -847,14 +838,40 @@ and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( and convert_subexpression (apply : Xml.op_appl_node) : Expr.T.expr = ( raise (Unsupported_language_feature (Option.map convert_location apply.node.location, Subexpression))) +(** SANY gives references like M!op as opaque strings; these are resolved + using the UID system. We need to parse these back into Bang instances. + Probably this could most easily be done on the SANY side then attached + to various references, but we will do it here for now. Note that these + will not contain subexpression elements like :, <<, @, etc. because those + would have been given by SANY as the $Nop operator and thus are handled + in the convert_subexpression method. +*) +and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.expr_or_op_arg list) : Expr.T.expr = + let convert_selector (component : string) : Expr.T.sel = + if String.contains component '(' + then todo "Definition reference" "Function application in selector" node.location + else Sel_lab (component, []) + in let components = String.split_on_char '!' name in + if List.mem "" components then todo "Definition reference" "!!" node.location + else match components with + | [] -> conversion_failure "Unexpected empty definition reference" node.location + | [component] -> Apply ( + Opaque name |> attach_props node, + List.map convert_expression_or_operator_argument args + ) |> attach_props node + | head :: tail -> + let prefix, last = split_last_ls node tail in + let last = Sel_lab (last, List.map convert_expression_or_operator_argument args) in + Bang ( + Opaque head |> noprops, + List.map convert_selector prefix @ [last] + ) |> attach_props node + (** Conversion of application of user-defined operators, including operators defined in the standard modules. *) and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = - Apply ( - Opaque op.name |> attach_props op.node, - List.map convert_expression_or_operator_argument apply.operands - ) |> attach_props apply.node + convert_definition_reference apply.node op.name apply.operands (** Conversion of reference to in-scope operator parameters, such as in op(a, b, c) == a. This is a case where information is actually lost, @@ -874,12 +891,7 @@ and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.fo Bruijn index later on. *) and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_node) : Expr.T.expr = - match decl.arity with - | 0 -> Opaque decl.name |> attach_props decl.node - | n -> Apply ( - Opaque decl.name |> attach_props decl.node, - List.map convert_expression_or_operator_argument apply.operands - ) |> attach_props apply.node + convert_definition_reference apply.node decl.name apply.operands (** OpApplNode is a very general node used by SANY to represent essentially all expression types. Things like \A x \in S : P are represented as an @@ -899,9 +911,9 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = (* A reference to a CONSTANT or VARIABLE identifier *) | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl (* A reference to a named THEOREM or a proof step *) - | TheoremDefNode thm -> Opaque thm.name |> attach_props thm.node + | TheoremDefNode thm -> convert_definition_reference thm.node thm.name [] (* A reference to a named ASSUME node *) - | AssumeDefNode assume -> Opaque assume.name |> attach_props assume.node + | AssumeDefNode assume -> convert_definition_reference assume.node assume.name [] | _ -> conversion_failure ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind)) apply.node.location (** Some places in TLA⁺ syntax allow both normal expressions and also @@ -915,11 +927,11 @@ and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Exp | Expression expr -> convert_expression expr | OpArg uid -> match (resolve_ref uid).kind with | FormalParamNode param -> Opaque param.name |> attach_props param.node - | UserDefinedOpKind userdef -> Opaque userdef.name |> attach_props userdef.node + | UserDefinedOpKind userdef -> convert_definition_reference userdef.node userdef.name [] | BuiltInKind builtin -> let op = sany_to_tlapm_builtin builtin.node builtin.operator in Internal op |> attach_props builtin.node - | OpDeclNode decl -> Opaque decl.name |> attach_props decl.node + | OpDeclNode decl -> convert_definition_reference decl.node decl.name [] | AssumeNode assume -> conversion_failure "Invalid operator argument reference to ASSUME" assume.node.location | AssumeDefNode assume -> conversion_failure ("Invalid operator argument reference to ASSUME: " ^ assume.name) assume.node.location | TheoremNode thm -> conversion_failure "Invalid operator argument reference to THEOREM" thm.node.location @@ -1000,17 +1012,19 @@ and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = | params -> Lambda (List.map resolve_leibniz_formal_param_node params, body) |> attach_props op.node in Operator (attach_props op.node op.name, expr) |> attach_props op.node -(** Converts user-defined operators defined in a module top-level. +(** Converts user-defined operators defined in a module top-level. If operator + was defined in a different module, return None. *) -and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) : Module.T.modunit = +and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) (enclosing_module_name : string) : Module.T.modunit option = + if (Option.get xml.node.location).filename <> enclosing_module_name then None else match xml.recursive with | true -> raise (Unsupported_language_feature (Option.map convert_location xml.node.location, RecursiveOperator)) - | false -> (Definition ( + | false -> Definition ( convert_user_defined_op_kind xml, User, Hidden, (* If Visible, will be auto-included in all BY proofs *) if xml.local then Local else Export - )) |> attach_props xml.node + ) |> attach_props xml.node |> Option.some (** This type is redundant with the below TheoremNode type and its conversion does not need to be handled. Probably the SANY XML exporter should be @@ -1079,7 +1093,13 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p and convert_proof_step_name (uid : int) (proof_level : int) (theorem_def_ref : int option) : stepno = match theorem_def_ref with - | Some uid -> parse_proof_step_name proof_level (resolve_theorem_def_node uid).name + | Some uid -> + let proof_name = (resolve_theorem_def_node uid).name in + let name_start = String.index proof_name '>' in + let name_end = match String.index_opt proof_name '.' with | Some n -> n | None -> String.length proof_name in + let name_len = name_end - name_start in + let name = String.sub proof_name name_start name_len in + Named (proof_level, name, false) | None -> Unnamed (proof_level, uid) (** One possible proof form is a series of steps, culminating in a QED step. diff --git a/src/tlapm_args.ml b/src/tlapm_args.ml index ddebafd0..f00a441e 100644 --- a/src/tlapm_args.ml +++ b/src/tlapm_args.ml @@ -57,6 +57,7 @@ let set_parser_backend parser_str = let add_module_jar_path jar_path = Params.module_jar_paths := jar_path :: !Params.module_jar_paths + let parse_args executable_name args opts mods usage_fmt err terminate = try Arg.current := 0; diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 25116ad3..04c597dc 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -20,7 +20,9 @@ let _has_substring needle haystack = let should_run (path : string) : bool = let preds = [ - (* String.ends_with ~suffix:"NameOfSpecToSkip.tla"; *) + String.ends_with ~suffix:"paxos/Paxos.tla"; + String.ends_with ~suffix:"ByzPaxos/BPConProof.tla"; + String.ends_with ~suffix:"GraphTheorem.tla"; ] in not (List.exists (fun pred -> pred path) preds) let _start_at (filename : string) (files : string list) : string list = @@ -56,10 +58,10 @@ let _ = ]; add_debug_flag "sany"; let tla_files = [ - "/mnt/data/ahelwer/src/tlaplus/examples/specifications"; "/mnt/data/ahelwer/src/tlaplus/proofs/examples"; - "/mnt/data/ahelwer/src/tlaplus/proofs/library" + "/mnt/data/ahelwer/src/tlaplus/proofs/library"; + "/mnt/data/ahelwer/src/tlaplus/examples/specifications"; ] |> List.map find_tla_files |> List.flatten |> List.filter should_run - (*|> _start_at "MCPaxos.tla"*) + (*|> _start_at "paxos/Paxos.tla"*) in List.map parse_tla_file tla_files From 0590454412b5daa341b4345d2f7364828991e59f Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Feb 2026 15:17:58 -0800 Subject: [PATCH 68/85] Added location info for debugging ref resolve failures Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 172 ++++++++++++++++++++-------------------- src/sany/xml.ml | 25 ++++++ test/sany/sany_tests.ml | 1 + 3 files changed, 113 insertions(+), 85 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 982d4b34..3a31fbe5 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -145,82 +145,72 @@ let attach_props (props : Xml.node) (value : 'a) : 'a wrapped = (** Look up the given ref in the global entries table, failing if not found. *) -let resolve_ref (uid : int) : Xml.entry = +let resolve_ref (node : Xml.node) (uid : int) : Xml.entry = match Coll.Im.find_opt uid !entries with | Some kind -> {uid; kind} - | None -> conversion_failure ("Unresolved reference to entry UID: " ^ string_of_int uid) None + | None -> conversion_failure ("Unresolved reference to entry UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for module nodes. *) -let resolve_module_node (uid : int) : Xml.module_node = - match (resolve_ref uid).kind with +let resolve_module_node (node : Xml.node) (uid : int) : Xml.module_node = + match (resolve_ref node uid).kind with | ModuleNode mule -> mule - | _ -> conversion_failure ("Expected module node for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected module node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for operator declaration nodes. *) -let resolve_op_decl_node (uid : int) : Xml.op_decl_node = - match (resolve_ref uid).kind with +let resolve_op_decl_node (node : Xml.node) (uid : int) : Xml.op_decl_node = + match (resolve_ref node uid).kind with | OpDeclNode odn -> odn - | _ -> conversion_failure ("Expected operator declaration node for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected operator declaration node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for user-defined operators. *) -let resolve_user_defined_op_kind (uid : int) : Xml.user_defined_op_kind = - match (resolve_ref uid).kind with +let resolve_user_defined_op_kind (node : Xml.node) (uid : int) : Xml.user_defined_op_kind = + match (resolve_ref node uid).kind with | UserDefinedOpKind udok -> udok - | _ -> conversion_failure ("Expected user defined operator for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected user defined operator for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for operator parameter nodes. *) -let resolve_formal_param_node (uid : int) : Xml.formal_param_node = - match (resolve_ref uid).kind with +let resolve_formal_param_node (node : Xml.node) (uid : int) : Xml.formal_param_node = + match (resolve_ref node uid).kind with | Xml.FormalParamNode xml -> xml - | _ -> conversion_failure ("Expected formal parameter node for UID: " ^ string_of_int uid) None - -(** A typed version of resolve_ref for Leibniz operator parameter nodes. -*) -let resolve_leibniz_formal_param_node (param : Xml.leibniz_param) : (hint * shape) = - let fpn = resolve_formal_param_node param.ref in ( - attach_props fpn.node fpn.name, - match fpn.arity with - | 0 -> Shape_expr - | n -> Shape_op n - ) + | _ -> conversion_failure ("Expected formal parameter node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for theorem definition nodes. *) -let resolve_theorem_def_node (uid : int) : Xml.theorem_def_node = - match (resolve_ref uid).kind with +let resolve_theorem_def_node (node : Xml.node) (uid : int) : Xml.theorem_def_node = + match (resolve_ref node uid).kind with | TheoremDefNode xml -> xml - | _ -> conversion_failure ("Expected theorem definition node for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected theorem definition node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for assume definition nodes. *) -let resolve_assume_def_node (uid : int) : Xml.assume_def_node = - match (resolve_ref uid).kind with +let resolve_assume_def_node (node : Xml.node) (uid : int) : Xml.assume_def_node = + match (resolve_ref node uid).kind with | AssumeDefNode xml -> xml - | _ -> conversion_failure ("Expected assume definition node for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected assume definition node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for theorem nodes. *) -let resolve_theorem_node (uid : int) : Xml.theorem_node = - match (resolve_ref uid).kind with +let resolve_theorem_node (node : Xml.node) (uid : int) : Xml.theorem_node = + match (resolve_ref node uid).kind with | TheoremNode xml -> xml - | _ -> conversion_failure ("Expected theorem node for UID: " ^ string_of_int uid) None + | _ -> conversion_failure ("Expected theorem node for UID: " ^ string_of_int uid) node.location (** A typed version of resolve_ref for bound symbols. *) -let resolve_bound_symbol (uid : int) : hint = - match Coll.Im.find_opt uid !entries with - | Some (Xml.FormalParamNode ({arity = 0} as xml)) -> attach_props xml.node xml.name - | Some (Xml.FormalParamNode _) -> conversion_failure ("Bound symbol cannot be an operator: " ^ string_of_int uid) None - | _ -> conversion_failure ("Unresolved formal parameter node UID: " ^ string_of_int uid) None +let resolve_bound_symbol (node : Xml.node) (uid : int) : hint = + match (resolve_ref node uid).kind with + | FormalParamNode ({arity = 0} as xml) -> attach_props xml.node xml.name + | FormalParamNode _ -> conversion_failure ("Bound symbol cannot be an operator: " ^ string_of_int uid) node.location + | _ -> conversion_failure ("Unresolved formal parameter node UID: " ^ string_of_int uid) node.location (** Resolves definitions referenced in BY proofs or USE/HIDE statements. *) let resolve_def (node : Xml.node) (ref : int) : use_def wrapped = - match (resolve_ref ref).kind with + match (resolve_ref node ref).kind with | UserDefinedOpKind op -> Dvar op.name |> attach_props op.node | TheoremDefNode thm -> Dvar thm.name |> attach_props thm.node | other -> conversion_failure ("Invalid definition reference in BY proof: " ^ (Xml.show_entry_kind other)) node.location @@ -228,8 +218,8 @@ let resolve_def (node : Xml.node) (ref : int) : use_def wrapped = (** Predicate for quickly checking whether a given UID corresponds to the given built-in operator. *) -let is_builtin_op (uid : int) (op : Xml.built_in_operator) : bool = - match (resolve_ref uid).kind with +let is_builtin_op (node : Xml.node) (uid : int) (op : Xml.built_in_operator) : bool = + match (resolve_ref node uid).kind with | BuiltInKind {operator} when operator = op -> true | _ -> false @@ -381,13 +371,14 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = match unit with | Instance instance -> Some (convert_instance instance) | UseOrHide use_or_hide -> Some (convert_use_or_hide use_or_hide) - | Ref uid -> let entry = resolve_ref uid in + | Ref uid -> let entry = resolve_ref mule.node uid in match entry.kind with | ModuleNode submod -> Some (Submod (convert_module_node submod) |> attach_props submod.node) | AssumeNode assume -> Some (convert_assume_node assume) | OpDeclNode op_decl_node -> Some (convert_op_decl_node op_decl_node) | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind mule.name | TheoremNode theorem_node -> Some (convert_theorem_node entry.uid 0 theorem_node) + | ModuleInstanceKind instance -> Some (convert_instance instance) | BuiltInKind _ -> conversion_failure "BuiltInKind not expected at module top-level" None | FormalParamNode _ -> conversion_failure "FormalParamNode not expected at module top-level" None | AssumeDefNode assume -> conversion_failure "AssumeDefNode should not be converted directly" None @@ -418,12 +409,12 @@ and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( | 0 -> attach_props param.node param.name | _ -> conversion_failure "TLAPM cannot handle operators as instance arguments" param.node.location in let mk_substitution (sub : Xml.substitution) : (hint * Expr.T.expr) = - let target = resolve_op_decl_node sub.target_uid in ( + let target = resolve_op_decl_node instance.node sub.target_uid in ( attach_props target.node target.name, - convert_expression_or_operator_argument sub.substitute + convert_expression_or_operator_argument instance.node sub.substitute ) in let instantiation : Expr.T.instance = { - inst_args = instance.parameters |> List.map resolve_formal_param_node |> List.map mk_arg; + inst_args = instance.parameters |> List.map (resolve_formal_param_node instance.node) |> List.map mk_arg; inst_mod = instance.module_name; inst_sub = List.map mk_substitution instance.substitutions; } in match instance.name with @@ -442,7 +433,7 @@ and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = Module.T.Axiom ( - Option.map (fun uid -> let def = resolve_assume_def_node uid in attach_props def.node def.name) assume.definition, + Option.map (fun uid -> let def = resolve_assume_def_node assume.node uid in attach_props def.node def.name) assume.definition, convert_expression assume.body ) |> attach_props assume.node @@ -492,21 +483,21 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( (* Case 1: Bounded non-tuple CHOOSE expression *) | [Bound {is_tuple = false; symbol_refs = [param]; expression}], [Expression body] -> Choose ( - resolve_bound_symbol param, + resolve_bound_symbol apply.node param, Some (convert_expression expression), convert_expression body ) (* Case 2: Bounded tuple CHOOSE expression *) | [Bound ({is_tuple = true} as symbol)], [Expression body] -> ChooseTuply ( - List.map resolve_bound_symbol symbol.symbol_refs, + List.map (resolve_bound_symbol apply.node) symbol.symbol_refs, Some (convert_expression symbol.expression), convert_expression body ) (* Case 3: Unbounded non-tuple CHOOSE expression *) | [Unbound ({is_tuple = false} as symbol)], [Expression body] -> Choose ( - resolve_bound_symbol symbol.symbol_ref, + resolve_bound_symbol apply.node symbol.symbol_ref, None, convert_expression body ) @@ -516,7 +507,7 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( if List.length symbols <> List.length apply.bound_symbols then conversion_failure "Inconsistent bound/unbound or tuple/non-tuple symbols in CHOOSE" apply.node.location else ChooseTuply ( - List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol s.symbol_ref) symbols, + List.map (fun (s : Xml.unbound_symbol) -> resolve_bound_symbol apply.node s.symbol_ref) symbols, None, convert_expression body ) @@ -528,7 +519,7 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( *) and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : bounds = if bound.is_tuple then conversion_failure "Tuple bound passed to non-tuple bound conversion" node.location else - match List.map resolve_bound_symbol bound.symbol_refs with + match List.map (resolve_bound_symbol node) bound.symbol_refs with (* TODO: figure out meaning of "Unknown" parameter *) | hd :: tl -> (hd, Unknown, Domain (convert_expression bound.expression)) :: List.map (fun s -> (s, Unknown, Ditto)) tl @@ -542,10 +533,10 @@ and convert_non_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : boun *) and convert_tuply_bounds (node : Xml.node) (bound : Xml.bound_symbol) : tuply_bounds = if bound.is_tuple - then match List.map resolve_bound_symbol bound.symbol_refs with + then match List.map (resolve_bound_symbol node) bound.symbol_refs with | (_ :: _ as symbols) -> [(Bound_names symbols, Domain (convert_expression bound.expression))] | [] -> conversion_failure "Tuple bound symbol groups must have at least one symbol" node.location - else match List.map resolve_bound_symbol bound.symbol_refs with + else match List.map (resolve_bound_symbol node) bound.symbol_refs with | hd :: tl -> (Bound_name hd, Domain (convert_expression bound.expression)) :: List.map (fun s -> (Bound_name s, Ditto)) tl | [] -> conversion_failure "Bound symbol groups must have at least one symbol" node.location @@ -582,7 +573,7 @@ and convert_bound_or_unbound_symbols (node : Xml.node) (all_symbols : Xml.symbol else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols then conversion_failure "Unbounded tuple quantification is not supported" node.location else let mk_bound (bound : Xml.unbound_symbol) : bound = ( - resolve_bound_symbol bound.symbol_ref, + resolve_bound_symbol node bound.symbol_ref, Unknown, (* TODO: figure out purpose of this parameter *) No_domain ) in NonTuply (List.map mk_bound unbound_symbols) @@ -637,7 +628,7 @@ and convert_temporal_quantification (quant : Expr.T.quantifier) (apply : Xml.op_ then conversion_failure "Temporal quantification requires unbound symbols" apply.node.location else if List.exists (fun (b : Xml.unbound_symbol) -> b.is_tuple) unbound_symbols then conversion_failure "Unbounded tuple quantification is not supported" apply.node.location - else let bounds = List.map (fun (b : Xml.unbound_symbol) -> resolve_bound_symbol b.symbol_ref) unbound_symbols in + else let bounds = List.map (fun (b : Xml.unbound_symbol) -> resolve_bound_symbol apply.node b.symbol_ref) unbound_symbols in Tquant (quant, bounds, convert_expression body) | _ -> conversion_failure "Invalid number of bounds or operands to temporal quantification" apply.node.location ) |> attach_props apply.node @@ -658,12 +649,12 @@ and convert_set_map (apply : Xml.op_appl_node) : Expr.T.expr = and convert_set_filter (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [Bound {symbol_refs = [symbol_ref]; is_tuple = false; expression}], [Expression predicate] -> SetSt ( - resolve_bound_symbol symbol_ref, + resolve_bound_symbol apply.node symbol_ref, convert_expression expression, convert_expression predicate ) | [Bound {symbol_refs = (_ :: _) as symbol_refs; is_tuple = true; expression}], [Expression predicate] -> SetStTuply ( - List.map resolve_bound_symbol symbol_refs, + List.map (resolve_bound_symbol apply.node) symbol_refs, convert_expression expression, convert_expression predicate ) @@ -723,7 +714,7 @@ and convert_function_application (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with | [], [Expression fn; Expression args] -> ( let args = match args with - | OpApplNode {node; operator; operands} when is_builtin_op operator TupleLiteral -> ( + | OpApplNode {node; operator; operands} when is_builtin_op apply.node operator TupleLiteral -> ( match operands with | [] -> [args] (* Empty tuple *) | [Expression single_arg] -> [args] (* Tuple with single element *) @@ -758,7 +749,7 @@ and convert_record_constructor (apply : Xml.op_appl_node) : Expr.T.expr = and as_pair (node : Xml.node) (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) = match operand with | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression left; Expression right]} -> ( - match (resolve_ref operator).kind with + match (resolve_ref node operator).kind with | BuiltInKind {operator = Pair} -> (left, right) | _ -> conversion_failure "Expected pair of expressions" node.location ) | _ -> conversion_failure "Expected pair of expressions" node.location @@ -795,7 +786,7 @@ and convert_except (apply : Xml.op_appl_node) : Expr.T.expr = ( in let mk_update (operand : Xml.expr_or_op_arg) : (Expr.T.expoint list * Expr.T.expr) option = match operand with | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression OpApplNode {operator = update_op; bound_symbols = []; operands = update_path}; Expression new_value]} -> ( - match (resolve_ref operator).kind, (resolve_ref update_op).kind with + match (resolve_ref apply.node operator).kind, (resolve_ref apply.node update_op).kind with | BuiltInKind {operator = Pair}, BuiltInKind {operator = Sequence} -> let path = update_path |> as_expr_ls __FUNCTION__ apply.node.location |> List.map convert_expression in Some (List.map mk_path path, convert_expression new_value) @@ -857,11 +848,11 @@ and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.e | [] -> conversion_failure "Unexpected empty definition reference" node.location | [component] -> Apply ( Opaque name |> attach_props node, - List.map convert_expression_or_operator_argument args + List.map (convert_expression_or_operator_argument node) args ) |> attach_props node | head :: tail -> let prefix, last = split_last_ls node tail in - let last = Sel_lab (last, List.map convert_expression_or_operator_argument args) in + let last = Sel_lab (last, List.map (convert_expression_or_operator_argument node) args) in Bang ( Opaque head |> noprops, List.map convert_selector prefix @ [last] @@ -883,7 +874,7 @@ and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.fo | 0 -> Opaque param.name |> attach_props param.node | n -> Apply ( Opaque param.name |> attach_props param.node, - List.map convert_expression_or_operator_argument apply.operands + List.map (convert_expression_or_operator_argument apply.node) apply.operands ) |> attach_props apply.node (** Conversion of reference to module-level constants or variables. Again @@ -900,7 +891,7 @@ and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_ detailed Expr.T.expr variant type used by TLAPS. *) and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = - let op_kind = (resolve_ref apply.operator).kind in + let op_kind = (resolve_ref apply.node apply.operator).kind in match op_kind with (* Operators like = and \cup but also CHOOSE and \A *) | BuiltInKind op -> convert_built_in_op_appl apply op @@ -922,16 +913,17 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = like op(x, y, z), x, y, and z can each be either expressions or operator references. LAMBDA operators can also appear here. *) -and convert_expression_or_operator_argument (op_expr : Xml.expr_or_op_arg) : Expr.T.expr = +and convert_expression_or_operator_argument (node : Xml.node) (op_expr : Xml.expr_or_op_arg) : Expr.T.expr = match op_expr with | Expression expr -> convert_expression expr - | OpArg uid -> match (resolve_ref uid).kind with + | OpArg uid -> match (resolve_ref node uid).kind with | FormalParamNode param -> Opaque param.name |> attach_props param.node | UserDefinedOpKind userdef -> convert_definition_reference userdef.node userdef.name [] | BuiltInKind builtin -> let op = sany_to_tlapm_builtin builtin.node builtin.operator in Internal op |> attach_props builtin.node | OpDeclNode decl -> convert_definition_reference decl.node decl.name [] + | ModuleInstanceKind instance -> conversion_failure ("Invalid operator argument reference to module instance: " ^ Option.get instance.name) instance.node.location | AssumeNode assume -> conversion_failure "Invalid operator argument reference to ASSUME" assume.node.location | AssumeDefNode assume -> conversion_failure ("Invalid operator argument reference to ASSUME: " ^ assume.name) assume.node.location | TheoremNode thm -> conversion_failure "Invalid operator argument reference to THEOREM" thm.node.location @@ -997,7 +989,7 @@ and convert_label (label : Xml.label_node) : Expr.T.expr = ( *) and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr = let convert_definition (def_ref : int) : Expr.T.defn = - match (resolve_ref def_ref).kind with + match (resolve_ref node def_ref).kind with | UserDefinedOpKind op -> convert_user_defined_op_kind op | _ -> todo "LET/IN definition" "Probably an instance" None in Let (List.map convert_definition def_refs, convert_expression body) |> attach_props node @@ -1005,11 +997,20 @@ and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr (** Converts user-defined operators defined within LET/IN expressions. *) and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = + let mk_params ({ref} : Xml.leibniz_param) : (hint * shape) = ( + let fpn = resolve_formal_param_node op.node ref in + attach_props fpn.node fpn.name, + match fpn.arity with + | 0 -> Shape_expr + | n -> Shape_op n + ) in let body = convert_expression op.body in (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) let expr = match op.params with | [] -> body - | params -> Lambda (List.map resolve_leibniz_formal_param_node params, body) |> attach_props op.node + | params -> + Lambda (List.map mk_params params, body) + |> attach_props op.node in Operator (attach_props op.node op.name, expr) |> attach_props op.node (** Converts user-defined operators defined in a module top-level. If operator @@ -1045,7 +1046,7 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = let proof = convert_proof uid previous_proof_level thm.proof in Theorem ( - Option.map (fun uid -> let def = resolve_theorem_def_node uid in attach_props def.node def.name) thm.definition, + Option.map (fun uid -> let def = resolve_theorem_def_node thm.node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, 0 (* The purpose of this integer parameter is unknown. *), proof, @@ -1091,10 +1092,10 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p only ) |> attach_props node -and convert_proof_step_name (uid : int) (proof_level : int) (theorem_def_ref : int option) : stepno = +and convert_proof_step_name (node : Xml.node) (uid : int) (proof_level : int) (theorem_def_ref : int option) : stepno = match theorem_def_ref with | Some uid -> - let proof_name = (resolve_theorem_def_node uid).name in + let proof_name = (resolve_theorem_def_node node uid).name in let name_start = String.index proof_name '>' in let name_end = match String.index_opt proof_name '.' with | Some n -> n | None -> String.length proof_name in let name_len = name_end - name_start in @@ -1119,13 +1120,13 @@ and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proo let convert_qed_step (qed_proof_step : Xml.proof_step_group) : Proof.T.qed_step = match qed_proof_step with | TheoremNodeRef uid -> - let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name uid proof_level thm.definition in + let thm = resolve_theorem_node node uid in + let step_name = convert_proof_step_name node uid proof_level thm.definition in Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node |> attach_proof_step_name step_name | _ -> conversion_failure "QED step must be a theorem node" node.location in let steps, qed = split_last_ls node steps - in let steps = List.map (convert_proof_step proof_level) steps + in let steps = List.map (convert_proof_step node proof_level) steps in let qed_step = convert_qed_step qed in Steps (List.rev steps, qed_step) |> attach_props node @@ -1149,32 +1150,32 @@ and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proo The resulting list of proof steps is returned in reverse order, and must be reversed to be in the correct order for TLAPM. *) -and convert_proof_step (proof_level : int) (step : Xml.proof_step_group) : Proof.T.step = +and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_step_group) : Proof.T.step = match step with | InstanceNode {node} -> conversion_failure "INSTANCE proof steps are deprecated from the TLA+ language standard" node.location | TheoremNode -> todo "TheoremNode proof step" "" None (* TODO: attach name to DefStep step *) | DefStep {node; def_refs} -> - Define (def_refs |> List.map resolve_user_defined_op_kind |> List.map convert_user_defined_op_kind) |> attach_props node + Define (def_refs |> List.map (resolve_user_defined_op_kind node) |> List.map convert_user_defined_op_kind) |> attach_props node (* TODO: confirm boolean parameter corresponds to ONLY keyword *) (* TODO: attach name to UseOrHide step *) | UseOrHide use_or_hide -> Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node | TheoremNodeRef uid -> - let thm = resolve_theorem_node uid in - let step_name = convert_proof_step_name uid proof_level thm.definition in + let thm = resolve_theorem_node node uid in + let step_name = convert_proof_step_name node uid proof_level thm.definition in let proof = convert_proof uid (step_number step_name) thm.proof in let step = match thm.body with - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator CaseProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator CaseProofStep -> convert_case_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator PickProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator PickProofStep -> convert_pick_proof_step apply proof - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator TakeProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator TakeProofStep -> convert_take_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator HaveProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator HaveProofStep -> convert_have_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator WitnessProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator WitnessProofStep -> convert_witness_proof_step apply - | Expression OpApplNode ({operator} as apply) when is_builtin_op operator SufficesProofStep -> + | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator SufficesProofStep -> convert_suffices_proof_step apply proof | _ -> Suffices (convert_sequent thm.body, proof) in step |> attach_props thm.node |> attach_proof_step_name step_name @@ -1249,7 +1250,8 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string ast.context; let ctx : Module.T.modctx = List.fold_left (fun (map : Module.T.modctx) (mule_ref : int) -> - let mule : Xml.module_node = mule_ref |> resolve_module_node in + let toplevel_node : Xml.node = {location = None; level = None} in + let mule : Xml.module_node = resolve_module_node toplevel_node mule_ref in if Coll.Sm.mem mule.name map then map else Coll.Sm.add mule.name (convert_module_node mule) map ) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 62ee8332..d2e72e2d 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -590,6 +590,29 @@ let xml_to_instance_node (children : tree list) : instance_node = } | _ -> ls_conversion_failure __FUNCTION__ children +(** This is a weird case that is almost definitely just a bug on SANY's side. + For some reason SANY treats DEFINE M == INSTANCE Naturals proof steps + differently from any other INSTANCE node, which always are either + immediately inlined as M!-prefixed operators (in LET/IN blocks) or given + as an InstanceNode type. This is the ModuleInstanceKind node type, which + cannot even represent parameterization or substitution. In fact, it does + not even export the name of the instance at all! Thankfully very few + proofs seem to include DEFINE steps with an INSTANCE. + + TODO: fix this on SANY's side. +*) +let xml_to_define_step_instance_node (children : tree list) : instance_node = + match extract_inline_node children with + | node, Node ("uniquename", [SValue name]) :: local -> { + node; + name = Some name; + module_name = ""; + substitutions = []; + parameters = []; + local = match local with | [Node ("local", _)] -> true | _ -> false; + } + | _ -> ls_conversion_failure __FUNCTION__ children + type use_or_hide_node = { node : node; facts : expression list; @@ -1011,6 +1034,7 @@ type entry_kind = | ModuleNode of module_node | OpDeclNode of op_decl_node | AssumeNode of assume_node + | ModuleInstanceKind of instance_node | UserDefinedOpKind of user_defined_op_kind | BuiltInKind of built_in_kind | TheoremNode of theorem_node @@ -1027,6 +1051,7 @@ let xml_to_entry_kind (xml : tree) : entry_kind = | Node ("UserDefinedOpKind", children) -> UserDefinedOpKind (xml_to_user_defined_op_kind children) | Node ("BuiltInKind", children) -> BuiltInKind (xml_to_built_in_kind children) | Node ("FormalParamNode", children) -> FormalParamNode (xml_to_formal_param_node children) + | Node ("ModuleInstanceKind", children) -> ModuleInstanceKind (xml_to_define_step_instance_node children) | Node ("TheoremDefNode", children) -> TheoremDefNode (xml_to_theorem_def_node children) | Node ("TheoremNode", children)-> TheoremNode (xml_to_theorem_node children) | _ -> conversion_failure __FUNCTION__ xml diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 04c597dc..b57369eb 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -58,6 +58,7 @@ let _ = ]; add_debug_flag "sany"; let tla_files = [ + "/home/ahelwer/src/tlaplus/java-tools/tlatools/org.lamport.tlatools/test/tla2sany/semantic/corpus"; "/mnt/data/ahelwer/src/tlaplus/proofs/examples"; "/mnt/data/ahelwer/src/tlaplus/proofs/library"; "/mnt/data/ahelwer/src/tlaplus/examples/specifications"; From 2145d7178fc26ca584b66d393256b30ffe463d28 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Feb 2026 15:59:55 -0800 Subject: [PATCH 69/85] Convert DEFINE INSTANCE proof steps Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 41 ++++++++++++++++++++++++++++++++--------- test/sany/sany_tests.ml | 1 + 2 files changed, 33 insertions(+), 9 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 3a31fbe5..9d8fe60b 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -369,7 +369,7 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = *) let convert_entry (unit : Xml.unit_kind) : Module.T.modunit option = match unit with - | Instance instance -> Some (convert_instance instance) + | Instance instance -> Some (convert_unit_instance instance) | UseOrHide use_or_hide -> Some (convert_use_or_hide use_or_hide) | Ref uid -> let entry = resolve_ref mule.node uid in match entry.kind with @@ -378,7 +378,7 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = | OpDeclNode op_decl_node -> Some (convert_op_decl_node op_decl_node) | UserDefinedOpKind user_defined_op_kind -> convert_unit_user_defined_op_kind user_defined_op_kind mule.name | TheoremNode theorem_node -> Some (convert_theorem_node entry.uid 0 theorem_node) - | ModuleInstanceKind instance -> Some (convert_instance instance) + | ModuleInstanceKind instance -> Some (convert_unit_instance instance) | BuiltInKind _ -> conversion_failure "BuiltInKind not expected at module top-level" None | FormalParamNode _ -> conversion_failure "FormalParamNode not expected at module top-level" None | AssumeDefNode assume -> conversion_failure "AssumeDefNode should not be converted directly" None @@ -403,7 +403,7 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = does not handle operator parameters, but it is odd that arity info is not captured. For now we will just error in that case. *) -and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( +and convert_instance (instance : Xml.instance_node) : Expr.T.instance = let mk_arg (param : Xml.formal_param_node) : hint = match param.arity with | 0 -> attach_props param.node param.name @@ -413,11 +413,17 @@ and convert_instance (instance : Xml.instance_node) : Module.T.modunit = ( attach_props target.node target.name, convert_expression_or_operator_argument instance.node sub.substitute ) - in let instantiation : Expr.T.instance = { + in { inst_args = instance.parameters |> List.map (resolve_formal_param_node instance.node) |> List.map mk_arg; inst_mod = instance.module_name; inst_sub = List.map mk_substitution instance.substitutions; - } in match instance.name with + } + +(** INSTANCE conversion at the module unit level. +*) +and convert_unit_instance (instance : Xml.instance_node) : Module.T.modunit = ( + let instantiation = convert_instance instance in + match instance.name with | Some name -> Definition (Instance (noprops name, instantiation) |> noprops, User, Hidden, Export) | None -> Anoninst (instantiation, if instance.local then Local else Export) ) |> attach_props instance.node @@ -1154,10 +1160,7 @@ and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_s match step with | InstanceNode {node} -> conversion_failure "INSTANCE proof steps are deprecated from the TLA+ language standard" node.location | TheoremNode -> todo "TheoremNode proof step" "" None - (* TODO: attach name to DefStep step *) - | DefStep {node; def_refs} -> - Define (def_refs |> List.map (resolve_user_defined_op_kind node) |> List.map convert_user_defined_op_kind) |> attach_props node - (* TODO: confirm boolean parameter corresponds to ONLY keyword *) + | DefStep {node; def_refs} -> convert_definition_proof_step node def_refs (* TODO: attach name to UseOrHide step *) | UseOrHide use_or_hide -> Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node | TheoremNodeRef uid -> @@ -1180,6 +1183,26 @@ and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_s | _ -> Suffices (convert_sequent thm.body, proof) in step |> attach_props thm.node |> attach_proof_step_name step_name +(** Converts DEFINE proof steps, like + DEFINE + P(x) == x + Q(y) == y + M(z) == INSTANCE Naturals + + TODO: attach name to DefStep step +*) +and convert_definition_proof_step (node : Xml.node) (def_refs : int list) : Proof.T.step = + let mk_def (uid : int) : Expr.T.defn = + match (resolve_ref node uid).kind with + | UserDefinedOpKind op -> convert_user_defined_op_kind op + | ModuleInstanceKind m -> ( + match m.name with + | Some name -> Instance (noprops name, convert_instance m) |> attach_props m.node + | None -> conversion_failure "Unnamed module instance in DEFINE proof step" m.node.location + ) + | _ -> conversion_failure "Invalid reference type in DEFINE proof step" node.location + in Define (List.map mk_def def_refs) |> attach_props node + (** Converts CASE proof steps, like: <2>7. CASE UNCHANGED vars *) and convert_case_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proof) : Proof.T.step_ = diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index b57369eb..e658552a 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -23,6 +23,7 @@ let should_run (path : string) : bool = String.ends_with ~suffix:"paxos/Paxos.tla"; String.ends_with ~suffix:"ByzPaxos/BPConProof.tla"; String.ends_with ~suffix:"GraphTheorem.tla"; + String.ends_with ~suffix:"NegativeOpTest.tla"; ] in not (List.exists (fun pred -> pred path) preds) let _start_at (filename : string) (files : string list) : string list = From a4427b0c163e5e9cb02321093751d25ab09fe36b Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Feb 2026 16:26:31 -0800 Subject: [PATCH 70/85] Use TLAPM standard modules Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 9d8fe60b..55cd6d58 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1275,10 +1275,11 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string (fun (map : Module.T.modctx) (mule_ref : int) -> let toplevel_node : Xml.node = {location = None; level = None} in let mule : Xml.module_node = resolve_module_node toplevel_node mule_ref in - if Coll.Sm.mem mule.name map then map - else Coll.Sm.add mule.name (convert_module_node mule) map + match Coll.Sm.find_opt mule.name Module.Standard.initctx with + | Some std_mule -> Coll.Sm.add mule.name std_mule map + | None -> Coll.Sm.add mule.name (convert_module_node mule) map ) - Coll.Sm.empty (* TODO: use standard modules here *) + Coll.Sm.empty ast.module_refs in let root_module = Coll.Sm.find ast.root_module ctx in root_module.core.important <- true; From 30a68e6755026b6934920bb693272edce1ba9c55 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Feb 2026 19:35:18 -0800 Subject: [PATCH 71/85] Improve error reporting Signed-off-by: Andrew Helwer --- src/sany/xml.ml | 29 ++++++++++++++--------------- test/sany/sany_tests.ml | 10 ++++++---- 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index d2e72e2d..af5b9c5a 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -9,7 +9,7 @@ (** Calls SANY in another process to parse the given TLA+ file, then collects the XML parse tree output. *) -let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string * int)) result = +let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (string, (string option * string)) result = let open Unix in let open Paths in (** Module jars must be appended at the end of the classpath; the reason @@ -30,7 +30,7 @@ let source_to_sany_xml_str (module_path : string) (stdlib_path : string) : (stri In_channel.close in_chan; match Unix.waitpid [] pid with | (_, WEXITED 0) -> Ok output - | (_, WEXITED exit_code) -> Error (output, exit_code) + | (_, WEXITED exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) | _ -> failwith "Process terminated abnormally" open Xmlm;; @@ -52,11 +52,14 @@ type tree = to make use of attributes or namespaces, this function and the tree type will both need to be updated accordingly. *) -let str_to_xml (xml_str: string) : tree = - let xml = Xmlm.make_input (`String (0, xml_str)) in - let el (((_namespace, name), _attributes) : tag) (children : tree list) = Node (name, children) in - let data (s : string) = match int_of_string_opt s with | Some n -> IValue n | None -> SValue s in - Xmlm.input_doc_tree ~el ~data xml |> snd +let str_to_xml (xml_str: string) : (tree, (string option * string)) result = + try + let xml = Xmlm.make_input (`String (0, xml_str)) in + let el (((_namespace, name), _attributes) : tag) (children : tree list) = Node (name, children) in + let data (s : string) = match int_of_string_opt s with | Some n -> IValue n | None -> SValue s in + let _, tree = Xmlm.input_doc_tree ~el ~data xml in Ok tree + with Xmlm.Error ((line, column), err) -> + Error (Some (Printf.sprintf "Line: %d, Column: %d" line column), "XML parsing failed: " ^ Xmlm.error_message err) (** Error method which raises an exception when parsing the SANY XML output fails. If this is ever triggered it indicates a bug either in this code @@ -1099,7 +1102,7 @@ let xml_to_modules (xml : tree) : modules = | _ -> ls_conversion_failure __FUNCTION__ children) | _ -> conversion_failure __FUNCTION__ xml -let xml_to_ast (xml : tree) : (modules, (string * string)) result = +let xml_to_ast (xml : tree) : (modules, (string option * string)) result = let prev_backtrace = Printexc.backtrace_status () in if Params.debugging "sany" then Printexc.record_backtrace true; try @@ -1109,12 +1112,8 @@ let xml_to_ast (xml : tree) : (modules, (string * string)) result = with Invalid_argument e -> let trace = Printexc.get_backtrace () in Printexc.record_backtrace prev_backtrace; - Result.error (e, trace) + Result.error (None, Printf.sprintf "%s\n%s" e trace) let get_module_ast_xml (module_path : string) (stdlib_path : string) : (modules, (string option * string)) result = - match source_to_sany_xml_str module_path stdlib_path with - | Error (output, exit_code) -> Error (None, Printf.sprintf "%d\n%s" exit_code output) - | Ok xml_str -> - match xml_str |> str_to_xml |> xml_to_ast with - | Error (msg, trace) -> Error (None, Printf.sprintf "%s\n%s" msg trace) - | Ok ast -> ast |> Result.ok + let ( >>= ) = Result.bind in + (source_to_sany_xml_str module_path stdlib_path) >>= str_to_xml >>= xml_to_ast diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index e658552a..876ec905 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -40,16 +40,18 @@ let parse_tla_file filename = let open Tlapm_lib__Sany in print_endline ("Parsing " ^ filename ^ " ..."); try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with - | Error (_, msg) -> Printf.eprintf "%s\n" msg; failwith "Parsing failed" + | Error (_, msg) -> failwith msg | Ok _ -> print_endline (filename ^ " success") with + | Unsupported_language_feature (location, RecursiveOperator) -> (* This is okay, we just don't support recursive operators *) - | Unsupported_language_feature (_, RecursiveOperator) -> () + Printf.eprintf "%s:\nUnsupported recursive operator at %s\n" filename (Loc.string_of_locus (Option.get location)) + | Unsupported_language_feature (location, Subexpression) -> (* This is okay, we just don't support subexpressions *) - | Unsupported_language_feature (_, Subexpression) -> () + Printf.eprintf "%s:\nUnsupported subexpression at %s\n" filename (Loc.string_of_locus (Option.get location)) | Failure (e : string) -> Printf.eprintf "%s\n" e; - failwith "Parsing failed" + failwith filename let _ = parser_backend := Sany; From 9892d23ac23181d19dea3fc7315af37e09c2b5c4 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Mar 2026 10:44:00 -0800 Subject: [PATCH 72/85] Fixed proof step order bug Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 215 ++++++++++++++++++++++++++-------------------- src/sany/sany.mli | 8 ++ 2 files changed, 131 insertions(+), 92 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 55cd6d58..fe3bd3be 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -65,30 +65,34 @@ open Util;; type language_feature = | RecursiveOperator + | InstanceProofStep | Subexpression exception Unsupported_language_feature of Loc.locus option * language_feature -let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = - let loc = match loc with - | Some loc -> Xml.show_location loc - | None -> "Unknown location" - in failwith (Printf.sprintf "%s not yet implemented: %s\n%s" category msg loc) +type conversion_failure_kind = + | NotYetImplemented + | InvalidBoundsOrOperands -let conversion_failure (msg : string) (loc : Xml.location option) : 'a = - let loc = match loc with - | Some loc -> Xml.show_location loc - | None -> "Unknown location" - in failwith (Printf.sprintf "Conversion failure:\n%s\n%s" msg loc) +exception Conversion_failure of conversion_failure_kind * string option * string -(** Several places require special handling of the last element of a list, - for example proof steps which end in a QED and CASE pairs which end - (possibly) in an OTHER statement. This utility function helps with that. +(** Utility function constructing & raising an exception for when conversion + of a TLA+ language feature is not yet implemented, although is planned to + be; Unsupported_language_feature is used when support is not currently + planned although could be added in the future. *) -let split_last_ls (node : Xml.node) (ls : 'a list) : 'a list * 'a = - match List.rev ls with - | [] -> conversion_failure "Cannot get last element of empty list" node.location - | hd :: tl -> (List.rev tl, hd) +let todo (category : string) (msg : string) (loc : Xml.location option) : 'a = + raise (Conversion_failure (NotYetImplemented, Option.map Xml.show_location loc, Printf.sprintf "%s not yet implemented: %s" category msg)) + +(** Utility function constructing & raising an exception for when conversion + of a TLA+ language construct fails due to invalid bounds or operands from + SANY's parse output. This can broadly be viewed as a way to account for + the projection from Java's type system to OCaml's variants, in that Java + allows representation of invalid data (for example: more than one arg to + existential quantification) which is occluded by OCaml's variants. +*) +let conversion_failure (msg : string) (loc : Xml.location option) : 'a = + raise (Conversion_failure (InvalidBoundsOrOperands, Option.map Xml.show_location loc, msg)) (** A module-global table of SANY AST entities, indexed by UID. *) @@ -112,29 +116,18 @@ let convert_location ({column = (col_start, col_finish); line = (line_start, lin file = filename ^ ".tla"; } +(** An attempt to reduce code duplication between tuple & non-tuple bounds by + wrapping them in a variant. +*) type bounds_kind = | Tuply of tuply_bounds | NonTuply of bounds -type bound_ - (** Wraps the given proof step with its name in the metadata. *) let attach_proof_step_name (proof_name : stepno) (step : 'a) : 'a = assign step Props.step proof_name -(** An OpApplNode's operands can be either expressions or operator arguments. - Often we only want them to be expressions. This function coerces the list - items into expressions, raising an error if they are operators. -*) -let as_expr_ls (name : string) (loc : Xml.location option) (operands : Xml.expr_or_op_arg list) : Xml.expression list = - let exprs = List.filter_map - (fun (operand : Xml.expr_or_op_arg) -> match operand with Expression e -> Some e | _ -> None) - operands - in if List.length exprs <> List.length operands - then conversion_failure (Format.sprintf "Expected all operands to be expressions in %s" name) loc - else exprs - (** Wrap the given object in location data. TODO: also wrap with level data. *) @@ -223,6 +216,37 @@ let is_builtin_op (node : Xml.node) (uid : int) (op : Xml.built_in_operator) : b | BuiltInKind {operator} when operator = op -> true | _ -> false +(** An OpApplNode's operands can be either expressions or operator arguments. + Often we only want them to be expressions. This function coerces the list + items into expressions, raising an error if they are operators. +*) +let as_expr_ls (name : string) (loc : Xml.location option) (operands : Xml.expr_or_op_arg list) : Xml.expression list = + let exprs = List.filter_map + (fun (operand : Xml.expr_or_op_arg) -> match operand with Expression e -> Some e | _ -> None) + operands + in if List.length exprs <> List.length operands + then conversion_failure (Format.sprintf "Expected all operands to be expressions in %s" name) loc + else exprs + +(** Several places require special handling of the last element of a list, + for example proof steps which end in a QED and CASE pairs which end + (possibly) in an OTHER statement. This utility function helps with that. +*) +let split_last_ls (node : Xml.node) (ls : 'a list) : 'a list * 'a = + match List.rev ls with + | [] -> conversion_failure "Cannot get last element of empty list" node.location + | hd :: tl -> (List.rev tl, hd) + +(** Utility function to convert a list of operands to a list of expression pairs. +*) +let as_pair (node : Xml.node) (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) = + match operand with + | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression left; Expression right]} -> ( + match (resolve_ref node operator).kind with + | BuiltInKind {operator = Pair} -> (left, right) + | _ -> conversion_failure "Expected pair of expressions" node.location + ) | _ -> conversion_failure "Expected pair of expressions" node.location + (** Converts a SANY built-in operator to a TLAPM built-in operator. This is only defined for a subset of the operators that SANY considers built-in, and not all operators that TLAPM considers built-in are represented in @@ -419,7 +443,8 @@ and convert_instance (instance : Xml.instance_node) : Expr.T.instance = inst_sub = List.map mk_substitution instance.substitutions; } -(** INSTANCE conversion at the module unit level. +(** INSTANCE conversion at the module unit level. This just wraps a converted + instance in a Definition or Anoninst variant. *) and convert_unit_instance (instance : Xml.instance_node) : Module.T.modunit = ( let instantiation = convert_instance instance in @@ -428,15 +453,28 @@ and convert_unit_instance (instance : Xml.instance_node) : Module.T.modunit = ( | None -> Anoninst (instantiation, if instance.local then Local else Export) ) |> attach_props instance.node +(** Converts USE x, y, z and HIDE a, b, c statements. These statements will + reveal or conceal the given definitions to all subsequent proof steps. + The USE ONLY x, y, z statement ensures that only the given definitions + will be considered in subsequent proof steps. +*) +and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = + let action = if use_or_hide.hide then `Hide else `Use use_or_hide.only in + Mutate (action, convert_usable use_or_hide) |> attach_props use_or_hide.node + +(** Called both from unit-level USE/HIDE conversion and from proof step USE/ + HIDE conversion. De-duplication of shared conversion logic. +*) and convert_usable (use_or_hide : Xml.use_or_hide_node) : Proof.T.usable = { facts = List.map convert_expression use_or_hide.facts; defs = List.map (resolve_def use_or_hide.node) use_or_hide.def_refs; } -and convert_use_or_hide (use_or_hide : Xml.use_or_hide_node) : Module.T.modunit = - let action = if use_or_hide.hide then `Hide else `Use use_or_hide.only in - Mutate (action, convert_usable use_or_hide) |> attach_props use_or_hide.node - +(** Converts an ASSUME unit-level construct. This can be named or unnamed. If + named, this name is given by resolving a reference to an AssumeDefNode, + which is different from an AssumeNode. Probably this duplication will be + removed on the SANY side eventually. +*) and convert_assume_node (assume : Xml.assume_node) : Module.T.modunit = Module.T.Axiom ( Option.map (fun uid -> let def = resolve_assume_def_node assume.node uid in attach_props def.node def.name) assume.definition, @@ -462,7 +500,8 @@ and convert_fairness (fairness : fairness_op) (apply : Xml.op_appl_node) : Expr. | _ -> conversion_failure "Wrong number of operands to fairness expression" apply.node.location ) |> attach_props apply.node -(** Converts action-level expressions such as [][expr]_sub and <><>_sub. +(** Converts action-level expressions such as [expr]_sub and <>_sub. + TODO: construct the TSub type if this is prefixed with [] or <>. *) and convert_action_expr (op : modal_op) (apply : Xml.op_appl_node) : Expr.T.expr = match apply.operands with @@ -507,7 +546,7 @@ and convert_choose (apply : Xml.op_appl_node) : Expr.T.expr = ( None, convert_expression body ) - (* Case 4: Unbounded tuple CHOOSE expression *) + (* Case 4: Unbounded tuple CHOOSE expression; this is the only place in TLA+ where an unbounded tuple quantifier is valid. *) | Unbound {is_tuple = true} :: _, [Expression body] -> let symbols = List.filter_map (fun (s : Xml.symbol) -> match s with | Unbound ({is_tuple = true} as u) -> Some u | _ -> None) apply.bound_symbols in if List.length symbols <> List.length apply.bound_symbols @@ -750,16 +789,6 @@ and convert_record_set (apply : Xml.op_appl_node) : Expr.T.expr = and convert_record_constructor (apply : Xml.op_appl_node) : Expr.T.expr = convert_record_operator apply (fun arg -> Record arg) -(** Utility function to convert a list of operands to a list of expression pairs. -*) -and as_pair (node : Xml.node) (operand : Xml.expr_or_op_arg) : (Xml.expression * Xml.expression) = - match operand with - | Expression OpApplNode {operator; bound_symbols = []; operands = [Expression left; Expression right]} -> ( - match (resolve_ref node operator).kind with - | BuiltInKind {operator = Pair} -> (left, right) - | _ -> conversion_failure "Expected pair of expressions" node.location - ) | _ -> conversion_failure "Expected pair of expressions" node.location - (** The conversion logic for both record sets and record constructors is identical except for the wrapping constructor (Rect vs Record). This method captures that shared logic, taking the constructor as a parameter. @@ -814,7 +843,12 @@ and convert_if_then_else (apply : Xml.op_appl_node) : Expr.T.expr = ( | _ -> conversion_failure "Invalid operands to IF/THEN/ELSE" apply.node.location ) |> attach_props apply.node -(** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e +(** Conversion of expression CASE p1 -> e1 [] p2 -> e2 [] ... [] OTHER -> e. + Operands are given as a list of (predicate, expression) pairs, with the + optional final OTHER node having its predicate represented as a string + with value "$Other"; this will likely be changed on the SANY side in the + future, as it's equivalent in representation to the plausible syntax + CASE "$Other" -> expr. *) and convert_case (apply : Xml.op_appl_node) : Expr.T.expr = ( match apply.bound_symbols, apply.operands with @@ -842,6 +876,7 @@ and convert_subexpression (apply : Xml.op_appl_node) : Expr.T.expr = ( will not contain subexpression elements like :, <<, @, etc. because those would have been given by SANY as the $Nop operator and thus are handled in the convert_subexpression method. + TODO: How are things like M!N(a)!op represented? *) and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.expr_or_op_arg list) : Expr.T.expr = let convert_selector (component : string) : Expr.T.sel = @@ -892,7 +927,7 @@ and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_ (** OpApplNode is a very general node used by SANY to represent essentially all expression types. Things like \A x \in S : P are represented as an - application of the built-in "forall" operator, with argument P and symbol + application of the built-in "forall" operator, with operand P and symbol x bound by S. This complicated method de-abstracts this into the more detailed Expr.T.expr variant type used by TLAPS. *) @@ -980,16 +1015,6 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = and convert_substitution_in (subst : Xml.subst_in_node) : Expr.T.expr = convert_expression subst.body -(** Converts lbl(a, b, c) :: expr - TODO: Handle conversion in all cases -*) -and convert_label (label : Xml.label_node) : Expr.T.expr = ( - match label.body with - | Expression expr -> Parens (convert_expression expr, noprops Syntax) - | AssumeProveLike AssumeProveNode ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) - | AssumeProveLike AssumeProveSubstitution aps -> todo "Label" "AssumeProveSubstitution" aps.node.location -) |> attach_props label.node - (** Converts LET/IN definition sets, consisting of one or more definitions followed by a body expression in which the definitions are available. *) @@ -997,7 +1022,7 @@ and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr let convert_definition (def_ref : int) : Expr.T.defn = match (resolve_ref node def_ref).kind with | UserDefinedOpKind op -> convert_user_defined_op_kind op - | _ -> todo "LET/IN definition" "Probably an instance" None + | _ -> todo "LET/IN definition" "" None in Let (List.map convert_definition def_refs, convert_expression body) |> attach_props node (** Converts user-defined operators defined within LET/IN expressions. @@ -1060,14 +1085,19 @@ and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.the empty_summary ) |> attach_props thm.node +(** Converts ASSUME/PROVE constructs; this method de-duplicates some logic + and is called both from the theorem sequent conversion method and also + the label conversion method. + TODO: fill in context from ASSUME +*) and convert_assume_prove (ap : Xml.assume_prove_node) : sequent = { - context = Deque.empty; (* TODO: fill in context from ASSUME part *) + context = Deque.empty; active = convert_expression ap.prove; } (** Sequents are theorem bodies, which are either simple expressions or ASSUME/PROVE constructs. - TODO: handle ASSUME/PROVE + TODO: handle ASSUME/PROVE substitution case (uncertain what this is). *) and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with @@ -1075,15 +1105,29 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = | AssumeProveLike AssumeProveNode ap -> convert_assume_prove ap | AssumeProveLike AssumeProveSubstitution aps -> todo "Sequent" "AssumeProveSubstitution" aps.node.location +(** Converts lbl(a, b, c) :: expr + TODO: Handle conversion in all cases +*) +and convert_label (label : Xml.label_node) : Expr.T.expr = ( + match label.body with + | Expression expr -> Parens (convert_expression expr, noprops Syntax) + | AssumeProveLike AssumeProveNode ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) + | AssumeProveLike AssumeProveSubstitution aps -> todo "Label" "AssumeProveSubstitution" aps.node.location +) |> attach_props label.node + (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series - of individual proof steps culminated in a QED step. + of individual proof steps culminated in a QED step. We need to attach a + proof name to each proof step type, which in most of them is fairly + meaningless but is required by subsequent TLAPM processing. Thus we just + attach the incremented previous proof level and the reference UID. *) and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group option) : Proof.T.proof = + let proof_name = Unnamed (previous_proof_level + 1, uid) in match proof with - | None -> Omitted Implicit |> noprops |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) - | Some By proof -> convert_by_proof proof |> attach_proof_step_name (Unnamed (previous_proof_level + 1, uid)) + | None -> Omitted Implicit |> noprops |> attach_proof_step_name proof_name + | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name proof_name + | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name proof_name + | Some By proof -> convert_by_proof proof |> attach_proof_step_name proof_name | Some Steps proof -> convert_proof_steps uid proof (** Converts proofs of the form BY x, y, z DEF a, b, c. This is another place @@ -1098,6 +1142,11 @@ and convert_by_proof ({node; facts; defs; only} : Xml.by_proof_node) : Proof.T.p only ) |> attach_props node +(** Extracts the proof step name from a string like <1>abc. This is done by + taking the substring between the > and either the end of the string or + the first '.' character. Probably this information should be exposed by + SANY. +*) and convert_proof_step_name (node : Xml.node) (uid : int) (proof_level : int) (theorem_def_ref : int option) : stepno = match theorem_def_ref with | Some uid -> @@ -1110,17 +1159,7 @@ and convert_proof_step_name (node : Xml.node) (uid : int) (proof_level : int) (t | None -> Unnamed (proof_level, uid) (** One possible proof form is a series of steps, culminating in a QED step. - This method converts that structure. This is the most complex part of the - proof conversion, primarily due to the necessity of appending proof step - names and levels to each step and overall proof. SANY does not export the - proof level in its parse tree, and looking at the code on that side there - does not seem to be an easy method of doing so. Thus we have to parse the - first proof step name to get the initial proof level, which might be <*> - or <+> and thus relative to the previous proof level. This information is - propagated both up & down the parse tree to assign correct proof levels - elsewhere. Proof names can be either named or unnamed; in the latter case - TLAPM requires a unique ID to be assigned, so we use the UID of the SANY - AST node. + This method converts that structure. *) and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proof_node) : Proof.T.proof = let convert_qed_step (qed_proof_step : Xml.proof_step_group) : Proof.T.qed_step = @@ -1132,11 +1171,10 @@ and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proo |> attach_proof_step_name step_name | _ -> conversion_failure "QED step must be a theorem node" node.location in let steps, qed = split_last_ls node steps - in let steps = List.map (convert_proof_step node proof_level) steps - in let qed_step = convert_qed_step qed - in Steps (List.rev steps, qed_step) - |> attach_props node - |> attach_proof_step_name (Unnamed (proof_level, uid)) + in Steps ( + List.map (convert_proof_step node proof_level) steps, + convert_qed_step qed + ) |> attach_props node |> attach_proof_step_name (Unnamed (proof_level, uid)) (** Converts a specific proof step into the Proof.T.step variant expected by TLAPM. While TLAPM has thirteen proof variants as of this writing, SANY @@ -1148,17 +1186,10 @@ and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proo used. TheoremNodeRef is the real workhorse proof step type, as it is used for all proof step types that can have sub-proofs. The specific proof step subtype is identified by a special built-in operator as the theorem body. - - This function has an odd type signature because it's intended for use in - a List.fold_left over the list of proof steps; the reason we need to do - this is to identify the proof level of this proof by parsing the actual - proof step names, then propagating this knowledge forward in the fold. - The resulting list of proof steps is returned in reverse order, and must - be reversed to be in the correct order for TLAPM. *) and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_step_group) : Proof.T.step = match step with - | InstanceNode {node} -> conversion_failure "INSTANCE proof steps are deprecated from the TLA+ language standard" node.location + | InstanceNode {node} -> raise (Unsupported_language_feature (Option.map convert_location node.location, InstanceProofStep)) | TheoremNode -> todo "TheoremNode proof step" "" None | DefStep {node; def_refs} -> convert_definition_proof_step node def_refs (* TODO: attach name to UseOrHide step *) diff --git a/src/sany/sany.mli b/src/sany/sany.mli index 32c6a3e7..7a9ce095 100644 --- a/src/sany/sany.mli +++ b/src/sany/sany.mli @@ -1,6 +1,14 @@ type language_feature = | RecursiveOperator + | InstanceProofStep | Subexpression exception Unsupported_language_feature of Loc.locus option * language_feature + +type conversion_failure_kind = + | NotYetImplemented + | InvalidBoundsOrOperands + +exception Conversion_failure of conversion_failure_kind * string option * string + val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result \ No newline at end of file From 68b7b709b2683dd1473bf356e44552fee2bb17f9 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Mar 2026 11:14:35 -0800 Subject: [PATCH 73/85] Removed unnecessary utility functions in xml Signed-off-by: Andrew Helwer --- src/sany/xml.ml | 67 ++++++++++--------------------------------------- 1 file changed, 13 insertions(+), 54 deletions(-) diff --git a/src/sany/xml.ml b/src/sany/xml.ml index af5b9c5a..13d43f2b 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -85,53 +85,6 @@ let is_tag (tag_name : string) (node : tree) : bool = | Node (name, _) when name = tag_name -> true | _ -> false -(** Utility function that simply returns the children of an XML node. Raises - an exception if called on a leaf node. -*) -let children_of (xml : tree) : tree list = - match xml with - | Node (_, children) -> children - | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise - -(** Utility function that returns the single child of an XML node. Raises an - exception if there is not exactly one child. -*) -let child_of (xml : tree) : tree = - match xml with - | Node (_, [child]) -> child - | Node (_, _) -> Invalid_argument (Printf.sprintf "Require single child of node %s" (show_tree xml)) |> raise - | _ -> Invalid_argument (Printf.sprintf "Cannot get children of node %s" (show_tree xml)) |> raise - -(** Searches for an optional tag in the children of an XML node. -*) -let find_tag_opt (tag_name : string) (children : tree list) : tree option = - List.find_opt (is_tag tag_name) children - -(** Searches for a tag in the children of an XML node, and raises a detailed - exception if it is not found. -*) -let find_tag (tag_name : string) (children : tree list) : tree = - match find_tag_opt tag_name children with - | Some v -> v - | None -> ls_conversion_failure __FUNCTION__ children - -(** Utility function to extract the string value from a tagged XML node which - may or may not be present. -*) -let xml_to_tagged_string_opt (tag_name : string) (children : tree list) : string option = - match find_tag_opt tag_name children with - | Some (Node (_, [SValue s])) -> Some s - | _ -> None - -(** Utility function to extract the string value from a tagged XML node. - Raises a detailed exception if the tag is not found or if the tagged node - does not contain a single string value. -*) -let xml_to_tagged_string (tag_name : string) (children : tree list) : string = - match xml_to_tagged_string_opt tag_name children with - | Some s -> s - | None -> ls_conversion_failure __FUNCTION__ children - (** Use this in conjunction with List.filter_map on children of a node to get all references of various types. *) @@ -552,16 +505,22 @@ and xml_to_expression (xml : tree) : expression = | _ -> conversion_failure __FUNCTION__ xml and xml_to_user_defined_op_kind (children : tree list) : user_defined_op_kind = - match extract_inline_node children with - | node, Node ("uniquename", [SValue name]) :: Node ("arity", [IValue arity]) :: children -> { + let node, name, arity, precomments, children = match extract_inline_node children with + | node, Node ("uniquename", [SValue name]) :: Node ("arity", [IValue arity]) :: Node ("pre-comments", [SValue precomments]) :: children -> + node, name, arity, Some precomments, children + | node, Node ("uniquename", [SValue name]) :: Node ("arity", [IValue arity]) :: children -> + node, name, arity, None, children + | _ -> ls_conversion_failure __FUNCTION__ children + in match children with + | Node ("body", [body]) :: Node ("params", parameters) :: flags -> { node; name; arity; - precomments = children |> xml_to_tagged_string_opt "pre-comments"; - body = children |> find_tag "body" |> child_of |> xml_to_expression; - params = children |> find_tag "params" |> children_of |> List.map xml_to_leibniz_param; - recursive = children |> List.exists (is_tag "recursive"); - local = children |> List.exists (is_tag "local"); + precomments; + body = xml_to_expression body; + params = List.map xml_to_leibniz_param parameters; + recursive = flags |> List.exists (is_tag "recursive"); + local = flags |> List.exists (is_tag "local"); } | _ -> ls_conversion_failure __FUNCTION__ children From bd4a5f84cbb082413083b44911e4d393217a4aeb Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Mar 2026 13:11:46 -0800 Subject: [PATCH 74/85] Translated ASSUME/PROVE hypotheses Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 33 +++++++++++++++++++++++++++------ 1 file changed, 27 insertions(+), 6 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index fe3bd3be..7b34c0cc 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1088,12 +1088,33 @@ and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.the (** Converts ASSUME/PROVE constructs; this method de-duplicates some logic and is called both from the theorem sequent conversion method and also the label conversion method. - TODO: fill in context from ASSUME *) -and convert_assume_prove (ap : Xml.assume_prove_node) : sequent = { - context = Deque.empty; - active = convert_expression ap.prove; -} +and convert_assume_prove (ap : Xml.assume_prove_node) : sequent = + let convert_hypothesis (hypothesis : Xml.assumption_kind) : Expr.T.hyp = + match hypothesis with + | Expression expr -> Fact (convert_expression expr, Visible, NotSet) |> attach_props ap.node + | NewSymbol ns -> + let symbol = resolve_op_decl_node ns.node ns.symbol_ref in + let arity = match symbol.arity with | 0 -> Shape_expr | n -> Shape_op n in + let kind = match symbol.kind with + | NewConstant -> Constant + | NewVariable -> State + | NewState -> State + | NewAction -> Action + | NewTemporal -> Temporal + | _ -> conversion_failure "Invalid symbol kind in NEW" ns.node.location + in let domain = match ns.domain with + | Some domain -> Bounded (convert_expression domain, Hidden) + | None -> Unbounded + in Fresh (noprops symbol.name, arity, kind, domain) + |> attach_props ns.node + | AssumeProveLike AssumeProveNode apl -> + Fact (Sequent (convert_assume_prove apl) |> attach_props apl.node, Visible, NotSet) |> attach_props apl.node + | AssumeProveLike AssumeProveSubstitution apl -> todo "ASSUME/PROVE" "nested ASSUME/PROVE with substitution" apl.node.location + in { + context = List.map convert_hypothesis ap.assumptions |> Deque.of_list; + active = convert_expression ap.prove; + } (** Sequents are theorem bodies, which are either simple expressions or ASSUME/PROVE constructs. @@ -1103,7 +1124,7 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = match seq with | Expression expr -> {context = Deque.empty; active = convert_expression expr} | AssumeProveLike AssumeProveNode ap -> convert_assume_prove ap - | AssumeProveLike AssumeProveSubstitution aps -> todo "Sequent" "AssumeProveSubstitution" aps.node.location + | AssumeProveLike AssumeProveSubstitution aps -> todo "Sequent" "ASSUME/PROVE with substitution" aps.node.location (** Converts lbl(a, b, c) :: expr TODO: Handle conversion in all cases From 4e89248cef4f1456b8d332a19c76401e56fd6560 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 2 Mar 2026 13:36:04 -0800 Subject: [PATCH 75/85] Fully convert label nodes Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 17 ++++++++++++----- src/sany/xml.ml | 2 ++ 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 7b34c0cc..41790646 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1126,14 +1126,21 @@ and convert_sequent (seq : Xml.expr_or_assume_prove) : sequent = | AssumeProveLike AssumeProveNode ap -> convert_assume_prove ap | AssumeProveLike AssumeProveSubstitution aps -> todo "Sequent" "ASSUME/PROVE with substitution" aps.node.location -(** Converts lbl(a, b, c) :: expr - TODO: Handle conversion in all cases +(** Converts lbl(a, b, c) :: expr and lbl(a, b, c) :: ASSUME ... PROVE. TLAPM + treats labels as parentheses subtypes. + TODO: Determine whether labels should be able to handle operators here. *) and convert_label (label : Xml.label_node) : Expr.T.expr = ( + let mk_arg (param : Xml.formal_param_node) : hint = + match param.arity with + | 0 -> attach_props param.node param.name + | _ -> conversion_failure "TLAPM cannot handle operators as label arguments" param.node.location + in let parameters = List.map (resolve_formal_param_node label.node) label.parameters |> List.map mk_arg in + let lbl = Nlabel (label.name, parameters) |> attach_props label.node in match label.body with - | Expression expr -> Parens (convert_expression expr, noprops Syntax) - | AssumeProveLike AssumeProveNode ap -> Parens (Sequent (convert_assume_prove ap) |> noprops, noprops Syntax) - | AssumeProveLike AssumeProveSubstitution aps -> todo "Label" "AssumeProveSubstitution" aps.node.location + | Expression expr -> Parens (convert_expression expr, lbl) + | AssumeProveLike AssumeProveNode ap -> Parens (Sequent (convert_assume_prove ap) |> attach_props ap.node, lbl) + | AssumeProveLike AssumeProveSubstitution aps -> todo "Label" "ASSUME/PROVE with substitution" aps.node.location ) |> attach_props label.node (** Converts a proof, which can either be OMITTED, OBVIOUS, BY, or a series diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 13d43f2b..05215231 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -271,6 +271,7 @@ and at_node = { and label_node = { node : node; + name : string; arity : int; body : expr_or_assume_prove; parameters : int list @@ -426,6 +427,7 @@ and xml_to_label_node (children : tree list) : label_node = Node ("params", parameters) ] -> { node; + name; arity; body = xml_to_expr_or_assume_prove body; parameters = List.map get_ref parameters; From 8c5ee321699e1e249da93aa001b70a352e4cad24 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Thu, 12 Mar 2026 16:09:08 -0700 Subject: [PATCH 76/85] Convert LAMBDA Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 72 +++++++++++++++++++++----------- src/sany/xml.ml | 24 ++++------- src/tlapm_lib.ml | 7 ++-- test/sany/sany_tests.ml | 10 ++--- test/semantics/Test.tla | 1 + test/semantics/semantic_tests.ml | 41 +++++++++--------- 6 files changed, 87 insertions(+), 68 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 41790646..8d1b9915 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -216,6 +216,16 @@ let is_builtin_op (node : Xml.node) (uid : int) (op : Xml.built_in_operator) : b | BuiltInKind {operator} when operator = op -> true | _ -> false +(** Unboxes the Leibniz param into a formal param node and converts it into + the form usually (but not always; see labels) used within TLAPM. +*) +let convert_leibniz_param_node (node : Xml.node) ({ref} : Xml.leibniz_param) : (hint * shape) = + let fpn = resolve_formal_param_node node ref in + attach_props fpn.node fpn.name, + match fpn.arity with + | 0 -> Shape_expr + | n -> Shape_op n + (** An OpApplNode's operands can be either expressions or operator arguments. Often we only want them to be expressions. This function coerces the list items into expressions, raising an error if they are operators. @@ -878,7 +888,7 @@ and convert_subexpression (apply : Xml.op_appl_node) : Expr.T.expr = ( in the convert_subexpression method. TODO: How are things like M!N(a)!op represented? *) -and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.expr_or_op_arg list) : Expr.T.expr = +and convert_definition_reference (node : Xml.node) (name : string) (op_or_apply : [ `Op | `Apply of Xml.expr_or_op_arg list]) : Expr.T.expr = let convert_selector (component : string) : Expr.T.sel = if String.contains component '(' then todo "Definition reference" "Function application in selector" node.location @@ -887,14 +897,20 @@ and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.e if List.mem "" components then todo "Definition reference" "!!" node.location else match components with | [] -> conversion_failure "Unexpected empty definition reference" node.location - | [component] -> Apply ( - Opaque name |> attach_props node, - List.map (convert_expression_or_operator_argument node) args - ) |> attach_props node + | [component] -> ( + match op_or_apply with + | `Op -> Opaque name |> attach_props node + | `Apply args -> Apply ( + Opaque name |> attach_props node, + List.map (convert_expression_or_operator_argument node) args + ) |> attach_props node + ) | head :: tail -> let prefix, last = split_last_ls node tail in - let last = Sel_lab (last, List.map (convert_expression_or_operator_argument node) args) in - Bang ( + let last = Sel_lab ( + last, + List.map (convert_expression_or_operator_argument node) (match op_or_apply with | `Op -> [] | `Apply args -> args) + ) in Bang ( Opaque head |> noprops, List.map convert_selector prefix @ [last] ) |> attach_props node @@ -903,7 +919,7 @@ and convert_definition_reference (node : Xml.node) (name : string) (args : Xml.e defined in the standard modules. *) and convert_user_defined_op_appl (apply : Xml.op_appl_node) (op : Xml.user_defined_op_kind) : Expr.T.expr = - convert_definition_reference apply.node op.name apply.operands + convert_definition_reference apply.node op.name (`Apply apply.operands) (** Conversion of reference to in-scope operator parameters, such as in op(a, b, c) == a. This is a case where information is actually lost, @@ -923,7 +939,7 @@ and convert_formal_param_node_op_appl (apply : Xml.op_appl_node) (param : Xml.fo Bruijn index later on. *) and convert_op_decl_node_op_appl (apply : Xml.op_appl_node) (decl : Xml.op_decl_node) : Expr.T.expr = - convert_definition_reference apply.node decl.name apply.operands + convert_definition_reference apply.node decl.name (`Apply apply.operands) (** OpApplNode is a very general node used by SANY to represent essentially all expression types. Things like \A x \in S : P are represented as an @@ -943,9 +959,9 @@ and convert_op_appl_node (apply : Xml.op_appl_node) : Expr.T.expr = (* A reference to a CONSTANT or VARIABLE identifier *) | OpDeclNode decl -> convert_op_decl_node_op_appl apply decl (* A reference to a named THEOREM or a proof step *) - | TheoremDefNode thm -> convert_definition_reference thm.node thm.name [] + | TheoremDefNode thm -> convert_definition_reference thm.node thm.name `Op (* A reference to a named ASSUME node *) - | AssumeDefNode assume -> convert_definition_reference assume.node assume.name [] + | AssumeDefNode assume -> convert_definition_reference assume.node assume.name `Op | _ -> conversion_failure ("Invalid operator reference in OpApplNode : " ^ (Xml.show_entry_kind op_kind)) apply.node.location (** Some places in TLA⁺ syntax allow both normal expressions and also @@ -959,11 +975,14 @@ and convert_expression_or_operator_argument (node : Xml.node) (op_expr : Xml.exp | Expression expr -> convert_expression expr | OpArg uid -> match (resolve_ref node uid).kind with | FormalParamNode param -> Opaque param.name |> attach_props param.node - | UserDefinedOpKind userdef -> convert_definition_reference userdef.node userdef.name [] + | UserDefinedOpKind userdef -> + (* The XML export format identifies lambda operators with just the string name LAMBDA *) + if userdef.name = "LAMBDA" then convert_lambda userdef else + convert_definition_reference userdef.node userdef.name `Op | BuiltInKind builtin -> let op = sany_to_tlapm_builtin builtin.node builtin.operator in Internal op |> attach_props builtin.node - | OpDeclNode decl -> convert_definition_reference decl.node decl.name [] + | OpDeclNode decl -> convert_definition_reference decl.node decl.name `Op | ModuleInstanceKind instance -> conversion_failure ("Invalid operator argument reference to module instance: " ^ Option.get instance.name) instance.node.location | AssumeNode assume -> conversion_failure "Invalid operator argument reference to ASSUME" assume.node.location | AssumeDefNode assume -> conversion_failure ("Invalid operator argument reference to ASSUME: " ^ assume.name) assume.node.location @@ -988,6 +1007,15 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | TheoremDefRef uid -> todo "Expression" "TheoremDefRef" None | AssumeDefRef uid -> todo "Expression" "AssumeDefRef" None +(** Converts LAMBDA x : x + 1 type operators, which can only appear as + parameters to other operators. +*) +and convert_lambda (op : Xml.user_defined_op_kind) : Expr.T.expr = + Lambda ( + List.map (convert_leibniz_param_node op.node) op.params, + convert_expression op.body + ) |> attach_props op.node + (** When a module has been imported using INSTANCE along with one or more substitutions, and then an expression referencing an operator or definition from that module is used, that reference is given as a subst_in_node by @@ -1028,19 +1056,12 @@ and convert_let_in_node ({node; def_refs; body} : Xml.let_in_node) : Expr.T.expr (** Converts user-defined operators defined within LET/IN expressions. *) and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = - let mk_params ({ref} : Xml.leibniz_param) : (hint * shape) = ( - let fpn = resolve_formal_param_node op.node ref in - attach_props fpn.node fpn.name, - match fpn.arity with - | 0 -> Shape_expr - | n -> Shape_op n - ) in let body = convert_expression op.body in (* TLAPS represents op(x) == expr as op == LAMBDA x : expr *) let expr = match op.params with | [] -> body | params -> - Lambda (List.map mk_params params, body) + Lambda (List.map (convert_leibniz_param_node op.node) params, body) |> attach_props op.node in Operator (attach_props op.node op.name, expr) |> attach_props op.node @@ -1324,7 +1345,6 @@ and convert_suffices_proof_step (apply : Xml.op_appl_node) (proof : Proof.T.proo root. *) let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string option * string)) result = - if ast.modules <> [] then conversion_failure "SANY AST cannot have multiple top-level modules" None; entries := List.fold_left (fun m (e : Xml.entry) -> Coll.Im.add e.uid e.kind m) @@ -1335,8 +1355,12 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string let toplevel_node : Xml.node = {location = None; level = None} in let mule : Xml.module_node = resolve_module_node toplevel_node mule_ref in match Coll.Sm.find_opt mule.name Module.Standard.initctx with - | Some std_mule -> Coll.Sm.add mule.name std_mule map - | None -> Coll.Sm.add mule.name (convert_module_node mule) map + | Some std_mule -> + print_endline ("Using built-in standard module " ^ mule.name); + Coll.Sm.add mule.name std_mule map + | None -> + print_endline ("Converting parsed module " ^ mule.name); + Coll.Sm.add mule.name (convert_module_node mule) map ) Coll.Sm.empty ast.module_refs diff --git a/src/sany/xml.ml b/src/sany/xml.ml index 05215231..b3607766 100644 --- a/src/sany/xml.ml +++ b/src/sany/xml.ml @@ -244,13 +244,13 @@ type unbound_symbol = { } [@@deriving show] -let xml_to_unbound_symbol xml = - match xml with - | Node ("unbound", Node ("FormalParamNodeRef", [Node ("UID", [IValue symbol_ref])]) :: tuple_tag_opt) -> { +let xml_to_unbound_symbol (children : tree list) : unbound_symbol = + match children with + | Node ("FormalParamNodeRef", [Node ("UID", [IValue symbol_ref])]) :: tuple_tag_opt -> { symbol_ref; is_tuple = match tuple_tag_opt with | [Node ("tuple", [])] -> true | _ -> false; } - | _ -> conversion_failure __FUNCTION__ xml + | _ -> ls_conversion_failure __FUNCTION__ children type op_appl_node = { node : node; @@ -353,9 +353,9 @@ and expr_or_assume_prove = | AssumeProveLike of assume_prove_like [@@deriving show] -let rec xml_to_symbols xml = +let rec xml_to_symbols (xml : tree) : symbol = match xml with - | Node ("unbound", _) -> Unbound (xml_to_unbound_symbol xml) + | Node ("unbound", children) -> Unbound (xml_to_unbound_symbol children) | Node ("bound", children) -> Bound (xml_to_bound_symbol children) | _ -> conversion_failure __FUNCTION__ xml @@ -1037,7 +1037,6 @@ let xml_to_entry (xml : tree) : entry = type modules = { root_module: string; context: entry list; - modules: module_node list; module_refs : int list; } [@@deriving show] @@ -1049,16 +1048,7 @@ let xml_to_modules (xml : tree) : modules = | Node ("RootModule", [SValue root_module]) :: Node ("context", entries) :: modules -> { root_module; context = List.map xml_to_entry entries; - modules = modules |> List.filter_map (fun entry -> - match entry with - | Node ("ModuleNode", children) -> Some (xml_to_module_node children) - | _ -> None - ); - module_refs = List.filter_map (fun entry -> - match entry with - | Node ("ModuleNodeRef", [Node ("UID", [IValue uid])]) -> Some uid - | _ -> None - ) modules; + module_refs = List.map get_ref modules; } | _ -> ls_conversion_failure __FUNCTION__ children) | _ -> conversion_failure __FUNCTION__ xml diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index e8dbce7e..dbefe27c 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -544,13 +544,14 @@ let setup_loader fs loader_paths = let loader_paths = List.fold_left add_if_new loader_paths fs in Loader.Global.setup loader_paths -let sany_modctx_of_string filename = - (*let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = +let sany_modctx_of_string filename = (* + let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = Params.input_files := [Filename.basename filename]; Params.set_search_path [Filename.basename filename]; let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) - in Result.bind (Sany.parse filename) transform*) + in Result.bind (Sany.parse filename) transform + *) Sany.parse filename let main fs = diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 876ec905..4af87967 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -49,9 +49,9 @@ let parse_tla_file filename = | Unsupported_language_feature (location, Subexpression) -> (* This is okay, we just don't support subexpressions *) Printf.eprintf "%s:\nUnsupported subexpression at %s\n" filename (Loc.string_of_locus (Option.get location)) - | Failure (e : string) -> + (*| Failure (e : string) -> Printf.eprintf "%s\n" e; - failwith filename + failwith filename*) let _ = parser_backend := Sany; @@ -61,10 +61,10 @@ let _ = ]; add_debug_flag "sany"; let tla_files = [ - "/home/ahelwer/src/tlaplus/java-tools/tlatools/org.lamport.tlatools/test/tla2sany/semantic/corpus"; - "/mnt/data/ahelwer/src/tlaplus/proofs/examples"; - "/mnt/data/ahelwer/src/tlaplus/proofs/library"; "/mnt/data/ahelwer/src/tlaplus/examples/specifications"; + "/mnt/data/ahelwer/src/tlaplus/proofs/library"; + "/mnt/data/ahelwer/src/tlaplus/proofs/examples"; + "/home/ahelwer/src/tlaplus/java-tools/tlatools/org.lamport.tlatools/test/tla2sany/semantic/corpus"; ] |> List.map find_tla_files |> List.flatten |> List.filter should_run (*|> _start_at "paxos/Paxos.tla"*) diff --git a/test/semantics/Test.tla b/test/semantics/Test.tla index 896f7532..a6128767 100644 --- a/test/semantics/Test.tla +++ b/test/semantics/Test.tla @@ -1,4 +1,5 @@ ---- MODULE Test ---- EXTENDS Naturals +op == 1 + 2 ==== diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 84ab77f6..0459fa1d 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -1,21 +1,24 @@ -open Tlapm_lib;; -open Tlapm_lib__Util;; -let _ = - let filename = "Test.tla" in - let file_channel = open_in filename in - let content = In_channel.input_all file_channel in - close_in file_channel; - match modctx_of_string - ~content - ~filename - ~loader_paths:[] - ~prefer_stdlib:true +let parse_tla_file filename = + let open Tlapm_lib in + let open Stdlib in + let open Tlapm_lib__Sany in + let open Tlapm_lib__Params in + parser_backend := Sany; + add_debug_flag "sany"; + print_endline ("Parsing " ^ filename ^ " ..."); + try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with + | Error (_, msg) -> failwith msg + | Ok _ -> print_endline (filename ^ " success") with - | Ok (mcx, _mule) -> - Coll.Sm.iter (fun modname _modtree -> print_endline modname) mcx; - | Error (Some msg, msg2) -> - print_endline msg; - print_endline msg2; - | Error (None, msg) -> - print_endline msg; \ No newline at end of file + | Unsupported_language_feature (location, RecursiveOperator) -> + (* This is okay, we just don't support recursive operators *) + Printf.eprintf "%s:\nUnsupported recursive operator at %s\n" filename (Loc.string_of_locus (Option.get location)) + | Unsupported_language_feature (location, Subexpression) -> + (* This is okay, we just don't support subexpressions *) + Printf.eprintf "%s:\nUnsupported subexpression at %s\n" filename (Loc.string_of_locus (Option.get location)) + | Failure (e : string) -> + Printf.eprintf "%s\n" e; + failwith filename + +let _ = parse_tla_file "Test.tla" From 4e7e2f2f44a9c2374bb07a6f950be208f7a2004a Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 13 Mar 2026 12:12:35 -0700 Subject: [PATCH 77/85] Fix sany_tests, start work on semantic test escalation Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 5 +++-- src/tlapm_lib.ml | 4 +--- test/sany/sany_tests.ml | 3 +-- 3 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 8d1b9915..30be9bae 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -421,6 +421,7 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = name = noprops mule.name; extendees = List.map (fun name -> noprops name) mule.extends; instancees = []; (* TODO: collate list of instancees from units *) + (* Filter map to skip all operators which were inlined during import. *) body = List.filter_map convert_entry mule.units; defdepth = 0; stage = Parsed; @@ -1007,8 +1008,7 @@ and convert_expression (expr : Xml.expression) : Expr.T.expr = | TheoremDefRef uid -> todo "Expression" "TheoremDefRef" None | AssumeDefRef uid -> todo "Expression" "AssumeDefRef" None -(** Converts LAMBDA x : x + 1 type operators, which can only appear as - parameters to other operators. +(** Converts LAMBDA x : x + 1 type operators. *) and convert_lambda (op : Xml.user_defined_op_kind) : Expr.T.expr = Lambda ( @@ -1069,6 +1069,7 @@ and convert_user_defined_op_kind (op : Xml.user_defined_op_kind) : Expr.T.defn = was defined in a different module, return None. *) and convert_unit_user_defined_op_kind (xml: Xml.user_defined_op_kind) (enclosing_module_name : string) : Module.T.modunit option = + (* TODO: this comparison does not work for nested modules, since location.filename uses enclosing module name. *) if (Option.get xml.node.location).filename <> enclosing_module_name then None else match xml.recursive with | true -> raise (Unsupported_language_feature (Option.map convert_location xml.node.location, RecursiveOperator)) diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index dbefe27c..f665d2c7 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -544,15 +544,13 @@ let setup_loader fs loader_paths = let loader_paths = List.fold_left add_if_new loader_paths fs in Loader.Global.setup loader_paths -let sany_modctx_of_string filename = (* +let sany_modctx_of_string filename = let transform (ctx, mule : modctx * Module.T.mule) : (modctx * Module.T.mule, string option * string) result = Params.input_files := [Filename.basename filename]; Params.set_search_path [Filename.basename filename]; let (mule, _) = let open Module.Flatten in flatten ctx mule Ss.empty in let (ctx, m, _summ) = Module.Elab.normalize ctx Deque.empty mule in Ok (ctx, m) in Result.bind (Sany.parse filename) transform - *) - Sany.parse filename let main fs = match !Params.parser_backend, fs with diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 4af87967..18fd7795 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -36,10 +36,9 @@ let _start_at (filename : string) (files : string list) : string list = in drop_until files let parse_tla_file filename = - let open Stdlib in let open Tlapm_lib__Sany in print_endline ("Parsing " ^ filename ^ " ..."); - try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with + try match parse filename with | Error (_, msg) -> failwith msg | Ok _ -> print_endline (filename ^ " success") with From 38f024b7373947509940e3c35d341db93ef104f6 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Mon, 16 Mar 2026 16:54:24 -0700 Subject: [PATCH 78/85] Semantic test framework Signed-off-by: Andrew Helwer --- test/sany/sany_tests.ml | 5 ++--- test/semantics/A_ConstantRef.tla | 4 ++++ test/semantics/Test.tla | 5 ----- test/semantics/dune | 2 +- test/semantics/semantic_tests.ml | 21 +++++++++++++-------- 5 files changed, 20 insertions(+), 17 deletions(-) create mode 100644 test/semantics/A_ConstantRef.tla delete mode 100644 test/semantics/Test.tla diff --git a/test/sany/sany_tests.ml b/test/sany/sany_tests.ml index 18fd7795..cc6a96f1 100644 --- a/test/sany/sany_tests.ml +++ b/test/sany/sany_tests.ml @@ -1,6 +1,3 @@ -open Tlapm_lib;; -open Tlapm_lib__Params;; - let find_tla_files dir = let cmd = Printf.sprintf "find %s -name '*.tla'" (Filename.quote dir) in let ic = Unix.open_process_in cmd in @@ -36,6 +33,7 @@ let _start_at (filename : string) (files : string list) : string list = in drop_until files let parse_tla_file filename = + let open Tlapm_lib in let open Tlapm_lib__Sany in print_endline ("Parsing " ^ filename ^ " ..."); try match parse filename with @@ -53,6 +51,7 @@ let parse_tla_file filename = failwith filename*) let _ = + let open Tlapm_lib__Params in parser_backend := Sany; module_jar_paths := [ "/mnt/data/ahelwer/src/tlaplus/examples/deps/apalache/lib/apalache.jar"; diff --git a/test/semantics/A_ConstantRef.tla b/test/semantics/A_ConstantRef.tla new file mode 100644 index 00000000..c1ec55b0 --- /dev/null +++ b/test/semantics/A_ConstantRef.tla @@ -0,0 +1,4 @@ +---- MODULE A_ConstantRef ---- +CONSTANT C +op == C +==== diff --git a/test/semantics/Test.tla b/test/semantics/Test.tla deleted file mode 100644 index a6128767..00000000 --- a/test/semantics/Test.tla +++ /dev/null @@ -1,5 +0,0 @@ ----- MODULE Test ---- -EXTENDS Naturals -op == 1 + 2 -==== - diff --git a/test/semantics/dune b/test/semantics/dune index 33fe921a..f09834a9 100644 --- a/test/semantics/dune +++ b/test/semantics/dune @@ -2,6 +2,6 @@ (name semantic_tests) (modes exe) (libraries tlapm_lib ounit2) - (deps Test.tla) + (deps (glob_files *.tla)) (preprocess (pps ppx_deriving.show)) ) diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 0459fa1d..4fa5dc45 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -1,8 +1,19 @@ +let find_tla_files dir = + let cmd = Printf.sprintf "find %s -name '*.tla'" (Filename.quote dir) in + let ic = Unix.open_process_in cmd in + let rec loop acc = + match input_line ic with + | line -> loop (line :: acc) + | exception End_of_file -> + ignore (Unix.close_process_in ic); + List.rev acc + in + loop [] + let parse_tla_file filename = let open Tlapm_lib in let open Stdlib in - let open Tlapm_lib__Sany in let open Tlapm_lib__Params in parser_backend := Sany; add_debug_flag "sany"; @@ -11,14 +22,8 @@ let parse_tla_file filename = | Error (_, msg) -> failwith msg | Ok _ -> print_endline (filename ^ " success") with - | Unsupported_language_feature (location, RecursiveOperator) -> - (* This is okay, we just don't support recursive operators *) - Printf.eprintf "%s:\nUnsupported recursive operator at %s\n" filename (Loc.string_of_locus (Option.get location)) - | Unsupported_language_feature (location, Subexpression) -> - (* This is okay, we just don't support subexpressions *) - Printf.eprintf "%s:\nUnsupported subexpression at %s\n" filename (Loc.string_of_locus (Option.get location)) | Failure (e : string) -> Printf.eprintf "%s\n" e; failwith filename -let _ = parse_tla_file "Test.tla" +let _ = "." |> find_tla_files |> List.map parse_tla_file From 4d3647d9283ab27e329e604d800202b096444eb3 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 20 Mar 2026 12:31:55 -0700 Subject: [PATCH 79/85] Adding semantic tests Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 4 +-- test/semantics/0_ConstantRefTest.tla | 4 +++ test/semantics/1_VariableRefTest.tla | 4 +++ test/semantics/2_OperatorRefTest.tla | 4 +++ test/semantics/3_AssumeRefTest.tla | 4 +++ test/semantics/A_ConstantRef.tla | 4 --- test/semantics/semantic_tests.ml | 41 ++++++++++++++++++++-------- 7 files changed, 48 insertions(+), 17 deletions(-) create mode 100644 test/semantics/0_ConstantRefTest.tla create mode 100644 test/semantics/1_VariableRefTest.tla create mode 100644 test/semantics/2_OperatorRefTest.tla create mode 100644 test/semantics/3_AssumeRefTest.tla delete mode 100644 test/semantics/A_ConstantRef.tla diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 30be9bae..b4e15c86 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1357,10 +1357,10 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string let mule : Xml.module_node = resolve_module_node toplevel_node mule_ref in match Coll.Sm.find_opt mule.name Module.Standard.initctx with | Some std_mule -> - print_endline ("Using built-in standard module " ^ mule.name); + if Params.debugging "sany" then print_endline ("Using built-in standard module " ^ mule.name) else (); Coll.Sm.add mule.name std_mule map | None -> - print_endline ("Converting parsed module " ^ mule.name); + if Params.debugging "sany" then print_endline ("Converting parsed module " ^ mule.name) else (); Coll.Sm.add mule.name (convert_module_node mule) map ) Coll.Sm.empty diff --git a/test/semantics/0_ConstantRefTest.tla b/test/semantics/0_ConstantRefTest.tla new file mode 100644 index 00000000..85601358 --- /dev/null +++ b/test/semantics/0_ConstantRefTest.tla @@ -0,0 +1,4 @@ +---- MODULE 0_ConstantRefTest ---- +CONSTANTS x, y, z +op == <> +==== diff --git a/test/semantics/1_VariableRefTest.tla b/test/semantics/1_VariableRefTest.tla new file mode 100644 index 00000000..6000e235 --- /dev/null +++ b/test/semantics/1_VariableRefTest.tla @@ -0,0 +1,4 @@ +---- MODULE 1_VariableRefTest ---- +VARIABLES x, y, z +op == <> +==== diff --git a/test/semantics/2_OperatorRefTest.tla b/test/semantics/2_OperatorRefTest.tla new file mode 100644 index 00000000..afc0d918 --- /dev/null +++ b/test/semantics/2_OperatorRefTest.tla @@ -0,0 +1,4 @@ +---- MODULE 2_OperatorRefTest ---- +op == 0 +op2 == op +==== diff --git a/test/semantics/3_AssumeRefTest.tla b/test/semantics/3_AssumeRefTest.tla new file mode 100644 index 00000000..2518dcdf --- /dev/null +++ b/test/semantics/3_AssumeRefTest.tla @@ -0,0 +1,4 @@ +---- MODULE 3_AssumeRefTest ---- +ASSUME P == TRUE +op == P +==== \ No newline at end of file diff --git a/test/semantics/A_ConstantRef.tla b/test/semantics/A_ConstantRef.tla deleted file mode 100644 index c1ec55b0..00000000 --- a/test/semantics/A_ConstantRef.tla +++ /dev/null @@ -1,4 +0,0 @@ ----- MODULE A_ConstantRef ---- -CONSTANT C -op == C -==== diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 4fa5dc45..9a7f5b68 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -1,6 +1,6 @@ let find_tla_files dir = - let cmd = Printf.sprintf "find %s -name '*.tla'" (Filename.quote dir) in + let cmd = Printf.sprintf "find %s -name '*Test.tla'" (Filename.quote dir) in let ic = Unix.open_process_in cmd in let rec loop acc = match input_line ic with @@ -11,19 +11,38 @@ let find_tla_files dir = in loop [] -let parse_tla_file filename = +open OUnit2;; + +let run_test (filename : string) (_ctx: test_ctxt) : unit = let open Tlapm_lib in let open Stdlib in let open Tlapm_lib__Params in + (*add_debug_flag "sany";*) + let ic = open_in filename in + let content = really_input_string ic (in_channel_length ic) in + close_in ic; + let check_tlapm (loc, msg) = + parser_backend := Tlapm; + match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with + | Error (_, _) -> Printf.eprintf "WARNING: Both SANY and TLAPM failed" + | Ok _ -> assert_failure (Printf.sprintf "SANY failed, but TLAPM succeeded\n%s\n%s" msg (Option.value ~default:"" loc)) + in parser_backend := Sany; - add_debug_flag "sany"; - print_endline ("Parsing " ^ filename ^ " ..."); - try match modctx_of_string ~content:"" ~filename ~loader_paths:[] ~prefer_stdlib:true with - | Error (_, msg) -> failwith msg - | Ok _ -> print_endline (filename ^ " success") + try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with + | Error msg -> check_tlapm msg + | Ok _ -> () with - | Failure (e : string) -> - Printf.eprintf "%s\n" e; - failwith filename + | Failure (msg : string) -> check_tlapm (None, msg) + + +let mk_test (filepath : string) : test = + Filename.basename filepath >:: (run_test filepath) + +let tests = "SANY semantic escalation tests" >::: ( + find_tla_files "." + |> List.sort String.compare + |> List.map mk_test +) -let _ = "." |> find_tla_files |> List.map parse_tla_file +(** The OUnit2 test entrypoint. *) +let () = run_test_tt_main tests From f85040687a523a31ffd2b9ebbf656d3d47275fd3 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 20 Mar 2026 17:05:20 -0700 Subject: [PATCH 80/85] Promote s-expression conversion code from test to library Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 7 +++ src/sany/sany.mli | 5 +- .../sany}/translate_syntax_tree.ml | 5 +- src/tlapm_lib.ml | 9 ++-- test/parser/parser_tests.ml | 4 +- test/semantics/dune | 2 +- test/semantics/semantic_tests.ml | 49 +++++++++++++------ 7 files changed, 58 insertions(+), 23 deletions(-) rename {test/parser => src/sany}/translate_syntax_tree.ml (99%) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index b4e15c86..b39eb7e8 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1377,3 +1377,10 @@ let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string opt Option.to_result ~none:(None, "TLAPS standard library cannot be found") Params.stdlib_path >>= (Xml.get_module_ast_xml module_path) >>= convert_ast + +open Sexplib;; + +let module_to_sexp (mule : Module.T.mule) : Sexp.t = + mule + |> Translate_syntax_tree.translate_tla_source_file + |> Translate_syntax_tree.ts_node_to_sexpr diff --git a/src/sany/sany.mli b/src/sany/sany.mli index 7a9ce095..a76a847a 100644 --- a/src/sany/sany.mli +++ b/src/sany/sany.mli @@ -11,4 +11,7 @@ type conversion_failure_kind = exception Conversion_failure of conversion_failure_kind * string option * string -val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result \ No newline at end of file +val parse : string -> (Module.T.modctx * Module.T.mule, string option * string) result + +open Sexplib;; +val module_to_sexp : Module.T.mule -> Sexp.t diff --git a/test/parser/translate_syntax_tree.ml b/src/sany/translate_syntax_tree.ml similarity index 99% rename from test/parser/translate_syntax_tree.ml rename to src/sany/translate_syntax_tree.ml index e244d436..c6f7908a 100644 --- a/test/parser/translate_syntax_tree.ml +++ b/src/sany/translate_syntax_tree.ml @@ -4,7 +4,10 @@ *) open Sexplib;; -open Tlapm_lib;; +open Module.T;; +open Expr.T;; +open Proof.T;; +open Util;; type field_or_node = | Field of string * ts_node diff --git a/src/tlapm_lib.ml b/src/tlapm_lib.ml index f665d2c7..1fc61c12 100644 --- a/src/tlapm_lib.ml +++ b/src/tlapm_lib.ml @@ -673,8 +673,11 @@ let modctx_of_string ~(content : string) ~(filename : string) ~loader_paths ~pre | Sany -> sany_modctx_of_string filename let module_of_string module_str = - let hparse = Tla_parser.P.use Module.Parser.parse in - let (flex, _) = Alexer.lex_string module_str in - Tla_parser.P.run hparse ~init:Tla_parser.init ~source:flex + match !Params.parser_backend with + | Tlapm -> + let hparse = Tla_parser.P.use Module.Parser.parse in + let (flex, _) = Alexer.lex_string module_str in + Tla_parser.P.run hparse ~init:Tla_parser.init ~source:flex + | Sany -> failwith "SANY cannot parse modules from a string" let stdlib_search_paths = Params.stdlib_search_paths diff --git a/test/parser/parser_tests.ml b/test/parser/parser_tests.ml index 44439d92..5ebf535e 100644 --- a/test/parser/parser_tests.ml +++ b/test/parser/parser_tests.ml @@ -153,9 +153,9 @@ let tests = "Standardized syntax test corpus" >::: ( | None -> assert_bool "Expected parse success" (expect_parse_failure test) | Some tlapm_output -> skip_if (should_skip_tree_comparison test) "Skipping parse tree comparison"; - let open Translate_syntax_tree in + let open Tlapm_lib__Sany in let open Sexplib in - let actual = tlapm_output |> translate_tla_source_file |> ts_node_to_sexpr in + let actual = module_to_sexp tlapm_output in if Sexp.equal expected actual then assert_bool "Expected parse test to fail" (not (expect_tree_comparison_failure test)) else diff --git a/test/semantics/dune b/test/semantics/dune index f09834a9..0fd77a68 100644 --- a/test/semantics/dune +++ b/test/semantics/dune @@ -1,7 +1,7 @@ (test (name semantic_tests) (modes exe) - (libraries tlapm_lib ounit2) + (libraries tlapm_lib ounit2 sexp_diff) (deps (glob_files *.tla)) (preprocess (pps ppx_deriving.show)) ) diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 9a7f5b68..7348c70a 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -11,29 +11,48 @@ let find_tla_files dir = in loop [] +let read_file (filepath : string) : string = + let ic = open_in filepath in + let content = really_input_string ic (in_channel_length ic) in + close_in ic; + content + open OUnit2;; +open Tlapm_lib;; +open Stdlib;; +open Tlapm_lib__Params;; +open Tlapm_lib__Sany;; + +let compare_syntax_trees (filepath : string) (source_code : string) : unit = + parser_backend := Tlapm; + match module_of_string source_code with + | None -> assert_failure "TLAPM failed to parse the test input" + | Some tlapm_mule -> + parser_backend := Sany; + match parse filepath with + | Error _ -> assert_failure "SANY failed to parse the test input" + | Ok (_, sany_mule) -> + let open Sexplib in + let tlapm_tree = module_to_sexp tlapm_mule in + let sany_tree = module_to_sexp sany_mule in + if Sexp.equal tlapm_tree sany_tree + then () + else + let open Sexp_diff in + let diff = Algo.diff ~original:tlapm_tree ~updated:sany_tree () in + let options = Display.Display_options.(create Layout.Single_column) in + let text = Display.display_with_ansi_colors options diff in + assert_failure (Printf.sprintf "Parse trees differ:\n%s" text) let run_test (filename : string) (_ctx: test_ctxt) : unit = - let open Tlapm_lib in - let open Stdlib in - let open Tlapm_lib__Params in (*add_debug_flag "sany";*) - let ic = open_in filename in - let content = really_input_string ic (in_channel_length ic) in - close_in ic; - let check_tlapm (loc, msg) = - parser_backend := Tlapm; - match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with - | Error (_, _) -> Printf.eprintf "WARNING: Both SANY and TLAPM failed" - | Ok _ -> assert_failure (Printf.sprintf "SANY failed, but TLAPM succeeded\n%s\n%s" msg (Option.value ~default:"" loc)) - in + let content = read_file filename in parser_backend := Sany; try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with - | Error msg -> check_tlapm msg + | Error _ -> compare_syntax_trees filename content | Ok _ -> () with - | Failure (msg : string) -> check_tlapm (None, msg) - + | Failure _ -> compare_syntax_trees filename content let mk_test (filepath : string) : test = Filename.basename filepath >:: (run_test filepath) From 4a009d7cfc06c89c95631e0f32b47468b6e285f4 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 24 Mar 2026 13:06:06 -0700 Subject: [PATCH 81/85] Order unit-level definitions by position in file Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index b39eb7e8..01bfe4e0 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -417,12 +417,25 @@ and convert_module_node (mule : Xml.module_node) : Module.T.mule = | FormalParamNode _ -> conversion_failure "FormalParamNode not expected at module top-level" None | AssumeDefNode assume -> conversion_failure "AssumeDefNode should not be converted directly" None | TheoremDefNode theorem_def_node -> conversion_failure "TheoremDefNode should not be converted directly" None + (** Returns 0 if equal, positive if first is greater, negative if second is + greater; This is used to sort units in increasing order, where order is + given by the unit definition's position in the file. This function is + necessary because the XML Exporter does not provide unit definitions in + the same order as they appear in the file. + *) + in let order_unit (first : Module.T.modunit) (second : Module.T.modunit) : int = + let first_loc = Util.get_locus first in + let first_line_start, first_col_start = Loc.line first_loc.start, Loc.column first_loc.start in + let second_loc = Util.get_locus second in + let second_line_start, second_col_start = Loc.line second_loc.start, Loc.column second_loc.start in + let line_order = first_line_start - second_line_start + in if line_order <> 0 then line_order else first_col_start - second_col_start in { name = noprops mule.name; extendees = List.map (fun name -> noprops name) mule.extends; instancees = []; (* TODO: collate list of instancees from units *) (* Filter map to skip all operators which were inlined during import. *) - body = List.filter_map convert_entry mule.units; + body = mule.units |> List.filter_map convert_entry |> List.sort order_unit; defdepth = 0; stage = Parsed; important = false @@ -1370,7 +1383,14 @@ let convert_ast (ast : Xml.modules) : (Module.T.modctx * Module.T.mule, (string Ok (ctx, root_module) (** Calls SANY to parse the given module, then converts SANY's AST into the - TLAPM AST format. + TLAPM AST forma +This was, in retrospect, a huge mistake. + +The AI tokens cost more than the salaries.I spend more time maintaining AI agents than I ever spent managing the humans. Yet the performance is worse. + +But everyone on Linkedin was doing it and I didn't want to feel left out. + +I told myself this was the future. I just needed better prompts. Rome wasn't t. *) let parse (module_path : string) : (Module.T.modctx * Module.T.mule, (string option * string)) result = let ( >>= ) = Result.bind in From b1830f6a7cb63fe7f8e1f685c9b801a5193c36f0 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Tue, 24 Mar 2026 17:25:05 -0700 Subject: [PATCH 82/85] Fixed conversion of 0-arity builtins Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 8 ++++++-- test/semantics/0_ConstantRefTest.tla | 4 +++- test/semantics/1_VariableRefTest.tla | 4 +++- test/semantics/semantic_tests.ml | 2 +- 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 01bfe4e0..b2850ab9 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -308,9 +308,12 @@ let rec convert_built_in_op_appl (apply : Xml.op_appl_node) (op : Xml.built_in_k different from the set that SANY consideres "built-in"; this function constructs operators for the TLAPM built-in operator set. *) - let mk (builtin : Builtin.builtin) : Expr.T.expr = Apply ( + let mk (builtin : Builtin.builtin) : Expr.T.expr = + match apply.operands with + | [] -> Internal builtin |> attach_props apply.node + | args -> Apply ( Internal builtin |> attach_props op.node, - apply.operands |> as_expr_ls (Builtin.builtin_to_string builtin) apply.node.location |> List.map convert_expression + args |> as_expr_ls (Builtin.builtin_to_string builtin) apply.node.location |> List.map convert_expression ) |> attach_props apply.node in match op.operator with (* Reserved words *) @@ -914,6 +917,7 @@ and convert_definition_reference (node : Xml.node) (name : string) (op_or_apply | [component] -> ( match op_or_apply with | `Op -> Opaque name |> attach_props node + | `Apply [] -> Opaque name |> attach_props node | `Apply args -> Apply ( Opaque name |> attach_props node, List.map (convert_expression_or_operator_argument node) args diff --git a/test/semantics/0_ConstantRefTest.tla b/test/semantics/0_ConstantRefTest.tla index 85601358..fb0a5b56 100644 --- a/test/semantics/0_ConstantRefTest.tla +++ b/test/semantics/0_ConstantRefTest.tla @@ -1,4 +1,6 @@ ---- MODULE 0_ConstantRefTest ---- -CONSTANTS x, y, z +CONSTANT x +CONSTANT y +CONSTANT z op == <> ==== diff --git a/test/semantics/1_VariableRefTest.tla b/test/semantics/1_VariableRefTest.tla index 6000e235..a4afc86e 100644 --- a/test/semantics/1_VariableRefTest.tla +++ b/test/semantics/1_VariableRefTest.tla @@ -1,4 +1,6 @@ ---- MODULE 1_VariableRefTest ---- -VARIABLES x, y, z +VARIABLE x +VARIABLE y +VARIABLE z op == <> ==== diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 7348c70a..1b613d48 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -50,7 +50,7 @@ let run_test (filename : string) (_ctx: test_ctxt) : unit = parser_backend := Sany; try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with | Error _ -> compare_syntax_trees filename content - | Ok _ -> () + | Ok _ -> compare_syntax_trees filename content with | Failure _ -> compare_syntax_trees filename content From ae1597d3955e241690c3e5617d889d0c01424f01 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Wed, 25 Mar 2026 12:33:22 -0700 Subject: [PATCH 83/85] Validated basic theorem translation Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 10 +++++----- test/semantics/0_ConstantRefTest.tla | 2 +- test/semantics/1_VariableRefTest.tla | 2 +- test/semantics/4_TheoremRefTest.tla | 4 ++++ test/semantics/semantic_tests.ml | 15 +++++++++------ 5 files changed, 20 insertions(+), 13 deletions(-) create mode 100644 test/semantics/4_TheoremRefTest.tla diff --git a/src/sany/sany.ml b/src/sany/sany.ml index b2850ab9..927e9121 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1114,7 +1114,7 @@ and convert_theorem_def_node (theorem_def_node : Xml.theorem_def_node) : Module. unchanged for error message purposes. *) and convert_theorem_node (uid : int) (previous_proof_level : int) (thm : Xml.theorem_node) : Module.T.modunit = - let proof = convert_proof uid previous_proof_level thm.proof in + let proof = convert_proof thm.node uid previous_proof_level thm.proof in Theorem ( Option.map (fun uid -> let def = resolve_theorem_def_node thm.node uid in attach_props def.node def.name) thm.definition, convert_sequent thm.body, @@ -1188,10 +1188,10 @@ and convert_label (label : Xml.label_node) : Expr.T.expr = ( meaningless but is required by subsequent TLAPM processing. Thus we just attach the incremented previous proof level and the reference UID. *) -and convert_proof (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group option) : Proof.T.proof = +and convert_proof (enclosing_thm : Xml.node) (uid : int) (previous_proof_level : int) (proof : Xml.proof_node_group option) : Proof.T.proof = let proof_name = Unnamed (previous_proof_level + 1, uid) in match proof with - | None -> Omitted Implicit |> noprops |> attach_proof_step_name proof_name + | None -> Omitted Implicit |> attach_props enclosing_thm |> attach_proof_step_name proof_name | Some Omitted node -> Omitted Explicit |> attach_props node |> attach_proof_step_name proof_name | Some Obvious node -> Obvious |> attach_props node |> attach_proof_step_name proof_name | Some By proof -> convert_by_proof proof |> attach_proof_step_name proof_name @@ -1234,7 +1234,7 @@ and convert_proof_steps (uid : int) ({node; proof_level; steps} : Xml.steps_proo | TheoremNodeRef uid -> let thm = resolve_theorem_node node uid in let step_name = convert_proof_step_name node uid proof_level thm.definition in - Qed (convert_proof uid (step_number step_name) thm.proof) |> attach_props thm.node + Qed (convert_proof thm.node uid (step_number step_name) thm.proof) |> attach_props thm.node |> attach_proof_step_name step_name | _ -> conversion_failure "QED step must be a theorem node" node.location in let steps, qed = split_last_ls node steps @@ -1264,7 +1264,7 @@ and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_s | TheoremNodeRef uid -> let thm = resolve_theorem_node node uid in let step_name = convert_proof_step_name node uid proof_level thm.definition in - let proof = convert_proof uid (step_number step_name) thm.proof in + let proof = convert_proof thm.node uid (step_number step_name) thm.proof in let step = match thm.body with | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator CaseProofStep -> convert_case_proof_step apply proof diff --git a/test/semantics/0_ConstantRefTest.tla b/test/semantics/0_ConstantRefTest.tla index fb0a5b56..2196b20a 100644 --- a/test/semantics/0_ConstantRefTest.tla +++ b/test/semantics/0_ConstantRefTest.tla @@ -2,5 +2,5 @@ CONSTANT x CONSTANT y CONSTANT z -op == <> +op == <> ==== diff --git a/test/semantics/1_VariableRefTest.tla b/test/semantics/1_VariableRefTest.tla index a4afc86e..da51c41a 100644 --- a/test/semantics/1_VariableRefTest.tla +++ b/test/semantics/1_VariableRefTest.tla @@ -2,5 +2,5 @@ VARIABLE x VARIABLE y VARIABLE z -op == <> +op == <> ==== diff --git a/test/semantics/4_TheoremRefTest.tla b/test/semantics/4_TheoremRefTest.tla new file mode 100644 index 00000000..596424ac --- /dev/null +++ b/test/semantics/4_TheoremRefTest.tla @@ -0,0 +1,4 @@ +---- MODULE 4_TheoremRefTest ---- +THEOREM thm == TRUE +op == thm +==== \ No newline at end of file diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 1b613d48..9ad073d3 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -23,7 +23,7 @@ open Stdlib;; open Tlapm_lib__Params;; open Tlapm_lib__Sany;; -let compare_syntax_trees (filepath : string) (source_code : string) : unit = +let compare_syntax_trees (filepath : string) (source_code : string) (is_error : bool) : unit = parser_backend := Tlapm; match module_of_string source_code with | None -> assert_failure "TLAPM failed to parse the test input" @@ -36,23 +36,26 @@ let compare_syntax_trees (filepath : string) (source_code : string) : unit = let tlapm_tree = module_to_sexp tlapm_mule in let sany_tree = module_to_sexp sany_mule in if Sexp.equal tlapm_tree sany_tree - then () + then assert_bool "Syntax trees equivalent but SANY failed" (not is_error) else let open Sexp_diff in let diff = Algo.diff ~original:tlapm_tree ~updated:sany_tree () in let options = Display.Display_options.(create Layout.Single_column) in let text = Display.display_with_ansi_colors options diff in - assert_failure (Printf.sprintf "Parse trees differ:\n%s" text) + assert_failure ( + if is_error then (Printf.sprintf "SANY failed and parse trees differ:\n%s" text) + else (Printf.sprintf "SANY succeeded but parse trees differ:\n%s" text)) let run_test (filename : string) (_ctx: test_ctxt) : unit = (*add_debug_flag "sany";*) let content = read_file filename in parser_backend := Sany; try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with - | Error _ -> compare_syntax_trees filename content - | Ok _ -> compare_syntax_trees filename content + | Error _ -> compare_syntax_trees filename content true + | Ok _ -> compare_syntax_trees filename content false with - | Failure _ -> compare_syntax_trees filename content + | Failure _ -> compare_syntax_trees filename content true + | Not_found -> compare_syntax_trees filename content true let mk_test (filepath : string) : test = Filename.basename filepath >:: (run_test filepath) From a975b119b8dfa8e1c3e715fc4c34b84f487df92e Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Mar 2026 17:09:47 -0700 Subject: [PATCH 84/85] Tests for some proof types Signed-off-by: Andrew Helwer --- src/sany/sany.ml | 2 +- test/semantics/10_BasicStepProofTest.tla | 15 ++++++++ test/semantics/11_BasicAssumeProveTest.tla | 12 +++++++ test/semantics/12_BasicCaseStepProofTest.tla | 11 ++++++ test/semantics/5_ConstantOperatorTest.tla | 4 +++ test/semantics/6_OperatorParameterRefTest.tla | 3 ++ test/semantics/7_ExpressionTest.tla | 3 ++ test/semantics/8_ObviousProofTest.tla | 4 +++ test/semantics/9_BasicByProofTest.tla | 6 ++++ test/semantics/semantic_tests.ml | 36 +++++++++++++------ 10 files changed, 84 insertions(+), 12 deletions(-) create mode 100644 test/semantics/10_BasicStepProofTest.tla create mode 100644 test/semantics/11_BasicAssumeProveTest.tla create mode 100644 test/semantics/12_BasicCaseStepProofTest.tla create mode 100644 test/semantics/5_ConstantOperatorTest.tla create mode 100644 test/semantics/6_OperatorParameterRefTest.tla create mode 100644 test/semantics/7_ExpressionTest.tla create mode 100644 test/semantics/8_ObviousProofTest.tla create mode 100644 test/semantics/9_BasicByProofTest.tla diff --git a/src/sany/sany.ml b/src/sany/sany.ml index 927e9121..dd6f70d5 100644 --- a/src/sany/sany.ml +++ b/src/sany/sany.ml @@ -1263,7 +1263,7 @@ and convert_proof_step (node : Xml.node) (proof_level : int) (step : Xml.proof_s | UseOrHide use_or_hide -> Use (convert_usable use_or_hide, use_or_hide.only) |> attach_props use_or_hide.node | TheoremNodeRef uid -> let thm = resolve_theorem_node node uid in - let step_name = convert_proof_step_name node uid proof_level thm.definition in + let step_name = convert_proof_step_name thm.node uid proof_level thm.definition in let proof = convert_proof thm.node uid (step_number step_name) thm.proof in let step = match thm.body with | Expression OpApplNode ({operator} as apply) when is_builtin_op node operator CaseProofStep -> diff --git a/test/semantics/10_BasicStepProofTest.tla b/test/semantics/10_BasicStepProofTest.tla new file mode 100644 index 00000000..5e5d9606 --- /dev/null +++ b/test/semantics/10_BasicStepProofTest.tla @@ -0,0 +1,15 @@ +---- MODULE 10_BasicStepProofTest ---- +A == 0 +B == 0 +C == 0 +THEOREM AB == A = B +PROOF BY ONLY DEFS A, B +THEOREM BC == B = C +PROOF BY ONLY DEFS B, C +THEOREM AC == A = C +PROOF +<1>a AB +<1>b BC +<1>c QED + +==== \ No newline at end of file diff --git a/test/semantics/11_BasicAssumeProveTest.tla b/test/semantics/11_BasicAssumeProveTest.tla new file mode 100644 index 00000000..efaf9720 --- /dev/null +++ b/test/semantics/11_BasicAssumeProveTest.tla @@ -0,0 +1,12 @@ +---- MODULE 11_BasicAssumeProveTest ---- +THEOREM + ASSUME + NEW CONSTANT A, + NEW CONSTANT B, + NEW CONSTANT C + PROVE + /\ A = B + /\ B = C + => A = C +PROOF OBVIOUS +==== \ No newline at end of file diff --git a/test/semantics/12_BasicCaseStepProofTest.tla b/test/semantics/12_BasicCaseStepProofTest.tla new file mode 100644 index 00000000..c53b44bc --- /dev/null +++ b/test/semantics/12_BasicCaseStepProofTest.tla @@ -0,0 +1,11 @@ +---- MODULE 12_BasicCaseStepProofTest ---- +A == TRUE +B == TRUE +THEOREM A /\ B +PROOF +<1> CASE A + PROOF BY ONLY DEF A +<1> CASE B + PROOF BY ONLY DEF B +<1> QED +==== \ No newline at end of file diff --git a/test/semantics/5_ConstantOperatorTest.tla b/test/semantics/5_ConstantOperatorTest.tla new file mode 100644 index 00000000..f615df75 --- /dev/null +++ b/test/semantics/5_ConstantOperatorTest.tla @@ -0,0 +1,4 @@ +---- MODULE 5_ConstantOperatorTest ---- +CONSTANT F(_, _) +op == F(1, 2) +==== \ No newline at end of file diff --git a/test/semantics/6_OperatorParameterRefTest.tla b/test/semantics/6_OperatorParameterRefTest.tla new file mode 100644 index 00000000..a54b3a1d --- /dev/null +++ b/test/semantics/6_OperatorParameterRefTest.tla @@ -0,0 +1,3 @@ +---- MODULE 6_OperatorParameterRefTest ---- +op(x, y) == <> +==== \ No newline at end of file diff --git a/test/semantics/7_ExpressionTest.tla b/test/semantics/7_ExpressionTest.tla new file mode 100644 index 00000000..3ba54aee --- /dev/null +++ b/test/semantics/7_ExpressionTest.tla @@ -0,0 +1,3 @@ +---- MODULE 7_ExpressionTest ---- +ITE == IF TRUE THEN 1 ELSE 2 +==== \ No newline at end of file diff --git a/test/semantics/8_ObviousProofTest.tla b/test/semantics/8_ObviousProofTest.tla new file mode 100644 index 00000000..9618222d --- /dev/null +++ b/test/semantics/8_ObviousProofTest.tla @@ -0,0 +1,4 @@ +---- MODULE 8_ObviousProofTest ---- +THEOREM TRUE +PROOF OBVIOUS +==== \ No newline at end of file diff --git a/test/semantics/9_BasicByProofTest.tla b/test/semantics/9_BasicByProofTest.tla new file mode 100644 index 00000000..99f04c87 --- /dev/null +++ b/test/semantics/9_BasicByProofTest.tla @@ -0,0 +1,6 @@ +---- MODULE 9_BasicByProofTest ---- +A == 1 +B == 1 +THEOREM A = B +PROOF BY ONLY DEFS A, B +==== \ No newline at end of file diff --git a/test/semantics/semantic_tests.ml b/test/semantics/semantic_tests.ml index 9ad073d3..2b891958 100644 --- a/test/semantics/semantic_tests.ml +++ b/test/semantics/semantic_tests.ml @@ -25,12 +25,12 @@ open Tlapm_lib__Sany;; let compare_syntax_trees (filepath : string) (source_code : string) (is_error : bool) : unit = parser_backend := Tlapm; - match module_of_string source_code with - | None -> assert_failure "TLAPM failed to parse the test input" - | Some tlapm_mule -> + try match module_of_string source_code with + | None -> assert_failure "TLAPM failed to parse the test input syntax" + | Some tlapm_mule -> ( parser_backend := Sany; - match parse filepath with - | Error _ -> assert_failure "SANY failed to parse the test input" + try match parse filepath with + | Error _ -> assert_failure "SANY failed to parse the test input syntax" | Ok (_, sany_mule) -> let open Sexplib in let tlapm_tree = module_to_sexp tlapm_mule in @@ -45,17 +45,31 @@ let compare_syntax_trees (filepath : string) (source_code : string) (is_error : assert_failure ( if is_error then (Printf.sprintf "SANY failed and parse trees differ:\n%s" text) else (Printf.sprintf "SANY succeeded but parse trees differ:\n%s" text)) + with Failure _ -> assert_failure "SANY failed to parse the test input syntax" + ) with Failure _ -> assert_failure "TLAPM failed to parse the test input syntax" + +let check (filename : string) (content : string) : (unit, string) result = + try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with + | Error (_, msg) -> Error msg + | Ok _ -> Ok () + with Failure msg -> Error msg + +let check_in_tlapm : string -> string -> (unit, string) result = + parser_backend := Tlapm; + check + +let check_in_sany : string -> string -> (unit, string) result = + parser_backend := Sany; + check let run_test (filename : string) (_ctx: test_ctxt) : unit = (*add_debug_flag "sany";*) let content = read_file filename in - parser_backend := Sany; - try match modctx_of_string ~content ~filename ~loader_paths:[] ~prefer_stdlib:true with + match check_in_tlapm filename content with + | Error msg -> assert_failure ("TLAPM failed to parse the test input: " ^ msg) + | Ok () -> match check_in_sany filename content with | Error _ -> compare_syntax_trees filename content true - | Ok _ -> compare_syntax_trees filename content false - with - | Failure _ -> compare_syntax_trees filename content true - | Not_found -> compare_syntax_trees filename content true + | Ok () -> compare_syntax_trees filename content false let mk_test (filepath : string) : test = Filename.basename filepath >:: (run_test filepath) From 8c94caec261c3c810d00a47a7d1b4699f6511971 Mon Sep 17 00:00:00 2001 From: Andrew Helwer Date: Fri, 27 Mar 2026 17:22:36 -0700 Subject: [PATCH 85/85] Removed AddTwo Signed-off-by: Andrew Helwer --- AddTwoRenamed.tla | 30 ------------------------------ 1 file changed, 30 deletions(-) delete mode 100644 AddTwoRenamed.tla diff --git a/AddTwoRenamed.tla b/AddTwoRenamed.tla deleted file mode 100644 index d5c1385e..00000000 --- a/AddTwoRenamed.tla +++ /dev/null @@ -1,30 +0,0 @@ ------------------------------- MODULE AddTwo -------------------------------- -EXTENDS Naturals, TLAPS - -VARIABLE x - -vars == <> - -TypeOK == x \in Nat - -Init == x = 0 - -Next == x' = x + 2 - -Spec == Init /\ [][Next]_vars - -a|b == \E c \in Nat : a*c = b - -Even == 2|x - -THEOREM thm == Spec => []Even - <1>a. Init => Even - BY DEF Init, Even, | - <1>b. Even /\ UNCHANGED vars => Even' - BY DEF Even, vars - <1>c. Even /\ Next => Even' - BY \A c \in Nat : c+1 \in Nat /\ 2*(c+1) = 2*c + 2, Zenon - DEF TypeOK, Even, Next, | - <1> QED BY PTL, <1>a, <1>b, <1>c DEF Spec - -=============================================================================