From 52db5e4c40c190b2be36118f6e4bb2a9f2c51203 Mon Sep 17 00:00:00 2001 From: MM45 Date: Fri, 28 Nov 2025 17:17:56 +0100 Subject: [PATCH 01/26] Documentation comments and corresponding HTML generation. A comprehensive example covering most functionality and features can be found in `examples/docgen/docgenbasic.ec` In short, the command-line syntax is as follows: `easycrypt docgen [-outdir ] ` --- INSTALL.md | 3 + assets/.gitignore | 0 assets/styles/styles.css | 228 ++++++++++++++++++++ dune | 6 +- dune-project | 3 +- easycrypt.opam | 1 + examples/docgen/docgenbasic.ec | 320 ++++++++++++++++++++++++++++ src/dune | 2 +- src/ec.ml | 80 ++++++- src/ecCommands.ml | 106 ++++++---- src/ecCommands.mli | 7 +- src/ecDoc.ml | 338 ++++++++++++++++++++++++++++++ src/ecDoc.mli | 2 + src/ecIo.ml | 82 ++++++-- src/ecIo.mli | 3 +- src/ecLexer.mll | 23 +- src/ecOptions.ml | 26 +++ src/ecOptions.mli | 6 + src/ecParser.mly | 7 +- src/ecParsetree.ml | 9 + src/ecRelocate.ml | 8 +- src/ecRelocate.mli | 1 + src/ecScope.ml | 372 +++++++++++++++++++++++++++++---- src/ecScope.mli | 47 +++-- src/ecSection.ml | 4 +- src/ecSymbols.ml | 8 + src/ecSymbols.mli | 2 + src/ecTerminal.ml | 10 +- src/ecTerminal.mli | 2 +- 29 files changed, 1572 insertions(+), 134 deletions(-) create mode 100644 assets/.gitignore create mode 100644 assets/styles/styles.css create mode 100644 examples/docgen/docgenbasic.ec create mode 100644 src/ecDoc.ml create mode 100644 src/ecDoc.mli diff --git a/INSTALL.md b/INSTALL.md index a9808fe4fb..99a9a91de0 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -522,6 +522,9 @@ proceed to [install EasyCrypt from Source](#installing-easycrypt-from-source). - [OCaml ini-files](https://opam.ocaml.org/packages/ocaml-inifiles/) (version >= 1.2) Additional resources: - http://archive.ubuntu.com/ubuntu/pool/universe/o/ocaml-inifiles +- [OCaml Markdown](https://github.com/gildor478/ocaml-markdown) + Additional resources: + - https://opam.ocaml.org/packages/markdown - [Python3](https://www.python.org/downloads) You also need to install the following libraries: - [Python3 YAML](https://pyyaml.org/wiki/PyYAMLDocumentation) diff --git a/assets/.gitignore b/assets/.gitignore new file mode 100644 index 0000000000..e69de29bb2 diff --git a/assets/styles/styles.css b/assets/styles/styles.css new file mode 100644 index 0000000000..e3bdc9944f --- /dev/null +++ b/assets/styles/styles.css @@ -0,0 +1,228 @@ +/* General Styling */ +/* Body */ +body { + font-family: "-apple-system", "BlinkMacSystemFont", "Roboto", "Arial", sans-serif; + line-height: 1.2; + font-size: 16px; + margin: 0; + padding: 0; + color: #333; + background-color: #f9f9f9; +} + +/* Code blocks */ +pre { + font-family: "Fira Code", "Consolas", monospace; + font-size: 1rem; + padding: 5px; + border-radius: 1px; + color: #2d2d2d; + background-color: #ecf0f1; +} + +/* Inline code */ +code { + font-family: "Fira Code", "Consolas", monospace; + font-size: 1rem; + color: #d6336c; +} + +/* Headings */ +h1, h2, h3, h4, h5, h6 { + font-family: "Roboto", "Arial", sans-serif; + font-weight: 600; + color: #1a1a1a; + margin-bottom: 0.5em; +} + +h1 { + font-size: 2.25rem; +} +h2 { + font-size: 2rem; +} +h3 { + font-size: 1.75rem; +} +h4 { + font-size: 1.5rem; +} +h5 { + font-size: 1.25rem; +} +h6 { + font-size: 1rem; +} + +/* Links */ +a { + font-family: "Roboto", "Arial", sans-serif; + color: #007bff; + text-decoration: none; +} + +a:hover { + color: #0056b3; + text-decoration: underline; +} + +.serif-text { + font-family: "Times New Roman", "Times", serif; + font-size: 1rem; + color: #333; +} + +/* Specific styling */ + +/* Sidebar */ +.sidebar { + width: 200px; + background-color: #2c3e50; + color: #ecf0f1; + position: fixed; + height: 100%; + overflow: auto; +} + +.sidebar-title { + padding: 20px; + color: #ecf0f1; + background-color: #34495e; + margin-bottom: 20px; +} + +.sidebar-title h2 { + font-size: 1.5em; + margin-bottom: 5px; + color: #ecf0f1; +} + +.sidebar-title .sidebar-title-theory { + font-size: 1.2em; + color: #3498db; +} + +.sidebar-title-theory { + word-wrap: break-word; + overflow-wrap: break-word; + white-space: normal; +} + +.sidebar-elems { + padding: 20px; +} + +.sidebar-section-list { + list-style: none; + padding: 0; +} + +.sidebar-section-list li { + margin: 15px 0; +} + +.sidebar-section-list li a { + color: #ecf0f1; + font-weight: bold; +} + +/* Main content */ +main { + margin-left: 220px; + padding: 20px; + max-width: 960px; +} + +.page-heading-container { + border-bottom: 2px solid #ddd; + padding-bottom: 5px; + margin-bottom: 20px; +} + +.page-heading-container .page-heading { + margin-block-end: 5px; +} + +.page-heading-container .page-subheading { + margin-block-start: 0px; + margin-block-end: 5px; + font-size: 1.2em; +} + +/* Sections */ +.item-section { + margin-bottom: 40px; +} + +.section-heading { + color: #34495e; + border-bottom: 2px solid #ddd; + padding-bottom: 10px; + margin-bottom: 20px; +} + +/* Item lists */ +.item-list { + list-style: none; + padding: 0; +} + +.item-entry { + display: flex; + flex-direction: column; + margin-bottom: 20px; +} + +.item-name-desc-container { + display: flex; + align-items: flex-start; +} + +.item-name { + width: 200px; + font-weight: bold; + color: #2980b9; + white-space: normal; + overflow-wrap: break-word; +} + +.item-basic-desc { + flex: 1; + margin-left: 10px; +} + +.item-basic-desc p { + margin-top: 0px; +} + +.item-details { + margin-left: 210px; +} + +.item-details summary { + cursor: pointer; + color: #3498db; + font-weight: bold; +} + +.item-details summary:hover { + text-decoration: underline; +} + +.item-details-par { + margin-top: 10px; +} + +/* Source code */ +pre.source { + border: 2px solid #bdc3c7; + padding: 10px; + border-radius: 5px; + overflow-x: auto; + white-space: pre-wrap; +} + +/* Introduction section */ +.intro-section { + margin-bottom: 40px; +} diff --git a/dune b/dune index e19b69c5a5..7c8edf7096 100644 --- a/dune +++ b/dune @@ -1,9 +1,13 @@ -(dirs 3rdparty src etc theories examples scripts) +(dirs 3rdparty src etc theories examples assets scripts) (install (section (site (easycrypt commands))) (files (scripts/testing/runtest as runtest))) +(install + (section (site (easycrypt doc))) + (files (assets/styles/styles.css as styles.css))) + (install (section (bin)) (files (scripts/testing/bin-ec-runtest as ec-runtest))) diff --git a/dune-project b/dune-project index b285ee1756..85f142616e 100644 --- a/dune-project +++ b/dune-project @@ -10,7 +10,7 @@ (package (name easycrypt) - (sites (lib theories) (libexec commands) (lib config)) + (sites (lib theories) (libexec commands) (lib doc) (lib config)) (depends (ocaml (>= 4.08.0)) (batteries (>= 3)) @@ -19,6 +19,7 @@ dune dune-build-info dune-site + markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) yojson diff --git a/easycrypt.opam b/easycrypt.opam index 47ea3eb083..08bdb40eac 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -7,6 +7,7 @@ depends: [ "dune" {>= "3.13"} "dune-build-info" "dune-site" + "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} "yojson" diff --git a/examples/docgen/docgenbasic.ec b/examples/docgen/docgenbasic.ec new file mode 100644 index 0000000000..691efa23ec --- /dev/null +++ b/examples/docgen/docgenbasic.ec @@ -0,0 +1,320 @@ +(*^ + EasyCrypt_DocGen_Tutorial.ec + + To generate documentation for a source file, run the following command: + {{ + docgen [-outdir ] + }} + Here, `` is the path to the EasyCrypt executable on your + system, `` is the directory where the generated + documentation files will be stored, and `` is the path to the + source file you want to generate documentation for. You may omit the output + directory, in which case the tool defaults to the directory of the source file. + + This is a file documentation comment. In the generated documentation file, this + comment appears at the top. File documentation comments are typically used for + summaries, overviews, and meta-information about the file. +^*) + +(*^ + This is an additional file-documentation comment. In the generated + documentation, it is added as a paragraph below the (last paragraph of the) + previous file documentation comment. +^*) + +(* + Regular, non-documentation comments like this one are excluded from the + generated documentation file. +*) +require import FinType. + +(*& + This is a regular documentation comment, which is linked to the next + "documentable" item. In the generated documentation file, it appears as + documentation for the linked item. + + At the time of writing, the "documentable" items are: + - types, + - operators, + - axioms, + - lemmas, + - module types, + - modules, and + - theories. + + Note that "scoped" items (those specified with, e.g., `local` or `declare`) + are not "documentable", even if their "non-scoped" versions would be. + + This documentation comment is linked to `type t` below. +&*) +type t. + +(*& + It is not necessary to close a documentation comment with a matching closing + delimiter. Only the opening delimiter determines the type of comment. However, + it is good practice to use a matching closing delimiter. +*) +type u. + +(*& + Multiple documentation comments can be placed consecutively without any + "documentable" items in between. All of these comments are linked to the next + "documentable" item. However, starting with the second comment, each will be + hidden under an un-foldable "details" section, indicated by a clickable arrow. + Even if fewer than two documentation comments are linked to an item, this + "details" section always contains the source code for the item, except in the + case of (sub)theories. +&*) + +(*& + As an example, both the previous and this documentation comment are linked to + `type v` below. The first comment is shown by default, while this second one + is initially hidden, but can be revealed by unfolding the corresponding + "details" section. +&*) +type v. + +(*& + Documentation comments can be interleaved with non-documentation comments, + even before the item to which the documentation comments are linked. +&*) + +(* + This is a non-documentation comment between two documentation comments linked + to the same item. +*) + +(*& + Both the previous and this __documentation__ comment are correctly linked to + `type w` below, even though they are separated by a __non-documentation__ + comment. +&*) +type w. + +(*^ + File documentation comments can be placed anywhere in the file. Each comment + is added as a new paragraph below the previous one. However, it is + considered good practice to place file documentation comments at the + beginning of the file whenever possible. +^*) + +(*& + __Any__ comments nested inside documentation comments + are excluded from the generated documentation file. + (* This comment is excluded from the generated documentation file *) + (*& This comment is excluded from the generated documentation file &*) + (*^ This comment is excluded from the generated documentation file ^*) + However, anything outside these nested comments (but within + the documentation comment, of course) is included. +&*) +type x. + +(* + All "documentable" items are included in the generated documentation file, whether + or not they have a corresponding documentation comment. The source code + of each item is always included, though it is initially hidden under an + un-foldable "details" section. If there is no corresponding documentation + comment, a default message is shown, referring to the details section for the + source code. +*) +type y. + +(*& + All documentation comments can be + formatted using (a non-standard dialect of) Markdown. + The following is supported. + + As first non-blank character on a line (followed by a space): + - \! indicates a heading (one for largest heading, two for second-largest + heading, etc.); + - \*, \+, or \- indicate an item of an unordered list; + - \# indicates an item of an ordered list; and + - \> indicates (a line of) a blockquote. + + As delimiters: + - \{\{ and \}\} delimit a code block (both the delimiters and content should be + on separate lines); + - \` delimits inline code (e.g., `inline code`); + - \* delimits bold text (e.g., *bold text* ); and + - \__ delimits emphasized text (e.g., __emph text__). + + Any special characters can be escaped with a backslash (e.g., \`). + + Hyperlinks are formatted as `[]()` + (e.g., [EasyCrypt GitHub repository](https://github.com/EasyCrypt/easycrypt)). +&*) +type z. + +(*& + It is possible to link to other documented items *within + the theory's scope* (i.e., items defined in the file itself or + imported from other theories). The syntax is similar to + that for hyperlinks: `[](>|)`, + Here, `` is one of the following: + - `Ty` (or `Type`), + - `Op` (or `Operator`), + - `Ax` (or `Axiom`), + - `Lem` (or `Lemma`), + - `ModTy` (or `ModuleType`), + - `Mod` (or `Module`), and + - `Th` (or `Theory`). + + `` is the name of the item as you would print it in the theory + itself. Particularly, this means that the name may need to be qualified, + depending on the imports in the theory. For example, `[go to type t above](>Ty|t)` + becomes [go to type t above](>Ty|t). However, `[go to operator t below](>Op|t)` + becomes [go to operator t below](>Op|t). (Note that, even though the linked + type and operator are both referred to with the same name, the correct item is + linked due to the specification of the item kind.) + + If you omit ``, the documentation tool checks each item kind in the + order listed above for the given `` and links to the first match. + E.g., instead of `[go to type t above](>Ty|t)`, you can use `[go to type t + above](>|t)` (proof: [go to type t above](>|t)). However, you still need + to explicitly specify the `Op` kind for operator `t` below, because the + documentation tool checks the `Type` kind before the `Operator` kind, which + already results in a match. +&*) +op f : u -> v. + +(*& This is a documented operator &*) +op t : v -> w. + +(*& + The generated documentation file contains a section for each item kind. Within each + section, items are displayed in the order they appear in the source. +&*) +axiom ax : true. + +(*& + If there are no items of a certain kind, + the generated documentation file does not contain a section for that kind. + For example, the generated documentation file for this theory does not + contain a section for module types. + + The navigation bar on the left-hand side of the generated documentation file + shows only the sections that are present and provides links to them + for convenience. +&*) +lemma lem : true. +proof. by trivial. qed. + +(*& + Currently, individual procedures inside of modules (and module types) cannot + be documented using documentation comments. For the time being, a + (unsatisfactory) workaround is to use regular comments within the module (or + module type), which appear in the source code for the module (or module type) + in the generated documentation file. +&*) +module M = { + (* + This regular comment appears in the source code + for this module in the generated documentation file. + *) + proc p() : int = { + return 1; + } +}. + +(*& + Theories are special as "documentable" items. They appear as documented items + in the generated documentation file for their parent theory __and__ + receive their own documentation file, in turn documenting all their + "documentable" items. This file has a subheading indicating the subtheory and + links to entry of the (sub)theory in the parent theory's documentation file. + + The file name for a (sub)theory follows this pattern: `Y!Z`, where `Y`, and + `Z` represent the parent theory and (sub)theory, respectively. (This works + recursively: `Y` may itself be a (sub)theory of another theory `X`, in which + case the file name becomes `X!Y!Z`.) + + The "introductory text" for the (sub)theory, which you would usually put in + file documentation comments, is drawn from the regular documentation comments + in the parent theory. In the parent theory's documentation file, the + (sub)theory's name links to the corresponding (sub)theory documentation file. + + No source code is shown for subtheories in the parent theory's documentation + file. +&*) +theory T. + +(*& + This item is documented in the documentation file corresponding to + (sub)theory `T'. +&*) +type s. + +(*& + Linking to items is done from the perspective of the outermost theory (`Top`), + so names for items within (sub)theories that are not imported must be qualified. + In other words, if a (sub)theory is not imported by the outermost theory, + linking requires the item name to be qualified properly, even within the + (sub)theory itself. For example, to link to `type s` above, something along + the lines of `[go to s in T](>|s)` __does not__ work, but + `[go to s in T](>|T.s)` __does__ (proof: [go to s in T](>|T.s)). + However, if the (sub)theory would be imported at some point in the + outermost theory, `[go to s in T](>|s)` __would work__, provided + there are no naming collisions. +&*) +op a : s -> s. + +(*& + Linking to items in a parent theory works as expected. For example `[go to w + in parent](>|w)` would create a link to the entry for `w` in the parent + theory's documentation file (proof: [go to w in parent](>|w)). +&*) +op b : w -> w. + +(*& + The documentation mechanism for theories works recursively. + For example, theory `U` below is treated in the documentation file for `T` in the + same way that `T` is treated in the documentation file for the outermost theory. + In addition to appearing in `T`'s documentation file, `U` also receives its own + documentation file, similar to `T`, but now linking back to `T` rather than the + outermost theory. +&*) +abstract theory U. + +end U. + +end T. + + +section. + +(* + As mentioned before, "scoped" items are never documented, even + if their "non-scoped" version are. +*) +declare op lf : t -> t. + +(*& + If a documentation comment precedes (and would normally be linked to) an item + that is "undocumentable" (e.g., due to its scope), the comment is discarded, + effectively making it a regular, non-documentation comment. +&*) +local module M' = { + +}. + +(*& + This operator is documented, but the previous documentation comment is + not visible (indicating it has been dropped). +&*) +op foo = T.a. + +end section. + +(*& + At present, similar to the previously discussed "scoped" items, clones are + "undocumentable" items. As such, any preceding (would-be-linked) documentation + comments are discarded, effectively making them regular, non-documentation + comments. +&*) +clone FinType as FT with + type t <- t. + +(*& + A documentation comment without any subsequent item is + discarded, effectively making it a regular, non-documentation comment. +&*) diff --git a/src/dune b/src/dune index d3e8093146..75cb7e8abc 100644 --- a/src/dune +++ b/src/dune @@ -15,7 +15,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles pcre2 why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable diff --git a/src/ec.ml b/src/ec.ml index d61bd43292..48da43b802 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -413,6 +413,8 @@ let main () = interactive : bool; eco : bool; gccompact : int option; + docgen : bool; + outdirp : string option; } end in @@ -467,7 +469,9 @@ let main () = ; terminal = terminal ; interactive = true ; eco = false - ; gccompact = None } + ; gccompact = None + ; docgen = false + ; outdirp = None } end @@ -494,13 +498,54 @@ let main () = ; terminal = terminal ; interactive = false ; eco = cmpopts.cmpo_noeco - ; gccompact = cmpopts.cmpo_compact } + ; gccompact = cmpopts.cmpo_compact + ; docgen = false + ; outdirp = None } end | `Runtest _ -> (* Eagerly executed *) assert false + + | `DocGen docopts -> begin + let name = docopts.doco_input in + + begin try + let ext = Filename.extension name in + ignore (EcLoader.getkind ext : EcLoader.kind) + with EcLoader.BadExtension ext -> + Format.eprintf "do not know what to do with %s@." ext; + exit 1 + end; + + let prvoff = { + prvo_maxjobs = None; + prvo_timeout = None; + prvo_cpufactor = None; + prvo_provers = None; + prvo_pragmas = []; + prvo_ppwidth = None; + prvo_checkall = false; + prvo_profile = false; + prvo_iterate = false; + prvo_why3server = None; } + in + + let terminal = + lazy (T.from_channel ~name (open_in name)) + in + + { prvopts = prvoff + ; input = Some name + ; terminal = terminal + ; interactive = false + ; eco = true + ; gccompact = None + ; docgen = true + ; outdirp = docopts.doco_outdirp } + end + in (match state.input with @@ -511,9 +556,10 @@ let main () = | Some pwd -> EcCommands.addidir pwd); (* Check if the .eco is up-to-date and exit if so *) - oiter - (fun input -> if EcCommands.check_eco input then exit 0) - state.input; + (if not state.docgen then + oiter + (fun input -> if EcCommands.check_eco input then exit 0) + state.input); let finalize_input input scope = match input with @@ -606,8 +652,13 @@ let main () = EcCommands.cm_iterate = state.prvopts.prvo_iterate; } in + let checkproof = not state.docgen in + EcCommands.initialize ~restart - ~undo:state.interactive ~boot:ldropts.ldro_boot ~checkmode; + ~undo:state.interactive + ~boot:ldropts.ldro_boot + ~checkmode + ~checkproof; (try List.iter EcCommands.apply_pragma state.prvopts.prvo_pragmas with EcCommands.InvalidPragma x -> @@ -633,8 +684,9 @@ let main () = | Some (`Int i) -> Some i | _ -> None); begin - match EcLocation.unloc (T.next terminal) with - | EP.P_Prog (commands, locterm) -> + match snd_map EcLocation.unloc (T.next terminal) with + | (src, EP.P_Prog (commands, locterm)) -> + let src = String.strip src in terminate := locterm; List.iter (fun p -> @@ -643,7 +695,7 @@ let main () = let break = p.EP.gl_debug = Some `Break in let ignore_fail = ref false in try - let tdelta = EcCommands.process ~timed ~break p.EP.gl_action in + let tdelta = EcCommands.process ~src ~timed ~break p.EP.gl_action in if p.EP.gl_fail then begin ignore_fail := true; raise (EcScope.HiScopeError (None, "this command is expected to fail")) @@ -670,11 +722,15 @@ let main () = end) commands - | EP.P_Undo i -> + | _, EP.P_DocComment doc -> + EcCommands.doc_comment doc + + | _, EP.P_Undo i -> EcCommands.undo i - | EP.P_Exit -> + | _, EP.P_Exit -> terminate := true end; + T.finish `ST_Ok terminal; state.gccompact |> Option.iter (fun i -> @@ -689,6 +745,8 @@ let main () = T.finalize terminal; if not state.eco then finalize_input state.input (EcCommands.current ()); + if state.docgen then + EcDoc.generate_html ?outdirp:state.outdirp state.input (EcCommands.current ()); exit 0 end; with diff --git a/src/ecCommands.ml b/src/ecCommands.ml index f2da6001d7..9f647c52b4 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -401,15 +401,15 @@ let process_print scope p = exception Pragma of [`Reset | `Restart] (* -------------------------------------------------------------------- *) -let rec process_type (scope : EcScope.scope) (tyd : ptydecl located) = +let rec process_type ?(src : string option) (scope : EcScope.scope) (tyd : ptydecl located) = EcScope.check_state `InTop "type" scope; - let scope = EcScope.Ty.add scope tyd in + let scope = EcScope.Ty.add ?src scope tyd in EcScope.notify scope `Info "added type: `%s'" (unloc tyd.pl_desc.pty_name); scope (* -------------------------------------------------------------------- *) -and process_types (scope : EcScope.scope) tyds = - List.fold_left process_type scope tyds +and process_types ?(src : string option) (scope : EcScope.scope) tyds = + List.fold_left (process_type ?src) scope tyds (* -------------------------------------------------------------------- *) and process_subtype (scope : EcScope.scope) (subtype : psubtype located) = @@ -431,19 +431,19 @@ and process_tycinst (scope : EcScope.scope) (tci : ptycinstance located) = EcScope.Ty.add_instance scope (Pragma.get ()).pm_check tci (* -------------------------------------------------------------------- *) -and process_module (scope : EcScope.scope) m = +and process_module ?(src : string option) (scope : EcScope.scope) m = EcScope.check_state `InTop "module" scope; - EcScope.Mod.add scope m + EcScope.Mod.add ?src scope m (* -------------------------------------------------------------------- *) -and process_interface (scope : EcScope.scope) intf = +and process_interface ?(src : string option) (scope : EcScope.scope) intf = EcScope.check_state `InTop "interface" scope; - EcScope.ModType.add scope intf + EcScope.ModType.add ?src scope intf (* -------------------------------------------------------------------- *) -and process_operator (scope : EcScope.scope) (pop : poperator located) = +and process_operator ?(src : string option) (scope : EcScope.scope) (pop : poperator located) = EcScope.check_state `InTop "operator" scope; - let op, axs, scope = EcScope.Op.add scope pop in + let op, axs, scope = EcScope.Op.add ?src scope pop in let ppe = EcPrinting.PPEnv.ofenv (EcScope.env scope) in List.iter (fun { pl_desc = name } -> @@ -455,14 +455,14 @@ and process_operator (scope : EcScope.scope) (pop : poperator located) = scope (* -------------------------------------------------------------------- *) -and process_procop (scope : EcScope.scope) (pop : pprocop located) = +and process_procop ?(src : string option) (scope : EcScope.scope) (pop : pprocop located) = EcScope.check_state `InTop "operator" scope; - EcScope.Op.add_opsem scope pop + EcScope.Op.add_opsem ?src scope pop (* -------------------------------------------------------------------- *) -and process_predicate (scope : EcScope.scope) (p : ppredicate located) = +and process_predicate ?(src : string option) (scope : EcScope.scope) (p : ppredicate located) = EcScope.check_state `InTop "predicate" scope; - let op, scope = EcScope.Pred.add scope p in + let op, scope = EcScope.Pred.add ?src scope p in let ppe = EcPrinting.PPEnv.ofenv (EcScope.env scope) in EcScope.notify scope `Info "added predicate %s %a" (unloc p.pl_desc.pp_name) (EcPrinting.pp_added_op ppe) op; @@ -486,9 +486,9 @@ and process_abbrev (scope : EcScope.scope) (a : pabbrev located) = scope (* -------------------------------------------------------------------- *) -and process_axiom (scope : EcScope.scope) (ax : paxiom located) = +and process_axiom ?(src : string option) (scope : EcScope.scope) (ax : paxiom located) = EcScope.check_state `InTop "axiom" scope; - let (name, scope) = EcScope.Ax.add scope (Pragma.get ()).pm_check ax in + let (name, scope) = EcScope.Ax.add ?src scope (Pragma.get ()).pm_check ax in name |> EcUtils.oiter (fun x -> match (unloc ax).pa_kind with @@ -497,9 +497,9 @@ and process_axiom (scope : EcScope.scope) (ax : paxiom located) = scope (* -------------------------------------------------------------------- *) -and process_th_open (scope : EcScope.scope) (loca, abs, name) = +and process_th_open ?(src : string option) (scope : EcScope.scope) (loca, abs, name) = EcScope.check_state `InTop "theory" scope; - EcScope.Theory.enter scope (if abs then `Abstract else `Concrete) (unloc name) loca + EcScope.Theory.enter ?src scope (if abs then `Abstract else `Concrete) (unloc name) loca (* -------------------------------------------------------------------- *) and process_th_close (scope : EcScope.scope) (clears, name) = @@ -557,7 +557,7 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = try_finally (fun () -> let commands = EcIo.parseall (EcIo.from_file filename) in let commands = - List.fold_left + List.fold_left (fun scope g -> process_internal subld scope g.gl_action) iscope commands in commands) @@ -614,19 +614,21 @@ and process_sct_close (scope : EcScope.scope) name = EcScope.Section.exit scope name (* -------------------------------------------------------------------- *) -and process_tactics (scope : EcScope.scope) t = +(* Add and store src for proofs *) +and process_tactics ?(src : string option) (scope : EcScope.scope) t = let mode = (Pragma.get ()).pm_check in match t with - | `Actual t -> snd (EcScope.Tactics.process scope mode t) - | `Proof -> EcScope.Tactics.proof scope + | `Actual t -> snd (EcScope.Tactics.process ?src scope mode t) + | `Proof -> EcScope.Tactics.proof ?src scope (* -------------------------------------------------------------------- *) -and process_save (scope : EcScope.scope) ed = +(* Add and store src for proofs *) +and process_save ?(src : string option) (scope : EcScope.scope) ed = let (oname, scope) = match unloc ed with - | `Qed -> EcScope.Ax.save scope - | `Admit -> EcScope.Ax.admit scope - | `Abort -> (None, EcScope.Ax.abort scope) + | `Qed -> EcScope.Ax.save ?src scope + | `Admit -> EcScope.Ax.admit ?src scope + | `Abort -> (None, EcScope.Ax.abort ?src scope) in oname |> EcUtils.oiter (fun x -> EcScope.notify scope `Info "added lemma: `%s'" x); @@ -748,25 +750,25 @@ and process_dump scope (source, tc) = scope (* -------------------------------------------------------------------- *) -and process (ld : Loader.loader) (scope : EcScope.scope) g = +and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) g = let loc = g.pl_loc in let scope = match match g.pl_desc with - | Gtype t -> `Fct (fun scope -> process_types scope (List.map (mk_loc loc) t)) + | Gtype t -> `Fct (fun scope -> process_types ?src scope (List.map (mk_loc loc) t)) | Gsubtype t -> `Fct (fun scope -> process_subtype scope (mk_loc loc t)) | Gtypeclass t -> `Fct (fun scope -> process_typeclass scope (mk_loc loc t)) | Gtycinstance t -> `Fct (fun scope -> process_tycinst scope (mk_loc loc t)) - | Gmodule m -> `Fct (fun scope -> process_module scope m) - | Ginterface i -> `Fct (fun scope -> process_interface scope i) - | Goperator o -> `Fct (fun scope -> process_operator scope (mk_loc loc o)) - | Gprocop o -> `Fct (fun scope -> process_procop scope (mk_loc loc o)) - | Gpredicate p -> `Fct (fun scope -> process_predicate scope (mk_loc loc p)) + | Gmodule m -> `Fct (fun scope -> process_module ?src scope m) + | Ginterface i -> `Fct (fun scope -> process_interface ?src scope i) + | Goperator o -> `Fct (fun scope -> process_operator ?src scope (mk_loc loc o)) + | Gprocop o -> `Fct (fun scope -> process_procop ?src scope (mk_loc loc o)) + | Gpredicate p -> `Fct (fun scope -> process_predicate ?src scope (mk_loc loc p)) | Gnotation n -> `Fct (fun scope -> process_notation scope (mk_loc loc n)) | Gabbrev n -> `Fct (fun scope -> process_abbrev scope (mk_loc loc n)) - | Gaxiom a -> `Fct (fun scope -> process_axiom scope (mk_loc loc a)) - | GthOpen name -> `Fct (fun scope -> process_th_open scope name) + | Gaxiom a -> `Fct (fun scope -> process_axiom ?src scope (mk_loc loc a)) + | GthOpen name -> `Fct (fun scope -> process_th_open ?src scope name) | GthClose info -> `Fct (fun scope -> process_th_close scope info) | GthClear info -> `Fct (fun scope -> process_th_clear scope info) | GthRequire name -> `Fct (fun scope -> process_th_require ld scope name) @@ -780,11 +782,11 @@ and process (ld : Loader.loader) (scope : EcScope.scope) g = | Gprint p -> `Fct (fun scope -> process_print scope p; scope) | Gsearch qs -> `Fct (fun scope -> process_search scope qs; scope) | Glocate x -> `Fct (fun scope -> process_locate scope x; scope) - | Gtactics t -> `Fct (fun scope -> process_tactics scope t) + | Gtactics t -> `Fct (fun scope -> process_tactics ?src scope t) | Gtcdump info -> `Fct (fun scope -> process_dump scope info) | Grealize p -> `Fct (fun scope -> process_realize scope p) | Gprover_info pi -> `Fct (fun scope -> process_proverinfo scope pi) - | Gsave ed -> `Fct (fun scope -> process_save scope ed) + | Gsave ed -> `Fct (fun scope -> process_save ?src scope ed) | Gpragma opt -> `State (fun scope -> process_pragma scope opt) | Goption opt -> `Fct (fun scope -> process_option scope opt) | Gaddrw hint -> `Fct (fun scope -> process_addrw scope hint) @@ -827,7 +829,7 @@ type checkmode = { cm_iterate : bool; } -let initial ~checkmode ~boot = +let initial ~checkmode ~boot ~checkproof = let checkall = checkmode.cm_checkall in let profile = checkmode.cm_profile in let poptions = { EcScope.Prover.empty_options with @@ -850,7 +852,14 @@ let initial ~checkmode ~boot = scope [tactics; prelude] in let scope = EcScope.Prover.set_default scope poptions in - let scope = if checkall then EcScope.Prover.full_check scope else scope in + let scope = if checkproof then + begin + if checkall then + EcScope.Prover.full_check scope + else scope + end + else EcScope.Prover.check_proof scope false + in EcScope.freeze scope @@ -890,10 +899,10 @@ let push_context scope context = |> omap (fun st -> context.ct_current :: st); } (* -------------------------------------------------------------------- *) -let initialize ~restart ~undo ~boot ~checkmode = +let initialize ~restart ~undo ~boot ~checkmode ~checkproof = assert (restart || EcUtils.is_none !context); if restart then Pragma.set dpragma; - context := Some (rootctxt ~undo (initial ~checkmode ~boot)) + context := Some (rootctxt ~undo (initial ~checkmode ~boot ~checkproof)) (* -------------------------------------------------------------------- *) type notifier = EcGState.loglevel -> string Lazy.t -> unit @@ -925,19 +934,30 @@ let undo (olduuid : int) = context := Some (pop_context (oget !context)) done +(* -------------------------------------------------------------------- *) +let doc_comment (doc : [`Global | `Item] * string) : unit = + let current = oget !context in + let scope = current.ct_current in + let scope = EcScope.DocComment.add scope doc in + + context := Some (push_context scope current) + (* -------------------------------------------------------------------- *) let reset () = context := Some (rootctxt (oget !context).ct_root) (* -------------------------------------------------------------------- *) -let process ?(timed = false) ?(break = false) (g : global_action located) : float option = +let process + ?(src : string option) ?(timed = false) ?(break = false) + (g : global_action located) : float option += ignore break; let current = oget !context in let scope = current.ct_current in try - let (tdelta, oscope) = EcUtils.timed (process loader scope) g in + let (tdelta, oscope) = EcUtils.timed (process ?src loader scope) g in oscope |> oiter (fun scope -> context := Some (push_context scope current)); if timed then EcScope.notify scope `Info "time: %f" tdelta; diff --git a/src/ecCommands.mli b/src/ecCommands.mli index 69e6c47fd4..f61a313f34 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -24,13 +24,14 @@ type checkmode = { cm_iterate : bool; } -val initial : checkmode:checkmode -> boot:bool -> EcScope.scope +val initial : checkmode:checkmode -> boot:bool -> checkproof:bool -> EcScope.scope val initialize : restart:bool -> undo:bool -> boot:bool -> checkmode:checkmode + -> checkproof:bool -> unit val current : unit -> EcScope.scope @@ -44,7 +45,7 @@ val process_internal : -> EcScope.scope (* -------------------------------------------------------------------- *) -val process : ?timed:bool -> ?break:bool -> +val process : ?src:string -> ?timed:bool -> ?break:bool -> EcParsetree.global_action located -> float option val undo : int -> unit @@ -54,6 +55,8 @@ val mode : unit -> string val check_eco : string -> bool +val doc_comment : [`Global | `Item] * string -> unit + (* -------------------------------------------------------------------- *) val pp_current_goal : ?all:bool -> Format.formatter -> unit val pp_maybe_current_goal : Format.formatter -> unit diff --git a/src/ecDoc.ml b/src/ecDoc.ml new file mode 100644 index 0000000000..01b3437709 --- /dev/null +++ b/src/ecDoc.ml @@ -0,0 +1,338 @@ +(* -------------------------------------------------------------------- *) +open Tyxml.Html + +open EcScope + +(* -------------------------------------------------------------------- *) +let styles_file : string = + let (module Sites) = EcRelocate.sites in + Filename.concat Sites.doc "styles.css" + +let stdlib_doc_dp (th : string) : string = + match th with + | _ -> "" + +(* -------------------------------------------------------------------- *) +let from_stdlib (th : string) : bool = + match th with + | _ -> false + +(* -------------------------------------------------------------------- *) +let c_filename ?(ext : string option) (nms : string list) = + match ext with + | None -> String.concat "!" nms + | Some ext -> String.concat "!" nms ^ ext + +(* -------------------------------------------------------------------- *) +let thkind_str (kind : EcLoader.kind) : string = + match kind with + | `Ec -> "Theory" + | `EcA -> "Abstract Theory" + +(* -------------------------------------------------------------------- *) +let itemkind_str_pl (ik : itemkind) : string = + match ik with + | `Type -> "Types" + | `Operator -> "Operators" + | `Axiom -> "Axioms" + | `Lemma -> "Lemmas" + | `ModuleType -> "Module Types" + | `Module -> "Modules" + | `Theory -> "Theories" + +let itemkind_lookup_path (ik : itemkind) (q : EcSymbols.qsymbol) (env : EcEnv.env) = + match ik with + | `Type -> EcEnv.Ty.lookup_path q env + | `Operator -> EcEnv.Op.lookup_path q env + | `Axiom -> EcEnv.Ax.lookup_path q env + | `Lemma -> EcEnv.Ax.lookup_path q env + | `ModuleType -> EcEnv.ModTy.lookup_path q env + | `Module -> + begin + match (EcEnv.Mod.lookup_path q env).m_top with + | `Concrete (p, None) -> p + | `Concrete (_, Some _) -> failwith "Linking to sub-modules not supported." + | `Local _ -> failwith "Linking to local/declared modules not supported." + end + | `Theory -> EcEnv.Theory.lookup_path ~mode:`All q env + +(* -------------------------------------------------------------------- *) +let rec bot_env_of_qsymbol (q : EcSymbols.qsymbol) (env : EcEnv.env)= + match fst q with + | [] | ["Top"] -> env + | x :: xs -> + let p = EcEnv.Theory.lookup_path ~mode:`All ([], x) env in + let env = EcEnv.Theory.env_of_theory p env in + bot_env_of_qsymbol (xs, snd q) env + +let filename_of_path ?(ext : string option) (rth : string) (p : EcPath.path) = + let qs = EcPath.toqsymbol p in + match fst qs with + | [] -> assert false + | ["Top"] -> c_filename ?ext [rth] + | "Top" :: ts -> + let reqrt = (List.hd ts) in + if from_stdlib reqrt then + Filename.concat (stdlib_doc_dp reqrt) (c_filename ?ext ts) + else + (c_filename ?ext (rth :: ts)) + | _ -> assert false + +(* -------------------------------------------------------------------- *) +let md_pre_format ~kind (s : string) = + match kind with | _ -> pre [txt s] + +let md_href_format (rth : string) (env : EcEnv.env) (hr : Markdown.href) : Html_types.phrasing elt = + let il_format = Str.regexp "^>\\([^|]*\\)|\\([^|]+\\)$" in + if Str.string_match il_format hr.href_target 0 then + let tkind = Str.matched_group 1 hr.href_target in + let tname = Str.matched_group 2 hr.href_target in + let tqs = EcSymbols.qsymbol_of_string tname in + let env = bot_env_of_qsymbol tqs env in + let ikstr, path = + match tkind with + | "Ty" | "Type" -> itemkind_str_pl `Type, itemkind_lookup_path `Type tqs env + | "Op" | "Operator" -> itemkind_str_pl `Operator, itemkind_lookup_path `Operator tqs env + | "Ax" | "Axiom" -> itemkind_str_pl `Axiom, itemkind_lookup_path `Axiom tqs env + | "Lem" | "Lemma" -> itemkind_str_pl `Lemma, itemkind_lookup_path `Lemma tqs env + | "ModTy" | "ModuleType" -> itemkind_str_pl `ModuleType, itemkind_lookup_path `ModuleType tqs env + | "Mod" | "Module" -> itemkind_str_pl `Module, itemkind_lookup_path `Module tqs env + | "Th" | "Theory" -> itemkind_str_pl `Theory, itemkind_lookup_path `Theory tqs env + | "" -> + let rec try_lookup = function + | [] -> failwith (Printf.sprintf "No item/entity found with name `%s'." tname) + | ik :: iks -> + try itemkind_str_pl ik, itemkind_lookup_path ik tqs env + with EcEnv.LookupFailure _ -> try_lookup iks + in + let iks = [`Type; `Operator; `Axiom; `Lemma; `ModuleType; `Module; `Theory] in + try_lookup iks + | _ -> failwith (Printf.sprintf "Invalid item/entity kind `%s'." tkind) + in + let fn = filename_of_path ~ext:".html" rth path in + let il = fn ^ "#" ^ ikstr ^ snd tqs in + a ~a:[a_href (uri_of_string il)] [txt hr.href_desc] + else + a ~a:[a_href (uri_of_string hr.href_target)] [txt hr.href_desc] + +let md_img_format (_ : Markdown.img_ref) = + failwith "Image embedding not supported." + +let c_markdown (input : string) (rth : string) (env : EcEnv.env) = + let input = Markdown.parse_text input in + + MarkdownHTML.to_html + ~render_pre:md_pre_format + ~render_link:(md_href_format rth env) + ~render_img:md_img_format + input + + +(* -------------------------------------------------------------------- *) +let c_head (tstr : string) : [> Html_types.head] elt = + head (title (txt tstr)) [link ~rel:[`Stylesheet] ~href:styles_file ()] + +(* -------------------------------------------------------------------- *) +let c_sidebar (th : string) (lents : EcScope.docentity list) = + let iks = [`Type; `Operator; `Axiom; `Lemma; `ModuleType; `Module; `Theory] in + let iksin = + List.filter (fun ik -> + List.exists (fun ldoc -> + match ldoc with + | ItemDoc (_, (_, ikp, _, _)) -> ikp = ik + | SubDoc ((_, (_, ikp, _, _)), _) -> ikp = ik) lents) iks + in + nav ~a:[a_class ["sidebar"]] + [ + div ~a:[a_class["sidebar-title"]] + [ + h2 [txt "EasyCrypt Documentation"]; + span ~a:[a_class ["sidebar-title-theory"]] [txt th] + ]; + div ~a:[a_class ["sidebar-elems"]] + [ + ul ~a:[a_class ["sidebar-section-list"]] + (List.map (fun ik -> + let ikstr = itemkind_str_pl ik in + li [a ~a:[a_href (Xml.uri_of_string ("#" ^ ikstr))] [txt ikstr]]) iksin) + ] + ] + +(* -------------------------------------------------------------------- *) +let c_section_intro (rth : string) (gdoc : string list) (env : EcEnv.env) = + match gdoc with + | [] -> [] + | _ -> [ + let ids = "Introduction" in + section ~a:[a_id ids; a_title ids; a_class ["intro-section"]] [ + div ~a:[a_class ["intro-text-container"]] + (List.map (fun s -> div ~a:[a_class ["intro-par-container"]] (c_markdown s rth env)) gdoc) + ] + ] + +(* -------------------------------------------------------------------- *) +let c_section_main_itemkind_li ?(supthf : string option) (rth : string) (th : string) (lent_ik : EcScope.docentity) (env : EcEnv.env) = + match lent_ik with + | SubDoc ((doc, (_, ik, subth, _)), _) -> + begin + match ik with + | `Theory -> + let (hdoc, tdoc) = + if doc = [] then "No description available.", [] + else if List.length doc = 1 then List.hd doc, [] + else List.hd doc, List.tl doc + in + let hn = + match supthf with + | None -> c_filename ~ext:(".html") [th; subth] + | Some supf -> c_filename ~ext:(".html") [supf; th; subth] + in + li ~a:[a_id (itemkind_str_pl ik ^ subth); a_class ["item-entry"]] ([ + div ~a:[a_class ["item-name-desc-container"]] [ + div ~a:[a_class ["item-name"]] [a ~a:[a_href (Xml.uri_of_string hn)] [txt subth]]; + div ~a:[a_class ["item-basic-desc"]] (c_markdown hdoc rth env) + ] + ] @ (if tdoc <> [] + then [details ~a:[a_class ["item-details"]] (summary []) + (List.map (fun d -> div ~a:[a_class ["item-details-par"]] (c_markdown d rth env)) tdoc)] + else [])) + | _ -> assert false + end + | ItemDoc (doc, (_, ik, nm, src)) -> + let psrc = String.trim (String.concat "\n" src) in + match ik with + | `Theory -> assert false + | _ -> + let (hdoc, tdoc) = + if doc = [] then "No description available. (However, see source below.)", [] + else if List.length doc = 1 then List.hd doc, [] + else List.hd doc, List.tl doc + in + li ~a:[a_id (itemkind_str_pl ik ^ nm) ; a_class ["item-entry"]] [ + div ~a:[a_class ["item-name-desc-container"]] [ + div ~a:[a_class ["item-name"]] [txt nm]; + div ~a:[a_class ["item-basic-desc"]] (c_markdown hdoc rth env) + ]; + details ~a:[a_class ["item-details"]] (summary []) + (List.map (fun d -> div ~a:[a_class ["item-details-par"]] (c_markdown d rth env)) tdoc + @ [div ~a:[a_class ["source-container"]] + [txt "Source:"; pre ~a:[a_class ["source"]] [txt psrc]]]) + ] + +(* -------------------------------------------------------------------- *) +let c_section_main_itemkind ?(supthf : string option) (rth : string) (th : string) (lents_ik : EcScope.docentity list) (env : EcEnv.env) = + [ + ul ~a:[a_class ["item-list"]] + (List.map (fun lent_ik -> c_section_main_itemkind_li ?supthf rth th lent_ik env) lents_ik) + ] + +(* -------------------------------------------------------------------- *) +let c_section_main ?(supthf : string option) (rth : string) (th : string) (lents : EcScope.docentity list) (env : EcEnv.env) = + let iks = [`Type; `Operator; `Axiom; `Lemma; `ModuleType; `Module; `Theory] in + List.concat + (List.map (fun ik -> + let lents_ik = List.filter (fun ent -> + match ent with + | ItemDoc (_, (md, ikp, _, _)) -> md = `Specific && ikp = ik + | SubDoc ((_, (_, ikp, _, _)), _) -> ikp = ik) lents + in + match lents_ik with + | [] -> [] + | _ -> [ + let iks = itemkind_str_pl ik in + section ~a:[a_id iks; a_title iks; a_class ["item-section"]] [ + h2 ~a:[a_class ["section-heading"]] [txt iks]; + div ~a:[a_class ["item-list-container"]] (c_section_main_itemkind ?supthf rth th lents_ik env) + ] + ] + ) + iks) + +let c_body ?(supths : string option) ?(supthf : string option) (rth : string) (th : string) (tstr : string) (gdoc : string list) (ldocents : EcScope.docentity list) (env : EcEnv.env) : [> Html_types.body] elt = + let sidebar = c_sidebar th ldocents in + let page_heading = + div ~a:[a_class ["page-heading-container"]] + (h1 ~a:[a_class ["page-heading"]] [txt tstr] + :: + match supths with + | None -> [] + | Some sup -> + match supthf with + | None -> assert false + | Some supf -> + [ + h2 ~a:[a_class ["page-subheading"]] [ + txt ("Subtheory of "); + a ~a:[a_href (Xml.uri_of_string (supf ^ ".html" ^ "#" ^ itemkind_str_pl `Theory ^ th))] [txt sup] + ] + ]) + in + let sec_intro = c_section_intro rth gdoc env in + let sec_main = c_section_main ?supthf rth th ldocents env in + body (sidebar :: [main (page_heading :: sec_intro @ sec_main)]) + +(* -------------------------------------------------------------------- *) +let c_page ?(supths : string option) ?(supthf : string option) (rth : string) (th : string) (tstr : string) (gdoc : string list) (ldocents : EcScope.docentity list) (env : EcEnv.env) : [> Html_types.html] elt = + html (c_head tstr) (c_body ?supths ?supthf rth th tstr gdoc ldocents env) + +(* -------------------------------------------------------------------- *) +let emit_page (dp : string) (fn : string) (page : [> Html_types.html ] elt) = + let wp = Filename.concat dp fn ^ ".html" in + let file = open_out wp in + let fmt = Format.formatter_of_out_channel file in + pp () fmt page; + Format.fprintf fmt "@."; + close_out file + +(* -------------------------------------------------------------------- *) +let emit_pages (dp : string) (th : string) (tstr : string) (gdoc : string list) (ldocents : EcScope.docentity list) (env : EcEnv.env) = + let rec c_subpages ?supths ?supthf th docents = + match docents with + | [] -> [] + | de :: docents' -> + match de with + | ItemDoc _ -> c_subpages ?supths ?supthf th docents' + | SubDoc ((sgdoc, (smd, _, sth, _)), sldocents) -> + let ststr = (if smd = `Abstract then "Abstract " else "") ^ "Theory " ^ sth in + let stsupf = + match supthf with + | None -> th + | Some supf -> c_filename [supf; th] + in + let stf = c_filename [stsupf; sth] in + (stf, c_page ~supths:th ~supthf:stsupf th sth ststr sgdoc sldocents env) + :: c_subpages ~supths:th ~supthf:stsupf sth sldocents + @ c_subpages ?supths ?supthf th docents' + in + let spgs = c_subpages th ldocents in + List.iter (fun fnpg -> emit_page dp (fst fnpg) (snd fnpg)) spgs; + emit_page dp th (c_page th th tstr gdoc ldocents env) + +(* -------------------------------------------------------------------- *) +(* input = input name, scope contains all documentation items *) +let generate_html ?(outdirp : string option) (fname : string option) (scope : EcScope.scope) : unit = + match fname with + | Some fn -> + let kind = + try EcLoader.getkind (Filename.extension fn) + with EcLoader.BadExtension _ -> assert false + in + let dp = + match outdirp with + | None -> Filename.dirname fn + | Some outdirp -> + try + if Sys.is_directory outdirp + then outdirp + else raise (Invalid_argument (Format.sprintf "%s is not an existing directory." outdirp)) + with + | _ as ex -> Printf.eprintf "Exception: %s\n." (Printexc.to_string ex); raise ex + in + let fn = Filename.basename fn in + let th = Filename.remove_extension fn in + let tstr = thkind_str kind ^ " " ^ th in + begin + try emit_pages dp th tstr (get_gdocstrings scope) (get_ldocentities scope) (env scope) with + | _ as ex -> Printf.eprintf "Exception: %s\n." (Printexc.to_string ex); raise ex + end + | None -> () diff --git a/src/ecDoc.mli b/src/ecDoc.mli new file mode 100644 index 0000000000..1e8fd31d23 --- /dev/null +++ b/src/ecDoc.mli @@ -0,0 +1,2 @@ +(* -------------------------------------------------------------------- *) +val generate_html : ?outdirp:string -> string option -> EcScope.scope -> unit \ No newline at end of file diff --git a/src/ecIo.ml b/src/ecIo.ml index e630d4b495..016545d85c 100644 --- a/src/ecIo.ml +++ b/src/ecIo.ml @@ -34,16 +34,20 @@ let isuniop_fun () : unit parser_t = (* -------------------------------------------------------------------- *) type ecreader_r = { (*---*) ecr_lexbuf : Lexing.lexbuf; + (*---*) ecr_source : Buffer.t; mutable ecr_atstart : bool; + mutable ecr_trim : int; mutable ecr_tokens : EcParser.token list; } type ecreader = ecreader_r Disposable.t (* -------------------------------------------------------------------- *) -let ecreader_of_lexbuf (lexbuf : L.lexbuf) : ecreader_r = +let ecreader_of_lexbuf (buffer : Buffer.t) (lexbuf : L.lexbuf) : ecreader_r = { ecr_lexbuf = lexbuf; + ecr_source = buffer; ecr_atstart = true; + ecr_trim = 0; ecr_tokens = []; } (* -------------------------------------------------------------------- *) @@ -51,28 +55,42 @@ let lexbuf (reader : ecreader) = (Disposable.get reader).ecr_lexbuf (* -------------------------------------------------------------------- *) -let from_channel ~(name : string) (channel : in_channel) = - let lexbuf = lexbuf_from_channel name channel in +let from_channel ?(close = false) ~name channel = + let buffer = Buffer.create 0 in + + let refill (bytes : bytes) (len : int) = + let aout = input channel bytes 0 len in + Buffer.add_bytes buffer (Bytes.sub bytes 0 aout); + aout + in + + let lexbuf = Lexing.from_function refill in + + Lexing.set_filename lexbuf name; + Disposable.create - (ecreader_of_lexbuf lexbuf) + ~cb:(fun _ -> if close then close_in channel) + (ecreader_of_lexbuf buffer lexbuf) (* -------------------------------------------------------------------- *) let from_file (filename : string) = let channel = open_in filename in + try - let lexbuf = lexbuf_from_channel filename channel in - Disposable.create - ~cb:(fun _ -> close_in channel) - (ecreader_of_lexbuf lexbuf) + from_channel ~close:true ~name:filename channel with e -> (try close_in channel with _ -> ()); raise e (* -------------------------------------------------------------------- *) -let from_string (data : string) = - Disposable.create - (ecreader_of_lexbuf (Lexing.from_string data)) +let from_string data = + let lexbuf = Lexing.from_string data in + let buffer = Buffer.create (String.length data) in + + Buffer.add_string buffer data; + + Disposable.create (ecreader_of_lexbuf buffer lexbuf) (* -------------------------------------------------------------------- *) let finalize (ecreader : ecreader) = @@ -86,8 +104,20 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = | EcParser.FINAL _ -> true | _ -> false in - if List.is_empty (ecreader.ecr_tokens) then - ecreader.ecr_tokens <- EcLexer.main lexbuf; + if ecreader.ecr_atstart then + ecreader.ecr_trim <- ecreader.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum; + + while List.is_empty (ecreader.ecr_tokens) do + match EcLexer.main lexbuf with + | [COMMENT] -> + if ecreader.ecr_atstart then + ecreader.ecr_trim <- (Lexing.lexeme_end_p ecreader.ecr_lexbuf).pos_cnum + | [DOCCOMMENT _] as tokens -> + if ecreader.ecr_atstart then + ecreader.ecr_tokens <- tokens + | tokens -> + ecreader.ecr_tokens <- tokens + done; let token, queue = List.destruct ecreader.ecr_tokens in @@ -103,7 +133,16 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = in ecreader.ecr_tokens <- prequeue @ queue; - ecreader.ecr_atstart <- (isfinal token); + + if isfinal token then + ecreader.ecr_atstart <- true + else + ecreader.ecr_atstart <- ecreader.ecr_atstart && ( + match token with + | P.DOCCOMMENT _ | P.COMMENT -> true + | _ -> false + ); + (token, Lexing.lexeme_start_p lexbuf, Lexing.lexeme_end_p lexbuf) (* -------------------------------------------------------------------- *) @@ -119,7 +158,7 @@ let drain (ecreader : ecreader) = drain () (* -------------------------------------------------------------------- *) -let parse (ecreader : ecreader) = +let parse (ecreader : ecreader) : EcParsetree.prog = let ecreader = Disposable.get ecreader in let rec parse (checkpoint : EcParsetree.prog I.checkpoint) : EcParsetree.prog = @@ -138,6 +177,17 @@ let parse (ecreader : ecreader) = in parse (EcParser.Incremental.prog ecreader.ecr_lexbuf.lex_curr_p) +(* -------------------------------------------------------------------- *) +let xparse (ecreader : ecreader) : string * EcParsetree.prog = + let ecr = Disposable.get ecreader in + + let p1 = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum in + let cd = parse ecreader in + let p2 = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum in + let p1 = max p1 ecr.ecr_trim in + + (Buffer.sub ecr.ecr_source p1 (p2 - p1), cd) + (* -------------------------------------------------------------------- *) let parseall (ecreader : ecreader) = let rec aux acc = @@ -145,6 +195,8 @@ let parseall (ecreader : ecreader) = | EcParsetree.P_Prog (commands, terminate) -> let acc = List.rev_append commands acc in if terminate then List.rev acc else aux acc + | EcParsetree.P_DocComment _ -> + aux acc | EcParsetree.P_Undo _ | EcParsetree.P_Exit -> assert false (* FIXME *) in diff --git a/src/ecIo.mli b/src/ecIo.mli index ce52869b44..42d28ba740 100644 --- a/src/ecIo.mli +++ b/src/ecIo.mli @@ -2,12 +2,13 @@ type ecreader (* -------------------------------------------------------------------- *) -val from_channel : name:string -> in_channel -> ecreader +val from_channel : ?close:bool -> name:string -> in_channel -> ecreader val from_file : string -> ecreader val from_string : string -> ecreader (* -------------------------------------------------------------------- *) val finalize : ecreader -> unit +val xparse : ecreader -> string * EcParsetree.prog val parse : ecreader -> EcParsetree.prog val parseall : ecreader -> EcParsetree.global list val drain : ecreader -> unit diff --git a/src/ecLexer.mll b/src/ecLexer.mll index a1b90c7c8c..19536eaae7 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -383,7 +383,14 @@ rule main = parse with Not_found -> [PUNIOP name] } - | "(*" { comment lexbuf; main lexbuf } + | "(*" (['&' '^'] as c) { + let buffer = doccomment c (Buffer.create 0) lexbuf in + let kind = match c with '&' -> `Item | '^' -> `Global | _ -> assert false in + [DOCCOMMENT (kind, Buffer.contents buffer)] + } + + | "(*" { comment lexbuf; [COMMENT] } + | "\"" { [STRING (Buffer.contents (string (Buffer.create 0) lexbuf))] } (* string symbols *) @@ -460,6 +467,20 @@ and comment = parse | eof { unterminated_comment () } | _ { comment lexbuf } +and doccomment kind buf = parse + | ['&' '^']? "*)" { buf } + | "(*" { comment lexbuf; doccomment kind buf lexbuf } + | eof { unterminated_comment () } + | newline { + Lexing.new_line lexbuf; + Buffer.add_char buf '\n'; + doccomment kind buf lexbuf + } + | _ as c { + Buffer.add_char buf c; + doccomment kind buf lexbuf + } + and string buf = parse | "\"" { buf } | "\\n" { Buffer.add_char buf '\n'; string buf lexbuf } diff --git a/src/ecOptions.ml b/src/ecOptions.ml index b3704e1a1a..4997737964 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -9,6 +9,7 @@ type command = [ | `Config | `Runtest of run_option | `Why3Config + | `DocGen of doc_option ] and options = { @@ -40,6 +41,11 @@ and run_option = { runo_rawargs : string list; } +and doc_option = { + doco_input : string; + doco_outdirp : string option; +} + and prv_options = { prvo_maxjobs : int option; prvo_timeout : int option; @@ -359,6 +365,10 @@ let specs = { ]); ("why3config", "Configure why3", []); + + ("docgen", "Generate documentation", [ + `Spec ("outdir", `String, "Output documentation files in ") + ]); ]; xp_groups = [ @@ -516,6 +526,10 @@ let runtest_options_of_values ini values (input, scenarios) = runo_jobs = get_int "jobs" values; runo_rawargs = get_strings "raw-args" values; } +let doc_options_of_values values input = + { doco_input = input; + doco_outdirp = get_string "outdir" values; } + (* -------------------------------------------------------------------- *) let parse getini argv = let (command, values, anons) = parse specs argv in @@ -575,6 +589,18 @@ let parse getini argv = (cmd, ini, true) + | "docgen" -> + begin + match anons with + | [input] -> + let ini = getini None in + let cmd = `DocGen (doc_options_of_values values input) in + (cmd, ini, true) + + | _ -> + raise (Arg.Bad "this command takes a single input file as argument") + end + | _ -> assert false in { diff --git a/src/ecOptions.mli b/src/ecOptions.mli index b779aa44e9..5ba1d0f63a 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -5,6 +5,7 @@ type command = [ | `Config | `Runtest of run_option | `Why3Config + | `DocGen of doc_option ] and options = { @@ -36,6 +37,11 @@ and run_option = { runo_rawargs : string list; } +and doc_option = { + doco_input : string; + doco_outdirp : string option; +} + and prv_options = { prvo_maxjobs : int option; prvo_timeout : int option; diff --git a/src/ecParser.mly b/src/ecParser.mly index eb1a1a9801..46205d02b5 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -412,6 +412,7 @@ %token COLON %token COLONTILD %token COMMA +%token COMMENT %token CONGR %token CONSEQ %token CONST @@ -606,7 +607,8 @@ %token ZETA %token NOP LOP1 ROP1 LOP2 ROP2 LOP3 ROP3 LOP4 ROP4 NUMOP %token LTCOLON DASHLT GT LT GE LE LTSTARGT LTLTSTARGT LTSTARGTGT -%token < Lexing.position> FINAL +%token FINAL +%token DOCCOMMENT %nonassoc prec_below_comma %nonassoc COMMA ELSE @@ -3904,6 +3906,9 @@ prog_r: | EXIT FINAL { P_Exit } +| d=DOCCOMMENT + { P_DocComment d } + | error { parse_error (EcLocation.make $startpos $endpos) None } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index b438cc9046..0189383d61 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -382,6 +382,12 @@ let rec pf_ident ?(raw = false) f = | PFtuple [f] when not raw -> pf_ident ~raw f | _ -> None + let rec pcmhd_ident (pcmhd : pmodule_header) : psymbol = + match pcmhd with + | Pmh_ident nm -> nm + | Pmh_params x -> pcmhd_ident (fst (unloc x)) + | Pmh_cast (pmh, _) -> pcmhd_ident pmh + (* -------------------------------------------------------------------- *) type psubtype = { pst_name : psymbol; @@ -1318,5 +1324,8 @@ type prog_r = | P_Prog of global list * bool | P_Exit | P_Undo of int + | P_DocComment of (dockind * string) + +and dockind = [`Global | `Item] type prog = prog_r located diff --git a/src/ecRelocate.ml b/src/ecRelocate.ml index f07cb429ab..0505a9b36b 100644 --- a/src/ecRelocate.ml +++ b/src/ecRelocate.ml @@ -23,6 +23,7 @@ let local (name : string list) : string = module type Sites = sig val commands : string val theories : string list + val doc : string val config : string end @@ -30,6 +31,7 @@ end module LocalSites() : Sites = struct let commands = local ["scripts"; "testing"] let theories = [local ["theories"]] + let doc = local ["assets"; "styles"] let config = local ["etc"] end @@ -42,7 +44,11 @@ module DuneSites() : Sites = struct let theories = EcDuneSites.Sites.theories - let config = + let doc = + Option.value ~default:"." + (EcUtils.List.Exceptionless.hd EcDuneSites.Sites.doc) + + let config = Option.value ~default:"etc" (EcUtils.List.Exceptionless.hd EcDuneSites.Sites.config) end diff --git a/src/ecRelocate.mli b/src/ecRelocate.mli index 8600315c03..59e80d7351 100644 --- a/src/ecRelocate.mli +++ b/src/ecRelocate.mli @@ -5,6 +5,7 @@ val sourceroot : string option module type Sites = sig val commands : string val theories : string list + val doc : string val config : string end diff --git a/src/ecScope.ml b/src/ecScope.ml index bce77e0abe..d8a4676f14 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -337,8 +337,105 @@ type scope = { sc_clears : path list; sc_pr_uc : proof_uc option; sc_options : GenOptions.options; + sc_globdoc : string list; + sc_locdoc : docstate; } +and docstate = { + docentities : docentity list; + subdocentbl : docentity list; + docstringbl : string list; + srcstringbl : string list; + currentname : string option; + currentkind : itemkind option; + currentmode : mode option; + currentproc : bool; +} + +and docentity = + | ItemDoc of string list * docitem + | SubDoc of (string list * docitem) * docentity list + +and docitem = + mode * itemkind * string * string list (* dec/reg, kind, name, src *) + +and itemkind = [`Type | `Operator | `Axiom | `Lemma | `ModuleType | `Module | `Theory] + +and mode = [`Abstract | `Specific] + +(* -------------------------------------------------------------------- *) +let get_gdocstrings (sc : scope) : string list = + sc.sc_globdoc + +let get_ldocentities (sc : scope) : docentity list = + sc.sc_locdoc.docentities + +module DocState = struct + let empty : docstate = + { docentities = []; + subdocentbl = []; + docstringbl = []; + srcstringbl = []; + currentname = None; + currentkind = None; + currentmode = None; + currentproc = false; } + + let start_process (state : docstate) (name : string) (kind : itemkind) (md : mode): docstate = + { state with + currentname = Some name; + currentkind = Some kind; + currentmode = Some md; + currentproc = true } + + let prevent_process (state : docstate) : docstate = + { state with + currentname = None; + currentkind = None; + currentmode = None; + currentproc = false } + + let reinitialize_process (state : docstate) : docstate = + { state with + docstringbl = []; + srcstringbl = []; + currentname = None; + currentkind = None; + currentmode = None; + currentproc = false } + + let push_docbl (state : docstate) (docc : string) : docstate = + { state with docstringbl = state.docstringbl @ [docc] } + + let push_srcbl (state : docstate) (srcs : string) : docstate = + { state with srcstringbl = state.srcstringbl @ [srcs] } + + let add_entity (state : docstate) (docent : docentity) : docstate = + { state with docentities = state.docentities @ [docent] } + + let add_item (state : docstate) : docstate = + let state = + if state.currentproc + then + add_entity state (ItemDoc (state.docstringbl, (oget state.currentmode, oget state.currentkind, oget state.currentname, state.srcstringbl))) + else + state + in + reinitialize_process state + + let add_sub (state : docstate) (substate : docstate) : docstate = + let state = + if state.currentproc + then + add_entity state (SubDoc ((state.docstringbl, (oget state.currentmode, oget state.currentkind, oget state.currentname, state.srcstringbl)), + (substate.docentities))) + else + state + in + reinitialize_process state + + end + (* -------------------------------------------------------------------- *) let empty (gstate : EcGState.gstate) = let env = EcEnv.initial gstate in @@ -350,7 +447,9 @@ let empty (gstate : EcGState.gstate) = sc_required = []; sc_clears = []; sc_pr_uc = None; - sc_options = GenOptions.freeze (); } + sc_options = GenOptions.freeze (); + sc_globdoc = []; + sc_locdoc = DocState.empty; } (* -------------------------------------------------------------------- *) let env (scope : scope) = @@ -470,7 +569,8 @@ let for_loading (scope : scope) = sc_clears = []; sc_pr_uc = None; sc_options = GenOptions.for_loading scope.sc_options; - } + sc_globdoc = []; + sc_locdoc = DocState.empty; } (* -------------------------------------------------------------------- *) let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = @@ -484,7 +584,10 @@ let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = sc_required = scope.sc_required; sc_clears = []; sc_pr_uc = None; - sc_options = GenOptions.for_subscope scope.sc_options; } + sc_options = GenOptions.for_subscope scope.sc_options; + sc_globdoc = []; + sc_locdoc = DocState.empty; + } (* -------------------------------------------------------------------- *) module Prover = struct @@ -694,7 +797,7 @@ module Tactics = struct let pi scope pi = Prover.do_prover_info scope pi - let proof (scope : scope) = + let proof ?(src : string option) (scope : scope) = check_state `InActiveProof "proof script" scope; match (oget scope.sc_pr_uc).puc_active with @@ -705,10 +808,14 @@ module Tactics = struct hierror "[proof] can only be used at beginning of a proof script"; { pac with puc_started = true } in - { scope with sc_pr_uc = - Some { (oget scope.sc_pr_uc) with puc_active = Some (pac, pct); } } + { scope with + sc_pr_uc = Some { (oget scope.sc_pr_uc) with puc_active = Some (pac, pct) }; + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } - let process_r ?reloc mark (mode : proofmode) (scope : scope) (tac : ptactic list) = + let process_r ?(src : string option) ?reloc mark (mode : proofmode) (scope : scope) (tac : ptactic list) = check_state `InProof "proof script" scope; let scope = @@ -720,6 +827,13 @@ module Tactics = struct else scope in + let scope = { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let puc = oget (scope.sc_pr_uc) in let pac, pct = oget (puc).puc_active in @@ -760,7 +874,7 @@ module Tactics = struct let pac = { pac with puc_jdg = PSCheck juc } in let puc = { puc with puc_active = Some (pac, pct); } in - let scope = { scope with sc_pr_uc = Some puc } in + let scope = { scope with sc_pr_uc = Some puc; } in Some (penv, hds), scope let process1_r mark mode scope t = @@ -770,8 +884,8 @@ module Tactics = struct let ts = List.map (fun t -> { pt_core = t; pt_intros = []; }) ts in snd (process_r mark mode scope ts) - let process scope mode tac = - process_r true mode scope tac + let process ?(src : string option) scope mode tac = + process_r ?src true mode scope tac end (* -------------------------------------------------------------------- *) @@ -825,7 +939,9 @@ module Ax = struct let bind ?(import = true) (scope : scope) ((x, ax) : _ * axiom) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_axiom (x, ax)) in - { scope with sc_env = EcSection.add_item item scope.sc_env } + { scope with sc_env = + EcSection.add_item item scope.sc_env; + sc_locdoc = DocState.add_item scope.sc_locdoc; } (* ------------------------------------------------------------------ *) let start_lemma scope (cont, axflags) check ?name (axd, ctxt) = @@ -1017,22 +1133,69 @@ module Ax = struct save_r scope (* ------------------------------------------------------------------ *) - let save scope = + let save ?(src : string option) scope = check_state `InProof "save" scope; + + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in save_r ~mode:`Save scope (* ------------------------------------------------------------------ *) - let admit scope = + let admit ?(src : string option) scope = check_state `InProof "admitted" scope; + + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + save_r ~mode:`Admit scope (* ------------------------------------------------------------------ *) - let abort scope = + let abort ?(src : string option) scope = check_state `InProof "abort" scope; + + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + snd (save_r ~mode:`Abort scope) (* ------------------------------------------------------------------ *) - let add (scope : scope) (mode : proofmode) (ax : paxiom located) = + let add ?(src : string option) (scope : scope) (mode : proofmode) (ax : paxiom located) = + let uax = unloc ax in + let kind = + match uax.pa_kind with + | PLemma _ -> `Lemma + | _ -> `Axiom + in + let scope = + { scope with + sc_locdoc = + match uax.pa_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc uax.pa_name) kind `Specific + | `Declare -> DocState.start_process scope.sc_locdoc (unloc uax.pa_name) kind `Abstract} + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in add_r scope mode ax (* ------------------------------------------------------------------ *) @@ -1088,10 +1251,30 @@ module Op = struct let bind ?(import = true) (scope : scope) ((x, op) : _ * operator) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_operator (x, op)) in - { scope with sc_env = EcSection.add_item item scope.sc_env; } + { scope with sc_env = + EcSection.add_item item scope.sc_env; + sc_locdoc = DocState.add_item scope.sc_locdoc; } - let add (scope : scope) (op : poperator located) = + let add ?(src : string option) (scope : scope) (op : poperator located) = assert (scope.sc_pr_uc = None); + + let uop = unloc op in + let scope = + { scope with + sc_locdoc = + match uop.po_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc uop.po_name) `Operator `Specific + | `Declare -> DocState.start_process scope.sc_locdoc (unloc uop.po_name) `Operator `Abstract } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let op = op.pl_desc and loc = op.pl_loc in let eenv = env scope in let ue = TT.transtyvars eenv (loc, op.po_tyvars) in @@ -1318,9 +1501,26 @@ module Op = struct tyop, List.rev !axs, scope - let add_opsem (scope : scope) (op : pprocop located) = + let add_opsem ?(src : string option) (scope : scope) (op : pprocop located) = let module Sem = EcProcSem in + let uop = unloc op in + let scope = + { scope with + sc_locdoc = + match uop.ppo_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc uop.ppo_name) `Operator `Specific + | `Declare -> DocState.start_process scope.sc_locdoc (unloc uop.ppo_name) `Operator `Abstract } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let op = unloc op in let f = EcTyping.trans_gamepath (env scope) op.ppo_target in let sig_, body = @@ -1453,9 +1653,26 @@ end module Pred = struct module TT = EcTyping - let add (scope : scope) (pr : ppredicate located) = + let add ?(src : string option) (scope : scope) (pr : ppredicate located) = assert (scope.sc_pr_uc = None); + let upr = unloc pr in + let scope = + { scope with + sc_locdoc = + match upr.pp_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc upr.pp_name) `Operator `Specific + | `Declare -> DocState.start_process scope.sc_locdoc (unloc upr.pp_name) `Operator `Abstract } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let typr = EcHiPredicates.trans_preddecl (env scope) pr in let scope = Op.bind scope (unloc (unloc pr).pp_name, typr) in typr, scope @@ -1480,14 +1697,34 @@ module Mod = struct let bind ?(import = true) (scope : scope) (m : top_module_expr) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_module m) in - { scope with sc_env = EcSection.add_item item scope.sc_env } + { scope with + sc_env = EcSection.add_item item scope.sc_env; + sc_locdoc = DocState.add_item scope.sc_locdoc; } - let add_concrete (scope : scope) lc (ptm : pmodule_def) = + let add_concrete ?(src : string option) (scope : scope) lc (ptm : pmodule_def) = assert (scope.sc_pr_uc = None); if lc = `Declare then hierror "cannot use [declare] for concrete modules"; + let nm = unloc (EcParsetree.pcmhd_ident ptm.ptm_header) in + + let scope = + { scope with + sc_locdoc = + match lc with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc nm `Module `Specific + | `Declare -> DocState.start_process scope.sc_locdoc nm `Module `Abstract } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let m = TT.transmod (env scope) ~attop:true ptm in let ur = EcModules.get_uninit_read_of_module (path scope) m in @@ -1517,10 +1754,10 @@ module Mod = struct { scope with sc_env = EcSection.add_decl_mod name tysig scope.sc_env } - let add (scope : scope) (m : pmodule_def_or_decl) = + let add ?(src : string option) (scope : scope) (m : pmodule_def_or_decl) = match m with | { ptm_locality = lc; ptm_def = `Concrete def } -> - add_concrete scope lc def + add_concrete ?src scope lc def | { ptm_locality = lc; ptm_def = `Abstract decl } -> if lc <> `Declare then @@ -1541,10 +1778,27 @@ module ModType = struct = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_modtype (x, tysig)) in - { scope with sc_env = EcSection.add_item item scope.sc_env } + { scope with + sc_env = EcSection.add_item item scope.sc_env; + sc_locdoc = DocState.add_item scope.sc_locdoc; } - let add (scope : scope) (intf : pinterface) = + let add ?(src : string option) (scope : scope) (intf : pinterface) = assert (scope.sc_pr_uc = None); + + let scope = + { scope with + sc_locdoc = + match intf.pi_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc intf.pi_name) `ModuleType `Specific } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in let tysig = EcTyping.transmodsig (env scope) intf in bind scope (unloc intf.pi_name, tysig) end @@ -1581,8 +1835,23 @@ module Theory = struct in { scope with sc_required = List.map for1 scope.sc_required } (* ------------------------------------------------------------------ *) - let enter (scope : scope) (mode : thmode) (name : symbol) = + let enter ?(src : string option) (scope : scope) (mode : thmode) (name : symbol) = assert (scope.sc_pr_uc = None); + let sc_locdoc = scope.sc_locdoc in + let sc_locdoc = + match src with + | None -> DocState.prevent_process scope.sc_locdoc + | Some src -> + let sc_locdoc = + DocState.start_process sc_locdoc name `Theory + (match mode with `Concrete -> `Specific | `Abstract -> `Abstract) + in + DocState.push_srcbl sc_locdoc src + in + let + scope = { scope with sc_locdoc } + in + subscope scope mode name (* ------------------------------------------------------------------ *) @@ -1633,7 +1902,10 @@ module Theory = struct let _, cth, _ = EcSection.exit_theory ?pempty ~clears scope.sc_env in let loaded = scope.sc_loaded in let required = scope.sc_required in - let sup = { sup with sc_loaded = loaded; } in + let sup = { + sup with + sc_loaded = loaded; + sc_locdoc = DocState.add_sub sup.sc_locdoc scope.sc_locdoc} in ((cth, required), scope.sc_name, sup) (* ------------------------------------------------------------------ *) @@ -1897,7 +2169,7 @@ module Cloning = struct | `Include -> scope) scope in - + if is_none thcl.pthc_local && oth.cth_loca = `Local then notify scope `Info "Theory `%s` has inherited `local` visibility. \ @@ -1929,10 +2201,29 @@ module Ty = struct let bind ?(import = true) (scope : scope) ((x, tydecl) : (_ * tydecl)) = assert (scope.sc_pr_uc = None); let item = EcTheory.mkitem ~import (EcTheory.Th_type (x, tydecl)) in - { scope with sc_env = EcSection.add_item item scope.sc_env } + { scope with + sc_env = EcSection.add_item item scope.sc_env; + sc_locdoc = DocState.add_item scope.sc_locdoc; } (* ------------------------------------------------------------------ *) - let add scope (tyd : ptydecl located) = + let add ?(src : string option) scope (tyd : ptydecl located) = + let utyd = unloc tyd in + let scope = + { scope with + sc_locdoc = + match utyd.pty_locality with + | `Local -> DocState.prevent_process scope.sc_locdoc + | `Global -> DocState.start_process scope.sc_locdoc (unloc utyd.pty_name) `Type `Specific + | `Declare -> DocState.start_process scope.sc_locdoc (unloc utyd.pty_name) `Type `Abstract } + in + let scope = + { scope with + sc_locdoc = + match src with + | Some src -> DocState.push_srcbl scope.sc_locdoc src + | None -> scope.sc_locdoc; } + in + let loc = loc tyd in let { pty_name = name; pty_tyvars = args; @@ -1986,14 +2277,14 @@ module Ty = struct let carrier = let ue = EcUnify.UniEnv.create None in transty tp_tydecl env ue subtype.pst_carrier in - + let pred = let x = EcIdent.create (fst subtype.pst_pred).pl_desc in let env = EcEnv.Var.bind_local x carrier env in let ue = EcUnify.UniEnv.create None in let pred = EcTyping.trans_prop env ue (snd subtype.pst_pred) in if not (EcUnify.UniEnv.closed ue) then - hierror ~loc:(snd subtype.pst_pred).pl_loc + hierror ~loc:(snd subtype.pst_pred).pl_loc "the predicate contains free type variables"; let uidmap = EcUnify.UniEnv.close ue in let fs = Tuni.subst uidmap in @@ -2015,12 +2306,12 @@ module Ty = struct ev_bynames = Msym.empty; ev_global = [ (None, Some [`Include, "prove"]) ] } } in - + let cname = Option.map unloc subtype.pst_cname in let npath = ofold ((^~) EcPath.pqname) (EcEnv.root env) cname in let cpath = EcPath.fromqsymbol ([EcCoreLib.i_top], "Subtype") in let theory = EcEnv.Theory.by_path ~mode:`Abstract cpath env in - + let renames = match subtype.pst_rename with | None -> [] @@ -2043,7 +2334,7 @@ module Ty = struct ) in let proofs = Cloning.replay_proofs scope `Check proofs in - + Ax.add_defer scope proofs (* ------------------------------------------------------------------ *) @@ -2508,3 +2799,14 @@ end notify scope `Info "%s" (Buffer.contents buffer) end + +(* -------------------------------------------------------------------- *) +module DocComment = struct + let add (scope : scope) ((kind, docc) : [`Global | `Item] * string) : scope = + match kind with + | `Global -> + { scope with sc_globdoc = scope.sc_globdoc @ [docc] } + + | `Item -> + { scope with sc_locdoc = DocState.push_docbl scope.sc_locdoc docc } +end diff --git a/src/ecScope.mli b/src/ecScope.mli index bc3c2812d1..d64007674c 100644 --- a/src/ecScope.mli +++ b/src/ecScope.mli @@ -54,9 +54,25 @@ and pucflags = { puc_local : bool; } +type docentity = + | ItemDoc of string list * docitem + | SubDoc of (string list * docitem) * docentity list + +and docitem = + mode * itemkind * string * string list (* dec/reg, kind, name, src *) + +and itemkind = [`Type | `Operator | `Axiom | `Lemma | `ModuleType | `Module | `Theory] + +and mode = [`Abstract | `Specific] + (* -------------------------------------------------------------------- *) val notify : scope -> EcGState.loglevel -> ('a, Format.formatter, unit, unit) format4 -> 'a +(* -------------------------------------------------------------------- *) +val get_gdocstrings : scope -> string list +val get_ldocentities : scope -> docentity list + + (* -------------------------------------------------------------------- *) val empty : EcGState.gstate -> scope val gstate : scope -> EcGState.gstate @@ -93,30 +109,30 @@ end (* -------------------------------------------------------------------- *) module Op : sig - val add : scope -> poperator located -> EcDecl.operator * string list * scope + val add : ?src:string -> scope -> poperator located -> EcDecl.operator * string list * scope - val add_opsem : scope -> pprocop located -> scope + val add_opsem : ?src:string -> scope -> pprocop located -> scope end (* -------------------------------------------------------------------- *) module Pred : sig - val add : scope -> ppredicate located -> EcDecl.operator * scope + val add : ?src:string -> scope -> ppredicate located -> EcDecl.operator * scope end (* -------------------------------------------------------------------- *) module Ax : sig type proofmode = [`WeakCheck | `Check | `Report] - val add : scope -> proofmode -> paxiom located -> symbol option * scope - val save : scope -> string option * scope - val admit : scope -> string option * scope - val abort : scope -> scope + val add : ?src:string -> scope -> proofmode -> paxiom located -> symbol option * scope + val save : ?src:string -> scope -> string option * scope + val admit : ?src:string -> scope -> string option * scope + val abort : ?src:string -> scope -> scope val realize : scope -> proofmode -> prealize located -> symbol option * scope end (* -------------------------------------------------------------------- *) module Ty : sig - val add : scope -> ptydecl located -> scope + val add : ?src:string -> scope -> ptydecl located -> scope val add_subtype : scope -> psubtype located -> scope val add_class : scope -> ptypeclass located -> scope @@ -125,14 +141,14 @@ end (* -------------------------------------------------------------------- *) module Mod : sig - val add : scope -> pmodule_def_or_decl -> scope + val add : ?src:string ->scope -> pmodule_def_or_decl -> scope val declare : scope -> pmodule_decl -> scope val import : scope -> pmsymbol located -> scope end (* -------------------------------------------------------------------- *) module ModType : sig - val add : scope -> pinterface -> scope + val add : ?src:string -> scope -> pinterface -> scope end (* -------------------------------------------------------------------- *) @@ -147,7 +163,7 @@ module Theory : sig (* [enter scope mode name] start a theory in scope [scope] with * name [name] and mode (abstract/concrete) [mode]. *) - val enter : scope -> thmode -> symbol -> EcTypes.is_local -> scope + val enter : ?src:string -> scope -> thmode -> symbol -> EcTypes.is_local -> scope (* [exit scope] close and finalize the top-most theory and returns * its name. Raises [TopScope] if [scope] has not super scope. *) @@ -195,8 +211,8 @@ module Tactics : sig type prinfos = proofenv * (handle * handle list) type proofmode = Ax.proofmode - val process : scope -> proofmode -> ptactic list -> prinfos option * scope - val proof : scope -> scope + val process : ?src:string -> scope -> proofmode -> ptactic list -> prinfos option * scope + val proof : ?src:string -> scope -> scope end (* -------------------------------------------------------------------- *) @@ -260,3 +276,8 @@ module Search : sig val search : scope -> pformula list -> unit val locate : scope -> pqsymbol -> unit end + +(* -------------------------------------------------------------------- *) +module DocComment : sig + val add : scope -> [`Global | `Item] * string -> scope +end diff --git a/src/ecSection.ml b/src/ecSection.ml index cdd5b1cb27..3534ea58e2 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -1443,7 +1443,7 @@ let genenv_of_scenv (scenv : scenv) : to_gen = ; tg_params = [] ; tg_binds = [] ; tg_subst = EcSubst.empty - ; tg_clear = empty_locals } + ; tg_clear = empty_locals } let generalize_lc_items scenv = let togen = @@ -1452,7 +1452,7 @@ let generalize_lc_items scenv = (EcEnv.root scenv.sc_env) (List.rev scenv.sc_items) in togen.tg_env - + (* -----------------------------------------------------------*) let import p scenv = { scenv with sc_env = EcEnv.Theory.import p scenv.sc_env } diff --git a/src/ecSymbols.ml b/src/ecSymbols.ml index e1e37313f4..9b2ee1cc62 100644 --- a/src/ecSymbols.ml +++ b/src/ecSymbols.ml @@ -87,3 +87,11 @@ let rec string_of_msymbol (mx : msymbol) = let pp_msymbol fmt x = Format.fprintf fmt "%s" (string_of_msymbol x) + +(* -------------------------------------------------------------------- *) +let qsymbol_of_string (s : string) : qsymbol = + let sspl = String.split_on_char '.' s in + match List.rev sspl with + | [] -> raise (invalid_arg "EcSymbols.qsymbol_of_string") + | [x] -> ([], x) + | x :: xs -> (List.rev xs, x) diff --git a/src/ecSymbols.mli b/src/ecSymbols.mli index a761df52fb..b42cb35e9c 100644 --- a/src/ecSymbols.mli +++ b/src/ecSymbols.mli @@ -32,3 +32,5 @@ val pp_qsymbol : Format.formatter -> qsymbol -> unit val pp_msymbol : Format.formatter -> msymbol -> unit val string_of_qsymbol : qsymbol -> string + +val qsymbol_of_string : string -> qsymbol \ No newline at end of file diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 7ed63fd890..94f7c048e5 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -15,7 +15,7 @@ type loglevel = EcGState.loglevel class type terminal = object method interactive : bool - method next : EcParsetree.prog + method next : string * EcParsetree.prog method notice : immediate:bool -> loglevel -> string -> unit method finish : status -> unit method finalize : unit @@ -70,7 +70,7 @@ object(self) end; Format.printf "[%d|%s]>\n%!" (EcCommands.uuid ()) (EcCommands.mode ()); - EcIo.parse iparser + EcIo.xparse iparser method notice ~(immediate:bool) (lvl : loglevel) (msg : string) = match immediate with @@ -116,7 +116,7 @@ object method next = Format.printf "[%d|%s]>\n%!" (EcCommands.uuid ()) (EcCommands.mode ()); EcIo.drain iparser; - EcIo.parse iparser + EcIo.xparse iparser method notice ~(immediate:bool) (_ : loglevel) (msg : string) = ignore immediate; @@ -271,8 +271,8 @@ class from_channel method interactive = false method next = - let aout = EcIo.parse iparser in - loc <- aout.LC.pl_loc; + let aout = EcIo.xparse iparser in + loc <- (snd aout).LC.pl_loc; self#_update_progress; aout method notice ~immediate lvl msg = diff --git a/src/ecTerminal.mli b/src/ecTerminal.mli index f18cee1ace..0a96a56d24 100644 --- a/src/ecTerminal.mli +++ b/src/ecTerminal.mli @@ -10,7 +10,7 @@ type loglevel = EcGState.loglevel (* -------------------------------------------------------------------- *) val interactive : terminal -> bool -val next : terminal -> EcParsetree.prog +val next : terminal -> string * EcParsetree.prog val notice : immediate:bool -> loglevel -> string -> terminal -> unit val finish : status -> terminal -> unit val finalize : terminal -> unit From eae4c78762e75bb512b13ec8051d92b8b066f147 Mon Sep 17 00:00:00 2001 From: Oskar Goldhahn Date: Wed, 19 Nov 2025 17:14:12 +0100 Subject: [PATCH 02/26] fix handling of bounds in conseq equiv phoare add tests for conseq equiv phoare --- src/phl/ecPhlConseq.ml | 31 ++++++++++++++++---------- tests/conseq_equiv_phoare.ec | 42 ++++++++++++++++++++++++++++++++++++ 2 files changed, 62 insertions(+), 11 deletions(-) create mode 100644 tests/conseq_equiv_phoare.ec diff --git a/src/phl/ecPhlConseq.ml b/src/phl/ecPhlConseq.ml index 90a07c86ff..bbbec8c990 100644 --- a/src/phl/ecPhlConseq.ml +++ b/src/phl/ecPhlConseq.ml @@ -785,26 +785,35 @@ let t_equivS_conseq_bd side pr po tc = (* -------------------------------------------------------------------- *) (* -(forall m1, P1 m1 => exists m2, P m1 m2 /\ P2 m2) +(forall m1, P1 m1 => exists m2, P m1 m2 /\ P2 m2 /\ q m1 = p m2) (forall m1 m2, Q m1 m2 => Q2 m2 => Q1 m1) -equiv M1 ~ M2 : P ==> Q hoare M2 : P2 ==> Q2. +equiv M1 ~ M2 : P ==> Q phoare M2 : P2 ==> Q2 R p. ----------------------------------------------- -hoare M1 : P1 ==> Q1. +phoare M1 : P1 ==> Q1 R q. *) -let transitivity_side_cond hyps prml poml pomr p q p2 q2 p1 q1 = +let transitivity_side_cond ?bds hyps prml poml pomr p q p2 q2 p1 q1 = let env = LDecl.toenv hyps in let cond1 = let fv1 = PV.fv env p.mr p.inv in let fv2 = PV.fv env p2.m p2.inv in let fv = PV.union fv1 fv2 in + let fv = match bds with + | Some (_, bd2) -> + let fvbd2 = PV.fv env bd2.m bd2.inv in + PV.union fv fvbd2 + | None -> fv in let elts, glob = PV.ntr_elements fv in let bd, s = generalize_subst env p2.m elts glob in let s1 = PVM.of_mpv s p.mr in let s2 = PVM.of_mpv s p2.m in - let concl = f_and (PVM.subst env s1 p.inv) (PVM.subst env s2 p2.inv) in - let p1 = ss_inv_rebind p1 p.ml in - f_forall_mems [prml] (f_imp p1.inv (f_exists bd concl)) in + let concl = {m=p1.m; inv=f_and (PVM.subst env s1 p.inv) (PVM.subst env s2 p2.inv)} in + let concl = match bds with + | Some (bd1, bd2) -> + let sbd = PVM.of_mpv s bd2.m in + map_ss_inv2 f_and concl (map_ss_inv1 (fun bd1 -> f_eq bd1 (PVM.subst env sbd bd2.inv)) bd1) + | None -> concl in + f_forall_mems_ss_inv prml (map_ss_inv2 f_imp p1 (map_ss_inv1 (f_exists bd) concl)) in let cond2 = let q1 = ss_inv_generalize_as_left q1 q.ml q.mr in let q2 = ss_inv_generalize_as_right q2 q.ml q.mr in @@ -821,14 +830,14 @@ let t_hoareF_conseq_equiv f2 p q p2 q2 tc = transitivity_side_cond hyps prml poml pomr p q p2 q2 (hf_pr hf1) (hf_po hf1) in FApi.xmutate1 tc `HoareFConseqEquiv [cond1; cond2; ef; hf2] -let t_bdHoareF_conseq_equiv f2 p q p2 q2 tc = +let t_bdHoareF_conseq_equiv f2 p q p2 q2 bd2 tc = let env, hyps, _ = FApi.tc1_eflat tc in let hf1 = tc1_as_bdhoareF tc in let ef = f_equivF p hf1.bhf_f f2 q in - let hf2 = f_bdHoareF p2 f2 q2 hf1.bhf_cmp (bhf_bd hf1) in + let hf2 = f_bdHoareF p2 f2 q2 hf1.bhf_cmp bd2 in let (prml, _prmr), (poml, pomr) = Fun.equivF_memenv p.ml p.mr hf1.bhf_f f2 env in let (cond1, cond2) = - transitivity_side_cond hyps prml poml pomr p q p2 q2 (bhf_pr hf1) (bhf_po hf1) in + transitivity_side_cond ~bds:(bhf_bd hf1, bd2) hyps prml poml pomr p q p2 q2 (bhf_pr hf1) (bhf_po hf1) in FApi.xmutate1 tc `BdHoareFConseqEquiv [cond1; cond2; ef; hf2] @@ -1152,7 +1161,7 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = let hf2 = pf_as_bdhoareF !!tc f2 in FApi.t_seqsub (t_bdHoareF_conseq_equiv hf2.bhf_f (ef_pr ef) (ef_po ef) - (bhf_pr hf2) (bhf_po hf2)) + (bhf_pr hf2) (bhf_po hf2) (bhf_bd hf2)) [t_id; t_id; t_apply_r nef; t_apply_r nf2] tc (* ------------------------------------------------------------------ *) diff --git a/tests/conseq_equiv_phoare.ec b/tests/conseq_equiv_phoare.ec new file mode 100644 index 0000000000..d6383d90ea --- /dev/null +++ b/tests/conseq_equiv_phoare.ec @@ -0,0 +1,42 @@ +require import Real Int. + +module M = { + var b: bool + + proc run() = { + M.b <- false; + } +}. + +lemma dep_bound : phoare[M.run : M.b ==> !M.b] = (b2i M.b)%r. +proof. by proc; auto => &hr ->. qed. + +equiv triv_equiv : M.run ~ M.run : true ==> ={M.b}. +proof. proc; auto. qed. + +lemma bad_bound : phoare[M.run : true ==> !M.b] = (b2i M.b)%r. +proof. +conseq triv_equiv dep_bound => //=. +move => &1. +fail smt(). +abort. + +lemma dep_bound_conseq : + phoare[M.run : !M.b ==> !M.b] = (1-b2i M.b)%r. +proof. +conseq triv_equiv dep_bound => //=. +move => &1 -> /=. +by exists true => />. +qed. + +lemma nodep_bound : phoare[M.run: true ==> true] = 1%r. +proof. proc; auto. qed. + +lemma nodep_bound_conseq : + phoare[M.run : !M.b ==> !M.b] = 1%r. +proof. +conseq triv_equiv dep_bound => //=. +move => &1 /> _. +by exists true. +qed. + From 2a87f9600cd308256f7430b9a0e56e486234884a Mon Sep 17 00:00:00 2001 From: oskgo <92018610+oskgo@users.noreply.github.com> Date: Thu, 18 Dec 2025 15:59:28 +0100 Subject: [PATCH 03/26] add manual trivial application to conseq variant (#848) --- src/phl/ecPhlConseq.ml | 2 +- tests/conseq_phoare_hoare.ec | 14 ++++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) create mode 100644 tests/conseq_phoare_hoare.ec diff --git a/src/phl/ecPhlConseq.ml b/src/phl/ecPhlConseq.ml index bbbec8c990..ebdc203d84 100644 --- a/src/phl/ecPhlConseq.ml +++ b/src/phl/ecPhlConseq.ml @@ -1129,7 +1129,7 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = t_intros_i [m;h0] @! t_cutdef (ptlocal ~args:[pamemory m; palocal h0] hi) mpre @! EcLowGoal.t_trivial; - t_mytrivial; + t_mytrivial @! t_intros_i [m; h0] @! t_apply_hyp h0; t_apply_hyp hh]; tac pre posta @+ [ t_apply_hyp hi; diff --git a/tests/conseq_phoare_hoare.ec b/tests/conseq_phoare_hoare.ec new file mode 100644 index 0000000000..021622544f --- /dev/null +++ b/tests/conseq_phoare_hoare.ec @@ -0,0 +1,14 @@ +require import Real. + +module Foo = {proc foo() = {}}. + +lemma foo_ll : islossless Foo.foo by islossless. + +op [opaque] p = predT<:int>. + +lemma foo_h: hoare [ Foo.foo : true ==> forall j, p j]. +proof. by proc; auto => /> j; rewrite /p. qed. + +lemma foo_p: phoare[ Foo.foo : true ==> forall j, p j] = 1%r. +by conseq foo_ll foo_h. +qed. From afe288fead283ae106ae806dd0cd93f460a828ae Mon Sep 17 00:00:00 2001 From: bgregoir Date: Thu, 18 Dec 2025 16:17:55 +0100 Subject: [PATCH 04/26] reduce when needed in proc and call rules (#849) * reduce in t_hF_or_bhF_or_eF * add reduction in call tactic --- src/ecLowGoal.ml | 9 +++--- src/ecLowGoal.mli | 4 +-- src/ecLowPhlGoal.ml | 67 +++++++++++++++++++++++++++-------------- src/ecProofTyping.ml | 23 +------------- src/ecProofTyping.mli | 5 --- src/ecReduction.ml | 14 ++++++--- src/ecReduction.mli | 10 +++++- src/phl/ecPhlApp.ml | 18 +++++------ src/phl/ecPhlCall.ml | 14 ++++----- src/phl/ecPhlCodeTx.ml | 18 +++++------ src/phl/ecPhlEager.ml | 8 ++--- src/phl/ecPhlEqobs.ml | 6 ++-- src/phl/ecPhlHiCond.ml | 6 ++-- src/phl/ecPhlInline.ml | 2 +- src/phl/ecPhlLoopTx.ml | 14 ++++----- src/phl/ecPhlOutline.ml | 2 +- src/phl/ecPhlRCond.ml | 10 +++--- src/phl/ecPhlRewrite.ml | 36 +++++++++++----------- src/phl/ecPhlRnd.ml | 24 +++++++-------- src/phl/ecPhlRwEquiv.ml | 3 +- tests/call_with_op.ec | 59 ++++++++++++++++++++++++++++++++++++ tests/proc_with_op.ec | 14 +++++++++ 22 files changed, 224 insertions(+), 142 deletions(-) create mode 100644 tests/call_with_op.ec create mode 100644 tests/proc_with_op.ec diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index fd20b27fda..1e9306ac2d 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -406,7 +406,8 @@ let t_hred_with_info ?target (ri : reduction_info) (tc : tcenv1) = FApi.tcenv_of_tcenv1 (t_change_r ~fail:true ?target action tc) (* -------------------------------------------------------------------- *) -let rec t_lazy_match ?(reduce = `Full) (tx : form -> FApi.backward) +let rec t_lazy_match ?(reduce = `Full) ?(texn = fun _ -> raise InvalidGoalShape) + (tx : form -> FApi.backward) (tc : tcenv1) = let concl = FApi.tc1_goal tc in try tx concl tc @@ -416,7 +417,7 @@ let rec t_lazy_match ?(reduce = `Full) (tx : form -> FApi.backward) | `None -> raise InvalidGoalShape | `Full -> EcReduction.full_red | `NoDelta -> EcReduction.nodelta in - FApi.t_seq (t_hred_with_info strategy) (t_lazy_match ~reduce tx) tc + FApi.t_seq (FApi.t_or (t_hred_with_info strategy) texn) (t_lazy_match ~reduce tx) tc (* -------------------------------------------------------------------- *) type smode = [ `Cbv | `Cbn ] @@ -2598,8 +2599,8 @@ let t_solve ?(canfail = true) ?(bases = [EcEnv.Auto.dname]) ?(mode = fmdelta) ?( let pt = PT.pt_of_uglobal !!tc (FApi.tc1_hyps tc) p in try Apply.t_apply_bwd_r ~ri ~mode ~canview:false pt tc - with Apply.NoInstance _ -> - t_fail tc + with Apply.NoInstance _ -> + t_fail tc in let rec t_apply ctn ip tc = diff --git a/src/ecLowGoal.mli b/src/ecLowGoal.mli index 56004018a8..ef5dca0989 100644 --- a/src/ecLowGoal.mli +++ b/src/ecLowGoal.mli @@ -69,7 +69,7 @@ val t_change : ?ri:EcReduction.reduction_info -> ?target:ident -> form -> FApi. (* -------------------------------------------------------------------- *) val t_lazy_match: - ?reduce:lazyred -> (form -> FApi.backward)-> FApi.backward + ?reduce:lazyred -> ?texn:EcCoreGoal.FApi.backward -> (form -> FApi.backward)-> FApi.backward (* -------------------------------------------------------------------- *) val t_reflex : ?mode:[`Alpha | `Conv] -> ?reduce:lazyred -> FApi.backward @@ -362,4 +362,4 @@ val pp_tc :tcenv -> unit [@@ocaml.alert debug "Debug function, remove uses before merging"] val pp_tc1 :tcenv1 -> unit - [@@ocaml.alert debug "Debug function, remove uses before merging"] \ No newline at end of file + [@@ocaml.alert debug "Debug function, remove uses before merging"] diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index 4bec3d0ca2..97fe5f0b46 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -206,6 +206,27 @@ let tc1_get_stmt side tc = | _ -> tc_error_noXhl ~kinds:(hlkinds_Xhl_r `Stmt) !!tc +(* ------------------------------------------------------------------ *) +let tc1_process_codepos_range tc (side, cpr) = + let me, _ = tc1_get_stmt side tc in + let env = FApi.tc1_env tc in + let env = EcEnv.Memory.push_active_ss me env in + EcTyping.trans_codepos_range env cpr + +(* ------------------------------------------------------------------ *) +let tc1_process_codepos tc (side, cpos) = + let me, _ = tc1_get_stmt side tc in + let env = FApi.tc1_env tc in + let env = EcEnv.Memory.push_active_ss me env in + EcTyping.trans_codepos env cpos + +(* ------------------------------------------------------------------ *) +let tc1_process_codepos1 tc (side, cpos) = + let me, _ = tc1_get_stmt side tc in + let env = FApi.tc1_env tc in + let env = EcEnv.Memory.push_active_ss me env in + EcTyping.trans_codepos1 env cpos + (* -------------------------------------------------------------------- *) let hl_set_stmt (side : side option) (f : form) (s : stmt) = match side, f.f_node with @@ -256,28 +277,28 @@ let tc1_get_post tc = (* -------------------------------------------------------------------- *) let set_pre ~pre f = match f.f_node, pre with - | FhoareF hf, Inv_ss pre -> + | FhoareF hf, Inv_ss pre -> let pre = ss_inv_rebind pre hf.hf_m in f_hoareF pre hf.hf_f (hf_po hf) - | FhoareS hs, Inv_ss pre -> + | FhoareS hs, Inv_ss pre -> let pre = ss_inv_rebind pre (fst hs.hs_m) in f_hoareS (snd hs.hs_m) pre hs.hs_s (hs_po hs) - | FeHoareF hf, Inv_ss pre -> + | FeHoareF hf, Inv_ss pre -> let pre = ss_inv_rebind pre hf.ehf_m in f_eHoareF pre hf.ehf_f (ehf_po hf) - | FeHoareS hs, Inv_ss pre -> + | FeHoareS hs, Inv_ss pre -> let pre = ss_inv_rebind pre (fst hs.ehs_m) in f_eHoareS (snd hs.ehs_m) pre hs.ehs_s (ehs_po hs) | FbdHoareF hf, Inv_ss pre -> let pre = ss_inv_rebind pre hf.bhf_m in f_bdHoareF pre hf.bhf_f (bhf_po hf) hf.bhf_cmp (bhf_bd hf) - | FbdHoareS hs, Inv_ss pre -> + | FbdHoareS hs, Inv_ss pre -> let pre = ss_inv_rebind pre (fst hs.bhs_m) in f_bdHoareS (snd hs.bhs_m) pre hs.bhs_s (bhs_po hs) hs.bhs_cmp (bhs_bd hs) - | FequivF ef, Inv_ts pre -> + | FequivF ef, Inv_ts pre -> let pre = ts_inv_rebind pre ef.ef_ml ef.ef_mr in f_equivF pre ef.ef_fl ef.ef_fr (ef_po ef) - | FequivS es, Inv_ts pre -> + | FequivS es, Inv_ts pre -> let pre = ts_inv_rebind pre (fst es.es_ml) (fst es.es_mr) in f_equivS (snd es.es_ml) (snd es.es_mr) pre es.es_sl es.es_sr (es_po es) | _ -> assert false @@ -307,33 +328,33 @@ let t_hS_or_bhS_or_eS ?th ?teh ?tbh ?te tc = | FeHoareS _ when EcUtils.is_some teh -> (oget teh) tc | FbdHoareS _ when EcUtils.is_some tbh -> (oget tbh) tc | FequivS _ when EcUtils.is_some te -> (oget te ) tc - | _ -> let kinds = List.flatten [ - if EcUtils.is_some th then [`Hoare `Stmt] else []; - if EcUtils.is_some teh then [`EHoare `Stmt] else []; - if EcUtils.is_some tbh then [`PHoare `Stmt] else []; - if EcUtils.is_some te then [`Equiv `Stmt] else []] - + if EcUtils.is_some th then [`Hoare `Stmt] else []; + if EcUtils.is_some teh then [`EHoare `Stmt] else []; + if EcUtils.is_some tbh then [`PHoare `Stmt] else []; + if EcUtils.is_some te then [`Equiv `Stmt] else []] in tc_error_noXhl ~kinds !!tc let t_hF_or_bhF_or_eF ?th ?teh ?tbh ?te ?teg tc = - match (FApi.tc1_goal tc).f_node with - | FhoareF _ when EcUtils.is_some th -> (oget th ) tc - | FeHoareF _ when EcUtils.is_some teh -> (oget teh) tc - | FbdHoareF _ when EcUtils.is_some tbh -> (oget tbh) tc - | FequivF _ when EcUtils.is_some te -> (oget te ) tc - | FeagerF _ when EcUtils.is_some teg -> (oget teg) tc - - | _ -> + let texn tc = let kinds = List.flatten [ if EcUtils.is_some th then [`Hoare `Pred] else []; if EcUtils.is_some teh then [`EHoare `Pred] else []; if EcUtils.is_some tbh then [`PHoare `Pred] else []; if EcUtils.is_some te then [`Equiv `Pred] else []; if EcUtils.is_some teg then [`Eager ] else []] + in tc_error_noXhl ~kinds !!tc in + let tx f tc = + match f.f_node with + | FhoareF _ when EcUtils.is_some th -> (oget th ) tc + | FeHoareF _ when EcUtils.is_some teh -> (oget teh) tc + | FbdHoareF _ when EcUtils.is_some tbh -> (oget tbh) tc + | FequivF _ when EcUtils.is_some te -> (oget te ) tc + | FeagerF _ when EcUtils.is_some teg -> (oget teg) tc + | _ -> raise EcProofTyping.NoMatch in + EcLowGoal.t_lazy_match ~texn tx tc - in tc_error_noXhl ~kinds !!tc (* -------------------------------------------------------------------- *) let tag_sym_with_side ?mc name m = @@ -672,7 +693,7 @@ let t_code_transform (side : oside) ?(bdhoare = false) cpos tr tx tc = let pr, po = bhs_pr bhs, bhs_po bhs in let (me, stmt, cs) = tx (pf, hyps) cpos (pr.inv, po.inv) (bhs.bhs_m, bhs.bhs_s) in - let concl = f_bdHoareS (snd me) (bhs_pr bhs) stmt (bhs_po bhs) + let concl = f_bdHoareS (snd me) (bhs_pr bhs) stmt (bhs_po bhs) bhs.bhs_cmp (bhs_bd bhs) in FApi.xmutate1 tc (tr None) (cs @ [concl]) diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index 73164e4746..abc49d124b 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -132,7 +132,7 @@ let tc1_process_stmt ?map hyps tc c = let tc1_process_prhl_stmt ?map tc side c = let concl = FApi.tc1_goal tc in - let ml, mr = match concl.f_node with + let ml, mr = match concl.f_node with | FequivS {es_ml=ml; es_mr=mr} -> (ml, mr) | FeagerF {eg_ml=ml; eg_mr=mr} -> EcMemory.abstract ml, EcMemory.abstract mr @@ -188,27 +188,6 @@ let tc1_process_Xhl_formula ?side tc pf = let tc1_process_Xhl_formula_xreal tc pf = tc1_process_Xhl_form tc txreal pf -(* ------------------------------------------------------------------ *) -let tc1_process_codepos_range tc (side, cpr) = - let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in - let env = FApi.tc1_env tc in - let env = EcEnv.Memory.push_active_ss me env in - EcTyping.trans_codepos_range env cpr - -(* ------------------------------------------------------------------ *) -let tc1_process_codepos tc (side, cpos) = - let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in - let env = FApi.tc1_env tc in - let env = EcEnv.Memory.push_active_ss me env in - EcTyping.trans_codepos env cpos - -(* ------------------------------------------------------------------ *) -let tc1_process_codepos1 tc (side, cpos) = - let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in - let env = FApi.tc1_env tc in - let env = EcEnv.Memory.push_active_ss me env in - EcTyping.trans_codepos1 env cpos - (* ------------------------------------------------------------------ *) (* FIXME: factor out to typing module *) (* FIXME: TC HOOK - check parameter constraints *) diff --git a/src/ecProofTyping.mli b/src/ecProofTyping.mli index b450ac1890..359b570455 100644 --- a/src/ecProofTyping.mli +++ b/src/ecProofTyping.mli @@ -4,7 +4,6 @@ open EcIdent open EcDecl open EcEnv open EcCoreGoal -open EcMatching.Position open EcAst (* -------------------------------------------------------------------- *) @@ -59,10 +58,6 @@ val tc1_process_prhl_stmt : val tc1_process_Xhl_stmt : ?map:EcTyping.ismap -> tcenv1 -> pstmt -> stmt -val tc1_process_codepos_range : tcenv1 -> oside * pcodepos_range -> codepos_range -val tc1_process_codepos : tcenv1 -> oside * pcodepos -> codepos -val tc1_process_codepos1 : tcenv1 -> oside * pcodepos1 -> codepos1 - (* -------------------------------------------------------------------- *) exception NoMatch diff --git a/src/ecReduction.ml b/src/ecReduction.ml index 1dce11fabf..976c52312a 100644 --- a/src/ecReduction.ml +++ b/src/ecReduction.ml @@ -1258,23 +1258,23 @@ let rec simplify ri env f = match f.f_node with | FhoareF hf when ri.ri.modpath -> let hf_f = EcEnv.NormMp.norm_xfun env hf.hf_f in - f_map (fun ty -> ty) (simplify ri env) + f_map (fun ty -> ty) (simplify ri env) (f_hoareF (hf_pr hf) hf_f (hf_po hf)) | FeHoareF hf when ri.ri.modpath -> let ehf_f = EcEnv.NormMp.norm_xfun env hf.ehf_f in - f_map (fun ty -> ty) (simplify ri env) + f_map (fun ty -> ty) (simplify ri env) (f_eHoareF (ehf_pr hf) ehf_f (ehf_po hf)) | FbdHoareF hf when ri.ri.modpath -> let bhf_f = EcEnv.NormMp.norm_xfun env hf.bhf_f in - f_map (fun ty -> ty) (simplify ri env) + f_map (fun ty -> ty) (simplify ri env) (f_bdHoareF (bhf_pr hf) bhf_f (bhf_po hf) hf.bhf_cmp (bhf_bd hf)) | FequivF ef when ri.ri.modpath -> let ef_fl = EcEnv.NormMp.norm_xfun env ef.ef_fl in let ef_fr = EcEnv.NormMp.norm_xfun env ef.ef_fr in - f_map (fun ty -> ty) (simplify ri env) + f_map (fun ty -> ty) (simplify ri env) (f_equivF (ef_pr ef) ef_fl ef_fr (ef_po ef)) | FeagerF eg when ri.ri.modpath -> @@ -1666,6 +1666,12 @@ let h_red_opt ri hyps f = try Some (h_red ri hyps f) with NotReducible -> None +let rec h_red_until ?(until = fun _ -> false) ri hyps f = + if until f then f + else match h_red ri hyps f with + | f -> h_red_until ~until ri hyps f + | exception NotReducible -> f + (* -------------------------------------------------------------------- *) type xconv = [`Eq | `AlphaEq | `Conv] diff --git a/src/ecReduction.mli b/src/ecReduction.mli index 116cb80150..27dea22f8d 100644 --- a/src/ecReduction.mli +++ b/src/ecReduction.mli @@ -88,6 +88,14 @@ val reduce_logic : reduction_info -> env -> LDecl.hyps -> form -> form val h_red_opt : reduction_info -> LDecl.hyps -> form -> form option val h_red : reduction_info -> LDecl.hyps -> form -> form +(* [hred_until ~until ri hyps f] performs head reduction on [f] + until [test f] is true or that no more head reduction is possible. + If no [until] argument is provided then head reduction is performed + until it is possible. +*) +val h_red_until : + ?until:(form -> bool) -> reduction_info -> LDecl.hyps -> form -> form + val reduce_user_gen : (EcFol.form -> EcFol.form) -> reduction_info -> @@ -109,4 +117,4 @@ type xconv = [`Eq | `AlphaEq | `Conv] val xconv : xconv -> LDecl.hyps -> form -> form -> bool val ss_inv_alpha_eq : LDecl.hyps -> ss_inv -> ss_inv -> bool -val ts_inv_alpha_eq : LDecl.hyps -> ts_inv -> ts_inv -> bool \ No newline at end of file +val ts_inv_alpha_eq : LDecl.hyps -> ts_inv -> ts_inv -> bool diff --git a/src/phl/ecPhlApp.ml b/src/phl/ecPhlApp.ml index d632864299..3984e25360 100644 --- a/src/phl/ecPhlApp.ml +++ b/src/phl/ecPhlApp.ml @@ -67,7 +67,7 @@ let t_bdhoare_app_r_low i (phi, pR, f1, f2, g1, g2) tc = let (ir1, ir2) = EcIdent.create "r", EcIdent.create "r" in let (r1 , r2 ) = f_local ir1 treal, f_local ir2 treal in let condnm = - let eqs = map_ss_inv2 f_and (map_ss_inv1 ((EcUtils.flip f_eq) r1) f2) + let eqs = map_ss_inv2 f_and (map_ss_inv1 ((EcUtils.flip f_eq) r1) f2) (map_ss_inv1 ((EcUtils.flip f_eq) r2) g2) in f_forall [(ir1, GTty treal); (ir2, GTty treal)] @@ -124,11 +124,11 @@ let t_equiv_app_onesided side i pre post tc = let (ml, mr) = fst es.es_ml, fst es.es_mr in let s, s', p', q' = match side with - | `Left -> + | `Left -> let p' = ss_inv_generalize_right (EcSubst.ss_inv_rebind pre ml) mr in let q' = ss_inv_generalize_right (EcSubst.ss_inv_rebind post ml) mr in es.es_sl, es.es_sr, p', q' - | `Right -> + | `Right -> let p' = ss_inv_generalize_left (EcSubst.ss_inv_rebind pre mr) ml in let q' = ss_inv_generalize_left (EcSubst.ss_inv_rebind post mr) ml in es.es_sr, es.es_sl, p', q' @@ -227,13 +227,13 @@ let process_app (side, dir, k, phi, bd_info) tc = | Single i, PAppNone when is_hoareS concl -> check_side side; let _, phi = TTC.tc1_process_Xhl_formula tc (get_single phi) in - let i = EcProofTyping.tc1_process_codepos1 tc (side, i) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (side, i) in t_hoare_app i phi tc | Single i, PAppNone when is_eHoareS concl -> check_side side; let _, phi = TTC.tc1_process_Xhl_formula_xreal tc (get_single phi) in - let i = EcProofTyping.tc1_process_codepos1 tc (side, i) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (side, i) in t_ehoare_app i phi tc | Single i, PAppNone when is_equivS concl -> @@ -248,21 +248,21 @@ let process_app (side, dir, k, phi, bd_info) tc = match side with | None -> tc_error !!tc "seq onsided: side information expected" | Some side -> side in - let i = EcProofTyping.tc1_process_codepos1 tc (Some side, i) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (Some side, i) in t_equiv_app_onesided side i pre post tc | Single i, _ when is_bdHoareS concl -> check_side side; let _, pia = TTC.tc1_process_Xhl_formula tc (get_single phi) in let (ra, f1, f2, f3, f4) = process_phl_bd_info dir bd_info tc in - let i = EcProofTyping.tc1_process_codepos1 tc (side, i) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (side, i) in t_bdhoare_app i (ra, pia, f1, f2, f3, f4) tc | Double (i, j), PAppNone when is_equivS concl -> check_side side; let phi = TTC.tc1_process_prhl_formula tc (get_single phi) in - let i = EcProofTyping.tc1_process_codepos1 tc (Some `Left, i) in - let j = EcProofTyping.tc1_process_codepos1 tc (Some `Left, j) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left, i) in + let j = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left, j) in t_equiv_app (i, j) phi tc | Single _, PAppNone diff --git a/src/phl/ecPhlCall.ml b/src/phl/ecPhlCall.ml index 298e0588d6..8231b9f279 100644 --- a/src/phl/ecPhlCall.ml +++ b/src/phl/ecPhlCall.ml @@ -152,7 +152,7 @@ let t_ehoare_call fpre fpost tc = let t_ehoare_call_concave f fpre fpost tc = let _, _, _, s, _, wppre, wppost = ehoare_call_pre_post fpre fpost tc in let tcenv = - EcPhlApp.t_ehoare_app (EcMatching.Zipper.cpos (List.length s.s_node)) + EcPhlApp.t_ehoare_app (EcMatching.Zipper.cpos (List.length s.s_node)) (map_ss_inv2 (fun wppre f -> f_app_simpl f [wppre] txreal) wppre f) tc in let tcenv = FApi.t_swap_goals 0 1 tcenv in let t_call = @@ -219,7 +219,7 @@ let t_bdhoare_call fpre fpost opt_bd tc = let post = map_ss_inv2 f_anda_simpl (map_ss_inv1 (PVM.subst env spre) fpre) post in (* most of the above code is duplicated from t_hoare_call *) - let concl = + let concl = let _,mt = bhs.bhs_m in match bhs.bhs_cmp, opt_bd with | FHle, None -> @@ -325,8 +325,8 @@ let call_error env tc f1 f2 = let t_call side ax tc = let env = FApi.tc1_env tc in - let concl = FApi.tc1_goal tc in - + let hyps, concl = FApi.tc1_flat tc in + let ax = EcReduction.h_red_until EcReduction.full_red hyps ax in match ax.f_node, concl.f_node with | FhoareF hf, FhoareS hs -> let (_, f, _), _ = tc1_last_call tc hs.hs_s in @@ -418,7 +418,7 @@ let process_call side info tc = let m = (EcIdent.create "&hr") in let penv, qenv = LDecl.hoareF m f hyps in let pre = TTC.pf_process_form !!tc penv tbool pre in - let post = TTC.pf_process_form !!tc qenv tbool post in + let post = TTC.pf_process_form !!tc qenv tbool post in f_hoareF {m;inv=pre} f {m;inv=post} | FbdHoareS bhs, None -> @@ -435,7 +435,7 @@ let process_call side info tc = let m = (EcIdent.create "&hr") in let penv, qenv = LDecl.hoareF m f hyps in let pre = TTC.pf_process_form !!tc penv txreal pre in - let post = TTC.pf_process_form !!tc qenv txreal post in + let post = TTC.pf_process_form !!tc qenv txreal post in f_eHoareF {m;inv=pre} f {m;inv=post} | FbdHoareS _, Some _ @@ -448,7 +448,7 @@ let process_call side info tc = let (ml, mr) = (EcIdent.create "&1", EcIdent.create "&2") in let penv, qenv = LDecl.equivF ml mr fl fr hyps in let pre = TTC.pf_process_form !!tc penv tbool pre in - let post = TTC.pf_process_form !!tc qenv tbool post in + let post = TTC.pf_process_form !!tc qenv tbool post in f_equivF {ml;mr;inv=pre} fl fr {ml;mr;inv=post} | FequivS es, Some side -> diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index 0cc9e48b4f..f3ec2c513c 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -236,11 +236,11 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( | e, _ -> [e] in let lv = lv_to_ty_list lv in - + let tosubst, asgn2 = List.partition (fun ((pv, _), e) -> Mpv.mem env pv subst0 && is_const_expression e ) (List.combine lv es) in - + let subst = List.fold_left (fun subst ((pv, _), e) -> Mpv.add env pv e subst) @@ -342,24 +342,24 @@ let t_cfold = FApi.t_low3 "code-tx-cfold" t_cfold_r (* -------------------------------------------------------------------- *) let process_cfold (side, cpos, olen) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_cfold side cpos olen tc let process_kill (side, cpos, len) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_kill side cpos len tc let process_alias (side, cpos, id) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_alias side cpos id tc let process_set (side, cpos, fresh, id, e) tc = let e = TTC.tc1_process_Xhl_exp tc side None e in - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_set side cpos (fresh, id) e tc let process_set_match (side, cpos, id, pattern) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in let me, _ = tc1_get_stmt side tc in let hyps = LDecl.push_active_ss me (FApi.tc1_hyps tc) in let ue = EcProofTyping.unienv_of_hyps hyps in @@ -368,7 +368,7 @@ let process_set_match (side, cpos, id, pattern) tc = t_set_match side cpos (EcLocation.unloc id) (ue, EcMatching.MEV.of_idents (Mid.keys !ptnmap) `Form, pattern) tc - + (* -------------------------------------------------------------------- *) let process_weakmem (side, id, params) tc = let open EcLocation in @@ -459,7 +459,7 @@ let process_case ((side, pos) : side option * pcodepos) (tc : tcenv1) = assert false; let _, s = EcLowPhlGoal.tc1_get_stmt side tc in - let pos = EcProofTyping.tc1_process_codepos tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos tc (side, pos) in let goals, s = EcMatching.Zipper.map env pos change s in let concl = EcLowPhlGoal.hl_set_stmt side concl s in diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml index a99092c829..72859bb28a 100644 --- a/src/phl/ecPhlEager.ml +++ b/src/phl/ecPhlEager.ml @@ -140,7 +140,7 @@ let t_eager_if_r tc = let fe = ss_inv_generalize_right (ss_inv_of_expr ml e) mr in let eqb = map_ts_inv2 f_eq fe {ml;mr;inv=f_local b tbool} in - EcSubst.f_forall_mems_ss_inv es.es_mr + EcSubst.f_forall_mems_ss_inv es.es_mr (map_ss_inv1 (f_forall [(b, GTty tbool)]) (ts_inv_lower_left2 (fun pr po -> f_hoareS (snd es.es_ml) pr s po) (map_ts_inv2 f_and (es_pr es) eqb) eqb)) in @@ -196,7 +196,7 @@ let t_eager_while_r h tc = and bT = f_equivS (snd eC.es_ml) (snd eC.es_mr) (map_ts_inv2 f_and_simpl eqI e1) (stmt (s.s_node@c.s_node)) (stmt (c'.s_node@s'.s_node)) eqI - + and cT = f_equivS (snd eC.es_mr) (snd eC.es_mr) eqI2 c' c' eqI2 in @@ -574,8 +574,8 @@ let process_info info tc = let process_seq info (i, j) eqR tc = let eqR = TTC.tc1_process_prhl_form tc tbool eqR in let gs, h = process_info info tc in - let i = EcProofTyping.tc1_process_codepos1 tc (Some `Left , i) in - let j = EcProofTyping.tc1_process_codepos1 tc (Some `Right, j) in + let i = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left , i) in + let j = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Right, j) in FApi.t_last (t_eager_seq i j eqR h) gs (* -------------------------------------------------------------------- *) diff --git a/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml index 6fc4497fda..8466ac9351 100644 --- a/src/phl/ecPhlEqobs.ml +++ b/src/phl/ecPhlEqobs.ml @@ -469,8 +469,8 @@ let process_eqobs_inS info tc = (FApi.t_try (FApi.t_seq EcPhlSkip.t_skip t_trivial)) (t_eqobs_inS sim eqo tc) | Some(p1,p2) -> - let p1 = EcProofTyping.tc1_process_codepos1 tc (Some `Left , p1) in - let p2 = EcProofTyping.tc1_process_codepos1 tc (Some `Right, p2) in + let p1 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left , p1) in + let p2 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Right, p2) in let _,sl2 = s_split env p1 es.es_sl in let _,sr2 = s_split env p2 es.es_sr in let _, eqi = @@ -499,7 +499,7 @@ let process_eqobs_inF info tc = let fl = ef.ef_fl and fr = ef.ef_fr in let eqo = match info.EcParsetree.sim_eqs with - | Some pf -> + | Some pf -> let _,(mle,mre) = Fun.equivF_memenv ml mr fl fr env in let hyps = LDecl.push_active_ts mle mre hyps in process_eqs env tc {ml; mr; inv=TTC.pf_process_form !!tc hyps tbool pf} diff --git a/src/phl/ecPhlHiCond.ml b/src/phl/ecPhlHiCond.ml index 77ffeb1b2d..89225fb4de 100644 --- a/src/phl/ecPhlHiCond.ml +++ b/src/phl/ecPhlHiCond.ml @@ -22,8 +22,8 @@ let process_cond (info : EcParsetree.pcond_info) tc = | `Seq (side, (i1, i2), f) -> let es = tc1_as_equivS tc in let f = EcProofTyping.tc1_process_prhl_formula tc f in - let i1 = Option.map (fun i1 -> EcProofTyping.tc1_process_codepos1 tc (side, i1)) i1 in - let i2 = Option.map (fun i2 -> EcProofTyping.tc1_process_codepos1 tc (side, i2)) i2 in + let i1 = Option.map (fun i1 -> EcLowPhlGoal.tc1_process_codepos1 tc (side, i1)) i1 in + let i2 = Option.map (fun i2 -> EcLowPhlGoal.tc1_process_codepos1 tc (side, i2)) i2 in let n1 = default_if i1 es.es_sl in let n2 = default_if i2 es.es_sr in FApi.t_seqsub (EcPhlApp.t_equiv_app (n1, n2) f) @@ -31,7 +31,7 @@ let process_cond (info : EcParsetree.pcond_info) tc = | `SeqOne (s, i, f1, f2) -> let es = tc1_as_equivS tc in - let i = Option.map (fun i1 -> EcProofTyping.tc1_process_codepos1 tc (Some s, i1)) i in + let i = Option.map (fun i1 -> EcLowPhlGoal.tc1_process_codepos1 tc (Some s, i1)) i in let n = default_if i (match s with `Left -> es.es_sl | `Right -> es.es_sr) in let _, f1 = EcProofTyping.tc1_process_Xhl_formula ~side:s tc f1 in let _, f2 = EcProofTyping.tc1_process_Xhl_formula ~side:s tc f2 in diff --git a/src/phl/ecPhlInline.ml b/src/phl/ecPhlInline.ml index bdf1a7ef64..d40f5ab8b8 100644 --- a/src/phl/ecPhlInline.ml +++ b/src/phl/ecPhlInline.ml @@ -407,7 +407,7 @@ let process_inline_occs ~use_tuple side cond occs tc = let process_inline_codepos ~use_tuple side pos tc = let env = FApi.tc1_env tc in let concl = FApi.tc1_goal tc in - let pos = EcProofTyping.tc1_process_codepos tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos tc (side, pos) in try match concl.f_node, side with diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index bef1209842..434dece2ce 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -205,18 +205,18 @@ let t_splitwhile = FApi.t_low3 "split-while" t_splitwhile_r (* -------------------------------------------------------------------- *) let process_fission (side, cpos, infos) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_fission side cpos infos tc let process_fusion (side, cpos, infos) tc = - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_fusion side cpos infos tc let process_splitwhile (b, side, cpos) tc = let b = try TTC.tc1_process_Xhl_exp tc side (Some tbool) b with EcFol.DestrError _ -> tc_error !!tc "goal must be a *HL statement" in - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_splitwhile b side cpos tc (* -------------------------------------------------------------------- *) @@ -228,7 +228,7 @@ let process_unroll_for side cpos tc = if not (List.is_empty (fst cpos)) then tc_error !!tc "cannot use deep code position"; - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in let z, cpos = Zpr.zipper_of_cpos_r env cpos c in let pos = 1 + List.length z.Zpr.z_head in @@ -305,7 +305,7 @@ let process_unroll_for side cpos tc = let t_conseq_nm tc = match (tc1_get_pre tc) with - | Inv_ss inv -> + | Inv_ss inv -> (EcPhlConseq.t_hoareS_conseq_nm inv {m=inv.m;inv=f_true} @+ [ t_trivial; t_trivial; EcPhlTAuto.t_hoare_true]) tc | _ -> tc_error !!tc "expecting single sided precondition" in @@ -337,6 +337,6 @@ let process_unroll (side, cpos, for_) tc = if for_ then process_unroll_for side cpos tc else begin - let cpos = EcProofTyping.tc1_process_codepos tc (side, cpos) in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_unroll side cpos tc - end \ No newline at end of file + end diff --git a/src/phl/ecPhlOutline.ml b/src/phl/ecPhlOutline.ml index 1fd63d0bb4..2898a138b5 100644 --- a/src/phl/ecPhlOutline.ml +++ b/src/phl/ecPhlOutline.ml @@ -59,7 +59,7 @@ let process_outline info tc = let ppe = EcPrinting.PPEnv.ofenv env in let range = - EcProofTyping.tc1_process_codepos_range tc + EcLowPhlGoal.tc1_process_codepos_range tc (Some side, info.outline_range) in try diff --git a/src/phl/ecPhlRCond.ml b/src/phl/ecPhlRCond.ml index 20bd429ad6..d45a50ede3 100644 --- a/src/phl/ecPhlRCond.ml +++ b/src/phl/ecPhlRCond.ml @@ -79,7 +79,7 @@ module Low = struct let ss_inv_generalize_other = sideif side ss_inv_generalize_right ss_inv_generalize_left in let hd,_,e,s = gen_rcond (!!tc, env) b (fst m) at_pos s in let e = ss_inv_generalize_other e (fst mo) in - let concl1 = + let concl1 = EcSubst.f_forall_mems_ss_inv (EcIdent.create "&m", snd mo) (ts_inv_lower_side2 (fun pr po -> let mhs = EcIdent.create "&hr" in @@ -112,7 +112,7 @@ let t_rcond side b at_pos tc = Low.t_equiv_rcond side b at_pos tc let process_rcond side b at_pos tc = - let at_pos = EcProofTyping.tc1_process_codepos1 tc (side, at_pos) in + let at_pos = EcLowPhlGoal.tc1_process_codepos1 tc (side, at_pos) in t_rcond side b at_pos tc (* -------------------------------------------------------------------- *) @@ -266,12 +266,12 @@ module LowMatch = struct let (epr, hd, po1), (me, full) = gen_rcond_full (!!tc, FApi.tc1_env tc) c m at_pos s in - let ss_inv_generalize_other inv = sideif side + let ss_inv_generalize_other inv = sideif side (ss_inv_generalize_right inv mr) (ss_inv_generalize_left inv ml) in let epr = omap (fun epr -> ss_inv_generalize_other (ss_inv_rebind epr (fst m))) epr in - + let ts_inv_lower_side1 = sideif side ts_inv_lower_left1 ts_inv_lower_right1 in @@ -319,5 +319,5 @@ let t_rcond_match side c at_pos tc = (* -------------------------------------------------------------------- *) let process_rcond_match side c at_pos tc = - let at_pos = EcProofTyping.tc1_process_codepos1 tc (side, at_pos) in + let at_pos = EcLowPhlGoal.tc1_process_codepos1 tc (side, at_pos) in t_rcond_match side c at_pos tc diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index da50578552..57abab3d51 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -55,7 +55,7 @@ let process_change (form : pexpr) (tc : tcenv1) = - let pos = EcProofTyping.tc1_process_codepos tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos tc (side, pos) in let expr (e : expr) ((hyps, m) : LDecl.hyps * memenv) = let hyps = LDecl.push_active_ss m hyps in @@ -96,7 +96,7 @@ let process_rewrite_rw let f2 = EcProofTerm.concretize_form pt.ptev_env f2 in let pt, _ = EcProofTerm.concretize pt in - let cpos = + let cpos = EcMatching.FPosition.select_form ~xconv:`AlphaEq ~keyed:occmode.k_keyed hyps None subf.inv e.inv in @@ -118,7 +118,7 @@ let process_rewrite_rw (m, data), expr_of_ss_inv e in - let pos = EcProofTyping.tc1_process_codepos tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos tc (side, pos) in let (m, (pt, mode, cpos)), tc = t_change side pos change tc in let cpos = EcMatching.FPosition.reroot [1] cpos in @@ -147,7 +147,7 @@ let change (e : expr) ((hyps, me) : LDecl.hyps * memenv) = (fst me, f), e in - let pos = EcProofTyping.tc1_process_codepos tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos tc (side, pos) in let (m, f), tc = t_change side pos change tc in FApi.t_first ( @@ -172,20 +172,20 @@ let process_rewrite (* -------------------------------------------------------------------- *) let t_change_stmt (side : side option) - (pos : EcMatching.Position.codepos_range) + (pos : EcMatching.Position.codepos_range) (s : stmt) (tc : tcenv1) = let env = FApi.tc1_env tc in - let me, stmt = EcLowPhlGoal.tc1_get_stmt side tc in + let me, stmt = EcLowPhlGoal.tc1_get_stmt side tc in let (zpr, _), (stmt, epilog) = EcMatching.Zipper.zipper_and_split_of_cpos_range env pos stmt in let pvs = EcPV.is_write env (stmt @ s.s_node) in let pvs, globs = EcPV.PV.elements pvs in - let pre_pvs, pre_globs = EcPV.PV.elements @@ EcPV.PV.inter - (EcPV.is_read env stmt) + let pre_pvs, pre_globs = EcPV.PV.elements @@ EcPV.PV.inter + (EcPV.is_read env stmt) (EcPV.is_read env s.s_node) in @@ -201,7 +201,7 @@ let t_change_stmt (fun mp -> f_eqglob mp mleft mp mright) globs in - let pre_eq = + let pre_eq = List.map (fun (pv, ty) -> f_eq (f_pvar pv ty mleft).inv (f_pvar pv ty mright).inv) pre_pvs @@ -214,7 +214,7 @@ let t_change_stmt let goal1 = f_equivS (snd me) (snd me) - {ml=mleft; mr=mright; inv=f_ands pre_eq} + {ml=mleft; mr=mright; inv=f_ands pre_eq} (EcAst.stmt stmt) s {ml=mleft; mr=mright; inv=f_ands eq} in @@ -238,31 +238,31 @@ let process_change_stmt let env = FApi.tc1_env tc in begin match side, (FApi.tc1_goal tc).f_node with - | _, FhoareF _ + | _, FhoareF _ | _, FeHoareF _ | _, FequivF _ | _, FbdHoareF _ -> tc_error !!tc "Expecting goal with inlined program code" - | Some _, FhoareS _ + | Some _, FhoareS _ | Some _, FeHoareS _ | Some _, FbdHoareS _-> tc_error !!tc "Tactic should not receive side for non-relational goal" | None, FequivS _ -> tc_error !!tc "Tactic requires side selector for relational goal" - | None, FhoareS _ + | None, FhoareS _ | None, FeHoareS _ | None, FbdHoareS _ | Some _ , FequivS _ -> () | _ -> tc_error !!tc "Wrong goal shape, expecting hoare or equiv goal with inlined code" end; - let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in + let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in - let pos = + let pos = let env = EcEnv.Memory.push_active_ss me env in - EcTyping.trans_codepos_range ~memory:(fst me) env pos + EcTyping.trans_codepos_range ~memory:(fst me) env pos in - let s = match side with + let s = match side with | Some side -> EcProofTyping.tc1_process_prhl_stmt tc side s - | None -> EcProofTyping.tc1_process_Xhl_stmt tc s + | None -> EcProofTyping.tc1_process_Xhl_stmt tc s in t_change_stmt side pos s tc diff --git a/src/phl/ecPhlRnd.ml b/src/phl/ecPhlRnd.ml index 48a8ed32f0..35bb3de4d1 100644 --- a/src/phl/ecPhlRnd.ml +++ b/src/phl/ecPhlRnd.ml @@ -51,7 +51,7 @@ module Core = struct let m = fst hs.ehs_m in let distr = EcFol.ss_inv_of_expr m distr in let post = subst_form_lv env lv {m;inv=x} (ehs_po hs) in - let post = map_ss_inv2 (f_Ep ty_distr) distr + let post = map_ss_inv2 (f_Ep ty_distr) distr (map_ss_inv1 (f_lambda [(x_id,GTty ty_distr)]) post) in let concl = f_eHoareS (snd hs.ehs_m) (ehs_pr hs) s post in FApi.xmutate1 tc `Rnd [concl] @@ -211,7 +211,7 @@ module Core = struct | PNoRndParams, FHle -> if is_post_indep then (* event is true *) - let concl = f_bdHoareS (snd bhs.bhs_m) + let concl = f_bdHoareS (snd bhs.bhs_m) (bhs_pr bhs) s (bhs_po bhs) bhs.bhs_cmp (bhs_bd bhs) in [concl] else @@ -273,7 +273,7 @@ module Core = struct let post = map_ss_inv2 f_anda bounded_distr (mk_event_cond event) in f_forall_mems_ss_inv bhs.bhs_m (map_ss_inv2 f_imp (map_ss_inv1 f_not phi) post) in let sgoal5 = - let f_inbound x = + let f_inbound x = let f_r1, f_r0 = {m;inv=f_r1}, {m;inv=f_r0} in map_ss_inv2 f_anda (map_ss_inv2 f_real_le f_r0 x) (map_ss_inv2 f_real_le x f_r1) in map_ss_inv f_ands (List.map f_inbound [d1; d2; d3; d4]) @@ -525,11 +525,11 @@ let wp_equiv_rnd_r bij tc = let po = match hdc2, hdc3 with | None , None -> None - | Some _, Some _ -> + | Some _, Some _ -> Some (map_ts_inv2 f_anda c1 (map_ts_inv1 (f_forall [x, xty]) (map_ts_inv2 f_imp ind c4))) - | Some _, None -> + | Some _, None -> Some (map_ts_inv2 f_anda c1 (map_ts_inv1 (f_forall [x, xty]) (map_ts_inv2 f_imp ind (map_ts_inv2 f_anda c3 c4)))) - | None , Some _ -> + | None , Some _ -> Some (map_ts_inv f_andas [c1; c2; map_ts_inv1 (f_forall [x, xty]) (map_ts_inv2 f_imp ind c4)]) in @@ -590,7 +590,7 @@ let t_equiv_rnd_r side pos bij_info tc = match side, pos, bij_info with | Some side, None, (None, None) -> wp_equiv_disj_rnd_r side tc - | Some side, None, _ -> + | Some _side, None, _ -> tc_error !!tc "one-sided rnd takes no arguments" | None, _, _ -> begin let pos = @@ -683,16 +683,16 @@ let process_rnd side pos tac_info tc = | Single (b, p) -> let p = if Option.is_some side then - EcProofTyping.tc1_process_codepos1 tc (side, p) + EcLowPhlGoal.tc1_process_codepos1 tc (side, p) else EcTyping.trans_codepos1 (FApi.tc1_env tc) p in Single (b, p) | Double ((b1, p1), (b2, p2)) -> - let p1 = EcProofTyping.tc1_process_codepos1 tc (Some `Left , p1) in - let p2 = EcProofTyping.tc1_process_codepos1 tc (Some `Right, p2) in + let p1 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left , p1) in + let p2 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Right, p2) in Double ((b1, p1), (b2, p2)) ) in - + t_equiv_rnd side ?pos bij_info tc | _ -> tc_error !!tc "invalid arguments" @@ -705,7 +705,7 @@ let t_equiv_rndsem = FApi.t_low3 "equiv-rndsem" Core.t_equiv_rndsem_r (* -------------------------------------------------------------------- *) let process_rndsem ~reduce side pos tc = let concl = FApi.tc1_goal tc in - let pos = EcProofTyping.tc1_process_codepos1 tc (side, pos) in + let pos = EcLowPhlGoal.tc1_process_codepos1 tc (side, pos) in match side with | None when is_hoareS concl -> diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index b47d050848..777b93c165 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -56,7 +56,7 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = (* Extract the call statement and surrounding code *) let prefix, (llv, func, largs), suffix = - let cp = EcProofTyping.tc1_process_codepos1 tc (Some side, cp) in + let cp = EcLowPhlGoal.tc1_process_codepos1 tc (Some side, cp) in let p, i, s = s_split_i env cp code in if not (is_call i) then rwe_error RWE_InvalidPosition; @@ -159,4 +159,3 @@ let process_rewrite_equiv info tc = tc_error !!tc "rewrite equiv: function mismatch\nExpected %s but got %s" (x_tostring wanted) (x_tostring got) | RwEquivError RWE_InvalidPosition -> tc_error !!tc "rewrite equiv: targetted instruction is not a function call" - diff --git a/tests/call_with_op.ec b/tests/call_with_op.ec new file mode 100644 index 0000000000..f0832de4f4 --- /dev/null +++ b/tests/call_with_op.ec @@ -0,0 +1,59 @@ +require import AllCore. + +module M = { + proc f(x:int) : int = { + return x; + } + + proc g(x:int) : int = { + var z; + z <@ f(x); + return z; + } +}. + +op f_spec x_ = hoare [M.f : x = x_ ==> res = x_]. +op g_spec x_ = hoare [M.g : x = x_ ==> res = x_]. + +lemma f_ok1 x_ : f_spec x_. +proof. + proc; auto. +qed. + +lemma g_ok1 x_ : g_spec x_. +proof. + proc. + call (f_ok1 x_). + auto. +qed. + +lemma g_ok1_e x_ : g_spec x_. +proof. + proc. + ecall (f_ok1 x). + auto. +qed. + +op f_spec_all = forall x_, hoare [M.f : x = x_ ==> res = x_]. + +lemma f_ok2 : f_spec_all. +proof. + move=> x_;proc; auto. +qed. + +lemma g_ok2 x_ : g_spec x_. +proof. + proc. + call (f_ok2 x_). + auto. +qed. + +lemma g_ok2_e x_ : g_spec x_. +proof. + proc. + ecall (f_ok2 x). + auto. +qed. + + + diff --git a/tests/proc_with_op.ec b/tests/proc_with_op.ec new file mode 100644 index 0000000000..7c79de2626 --- /dev/null +++ b/tests/proc_with_op.ec @@ -0,0 +1,14 @@ +require import AllCore. + +module M = { + proc f () : int = { + return 0; + } +}. + +op spec = hoare[M.f : true ==> true]. + +lemma Mf : spec. +proc. +auto. +qed. From 6b74629faf5c5826acd6474fc7b848cc518cfaf3 Mon Sep 17 00:00:00 2001 From: Oskar Goldhahn Date: Thu, 18 Dec 2025 14:50:23 +0100 Subject: [PATCH 05/26] make casts from existing single sided formulas to two sided ones use a more robust pattern --- src/phl/ecPhlApp.ml | 12 +++--- src/phl/ecPhlConseq.ml | 58 ++++++++++++++------------- tests/conseq_equiv_phoare_at_equiv.ec | 13 ++++++ 3 files changed, 49 insertions(+), 34 deletions(-) create mode 100644 tests/conseq_equiv_phoare_at_equiv.ec diff --git a/src/phl/ecPhlApp.ml b/src/phl/ecPhlApp.ml index 3984e25360..4ebf52413e 100644 --- a/src/phl/ecPhlApp.ml +++ b/src/phl/ecPhlApp.ml @@ -124,13 +124,13 @@ let t_equiv_app_onesided side i pre post tc = let (ml, mr) = fst es.es_ml, fst es.es_mr in let s, s', p', q' = match side with - | `Left -> - let p' = ss_inv_generalize_right (EcSubst.ss_inv_rebind pre ml) mr in - let q' = ss_inv_generalize_right (EcSubst.ss_inv_rebind post ml) mr in + | `Left -> + let p' = ss_inv_generalize_as_left pre ml mr in + let q' = ss_inv_generalize_as_left post ml mr in es.es_sl, es.es_sr, p', q' - | `Right -> - let p' = ss_inv_generalize_left (EcSubst.ss_inv_rebind pre mr) ml in - let q' = ss_inv_generalize_left (EcSubst.ss_inv_rebind post mr) ml in + | `Right -> + let p' = ss_inv_generalize_as_right pre ml mr in + let q' = ss_inv_generalize_as_right post ml mr in es.es_sr, es.es_sl, p', q' in let generalize_mod_side= sideif side generalize_mod_left generalize_mod_right in diff --git a/src/phl/ecPhlConseq.ml b/src/phl/ecPhlConseq.ml index ebdc203d84..d4631bfe6f 100644 --- a/src/phl/ecPhlConseq.ml +++ b/src/phl/ecPhlConseq.ml @@ -719,10 +719,10 @@ let t_equivS_conseq_conj pre1 post1 pre2 post2 pre' post' tc = let (_, hyps, _) = FApi.tc1_eflat tc in let es = tc1_as_equivS tc in let (ml, mtl), (mr, mtr) = es.es_ml, es.es_mr in - let pre1' = ss_inv_generalize_right (ss_inv_rebind pre1 ml) mr in - let post1' = ss_inv_generalize_right (ss_inv_rebind post1 ml) mr in - let pre2' = ss_inv_generalize_left (ss_inv_rebind pre2 mr) ml in - let post2' = ss_inv_generalize_left (ss_inv_rebind post2 mr) ml in + let pre1' = ss_inv_generalize_as_left pre1 ml mr in + let post1' = ss_inv_generalize_as_left post1 ml mr in + let pre2' = ss_inv_generalize_as_right pre2 ml mr in + let post2' = ss_inv_generalize_as_right post2 ml mr in if not (ts_inv_alpha_eq hyps (es_pr es) (map_ts_inv f_ands [pre';pre1';pre2'])) then tc_error !!tc "invalid pre-condition"; if not (ts_inv_alpha_eq hyps (es_po es) (map_ts_inv f_ands [post';post1';post2'])) then @@ -737,15 +737,17 @@ let t_equivF_conseq_conj pre1 post1 pre2 post2 pre' post' tc = let (_, hyps, _) = FApi.tc1_eflat tc in let ef = tc1_as_equivF tc in let ml, mr = ef.ef_ml, ef.ef_mr in - let pre1' = ss_inv_generalize_right (ss_inv_rebind pre1 ml) mr in - let post1' = ss_inv_generalize_right (ss_inv_rebind post1 ml) mr in - let pre2' = ss_inv_generalize_left (ss_inv_rebind pre2 mr) ml in - let post2' = ss_inv_generalize_left (ss_inv_rebind post2 mr) ml in - let pre'' = map_ts_inv f_ands [pre'; pre1'; pre2'] in - let post'' = map_ts_inv f_ands [post'; post1'; post2'] in - if not (ts_inv_alpha_eq hyps (ef_pr ef) pre'') + let pre1' = ss_inv_generalize_as_left pre1 ml mr in + let post1' = ss_inv_generalize_as_left post1 ml mr in + let pre2' = ss_inv_generalize_as_right pre2 ml mr in + let post2' = ss_inv_generalize_as_right post2 ml mr in + let pre'' = ts_inv_rebind pre' ml mr in + let pre_and = map_ts_inv f_ands [pre''; pre1'; pre2'] in + let post'' = ts_inv_rebind post' ml mr in + let post_and = map_ts_inv f_ands [post''; post1'; post2'] in + if not (ts_inv_alpha_eq hyps (ef_pr ef) pre_and) then tc_error !!tc "invalid pre-condition"; - if not (ts_inv_alpha_eq hyps (ef_po ef) post'') + if not (ts_inv_alpha_eq hyps (ef_po ef) post_and) then tc_error !!tc "invalid post-condition"; let concl1 = f_hoareF pre1 ef.ef_fl post1 in let concl2 = f_hoareF pre2 ef.ef_fr post2 in @@ -760,12 +762,12 @@ let t_equivS_conseq_bd side pr po tc = let m,s,s',prs,pos = match side with | `Left -> - let pos = ss_inv_generalize_right (ss_inv_rebind po ml) mr in - let prs = ss_inv_generalize_right (ss_inv_rebind pr ml) mr in + let pos = ss_inv_generalize_as_left po ml mr in + let prs = ss_inv_generalize_as_left pr ml mr in es.es_ml, es.es_sl, es.es_sr, prs, pos | `Right -> - let pos = ss_inv_generalize_left (ss_inv_rebind po mr) ml in - let prs = ss_inv_generalize_left (ss_inv_rebind pr mr) ml in + let pos = ss_inv_generalize_as_right po ml mr in + let prs = ss_inv_generalize_as_right pr ml mr in es.es_mr, es.es_sr, es.es_sl, prs, pos in if not (List.is_empty s'.s_node) then begin @@ -1180,10 +1182,10 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = let hs2 = pf_as_hoareS !!tc f2 in let hs3 = pf_as_hoareS !!tc f3 in let (ml, mr) = (fst es.es_ml, fst es.es_mr) in - let hs2_pr = ss_inv_generalize_right (ss_inv_rebind (hs_pr hs2) ml) mr in - let hs2_po = ss_inv_generalize_right (ss_inv_rebind (hs_po hs2) ml) mr in - let hs3_pr = ss_inv_generalize_left (ss_inv_rebind (hs_pr hs3) mr) ml in - let hs3_po = ss_inv_generalize_left (ss_inv_rebind (hs_po hs3) mr) ml in + let hs2_pr = ss_inv_generalize_as_left (hs_pr hs2) ml mr in + let hs2_po = ss_inv_generalize_as_left (hs_po hs2) ml mr in + let hs3_pr = ss_inv_generalize_as_right (hs_pr hs3) ml mr in + let hs3_po = ss_inv_generalize_as_right (hs_po hs3) ml mr in let pre = map_ts_inv f_ands [es_pr es; hs2_pr; hs3_pr] in let post = map_ts_inv f_ands [es_po es; hs2_po; hs3_po] in let tac = if notmod then t_equivS_conseq_nm else t_equivS_conseq in @@ -1238,8 +1240,8 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = | FequivS es, None, Some ((_, f2) as nf2), None -> let hs = pf_as_bdhoareS !!tc f2 in let (ml, mr) = (fst es.es_ml, fst es.es_mr) in - let pre = ss_inv_generalize_right (ss_inv_rebind (bhs_pr hs) ml) mr in - let post = ss_inv_generalize_right (ss_inv_rebind (bhs_po hs) ml) mr in + let pre = ss_inv_generalize_as_left (bhs_pr hs) ml mr in + let post = ss_inv_generalize_as_left (bhs_po hs) ml mr in let tac = if notmod then t_equivS_conseq_nm else t_equivS_conseq in check_is_detbound `Second (bhs_bd hs).inv; @@ -1256,8 +1258,8 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = | FequivS es, None, None, Some ((_, f3) as nf3) -> let hs = pf_as_bdhoareS !!tc f3 in let (ml, mr) = (fst es.es_ml, fst es.es_mr) in - let pre = ss_inv_generalize_left (ss_inv_rebind (bhs_pr hs) mr) ml in - let post = ss_inv_generalize_left (ss_inv_rebind (bhs_po hs) mr) ml in + let pre = ss_inv_generalize_as_right (bhs_pr hs) ml mr in + let post = ss_inv_generalize_as_right (bhs_po hs) ml mr in let tac = if notmod then t_equivS_conseq_nm else t_equivS_conseq in check_is_detbound `Third (bhs_bd hs).inv; @@ -1285,11 +1287,11 @@ let rec t_hi_conseq notmod f1 f2 f3 tc = let hs2 = pf_as_hoareF !!tc f2 in let hs3 = pf_as_hoareF !!tc f3 in let (ml, mr) = (ef.ef_ml, ef.ef_mr) in - let hs2_pr = ss_inv_generalize_right (ss_inv_rebind (hf_pr hs2) ml) mr in - let hs3_pr = ss_inv_generalize_left (ss_inv_rebind (hf_pr hs3) mr) ml in + let hs2_pr = ss_inv_generalize_as_left (hf_pr hs2) ml mr in + let hs3_pr = ss_inv_generalize_as_right (hf_pr hs3) ml mr in let pre = map_ts_inv f_ands [ef_pr ef; hs2_pr; hs3_pr] in - let hs2_po = ss_inv_generalize_right (ss_inv_rebind (hf_po hs2) ml) mr in - let hs3_po = ss_inv_generalize_left (ss_inv_rebind (hf_po hs3) mr) ml in + let hs2_po = ss_inv_generalize_as_left (hf_po hs2) ml mr in + let hs3_po = ss_inv_generalize_as_right (hf_po hs3) ml mr in let post = map_ts_inv f_ands [ef_po ef; hs2_po; hs3_po] in let tac = if notmod then t_equivF_conseq_nm else t_equivF_conseq in t_on1seq 2 diff --git a/tests/conseq_equiv_phoare_at_equiv.ec b/tests/conseq_equiv_phoare_at_equiv.ec new file mode 100644 index 0000000000..e45598b977 --- /dev/null +++ b/tests/conseq_equiv_phoare_at_equiv.ec @@ -0,0 +1,13 @@ +module Foo = { + proc foo(i : int) = { + } +}. + +lemma foo_corr : hoare [ Foo.foo : true ==> true] by proc;auto. + +lemma foo_eq : equiv [ Foo.foo ~ Foo.foo : ={arg} ==> true ] by sim. + +lemma foo_eq_corr: + equiv [ Foo.foo ~ Foo.foo : ={arg} ==> ={res} ]. + conseq foo_eq foo_corr. +qed. From 15e75814064070c90b2ffae48961b1f1418beb14 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 7 Jan 2026 08:58:26 +0100 Subject: [PATCH 06/26] Remove dead-code in theory cloning code. All code that relates to module replacement is now usused and has been removed. --- src/ecThCloning.ml | 2 -- src/ecThCloning.mli | 1 - src/ecTheoryReplay.ml | 53 ++++--------------------------------------- 3 files changed, 5 insertions(+), 51 deletions(-) diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index a2f24e593a..2731d928b9 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -71,7 +71,6 @@ type evclone = { evc_ops : (xop_override located) Msym.t; evc_preds : (xpr_override located) Msym.t; evc_abbrevs : (nt_override located) Msym.t; - evc_modexprs : (me_override located) Msym.t; evc_modtypes : (mt_override located) Msym.t; evc_lemmas : evlemma; evc_ths : (evclone * bool) Msym.t; @@ -93,7 +92,6 @@ let evc_empty = evc_ops = Msym.empty; evc_preds = Msym.empty; evc_abbrevs = Msym.empty; - evc_modexprs = Msym.empty; evc_modtypes = Msym.empty; evc_lemmas = evl; evc_ths = Msym.empty; } diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli index a135698baf..82e160cfa2 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -57,7 +57,6 @@ type evclone = { evc_ops : (xop_override located) Msym.t; evc_preds : (xpr_override located) Msym.t; evc_abbrevs : (nt_override located) Msym.t; - evc_modexprs : (me_override located) Msym.t; evc_modtypes : (mt_override located) Msym.t; evc_lemmas : evlemma; evc_ths : (evclone * bool) Msym.t; diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 0eff5cf66d..8347cce431 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -868,54 +868,11 @@ and replay_modtype and replay_mod (ove : _ ovrenv) (subst, ops, proofs, scope) (import, (me : top_module_expr)) = - match Msym.find_opt me.tme_expr.me_name ove.ovre_ovrd.evc_modexprs with - | None -> - let subst, name = rename ove subst (`Module, me.tme_expr.me_name) in - let me = EcSubst.subst_top_module subst me in - let me = { me with tme_expr = { me.tme_expr with me_name = name } } in - let item = (Th_module me) in - (subst, ops, proofs, ove.ovre_hooks.hadd_item scope ~import item) - - | Some { pl_desc = (newname, mode) } -> - let name = me.tme_expr.me_name in - let env = EcSection.env (ove.ovre_hooks.henv scope) in - - let mp, (newme, newlc) = EcEnv.Mod.lookup (unloc newname) env in - - let substme = EcSubst.add_moddef subst ~src:(xpath ove name) ~dst:mp in - - let me = EcSubst.subst_top_module substme me in - let me = { me with tme_expr = { me.tme_expr with me_name = name } } in - let newme = { newme with me_name = name } in - let newme = { tme_expr = newme; tme_loca = Option.get newlc; } in - - if not (EcReduction.EqTest.for_mexpr ~body:false env me.tme_expr newme.tme_expr) then - clone_error env (CE_ModIncompatible (snd ove.ovre_prefix, name)); - - let subst = - match mode with - | `Alias -> - fst (rename ove subst (`Module, name)) - | `Inline _ -> - substme in - - let newme = - if mode = `Alias || mode = `Inline `Keep then - let alias = ME_Alias ( - List.length newme.tme_expr.me_params, - EcPath.m_apply - mp - (List.map (fun (id, _) -> EcPath.mident id) newme.tme_expr.me_params) - ) - in { newme with tme_expr = { newme.tme_expr with me_body = alias } } - else newme in - - let scope = - if keep_of_mode mode - then ove.ovre_hooks.hadd_item scope ~import (Th_module newme) - else scope in - - (subst, ops, proofs, scope) + let subst, name = rename ove subst (`Module, me.tme_expr.me_name) in + let me = EcSubst.subst_top_module subst me in + let me = { me with tme_expr = { me.tme_expr with me_name = name } } in + let item = (Th_module me) in + (subst, ops, proofs, ove.ovre_hooks.hadd_item scope ~import item) (* -------------------------------------------------------------------- *) and replay_export From 02238cd720e30fcb4c5b6a88c55f39d137ee863f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 7 Jan 2026 08:36:08 +0100 Subject: [PATCH 07/26] Kill warnings + unify flags for ci/dev dune environments This commit makes the warning flags now explicit for the dev/ci environments and use the same set of warning flags for both of them. This will allow us to catch more warnings in the CI. For the release environment, we now use the default set of flags. As a side effect, this commit fixes the pretty printing of local variables (the actual code was not using the printing environment anymore to get the display name) --- src/dune | 9 +++++---- src/ecPrinting.ml | 2 +- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/dune b/src/dune index 75cb7e8abc..f5c2eed643 100644 --- a/src/dune +++ b/src/dune @@ -1,9 +1,10 @@ (env - (dev (flags :standard -rectypes -warn-error -a+31 -w +28+33-9-23-32-58-67-69)) - (ci (flags :standard -rectypes -warn-error +a -w +28+33-9-23-32-58-67-69)) - (release (flags :standard -rectypes -warn-error -a -w +28+33-9-23-32-58-67-69) + (dev (flags :standard -rectypes -w @1..3@5..28@31..39@43@46..47@49..57@61..62-40-9-23-32-67-69 -warn-error -a+31)) + (ci (flags :standard -rectypes -w @1..3@5..28@31..39@43@46..47@49..57@61..62-40-9-23-32-67-69 -warn-error +a)) + (release (flags :standard -rectypes) (ocamlopt_flags -O3 -unbox-closures))) + (include_subdirs unqualified) (generate_sites_module @@ -30,4 +31,4 @@ (menhir (modules ecParser) (explain true) - (flags --table)) + (flags --table --unused-token COMMENT)) diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index b37fbe2283..c320e71867 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -620,7 +620,7 @@ let pp_modtype1 (ppe : PPEnv.t) fmt mty = (* -------------------------------------------------------------------- *) let pp_local (ppe : PPEnv.t) fmt x = - Format.fprintf fmt "%s" (EcIdent.name x) + Format.fprintf fmt "%s" (PPEnv.local_symb ppe x) (* -------------------------------------------------------------------- *) let pp_local ?fv (ppe : PPEnv.t) fmt x = From cd2ab8b6e87148178c8b256312363ad491426a22 Mon Sep 17 00:00:00 2001 From: Oskar Goldhahn Date: Sat, 10 Jan 2026 00:30:42 +0100 Subject: [PATCH 08/26] also swap memory types when swapping memories --- src/phl/ecPhlSym.ml | 2 +- tests/symmetry.ec | 15 +++++++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) create mode 100644 tests/symmetry.ec diff --git a/src/phl/ecPhlSym.ml b/src/phl/ecPhlSym.ml index 4868fa478c..7d706dcc36 100644 --- a/src/phl/ecPhlSym.ml +++ b/src/phl/ecPhlSym.ml @@ -20,7 +20,7 @@ let t_equivS_sym tc = let (ml, mtl), (mr, mtr) = es.es_ml, es.es_mr in let pr = {ml;mr;inv=(ts_inv_rebind (es_pr es) mr ml).inv} in let po = {ml;mr;inv=(ts_inv_rebind (es_po es) mr ml).inv} in - let cond = f_equivS mtl mtr pr es.es_sr es.es_sl po in + let cond = f_equivS mtr mtl pr es.es_sr es.es_sl po in FApi.xmutate1 tc `EquivSym [cond] (*-------------------------------------------------------------------- *) diff --git a/tests/symmetry.ec b/tests/symmetry.ec new file mode 100644 index 0000000000..a2c527c06f --- /dev/null +++ b/tests/symmetry.ec @@ -0,0 +1,15 @@ +module M = { + proc f() = { + var f : int; + + f <- 0; + } + + proc g() = {} +}. + +equiv toto: M.g ~ M.f: true ==> ={res}. +proof. +proc. symmetry. +conseq (:true ==> true) (: true ==> f=0). +abort. From c507676a52b63d3149cb5cc5a6d992e0835908a7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 12 Jan 2026 09:41:13 +0100 Subject: [PATCH 09/26] In matching, do not unify a memory with itself --- src/ecMatching.ml | 23 ++++++++++++----------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 7c8e6a2fb0..fe5d6090fe 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -837,19 +837,20 @@ let f_match_core opts hyps (ue, ev) f1 f2 = cb (odfl reduced (EcReduction.h_red_opt EcReduction.beta_red hyps reduced)) and doit_mem _env mxs m1 m2 = - match EV.get m1 !ev.evm_mem with - | None -> - if not (EcMemory.mem_equal m1 m2) then + if not (EcMemory.mem_equal m1 m2) then begin + match EV.get m1 !ev.evm_mem with + | None -> raise MatchFailure - | Some `Unset -> - if Mid.mem m2 mxs then - raise MatchFailure; - ev := { !ev with evm_mem = EV.set m1 m2 !ev.evm_mem } - - | Some (`Set m1) -> - if not (EcMemory.mem_equal m1 m2) then - raise MatchFailure + | Some `Unset -> + if Mid.mem m2 mxs then + raise MatchFailure; + ev := { !ev with evm_mem = EV.set m1 m2 !ev.evm_mem } + + | Some (`Set m1) -> + if not (EcMemory.mem_equal m1 m2) then + raise MatchFailure + end and doit_bindings env (subst, mxs) q1 q2 = let doit_binding (env, subst, mxs) (x1, gty1) (x2, gty2) = From 919b973a2a6a75dea0f50561446437ec73a5d7cf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 12 Jan 2026 10:35:56 +0100 Subject: [PATCH 10/26] Improve error message in to-assumption rewrite Currently, if the top-assumption is not an hypothesis, we let an low-tactic error message do escape. We now write a proper error message before this happens. --- src/ecHiGoal.ml | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index f08413545c..b16b7eb03d 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -1515,8 +1515,12 @@ let rec process_mintros_1 ?(cf = true) ttenv pis gs = and intro1_rw (_ : ST.state) (o, s) tc = let h = EcIdent.create "_" in let rwt tc = - let pt = PT.pt_of_hyp !!tc (FApi.tc1_hyps tc) h in - process_rewrite1_core ~close:false (s, None, o) pt tc + match LDecl.by_id h (FApi.tc1_hyps tc) with + | LD_hyp _ -> + let pt = PT.pt_of_hyp !!tc (FApi.tc1_hyps tc) h in + process_rewrite1_core ~close:false (s, None, o) pt tc + | _ -> + tc_error !!tc "top assumption is not an hypothesis"; in t_seqs [t_intros_i [h]; rwt; t_clear h] tc and intro1_unfold (_ : ST.state) (s, o) p tc = From 1155bca27ccee1d1c42aa33050da4b488d4c6a05 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 12 Jan 2026 11:47:55 +0100 Subject: [PATCH 11/26] When doing section-analysis, recurse in operators body --- src/ecSection.ml | 575 +++++++++++++++++++++++++---------------------- 1 file changed, 310 insertions(+), 265 deletions(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index 3534ea58e2..8f54c0bc0a 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -91,325 +91,386 @@ let hierror fmt = bfmt fmt (* -------------------------------------------------------------------- *) -let rec on_mp (cb : cb) (mp : mpath) = - let f = m_functor mp in - cb (`Module f); - List.iter (on_mp cb) mp.m_args +type aenv = { + env : EcEnv.env; (* Global environment for dep. analysis *) + cb : cb; (* Dep. analysis callback *) + cache : acache ref; (* Dep. analysis cache *) +} -let on_xp (cb : cb) (xp : xpath) = - on_mp cb xp.x_top +and acache = { + op : Sp.t; (* Operator declaration already handled *) +} -let rec on_ty (cb : cb) (ty : ty) = - match ty.ty_node with - | Tunivar _ -> () - | Tvar _ -> () - | Tglob _ -> () - | Ttuple tys -> List.iter (on_ty cb) tys - | Tconstr (p, tys) -> cb (`Type p); List.iter (on_ty cb) tys - | Tfun (ty1, ty2) -> List.iter (on_ty cb) [ty1; ty2] +(* -------------------------------------------------------------------- *) +let empty_acache : acache = + { op = Sp.empty; } + +(* -------------------------------------------------------------------- *) +let mkaenv (env : EcEnv.env) (cb : cb) : aenv = + { env; cb; cache = ref empty_acache; } + +(* -------------------------------------------------------------------- *) +let rec on_mp (aenv : aenv) (mp : mpath) = + aenv.cb (`Module (m_functor mp)); + List.iter (on_mp aenv) mp.m_args + +(* -------------------------------------------------------------------- *) +and on_xp (aenv : aenv) (xp : xpath) = + on_mp aenv xp.x_top + +(* -------------------------------------------------------------------- *) +and on_memtype (aenv : aenv) (mt : EcMemory.memtype) = + EcMemory.mt_iter_ty (on_ty aenv) mt + +(* -------------------------------------------------------------------- *) +and on_memenv (aenv : aenv) (m : EcMemory.memenv) = + on_memtype aenv (snd m) -let on_pv (cb : cb) (pv : prog_var)= +(* -------------------------------------------------------------------- *) +and on_pv (aenv : aenv) (pv : prog_var)= match pv with - | PVglob xp -> on_xp cb xp + | PVglob xp -> on_xp aenv xp | _ -> () -let on_lp (cb : cb) (lp : lpattern) = +(* -------------------------------------------------------------------- *) +and on_lp (aenv : aenv) (lp : lpattern) = match lp with - | LSymbol (_, ty) -> on_ty cb ty - | LTuple xs -> List.iter (fun (_, ty) -> on_ty cb ty) xs - | LRecord (_, xs) -> List.iter (on_ty cb |- snd) xs + | LSymbol (_, ty) -> on_ty aenv ty + | LTuple xs -> List.iter (fun (_, ty) -> on_ty aenv ty) xs + | LRecord (_, xs) -> List.iter (on_ty aenv |- snd) xs + +(* -------------------------------------------------------------------- *) +and on_binding (aenv : aenv) ((_, ty) : (EcIdent.t * ty)) = + on_ty aenv ty + +(* -------------------------------------------------------------------- *) +and on_bindings (aenv : aenv) (bds : (EcIdent.t * ty) list) = + List.iter (on_binding aenv) bds -let on_binding (cb : cb) ((_, ty) : (EcIdent.t * ty)) = - on_ty cb ty +(* -------------------------------------------------------------------- *) +and on_ty (aenv : aenv) (ty : ty) = + match ty.ty_node with + | Tunivar _ -> () + | Tvar _ -> () + | Tglob _ -> () + | Ttuple tys -> List.iter (on_ty aenv) tys + | Tconstr (p, tys) -> aenv.cb (`Type p); List.iter (on_ty aenv) tys + | Tfun (ty1, ty2) -> List.iter (on_ty aenv) [ty1; ty2] -let on_bindings (cb : cb) (bds : (EcIdent.t * ty) list) = - List.iter (on_binding cb) bds +(* -------------------------------------------------------------------- *) +and on_opname (aenv : aenv) (p : EcPath.path) = + aenv.cb (`Op p); + if not (Sp.mem p !(aenv.cache).op) then begin + let cache = { !(aenv.cache) with op = Sp.add p !(aenv.cache).op } in + aenv.cache := cache; + on_opdecl aenv (EcEnv.Op.by_path p aenv.env); + end -let rec on_expr (cb : cb) (e : expr) = - let cbrec = on_expr cb in +(* -------------------------------------------------------------------- *) +and on_expr (aenv : aenv) (e : expr) = + let cbrec = on_expr aenv in let fornode () = match e.e_node with | Eint _ -> () | Elocal _ -> () - | Equant (_, bds, e) -> on_bindings cb bds; cbrec e - | Evar pv -> on_pv cb pv - | Elet (lp, e1, e2) -> on_lp cb lp; List.iter cbrec [e1; e2] + | Equant (_, bds, e) -> on_bindings aenv bds; cbrec e + | Evar pv -> on_pv aenv pv + | Elet (lp, e1, e2) -> on_lp aenv lp; List.iter cbrec [e1; e2] | Etuple es -> List.iter cbrec es - | Eop (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys | Eapp (e, es) -> List.iter cbrec (e :: es) | Eif (c, e1, e2) -> List.iter cbrec [c; e1; e2] - | Ematch (e, es, ty) -> on_ty cb ty; List.iter cbrec (e :: es) + | Ematch (e, es, ty) -> on_ty aenv ty; List.iter cbrec (e :: es) | Eproj (e, _) -> cbrec e - in on_ty cb e.e_ty; fornode () + | Eop (p, tys) -> begin + on_opname aenv p; + List.iter (on_ty aenv) tys; + end + + in on_ty aenv e.e_ty; fornode () -let on_lv (cb : cb) (lv : lvalue) = - let for1 (pv, ty) = on_pv cb pv; on_ty cb ty in +(* -------------------------------------------------------------------- *) +and on_lv (aenv : aenv) (lv : lvalue) = + let for1 (pv, ty) = on_pv aenv pv; on_ty aenv ty in match lv with | LvVar pv -> for1 pv | LvTuple pvs -> List.iter for1 pvs -let rec on_instr (cb : cb) (i : instr)= +(* -------------------------------------------------------------------- *) +and on_instr (aenv : aenv) (i : instr)= match i.i_node with | Srnd (lv, e) | Sasgn (lv, e) -> - on_lv cb lv; - on_expr cb e + on_lv aenv lv; + on_expr aenv e | Sassert e -> - on_expr cb e + on_expr aenv e | Scall (lv, f, args) -> - lv |> oiter (on_lv cb); - on_xp cb f; - List.iter (on_expr cb) args + oiter (on_lv aenv) lv; + on_xp aenv f; + List.iter (on_expr aenv) args | Sif (e, s1, s2) -> - on_expr cb e; - List.iter (on_stmt cb) [s1; s2] + on_expr aenv e; + List.iter (on_stmt aenv) [s1; s2] | Swhile (e, s) -> - on_expr cb e; - on_stmt cb s + on_expr aenv e; + on_stmt aenv s | Smatch (e, b) -> let forb (bs, s) = - List.iter (on_ty cb |- snd) bs; - on_stmt cb s - in on_expr cb e; List.iter forb b + List.iter (on_ty aenv |- snd) bs; + on_stmt aenv s + in on_expr aenv e; List.iter forb b | Sabstract _ -> () -and on_stmt (cb : cb) (s : stmt) = - List.iter (on_instr cb) s.s_node - -let on_memtype cb mt = - EcMemory.mt_iter_ty (on_ty cb) mt - -let on_memenv cb (m : EcMemory.memenv) = - on_memtype cb (snd m) +(* -------------------------------------------------------------------- *) +and on_stmt (aenv : aenv) (s : stmt) = + List.iter (on_instr aenv) s.s_node -let rec on_form (cb : cb) (f : EcFol.form) = - let cbrec = on_form cb in +(* -------------------------------------------------------------------- *) +and on_form (aenv : aenv) (f : EcFol.form) = + let cbrec = on_form aenv in let rec fornode () = match f.EcAst.f_node with | EcAst.Fint _ -> () | EcAst.Flocal _ -> () - | EcAst.Fquant (_, b, f) -> on_gbindings cb b; cbrec f + | EcAst.Fquant (_, b, f) -> on_gbindings aenv b; cbrec f | EcAst.Fif (f1, f2, f3) -> List.iter cbrec [f1; f2; f3] - | EcAst.Fmatch (b, fs, ty) -> on_ty cb ty; List.iter cbrec (b :: fs) - | EcAst.Flet (lp, f1, f2) -> on_lp cb lp; List.iter cbrec [f1; f2] - | EcAst.Fop (p, tys) -> cb (`Op p); List.iter (on_ty cb) tys + | EcAst.Fmatch (b, fs, ty) -> on_ty aenv ty; List.iter cbrec (b :: fs) + | EcAst.Flet (lp, f1, f2) -> on_lp aenv lp; List.iter cbrec [f1; f2] | EcAst.Fapp (f, fs) -> List.iter cbrec (f :: fs) | EcAst.Ftuple fs -> List.iter cbrec fs | EcAst.Fproj (f, _) -> cbrec f - | EcAst.Fpvar (pv, _) -> on_pv cb pv + | EcAst.Fpvar (pv, _) -> on_pv aenv pv | EcAst.Fglob _ -> () - | EcAst.FhoareF hf -> on_hf cb hf - | EcAst.FhoareS hs -> on_hs cb hs - | EcAst.FeHoareF hf -> on_ehf cb hf - | EcAst.FeHoareS hs -> on_ehs cb hs - | EcAst.FequivF ef -> on_ef cb ef - | EcAst.FequivS es -> on_es cb es - | EcAst.FeagerF eg -> on_eg cb eg - | EcAst.FbdHoareS bhs -> on_bhs cb bhs - | EcAst.FbdHoareF bhf -> on_bhf cb bhf - | EcAst.Fpr pr -> on_pr cb pr - - and on_hf cb hf = - on_form cb (hf_pr hf).inv; - on_form cb (hf_po hf).inv; - on_xp cb hf.EcAst.hf_f - - and on_hs cb hs = - on_form cb (hs_pr hs).inv; - on_form cb (hs_po hs).inv; - on_stmt cb hs.EcAst.hs_s; - on_memenv cb hs.EcAst.hs_m - - and on_ef cb ef = - on_form cb (EcAst.ef_pr ef).inv; - on_form cb (EcAst.ef_po ef).inv; - on_xp cb ef.EcAst.ef_fl; - on_xp cb ef.EcAst.ef_fr - - and on_es cb es = - on_form cb (EcAst.es_pr es).inv; - on_form cb (EcAst.es_po es).inv; - on_stmt cb es.EcAst.es_sl; - on_stmt cb es.EcAst.es_sr; - on_memenv cb es.EcAst.es_ml; - on_memenv cb es.EcAst.es_mr - - and on_eg cb eg = - on_form cb (EcAst.eg_pr eg).inv; - on_form cb (EcAst.eg_po eg).inv; - on_xp cb eg.EcAst.eg_fl; - on_xp cb eg.EcAst.eg_fr; - on_stmt cb eg.EcAst.eg_sl; - on_stmt cb eg.EcAst.eg_sr; - - and on_ehf cb hf = - on_form cb (EcAst.ehf_pr hf).inv; - on_form cb (EcAst.ehf_po hf).inv; - on_xp cb hf.EcAst.ehf_f - - and on_ehs cb hs = - on_form cb (EcAst.ehs_pr hs).inv; - on_form cb (EcAst.ehs_po hs).inv; - on_stmt cb hs.EcAst.ehs_s; - on_memenv cb hs.EcAst.ehs_m - - and on_bhf cb bhf = - on_form cb (EcAst.bhf_pr bhf).inv; - on_form cb (EcAst.bhf_po bhf).inv; - on_form cb (EcAst.bhf_bd bhf).inv; - on_xp cb bhf.EcAst.bhf_f - - and on_bhs cb bhs = - on_form cb (EcAst.bhs_pr bhs).inv; - on_form cb (EcAst.bhs_po bhs).inv; - on_form cb (EcAst.bhs_bd bhs).inv; - on_stmt cb bhs.EcAst.bhs_s; - on_memenv cb bhs.EcAst.bhs_m - - - and on_pr cb pr = - on_xp cb pr.EcAst.pr_fun; - List.iter (on_form cb) [pr.EcAst.pr_event.inv; pr.EcAst.pr_args] + | EcAst.FhoareF hf -> on_hf aenv hf + | EcAst.FhoareS hs -> on_hs aenv hs + | EcAst.FeHoareF hf -> on_ehf aenv hf + | EcAst.FeHoareS hs -> on_ehs aenv hs + | EcAst.FequivF ef -> on_ef aenv ef + | EcAst.FequivS es -> on_es aenv es + | EcAst.FeagerF eg -> on_eg aenv eg + | EcAst.FbdHoareS bhs -> on_bhs aenv bhs + | EcAst.FbdHoareF bhf -> on_bhf aenv bhf + | EcAst.Fpr pr -> on_pr aenv pr + + | EcAst.Fop (p, tys) -> begin + on_opname aenv p; + List.iter (on_ty aenv) tys; + end + + and on_hf (aenv : aenv) hf = + on_form aenv (hf_pr hf).inv; + on_form aenv (hf_po hf).inv; + on_xp aenv hf.EcAst.hf_f + + and on_hs (aenv : aenv) hs = + on_form aenv (hs_pr hs).inv; + on_form aenv (hs_po hs).inv; + on_stmt aenv hs.EcAst.hs_s; + on_memenv aenv hs.EcAst.hs_m + + and on_ef (aenv : aenv) ef = + on_form aenv (EcAst.ef_pr ef).inv; + on_form aenv (EcAst.ef_po ef).inv; + on_xp aenv ef.EcAst.ef_fl; + on_xp aenv ef.EcAst.ef_fr + + and on_es (aenv : aenv) es = + on_form aenv (EcAst.es_pr es).inv; + on_form aenv (EcAst.es_po es).inv; + on_stmt aenv es.EcAst.es_sl; + on_stmt aenv es.EcAst.es_sr; + on_memenv aenv es.EcAst.es_ml; + on_memenv aenv es.EcAst.es_mr + + and on_eg (aenv : aenv) eg = + on_form aenv (EcAst.eg_pr eg).inv; + on_form aenv (EcAst.eg_po eg).inv; + on_xp aenv eg.EcAst.eg_fl; + on_xp aenv eg.EcAst.eg_fr; + on_stmt aenv eg.EcAst.eg_sl; + on_stmt aenv eg.EcAst.eg_sr; + + and on_ehf (aenv : aenv) hf = + on_form aenv (EcAst.ehf_pr hf).inv; + on_form aenv (EcAst.ehf_po hf).inv; + on_xp aenv hf.EcAst.ehf_f + + and on_ehs (aenv : aenv) hs = + on_form aenv (EcAst.ehs_pr hs).inv; + on_form aenv (EcAst.ehs_po hs).inv; + on_stmt aenv hs.EcAst.ehs_s; + on_memenv aenv hs.EcAst.ehs_m + + and on_bhf (aenv : aenv) bhf = + on_form aenv (EcAst.bhf_pr bhf).inv; + on_form aenv (EcAst.bhf_po bhf).inv; + on_form aenv (EcAst.bhf_bd bhf).inv; + on_xp aenv bhf.EcAst.bhf_f + + and on_bhs (aenv : aenv) bhs = + on_form aenv (EcAst.bhs_pr bhs).inv; + on_form aenv (EcAst.bhs_po bhs).inv; + on_form aenv (EcAst.bhs_bd bhs).inv; + on_stmt aenv bhs.EcAst.bhs_s; + on_memenv aenv bhs.EcAst.bhs_m + + + and on_pr (aenv : aenv) pr = + on_xp aenv pr.EcAst.pr_fun; + List.iter (on_form aenv) [pr.EcAst.pr_event.inv; pr.EcAst.pr_args] in - on_ty cb f.EcAst.f_ty; fornode () + on_ty aenv f.EcAst.f_ty; fornode () -and on_restr (cb : cb) (restr : mod_restr) = - let doit (xs, ms) = Sx.iter (on_xp cb) xs; Sm.iter (on_mp cb) ms in +(* -------------------------------------------------------------------- *) +and on_restr (aenv : aenv) (restr : mod_restr) = + let doit (xs, ms) = Sx.iter (on_xp aenv) xs; Sm.iter (on_mp aenv) ms in oiter doit restr.ur_pos; doit restr.ur_neg -and on_modty cb (mty : module_type) = - cb (`ModuleType mty.mt_name); - List.iter (fun (_, mty) -> on_modty cb mty) mty.mt_params; - List.iter (on_mp cb) mty.mt_args +(* -------------------------------------------------------------------- *) +and on_modty (aenv : aenv) (mty : module_type) = + aenv.cb (`ModuleType mty.mt_name); + List.iter (fun (_, mty) -> on_modty aenv mty) mty.mt_params; + List.iter (on_mp aenv) mty.mt_args -and on_mty_mr (cb : cb) ((mty, mr) : mty_mr) = - on_modty cb mty; on_restr cb mr +(* -------------------------------------------------------------------- *) +and on_mty_mr (aenv : aenv) ((mty, mr) : mty_mr) = + on_modty aenv mty; on_restr aenv mr -and on_gbinding (cb : cb) (b : gty) = +(* -------------------------------------------------------------------- *) +and on_gbinding (aenv : aenv) (b : gty) = match b with | EcAst.GTty ty -> - on_ty cb ty + on_ty aenv ty | EcAst.GTmodty mty -> - on_mty_mr cb mty + on_mty_mr aenv mty | EcAst.GTmem m -> - on_memtype cb m + on_memtype aenv m -and on_gbindings (cb : cb) (b : (EcIdent.t * gty) list) = - List.iter (fun (_, b) -> on_gbinding cb b) b +(* -------------------------------------------------------------------- *) +and on_gbindings (aenv : aenv) (b : (EcIdent.t * gty) list) = + List.iter (fun (_, b) -> on_gbinding aenv b) b -and on_module (cb : cb) (me : module_expr) = +(* -------------------------------------------------------------------- *) +and on_module (aenv : aenv) (me : module_expr) = match me.me_body with - | ME_Alias (_, mp) -> on_mp cb mp - | ME_Structure st -> on_mstruct cb st - | ME_Decl mty -> on_mty_mr cb mty + | ME_Alias (_, mp) -> on_mp aenv mp + | ME_Structure st -> on_mstruct aenv st + | ME_Decl mty -> on_mty_mr aenv mty -and on_mstruct (cb : cb) (st : module_structure) = - List.iter (on_mpath_mstruct1 cb) st.ms_body +(* -------------------------------------------------------------------- *) +and on_mstruct (aenv : aenv) (st : module_structure) = + List.iter (on_mpath_mstruct1 aenv) st.ms_body -and on_mpath_mstruct1 (cb : cb) (item : module_item) = +(* -------------------------------------------------------------------- *) +and on_mpath_mstruct1 (aenv : aenv) (item : module_item) = match item with - | MI_Module me -> on_module cb me - | MI_Variable x -> on_ty cb x.v_type - | MI_Function f -> on_fun cb f + | MI_Module me -> on_module aenv me + | MI_Variable x -> on_ty aenv x.v_type + | MI_Function f -> on_fun aenv f -and on_fun (cb : cb) (fun_ : function_) = - on_fun_sig cb fun_.f_sig; - on_fun_body cb fun_.f_def +(* -------------------------------------------------------------------- *) +and on_fun (aenv : aenv) (fun_ : function_) = + on_fun_sig aenv fun_.f_sig; + on_fun_body aenv fun_.f_def -and on_fun_sig (cb : cb) (fsig : funsig) = - on_ty cb fsig.fs_arg; - on_ty cb fsig.fs_ret +(* -------------------------------------------------------------------- *) +and on_fun_sig (aenv : aenv) (fsig : funsig) = + on_ty aenv fsig.fs_arg; + on_ty aenv fsig.fs_ret -and on_fun_body (cb : cb) (fbody : function_body) = +(* -------------------------------------------------------------------- *) +and on_fun_body (aenv : aenv) (fbody : function_body) = match fbody with - | FBalias xp -> on_xp cb xp - | FBdef fdef -> on_fun_def cb fdef - | FBabs oi -> on_oi cb oi + | FBalias xp -> on_xp aenv xp + | FBdef fdef -> on_fun_def aenv fdef + | FBabs oi -> on_oi aenv oi -and on_fun_def (cb : cb) (fdef : function_def) = - List.iter (fun v -> on_ty cb v.v_type) fdef.f_locals; - on_stmt cb fdef.f_body; - fdef.f_ret |> oiter (on_expr cb); - on_uses cb fdef.f_uses +(* -------------------------------------------------------------------- *) +and on_fun_def (aenv : aenv) (fdef : function_def) = + List.iter (fun v -> on_ty aenv v.v_type) fdef.f_locals; + on_stmt aenv fdef.f_body; + fdef.f_ret |> oiter (on_expr aenv); + on_uses aenv fdef.f_uses -and on_uses (cb : cb) (uses : uses) = - List.iter (on_xp cb) uses.us_calls; - Sx.iter (on_xp cb) uses.us_reads; - Sx.iter (on_xp cb) uses.us_writes +(* -------------------------------------------------------------------- *) +and on_uses (aenv : aenv) (uses : uses) = + List.iter (on_xp aenv) uses.us_calls; + Sx.iter (on_xp aenv) uses.us_reads; + Sx.iter (on_xp aenv) uses.us_writes -and on_oi (cb : cb) (oi : OI.t) = - List.iter (on_xp cb) (OI.allowed oi) +(* -------------------------------------------------------------------- *) +and on_oi (aenv : aenv) (oi : OI.t) = + List.iter (on_xp aenv) (OI.allowed oi) (* -------------------------------------------------------------------- *) -let on_typeclasses cb s = - Sp.iter (fun p -> cb (`Typeclass p)) s +and on_typeclasses (aenv : aenv) s = + Sp.iter (fun p -> aenv.cb (`Typeclass p)) s -let on_typarams cb typarams = - List.iter (fun (_,s) -> on_typeclasses cb s) typarams +and on_typarams (aenv : aenv) typarams = + List.iter (fun (_,s) -> on_typeclasses aenv s) typarams (* -------------------------------------------------------------------- *) -let on_tydecl (cb : cb) (tyd : tydecl) = - on_typarams cb tyd.tyd_params; +and on_tydecl (aenv : aenv) (tyd : tydecl) = + on_typarams aenv tyd.tyd_params; match tyd.tyd_type with - | `Concrete ty -> on_ty cb ty - | `Abstract s -> on_typeclasses cb s + | `Concrete ty -> on_ty aenv ty + | `Abstract s -> on_typeclasses aenv s | `Record (f, fds) -> - on_form cb f; - List.iter (on_ty cb |- snd) fds + on_form aenv f; + List.iter (on_ty aenv |- snd) fds | `Datatype dt -> - List.iter (List.iter (on_ty cb) |- snd) dt.tydt_ctors; - List.iter (on_form cb) [dt.tydt_schelim; dt.tydt_schcase] + List.iter (List.iter (on_ty aenv) |- snd) dt.tydt_ctors; + List.iter (on_form aenv) [dt.tydt_schelim; dt.tydt_schcase] -let on_typeclass cb tc = - oiter (fun p -> cb (`Typeclass p)) tc.tc_prt; - List.iter (fun (_,ty) -> on_ty cb ty) tc.tc_ops; - List.iter (fun (_,f) -> on_form cb f) tc.tc_axs +and on_typeclass (aenv : aenv) tc = + oiter (fun p -> aenv.cb (`Typeclass p)) tc.tc_prt; + List.iter (fun (_,ty) -> on_ty aenv ty) tc.tc_ops; + List.iter (fun (_,f) -> on_form aenv f) tc.tc_axs (* -------------------------------------------------------------------- *) -let on_opdecl (cb : cb) (opdecl : operator) = - on_typarams cb opdecl.op_tparams; +and on_opdecl (aenv : aenv) (opdecl : operator) = + on_typarams aenv opdecl.op_tparams; let for_kind () = match opdecl.op_kind with | OB_pred None -> () | OB_pred (Some (PR_Plain f)) -> - on_form cb f + on_form aenv f | OB_pred (Some (PR_Ind pri)) -> - on_bindings cb pri.pri_args; + on_bindings aenv pri.pri_args; List.iter (fun ctor -> - on_gbindings cb ctor.prc_bds; - List.iter (on_form cb) ctor.prc_spec) + on_gbindings aenv ctor.prc_bds; + List.iter (on_form aenv) ctor.prc_spec) pri.pri_ctors | OB_nott nott -> - List.iter (on_ty cb |- snd) nott.ont_args; - on_ty cb nott.ont_resty; - on_expr cb nott.ont_body + List.iter (on_ty aenv |- snd) nott.ont_args; + on_ty aenv nott.ont_resty; + on_expr aenv nott.ont_body | OB_oper None -> () | OB_oper Some b -> match b with - | OP_Constr _ | OP_Record _ | OP_Proj _ -> assert false - | OP_TC -> assert false - | OP_Plain f -> on_form cb f + | OP_Constr _ | OP_Record _ | OP_Proj _ | OP_TC -> () + | OP_Plain f -> on_form aenv f | OP_Fix f -> let rec on_mpath_branches br = match br with | OPB_Leaf (bds, e) -> - List.iter (on_bindings cb) bds; - on_expr cb e + List.iter (on_bindings aenv) bds; + on_expr aenv e | OPB_Branch br -> Parray.iter on_mpath_branch br @@ -418,45 +479,48 @@ let on_opdecl (cb : cb) (opdecl : operator) = in on_mpath_branches f.opf_branches - in on_ty cb opdecl.op_ty; for_kind () + in on_ty aenv opdecl.op_ty; for_kind () (* -------------------------------------------------------------------- *) -let on_axiom (cb : cb) (ax : axiom) = - on_typarams cb ax.ax_tparams; - on_form cb ax.ax_spec +and on_axiom (aenv : aenv) (ax : axiom) = + on_typarams aenv ax.ax_tparams; + on_form aenv ax.ax_spec (* -------------------------------------------------------------------- *) -let on_modsig (cb:cb) (ms:module_sig) = - List.iter (fun (_,mt) -> on_modty cb mt) ms.mis_params; +and on_modsig (aenv : aenv) (ms:module_sig) = + List.iter (fun (_,mt) -> on_modty aenv mt) ms.mis_params; List.iter (fun (Tys_function fs) -> - on_ty cb fs.fs_arg; - List.iter (fun x -> on_ty cb x.ov_type) fs.fs_anames; - on_ty cb fs.fs_ret;) ms.mis_body; - Msym.iter (fun _ oi -> on_oi cb oi) ms.mis_oinfos - -let on_ring cb r = - on_ty cb r.r_type; - let on_p p = cb (`Op p) in + on_ty aenv fs.fs_arg; + List.iter (fun x -> on_ty aenv x.ov_type) fs.fs_anames; + on_ty aenv fs.fs_ret;) ms.mis_body; + Msym.iter (fun _ oi -> on_oi aenv oi) ms.mis_oinfos + +(* -------------------------------------------------------------------- *) +and on_ring (aenv : aenv) (r : ring) = + on_ty aenv r.r_type; + let on_p p = on_opname aenv p in List.iter on_p [r.r_zero; r.r_one; r.r_add; r.r_mul]; List.iter (oiter on_p) [r.r_opp; r.r_exp; r.r_sub]; match r.r_embed with | `Direct | `Default -> () | `Embed p -> on_p p -let on_field cb f = - on_ring cb f.f_ring; - let on_p p = cb (`Op p) in +(* -------------------------------------------------------------------- *) +and on_field (aenv : aenv) (f : field) = + on_ring aenv f.f_ring; + let on_p p = on_opname aenv p in on_p f.f_inv; oiter on_p f.f_div -let on_instance cb ty tci = - on_typarams cb (fst ty); - on_ty cb (snd ty); +(* -------------------------------------------------------------------- *) +and on_instance (aenv : aenv) ty tci = + on_typarams aenv (fst ty); + on_ty aenv (snd ty); match tci with - | `Ring r -> on_ring cb r - | `Field f -> on_field cb f + | `Ring r -> on_ring aenv r + | `Field f -> on_field aenv f | `General p -> (* FIXME section: ring/field use type class that do not exists *) - cb (`Typeclass p) + aenv.cb (`Typeclass p) (* -------------------------------------------------------------------- *) type sc_name = @@ -973,7 +1037,7 @@ let generalize_module to_gen prefix me = | _ -> () in try - on_mp check_gen mp; + on_mp (mkaenv to_gen.tg_env.sc_env check_gen) mp; to_gen, Some (Th_module me) with Inline -> @@ -1159,27 +1223,7 @@ let check_tyd scenv prefix name tyd = d_modty = []; d_tc = [`Global]; } in - on_tydecl (cb scenv from cd) tyd - -(* -let cb_glob scenv (who:cbarg) = - match who with - | `Type p -> - if is_local scenv who then - hierror "global definition can't depend of local type %s" - (EcPath.tostring p) - | `Module mp -> - check_glob_mp scenv mp - | `Op p -> - if is_local scenv who then - hierror "global definition can't depend of local op %s" - (EcPath.tostring p) - | `ModuleType p -> - if is_local scenv who then - hierror "global definition can't depend of local module type %s" - (EcPath.tostring p) - | `Ax _ | `Typeclass _ -> assert false -*) + on_tydecl (mkaenv scenv.sc_env (cb scenv from cd)) tyd let is_abstract_op op = match op.op_kind with @@ -1205,7 +1249,7 @@ let check_op scenv prefix name op = d_modty = []; d_tc = [`Global]; } in - on_opdecl (cb scenv from cd) op + on_opdecl (mkaenv scenv.sc_env (cb scenv from cd)) op | `Global -> let cd = { @@ -1217,7 +1261,7 @@ let check_op scenv prefix name op = d_modty = []; d_tc = [`Global]; } in - on_opdecl (cb scenv from cd) op + on_opdecl (mkaenv scenv.sc_env (cb scenv from cd)) op let is_inth scenv = match scenv.sc_name with @@ -1236,7 +1280,7 @@ let check_ax (scenv : scenv) (prefix : path) (name : symbol) (ax : axiom) = d_modty = [`Global]; d_tc = [`Global]; } in - let doit = on_axiom (cb scenv from cd) in + let doit = on_axiom (mkaenv scenv.sc_env (cb scenv from cd)) in let error b s1 s = if b then hierror "%s %a %s" s1 (pp_axname scenv) path s in @@ -1268,7 +1312,7 @@ let check_modtype scenv prefix name ms = | `Local -> check_section scenv from | `Global -> if scenv.sc_insec then - on_modsig (cb scenv from cd_glob) ms.tms_sig + on_modsig (mkaenv scenv.sc_env (cb scenv from cd_glob)) ms.tms_sig let check_module scenv prefix tme = @@ -1288,7 +1332,7 @@ let check_module scenv prefix tme = d_modty = [`Global]; d_tc = [`Global]; } in - on_module (cb scenv from cd) me + on_module (mkaenv scenv.sc_env (cb scenv from cd)) me | `Declare -> (* Should be SC_decl_mod ... *) assert false @@ -1297,7 +1341,7 @@ let check_typeclass scenv prefix name tc = let from = ((tc.tc_loca :> locality), `Typeclass path) in if tc.tc_loca = `Local then check_section scenv from else - on_typeclass (cb scenv from cd_glob) tc + on_typeclass (mkaenv scenv.sc_env (cb scenv from cd_glob)) tc let check_instance scenv ty tci lc = let from = (lc :> locality), `Instance tci in @@ -1305,10 +1349,11 @@ let check_instance scenv ty tci lc = else if scenv.sc_insec then match tci with - | `Ring _ | `Field _ -> on_instance (cb scenv from cd_glob) ty tci + | `Ring _ | `Field _ -> + on_instance (mkaenv scenv.sc_env (cb scenv from cd_glob) )ty tci | `General _ -> let cd = { cd_glob with d_ty = [`Declare; `Global]; } in - on_instance (cb scenv from cd) ty tci + on_instance (mkaenv scenv.sc_env (cb scenv from cd)) ty tci (* -----------------------------------------------------------*) let enter_theory (name:symbol) (lc:is_local) (mode:thmode) scenv : scenv = @@ -1527,7 +1572,7 @@ let add_decl_mod id mt scenv = d_tc = [`Global]; } in let from = `Declare, `Module (mpath_abs id []) in - on_mty_mr (cb scenv from cd) mt; + on_mty_mr (mkaenv scenv.sc_env (cb scenv from cd)) mt; { scenv with sc_env = EcEnv.Mod.declare_local id mt scenv.sc_env; sc_items = SC_decl_mod (id, mt) :: scenv.sc_items } From 2ca19dc2e96e9a1e30a905715adf85a6af441c8f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 12 Jan 2026 16:16:58 +0100 Subject: [PATCH 12/26] When doing section-analysis, recurse in types body --- src/ecSection.ml | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/ecSection.ml b/src/ecSection.ml index 8f54c0bc0a..6d49c3f0af 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -98,12 +98,13 @@ type aenv = { } and acache = { - op : Sp.t; (* Operator declaration already handled *) + op : Sp.t; (* Operator declaration already handled *) + type_ : Sp.t; (* Type declaration already handled *) } (* -------------------------------------------------------------------- *) let empty_acache : acache = - { op = Sp.empty; } + { op = Sp.empty; type_ = Sp.empty; } (* -------------------------------------------------------------------- *) let mkaenv (env : EcEnv.env) (cb : cb) : aenv = @@ -154,9 +155,18 @@ and on_ty (aenv : aenv) (ty : ty) = | Tvar _ -> () | Tglob _ -> () | Ttuple tys -> List.iter (on_ty aenv) tys - | Tconstr (p, tys) -> aenv.cb (`Type p); List.iter (on_ty aenv) tys + | Tconstr (p, tys) -> on_tyname aenv p; List.iter (on_ty aenv) tys | Tfun (ty1, ty2) -> List.iter (on_ty aenv) [ty1; ty2] +(* -------------------------------------------------------------------- *) +and on_tyname (aenv : aenv) (p : path) = + aenv.cb (`Type p); + if not (Sp.mem p !(aenv.cache).type_) then begin + let cache = { !(aenv.cache) with type_ = Sp.add p !(aenv.cache).type_ } in + aenv.cache := cache; + on_tydecl aenv (EcEnv.Ty.by_path p aenv.env) + end + (* -------------------------------------------------------------------- *) and on_opname (aenv : aenv) (p : EcPath.path) = aenv.cb (`Op p); From 4566042c43d31afd77ad7ad60dd6a3d6c3579dae Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 12 Jan 2026 15:08:14 +0100 Subject: [PATCH 13/26] Fix dependency analysis Check modules in types + properly classify declared modules as declared --- src/ecCoreModules.ml | 3 +++ src/ecCoreModules.mli | 2 ++ src/ecSection.ml | 34 ++++++++++++++++++++-------------- 3 files changed, 25 insertions(+), 14 deletions(-) diff --git a/src/ecCoreModules.ml b/src/ecCoreModules.ml index 6f96118abe..a07f9ab2a3 100644 --- a/src/ecCoreModules.ml +++ b/src/ecCoreModules.ml @@ -494,6 +494,9 @@ type top_module_expr = { tme_loca : locality; } +let is_me_body_alias (body : module_body) = + match body with ME_Alias _ -> true | _ -> false + (* -------------------------------------------------------------------- *) let ur_hash = EcAst.ur_hash diff --git a/src/ecCoreModules.mli b/src/ecCoreModules.mli index 1b84c0df22..178b4c581f 100644 --- a/src/ecCoreModules.mli +++ b/src/ecCoreModules.mli @@ -247,6 +247,8 @@ type top_module_expr = { tme_loca : locality; } +val is_me_body_alias : module_body -> bool + (* -------------------------------------------------------------------- *) val mty_equal : module_type -> diff --git a/src/ecSection.ml b/src/ecSection.ml index 6d49c3f0af..51d65680d3 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -42,7 +42,10 @@ let pp_cbarg env fmt (who : cbarg) = | `Module mp -> let ppe = match mp.m_top with - | `Local id -> EcPrinting.PPEnv.add_locals ppe [id] + | `Local id -> + if EcEnv.Mod.is_declared id env then + ppe + else EcPrinting.PPEnv.add_locals ppe [id] | _ -> ppe in Format.fprintf fmt "module %a" (EcPrinting.pp_topmod ppe) mp | `ModuleType p -> @@ -153,7 +156,7 @@ and on_ty (aenv : aenv) (ty : ty) = match ty.ty_node with | Tunivar _ -> () | Tvar _ -> () - | Tglob _ -> () + | Tglob m -> aenv.cb (`Module (mident m)) | Ttuple tys -> List.iter (on_ty aenv) tys | Tconstr (p, tys) -> on_tyname aenv p; List.iter (on_ty aenv) tys | Tfun (ty1, ty2) -> List.iter (on_ty aenv) [ty1; ty2] @@ -380,10 +383,10 @@ and on_module (aenv : aenv) (me : module_expr) = (* -------------------------------------------------------------------- *) and on_mstruct (aenv : aenv) (st : module_structure) = - List.iter (on_mpath_mstruct1 aenv) st.ms_body + List.iter (on_mstruct1 aenv) st.ms_body (* -------------------------------------------------------------------- *) -and on_mpath_mstruct1 (aenv : aenv) (item : module_item) = +and on_mstruct1 (aenv : aenv) (item : module_item) = match item with | MI_Module me -> on_module aenv me | MI_Variable x -> on_ty aenv x.v_type @@ -578,15 +581,16 @@ let pp_thname scenv = (* -------------------------------------------------------------------- *) let locality (env : EcEnv.env) (who : cbarg) = match who with - | `Type p -> (EcEnv. Ty.by_path p env).tyd_loca - | `Op p -> (EcEnv. Op.by_path p env).op_loca - | `Ax p -> (EcEnv. Ax.by_path p env).ax_loca - | `Typeclass p -> ((EcEnv.TypeClass.by_path p env).tc_loca :> locality) - | `Module mp -> - begin match EcEnv.Mod.by_mpath_opt mp env with + | `Type p -> (EcEnv.Ty.by_path p env).tyd_loca + | `Op p -> (EcEnv.Op.by_path p env).op_loca + | `Ax p -> (EcEnv.Ax.by_path p env).ax_loca + | `Typeclass p -> ((EcEnv.TypeClass.by_path p env).tc_loca :> locality) + | `Module mp -> begin + match EcEnv.Mod.by_mpath_opt mp env with | Some (_, Some lc) -> lc - (* in this case it should be a quantified module *) - | _ -> `Global + | _ -> + let id = EcPath.mget_ident mp in + if EcEnv.Mod.is_declared id env then `Declare else `Global end | `ModuleType p -> ((EcEnv.ModTy.by_path p env).tms_loca :> locality) | `Instance _ -> assert false @@ -1332,17 +1336,19 @@ let check_module scenv prefix tme = match tme.tme_loca with | `Local -> check_section scenv from | `Global -> - if scenv.sc_insec then + if scenv.sc_insec then begin + let isalias = EcModules.is_me_body_alias tme.tme_expr.me_body in let cd = { d_ty = [`Global]; d_op = [`Global]; d_ax = []; d_sc = []; - d_mod = [`Global]; (* FIXME section: add local *) + d_mod = [`Global] @ (if isalias then [`Declare] else []); d_modty = [`Global]; d_tc = [`Global]; } in on_module (mkaenv scenv.sc_env (cb scenv from cd)) me + end | `Declare -> (* Should be SC_decl_mod ... *) assert false From d049b6e133f4e1d3fd0b378413b0531d7dabe990 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 14 Jan 2026 18:12:17 +0100 Subject: [PATCH 14/26] Build: unify release/dev warnings flags --- src/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune b/src/dune index f5c2eed643..487e9cfcf5 100644 --- a/src/dune +++ b/src/dune @@ -1,7 +1,7 @@ (env (dev (flags :standard -rectypes -w @1..3@5..28@31..39@43@46..47@49..57@61..62-40-9-23-32-67-69 -warn-error -a+31)) (ci (flags :standard -rectypes -w @1..3@5..28@31..39@43@46..47@49..57@61..62-40-9-23-32-67-69 -warn-error +a)) - (release (flags :standard -rectypes) + (release (flags :standard -rectypes -w @1..3@5..28@31..39@43@46..47@49..57@61..62-40-9-23-32-67-69 -warn-error -a) (ocamlopt_flags -O3 -unbox-closures))) From a27f28ee29fe44fd83f363286148a0caff859778 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Dupressoir?= Date: Fri, 21 Nov 2025 15:34:26 +0000 Subject: [PATCH 15/26] fix dockerfiles --- scripts/docker/Dockerfile.base | 4 ++-- scripts/docker/Dockerfile.test | 3 +-- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/scripts/docker/Dockerfile.base b/scripts/docker/Dockerfile.base index b8aff9ce11..1a43903b01 100644 --- a/scripts/docker/Dockerfile.base +++ b/scripts/docker/Dockerfile.base @@ -2,11 +2,11 @@ FROM debian:stable -MAINTAINER Pierre-Yves Strub +LABEL org.opencontainers.image.maintainer="Pierre-Yves Strub " ARG user=charlie -ENV DEBIAN_FRONTEND noninteractive +ENV DEBIAN_FRONTEND=noninteractive RUN \ apt-get -q -y update && \ diff --git a/scripts/docker/Dockerfile.test b/scripts/docker/Dockerfile.test index f8dcd165da..2e9522d3aa 100644 --- a/scripts/docker/Dockerfile.test +++ b/scripts/docker/Dockerfile.test @@ -5,7 +5,6 @@ FROM ./Dockerfile.build ARG EC_VERSION=main RUN \ - opam pin --dev-repo \ - add -n easycrypt https://github.com/EasyCrypt/easycrypt.git#${EC_VERSION} && \ + opam pin add -n easycrypt https://github.com/EasyCrypt/easycrypt.git#${EC_VERSION} && \ opam install -v easycrypt && \ rm -rf .opam/packages.dev/* From 3066b239d876e3a254496328582371a4b02de10a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois=20Dupressoir?= Date: Fri, 21 Nov 2025 15:34:42 +0000 Subject: [PATCH 16/26] add a formosa dockerfile --- scripts/docker/Dockerfile.formosa | 7 +++++++ 1 file changed, 7 insertions(+) create mode 100644 scripts/docker/Dockerfile.formosa diff --git a/scripts/docker/Dockerfile.formosa b/scripts/docker/Dockerfile.formosa new file mode 100644 index 0000000000..8ff3767340 --- /dev/null +++ b/scripts/docker/Dockerfile.formosa @@ -0,0 +1,7 @@ +# syntax = devthefuture/dockerfile-x + +FROM ./Dockerfile.build as build-formosa + +RUN \ + opam install --deps-only --confirm-level=unsafe-yes jasmin && \ + opam clean From fcbac7948909c5fbc70eafbcf9412245e9f41bf9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 14 Jun 2024 21:07:15 +0200 Subject: [PATCH 17/26] [eco]: add a compilation trace (messages + goals) ECO version is now 4. The trace field is optional. The -trace command line option triggers the trace recording in the generated .eco file. --- src/ec.ml | 97 +++++++++++++++++++++++++++++++++++-------- src/ecCommands.ml | 34 +++++++++++++++ src/ecCommands.mli | 2 + src/ecCorePrinting.ml | 2 + src/ecEco.ml | 78 ++++++++++++++++++++++++++++++---- src/ecOptions.ml | 5 ++- src/ecOptions.mli | 1 + src/ecPrinting.ml | 4 ++ 8 files changed, 198 insertions(+), 25 deletions(-) diff --git a/src/ec.ml b/src/ec.ml index 48da43b802..627d25b81b 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -407,15 +407,36 @@ let main () = (* Initialize I/O + interaction module *) let module State = struct type t = { - prvopts : prv_options; - input : string option; - terminal : T.terminal lazy_t; - interactive : bool; - eco : bool; - gccompact : int option; - docgen : bool; - outdirp : string option; + (*---*) prvopts : prv_options; + (*---*) input : string option; + (*---*) terminal : T.terminal lazy_t; + (*---*) interactive : bool; + (*---*) eco : bool; + (*---*) gccompact : int option; + (*---*) docgen : bool; + (*---*) outdirp : string option; + mutable trace : trace1 list option; } + + and trace1 = + { position : int + ; goals : string list option + ; messages : (EcGState.loglevel * string) list } + + module Trace = struct + let trace0 : trace1 = + { position = 0; goals = None; messages = []; } + + let push1_message (trace1 : trace1) (msg, lvl) : trace1 = + { trace1 with messages = (msg, lvl) :: trace1.messages } + + let push_message (trace : trace1 list) msg = + match trace with + | [] -> + [push1_message trace0 msg] + | trace1 :: trace -> + push1_message trace1 msg :: trace + end end in let state : State.t = @@ -471,7 +492,8 @@ let main () = ; eco = false ; gccompact = None ; docgen = false - ; outdirp = None } + ; outdirp = None + ; trace = None } end @@ -493,6 +515,11 @@ let main () = lazy (T.from_channel ~name ~gcstats ~progress (open_in name)) in + let trace0 = + if cmpopts.cmpo_trace then + Some [State.{ position = 0; goals = None; messages = [] }] + else None in + { prvopts = {cmpopts.cmpo_provers with prvo_iterate = true} ; input = Some name ; terminal = terminal @@ -500,7 +527,8 @@ let main () = ; eco = cmpopts.cmpo_noeco ; gccompact = cmpopts.cmpo_compact ; docgen = false - ; outdirp = None } + ; outdirp = None + ; trace = trace0 } end @@ -543,7 +571,8 @@ let main () = ; eco = true ; gccompact = None ; docgen = true - ; outdirp = docopts.doco_outdirp } + ; outdirp = docopts.doco_outdirp + ; trace = None } end in @@ -571,7 +600,20 @@ let main () = assert (nameo <> input); - let eco = EcEco.{ + let eco = + let mktrace (trace : State.trace1 list) : EcEco.ecotrace = + let mktrace1 (trace1 : State.trace1) : int * EcEco.ecotrace1 = + let goals = Option.value ~default:[] trace1.goals in + let messages = + let for1 (lvl, msg) = + Format.sprintf "%s: %s" + (EcGState.string_of_loglevel lvl) + msg in + String.concat "\n" (List.rev_map for1 trace1.messages) in + (trace1.position, EcEco.{ goals; messages; }) + in List.rev_map mktrace1 trace in + + EcEco.{ eco_root = EcEco.{ eco_digest = Digest.file input; eco_kind = kind; @@ -584,6 +626,7 @@ let main () = eco_kind = x.rqd_kind; } in (x.rqd_name, (ecr, x.rqd_direct))) (EcScope.Theory.required scope)); + eco_trace = Option.map mktrace state.trace; } in let out = open_out nameo in @@ -665,7 +708,10 @@ let main () = EcScope.hierror "invalid pragma: `%s'\n%!" x); let notifier (lvl : EcGState.loglevel) (lazy msg) = - T.notice ~immediate:true lvl msg terminal + state.trace <- state.trace |> Option.map (fun trace -> + State.Trace.push_message trace (lvl, msg) + ); + T.notice ~immediate:true lvl msg terminal; in EcCommands.addnotifier notifier; @@ -694,8 +740,25 @@ let main () = let timed = p.EP.gl_debug = Some `Timed in let break = p.EP.gl_debug = Some `Break in let ignore_fail = ref false in + + state.trace <- state.trace |> Option.map (fun trace -> + { State.Trace.trace0 with position = loc.loc_echar } :: trace + ); + try let tdelta = EcCommands.process ~src ~timed ~break p.EP.gl_action in + + state.trace <- state.trace |> Option.map (fun trace -> + match trace with + | [] -> assert false + | trace1 :: trace -> + assert (Option.is_none trace1.State.goals); + let goals = EcCommands.pp_all_goals () in + let goals = if List.is_empty goals then None else Some goals in + let trace1 = { trace1 with goals } in + trace1 :: trace + ); + if p.EP.gl_fail then begin ignore_fail := true; raise (EcScope.HiScopeError (None, "this command is expected to fail")) @@ -713,10 +776,10 @@ let main () = raise (EcScope.toperror_of_exn ~gloc:loc e) end; if T.interactive terminal then begin - let error = - Format.asprintf - "The following error has been ignored:@.@.@%a" - EcPException.exn_printer e in + let error = + Format.asprintf + "The following error has been ignored:@.@.@%a" + EcPException.exn_printer e in T.notice ~immediate:true `Info error terminal end end) diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 9f647c52b4..135a2b3de3 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -912,6 +912,11 @@ let addnotifier (notifier : notifier) = let gstate = EcScope.gstate (oget !context).ct_root in ignore (EcGState.add_notifier notifier gstate) +(* -------------------------------------------------------------------- *) +let notify (level : EcGState.loglevel) fmt = + assert (EcUtils.is_some !context); + EcScope.notify (oget !context).ct_root level fmt + (* -------------------------------------------------------------------- *) let current () = (oget !context).ct_current @@ -1017,7 +1022,36 @@ let pp_current_goal ?(all = false) stream = end end +(* -------------------------------------------------------------------- *) let pp_maybe_current_goal stream = match (Pragma.get ()).pm_verbose with | true -> pp_current_goal ~all:(Pragma.get ()).pm_g_prall stream | false -> () + +(* -------------------------------------------------------------------- *) +let pp_all_goals () = + let scope = current () in + + match S.xgoal scope with + | Some { S.puc_active = Some ({ puc_jdg = S.PSCheck pf }, _) } -> begin + match EcCoreGoal.opened pf with + | None -> + [] + + | Some _ -> + let get_hc { EcCoreGoal.g_hyps; EcCoreGoal.g_concl } = + (EcEnv.LDecl.tohyps g_hyps, g_concl) + in + + let ppe = EcPrinting.PPEnv.ofenv (S.env scope) in + let goals = List.map get_hc (EcCoreGoal.all_opened pf) in + + List.map (fun goal -> + let buffer = Buffer.create 0 in + Format.fprintf + (Format.formatter_of_buffer buffer) + "%a@?" (EcPrinting.pp_goal1 ppe) goal; + Buffer.contents buffer) goals + end + + | _ -> [] diff --git a/src/ecCommands.mli b/src/ecCommands.mli index f61a313f34..a72d31a437 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -36,6 +36,7 @@ val initialize : val current : unit -> EcScope.scope val addnotifier : notifier -> unit +val notify : EcGState.loglevel -> ('a, Format.formatter, unit, unit) format4 -> 'a (* -------------------------------------------------------------------- *) val process_internal : @@ -60,6 +61,7 @@ val doc_comment : [`Global | `Item] * string -> unit (* -------------------------------------------------------------------- *) val pp_current_goal : ?all:bool -> Format.formatter -> unit val pp_maybe_current_goal : Format.formatter -> unit +val pp_all_goals : unit -> string list (* -------------------------------------------------------------------- *) val pragma_verbose : bool -> unit diff --git a/src/ecCorePrinting.ml b/src/ecCorePrinting.ml index d906a61e3c..29051f0a03 100644 --- a/src/ecCorePrinting.ml +++ b/src/ecCorePrinting.ml @@ -112,6 +112,8 @@ module type PrinterAPI = sig val pp_hyps : PPEnv.t -> EcEnv.LDecl.hyps pp val pp_goal : PPEnv.t -> prpo_display -> ppgoal pp + val pp_goal1 : PPEnv.t -> (EcBaseLogic.hyps * form) pp + (* ------------------------------------------------------------------ *) val pp_by_theory : PPEnv.t -> (PPEnv.t -> (EcPath.path * 'a) pp) -> ((EcPath.path * 'a) list) pp diff --git a/src/ecEco.ml b/src/ecEco.ml index cd80c80205..fc8f41c986 100644 --- a/src/ecEco.ml +++ b/src/ecEco.ml @@ -5,7 +5,7 @@ module Json = Yojson (* -------------------------------------------------------------------- *) module Version = struct - let current : int = 3 + let current : int = 4 end (* -------------------------------------------------------------------- *) @@ -16,9 +16,16 @@ type ecoroot = { eco_digest : digest; } +type ecorange = int + +type ecotrace1 = { goals: string list; messages: string; } + +type ecotrace = (ecorange * ecotrace1) list + type eco = { eco_root : ecoroot; eco_depends : ecodepend Mstr.t; + eco_trace : ecotrace option; } and ecodepend = @@ -36,6 +43,24 @@ let flag_of_json (data : Json.t) : bool = let flag_to_json (flag : bool) : Json.t = `Bool flag +(* -------------------------------------------------------------------- *) +let int_of_json (data : Json.t) : int = + match data with + | `Int i -> i + | _ -> raise InvalidEco + +(* -------------------------------------------------------------------- *) +let string_of_json (data : Json.t) : string = + match data with + | `String s -> s + | _ -> raise InvalidEco + +(* -------------------------------------------------------------------- *) +let list_of_json (tx : Json.t -> 'a) (data : Json.t) : 'a list = + match data with + | `List data -> List.map tx data + | _ -> raise InvalidEco + (* -------------------------------------------------------------------- *) let kind_to_json (k : EcLoader.kind) = match k with @@ -71,9 +96,9 @@ let ecoroot_to_map (ecor : ecoroot) : (string * Json.t) list = "digest", digest_to_json ecor.eco_digest ] let ecoroot_of_map (data : Json.t Mstr.t) : ecoroot = - let kd = kind_of_json (Mstr.find_exn InvalidEco "kind" data) in - let dg = digest_of_json (Mstr.find_exn InvalidEco "digest" data) in - { eco_kind = kd; eco_digest = dg; } + let eco_kind = kind_of_json (Mstr.find_exn InvalidEco "kind" data) in + let eco_digest = digest_of_json (Mstr.find_exn InvalidEco "digest" data) in + { eco_kind; eco_digest; } (* -------------------------------------------------------------------- *) let ecoroot_to_json (ecor : ecoroot) : Json.t = @@ -86,6 +111,43 @@ let ecoroot_of_json (data : Json.t) : ecoroot = | _ -> raise InvalidEco +(* -------------------------------------------------------------------- *) +let trace_to_json (trace : ecotrace option) : Json.t = + match trace with + | None -> + `Null + + | Some trace -> + let for1 ((position, { goals; messages; })) = + `Assoc [ + ("position", `Int position); + ("goals" , `List (List.map (fun goal -> `String goal) goals)); + ("messages", `String messages); + ] + in `List (List.map for1 trace) + +let trace_of_json (data : Json.t) : ecotrace option = + match data with + | `Null -> + None + + | `List data -> + let for1 (data : Json.t) = + match data with + | `Assoc data -> + let data = Mstr.of_list data in + let position = Mstr.find_exn InvalidEco "position" data |> int_of_json in + let goals = Mstr.find_exn InvalidEco "goals" data |> list_of_json string_of_json in + let messages = Mstr.find_exn InvalidEco "messages" data |> string_of_json in + (position, { goals; messages; }) + | _ -> + raise InvalidEco + + in Some (List.map for1 data) + + | _ -> + raise InvalidEco + (* -------------------------------------------------------------------- *) let ecodepend_to_json ((ecor, direct) : ecodepend) : Json.t = `Assoc ([ "direct", flag_to_json direct] @ (ecoroot_to_map ecor)) @@ -119,6 +181,7 @@ let to_json (eco : eco) : Json.t = [ "version", `Int Version.current; "echash" , `String EcVersion.hash; "root" , ecoroot_to_json eco.eco_root; + "trace" , trace_to_json eco.eco_trace; "depends", `Assoc depends ] (* -------------------------------------------------------------------- *) @@ -135,10 +198,11 @@ let of_json (data : Json.t) : eco = if echash <> `String EcVersion.hash then raise InvalidEco; - let root = ecoroot_of_json (Mstr.find_exn InvalidEco "root" data) in - let depends = depends_of_json (Mstr.find_exn InvalidEco "depends" data) in + let eco_root = ecoroot_of_json (Mstr.find_exn InvalidEco "root" data) in + let eco_depends = depends_of_json (Mstr.find_exn InvalidEco "depends" data) in + let eco_trace = trace_of_json (Mstr.find_exn InvalidEco "trace" data) in - { eco_root = root; eco_depends = depends; } + { eco_root; eco_depends; eco_trace; } | _ -> raise InvalidEco diff --git a/src/ecOptions.ml b/src/ecOptions.ml index 4997737964..f012e8e8d6 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -25,6 +25,7 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; + cmpo_trace : bool; } and cli_option = { @@ -347,6 +348,7 @@ let specs = { `Spec ("tstats" , `String, "Save timing statistics to "); `Spec ("script" , `Flag , "Computer-friendly output"); `Spec ("no-eco" , `Flag , "Do not cache verification results"); + `Spec ("trace" , `Flag , "Save all goals & messages in .eco"); `Spec ("compact", `Int , "")]); ("cli", "Run EasyCrypt top-level", [ @@ -516,7 +518,8 @@ let cmp_options_of_values ini values input = cmpo_compact = get_int "compact" values; cmpo_tstats = get_string "tstats" values; cmpo_noeco = get_flag "no-eco" values; - cmpo_script = get_flag "script" values; } + cmpo_script = get_flag "script" values; + cmpo_trace = get_flag "trace" values; } let runtest_options_of_values ini values (input, scenarios) = { runo_input = input; diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 5ba1d0f63a..59009718ad 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -21,6 +21,7 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; + cmpo_trace : bool; } and cli_option = { diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index c320e71867..a9f63997db 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3314,6 +3314,10 @@ let pp_goal (ppe : PPEnv.t) (prpo : prpo_display) fmt (g, extra) = (PPGoal.pp_goal1 ~pphyps:false ~prpo ~idx:(i+2) ppe) g) gs +(* -------------------------------------------------------------------- *) +let pp_goal1 (ppe : PPEnv.t) (fmt : Format.formatter) (g : EcBaseLogic.hyps * form) = + PPGoal.pp_goal1 ppe fmt g + (* -------------------------------------------------------------------- *) let pp_ovdecl ppe fmt ov = Format.fprintf fmt "%s : %a" (odfl "_" ov.ov_name) (pp_type ppe) ov.ov_type From b2751ad51c8ea0fcb79e59017ec796fa0f72b969 Mon Sep 17 00:00:00 2001 From: Xingyu Xie Date: Tue, 20 Jan 2026 17:43:37 +0100 Subject: [PATCH 18/26] fix the free memory of the second goal of `byehoare` The second goal generated from byehoare is unsound, in which the procedure arguments are bound in a free memory. This is a small bug introduced in #789 . We need to use the default memory (hr) of the program. --- src/phl/ecPhlDeno.ml | 8 +++++--- tests/byehoare-arg.ec | 28 ++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 3 deletions(-) create mode 100644 tests/byehoare-arg.ec diff --git a/src/phl/ecPhlDeno.ml b/src/phl/ecPhlDeno.ml index 0a6ce9af25..4ea1b7d6cd 100644 --- a/src/phl/ecPhlDeno.ml +++ b/src/phl/ecPhlDeno.ml @@ -86,6 +86,8 @@ let t_phoare_deno_r pre post tc = (* -------------------------------------------------------------------- *) let t_ehoare_deno_r pre post tc = + assert (pre.m = post.m); + let m = pre.m in let env, _, concl = FApi.tc1_eflat tc in let f, bd = @@ -99,11 +101,11 @@ let t_ehoare_deno_r pre post tc = let pr = destr_pr f in let concl_e = f_eHoareF pre pr.pr_fun post in - let mpr, mpo = EcEnv.Fun.hoareF_memenv pr.pr_mem pr.pr_fun env in + let _, mpo = EcEnv.Fun.hoareF_memenv m pr.pr_fun env in (* pre <= bd *) (* building the substitution for the pre *) - let sargs = PVM.add env pv_arg (fst mpr) pr.pr_args PVM.empty in - let smem = Fsubst.f_bind_mem Fsubst.f_subst_id (fst mpr) pr.pr_mem in + let sargs = PVM.add env pv_arg m pr.pr_args PVM.empty in + let smem = Fsubst.f_bind_mem Fsubst.f_subst_id m pr.pr_mem in let pre = Fsubst.f_subst smem (PVM.subst env sargs pre.inv) in let concl_pr = f_xreal_le pre (f_r2xr bd) in diff --git a/tests/byehoare-arg.ec b/tests/byehoare-arg.ec new file mode 100644 index 0000000000..3fd7eb9340 --- /dev/null +++ b/tests/byehoare-arg.ec @@ -0,0 +1,28 @@ +require import AllCore Int Real Xreal. + +module M = { + proc main_int(x : int) = { + return x; + } + + proc main_bool(x : bool) = { + return x; + } +}. + +lemma L &m (_x : int): + Pr [ M.main_int(_x) @ &m : _x = res ] <= 1%r. +proof. +byehoare (_: ((arg = _x) `|` (1%xr)) ==> _) => //. +- proc; auto => &hr. + by apply xle_cxr_r => ->. +qed. + +lemma L1 (&m: {arg: bool}): !arg{m} => + Pr [ M.main_bool(true) @ &m : true] <= 0%r. +proof. +move => arg_eq. +byehoare (_: (!arg{m})%xr ==> _). ++ proc; auto. by rewrite arg_eq. +fail by auto. +abort. From bfec8d691e5f15f1b591058251f969d57d6e46bc Mon Sep 17 00:00:00 2001 From: Lucas Tabary-Maujean Date: Tue, 17 Jun 2025 17:46:47 +0200 Subject: [PATCH 19/26] feat: new source-documented lazy/eager logic. This logic is deliberately slightly less expressive than the one it replaces, which does not hinder usability in any cryptographic context, with the hope that it is simpler to maintain and verify. --- examples/PRG.ec | 12 +- examples/UC/RndO.ec | 3 +- src/ecEnv.ml | 5 +- src/ecHiTacticals.ml | 3 +- src/ecParser.mly | 20 +- src/ecParsetree.ml | 14 +- src/phl/ecPhlEager.ml | 864 +++++++++++++------------------- src/phl/ecPhlEager.mli | 180 +++---- theories/crypto/PROM.ec | 3 +- theories/distributions/SDist.ec | 13 +- 10 files changed, 465 insertions(+), 652 deletions(-) diff --git a/examples/PRG.ec b/examples/PRG.ec index f32ddf910b..870a3ce0eb 100644 --- a/examples/PRG.ec +++ b/examples/PRG.ec @@ -340,11 +340,8 @@ section. by wp; rnd; wp; rnd{2}; auto; rewrite dseed_ll. (* presampling ~ postsampling *) seq 2 2: (={glob A, glob F, glob Plog}); first by sim. - eager (H: Resample.resample(); ~ Resample.resample(); - : ={glob Plog} ==> ={glob Plog}) - : (={glob A, glob Plog, glob F})=> //; - first by sim. - eager proc H (={glob Plog, glob F})=> //. + eager call (: ={glob Plog, glob A, glob F}). + eager proc (={glob Plog, glob F}) => //; try sim. + eager proc; inline Resample.resample. swap{1} 3 3. swap{2} [4..5] 2. swap{2} [6..8] 1. swap{1} 4 3. swap{1} 4 2. swap{2} 2 4. @@ -357,10 +354,9 @@ section. by wp; rnd{2}; auto=> />; smt (size_ge0). rcondt{2} 1; first by move=> &hr; auto=> /#. rcondf{2} 3; first by move=> &hr; auto=> /#. - + by sim. - + by sim. + by sim. + by eager proc; swap{1} 1 4; sim. - by sim. + by auto. qed. lemma P_PrgI &m: diff --git a/examples/UC/RndO.ec b/examples/UC/RndO.ec index 2450f14fbb..e7b3c09838 100644 --- a/examples/UC/RndO.ec +++ b/examples/UC/RndO.ec @@ -681,8 +681,7 @@ lemma eager_D : D(RRO).distinguish, RRO.resample(); : ={glob D, FRO.m} ==> ={FRO.m, glob D} /\ ={res}]. proof. - eager proc (H_: RRO.resample(); ~ RRO.resample();: ={FRO.m} ==> ={FRO.m}) - (={FRO.m}) =>//; try by sim. + eager proc (={FRO.m}) => //; try by sim. + by apply eager_init. + by apply eager_get. + by apply eager_set. + by apply eager_rem. + by apply eager_sample. + by apply eager_in_dom. + by apply eager_restrK. diff --git a/src/ecEnv.ml b/src/ecEnv.ml index a4a5c8a7ca..4ccfcc7ae8 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2360,7 +2360,7 @@ module NormMp = struct match item with | MI_Module me -> mod_use env rm fdone us (EcPath.mqname mp me.me_name) | MI_Variable v -> add_var env (xpath mp v.v_name) us - | MI_Function f -> fun_use_aux env rm fdone us (xpath mp f.f_name) + | MI_Function f -> gen_fun_use env fdone rm us (xpath mp f.f_name) and body_use env rm fdone mp us comps body = match body with @@ -2372,9 +2372,6 @@ module NormMp = struct | ME_Structure ms -> List.fold_left (item_use env rm fdone mp) us ms.ms_body - and fun_use_aux env rm fdone us f = - gen_fun_use env fdone rm us f - let mod_use_top env mp = let mp = norm_mpath env mp in let me, _ = Mod.by_mpath mp env in diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index 9eb6521e35..45af108525 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -223,9 +223,8 @@ and process1_phl (_ : ttenv) (t : phltactic located) (tc : tcenv1) = | Peager_if -> EcPhlEager.process_if | Peager_while info -> EcPhlEager.process_while info | Peager_fun_def -> EcPhlEager.process_fun_def - | Peager_fun_abs infos -> curry EcPhlEager.process_fun_abs infos + | Peager_fun_abs infos -> EcPhlEager.process_fun_abs infos | Peager_call info -> EcPhlEager.process_call info - | Peager infos -> curry EcPhlEager.process_eager infos | Pbd_equiv (nm, f1, f2) -> EcPhlConseq.process_bd_equiv nm (f1, f2) | Pauto -> EcPhlAuto.t_auto ~conv:`Conv | Plossless -> EcPhlHiAuto.t_lossless diff --git a/src/ecParser.mly b/src/ecParser.mly index 46205d02b5..a1c9acf083 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2847,35 +2847,25 @@ logtactic: | WLOG b=boption(SUFF) COLON ids=loc(ipcore_name)* SLASH f=form { Pwlog (ids, b, f) } -eager_info: -| h=ident - { LE_done h } - -| LPAREN h=ident COLON s1=stmt TILD s2=stmt COLON pr=form LONGARROW po=form RPAREN - { LE_todo (h, s1, s2, pr, po) } - eager_tac: -| SEQ n1=codepos1 n2=codepos1 i=eager_info COLON p=sform - { Peager_seq (i, (n1, n2), p) } +| SEQ n1=codepos1 n2=codepos1 COLON s=stmt COLON p=form_or_double_form + { Peager_seq ((n1, n2), s, p) } | IF { Peager_if } -| WHILE i=eager_info +| WHILE i=sform { Peager_while i } | PROC { Peager_fun_def } -| PROC i=eager_info f=sform - { Peager_fun_abs (i, f) } +| PROC f=sform + { Peager_fun_abs f } | CALL info=gpterm(call_info) { Peager_call info } -| info=eager_info COLON p=sform - { Peager (info, p) } - form_or_double_form: | f=sform { Single f } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 0189383d61..e9991a3eae 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -602,11 +602,6 @@ type trans_formula = type trans_info = trans_kind * trans_formula -(* -------------------------------------------------------------------- *) -type eager_info = - | LE_done of psymbol - | LE_todo of psymbol * pstmt * pstmt * pformula * pformula - (* -------------------------------------------------------------------- *) type bdh_split = | BDH_split_bop of pformula * pformula * pformula option @@ -782,13 +777,12 @@ type phltactic = (* Eager *) - | Peager_seq of (eager_info * pcodepos1 pair * pformula) + | Peager_seq of (pcodepos1 pair * pstmt * pformula doption) | Peager_if - | Peager_while of (eager_info) + | Peager_while of pformula | Peager_fun_def - | Peager_fun_abs of (eager_info * pformula) - | Peager_call of (call_info gppterm) - | Peager of (eager_info * pformula) + | Peager_fun_abs of pformula + | Peager_call of call_info gppterm (* Relation between logic *) | Pbd_equiv of (side * pformula * pformula) diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml index 72859bb28a..e4f23a7900 100644 --- a/src/phl/ecPhlEager.ml +++ b/src/phl/ecPhlEager.ml @@ -1,299 +1,358 @@ -(* -------------------------------------------------------------------- *) -open EcUtils -open EcLocation open EcAst -open EcTypes -open EcModules -open EcFol -open EcEnv -open EcPV - open EcCoreGoal +open EcEnv +open EcFol open EcLowGoal open EcLowPhlGoal - -module ER = EcReduction -module PT = EcProofTerm +open EcMatching.Zipper +open EcModules +open EcPV +open EcTypes +open EcUtils +module ER = EcReduction +module PT = EcProofTerm module TTC = EcProofTyping -(* -------------------------------------------------------------------- *) -let pf_destr_eqobsS pf env f = - let es = destr_equivS f in - let of_form = - try Mpv2.of_form env - with Not_found -> tc_error pf "cannot reconize a set of equalities" +(** Builds a formula that represents equality on the list of variables [l] + between two memories [ml] and [mr] *) +let list_eq_to_form ml mr (l, l_glob) = + let to_form m = List.map (fun (pv, ty) -> (f_pvar pv ty m).inv) in + let to_form_glob m = + List.map (fun x -> (f_glob (EcPath.mget_ident x) m).inv) in - (es, es.es_sl, es.es_sr, of_form (es_pr es), of_form (es_po es)) - -(* -------------------------------------------------------------------- *) -let pf_hSS pf hyps h = - let tH = LDecl.hyp_by_id h hyps in - (tH, pf_destr_eqobsS pf (LDecl.toenv hyps) tH) - -(* -------------------------------------------------------------------- *) -let tc1_destr_eagerS tc s s' = - let env = FApi.tc1_env tc in - let es = tc1_as_equivS tc in - let c , c' = es.es_sl, es.es_sr in - let s1, c = s_split env (Zpr.cpos (List.length s.s_node)) c in - let c',s1' = s_split env (Zpr.cpos (List.length c'.s_node - List.length s'.s_node)) c' in - - if not (List.all2 i_equal s1 s.s_node) then begin - let ppe = EcPrinting.PPEnv.ofenv (FApi.tc1_env tc) in + { + ml; + mr; + inv = + f_eqs + (to_form ml l @ to_form_glob ml l_glob) + (to_form mr l @ to_form_glob mr l_glob); + } + +(** Returns a formula that describes equality on all variables from one side of + the memory present in the formula [q]. + + Example: If [q] is [(a{ml} \/ b{m'} /\ c{ml})], (with [ml] the first bound + memory, [mr] the second and [m'] another memory, distinct from [ml]) then + this function returns [(a{ml} = a{mr} /\ c{ml} = c{mr})]. The result of this + operation is sometimes denoted [={q.m1}]. *) +let eq_on_sided_form env { ml; mr; inv } = + PV.fv env ml inv |> PV.elements |> list_eq_to_form ml mr + +(** Returns a formula that describes equality on all variables from both + memories in predicate [inv], as well as equality on all variables read from + [c]. + + This is used to implement what is denoted [Eq] in the module documentation, + i.e. equality on the whole memory. *) +let eq_on_form_and_stmt env { ml; mr; inv } c = + s_read env c + |> PV.union (PV.fv env ml inv) + |> PV.union (PV.fv env mr inv) + |> PV.elements |> list_eq_to_form ml mr + +(** Equality on all variables from a function [f] *) +let eq_on_fun env m1 m2 f = + let l, l' = NormMp.flatten_use (NormMp.fun_use env f) in + let l_glob = List.map EcPath.mident l in + let l_pv = List.map (fun (x, ty) -> (pv_glob x, ty)) l' in + list_eq_to_form m1 m2 (l_pv, l_glob) + +(** Given a goal environment [tc] and a statement [s], if the goal is an + equivalence of the shape [s; c ~ c'; s], returns the same equivalence goal, + as well as the terms c and c'. + + Yields an error if the statements are not of the right form. *) +let destruct_eager tc s = + let env = FApi.tc1_env tc + and es = tc1_as_equivS tc + and ss = List.length s.s_node in + + let c, c' = (es.es_sl, es.es_sr) in + let z, c = s_split env (Zpr.cpos ss) c + and c', z' = s_split env (Zpr.cpos (List.length c'.s_node - ss)) c' in + + let env, _, _ = FApi.tc1_eflat tc in + let z_eq_s = ER.EqTest.for_stmt env (stmt z) s + and z'_eq_s = ER.EqTest.for_stmt env (stmt z') s in + + if z_eq_s && z'_eq_s then (es, stmt c, stmt c') + else + let err_stmt, prefix = + if z_eq_s then (z', "tail of the right") else (z, "head of the left") + and ppe = EcPrinting.PPEnv.ofenv (FApi.tc1_env tc) in tc_error_lazy !!tc (fun fmt -> - Format.fprintf fmt - "the head of the left statement is not of the right form:@\n%a should be@\n%a" - (EcPrinting.pp_stmt ppe) (stmt s1) (EcPrinting.pp_stmt ppe) s) - end; - - if not (List.all2 i_equal s1' s'.s_node) then begin - let ppe = EcPrinting.PPEnv.ofenv (FApi.tc1_env tc) in - tc_error_lazy !!tc (fun fmt -> - Format.fprintf fmt - "the tail of the right statement is not of the right form:@\n%a should be@\n%a" - (EcPrinting.pp_stmt ppe) (stmt s1') (EcPrinting.pp_stmt ppe) s') - end; - - (es, stmt c, stmt c') - -(* -------------------------------------------------------------------- *) -(* This ensure condition (d) and (e) of the eager_seq rule. *) -let pf_compat pf env modS modS' eqR eqIs eqXs = - if not (Mpv2.subset eqIs eqR) then begin - let ml, mr = EcIdent.create "&1_dummy", EcIdent.create "&2_dummy" in - let f_true = {ml; mr; inv=f_true} in - let eqR = Mpv2.to_form_ts_inv eqR f_true in - let eqIs = Mpv2.to_form_ts_inv eqIs f_true in - tc_error_lazy pf (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt "%a should be included in %a" - (EcPrinting.pp_form ppe) eqIs.inv (EcPrinting.pp_form ppe) eqR.inv) - end; - - let check_pv x1 x2 _ = - if not (Mpv2.mem x1 x2 eqXs) - && (PV.mem_pv env x1 modS || PV.mem_pv env x2 modS') - then - tc_error_lazy pf (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in Format.fprintf fmt - "equality of %a and %a should be ensured by the swapping statement" - (EcPrinting.pp_pv ppe) x1 (EcPrinting.pp_pv ppe) x2) + "eager: the %s statement is not of the right form:@\n\ + %a should be@\n\ + %a" + prefix (EcPrinting.pp_stmt ppe) (stmt err_stmt) + (EcPrinting.pp_stmt ppe) s) + +(** Given a goal environment with a current goal of the shape [s; op ~ op'; s], + returns the triplet [(es, s, op, op')]. Yields an error if the goal doesn't + have the right shape *) +let destruct_on_op id_op tc = + let env = FApi.tc1_env tc and es = tc1_as_equivS tc in + let s = + try + let s, _ = split_at_cpos1 env (-1, `ByMatch (None, id_op)) es.es_sl + (* ensure the right statement also contains an [id_op]: *) + and _, _ = split_at_cpos1 env (1, `ByMatch (None, id_op)) es.es_sr in + s + with InvalidCPos -> + tc_error_lazy !!tc (fun fmt -> + Format.fprintf fmt "eager: invalid pivot statement") + in - and check_glob m = - if not (Mpv2.mem_glob m eqXs) - && (PV.mem_glob env m modS || PV.mem_glob env m modS') - then + if List.is_empty s then + tc_error_lazy !!tc (fun fmt -> + Format.fprintf fmt "eager: empty swapping statement"); + + let es, c1, c2 = destruct_eager tc (stmt s) in + match (c1.s_node, c2.s_node) with + | [ i1 ], [ i2 ] -> (es, stmt s, i1, i2) + | _, _ -> + let verb, side = + if List.length c1.s_node = 1 then ("precede", "right") + else ("follow", "left") + in + tc_error_lazy !!tc (fun fmt -> + Format.fprintf fmt + "eager: no statements may %s the %s pivot statement." verb side) + +let rec match_eq tc m1 m2 t1 t2 = + match (t1.f_node, t2.f_node) with + | Fpvar (p1, m1_), Fpvar (p2, m2_) -> + ((m1 = m1_ && m2 = m2_) || (m1 = m2_ && m2 = m1_)) && p1 = p2 + | Fglob (p1, m1_), Fglob (p2, m2_) -> + ((m1 = m1_ && m2 = m2_) || (m1 = m2_ && m2 = m1_)) && p1 = p2 + | Ftuple l1, Ftuple l2 -> List.for_all2 (match_eq tc m1 m2) l1 l2 + | _ -> false + +(** Ensure that a given proposition is a conjunction of same-name variables + equalities between two given memories. + + This test is of course a bit conservative but should be sufficient for all + the use cases it covers *) +let rec ensure_eq_shape tc m1 m2 q = + match q.f_node with + | Fapp (_, [ q1; q2 ]) when is_and q -> + ensure_eq_shape tc m1 m2 q1 && ensure_eq_shape tc m1 m2 q2 + | Fapp (_, [ t1; t2 ]) when is_eq q -> match_eq tc m1 m2 t1 t2 + | _ -> is_true q + +(** Ensure the swapping statement [s] only interacts with global variables. *) +let check_only_global pf env s = + let sw = s_write env s + and sr = s_read env s + and check_mp _ = () + and check_glob v _ = + if is_loc v then tc_error_lazy pf (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt - "equality of %a should be ensured by the swapping statement" - (EcPrinting.pp_topmod ppe) m) - + let ppe = EcPrinting.PPEnv.ofenv env in + Format.fprintf fmt + "eager: swapping statement may use only global variables: %a" + (EcPrinting.pp_pv ppe) v) in - Mpv2.iter check_pv check_glob eqR + PV.iter check_glob check_mp sw; + PV.iter check_glob check_mp sr (* -------------------------------------------------------------------- *) -let t_eager_seq_r i j eqR h tc = - let env, hyps, _ = FApi.tc1_eflat tc in - - (* h is a proof of (h) *) - let tH, (_, s, s', eqIs, eqXs) = pf_hSS !!tc hyps h in - let eC, c, c' = tc1_destr_eagerS tc s s' in - let seqR = Mpv2.of_form env eqR in - - (* check (d) and (e) *) - pf_compat !!tc env (s_write env s) (s_write env s') seqR eqIs eqXs; - - let eqO2 = Mpv2.eq_refl (PV.fv env (fst eC.es_mr) (es_po eC).inv) in - let c1 ,c2 = s_split env i c in - let c1',c2' = s_split env j c' in - - let to_form eq = Mpv2.to_form_ts_inv eq {ml=(fst eC.es_ml); mr=(fst eC.es_mr); inv=f_true} in - - let a = f_equivS (snd eC.es_ml) (snd eC.es_mr) (es_pr eC) (stmt (s.s_node@c1)) (stmt (c1'@s'.s_node)) eqR - and b = f_equivS (snd eC.es_ml) (snd eC.es_mr) eqR (stmt (s.s_node@c2)) (stmt (c2'@s'.s_node)) (es_po eC) - and c = f_equivS (snd eC.es_mr) (snd eC.es_mr) (to_form (Mpv2.eq_fv2 seqR)) - (stmt c2') (stmt c2') (to_form eqO2) in - - FApi.t_first - (t_apply_hyp h) - (FApi.xmutate1 tc `EagerSeq [tH; a; b; c]) +(* Internal variants of eager tactics *) + +let t_eager_seq_r (i, j) s (r2, r1) tc = + let env, _, _ = FApi.tc1_eflat tc and eC, c, c' = destruct_eager tc s in + + let (_, ml_ty), (_, mr_ty) = (eC.es_ml, eC.es_mr) in + let c1, c2 = s_split env i c and c1', c2' = s_split env j c' in + let eqMem1 = eq_on_form_and_stmt env r1 (stmt c1') + and eqQ1 = eq_on_sided_form env (es_po eC) in + + let a = + f_equivS ml_ty mr_ty (es_pr eC) + (stmt (s.s_node @ c1)) + (stmt (c1' @ s.s_node)) + r2 + and b = + f_equivS ml_ty mr_ty r1 + (stmt (s.s_node @ c2)) + (stmt (c2' @ s.s_node)) + (es_po eC) + and c = f_equivS mr_ty mr_ty eqMem1 (stmt c1') (stmt c1') r1 + and d = f_equivS ml_ty ml_ty r2 (stmt c2) (stmt c2) eqQ1 in + FApi.xmutate1 tc `EagerSeq [ a; b; c; d ] (* -------------------------------------------------------------------- *) let t_eager_if_r tc = - let es = tc1_as_equivS tc in - let ml, mr = fst es.es_ml, fst es.es_mr in - - let (e , c1 , c2 ), s = pf_last_if !!tc es.es_sl in - let (e', c1', c2'), s' = pf_first_if !!tc es.es_sr in + let es, s, c, c' = destruct_on_op `If tc in + let e, c1, c2 = destr_if c and e', c1', c2' = destr_if c' in - let fel = ss_inv_generalize_right (ss_inv_of_expr ml e) mr in - let fer = ss_inv_generalize_left (ss_inv_of_expr mr e') ml in + let { ml; mr; inv = pr_inv } = es_pr es in + let { es_ml = _, ml_ty; es_mr = _, mr_ty } = es in + let fe = (ss_inv_of_expr ml e).inv and fe' = (ss_inv_of_expr mr e').inv in let aT = - EcSubst.f_forall_mems_ts_inv es.es_ml es.es_mr - (map_ts_inv2 f_imp (es_pr es) (map_ts_inv2 f_eq fel fer)) in + f_forall + [ (ml, GTmem ml_ty); (mr, GTmem mr_ty) ] + (f_imp pr_inv (f_eq fe fe')) + in let bT = - let b = EcIdent.create "b1" in - let fe = ss_inv_generalize_right (ss_inv_of_expr ml e) mr in - let eqb = map_ts_inv2 f_eq fe {ml;mr;inv=f_local b tbool} in - - EcSubst.f_forall_mems_ss_inv es.es_mr - (map_ss_inv1 - (f_forall [(b, GTty tbool)]) - (ts_inv_lower_left2 (fun pr po -> f_hoareS (snd es.es_ml) pr s po) (map_ts_inv2 f_and (es_pr es) eqb) eqb)) in + let b = EcIdent.create "b" in + let eqb = f_eq fe (f_local b tbool) in + let pre = { m = ml; inv = f_and pr_inv eqb } in + let post = { m = ml; inv = eqb } in + f_forall [ (mr, GTmem mr_ty); (b, GTty tbool) ] (f_hoareS ml_ty pre s post) + in let cT = - let pre = map_ts_inv2 f_and (es_pr es) (map_ts_inv2 f_eq fel {ml;mr;inv=f_true}) in - let st = stmt (s.s_node @ c1.s_node) in - let st' = stmt (c1'.s_node @ s'.s_node) in - f_equivS (snd es.es_ml) (snd es.es_mr) pre st st' (es_po es) in + let pre = { ml; mr; inv = f_and pr_inv (f_eq fe f_true) } in + let st = stmt (s.s_node @ c1.s_node) in + let st' = stmt (c1'.s_node @ s.s_node) in + f_equivS ml_ty mr_ty pre st st' (es_po es) + in let dT = - let pre = map_ts_inv2 f_and (es_pr es) (map_ts_inv2 f_eq fel {ml;mr;inv=f_false}) in - let st = stmt (s.s_node @ c2.s_node) in - let st' = stmt (c2'.s_node @ s'.s_node) in - f_equivS (snd es.es_ml) (snd es.es_mr) pre st st' (es_po es) in + let pre = { ml; mr; inv = f_and pr_inv (f_eq fe f_false) } in + let st = stmt (s.s_node @ c2.s_node) in + let st' = stmt (c2'.s_node @ s.s_node) in + f_equivS ml_ty mr_ty pre st st' (es_po es) + in - FApi.xmutate1 tc `EagerIf [aT; bT; cT; dT] + FApi.xmutate1 tc `EagerIf [ aT; bT; cT; dT ] (* -------------------------------------------------------------------- *) -let t_eager_while_r h tc = - let env, hyps, _ = FApi.tc1_eflat tc in +let t_eager_while_r i tc = + let env, _, _ = FApi.tc1_eflat tc in - let tH, (_, s, s', eqIs, eqXs) = pf_hSS !!tc hyps h in - let eC, wc, wc' = tc1_destr_eagerS tc s s' in - let ml, mr = fst eC.es_ml, fst eC.es_mr in + let es, s, w, w' = destruct_on_op `While tc in + let e, c = destr_while w and _e, c' = destr_while w' in - let (e , c ), n = pf_first_while !!tc wc in - let (e', c'), n' = pf_first_while !!tc wc' in - if not (List.is_empty n.s_node && List.is_empty n'.s_node) then - tc_error !!tc "no statements should followed the while loops"; + let { ml; mr; inv = pr_inv } = es_pr es in + let { es_ml = _, ml_ty; es_mr = _, mr_ty } = es in - let to_form eq = Mpv2.to_form_ts_inv eq {ml=(fst eC.es_ml);mr=(fst eC.es_mr);inv=f_true} in - - let eqI = (es_pr eC) in - let seqI = - try - Mpv2.of_form env eqI - with Not_found -> - tc_error_lazy !!tc (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt "recognize equalities in %a@." (EcPrinting.pp_form ppe) eqI.inv) + let sub_to_left_mem = + let open EcSubst in + subst_expr (add_memory empty mr ml) in - let eqI2 = to_form (Mpv2.eq_fv2 seqI) in - let e1 = ss_inv_generalize_right (ss_inv_of_expr ml e) mr in - let e2 = ss_inv_generalize_left (ss_inv_of_expr mr e') ml in - let post = Mpv2.to_form_ts_inv (Mpv2.union seqI eqXs) (map_ts_inv1 f_not e1) in - - (* check (e) and (f) *) - pf_compat !!tc env (s_write env s) (s_write env s') seqI eqIs eqXs; - let aT = EcSubst.f_forall_mems_ts_inv eC.es_ml eC.es_mr - (map_ts_inv2 f_imp eqI (map_ts_inv2 f_eq e1 e2)) + if (not (e_equal e (sub_to_left_mem _e))) then + tc_error !!tc "eager: both while guards must be syntactically equal"; + + let eqMem1 = eq_on_form_and_stmt env i c' and eqI = eq_on_sided_form env i in - and bT = f_equivS (snd eC.es_ml) (snd eC.es_mr) (map_ts_inv2 f_and_simpl eqI e1) (stmt (s.s_node@c.s_node)) - (stmt (c'.s_node@s'.s_node)) eqI + let el = ss_inv_of_expr ml e and er = ss_inv_of_expr mr e in - and cT = f_equivS (snd eC.es_mr) (snd eC.es_mr) eqI2 c' c' eqI2 + let aT = + let and_ = f_and_simpl (f_eq el.inv er.inv) eqI.inv in + f_forall [ (ml, GTmem ml_ty); (mr, GTmem mr_ty) ] (f_imp i.inv and_) + and bT = + let pre = { ml; mr; inv = f_and i.inv el.inv } in + f_equivS ml_ty mr_ty pre + (stmt (s.s_node @ c.s_node)) + (stmt (c'.s_node @ s.s_node)) + i + and cT = + let b = EcIdent.create "b" in + let eqb = f_eq el.inv (f_local b tbool) in + let pre = { m = ml; inv = f_and pr_inv eqb } in + let post = { m = ml; inv = eqb } in + f_forall [ (mr, GTmem mr_ty); (b, GTty tbool) ] (f_hoareS ml_ty pre s post) + and dT = f_equivS ml_ty mr_ty eqMem1 c' c' i + and eT = f_equivS ml_ty mr_ty i c c i + and fT = + f_equivS ml_ty mr_ty { ml; mr; inv = f_and i.inv (f_not el.inv) } s s i in - let tsolve tc = - FApi.t_first - (t_apply_hyp h) - (FApi.xmutate1 tc `EagerWhile [tH; aT; bT; cT]) - in - - FApi.t_seqsub - (EcPhlConseq.t_equivS_conseq eqI post) - [t_trivial; t_trivial; tsolve] - tc + FApi.xmutate1 tc `EagerWhile [ aT; bT; cT; dT; eT; fT ] (* -------------------------------------------------------------------- *) let t_eager_fun_def_r tc = let env = FApi.tc1_env tc in - let eg = tc1_as_eagerF tc in - let ml, mr = eg.eg_ml, eg.eg_mr in + let eg = tc1_as_eagerF tc in - let fl, fr = - (NormMp.norm_xfun env eg.eg_fl, - NormMp.norm_xfun env eg.eg_fr) - in + let fl, fr = (NormMp.norm_xfun env eg.eg_fl, NormMp.norm_xfun env eg.eg_fr) in EcPhlFun.check_concrete !!tc env fl; EcPhlFun.check_concrete !!tc env fr; - let (memenvl, (fsigl,fdefl), - memenvr, (fsigr,fdefr), env) = Fun.equivS ml mr fl fr env in + let memenvl, (fsigl, fdefl), memenvr, (fsigr, fdefr), env = + Fun.equivS eg.eg_ml eg.eg_mr fl fr env + in let extend mem fdef = match fdef.f_ret with - | None -> {m=fst mem;inv=f_tt}, mem, fdef.f_body + | None -> (f_tt, mem, fdef.f_body) | Some e -> - let v = { ov_name = Some "result"; ov_type = e.e_ty } in - let mem, s = EcMemory.bind_fresh v mem in - (* oget cannot fail — Some in, Some out *) - let x = EcTypes.pv_loc (oget s.ov_name) in - f_pvar x e.e_ty (fst mem), mem, - s_seq fdef.f_body (stmt [i_asgn(LvVar(x,e.e_ty), e)]) + let v = { ov_name = Some "result"; ov_type = e.e_ty } in + let mem, s = EcMemory.bind_fresh v mem in + (* oget cannot fail — Some in, Some out *) + let x = EcTypes.pv_loc (oget s.ov_name) in + ( (f_pvar x e.e_ty (fst mem)).inv, + mem, + s_seq fdef.f_body (stmt [ i_asgn (LvVar (x, e.e_ty), e) ]) ) in let el, meml, sfl = extend memenvl fdefl in let er, memr, sfr = extend memenvr fdefr in - let ml, mr = EcMemory.memory meml, EcMemory.memory memr in + let ml, mr = (EcMemory.memory meml, EcMemory.memory memr) in let s = PVM.empty in - let s = PVM.add env pv_res ml el.inv s in - let s = PVM.add env pv_res mr er.inv s in + let s = PVM.add env pv_res ml el s in + let s = PVM.add env pv_res mr er s in let post = map_ts_inv1 (PVM.subst env s) (eg_po eg) in let s = PVM.empty in let s = EcPhlFun.subst_pre env fsigl ml s in let s = EcPhlFun.subst_pre env fsigr mr s in let pre = map_ts_inv1 (PVM.subst env s) (eg_pr eg) in - let cond = f_equivS (snd meml) (snd memr) pre (s_seq eg.eg_sl sfl) (s_seq sfr eg.eg_sr) post in + let cond = + f_equivS (snd meml) (snd memr) pre (s_seq eg.eg_sl sfl) (s_seq sfr eg.eg_sr) + post + in - FApi.xmutate1 tc `EagerFunDef [cond] + FApi.xmutate1 tc `EagerFunDef [ cond ] (* -------------------------------------------------------------------- *) -let t_eager_fun_abs_r eqI h tc = - let env, hyps, _ = FApi.tc1_eflat tc in +let t_eager_fun_abs_r i tc = + let env, _, _ = FApi.tc1_eflat tc and eg = tc1_as_eagerF tc in - let tH, (_, s, s', eqIs, eqXs) = pf_hSS !!tc hyps h in - let eg = tc1_as_eagerF tc in + if not (s_equal eg.eg_sl eg.eg_sr) then + tc_error !!tc "eager: both swapping statements must be identical"; + + if not (ensure_eq_shape tc i.ml i.mr i.inv) then + tc_error !!tc + "eager: the invariant must be a conjunction of same-name variable \ + equalities"; - if not (s_equal s eg.eg_sl && s_equal s' eg.eg_sr) then - tc_error !!tc "cannot reconize the swapping statement"; + let s, fl, fr = (eg.eg_sl, eg.eg_fl, eg.eg_fr) in - let fl, fr = eg.eg_fl, eg.eg_fr in - let pre, post, sg = - EcPhlFun.FunAbsLow.equivF_abs_spec !!tc env fl fr eqI in + let pre, post, sg_e = EcPhlFun.FunAbsLow.equivF_abs_spec !!tc env fl fr i in + let _, _, sg_f = EcPhlFun.FunAbsLow.equivF_abs_spec !!tc env fr fr i in + let _, _, sg_g = EcPhlFun.FunAbsLow.equivF_abs_spec !!tc env fl fl i in - let do1 og sg = + let do_e og = let ef = destr_equivF og in - let torefl f = - Mpv2.to_form_ts_inv - (Mpv2.eq_refl (PV.fv env f.mr f.inv)) - {ml=f.ml;mr=f.mr;inv=f_true} - in - f_eagerF (ef_pr ef) s ef.ef_fl ef.ef_fr s' (ef_po ef) - :: f_equivF (torefl (ef_pr ef)) ef.ef_fr ef.ef_fr (torefl (ef_po ef)) - :: sg + f_eagerF (ef_pr ef) s ef.ef_fl ef.ef_fr s (ef_po ef) in - let sg = List.fold_right do1 sg [] in - let seqI = Mpv2.of_form env eqI in - - (* check (e) and (f)*) - pf_compat !!tc env (s_write env s) (s_write env s') seqI eqIs eqXs; + let do_f og = + let ef = destr_equivF og in - (* TODO : check that S S' do not modify glob A *) - let tactic tc = - FApi.t_first (t_apply_hyp h) - (FApi.xmutate1 tc `EagerFunAbs (tH::sg)) + let eqMem = eq_on_fun env i.ml i.mr ef.ef_fr in + f_equivF (map_ts_inv2 f_and eqMem (ef_pr ef)) ef.ef_fl ef.ef_fl (ef_po ef) in + let sg_e = List.map do_e sg_e and sg_f = List.map do_f sg_f in + + (* Reorder per-oracle goals in order to align with the description *) + let sg = + List.combine sg_e (List.combine sg_f sg_g) + |> List.concat_map (fun (x, (y, z)) -> [ x; y; z ]) + and sg_d = f_equivS EcMemory.abstract_mt EcMemory.abstract_mt i s s i in + + let tactic tc = FApi.xmutate1 tc `EagerFunAbs (sg_d :: sg) in + FApi.t_last tactic (EcPhlConseq.t_eagerF_conseq pre post tc) (* -------------------------------------------------------------------- *) @@ -303,338 +362,111 @@ let t_eager_call_r fpre fpost tc = let fpre = EcSubst.ts_inv_rebind fpre (fst es.es_ml) (fst es.es_mr) in let fpost = EcSubst.ts_inv_rebind fpost (fst es.es_ml) (fst es.es_mr) in - let (lvl, fl, argsl), sl = pf_last_call !!tc es.es_sl in + let (lvl, fl, argsl), sl = pf_last_call !!tc es.es_sl in let (lvr, fr, argsr), sr = pf_first_call !!tc es.es_sr in let swl = s_write env sl in let swr = s_write env sr in let check_a e = - let er = e_read env e in + let er = e_read env e in let diff = PV.interdep env swl er in if not (PV.is_empty diff) then tc_error_lazy !!tc (fun fmt -> - Format.fprintf fmt - "eager call: the statement write %a" - (PV.pp env) diff) + Format.fprintf fmt "eager: swapping statement may not write to `%a`" + (PV.pp env) diff) in List.iter check_a argsl; let modil = PV.union (f_write env fl) swl in let modir = PV.union (f_write env fr) swr in - let post = EcPhlCall.wp2_call env fpre fpost (lvl, fl, argsl) modil - - (lvr,fr,argsr) modir (es_po es) hyps in - let f_concl = f_eagerF fpre sl fl fr sr fpost in - let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) (stmt []) (stmt []) post in - - FApi.xmutate1 tc `EagerCall [f_concl; concl] - -(* -------------------------------------------------------------------- *) -let check_only_global pf env s = - let sw = s_write env s in - let sr = s_read env s in - - let check_glob v _ = - if is_loc v then - tc_error_lazy pf (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt - "swapping statement should use only global variables: %a" - (EcPrinting.pp_pv ppe) v) + let post = + EcPhlCall.wp2_call env fpre fpost (lvl, fl, argsl) modil (lvr, fr, argsr) + modir (es_po es) hyps in - - let check_mp _ = () in - - PV.iter check_glob check_mp sw; - PV.iter check_glob check_mp sr - -(* -------------------------------------------------------------------- *) -(* This part of the code is for automatic application of eager rules *) -(* -------------------------------------------------------------------- *) -let eager pf env s s' inv eqIs eqXs c c' eqO = - let modi = s_write env s in - let modi' = s_write env s' in - let readi = s_read env s in - - let rev st = List.rev st.s_node in - - let check_args args = - let read = List.fold_left (e_read_r env) PV.empty args in - if not (PV.indep env modi read) then raise EqObsInError in - - let check_swap_s i = - let m = is_write env [i] in - let r = is_read env [i] in - let t = - PV.indep env m modi - && PV.indep env m readi - && PV.indep env modi r - in - if not t then raise EqObsInError - in - - let remove lvl lvr eqs = - let aux eqs (pvl, tyl) (pvr, tyr) = - if (ER.EqTest.for_type env tyl tyr) - then Mpv2.remove env pvl pvr eqs - else raise EqObsInError in - - match lvl, lvr with - | LvVar xl, LvVar xr -> aux eqs xl xr - - | LvTuple ll, LvTuple lr - when List.length ll = List.length lr - -> - List.fold_left2 aux eqs ll lr - - | _, _ -> raise EqObsInError in - - let oremove lvl lvr eqs = - match lvl, lvr with - | None , None -> eqs - | Some lvl, Some lvr -> remove lvl lvr eqs - | _ , _ -> raise EqObsInError in - - let rec s_eager fhyps rsl rsr eqo = - match rsl, rsr with - | [], _ -> [], rsr, fhyps, eqo - | _ , [] -> rsl, [], fhyps, eqo - - | il::rsl', ir::rsr' -> - match (try Some (i_eager fhyps il ir eqo) with _ -> None) with - | None -> rsl, rsr, fhyps, eqo - | Some (fhyps, eqi) -> - (* we ensure that the seq rule can be apply *) - let eqi2 = i_eqobs_in_refl env ir (Mpv2.fv2 eqo) in - if not (PV.subset eqi2 (Mpv2.fv2 eqi)) then raise EqObsInError; - pf_compat pf env modi modi' eqi eqIs eqXs; - s_eager fhyps rsl' rsr' eqi - - and i_eager fhyps il ir eqo = - match il.i_node, ir.i_node with - | Sasgn (lvl, el), Sasgn (lvr, er) - | Srnd (lvl, el), Srnd (lvr, er) -> - check_swap_s il; - let eqnm = Mpv2.split_nmod env modi modi' eqo in - let eqm = Mpv2.split_mod env modi modi' eqo in - if not (Mpv2.subset eqm eqXs) then raise EqObsInError; - let eqi = Mpv2.union eqIs eqnm in - (fhyps, Mpv2.add_eqs env el er (remove lvl lvr eqi) ) - - | Scall (lvl, fl, argsl), Scall (lvr, fr, argsr) - when List.length argsl = List.length argsr - -> - check_args argsl; - let eqo = oremove lvl lvr eqo in - let modl = PV.union modi (f_write env fl) in - let modr = PV.union modi' (f_write env fr) in - let eqnm = Mpv2.split_nmod env modl modr eqo in - let outf = Mpv2.split_mod env modl modr eqo in - Mpv2.check_glob outf; - let fhyps, inf = f_eager fhyps fl fr outf in - let eqi = - List.fold_left2 - (fun eqs e1 e2 -> Mpv2.add_eqs env e1 e2 eqs) - (Mpv2.union eqnm inf) argsl argsr - in - (fhyps, eqi) - - | Sif (el, stl, sfl), Sif (er, str, sfr) -> - check_args [el]; - let r1,r2,fhyps1, eqs1 = s_eager fhyps (rev stl) (rev str) eqo in - if r1 <> [] || r2 <> [] then raise EqObsInError; - let r1,r2, fhyps2, eqs2 = s_eager fhyps1 (rev sfl) (rev sfr) eqo in - if r1 <> [] || r2 <> [] then raise EqObsInError; - let eqi = Mpv2.union eqs1 eqs2 in - let eqe = Mpv2.add_eqs env el er eqi in - (fhyps2, eqe) - - | Swhile (el, sl), Swhile (er, sr2) -> - check_args [el]; (* ensure condition (d) *) - let sl, sr = rev sl, rev sr2 in - let rec aux eqo = - let r1,r2,fhyps, eqi = s_eager fhyps sl sr eqo in - if r1 <> [] || r2 <> [] then raise EqObsInError; - if Mpv2.subset eqi eqo then fhyps, eqo - else aux (Mpv2.union eqi eqo) - in - let fhyps, eqi = aux (Mpv2.union eqIs (Mpv2.add_eqs env el er eqo)) in - (* by construction condition (a), (b) and (c) are satisfied *) - pf_compat pf env modi modi' eqi eqIs eqXs; (* ensure (e) and (f) *) - (* (h) is assumed *) - (fhyps, eqi) - - | Sassert el, Sassert er -> - check_args [el]; - let eqnm = Mpv2.split_nmod env modi modi' eqo in - let eqm = Mpv2.split_mod env modi modi' eqo in - if not (Mpv2.subset eqm eqXs) then raise EqObsInError; - let eqi = Mpv2.union eqIs eqnm in - (fhyps, Mpv2.add_eqs env el er eqi) - - | Sabstract _, Sabstract _ -> assert false (* FIXME *) - - | _, _ -> raise EqObsInError - - and f_eager fhyps fl fr out = - let fl = NormMp.norm_xfun env fl in - let fr = NormMp.norm_xfun env fr in - - let rec aux fhyps = - match fhyps with - | [] -> [fl,fr,out] - | (fl', fr', out') :: fhyps -> - if EcPath.x_equal fl fl' && EcPath.x_equal fr fr' - then (fl ,fr , Mpv2.union out out') :: fhyps - else (fl',fr', out') :: (aux fhyps) - in - aux fhyps, inv - in - - s_eager [] (rev c) (rev c') eqO - -(* -------------------------------------------------------------------- *) -let t_eager_r h inv tc = - let env, hyps, _ = FApi.tc1_eflat tc in - let _, (_, s, s', eqIs, eqXs) = pf_hSS !!tc hyps h in - - check_only_global !!tc env s; - check_only_global !!tc env s'; - - let eC, c, c' = tc1_destr_eagerS tc s s' in - let ml, mr = fst eC.es_ml, fst eC.es_mr in - let eqinv = Mpv2.of_form env inv in - let eqO = Mpv2.of_form env (es_po eC) in - let c1, c1', fhyps, eqi = eager !!tc env s s' eqinv eqIs eqXs c c' eqO in - - if c1 <> [] || c1' <> [] then - tc_error !!tc "not able to apply eager"; (* FIXME *) - - let dof (fl,fr,eqo) = - let defl = Fun.by_xpath fl env in - let defr = Fun.by_xpath fr env in - let sigl, sigr = defl.f_sig, defr.f_sig in - let eq_res = ts_inv_eqres sigl.fs_ret ml sigr.fs_ret mr in - let post = Mpv2.to_form_ts_inv eqo eq_res in - let eq_params = - ts_inv_eqparams - sigl.fs_arg sigl.fs_anames ml - sigr.fs_arg sigr.fs_anames mr in - let pre = map_ts_inv2 f_and_simpl eq_params inv in - f_eagerF pre s fl fr s' post - in - + let f_concl = f_eagerF fpre sl fl fr sr fpost in let concl = - f_equivS (snd eC.es_ml) (snd eC.es_mr) (es_pr eC) (stmt []) (stmt []) - (Mpv2.to_form_ts_inv eqi {ml;mr;inv=f_true}) in - - let concls = List.map dof fhyps in + f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) (stmt []) (stmt []) post + in - FApi.xmutate1 tc `EagerAuto (concl::concls) + FApi.xmutate1 tc `EagerCall [ f_concl; concl ] (* -------------------------------------------------------------------- *) -let t_eager_seq = FApi.t_low4 "eager-seq" t_eager_seq_r -let t_eager_if = FApi.t_low0 "eager-if" t_eager_if_r -let t_eager_while = FApi.t_low1 "eager-while" t_eager_while_r +let t_eager_seq = FApi.t_low3 "eager-seq" t_eager_seq_r +let t_eager_if = FApi.t_low0 "eager-if" t_eager_if_r +let t_eager_while = FApi.t_low1 "eager-while" t_eager_while_r let t_eager_fun_def = FApi.t_low0 "eager-fun-def" t_eager_fun_def_r -let t_eager_fun_abs = FApi.t_low2 "eager-fun-abs" t_eager_fun_abs_r -let t_eager_call = FApi.t_low2 "eager-call" t_eager_call_r -let t_eager = FApi.t_low2 "eager" t_eager_r - -(* -------------------------------------------------------------------- *) -let process_info info tc = - let hyps = FApi.tc1_hyps tc in - - match info with - | EcParsetree.LE_done h -> - (t_id tc, fst (LDecl.hyp_by_name (unloc h) hyps)) - - | EcParsetree.LE_todo (h, s1, s2, eqIs, eqXs) -> - let (ml, mlt) as mle, ((mr, mrt) as mre) = - match (FApi.tc1_goal tc).f_node with - | FeagerF {eg_ml=ml;eg_mr=mr} -> - EcMemory.abstract ml, EcMemory.abstract mr - | _ -> - let es = tc1_as_equivS tc in - es.es_ml, es.es_mr in - let hyps = LDecl.push_active_ts mle mre hyps in - let process_formula = TTC.pf_process_form !!tc hyps tbool in - let eqIs = {ml;mr;inv=process_formula eqIs} in - let eqXs = {ml;mr;inv=process_formula eqXs} in - let s1 = TTC.tc1_process_prhl_stmt tc `Left s1 in - let s2 = TTC.tc1_process_prhl_stmt tc `Right s2 in - let f = f_equivS mlt mrt eqIs s1 s2 eqXs in - let h = LDecl.fresh_id hyps (unloc h) in - (FApi.t_last (t_intros_i [h]) (t_cut f tc), h) - -(* -------------------------------------------------------------------- *) -let process_seq info (i, j) eqR tc = - let eqR = TTC.tc1_process_prhl_form tc tbool eqR in - let gs, h = process_info info tc in - let i = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left , i) in - let j = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Right, j) in - FApi.t_last (t_eager_seq i j eqR h) gs - -(* -------------------------------------------------------------------- *) -let process_if tc = - t_eager_if tc +let t_eager_fun_abs = FApi.t_low1 "eager-fun-abs" t_eager_fun_abs_r +let t_eager_call = FApi.t_low2 "eager-call" t_eager_call_r (* -------------------------------------------------------------------- *) -let process_while info tc = - let gs, h = process_info info tc in - FApi.t_last (t_eager_while h) gs +let process_seq (i, j) s factor tc = + let open BatTuple.Tuple2 in + let indices = + mapn (tc1_process_codepos1 tc) ((Some `Left, i), (Some `Right, j)) + and factor = + factor + |> ( function Single p -> (p, p) | Double pp -> pp ) + |> mapn (TTC.tc1_process_prhl_form tc tbool) + and s = TTC.tc1_process_prhl_stmt tc `Left s in + + t_eager_seq indices s factor tc + +let process_if = t_eager_if + +let process_while inv tc = + (* This is performed here only to recover [e{1}] and setup + the consequence rule accordingly. *) + let es, _, w, _ = destruct_on_op `While tc in + let e, _ = destr_while w in + let e1 = ss_inv_of_expr (fst es.es_ml) e in + + let inv = TTC.tc1_process_prhl_form tc tbool inv in + (EcPhlConseq.t_equivS_conseq inv + { inv with inv = f_and inv.inv (f_not e1.inv) } + @+ [ t_trivial; t_trivial; t_eager_while inv ]) + tc -(* -------------------------------------------------------------------- *) -let process_fun_def tc = - t_eager_fun_def tc +let process_fun_def tc = t_eager_fun_def tc -(* -------------------------------------------------------------------- *) -let process_fun_abs info eqI tc = - let eg = EcLowPhlGoal.tc1_as_eagerF tc in - let ml, mr = eg.eg_ml, eg.eg_mr in - let hyps = FApi.tc1_hyps tc in - let env = LDecl.inv_memenv ml mr hyps in - let eqI = TTC.pf_process_form !!tc env tbool eqI in - let gs, h = process_info info tc in - FApi.t_last (t_eager_fun_abs {inv=eqI;ml;mr} h) gs +let process_fun_abs inv tc = + let hyps = FApi.tc1_hyps tc in + let { eg_ml = ml; eg_mr = mr } = tc1_as_eagerF tc in + let env = LDecl.inv_memenv ml mr hyps in + let inv = TTC.pf_process_formula !!tc env inv in + t_eager_fun_abs { ml; mr; inv } tc -(* -------------------------------------------------------------------- *) let process_call info tc = - let process_cut info = - match info with - | EcParsetree.CI_spec (fpre, fpost) -> - let env, hyps, _ = FApi.tc1_eflat tc in - let es = tc1_as_equivS tc in + let process_cut' fpre fpost = + let env, hyps, _ = FApi.tc1_eflat tc in + let es = tc1_as_equivS tc in - let (_,fl,_), sl = tc1_last_call tc es.es_sl in - let (_,fr,_), sr = tc1_first_call tc es.es_sr in + let (_, fl, _), sl = tc1_last_call tc es.es_sl in + let (_, fr, _), sr = tc1_first_call tc es.es_sr in - check_only_global !!tc env sl; - check_only_global !!tc env sr; + check_only_global !!tc env sl; + check_only_global !!tc env sr; - let (ml, mr) = fst es.es_ml, fst es.es_mr in - let penv, qenv = LDecl.equivF ml mr fl fr hyps in - let fpre = TTC.pf_process_form !!tc penv tbool fpre in - let fpost = TTC.pf_process_form !!tc qenv tbool fpost in - f_eagerF {ml;mr;inv=fpre} sl fl fr sr {ml;mr;inv=fpost} - - | _ -> tc_error !!tc "invalid arguments" + let ml, mr = (fst es.es_ml, fst es.es_mr) in + let penv, qenv = LDecl.equivF ml mr fl fr hyps in + let fpre = TTC.pf_process_formula !!tc penv fpre in + let fpost = TTC.pf_process_formula !!tc qenv fpost in + f_eagerF { ml; mr; inv = fpre } sl fl fr sr { ml; mr; inv = fpost } + in + let process_cut = function + | EcParsetree.CI_spec (fpre, fpost) -> process_cut' fpre fpost + | CI_inv inv -> process_cut' inv inv + | _ -> tc_error !!tc "eager: invalid call specification" in let pt, ax = - PT.tc1_process_full_closed_pterm_cut ~prcut:process_cut tc info in + PT.tc1_process_full_closed_pterm_cut ~prcut:process_cut tc info + in let eg = pf_as_eagerF !!tc ax in FApi.t_on1seq 0 (t_eager_call (eg_pr eg) (eg_po eg)) (EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true pt) tc - -(* -------------------------------------------------------------------- *) -let process_eager info inv tc = - let inv = TTC.tc1_process_prhl_form tc tbool inv in - let gs, h = process_info info tc in - FApi.t_last (t_eager h inv) gs diff --git a/src/phl/ecPhlEager.mli b/src/phl/ecPhlEager.mli index 1958df5529..6d5c2b0580 100644 --- a/src/phl/ecPhlEager.mli +++ b/src/phl/ecPhlEager.mli @@ -1,95 +1,103 @@ (* -------------------------------------------------------------------- *) +open EcAst open EcUtils open EcParsetree open EcCoreGoal.FApi open EcMatching.Position -open EcAst -(* -------------------------------------------------------------------- *) -val t_eager_seq : codepos1 -> codepos1 -> ts_inv -> EcIdent.t -> backward -val t_eager_if : backward -val t_eager_while : EcIdent.t -> backward -val t_eager_fun_def : backward -val t_eager_fun_abs : ts_inv -> EcIdent.t -> backward -val t_eager_call : ts_inv -> ts_inv -> backward +val process_seq : pcodepos1 pair -> pstmt -> pformula doption -> backward +(** Tactic [eager seq] derives the following proof: + {v + (a) S; c₁ ~ c₁'; S : P ==> R₂ + (b) S; c₂ ~ c₂'; S : R₁ ==> Q + (c) c₁' ~ c₁' : Eq ==> R₁ + (d) c₂ ~ c₂ : R₂ ==> ={Q.1} + ----------------------------------- + S; c₁; c₂ ~ c₁'; c₂'; S : P ==> Q + v} + where [R₁] and [R₂] are provided manually (and equal if a single value was + provided), as well as [S]. The predicate [={Q.1}] means equality on all free + variables bound to the first memory in [Q]. *) + +val t_eager_seq : codepos1 pair -> stmt -> ts_inv pair -> backward +(** Internal variant of [eager seq] *) + +val process_if : backward +(** Tactic [eager if] derives the following proof: + {v + (a) forall &1 &2, P => e{1} = e'{2} + (b) forall &2 b, S : P /\ e = b ==> e = b + (c) S; c₁ ~ c₁'; S : P /\ e{1} ==> Q + (d) S; c₂ ~ c₂'; S : P /\ !e{1} ==> Q + -------------------------------------------- + S; if e then c₁ else c₂ + ~ if e' then c₁' else c₂'; S : P ==> Q + v} *) + +val t_eager_if : backward +(** Internal variant of [eager if] *) + +val process_while : pformula -> backward +(** Tactic [eager while] derives the following proof: + {v + (a) I => ={e, I.1} + (b) S; c ~ c'; S : I /\ e{1} ==> I + (c) forall b &2, S : e = b ==> e = b + (d) c' ~ c' : Eq ==> I + (e) c ~ c : I ==> I + (f) S ~ S : I /\ !e{1} ==> I + -------------------------------------------------------- + S; while e do c ~ while e do c'; S : I ==> I /\ !e{1} + v} + Where the invariant [I] is manually provided. + Please note that the guard [e] is syntactically identical in both + programs. *) + +val t_eager_while : ts_inv -> backward +(** Internal variant of [eager while] *) -(* -------------------------------------------------------------------- *) -val process_seq : eager_info -> pcodepos1 pair -> pformula -> backward -val process_if : backward -val process_while : eager_info -> backward val process_fun_def : backward -val process_fun_abs : eager_info -> pformula -> backward -val process_call : call_info gppterm -> backward -val process_eager : eager_info -> pformula -> backward +(** Tactic [eager proc] derives the following proof: + {v + (0) S and S' depend only of global (typing invariant) + (a) S; f.body; result = f.res; ~ S'; f'.body; result' = f'.res + : P ==> Q{res{1} <- result, res{2} <- result'} + ---------------------------------------------------------------- + S, f ~ f', S : P ==> Q + v} *) -(* -------------------------------------------------------------------- *) -(* [eager-seq] - * (a) c1;S ~ S;c1' : P ==> ={R} - * (b) c2;S ~ S;c2' : ={R} ==> Q - * (c) c2' ~ c2' : ={R.2} ==> ={Q.2} - * (d) ={R} => ={Is} - * (e) compat S S' R Xs - * (h) S ~ S' : ={Is} ==> ={Xs} - * -------------------------------------------------- - * c1;c2;S ~ S;c1';c2' : P ==> Q - * - * where compat S S' R Xs = - * forall modS modS', ={Xs{modS,modS'}} => ={R{modS,modS'}} - * - * [eager-if] - * (a) P => e{1} = e'{2} - * (b) S;c1 ~ S';c1' : P /\ e{1} ==> Q - * (c) S;c2 ~ S';c2' : P /\ !e{1} ==> Q - * (d) forall b &2, S : P /\ e = b ==> e = b - * -------------------------------------------------- - * S;if e then c1 else c2 - * ~ if e' then c1' else c2';S' : P ==> Q - * - * [eager-while] - * - * (a) ={I} => e{1} = e{2} - * (b) S;c ~ c';S' : ={I} /\ e{1} ==> ={I} - * (c) c' ~ c' : ={I.2} ==> ={I.2} - * (d) forall b &2, S : e = b ==> e = b - * (e) ={I} => ={Is} - * (f) compat S S' I Xs - * (h) S ~ S' : ={Is} ==> ={Xs} - * -------------------------------------------------- - * S;while e do c ~ while e' do c';S' - * : ={I} ==> ={I,Xs} /\ !e{1} - * - * [eager-fun-def] - * - * (a) S and S' depend only of global - * (this should be an invariant of the typing) - * (b) S;f.body;result = f.res; ~ S';f'.body;result' = f'.res - * : P ==> Q{res{1}<- result, res{2} <- result'} - * -------------------------------------------------- - * S, f ~ f', S' : P ==> Q - * - * [eager-fun-abs] - * - * S and S' depend only of global (hould be an invariant of the typing) - * - * (a) ={I} => e{1} = e{2} - * for each oracles o o': - * o and o' do not modify (glob A) (this is implied by (f)) - * (b) S,o ~ o',S' : ={I,params} ==> ={I,res} - * (c) o'~ o' : ={I.2, o'.params} ==> ={I.2, res} - * (e) ={I} => ={Is} - * (f) compat S S' I Xs - * (h) S ~ S' : ={Is} ==> ={Xs} - * (i) glob A not in I (checked in EcPhlFun.equivF_abs_spec) - * (j) S, S' do not modify glob A - * -------------------------------------------------- - * S, A.f{o} ~ A.f(o'), S' - * : ={I,glob A,A.f.params} ==> ={I,glob A,res} - * - * Remark : ={glob A} is not required in pre condition when A.f is an initializer - * - * [eager-call] - * S,f ~ f',S' : fpre ==> fpost - * S do not write a - * -------------------------------------------------- - * S;x = f(a) ~ x' = f'(a');S' : wp_call fpre fpost post ==> post - *) +val t_eager_fun_def : backward +(** Internal variant of [eager proc] *) + +val process_call : call_info gppterm -> backward +(** Tactic [eager call] derives the following proof: + {v + (a) S, f ~ f', S : fpre ==> fpost + (b) S does not write a + ------------------------------------------------------------------ + S; x = f(a) ~ x' = f'(a'); S : wp_call fpre fpost post ==> post + v} *) + +val t_eager_call : ts_inv -> ts_inv -> backward +(** Internal variant of [eager call] *) + +val process_fun_abs : pformula -> backward +(** Tactic [eager call] (on abstract functions) derives the following proof: + {v + (0) S depends only on globals (typing invariant) + (a) I is a conjunction of same-name variable equalities + (b) glob A not in I (checked in EcPhlFun.equivF_abs_spec) + (c) S does not modify glob A + (d) S ~ S : I ==> I + for each oracles o o': + o and o' do not modify (glob A) + (e) S, o ~ o', S : I /\ ={o'.params} ==> I /\ ={res} + (f) o' ~ o' : Eq ==> I /\ ={res} + (g) o ~ o : I /\ ={o.params} ==> I /\ ={res} + -------------------------------------------------------- + S, A.f{o} ~ A.f(o'), S + : I /\ ={glob A, A.f.params} ==> I /\ ={glob A, res} + v} *) + +val t_eager_fun_abs : ts_inv -> backward +(** Internal variant of [eager call] (on abstract functions) *) diff --git a/theories/crypto/PROM.ec b/theories/crypto/PROM.ec index c672898f6a..59fd19bc5e 100644 --- a/theories/crypto/PROM.ec +++ b/theories/crypto/PROM.ec @@ -692,8 +692,7 @@ lemma eager_D : D(RRO).distinguish, RRO.resample(); : ={glob D, FRO.m, arg} ==> ={FRO.m, glob D} /\ ={res}]. proof. -eager proc (H_: RRO.resample(); ~ RRO.resample();: ={FRO.m} ==> ={FRO.m}) - (={FRO.m}) =>//; try by sim. +eager proc (={FRO.m}) =>//; try by sim. + by apply eager_init. + by apply eager_get. + by apply eager_set. diff --git a/theories/distributions/SDist.ec b/theories/distributions/SDist.ec index ef3b2f244d..70610147a0 100644 --- a/theories/distributions/SDist.ec +++ b/theories/distributions/SDist.ec @@ -509,7 +509,7 @@ local module Gr(O : Oracle_i) = { } }. -(* TOTHINK: Can this be strenthened by dropping the requirement that +(* TOTHINK: Can this be strengthened by dropping the requirement that d1 and d2 are lossless? The current proof uses the eager tactics to swap the statement [if (Var.b) Var.x <$ Var.d;] over the call to the adversary, which only works if the distributions are lossless. *) @@ -538,12 +538,11 @@ byequiv => //. have eq_main_O1e_O1l: equiv[Game(A, O1e).main ~ Gr(O1l).main: ={arg, glob A} /\ arg{1} = d' ==> ={res}]. + proc; inline *. - seq 6 6 : (={glob Var, glob A}); 1: by auto. - eager (H : if (Var.b) Var.x <$ Var.d; ~ if (Var.b) Var.x <$ Var.d; - : ={glob Var} ==> ={glob Var} ) - : (={glob A,glob Var} ) => //; 1: by sim. -eager proc H (={glob Var}) => //; 2: by sim. - proc*; inline *; rcondf{2} 6; [ by auto | by sp; if; auto]. + seq 6 6 : (={glob Var, glob A}); 1: by auto. + eager call (: ={glob Var, glob A} ==> ={glob Var, glob A, res}) => //. + eager proc (={glob Var}) => //; try sim. + eager proc. + by inline*; rcondf{2} 6; [ by auto | by sp; if; auto]. proc. transitivity* {1} {r <@ Game(A, O1e).main(d);}. + by inline *; rcondt{2} 8; auto; call(: ={Var.x}); 1: sim; auto. From 72b1903c010bec27eba250df6036b7e0391f4714 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 14 Jan 2026 22:19:49 +0100 Subject: [PATCH 20/26] Refman skeleton. Uses Sphinx + an extension that generates proofs viewable and navigable directly in the browser. --- .github/workflows/docs.yml | 115 ++++ doc/.gitignore | 2 + doc/Makefile | 45 ++ doc/_static/.keep | 0 doc/conf.py | 39 ++ doc/extensions/ecproofs/ecproofs.py | 142 ++++ doc/extensions/ecproofs/proofnav/.gitignore | 2 + doc/extensions/ecproofs/proofnav/easycrypt.ts | 114 ++++ doc/extensions/ecproofs/proofnav/esbuild.mjs | 22 + doc/extensions/ecproofs/proofnav/index.ts | 46 ++ .../ecproofs/proofnav/package-lock.json | 614 ++++++++++++++++++ doc/extensions/ecproofs/proofnav/package.json | 20 + doc/extensions/ecproofs/proofnav/proofnav.css | 233 +++++++ doc/extensions/ecproofs/proofnav/widget.ts | 461 +++++++++++++ doc/extensions/ecpygment/ecpygment.py | 15 + doc/extensions/ecpygment/lexers/easycrypt.py | 78 +++ doc/index.rst | 7 + doc/package-lock.json | 6 + doc/requirements.txt | 3 + doc/tactics.rst | 8 + doc/tactics/skip.rst | 123 ++++ 21 files changed, 2095 insertions(+) create mode 100644 .github/workflows/docs.yml create mode 100644 doc/.gitignore create mode 100644 doc/Makefile create mode 100644 doc/_static/.keep create mode 100644 doc/conf.py create mode 100644 doc/extensions/ecproofs/ecproofs.py create mode 100644 doc/extensions/ecproofs/proofnav/.gitignore create mode 100644 doc/extensions/ecproofs/proofnav/easycrypt.ts create mode 100644 doc/extensions/ecproofs/proofnav/esbuild.mjs create mode 100644 doc/extensions/ecproofs/proofnav/index.ts create mode 100644 doc/extensions/ecproofs/proofnav/package-lock.json create mode 100644 doc/extensions/ecproofs/proofnav/package.json create mode 100644 doc/extensions/ecproofs/proofnav/proofnav.css create mode 100644 doc/extensions/ecproofs/proofnav/widget.ts create mode 100644 doc/extensions/ecpygment/ecpygment.py create mode 100644 doc/extensions/ecpygment/lexers/easycrypt.py create mode 100644 doc/index.rst create mode 100644 doc/package-lock.json create mode 100644 doc/requirements.txt create mode 100644 doc/tactics.rst create mode 100644 doc/tactics/skip.rst diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml new file mode 100644 index 0000000000..87658237a9 --- /dev/null +++ b/.github/workflows/docs.yml @@ -0,0 +1,115 @@ +name: Build documentation + +on: + push: + branches: + - "main" + pull_request: + +permissions: + contents: read + pages: write + id-token: write + + +jobs: + build: + runs-on: ubuntu-latest + concurrency: + group: "refman" + cancel-in-progress: true + + steps: + - name: Checkout + uses: actions/checkout@v6 + + - name: Set up Node.js + uses: actions/setup-node@v6 + with: + node-version: "20" + + - name: Install npm dependencies + run: | + make -C doc ecproof-deps + + - name: Set up Python + uses: actions/setup-python@v6 + with: + python-version: "3.13" + + - name: Install Python dependencies + run: | + make -C doc sphinx-deps + + - name: Set-up OCaml + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: 5.4 + opam-disable-sandboxing: true + dune-cache: true + + - name: Install EasyCrypt dependencies + run: | + opam pin add -n easycrypt . + opam install --deps-only --depext-only --confirm-level=unsafe-yes easycrypt + opam install --deps-only easycrypt + + - name: Compile & Install EasyCrypt + run: | + opam exec -- make PROFILE=release install + + - name: Build Sphinx HTML + run: | + opam exec -- make -C doc ecproof-bundle sphinx-html + + - name: Upload documentation (artifact) + uses: actions/upload-artifact@v6 + with: + name: refman + path: doc/_build/html + + deploy: + runs-on: ubuntu-latest + needs: build + if: github.event_name == 'push' && github.ref == 'refs/heads/main' + concurrency: + group: "refman" + cancel-in-progress: false + + steps: + - name: Download documentation (artifact) + uses: actions/download-artifact@v7 + with: + name: refman + path: _refman + + - name: Deploy documentation + env: + PAGES_TOKEN: ${{ secrets.PAGES_REPO_TOKEN }} + PAGES_REPO: EasyCrypt/refman + TARGET_DIR: refman + BUILD_DIR: _refman + + run: | + set -euo pipefail + + git config --global user.name "github-actions[bot]" + git config --global user.email "github-actions[bot]@users.noreply.github.com" + + git clone --depth 1 https://x-access-token:${PAGES_TOKEN}@github.com/${PAGES_REPO}.git pages-repo + + rm -rf "pages-repo/${TARGET_DIR}" + mkdir -p "pages-repo/${TARGET_DIR}" + touch "pages-repo/${TARGET_DIR}"/.keep + + cp -a "${BUILD_DIR}/." "pages-repo/${TARGET_DIR}/" + + git -C pages-repo add -A + + if git -C pages-repo diff --cached --quiet; then + echo "No changes to deploy." + exit 0 + fi + + git -C pages-repo commit -m "Update docs: ${GITHUB_REPOSITORY}@${GITHUB_SHA}" + git -C pages-repo push origin main diff --git a/doc/.gitignore b/doc/.gitignore new file mode 100644 index 0000000000..88503a8c6a --- /dev/null +++ b/doc/.gitignore @@ -0,0 +1,2 @@ +__pycache__/ +_build/ diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 0000000000..bb8b8c368c --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,45 @@ +# -*- Makefile -*- + +# ------------------------------------------------------------------------ +SPHINXBUILD ?= sphinx-build +SPHINXOPTS ?= +SOURCEDIR = . +BUILDDIR = _build +NPM ?= npm + +# ------------------------------------------------------------------------ +.PHONY: + +default: + @echo "make [ecproof-deps | ecproof-bundle| sphinx-html]" >&2 + +# ------------------------------------------------------------------------ +.PHONY: sphinx-help sphinx-deps __force__ + +sphinx-help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(SPHINXOPTS) + +sphinx-deps: + pip install -r requirements.txt + +sphinx-%: __force__ + @$(SPHINXBUILD) -M $* "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(SPHINXOPTS) + +# ------------------------------------------------------------------------ +.PHONY: ecproof-deps ecproof-bundle + +ECPROOFDIR = extensions/ecproofs/proofnav + +ecproof-deps: + $(NPM) --prefix="$(ECPROOFDIR)" install + +ecproof-bundle: + $(NPM) --prefix="$(ECPROOFDIR)" run build + +# ------------------------------------------------------------------------ +clean: + rm -rf _build + rm -rf "$(ECPROOFDIR)"/dist + +mrproper: clean + rm -rf "$(ECPROOFDIR)"/node_modules diff --git a/doc/_static/.keep b/doc/_static/.keep new file mode 100644 index 0000000000..e69de29bb2 diff --git a/doc/conf.py b/doc/conf.py new file mode 100644 index 0000000000..5ba1204ea0 --- /dev/null +++ b/doc/conf.py @@ -0,0 +1,39 @@ +# Configuration file for the Sphinx documentation builder. +# +# For the full list of built-in configuration values, see the documentation: +# https://www.sphinx-doc.org/en/master/usage/configuration.html + +import pathlib +import sys + +# -- Project information ----------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#project-information + +project = 'EasyCrypt refman' +copyright = '2026, EasyCrypt development team' +author = 'EasyCrypt development team' + +# -- General configuration --------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#general-configuration + +EXTENSIONS = pathlib.Path('extensions').resolve() +for x in ['ecpygment', 'ecproofs']: + sys.path.append(str(EXTENSIONS / x)) + +extensions = [ + 'sphinx_rtd_theme', + 'sphinx_design', + 'ecpygment', + 'ecproofs', +] + +highlight_language = 'easycrypt' + +templates_path = ['_templates'] +exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] + +# -- Options for HTML output ------------------------------------------------- +# https://www.sphinx-doc.org/en/master/usage/configuration.html#options-for-html-output + +html_theme = 'sphinx_rtd_theme' +html_static_path = ['_static'] diff --git a/doc/extensions/ecproofs/ecproofs.py b/doc/extensions/ecproofs/ecproofs.py new file mode 100644 index 0000000000..6efe0f4454 --- /dev/null +++ b/doc/extensions/ecproofs/ecproofs.py @@ -0,0 +1,142 @@ +# -------------------------------------------------------------- +from __future__ import annotations + +import docutils as du + +import sphinx.application as sa +import sphinx.errors as se +import sphinx.util as su + +import bisect +import json +import os +import re +import subprocess as subp +import tempfile + +# ====================================================================== +ROOT = os.path.dirname(__file__) + +# ====================================================================== +class ProofnavNode(du.nodes.General, du.nodes.Element): + @staticmethod + def visit_proofnav_node_html(self, node: ProofnavNode): + pass + + @staticmethod + def depart_proofnav_node_html(self, node: ProofnavNode): + uid = node["uid"] + json = node["json"] + + html = f""" +
+
+ +
+""" + + self.body.append(html) + +# ====================================================================== +class EasyCryptProofDirective(su.docutils.SphinxDirective): + has_content = True + + option_spec = { + 'title': su.docutils.directives.unchanged, + } + + def run(self): + env = self.state.document.settings.env + + rawcode = '\n'.join(self.content) + '\n' + + # Find the trap + if (trap := re.search(r'\(\*\s*\$\s*\*\)\s*', rawcode, re.MULTILINE)) is None: + raise se.SphinxError('Cannot find the trap') + code = rawcode[:trap.start()] + rawcode[trap.end():] + + # Find the trap sentence number + sentences = [ + m.end() - 1 + for m in re.finditer(r'\.(\s+|\$)', code) + ] + sentence = bisect.bisect_left(sentences, trap.start()) + + # Run EasyCrypt and extract the proof trace + with tempfile.TemporaryDirectory(delete = False) as tmpdir: + ecfile = os.path.join(tmpdir, 'input.ec') + ecofile = os.path.join(tmpdir, 'input.eco') + with open(ecfile, 'w') as ecstream: + ecstream.write(code) + subp.check_call( + ['easycrypt', 'compile', '-pragmas', 'Proofs:weak', '-trace', ecfile], + stdout = subp.DEVNULL, + stderr = subp.DEVNULL, + ) + with open(ecofile) as ecostream: + eco = json.load(ecostream) + + serial = env.new_serialno("proofnav") + uid = f"proofnav-{serial}" + + # Create widget metadata + data = dict() + + data["source"] = code + data["sentenceEnds"] = [x["position"] for x in eco["trace"][1:]] + data["sentences"] = [ + dict(goals = x["goals"], message = x["messages"]) + for x in eco["trace"][1:] + ] + data["initialSentence"] = sentence - 1 + + if 'title' in self.options: + data['title'] = self.options['title'] + + node = ProofnavNode() + node["uid"] = uid + node["json"] = json.dumps( + data, ensure_ascii = False, separators = (",", ":"), indent = 2) + + return [node] + +# ====================================================================== +def on_builder_inited(app: sa.Sphinx): + out_dir = os.path.join(app.outdir, "_static", "proofnav") + os.makedirs(out_dir, exist_ok = True) + + js = os.path.join(ROOT, "proofnav", "dist", "proofnav.bundle.js") + css = os.path.join(ROOT, "proofnav", "proofnav.css") + + if not os.path.exists(js): + raise se.SphinxError( + "proofnav: bundle not found. Run the frontend build to generate " + f"{js}" + ) + + su.fileutil.copy_asset(js, out_dir) + su.fileutil.copy_asset(js + ".map", out_dir) + su.fileutil.copy_asset(css, out_dir) + +# ====================================================================== +def setup(app: sa.Sphinx) -> su.typing.ExtensionMetadata: + app.add_node( + ProofnavNode, + html = ( + ProofnavNode.visit_proofnav_node_html, + ProofnavNode.depart_proofnav_node_html, + ) + ) + + app.add_js_file("proofnav/proofnav.bundle.js", defer = "defer") + app.add_css_file("proofnav/proofnav.css") + + app.connect("builder-inited", on_builder_inited) + + app.add_directive('ecproof', EasyCryptProofDirective) + + return { + 'version': '0.1', + 'parallel_read_safe': True, + 'parallel_write_safe': True, + } diff --git a/doc/extensions/ecproofs/proofnav/.gitignore b/doc/extensions/ecproofs/proofnav/.gitignore new file mode 100644 index 0000000000..3d2bc62692 --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/.gitignore @@ -0,0 +1,2 @@ +/dist/ +/node_modules/ diff --git a/doc/extensions/ecproofs/proofnav/easycrypt.ts b/doc/extensions/ecproofs/proofnav/easycrypt.ts new file mode 100644 index 0000000000..4680cd7c95 --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/easycrypt.ts @@ -0,0 +1,114 @@ +import { StreamLanguage } from "@codemirror/language" +import type { StreamParser } from "@codemirror/language" + +type KeywordGroups = Record +type TagMap = Record + +const keywords: KeywordGroups = { + bytac : ['exact', 'assumption', 'smt', 'coq', 'check', 'edit', 'fix', 'by', 'reflexivity', 'done', 'solve'], + dangerous : ['admit', 'admitted'], + global : ['axiom', 'axiomatized', 'lemma', 'realize', 'proof', 'qed', 'abort', 'goal', 'end', 'from', 'import', 'export', 'include', 'local', 'global', 'declare', 'hint', 'module', 'of', 'const', 'op', 'pred', 'inductive', 'notation', 'abbrev', 'require', 'theory', 'abstract', 'section', 'subtype', 'type', 'class', 'instance', 'print', 'search', 'locate', 'as', 'Pr', 'clone', 'with', 'rename', 'prover', 'timeout', 'why3', 'dump', 'remove', 'exit', 'Top', 'Self'], + internal : ['fail', 'time', 'undo', 'debug', 'pragma'], + prog : ['forall', 'exists', 'fun', 'glob', 'let', 'in', 'for', 'var', 'proc', 'if', 'is', 'match', 'then', 'else', 'elif', 'match', 'for', 'while', 'assert', 'return', 'res', 'equiv', 'hoare', 'ehoare', 'phoare', 'islossless', 'async'], + tactic : ['beta', 'iota', 'zeta', 'eta', 'logic', 'delta', 'simplify', 'cbv', 'congr', 'change', 'split', 'left', 'right', 'case', 'pose', 'gen', 'have', 'suff', 'elim', 'exlim', 'ecall', 'clear', 'wlog', 'idassign', 'apply', 'rewrite', 'rwnormal', 'subst', 'progress', 'trivial', 'auto', 'idtac', 'move', 'modpath', 'field', 'fieldeq', 'ring', 'ringeq', 'algebra', 'replace', 'transitivity', 'symmetry', 'seq', 'wp', 'sp', 'sim', 'skip', 'call', 'rcondt', 'rcondf', 'swap', 'cfold', 'rnd', 'rndsem', 'pr_bounded', 'bypr', 'byphoare', 'byehoare', 'byequiv', 'byupto', 'fel', 'conseq', 'exfalso', 'inline', 'outline', 'interleave', 'alias', 'weakmem', 'fission', 'fusion', 'unroll', 'splitwhile', 'kill', 'eager'], + tactical : ['try', 'first', 'last', 'do', 'expect'], +} + +const tags: TagMap = { + bytac : "annotation", + dangerous : "invalid", + global : "namespace", + internal : "invalid", + prog : "keyword", + tactic : "controlKeyword", + tactical : "controlOperator", +} + +function buildKeywordTagMap( + keywords: KeywordGroups, + tags: TagMap +): Record { + const result: Record = {} + + for (const [group, words] of Object.entries(keywords)) { + const tag = tags[group] + if (!tag) continue + + for (const word of words) { + result[word] = tag + } + } + + return result +} + +const keywordToTag = buildKeywordTagMap(keywords, tags) + +const identRE = /^[a-zA-Z_][A-Za-z0-9_']*/ +const numberRE = /^\d+/ +const punctRE = /^[()\[\]{};,.:]/ + +type State = { commentDepth: number } + +function eatNestedComment(stream: any, state: State): void { + while (!stream.eol()) { + if (stream.match("(*")) { + state.commentDepth++ + continue + } + if (stream.match("*)")) { + state.commentDepth-- + if (state.commentDepth <= 0) { + state.commentDepth = 0 + break + } + continue + } + stream.next() + } +} + +const parser: StreamParser = { + name: "easycrypt", + startState(): State { + return {commentDepth: 0} + }, + token(stream: any, state: State): string | null { + // Nested comment continuation + if (state.commentDepth > 0) { + eatNestedComment(stream, state) + return "comment" + } + + if (stream.eatSpace()) return null + + // Nested comment start + if (stream.match("(*")) { + state.commentDepth = 1 + eatNestedComment(stream, state) + return "comment" + } + + // Numbers + if (stream.match(numberRE)) { + return "number" + } + + // Identifiers / keywords + if (stream.match(identRE)) { + const word: string = stream.current() + return keywordToTag[word] ?? "variableName" + } + + // Punctuation + if (stream.match(punctRE)) { + return "punctuation" + } + + // Always make progress + stream.next() + return null + } +} + +export const easycryptHighlight = StreamLanguage.define(parser) diff --git a/doc/extensions/ecproofs/proofnav/esbuild.mjs b/doc/extensions/ecproofs/proofnav/esbuild.mjs new file mode 100644 index 0000000000..61cbf24b4a --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/esbuild.mjs @@ -0,0 +1,22 @@ +import esbuild from "esbuild"; + +const watch = process.argv.includes("--watch"); + +const ctx = await esbuild.context({ + entryPoints: ["index.ts"], + bundle: true, + format: "iife", + target: ["es2019"], + outfile: "dist/proofnav.bundle.js", + sourcemap: true, + minify: true +}); + +if (watch) { + await ctx.watch(); + console.log("proofnav: watching..."); +} else { + await ctx.rebuild(); + await ctx.dispose(); + console.log("proofnav: built"); +} diff --git a/doc/extensions/ecproofs/proofnav/index.ts b/doc/extensions/ecproofs/proofnav/index.ts new file mode 100644 index 0000000000..414e0110a9 --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/index.ts @@ -0,0 +1,46 @@ +import { createProofNavigator } from "./widget"; + +type ProofNavData = { + source: string; + sentenceEnds: number[]; + sentences: Array<{ goals?: string[]; message?: string | null }>; + initialSentence?: number; + title?: string; +}; + +function mountOne(mount: HTMLElement) { + const id = mount.id; + const dataEl = document.getElementById(id + "-data"); + if (!dataEl) return; + + let data: ProofNavData; + try { + data = JSON.parse(dataEl.textContent || "{}"); + } catch (e) { + mount.innerHTML = `
proofnav: invalid JSON
`; + return; + } + + const initialSentence = typeof data.initialSentence === "number" ? data.initialSentence : -1; + const title = typeof data.title === "string" ? data.title : undefined; + + createProofNavigator({ + parent: mount, + source: data.source, + sentenceEnds: data.sentenceEnds, + sentences: data.sentences, + initialSentence, + title, + }); +} + +function mountAll() { + const mounts = document.querySelectorAll(".proofnav-sphinx .proofnav-mount"); + mounts.forEach(mountOne); +} + +if (document.readyState === "loading") { + document.addEventListener("DOMContentLoaded", mountAll); +} else { + mountAll(); +} diff --git a/doc/extensions/ecproofs/proofnav/package-lock.json b/doc/extensions/ecproofs/proofnav/package-lock.json new file mode 100644 index 0000000000..900f7747bd --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/package-lock.json @@ -0,0 +1,614 @@ +{ + "name": "proofnav", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "proofnav", + "dependencies": { + "@codemirror/commands": "~6.10", + "@codemirror/language": "~6.12", + "@codemirror/state": "~6.5", + "@codemirror/view": "~6.39", + "@lezer/highlight": "~1.2" + }, + "devDependencies": { + "esbuild": "~0.27", + "typescript": "~5" + } + }, + "node_modules/@codemirror/commands": { + "version": "6.10.1", + "resolved": "https://registry.npmjs.org/@codemirror/commands/-/commands-6.10.1.tgz", + "integrity": "sha512-uWDWFypNdQmz2y1LaNJzK7fL7TYKLeUAU0npEC685OKTF3KcQ2Vu3klIM78D7I6wGhktme0lh3CuQLv0ZCrD9Q==", + "license": "MIT", + "dependencies": { + "@codemirror/language": "^6.0.0", + "@codemirror/state": "^6.4.0", + "@codemirror/view": "^6.27.0", + "@lezer/common": "^1.1.0" + } + }, + "node_modules/@codemirror/language": { + "version": "6.12.1", + "resolved": "https://registry.npmjs.org/@codemirror/language/-/language-6.12.1.tgz", + "integrity": "sha512-Fa6xkSiuGKc8XC8Cn96T+TQHYj4ZZ7RdFmXA3i9xe/3hLHfwPZdM+dqfX0Cp0zQklBKhVD8Yzc8LS45rkqcwpQ==", + "license": "MIT", + "dependencies": { + "@codemirror/state": "^6.0.0", + "@codemirror/view": "^6.23.0", + "@lezer/common": "^1.5.0", + "@lezer/highlight": "^1.0.0", + "@lezer/lr": "^1.0.0", + "style-mod": "^4.0.0" + } + }, + "node_modules/@codemirror/state": { + "version": "6.5.4", + "resolved": "https://registry.npmjs.org/@codemirror/state/-/state-6.5.4.tgz", + "integrity": "sha512-8y7xqG/hpB53l25CIoit9/ngxdfoG+fx+V3SHBrinnhOtLvKHRyAJJuHzkWrR4YXXLX8eXBsejgAAxHUOdW1yw==", + "license": "MIT", + "dependencies": { + "@marijn/find-cluster-break": "^1.0.0" + } + }, + "node_modules/@codemirror/view": { + "version": "6.39.11", + "resolved": "https://registry.npmjs.org/@codemirror/view/-/view-6.39.11.tgz", + "integrity": "sha512-bWdeR8gWM87l4DB/kYSF9A+dVackzDb/V56Tq7QVrQ7rn86W0rgZFtlL3g3pem6AeGcb9NQNoy3ao4WpW4h5tQ==", + "license": "MIT", + "dependencies": { + "@codemirror/state": "^6.5.0", + "crelt": "^1.0.6", + "style-mod": "^4.1.0", + "w3c-keyname": "^2.2.4" + } + }, + "node_modules/@esbuild/aix-ppc64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/aix-ppc64/-/aix-ppc64-0.27.2.tgz", + "integrity": "sha512-GZMB+a0mOMZs4MpDbj8RJp4cw+w1WV5NYD6xzgvzUJ5Ek2jerwfO2eADyI6ExDSUED+1X8aMbegahsJi+8mgpw==", + "cpu": [ + "ppc64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "aix" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-arm": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/android-arm/-/android-arm-0.27.2.tgz", + "integrity": "sha512-DVNI8jlPa7Ujbr1yjU2PfUSRtAUZPG9I1RwW4F4xFB1Imiu2on0ADiI/c3td+KmDtVKNbi+nffGDQMfcIMkwIA==", + "cpu": [ + "arm" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/android-arm64/-/android-arm64-0.27.2.tgz", + "integrity": "sha512-pvz8ZZ7ot/RBphf8fv60ljmaoydPU12VuXHImtAs0XhLLw+EXBi2BLe3OYSBslR4rryHvweW5gmkKFwTiFy6KA==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/android-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/android-x64/-/android-x64-0.27.2.tgz", + "integrity": "sha512-z8Ank4Byh4TJJOh4wpz8g2vDy75zFL0TlZlkUkEwYXuPSgX8yzep596n6mT7905kA9uHZsf/o2OJZubl2l3M7A==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "android" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/darwin-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/darwin-arm64/-/darwin-arm64-0.27.2.tgz", + "integrity": "sha512-davCD2Zc80nzDVRwXTcQP/28fiJbcOwvdolL0sOiOsbwBa72kegmVU0Wrh1MYrbuCL98Omp5dVhQFWRKR2ZAlg==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "darwin" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/darwin-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/darwin-x64/-/darwin-x64-0.27.2.tgz", + "integrity": "sha512-ZxtijOmlQCBWGwbVmwOF/UCzuGIbUkqB1faQRf5akQmxRJ1ujusWsb3CVfk/9iZKr2L5SMU5wPBi1UWbvL+VQA==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "darwin" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/freebsd-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/freebsd-arm64/-/freebsd-arm64-0.27.2.tgz", + "integrity": "sha512-lS/9CN+rgqQ9czogxlMcBMGd+l8Q3Nj1MFQwBZJyoEKI50XGxwuzznYdwcav6lpOGv5BqaZXqvBSiB/kJ5op+g==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "freebsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/freebsd-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/freebsd-x64/-/freebsd-x64-0.27.2.tgz", + "integrity": "sha512-tAfqtNYb4YgPnJlEFu4c212HYjQWSO/w/h/lQaBK7RbwGIkBOuNKQI9tqWzx7Wtp7bTPaGC6MJvWI608P3wXYA==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "freebsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-arm": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-arm/-/linux-arm-0.27.2.tgz", + "integrity": "sha512-vWfq4GaIMP9AIe4yj1ZUW18RDhx6EPQKjwe7n8BbIecFtCQG4CfHGaHuh7fdfq+y3LIA2vGS/o9ZBGVxIDi9hw==", + "cpu": [ + "arm" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-arm64/-/linux-arm64-0.27.2.tgz", + "integrity": "sha512-hYxN8pr66NsCCiRFkHUAsxylNOcAQaxSSkHMMjcpx0si13t1LHFphxJZUiGwojB1a/Hd5OiPIqDdXONia6bhTw==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-ia32": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-ia32/-/linux-ia32-0.27.2.tgz", + "integrity": "sha512-MJt5BRRSScPDwG2hLelYhAAKh9imjHK5+NE/tvnRLbIqUWa+0E9N4WNMjmp/kXXPHZGqPLxggwVhz7QP8CTR8w==", + "cpu": [ + "ia32" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-loong64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-loong64/-/linux-loong64-0.27.2.tgz", + "integrity": "sha512-lugyF1atnAT463aO6KPshVCJK5NgRnU4yb3FUumyVz+cGvZbontBgzeGFO1nF+dPueHD367a2ZXe1NtUkAjOtg==", + "cpu": [ + "loong64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-mips64el": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-mips64el/-/linux-mips64el-0.27.2.tgz", + "integrity": "sha512-nlP2I6ArEBewvJ2gjrrkESEZkB5mIoaTswuqNFRv/WYd+ATtUpe9Y09RnJvgvdag7he0OWgEZWhviS1OTOKixw==", + "cpu": [ + "mips64el" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-ppc64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-ppc64/-/linux-ppc64-0.27.2.tgz", + "integrity": "sha512-C92gnpey7tUQONqg1n6dKVbx3vphKtTHJaNG2Ok9lGwbZil6DrfyecMsp9CrmXGQJmZ7iiVXvvZH6Ml5hL6XdQ==", + "cpu": [ + "ppc64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-riscv64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-riscv64/-/linux-riscv64-0.27.2.tgz", + "integrity": "sha512-B5BOmojNtUyN8AXlK0QJyvjEZkWwy/FKvakkTDCziX95AowLZKR6aCDhG7LeF7uMCXEJqwa8Bejz5LTPYm8AvA==", + "cpu": [ + "riscv64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-s390x": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-s390x/-/linux-s390x-0.27.2.tgz", + "integrity": "sha512-p4bm9+wsPwup5Z8f4EpfN63qNagQ47Ua2znaqGH6bqLlmJ4bx97Y9JdqxgGZ6Y8xVTixUnEkoKSHcpRlDnNr5w==", + "cpu": [ + "s390x" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/linux-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/linux-x64/-/linux-x64-0.27.2.tgz", + "integrity": "sha512-uwp2Tip5aPmH+NRUwTcfLb+W32WXjpFejTIOWZFw/v7/KnpCDKG66u4DLcurQpiYTiYwQ9B7KOeMJvLCu/OvbA==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "linux" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/netbsd-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/netbsd-arm64/-/netbsd-arm64-0.27.2.tgz", + "integrity": "sha512-Kj6DiBlwXrPsCRDeRvGAUb/LNrBASrfqAIok+xB0LxK8CHqxZ037viF13ugfsIpePH93mX7xfJp97cyDuTZ3cw==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "netbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/netbsd-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/netbsd-x64/-/netbsd-x64-0.27.2.tgz", + "integrity": "sha512-HwGDZ0VLVBY3Y+Nw0JexZy9o/nUAWq9MlV7cahpaXKW6TOzfVno3y3/M8Ga8u8Yr7GldLOov27xiCnqRZf0tCA==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "netbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/openbsd-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/openbsd-arm64/-/openbsd-arm64-0.27.2.tgz", + "integrity": "sha512-DNIHH2BPQ5551A7oSHD0CKbwIA/Ox7+78/AWkbS5QoRzaqlev2uFayfSxq68EkonB+IKjiuxBFoV8ESJy8bOHA==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "openbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/openbsd-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/openbsd-x64/-/openbsd-x64-0.27.2.tgz", + "integrity": "sha512-/it7w9Nb7+0KFIzjalNJVR5bOzA9Vay+yIPLVHfIQYG/j+j9VTH84aNB8ExGKPU4AzfaEvN9/V4HV+F+vo8OEg==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "openbsd" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/openharmony-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/openharmony-arm64/-/openharmony-arm64-0.27.2.tgz", + "integrity": "sha512-LRBbCmiU51IXfeXk59csuX/aSaToeG7w48nMwA6049Y4J4+VbWALAuXcs+qcD04rHDuSCSRKdmY63sruDS5qag==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "openharmony" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/sunos-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/sunos-x64/-/sunos-x64-0.27.2.tgz", + "integrity": "sha512-kMtx1yqJHTmqaqHPAzKCAkDaKsffmXkPHThSfRwZGyuqyIeBvf08KSsYXl+abf5HDAPMJIPnbBfXvP2ZC2TfHg==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "sunos" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-arm64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/win32-arm64/-/win32-arm64-0.27.2.tgz", + "integrity": "sha512-Yaf78O/B3Kkh+nKABUF++bvJv5Ijoy9AN1ww904rOXZFLWVc5OLOfL56W+C8F9xn5JQZa3UX6m+IktJnIb1Jjg==", + "cpu": [ + "arm64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-ia32": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/win32-ia32/-/win32-ia32-0.27.2.tgz", + "integrity": "sha512-Iuws0kxo4yusk7sw70Xa2E2imZU5HoixzxfGCdxwBdhiDgt9vX9VUCBhqcwY7/uh//78A1hMkkROMJq9l27oLQ==", + "cpu": [ + "ia32" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@esbuild/win32-x64": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/@esbuild/win32-x64/-/win32-x64-0.27.2.tgz", + "integrity": "sha512-sRdU18mcKf7F+YgheI/zGf5alZatMUTKj/jNS6l744f9u3WFu4v7twcUI9vu4mknF4Y9aDlblIie0IM+5xxaqQ==", + "cpu": [ + "x64" + ], + "dev": true, + "license": "MIT", + "optional": true, + "os": [ + "win32" + ], + "engines": { + "node": ">=18" + } + }, + "node_modules/@lezer/common": { + "version": "1.5.0", + "resolved": "https://registry.npmjs.org/@lezer/common/-/common-1.5.0.tgz", + "integrity": "sha512-PNGcolp9hr4PJdXR4ix7XtixDrClScvtSCYW3rQG106oVMOOI+jFb+0+J3mbeL/53g1Zd6s0kJzaw6Ri68GmAA==", + "license": "MIT" + }, + "node_modules/@lezer/highlight": { + "version": "1.2.3", + "resolved": "https://registry.npmjs.org/@lezer/highlight/-/highlight-1.2.3.tgz", + "integrity": "sha512-qXdH7UqTvGfdVBINrgKhDsVTJTxactNNxLk7+UMwZhU13lMHaOBlJe9Vqp907ya56Y3+ed2tlqzys7jDkTmW0g==", + "license": "MIT", + "dependencies": { + "@lezer/common": "^1.3.0" + } + }, + "node_modules/@lezer/lr": { + "version": "1.4.7", + "resolved": "https://registry.npmjs.org/@lezer/lr/-/lr-1.4.7.tgz", + "integrity": "sha512-wNIFWdSUfX9Jc6ePMzxSPVgTVB4EOfDIwLQLWASyiUdHKaMsiilj9bYiGkGQCKVodd0x6bgQCV207PILGFCF9Q==", + "license": "MIT", + "dependencies": { + "@lezer/common": "^1.0.0" + } + }, + "node_modules/@marijn/find-cluster-break": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/@marijn/find-cluster-break/-/find-cluster-break-1.0.2.tgz", + "integrity": "sha512-l0h88YhZFyKdXIFNfSWpyjStDjGHwZ/U7iobcK1cQQD8sejsONdQtTVU+1wVN1PBw40PiiHB1vA5S7VTfQiP9g==", + "license": "MIT" + }, + "node_modules/crelt": { + "version": "1.0.6", + "resolved": "https://registry.npmjs.org/crelt/-/crelt-1.0.6.tgz", + "integrity": "sha512-VQ2MBenTq1fWZUH9DJNGti7kKv6EeAuYr3cLwxUWhIu1baTaXh4Ib5W2CqHVqib4/MqbYGJqiL3Zb8GJZr3l4g==", + "license": "MIT" + }, + "node_modules/esbuild": { + "version": "0.27.2", + "resolved": "https://registry.npmjs.org/esbuild/-/esbuild-0.27.2.tgz", + "integrity": "sha512-HyNQImnsOC7X9PMNaCIeAm4ISCQXs5a5YasTXVliKv4uuBo1dKrG0A+uQS8M5eXjVMnLg3WgXaKvprHlFJQffw==", + "dev": true, + "hasInstallScript": true, + "license": "MIT", + "bin": { + "esbuild": "bin/esbuild" + }, + "engines": { + "node": ">=18" + }, + "optionalDependencies": { + "@esbuild/aix-ppc64": "0.27.2", + "@esbuild/android-arm": "0.27.2", + "@esbuild/android-arm64": "0.27.2", + "@esbuild/android-x64": "0.27.2", + "@esbuild/darwin-arm64": "0.27.2", + "@esbuild/darwin-x64": "0.27.2", + "@esbuild/freebsd-arm64": "0.27.2", + "@esbuild/freebsd-x64": "0.27.2", + "@esbuild/linux-arm": "0.27.2", + "@esbuild/linux-arm64": "0.27.2", + "@esbuild/linux-ia32": "0.27.2", + "@esbuild/linux-loong64": "0.27.2", + "@esbuild/linux-mips64el": "0.27.2", + "@esbuild/linux-ppc64": "0.27.2", + "@esbuild/linux-riscv64": "0.27.2", + "@esbuild/linux-s390x": "0.27.2", + "@esbuild/linux-x64": "0.27.2", + "@esbuild/netbsd-arm64": "0.27.2", + "@esbuild/netbsd-x64": "0.27.2", + "@esbuild/openbsd-arm64": "0.27.2", + "@esbuild/openbsd-x64": "0.27.2", + "@esbuild/openharmony-arm64": "0.27.2", + "@esbuild/sunos-x64": "0.27.2", + "@esbuild/win32-arm64": "0.27.2", + "@esbuild/win32-ia32": "0.27.2", + "@esbuild/win32-x64": "0.27.2" + } + }, + "node_modules/style-mod": { + "version": "4.1.3", + "resolved": "https://registry.npmjs.org/style-mod/-/style-mod-4.1.3.tgz", + "integrity": "sha512-i/n8VsZydrugj3Iuzll8+x/00GH2vnYsk1eomD8QiRrSAeW6ItbCQDtfXCeJHd0iwiNagqjQkvpvREEPtW3IoQ==", + "license": "MIT" + }, + "node_modules/typescript": { + "version": "5.9.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.9.3.tgz", + "integrity": "sha512-jl1vZzPDinLr9eUt3J/t7V6FgNEw9QjvBPdysz9KfQDD41fQrC2Y4vKQdiaUpFT4bXlb1RHhLpp8wtm6M5TgSw==", + "dev": true, + "license": "Apache-2.0", + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/w3c-keyname": { + "version": "2.2.8", + "resolved": "https://registry.npmjs.org/w3c-keyname/-/w3c-keyname-2.2.8.tgz", + "integrity": "sha512-dpojBhNsCNN7T82Tm7k26A6G9ML3NkhDsnw9n/eoxSRlVBB4CEtIQ/KTCLI2Fwf3ataSXRhYFkQi3SlnFwPvPQ==", + "license": "MIT" + } + } +} diff --git a/doc/extensions/ecproofs/proofnav/package.json b/doc/extensions/ecproofs/proofnav/package.json new file mode 100644 index 0000000000..421434db08 --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/package.json @@ -0,0 +1,20 @@ +{ + "name": "proofnav", + "private": true, + "type": "module", + "scripts": { + "build": "node esbuild.mjs", + "watch": "node esbuild.mjs --watch" + }, + "dependencies": { + "@codemirror/commands": "~6.10", + "@codemirror/state": "~6.5", + "@codemirror/view": "~6.39", + "@codemirror/language": "~6.12", + "@lezer/highlight": "~1.2" + }, + "devDependencies": { + "esbuild": "~0.27", + "typescript": "~5" + } +} diff --git a/doc/extensions/ecproofs/proofnav/proofnav.css b/doc/extensions/ecproofs/proofnav/proofnav.css new file mode 100644 index 0000000000..cea082ad04 --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/proofnav.css @@ -0,0 +1,233 @@ +/* Scope everything under the directive wrapper to avoid theme conflicts */ +.proofnav-sphinx .proofnav-rtd{ + --pn-panel: #fcfcfc; + --pn-border: #e1e4e5; + --pn-text: #404040; + --pn-muted: #6a6a6a; + + /* more visible highlights */ + --pn-doneBg: #e6edf3; + --pn-curBg: #cfe3ff; + --pn-hoverBg:#e8f2ff; + + --pn-radius: 4px; + --pn-mono: ui-monospace, SFMono-Regular, Menlo, Monaco, Consolas, + "Liberation Mono", "Courier New", monospace; + + font: inherit; + color: var(--pn-text); +} + +.proofnav-sphinx .proofnav-rtd.proofnav { + display: grid; + grid-template-rows: auto auto; + gap: 12px; + box-sizing: border-box; + min-width: 0; +} + +.proofnav-sphinx .proofnav-rtd .panel{ + border: 1px solid var(--pn-border); + border-radius: var(--pn-radius); + overflow: hidden; + background: var(--pn-panel); + min-width: 0; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__body{ + display: grid; + grid-template-rows: auto auto; + gap: 12px; +} + +.proofnav-sphinx .proofnav-rtd.pn-collapsed .proofnav__body{ + display: none; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__btnToggle{ + display: inline-flex; + align-items: center; + gap: 6px; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__btnToggle{ + padding: 4px 6px; + border-radius: 3px; + line-height: 1; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__sr{ + position: absolute; + width: 1px; + height: 1px; + padding: 0; + margin: -1px; + overflow: hidden; + clip: rect(0,0,0,0); + white-space: nowrap; + border: 0; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__chev{ + transition: transform 120ms ease; +} + +.proofnav-sphinx .proofnav-rtd.pn-collapsed .proofnav__chev{ + transform: rotate(-90deg); +} + +.proofnav-sphinx .proofnav-rtd .proofnav__sentencebar{ + display: flex; + align-items: center; + justify-content: space-between; + gap: 10px; + padding: 8px 10px; + border-bottom: 1px solid var(--pn-border); + background: #fff; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__header{ + display:flex; + align-items:center; + justify-content: space-between; + padding: 8px 10px; + border-bottom: 1px solid var(--pn-border); + background: #fff; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__title{ + font-weight: 600; + font-size: 14px; + color: #2d2d2d; + white-space: nowrap; + overflow: hidden; + text-overflow: ellipsis; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__title{ + display: flex; + align-items: center; + gap: 8px; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__subtitle{ + font-size: 12px; + color: var(--pn-muted); + margin-left: 10px; + font-weight: 500; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__controls{ + display:flex; + gap: 8px; + flex-shrink: 0; +} + +.proofnav-sphinx .proofnav-rtd .proofnav__btn{ + appearance: none; + border: 1px solid var(--pn-border); + background: #fff; + color: var(--pn-text); + padding: 6px 9px; + border-radius: 3px; + cursor: pointer; + font-weight: 600; + font-size: 12px; +} +.proofnav-sphinx .proofnav-rtd .proofnav__btn:hover{ background: #f7f7f7; } + +.proofnav-sphinx .proofnav-rtd .proofnav__editor{ + height: auto; + background: #fff; + overflow: hidden; +} + +.proofnav-sphinx .proofnav-rtd .infoBody{ + padding: 10px; + display: grid; + grid-template-rows: auto auto; + gap: 10px; + box-sizing: border-box; +} + +.proofnav-sphinx .proofnav-rtd .box{ + border: 1px solid var(--pn-border); + border-radius: var(--pn-radius); + padding: 8px 10px; + background: #fff; + min-width: 0; +} + +.proofnav-sphinx .proofnav-rtd .tabs{ + display:flex; + gap: 6px; + flex-wrap: wrap; + margin-bottom: 6px; +} + +.proofnav-sphinx .proofnav-rtd .tab{ + border: 1px solid var(--pn-border); + background: #fff; + color: var(--pn-text); + padding: 4px 8px; + border-radius: 999px; + cursor: pointer; + font-weight: 600; + font-size: 12px; +} + +.proofnav-sphinx .proofnav-rtd .tab[aria-selected="true"]{ + background: #e8f0ff; + border-color: #c9d7ff; +} + +.proofnav-sphinx .proofnav-rtd .goal-sep{ + border-top: 1px solid var(--pn-border); + margin: 6px 0 8px 0; +} + +.proofnav-sphinx .proofnav-rtd pre{ + margin: 0; + white-space: pre-wrap; + word-break: break-word; + font-family: var(--pn-mono); + font-size: 11.5px; + color: var(--pn-text); +} + +.proofnav-sphinx .proofnav-rtd .empty{ + color: var(--pn-muted); + font-size: 13px; + font-weight: 600; +} + +/* sentence highlights */ +.proofnav-sphinx .proofnav-rtd .cm-sentenceDone{ background: var(--pn-doneBg); } +.proofnav-sphinx .proofnav-rtd .cm-sentenceHover{ background: var(--pn-hoverBg); } +.proofnav-sphinx .proofnav-rtd .cm-sentenceCurrent{ + background: var(--pn-curBg) !important; + box-shadow: inset 3px 0 0 rgba(32,94,255,.35); +} + +/* active sentence gutter */ +.proofnav-sphinx .proofnav-rtd .cm-activeSentenceGutter{ + background: #fbfbfb; + border-right: 1px solid var(--pn-border); + color: #2d2d2d; +} + +.proofnav-sphinx .proofnav-rtd .cm-activeSentenceMarker{ + width: 10px; + display: inline-flex; + align-items: center; + justify-content: center; + font-size: 12px; + user-select: none; +} + +/* pointer cursor only when hovering a sentence */ +.proofnav-sphinx .proofnav-rtd.pn-hovering .cm-content, +.proofnav-sphinx .proofnav-rtd.pn-hovering .cm-line, +.proofnav-sphinx .proofnav-rtd.pn-hovering .cm-gutters{ + cursor: pointer; +} diff --git a/doc/extensions/ecproofs/proofnav/widget.ts b/doc/extensions/ecproofs/proofnav/widget.ts new file mode 100644 index 0000000000..e645807e5a --- /dev/null +++ b/doc/extensions/ecproofs/proofnav/widget.ts @@ -0,0 +1,461 @@ +import { + EditorState, + StateEffect, + StateField, + Range, + RangeSet, +} from "@codemirror/state"; + +import { + EditorView, + Decoration, + keymap, + gutter, + GutterMarker, + lineNumbers, +} from "@codemirror/view"; + +import { defaultKeymap } from "@codemirror/commands"; +import { syntaxHighlighting, HighlightStyle } from "@codemirror/language"; +import { tags as t } from "@lezer/highlight" + +import { easycryptHighlight } from "./easycrypt"; + +export type ProofSentence = { + goals?: string[]; + message?: string | null; +}; + +export type CreateProofNavigatorOptions = { + parent: HTMLElement; + source: string; + sentenceEnds: number[]; + sentences: ProofSentence[]; + initialSentence?: number; // allow -1 (before first) + collapsible?: boolean; // default true + initialCollapsed?: boolean; // default true + title?: string; // default "Proof Navigator" +}; + +export type ProofNavigatorHandle = { + view: EditorView; + setSentence: (idx: number, opts?: { scroll?: boolean }) => void; + getSentence: () => number; + collapse: () => void; + expand: () => void; + toggleCollapsed: () => void; + isCollapsed: () => boolean; +}; + +const rtdHighlight: HighlightStyle = HighlightStyle.define([ + { tag: t.keyword, color: "#005a9c", fontWeight: "600" }, + { tag: t.annotation, color: "#a10d2b", fontWeight: "600" }, + { tag: t.invalid, color: "#ff0000", fontWeight: "600" }, + { tag: t.namespace, color: "#b61295", fontWeight: "600" }, + { tag: t.keyword, color: "#005a9c", fontWeight: "600" }, + { tag: t.controlKeyword, color: "#005a9c", fontWeight: "600" }, + { tag: t.controlOperator, color: "#108401", fontWeight: "600" }, + { tag: [t.string, t.special(t.string)], color: "#1a7f37" }, + { tag: t.comment, color: "#6a737d", fontStyle: "italic" }, + { tag: t.number, color: "#b31d28" }, + { tag: t.variableName, color: "#24292f" }, + { tag: [t.operator, t.punctuation], color: "#57606a" }, +]); + +export function createProofNavigator(opts: CreateProofNavigatorOptions): ProofNavigatorHandle { + const { + parent, + source, + sentenceEnds, + sentences, + initialSentence = -1, + collapsible = true, + initialCollapsed = true, + title = "Proof Navigator", + } = opts; + + if (!parent) throw new Error("parent is required"); + if (!Array.isArray(sentenceEnds) || sentenceEnds.length === 0) { + throw new Error("sentenceEnds must be non-empty"); + } + if (!Array.isArray(sentences) || sentences.length !== sentenceEnds.length) { + throw new Error("sentences length mismatch"); + } + + function skipWhitespaceForward(pos: number): number { + while (pos < source.length && /\s/.test(source[pos])) pos++; + return pos; + } + + const sentenceStarts = sentenceEnds.map((_, i) => + i === 0 + ? skipWhitespaceForward(0) + : skipWhitespaceForward(sentenceEnds[i - 1]) + ); + + const clamp = (x: number, lo: number, hi: number) => Math.max(lo, Math.min(hi, x)); + + function sentenceIndexAtPos(pos: number): number { + let lo = 0; + let hi = sentenceEnds.length - 1; + while (lo < hi) { + const mid = (lo + hi) >> 1; + if (sentenceEnds[mid] >= pos) hi = mid; + else lo = mid + 1; + } + return lo; + } + + const root = document.createElement("div"); + root.className = "proofnav proofnav-rtd"; + root.innerHTML = ` +
+
+
+ ${collapsible ? ` + + ` : ""} + +
+
+ +
+
+
+
+ + +
+
+ +
+ +
+
+
+
+
+
+
+
+
+
+
+
+
+
+ `; + parent.appendChild(root); + + const elTitle = root.querySelector("[data-title]") as HTMLElement; + elTitle.textContent = title; + + const elEditor = root.querySelector("[data-editor]") as HTMLElement; + const elTabs = root.querySelector("[data-tabs]") as HTMLElement; + const elGoalContent = root.querySelector("[data-goalcontent]") as HTMLElement; + const elMessage = root.querySelector("[data-message]") as HTMLElement; + const elSentInfo = root.querySelector("[data-sentinfo]") as HTMLElement; + const elGoalSep = root.querySelector(".goal-sep") as HTMLElement; + const btnPrev = root.querySelector("[data-prev]") as HTMLButtonElement; + const btnNext = root.querySelector("[data-next]") as HTMLButtonElement; + + const btnToggle = root.querySelector("[data-toggle]") as HTMLButtonElement | null; + const elToggleLabel = root.querySelector("[data-toggle-label]") as HTMLElement | null; + + const setSentenceEffect = StateEffect.define(); + const setHoverEffect = StateEffect.define(); // number | null + + const sentenceField = StateField.define({ + create() { + return clamp(initialSentence, -1, sentenceEnds.length - 1); + }, + update(v, tr) { + for (const e of tr.effects) { + if (e.is(setSentenceEffect)) return e.value; + } + return v; + }, + }); + + const hoverField = StateField.define({ + create() { + return null; + }, + update(v, tr) { + for (const e of tr.effects) { + if (e.is(setHoverEffect)) return e.value; + } + return v; + }, + }); + + const sentenceHighlightField = StateField.define>({ + create(state) { + return buildDecorations(state.field(sentenceField), state.field(hoverField)); + }, + update(deco, tr) { + const changed = + tr.docChanged || + tr.effects.some((e) => e.is(setSentenceEffect) || e.is(setHoverEffect)); + if (changed) { + return buildDecorations(tr.state.field(sentenceField), tr.state.field(hoverField)); + } + return deco.map(tr.changes); + }, + provide: (f) => EditorView.decorations.from(f), + }); + + function buildDecorations(activeIdx: number, hoverIdx: number | null) { + const d: Range[] = []; + + if (hoverIdx != null && hoverIdx >= 0 && hoverIdx < sentenceEnds.length) { + const hs = sentenceStarts[hoverIdx]; + const he = sentenceEnds[hoverIdx]; + if (he > hs) d.push(Decoration.mark({ class: "cm-sentenceHover" }).range(hs, he)); + } + + if (activeIdx >= 0) { + const start = sentenceStarts[activeIdx]; + const end = sentenceEnds[activeIdx]; + + if (start > 0) d.push(Decoration.mark({ class: "cm-sentenceDone" }).range(0, start)); + if (end > start) d.push(Decoration.mark({ class: "cm-sentenceCurrent" }).range(start, end)); + } + + return Decoration.set(d, true); + } + + const hoverAndClick = EditorView.domEventHandlers({ + mousemove(e, view) { + const pos = view.posAtCoords({ x: e.clientX, y: e.clientY }); + if (pos == null) { + root.classList.remove("pn-hovering"); + if (view.state.field(hoverField) != null) { + view.dispatch({ effects: setHoverEffect.of(null) }); + } + return false; + } + + const idx = sentenceIndexAtPos(pos); + root.classList.add("pn-hovering"); + if (view.state.field(hoverField) !== idx) { + view.dispatch({ effects: setHoverEffect.of(idx) }); + } + return false; + }, + + mouseleave(_e, view) { + root.classList.remove("pn-hovering"); + if (view.state.field(hoverField) != null) { + view.dispatch({ effects: setHoverEffect.of(null) }); + } + return false; + }, + + mousedown(e, view) { + if (e.button !== 0) return false; + const pos = view.posAtCoords({ x: e.clientX, y: e.clientY }); + if (pos == null) return false; + setSentence(sentenceIndexAtPos(pos), { scroll: false }); + return true; + }, + }); + + class ActiveSentenceMarker extends GutterMarker { + toDOM() { + const span = document.createElement("span"); + span.className = "cm-activeSentenceMarker"; + span.textContent = "▶"; + return span; + } + } + const activeMarker = new ActiveSentenceMarker(); + + const activeSentenceGutter = gutter({ + class: "cm-activeSentenceGutter", + markers: (view) => { + const idx = view.state.field(sentenceField); + if (idx < 0) return RangeSet.empty; + const line = view.state.doc.lineAt(sentenceStarts[idx]).from; + return RangeSet.of([activeMarker.range(line)]); + }, + initialSpacer: () => activeMarker, + }); + + const rtdTheme = EditorView.theme({ + "&": { + backgroundColor: "#fff", + color: "#404040", + fontSize: "11px", + }, + ".cm-content": { + fontFamily: "var(--pn-mono)", + fontSize: "11px", + }, + ".cm-gutters": { + backgroundColor: "#fbfbfb", + borderRight: "1px solid #e1e4e5", + fontSize: "11px", + }, + ".cm-lineNumbers .cm-gutterElement": { + padding: "0 8px 0 10px", + fontSize: "11px", + } + }); + + const view = new EditorView({ + parent: elEditor, + state: EditorState.create({ + doc: source, + extensions: [ + easycryptHighlight, + syntaxHighlighting(rtdHighlight), + activeSentenceGutter, + lineNumbers(), + keymap.of(defaultKeymap), + EditorView.editable.of(false), + EditorState.readOnly.of(true), + sentenceField, + hoverField, + sentenceHighlightField, + hoverAndClick, + rtdTheme, + ], + }), + }); + + // autosize editor to content + function autosizeEditor() { + view.requestMeasure({ + read() { + return view.contentDOM.scrollHeight; + }, + write(height) { + // Small padding to avoid clipping descenders + elEditor.style.height = `${height + 6}px`; + } + }); + } + + requestAnimationFrame(() => requestAnimationFrame(autosizeEditor)); + + let activeGoalTab = 0; + + function render(idx: number) { + if (idx < 0) { + elSentInfo.textContent = "Before first sentence"; + elTabs.innerHTML = ""; + elGoalContent.innerHTML = `
No goals.
`; + elMessage.innerHTML = `
No message.
`; + elGoalSep.style.display = "none"; + return; + } + + elSentInfo.textContent = `Sentence ${idx + 1} / ${sentenceEnds.length}`; + const info = sentences[idx] || {}; + const goals = Array.isArray(info.goals) ? info.goals : []; + const msg = String(info.message ?? ""); + + elTabs.innerHTML = ""; + elGoalContent.innerHTML = ""; + elGoalSep.style.display = goals.length ? "block" : "none"; + + if (goals.length === 0) { + elGoalContent.innerHTML = `
No goals.
`; + activeGoalTab = 0; + } else { + activeGoalTab = clamp(activeGoalTab, 0, goals.length - 1); + goals.forEach((_, i) => { + const b = document.createElement("button"); + b.className = "tab"; + b.textContent = `Goal ${i + 1}`; + b.setAttribute("aria-selected", i === activeGoalTab ? "true" : "false"); + b.onclick = () => { + activeGoalTab = i; + render(getSentence()); + }; + elTabs.appendChild(b); + }); + const pre = document.createElement("pre"); + pre.textContent = goals[activeGoalTab] ?? ""; + elGoalContent.appendChild(pre); + } + + if (msg.trim()) { + const pre = document.createElement("pre"); + pre.textContent = msg; + elMessage.innerHTML = ""; + elMessage.appendChild(pre); + } else { + elMessage.innerHTML = `
No message.
`; + } + } + + function scrollTo(idx: number) { + if (idx < 0) return; + view.dispatch({ selection: { anchor: sentenceStarts[idx] }, scrollIntoView: true }); + } + + function setSentence(idx: number, { scroll = true }: { scroll?: boolean } = {}) { + const i = clamp(idx, -1, sentenceEnds.length - 1); + + const effects: StateEffect[] = [setSentenceEffect.of(i)]; + + if (i < 0) { + effects.push(setHoverEffect.of(null)); + root.classList.remove("pn-hovering"); + } + + view.dispatch({ effects }); + render(i); + if (scroll) scrollTo(i); + } + + function getSentence(): number { + return view.state.field(sentenceField); + } + + btnPrev.onclick = () => setSentence(getSentence() - 1); + btnNext.onclick = () => setSentence(getSentence() + 1); + + function isCollapsed(): boolean { + return root.classList.contains("pn-collapsed"); + } + + function setCollapsed(collapsed: boolean) { + if (!collapsible) return; + if (collapsed) root.classList.add("pn-collapsed"); + else root.classList.remove("pn-collapsed"); + + if (btnToggle) btnToggle.setAttribute("aria-expanded", collapsed ? "false" : "true"); + if (elToggleLabel) elToggleLabel.textContent = collapsed ? "Expand" : "Collapse"; + if (btnToggle) btnToggle.title = collapsed ? "Expand" : "Collapse"; + + // When expanding, CodeMirror may need a layout refresh + correct height. + if (!collapsed) { + requestAnimationFrame(() => { + autosizeEditor(); + view.requestMeasure(); + }); + } + } + + function collapse() { setCollapsed(true); } + function expand() { setCollapsed(false); } + function toggleCollapsed() { setCollapsed(!isCollapsed()); } + + if (btnToggle) { + btnToggle.onclick = () => toggleCollapsed(); + } + + setSentence(initialSentence); + + if (collapsible && initialCollapsed) { + setCollapsed(true); + } + + return { view, setSentence, getSentence, collapse, expand, toggleCollapsed, isCollapsed }; +} diff --git a/doc/extensions/ecpygment/ecpygment.py b/doc/extensions/ecpygment/ecpygment.py new file mode 100644 index 0000000000..7fb05381bd --- /dev/null +++ b/doc/extensions/ecpygment/ecpygment.py @@ -0,0 +1,15 @@ +# -------------------------------------------------------------- +import sphinx.application as sa +import sphinx.util as su + +from lexers.easycrypt import EasyCryptLexer + +# -------------------------------------------------------------- +def setup(app: sa.Sphinx) -> su.typing.ExtensionMetadata: + app.add_lexer("easycrypt", EasyCryptLexer) + + return { + 'version': '0.1', + 'parallel_read_safe': True, + 'parallel_write_safe': True, + } diff --git a/doc/extensions/ecpygment/lexers/easycrypt.py b/doc/extensions/ecpygment/lexers/easycrypt.py new file mode 100644 index 0000000000..732013b9bc --- /dev/null +++ b/doc/extensions/ecpygment/lexers/easycrypt.py @@ -0,0 +1,78 @@ +# ------------------------------------------------------------------------ +import pygments.lexer as pylex +import pygments.token as pytok + +import itertools as it + +# ------------------------------------------------------------------------ +# Generated by `scripts/srctx/keywords -m python < src/ecLexer.mll` +keywords = dict( + bytac = ['exact', 'assumption', 'smt', 'coq', 'check', 'edit', 'fix', 'by', 'reflexivity', 'done', 'solve'], + dangerous = ['admit', 'admitted'], + global_ = ['axiom', 'axiomatized', 'lemma', 'realize', 'proof', 'qed', 'abort', 'goal', 'end', 'from', 'import', 'export', 'include', 'local', 'global', 'declare', 'hint', 'module', 'of', 'const', 'op', 'pred', 'inductive', 'notation', 'abbrev', 'require', 'theory', 'abstract', 'section', 'subtype', 'type', 'class', 'instance', 'print', 'search', 'locate', 'as', 'Pr', 'clone', 'with', 'rename', 'prover', 'timeout', 'why3', 'dump', 'remove', 'exit', 'Top', 'Self'], + internal = ['fail', 'time', 'undo', 'debug', 'pragma'], + prog = ['forall', 'exists', 'fun', 'glob', 'let', 'in', 'for', 'var', 'proc', 'if', 'is', 'match', 'then', 'else', 'elif', 'match', 'for', 'while', 'assert', 'return', 'res', 'equiv', 'hoare', 'ehoare', 'phoare', 'islossless', 'async'], + tactic = ['beta', 'iota', 'zeta', 'eta', 'logic', 'delta', 'simplify', 'cbv', 'congr', 'change', 'split', 'left', 'right', 'case', 'pose', 'gen', 'have', 'suff', 'elim', 'exlim', 'ecall', 'clear', 'wlog', 'idassign', 'apply', 'rewrite', 'rwnormal', 'subst', 'progress', 'trivial', 'auto', 'idtac', 'move', 'modpath', 'field', 'fieldeq', 'ring', 'ringeq', 'algebra', 'replace', 'transitivity', 'symmetry', 'seq', 'wp', 'sp', 'sim', 'skip', 'call', 'rcondt', 'rcondf', 'swap', 'cfold', 'rnd', 'rndsem', 'pr_bounded', 'bypr', 'byphoare', 'byehoare', 'byequiv', 'byupto', 'fel', 'conseq', 'exfalso', 'inline', 'outline', 'interleave', 'alias', 'weakmem', 'fission', 'fusion', 'unroll', 'splitwhile', 'kill', 'eager'], + tactical = ['try', 'first', 'last', 'do', 'expect'], +) + +# ------------------------------------------------------------------------ +kwclasses = dict( + bytac = pytok.Name.Exception, + dangerous = pytok.Name.Exception, + global_ = pytok.Keyword.Declaration, + internal = pytok.Keyword.Declaration, + prog = pytok.Keyword.Reserved, + tactic = pytok.Keyword.Reserved, + tactical = pytok.Keyword.Pseudo, +) + +# ------------------------------------------------------------------------ +class EasyCryptLexer(pylex.RegexLexer): + name = "EasyCrypt" + filenames = ["*.ec", "*.eca"] + mimetypes = ["text/x-easycrypt"] + + tokens = { + "root": [ + # Whitespace + (r"[ \t]+", pytok.Whitespace), + (r"\n+", pytok.Whitespace), + + # Comments + (r"\(\*", pytok.Comment.Multiline, "comment"), + ] + [ + # Keywords + (pylex.words(keywords[ids], suffix=r"\b"), cls) + for ids, cls in kwclasses.items() + ] + [ + # Strings (simple single/double quoted) + (r'"([^"\\]|\\.)*"', pytok.String.Double), + + # Numbers + (r"\b\d+\b", pytok.Number.Integer), + + # Identifiers + (r"[A-Za-z_]\w*", pytok.Name), + + # Operators + (r"[+\-*/%=<>&|!]+", pytok.Operator), + + # Punctuation + (r"[()\[\]{},.;:]", pytok.Punctuation), + + # Anything else + (r".", pytok.Text), + ], + + "comment": [ + (r"\(\*", pytok.Comment.Multiline, "#push"), + + # If we see a closer, pop one nesting level + (r"\*\)", pytok.Comment.Multiline, "#pop"), + + # Otherwise consume content (keep it as Comment) + (r"[^()*]+", pytok.Comment.Multiline), + (r"[()*]", pytok.Comment.Multiline), + ], + } diff --git a/doc/index.rst b/doc/index.rst new file mode 100644 index 0000000000..8b6c7d9b2f --- /dev/null +++ b/doc/index.rst @@ -0,0 +1,7 @@ +EasyCrypt reference manual +======================================================================== + +.. toctree:: + :maxdepth: 2 + + tactics diff --git a/doc/package-lock.json b/doc/package-lock.json new file mode 100644 index 0000000000..012938edf8 --- /dev/null +++ b/doc/package-lock.json @@ -0,0 +1,6 @@ +{ + "name": "doc", + "lockfileVersion": 3, + "requires": true, + "packages": {} +} diff --git a/doc/requirements.txt b/doc/requirements.txt new file mode 100644 index 0000000000..a496b96f37 --- /dev/null +++ b/doc/requirements.txt @@ -0,0 +1,3 @@ +Sphinx==8.2.* +sphinx_rtd_theme==3.1.* +sphinx_design==0.6.* diff --git a/doc/tactics.rst b/doc/tactics.rst new file mode 100644 index 0000000000..5b954bbad8 --- /dev/null +++ b/doc/tactics.rst @@ -0,0 +1,8 @@ +Proof tactics reference +======================================================================== + +.. toctree:: + :maxdepth: 1 + :glob: + + tactics/* diff --git a/doc/tactics/skip.rst b/doc/tactics/skip.rst new file mode 100644 index 0000000000..6c3ff2a44d --- /dev/null +++ b/doc/tactics/skip.rst @@ -0,0 +1,123 @@ +======================================================================== +Tactic: `skip` +======================================================================== + +The ``skip`` tactic applies to program-logic goals where the program(s) +under consideration are empty. In this situation, program execution +performs no computation and produces no state changes. + +Applying ``skip`` eliminates the program component of the goal and reduces +the proof obligation to a pure logical goal. Concretely, the remaining +task is to prove that the precondition implies the postcondition. + +The ``skip`` tactic does not attempt to solve this logical obligation itself. + +.. contents:: + :local: + +------------------------------------------------------------------------ +Variant: ``skip`` (HL) +------------------------------------------------------------------------ + +.. ecproof:: + :title: Hoare logic example + + require import AllCore. + + module M = { + proc f(x : int) = { + return x; + } + }. + + pred p : int. + pred q : int. + + lemma L : hoare[M.f : p x ==> q res]. + proof. + proc. (*$*) skip. + abort. + +------------------------------------------------------------------------ +Variant: ``skip`` (pRHL) +------------------------------------------------------------------------ + +In the relational Hoare logic setting, the `skip`` tactic applies only +when both programs are empty, in which case it reduces the relational +judgment to obligations on the preconditions and postconditions alone. + +.. ecproof:: + :title: Probabilistic Relational Hoare logic example + + require import AllCore. + + module M = { + proc f(x : int) = { + return x; + } + }. + + pred p : int & int. + pred q : int & int. + + lemma L : equiv[M.f ~ M.f : p x{1} x{2} ==> q res{1} res{2}]. + proof. + proc. (*$*) skip. + abort. + +------------------------------------------------------------------------ +Variant: ``skip`` (pHL) +------------------------------------------------------------------------ + +In the probabilistic Hoare logic setting, applying ``skip`` generates an +additional proof obligation compared to the pure Hoare case. Besides the +logical implication between the precondition and the postcondition, one +must also prove that the probability weight of the empty program, namely +``1%r``, satisfies the bound specified in the judgment. + +.. ecproof:: + :title: Probabilistic Hoare logic example + + require import AllCore. + + module M = { + proc f(x : int) = { + return x; + } + }. + + pred p : int. + pred q : int. + + lemma L : phoare[M.f : p x ==> q res] >= (1%r / 2%r). + proof. + proc. (*$*) skip. + abort. + +------------------------------------------------------------------------ +Variant: ``skip`` (eHL) +------------------------------------------------------------------------ + +In expectation Hoare logic, where the precondition and postcondition are +respectively a pre-expectation and a post-expectation, applying skip generates +the obligation to prove that the post-expectation is bounded above by the +pre-expectation. + +.. ecproof:: + :title: Expectation Hoare logic example + + require import AllCore Xreal. + + module M = { + proc f(x : int) = { + return x; + } + }. + + op p : int -> xreal. + op q : int -> xreal. + + lemma L : ehoare[M.f : p x ==> q res]. + proof. + proc. (*$*) skip. + abort. From a52fe7f9710a17df47f6b687f88917deefb28581 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 23 Jan 2026 23:12:17 +0100 Subject: [PATCH 21/26] CI (doc): not cancellable --- .github/workflows/docs.yml | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index 87658237a9..43a02784da 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -11,13 +11,13 @@ permissions: pages: write id-token: write +concurrency: + group: "refman" + cancel-in-progress: false jobs: build: runs-on: ubuntu-latest - concurrency: - group: "refman" - cancel-in-progress: true steps: - name: Checkout @@ -72,9 +72,6 @@ jobs: runs-on: ubuntu-latest needs: build if: github.event_name == 'push' && github.ref == 'refs/heads/main' - concurrency: - group: "refman" - cancel-in-progress: false steps: - name: Download documentation (artifact) From 28bbb5df82c34bc2e5899f3bea6c68e31d30998d Mon Sep 17 00:00:00 2001 From: Lucas Tabary-Maujean Date: Thu, 25 Sep 2025 15:08:43 +0200 Subject: [PATCH 22/26] style: use regular datatype for ty_body --- src/ecDecl.ml | 42 +++++++++++++++++++++--------------------- src/ecDecl.mli | 32 ++++++++++++++++---------------- src/ecEnv.ml | 25 +++++++++++++------------ src/ecHiInductive.ml | 10 +++++----- src/ecPrinting.ml | 10 +++++----- src/ecScope.ml | 12 ++++++------ src/ecSection.ml | 30 +++++++++++++++--------------- src/ecSmt.ml | 8 ++++---- src/ecSubst.ml | 16 ++++++++-------- src/ecTheoryReplay.ml | 24 ++++++++++++------------ src/ecTyping.ml | 4 ++-- 11 files changed, 107 insertions(+), 106 deletions(-) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 5636641acc..ed356ac535 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -15,42 +15,42 @@ type ty_param = EcIdent.t * EcPath.Sp.t type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] -type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; -} - -and ty_body = [ - | `Concrete of EcTypes.ty - | `Abstract of Sp.t - | `Datatype of ty_dtype - | `Record of ty_record -] - -and ty_record = +type ty_record = EcCoreFol.form * (EcSymbols.symbol * EcTypes.ty) list -and ty_dtype_ctor = +type ty_dtype_ctor = EcSymbols.symbol * EcTypes.ty list -and ty_dtype = { +type ty_dtype = { tydt_ctors : ty_dtype_ctor list; tydt_schelim : EcCoreFol.form; tydt_schcase : EcCoreFol.form; } +type ty_body = + | Concrete of EcTypes.ty + | Abstract of Sp.t + | Datatype of ty_dtype + | Record of ty_record + + +type tydecl = { + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; +} + let tydecl_as_concrete (td : tydecl) = - match td.tyd_type with `Concrete x -> Some x | _ -> None + match td.tyd_type with Concrete x -> Some x | _ -> None let tydecl_as_abstract (td : tydecl) = - match td.tyd_type with `Abstract x -> Some x | _ -> None + match td.tyd_type with Abstract x -> Some x | _ -> None let tydecl_as_datatype (td : tydecl) = - match td.tyd_type with `Datatype x -> Some x | _ -> None + match td.tyd_type with Datatype x -> Some x | _ -> None let tydecl_as_record (td : tydecl) = - match td.tyd_type with `Record x -> Some x | _ -> None + match td.tyd_type with Record (x, y) -> Some (x, y) | _ -> None (* -------------------------------------------------------------------- *) let abs_tydecl ?(tc = Sp.empty) ?(params = `Int 0) lc = @@ -65,7 +65,7 @@ let abs_tydecl ?(tc = Sp.empty) ?(params = `Int 0) lc = (EcUid.NameGen.bulk ~fmt n) in - { tyd_params = params; tyd_type = `Abstract tc; tyd_loca = lc; } + { tyd_params = params; tyd_type = Abstract tc; tyd_loca = lc; } (* -------------------------------------------------------------------- *) let ty_instanciate (params : ty_params) (args : ty list) (ty : ty) = diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 7864a0e0de..c7a30b7bdb 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -11,31 +11,31 @@ type ty_param = EcIdent.t * EcPath.Sp.t type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] -type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; -} - -and ty_body = [ - | `Concrete of EcTypes.ty - | `Abstract of Sp.t - | `Datatype of ty_dtype - | `Record of ty_record -] - -and ty_record = +type ty_record = EcCoreFol.form * (EcSymbols.symbol * EcTypes.ty) list -and ty_dtype_ctor = +type ty_dtype_ctor = EcSymbols.symbol * EcTypes.ty list -and ty_dtype = { +type ty_dtype = { tydt_ctors : ty_dtype_ctor list; tydt_schelim : EcCoreFol.form; tydt_schcase : EcCoreFol.form; } +type ty_body = + | Concrete of EcTypes.ty + | Abstract of Sp.t + | Datatype of ty_dtype + | Record of ty_record + + +type tydecl = { + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; +} + val tydecl_as_concrete : tydecl -> EcTypes.ty option val tydecl_as_abstract : tydecl -> Sp.t option val tydecl_as_datatype : tydecl -> ty_dtype option diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 4ccfcc7ae8..b9bdd12e15 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -781,10 +781,10 @@ module MC = struct let loca = tyd.tyd_loca in match tyd.tyd_type with - | `Concrete _ -> mc - | `Abstract _ -> mc + | Concrete _ -> mc + | Abstract _ -> mc - | `Datatype dtype -> + | Datatype dtype -> let cs = dtype.tydt_ctors in let schelim = dtype.tydt_schelim in let schcase = dtype.tydt_schcase in @@ -828,7 +828,7 @@ module MC = struct _up_operator candup mc name (ipath name, op) ) mc projs - | `Record (scheme, fields) -> + | Record (scheme, fields) -> let params = List.map (fun (x, _) -> tvar x) tyd.tyd_params in let nfields = List.length fields in let cfields = @@ -2541,12 +2541,12 @@ module Ty = struct let defined (name : EcPath.path) (env : env) = match by_path_opt name env with - | Some { tyd_type = `Concrete _ } -> true + | Some { tyd_type = Concrete _ } -> true | _ -> false let unfold (name : EcPath.path) (args : EcTypes.ty list) (env : env) = match by_path_opt name env with - | Some ({ tyd_type = `Concrete body } as tyd) -> + | Some ({ tyd_type = Concrete body } as tyd) -> Tvar.subst (Tvar.init (List.map fst tyd.tyd_params) args) body @@ -2582,14 +2582,15 @@ module Ty = struct match ty.ty_node with | Tconstr (p, tys) -> begin match by_path_opt p env with - | Some ({ tyd_type = (`Datatype _ | `Record _) as body }) -> + | Some ({ tyd_type = (Datatype _ | Record _) as body }) -> let prefix = EcPath.prefix p in let basename = EcPath.basename p in let basename = match body, mode with - | `Record _, (`Ind | `Case) -> basename ^ "_ind" - | `Datatype _, `Ind -> basename ^ "_ind" - | `Datatype _, `Case -> basename ^ "_case" + | Record _, (`Ind | `Case) -> basename ^ "_ind" + | Datatype _, `Ind -> basename ^ "_ind" + | Datatype _, `Case -> basename ^ "_case" + | _, _ -> assert false in Some (EcPath.pqoname prefix basename, tys) | _ -> None @@ -2605,7 +2606,7 @@ module Ty = struct let env = MC.bind_tydecl name ty env in match ty.tyd_type with - | `Abstract tc -> + | Abstract tc -> let myty = let myp = EcPath.pqname (root env) name in let typ = List.map (fst_map EcIdent.fresh) ty.tyd_params in @@ -2931,7 +2932,7 @@ module Theory = struct | Th_type (x, tyd) -> begin match tyd.tyd_type with - | `Abstract tc -> + | Abstract tc -> let myty = let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index a51dede082..f4946fcf46 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -84,7 +84,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let env0 = let myself = { tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = `Abstract EcPath.Sp.empty; + tyd_type = Abstract EcPath.Sp.empty; tyd_loca = lc; } in EcEnv.Ty.bind (unloc name) myself env @@ -135,16 +135,16 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = fun ty -> ty_instanciate tdecl.tyd_params targs ty in match tdecl.tyd_type with - | `Abstract _ -> + | Abstract _ -> List.exists isempty (targs) - | `Concrete ty -> + | Concrete ty -> isempty_1 [tyinst () ty] - | `Record (_, fields) -> + | Record (_, fields) -> isempty_1 (List.map (tyinst () |- snd) fields) - | `Datatype dt -> + | Datatype dt -> isempty_n (List.map (List.map (tyinst ()) |- snd) dt.tydt_ctors) in diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index a9f63997db..854a61a599 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -1281,7 +1281,7 @@ let pp_opapp let recp = EcDecl.operator_as_rcrd op in match EcEnv.Ty.by_path_opt recp env with - | Some { tyd_type = `Record (_, fields) } + | Some { tyd_type = Record (_, fields) } when List.length fields = List.length es -> begin let wmap = @@ -2280,12 +2280,12 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = and pp_body fmt = match tyd.tyd_type with - | `Abstract _ -> () (* FIXME: TC HOOK *) + | Abstract _ -> () (* FIXME: TC HOOK *) - | `Concrete ty -> + | Concrete ty -> Format.fprintf fmt " =@ %a" (pp_type ppe) ty - | `Datatype { tydt_ctors = cs } -> + | Datatype { tydt_ctors = cs } -> let pp_ctor fmt (c, cty) = match cty with | [] -> @@ -2296,7 +2296,7 @@ let pp_typedecl (ppe : PPEnv.t) fmt (x, tyd) = in Format.fprintf fmt " =@ [@[%a@]]" (pp_list " |@ " pp_ctor) cs - | `Record (_, fields) -> + | Record (_, fields) -> let pp_field fmt (f, fty) = Format.fprintf fmt "%s: @[%a@]" f (pp_type ppe) fty in diff --git a/src/ecScope.ml b/src/ecScope.ml index d8a4676f14..1ca3e4e21d 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2239,12 +2239,12 @@ module Ty = struct (fun tc -> fst (EcEnv.TypeClass.lookup (unloc tc) env)) tcs in let ue = TT.transtyvars env (loc, Some args) in - EcUnify.UniEnv.tparams ue, `Abstract (Sp.of_list tcs) + EcUnify.UniEnv.tparams ue, Abstract (Sp.of_list tcs) | PTYD_Alias bd -> let ue = TT.transtyvars env (loc, Some args) in let body = transty tp_tydecl env ue bd in - EcUnify.UniEnv.tparams ue, `Concrete body + EcUnify.UniEnv.tparams ue, Concrete body | PTYD_Datatype dt -> let datatype = EHI.trans_datatype env (mk_loc loc (args,name)) dt in @@ -2252,12 +2252,12 @@ module Ty = struct try ELI.datatype_as_ty_dtype datatype with ELI.NonPositive -> EHI.dterror loc env EHI.DTE_NonPositive in - tparams, `Datatype tydt + tparams, Datatype tydt | PTYD_Record rt -> let record = EHI.trans_record env (mk_loc loc (args,name)) rt in let scheme = ELI.indsc_of_record record in - record.ELI.rc_tparams, `Record (scheme, record.ELI.rc_fields) + record.ELI.rc_tparams, Record (scheme, record.ELI.rc_fields) in bind scope (unloc name, { tyd_params; tyd_type; tyd_loca; }) @@ -2270,7 +2270,7 @@ module Ty = struct let scope = let decl = EcDecl.{ tyd_params = []; - tyd_type = `Abstract Sp.empty; + tyd_type = Abstract Sp.empty; tyd_loca = `Global; (* FIXME:SUBTYPE *) } in bind scope (unloc subtype.pst_name, decl) in @@ -2365,7 +2365,7 @@ module Ty = struct let asty = let body = ofold (fun p tc -> Sp.add p tc) Sp.empty uptc in { tyd_params = []; - tyd_type = `Abstract body; + tyd_type = Abstract body; tyd_loca = (lc :> locality); } in let scenv = EcEnv.Ty.bind name asty scenv in diff --git a/src/ecSection.ml b/src/ecSection.ml index 51d65680d3..b87cf7b68f 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -437,12 +437,12 @@ and on_typarams (aenv : aenv) typarams = and on_tydecl (aenv : aenv) (tyd : tydecl) = on_typarams aenv tyd.tyd_params; match tyd.tyd_type with - | `Concrete ty -> on_ty aenv ty - | `Abstract s -> on_typeclasses aenv s - | `Record (f, fds) -> + | Concrete ty -> on_ty aenv ty + | Abstract s -> on_typeclasses aenv s + | Record (f, fds) -> on_form aenv f; List.iter (on_ty aenv |- snd) fds - | `Datatype dt -> + | Datatype dt -> List.iter (List.iter (on_ty aenv) |- snd) dt.tydt_ctors; List.iter (on_form aenv) [dt.tydt_schelim; dt.tydt_schcase] @@ -652,7 +652,7 @@ let add_declared_ty to_gen path tydecl = assert (tydecl.tyd_params = []); let s = match tydecl.tyd_type with - | `Abstract s -> s + | Abstract s -> s | _ -> assert false in let name = "'" ^ basename path in @@ -721,14 +721,14 @@ and fv_and_tvar_f f = let tydecl_fv tyd = let fv = match tyd.tyd_type with - | `Concrete ty -> ty_fv_and_tvar ty - | `Abstract _ -> Mid.empty - | `Datatype tydt -> + | Concrete ty -> ty_fv_and_tvar ty + | Abstract _ -> Mid.empty + | Datatype tydt -> List.fold_left (fun fv (_, l) -> List.fold_left (fun fv ty -> EcIdent.fv_union fv (ty_fv_and_tvar ty)) fv l) Mid.empty tydt.tydt_ctors - | `Record (_f, l) -> + | Record (_f, l) -> List.fold_left (fun fv (_, ty) -> EcIdent.fv_union fv (ty_fv_and_tvar ty)) Mid.empty l in List.fold_left (fun fv (id, _) -> Mid.remove id fv) fv tyd.tyd_params @@ -817,9 +817,9 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let tosubst = fst_params, tconstr path args in let tg_subst, tyd_type = match tydecl.tyd_type with - | `Concrete _ | `Abstract _ -> + | Concrete _ | Abstract _ -> EcSubst.add_tydef to_gen.tg_subst path tosubst, tydecl.tyd_type - | `Record (f, prs) -> + | Record (f, prs) -> let subst = EcSubst.empty in let tg_subst = to_gen.tg_subst in let subst = EcSubst.add_tydef subst path tosubst in @@ -836,8 +836,8 @@ let generalize_tydecl to_gen prefix (name, tydecl) = in let prs = List.map add_op prs in let f = EcSubst.subst_form !rsubst f in - !rtg_subst, `Record (f, prs) - | `Datatype dt -> + !rtg_subst, Record (f, prs) + | Datatype dt -> let subst = EcSubst.empty in let tg_subst = to_gen.tg_subst in let subst = EcSubst.add_tydef subst path tosubst in @@ -857,7 +857,7 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let tydt_ctors = List.map add_op dt.tydt_ctors in let tydt_schelim = EcSubst.subst_form !rsubst dt.tydt_schelim in let tydt_schcase = EcSubst.subst_form !rsubst dt.tydt_schcase in - !rtg_subst, `Datatype {tydt_ctors; tydt_schelim; tydt_schcase } + !rtg_subst, Datatype {tydt_ctors; tydt_schelim; tydt_schcase } in @@ -1145,7 +1145,7 @@ let sc_decl_mod (id,mt) = SC_decl_mod (id,mt) (* ---------------------------------------------------------------- *) let is_abstract_ty = function - | `Abstract _ -> true + | Abstract _ -> true | _ -> false (* diff --git a/src/ecSmt.ml b/src/ecSmt.ml index 84ccddd804..c6119dff38 100644 --- a/src/ecSmt.ml +++ b/src/ecSmt.ml @@ -400,16 +400,16 @@ and trans_tydecl genv (p, tydecl) = let ts, opts, decl = match tydecl.tyd_type with - | `Abstract _ -> + | Abstract _ -> let ts = WTy.create_tysymbol pid tparams WTy.NoDef in (ts, [], WDecl.create_ty_decl ts) - | `Concrete ty -> + | Concrete ty -> let ty = trans_ty (genv, lenv) ty in let ts = WTy.create_tysymbol pid tparams (WTy.Alias ty) in (ts, [], WDecl.create_ty_decl ts) - | `Datatype dt -> + | Datatype dt -> let ncs = List.length dt.tydt_ctors in let ts = WTy.create_tysymbol pid tparams WTy.NoDef in @@ -429,7 +429,7 @@ and trans_tydecl genv (p, tydecl) = (ts, opts, WDecl.create_data_decl [ts, wdtype]) - | `Record (_, rc) -> + | Record (_, rc) -> let ts = WTy.create_tysymbol pid tparams WTy.NoDef in Hp.add genv.te_ty p ts; diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 45bdb2f747..33274e240b 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -841,21 +841,21 @@ let subst_genty (s : subst) (tparams, ty) = (* -------------------------------------------------------------------- *) let subst_tydecl_body (s : subst) (tyd : ty_body) = match tyd with - | `Abstract tc -> - `Abstract (subst_typeclass s tc) + | Abstract tc -> + Abstract (subst_typeclass s tc) - | `Concrete ty -> - `Concrete (subst_ty s ty) + | Concrete ty -> + Concrete (subst_ty s ty) - | `Datatype dtype -> + | Datatype dtype -> let dtype = { tydt_ctors = List.map (snd_map (List.map (subst_ty s))) dtype.tydt_ctors; tydt_schelim = subst_form s dtype.tydt_schelim; tydt_schcase = subst_form s dtype.tydt_schcase; } - in `Datatype dtype + in Datatype dtype - | `Record (scheme, fields) -> - `Record (subst_form s scheme, List.map (snd_map (subst_ty s)) fields) + | Record (scheme, fields) -> + Record (subst_form s scheme, List.map (snd_map (subst_ty s)) fields) (* -------------------------------------------------------------------- *) let subst_tydecl (s : subst) (tyd : tydecl) = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 8347cce431..a6af17b164 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -159,16 +159,16 @@ end = struct let rec tybody (hyps : EcEnv.LDecl.hyps) (ty_body1 : ty_body) (ty_body2 : ty_body) = match ty_body1, ty_body2 with - | `Abstract _ , `Abstract _ -> () (* FIXME Sp.t *) - | `Concrete ty1 , `Concrete ty2 -> check (EcReduction.EqTest.for_type (toenv hyps) ty1 ty2) - | `Datatype ty1 , `Datatype ty2 -> for_datatype hyps ty1 ty2 - | `Record rec1, `Record rec2 -> for_record hyps rec1 rec2 + | Abstract _ , Abstract _ -> () (* FIXME Sp.t *) + | Concrete ty1 , Concrete ty2 -> check (EcReduction.EqTest.for_type (toenv hyps) ty1 ty2) + | Datatype ty1 , Datatype ty2 -> for_datatype hyps ty1 ty2 + | Record rec1, Record rec2 -> for_record hyps rec1 rec2 - | _, `Concrete { ty_node = Tconstr (p, tys) } -> + | _, Concrete { ty_node = Tconstr (p, tys) } -> let ty_body2 = get_open_tydecl (toenv hyps) p tys in tybody hyps ty_body1 ty_body2 - | `Concrete{ ty_node = Tconstr (p, tys) }, _ -> + | Concrete{ ty_node = Tconstr (p, tys) }, _ -> let ty_body1 = get_open_tydecl (toenv hyps) p tys in tybody hyps ty_body1 ty_body2 @@ -187,7 +187,7 @@ end = struct let hyps = EcEnv.LDecl.init env params in match ty_body1, ty_body2 with - | `Abstract _, _ -> () (* FIXME Sp.t *) + | Abstract _, _ -> () (* FIXME Sp.t *) | _, _ -> tybody hyps ty_body1 ty_body2 with CoreIncompatible -> raise (Incompatible TyBody) @@ -429,7 +429,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd let ntyd = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in let decl = { tyd_params = nargs; - tyd_type = `Concrete ntyd; + tyd_type = Concrete ntyd; tyd_loca = otyd.tyd_loca; } in (decl, ntyd) @@ -439,7 +439,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | Some reftyd -> let tyargs = List.map (fun (x, _) -> EcTypes.tvar x) reftyd.tyd_params in let body = tconstr p tyargs in - let decl = { reftyd with tyd_type = `Concrete body; } in + let decl = { reftyd with tyd_type = Concrete body; } in (decl, body) | _ -> assert false @@ -449,7 +449,7 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd assert (List.is_empty otyd.tyd_params); let decl = { tyd_params = []; - tyd_type = `Concrete ty; + tyd_type = Concrete ty; tyd_loca = otyd.tyd_loca; } in (decl, ty) @@ -469,9 +469,9 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd let subst = (* FIXME: HACK *) match otyd.tyd_type, body.ty_node with - | `Datatype { tydt_ctors = octors }, Tconstr (np, _) -> begin + | Datatype { tydt_ctors = octors }, Tconstr (np, _) -> begin match (EcEnv.Ty.by_path np env).tyd_type with - | `Datatype { tydt_ctors = _ } -> + | Datatype { tydt_ctors = _ } -> let newtparams = List.fst newtyd.tyd_params in let newtparams_ty = List.map tvar newtparams in let newdtype = tconstr np newtparams_ty in diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 75f594a105..6af2f28e33 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -2720,7 +2720,7 @@ and transinstr match (EcEnv.ty_hnorm ety env).ty_node with | Tconstr (indp, _) -> begin match EcEnv.Ty.by_path indp env with - | { tyd_type = `Datatype dt } -> + | { tyd_type = Datatype dt } -> Some (indp, dt) | _ -> None end @@ -3329,7 +3329,7 @@ and trans_form_or_pattern env mode ?mv ?ps ue pf tt = match (EcEnv.ty_hnorm cfty env).ty_node with | Tconstr (indp, _) -> begin match EcEnv.Ty.by_path indp env with - | { tyd_type = `Datatype dt } -> + | { tyd_type = Datatype dt } -> Some (indp, dt) | _ -> None end From 3bb8264dceffe463bbcf7f60d337310eb9fa9539 Mon Sep 17 00:00:00 2001 From: Lucas Tabary-Maujean Date: Fri, 26 Sep 2025 13:42:06 +0200 Subject: [PATCH 23/26] style: correct spelling of 'instantiate' The spelling 'instanciate' is only acknowledged in the Wiktionary, while all other dictionaries prefer the spelling with a 't'. ex.: https://dictionary.cambridge.org/dictionary/english/instantiate --- src/ecCoreSubst.ml | 2 +- src/ecCoreSubst.mli | 2 +- src/ecDecl.ml | 2 +- src/ecDecl.mli | 2 +- src/ecEnv.ml | 2 +- src/ecEnv.mli | 2 +- src/ecFol.mli | 2 +- src/ecHiInductive.ml | 2 +- src/ecLowGoal.ml | 2 +- src/ecMatching.ml | 2 +- src/ecProofTerm.ml | 4 ++-- src/ecProofTyping.ml | 2 +- src/ecUnify.ml | 4 ++-- src/ecUnify.mli | 2 +- src/phl/ecPhlRwEquiv.ml | 2 +- 15 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/ecCoreSubst.ml b/src/ecCoreSubst.ml index c39a87a278..161d7d3c7a 100644 --- a/src/ecCoreSubst.ml +++ b/src/ecCoreSubst.ml @@ -14,7 +14,7 @@ type mod_extra = { mex_glob : memory -> form; } -type sc_instanciate = { +type sc_instantiate = { sc_memtype : memtype; sc_mempred : mem_pr Mid.t; sc_expr : expr Mid.t; diff --git a/src/ecCoreSubst.mli b/src/ecCoreSubst.mli index 80531ef9c6..f829b8d387 100644 --- a/src/ecCoreSubst.mli +++ b/src/ecCoreSubst.mli @@ -8,7 +8,7 @@ open EcCoreModules open EcCoreFol (* -------------------------------------------------------------------- *) -type sc_instanciate = { +type sc_instantiate = { sc_memtype : memtype; sc_mempred : mem_pr Mid.t; sc_expr : expr Mid.t; diff --git a/src/ecDecl.ml b/src/ecDecl.ml index ed356ac535..bcc414242d 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -68,7 +68,7 @@ let abs_tydecl ?(tc = Sp.empty) ?(params = `Int 0) lc = { tyd_params = params; tyd_type = Abstract tc; tyd_loca = lc; } (* -------------------------------------------------------------------- *) -let ty_instanciate (params : ty_params) (args : ty list) (ty : ty) = +let ty_instantiate (params : ty_params) (args : ty list) (ty : ty) = let subst = CS.Tvar.init (List.map fst params) args in CS.Tvar.subst subst ty diff --git a/src/ecDecl.mli b/src/ecDecl.mli index c7a30b7bdb..a974a60488 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -43,7 +43,7 @@ val tydecl_as_record : tydecl -> (form * (EcSymbols.symbol * EcTypes.ty) list) val abs_tydecl : ?tc:Sp.t -> ?params:ty_pctor -> locality -> tydecl -val ty_instanciate : ty_params -> ty list -> ty -> ty +val ty_instantiate : ty_params -> ty list -> ty -> ty (* -------------------------------------------------------------------- *) type locals = EcIdent.t list diff --git a/src/ecEnv.ml b/src/ecEnv.ml index b9bdd12e15..4490390b99 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2812,7 +2812,7 @@ module Ax = struct let rebind name ax env = MC.bind_axiom name ax env - let instanciate p tys env = + let instantiate p tys env = match by_path_opt p env with | Some ({ ax_spec = f } as ax) -> Tvar.f_subst ~freshen:true (List.map fst ax.ax_tparams) tys f diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 5a1d5bf602..fe21dc2475 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -168,7 +168,7 @@ module Ax : sig val iter : ?name:qsymbol -> (path -> t -> unit) -> env -> unit val all : ?check:(path -> t -> bool) -> ?name:qsymbol -> env -> (path * t) list - val instanciate : path -> EcTypes.ty list -> env -> form + val instantiate : path -> EcTypes.ty list -> env -> form end (* -------------------------------------------------------------------- *) diff --git a/src/ecFol.mli b/src/ecFol.mli index 108bed966d..080a4d3dea 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -116,7 +116,7 @@ val f_ty_app : EcEnv.env -> form -> form list -> form (* -------------------------------------------------------------------- *) (* WARNING : this function should be use only in a context ensuring - * that the quantified variables can be instanciated *) + * that the quantified variables can be instantiated *) val f_betared : form -> form diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index f4946fcf46..88fb3e81b8 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -132,7 +132,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tdecl = EcEnv.Ty.by_path_opt tname env0 |> odfl (EcDecl.abs_tydecl ~params:(`Named tparams) lc) in let tyinst () = - fun ty -> ty_instanciate tdecl.tyd_params targs ty in + fun ty -> ty_instantiate tdecl.tyd_params targs ty in match tdecl.tyd_type with | Abstract _ -> diff --git a/src/ecLowGoal.ml b/src/ecLowGoal.ml index 1e9306ac2d..14e2e72f66 100644 --- a/src/ecLowGoal.ml +++ b/src/ecLowGoal.ml @@ -168,7 +168,7 @@ module LowApply = struct | PTGlobal (p, tys) -> (* FIXME: poor API ==> poor error recovery *) let env = LDecl.toenv (hyps_of_ckenv tc) in - (pt, EcEnv.Ax.instanciate p tys env, subgoals) + (pt, EcEnv.Ax.instantiate p tys env, subgoals) | PTTerm pt -> let pt, ax, subgoals = check_ `Elim pt subgoals tc in diff --git a/src/ecMatching.ml b/src/ecMatching.ml index fe5d6090fe..b84d8d4302 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -915,7 +915,7 @@ let f_match opts hyps (ue, ev) f1 f2 = raise MatchFailure; let clue = try EcUnify.UniEnv.close ue - with EcUnify.UninstanciateUni -> raise MatchFailure + with EcUnify.UninstantiateUni -> raise MatchFailure in (ue, clue, ev) diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 7f3c3d0e16..0f1a19d116 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -193,7 +193,7 @@ let pt_of_hyp_r ptenv x = (* -------------------------------------------------------------------- *) let pt_of_global pf hyps p tys = let ptenv = ptenv_of_penv hyps pf in - let ax = EcEnv.Ax.instanciate p tys (LDecl.toenv hyps) in + let ax = EcEnv.Ax.instantiate p tys (LDecl.toenv hyps) in { ptev_env = ptenv; ptev_pt = ptglobal ~tys p; @@ -202,7 +202,7 @@ let pt_of_global pf hyps p tys = (* -------------------------------------------------------------------- *) let pt_of_global_r ptenv p tys = let env = LDecl.toenv ptenv.pte_hy in - let ax = EcEnv.Ax.instanciate p tys env in + let ax = EcEnv.Ax.instantiate p tys env in { ptev_env = ptenv; ptev_pt = ptglobal ~tys p; diff --git a/src/ecProofTyping.ml b/src/ecProofTyping.ml index abc49d124b..2674da433d 100644 --- a/src/ecProofTyping.ml +++ b/src/ecProofTyping.ml @@ -27,7 +27,7 @@ let process_form_opt ?mv hyps pf oty = let ts = Tuni.subst (EcUnify.UniEnv.close ue) in EcFol.Fsubst.f_subst ts ff - with EcUnify.UninstanciateUni -> + with EcUnify.UninstantiateUni -> EcTyping.tyerror pf.EcLocation.pl_loc (LDecl.toenv hyps) EcTyping.FreeTypeVariables diff --git a/src/ecUnify.ml b/src/ecUnify.ml index e5bb56299d..4664a8a712 100644 --- a/src/ecUnify.ml +++ b/src/ecUnify.ml @@ -14,7 +14,7 @@ module TC = EcTypeClass (* -------------------------------------------------------------------- *) exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * Sp.t] -exception UninstanciateUni +exception UninstantiateUni (* -------------------------------------------------------------------- *) type pb = [ `TyUni of ty * ty | `TcCtt of ty * Sp.t ] @@ -376,7 +376,7 @@ module UniEnv = struct UF.closed (!ue).ue_uf let close (ue : unienv) = - if not (closed ue) then raise UninstanciateUni; + if not (closed ue) then raise UninstantiateUni; (subst_of_uf (!ue).ue_uf) let assubst ue = subst_of_uf (!ue).ue_uf diff --git a/src/ecUnify.mli b/src/ecUnify.mli index 90488fabc4..1f6ed3e45f 100644 --- a/src/ecUnify.mli +++ b/src/ecUnify.mli @@ -7,7 +7,7 @@ open EcDecl (* -------------------------------------------------------------------- *) exception UnificationFailure of [`TyUni of ty * ty | `TcCtt of ty * Sp.t] -exception UninstanciateUni +exception UninstantiateUni type unienv diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index 777b93c165..100d49e72d 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -146,7 +146,7 @@ let process_rewrite_equiv info tc = let res = omap (fun v -> EcTyping.transexpcast subenv `InProc ue ret_ty v) pres in let es = e_subst (Tuni.subst (EcUnify.UniEnv.close ue)) in Some (List.map es args, omap (EcModules.lv_of_expr |- es) res) - with EcUnify.UninstanciateUni -> + with EcUnify.UninstantiateUni -> EcTyping.tyerror (loc pargs) env EcTyping.FreeTypeVariables end in From 3f28c2e67e0cd17a0b9eada26431313aa4d2aaab Mon Sep 17 00:00:00 2001 From: Lucas Tabary-Maujean Date: Fri, 19 Sep 2025 17:44:42 +0200 Subject: [PATCH 24/26] feat: positivity check in type constructors with stack-based error reports fix: perform positivity check in type arguments of type constructors test: add a simple test file for positivity checking. --- src/ecHiInductive.ml | 21 +++--- src/ecHiInductive.mli | 2 +- src/ecInductive.ml | 127 +++++++++++++++++++++++++++++++---- src/ecInductive.mli | 20 +++++- src/ecScope.ml | 17 +++-- src/ecTypes.ml | 6 ++ src/ecTypes.mli | 2 + src/ecUserMessages.ml | 36 +++++++++- tests/positivity_checking.ec | 40 +++++++++++ 9 files changed, 238 insertions(+), 33 deletions(-) create mode 100644 tests/positivity_checking.ec diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index 88fb3e81b8..72cf50e85b 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -23,7 +23,7 @@ type dterror = | DTE_TypeError of TT.tyerror | DTE_DuplicatedCtor of symbol | DTE_InvalidCTorType of symbol * TT.tyerror -| DTE_NonPositive +| DTE_NonPositive of symbol * EI.non_positive_context | DTE_Empty type fxerror = @@ -52,7 +52,7 @@ let trans_record (env : EcEnv.env) (name : ptydname) (rc : precord) = Msym.odup unloc (List.map fst rc) |> oiter (fun (x, y) -> rcerror y.pl_loc env (RCE_DuplicatedField x.pl_desc)); - (* Check for emptyness *) + (* Check for emptiness *) if List.is_empty rc then rcerror loc env RCE_Empty; @@ -106,7 +106,7 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = dt |> List.map for1 in - (* Check for emptyness *) + (* Check for emptiness *) begin let rec isempty_n (ctors : (ty list) list) = List.for_all isempty_1 ctors @@ -131,21 +131,24 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tdecl = EcEnv.Ty.by_path_opt tname env0 |> odfl (EcDecl.abs_tydecl ~params:(`Named tparams) lc) in - let tyinst () = - fun ty -> ty_instantiate tdecl.tyd_params targs ty in + let tyinst = ty_instantiate tdecl.tyd_params targs in match tdecl.tyd_type with | Abstract _ -> - List.exists isempty (targs) + List.exists isempty targs | Concrete ty -> - isempty_1 [tyinst () ty] + isempty_1 [ tyinst ty ] | Record (_, fields) -> - isempty_1 (List.map (tyinst () |- snd) fields) + isempty_1 (List.map (tyinst |- snd) fields) | Datatype dt -> - isempty_n (List.map (List.map (tyinst ()) |- snd) dt.tydt_ctors) + (* FIXME: Inspecting all constructors recursively causes + non-termination in some cases. One can have the same + limitation as is done for positivity in order to limit this + unfolding to well-behaved cases. *) + isempty_n (List.map (List.map tyinst |- snd) dt.tydt_ctors) in diff --git a/src/ecHiInductive.mli b/src/ecHiInductive.mli index 32fd116458..1db4bd0117 100644 --- a/src/ecHiInductive.mli +++ b/src/ecHiInductive.mli @@ -16,7 +16,7 @@ type dterror = | DTE_TypeError of EcTyping.tyerror | DTE_DuplicatedCtor of symbol | DTE_InvalidCTorType of symbol * EcTyping.tyerror -| DTE_NonPositive +| DTE_NonPositive of symbol * non_positive_context | DTE_Empty type fxerror = diff --git a/src/ecInductive.ml b/src/ecInductive.ml index a873688f4d..f21f3003c7 100644 --- a/src/ecInductive.ml +++ b/src/ecInductive.ml @@ -83,10 +83,120 @@ let datatype_ind_path (mode : indmode) (p : EcPath.path) = EcPath.pqoname (EcPath.prefix p) name (* -------------------------------------------------------------------- *) -exception NonPositive - -let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = - let normty = odfl (identity : ty -> ty) normty in +type non_positive_intype = Concrete | Record of symbol | Variant of symbol + +type non_positive_description = + | InType of EcIdent.ident option * non_positive_intype + | NonPositiveOcc of ty + | AbstractTypeRestriction + | TypePositionRestriction of ty + +type non_positive_context = (symbol * non_positive_description) list + +exception NonPositive of non_positive_context + +let with_context ?ident p ctx f = + try f () with NonPositive l -> raise (NonPositive ((EP.basename p, InType (ident, ctx)) :: l)) + +let non_positive (p : EP.path) ctx = raise (NonPositive [(EP.basename p, ctx)]) +let non_positive' (s : EcIdent.ident) ctx = raise (NonPositive [(s.id_symb, ctx)]) + +(** below, [fct] designates the function that takes a path to a type constructor + and returns the corresponding type declaration *) + +(** Strict positivity enforces the following, for every variant of the datatype p: + - for each subterm (a → b), p ∉ fv(a); + - inductive occurences a₁ a₂ .. aₙ p are such that ∀i. p ∉ fv(aᵢ) + + Crucially, this has to be checked whenever p occurs in an instance of + another type constructor. + + FIXME: The current implementation prohibits the use of a type which changes + its type arguments like e.g. + {v + type ('a, 'b) t = [ + | Elt of 'a + | Swap of ('b, 'a) t + ]. + v} + to be used in some places while defining another inductive type. *) + +let rec occurs ?(normty = identity) p t = + match (normty t).ty_node with + | Tconstr (p', _) when EcPath.p_equal p p' -> true + | _ -> EcTypes.ty_sub_exists (occurs p) t + +(** Tests whether the first list is a list of type variables, matching the + identifiers of the second list. *) +let ty_params_compat = + List.for_all2 (fun ty (param_id, _) -> + match ty.ty_node with + | Tvar id -> EcIdent.id_equal id param_id + | _ -> false) + +(** Ensures all occurrences of type variable [ident] are positive in type + declaration [decl] (with name [p]). + This function provide error context in case the check fails. *) +let rec check_positivity_in_decl fct p decl ident = + let check x () = check_positivity_ident fct p decl.tyd_params ident x + and iter l f = List.iter f l in + + match decl.tyd_type with + | Concrete ty -> with_context ~ident p Concrete (check ty) + | Abstract _ -> non_positive p AbstractTypeRestriction + | Datatype { tydt_ctors } -> + iter tydt_ctors @@ fun (name, argty) -> + iter argty @@ fun ty -> + with_context ~ident p (Variant name) (check ty) + | Record (_, tys) -> + iter tys @@ fun (name, ty) -> + with_context ~ident p (Record name) (check ty) + +(** Ensures all occurrences of type variable [ident] are positive in type [ty] *) +and check_positivity_ident fct p params ident ty = + match ty.ty_node with + | Tglob _ | Tunivar _ | Tvar _ -> () + | Ttuple tys -> List.iter (check_positivity_ident fct p params ident) tys + | Tconstr (q, args) when EcPath.p_equal q p -> + if not (ty_params_compat args params) then + non_positive p (TypePositionRestriction ty) + | Tconstr (q, args) -> + let decl = fct q in + List.iter (check_positivity_ident fct p params ident) args; + List.combine args decl.tyd_params + |> List.filter_map (fun (arg, (ident', _)) -> + if EcTypes.var_mem ident arg then Some ident' else None) + |> List.iter (check_positivity_in_decl fct q decl) + | Tfun (from, to_) -> + if EcTypes.var_mem ident from then non_positive' ident (NonPositiveOcc ty); + check_positivity_ident fct p params ident to_ + +(** Ensures all occurrences of path [p] are positive in type [ty] *) +let rec check_positivity_path fct p ty = + match ty.ty_node with + | Tglob _ | Tunivar _ | Tvar _ -> () + | Ttuple tys -> List.iter (check_positivity_path fct p) tys + | Tconstr (q, args) when EcPath.p_equal q p -> + if List.exists (occurs p) args then non_positive p (NonPositiveOcc ty) + | Tconstr (q, args) -> + let decl = fct q in + List.iter (check_positivity_path fct p) args; + List.combine args decl.tyd_params + |> List.filter_map (fun (arg, (ident, _)) -> + if occurs p arg then Some ident else None) + |> List.iter (check_positivity_in_decl fct q decl) + | Tfun (from, to_) -> + if occurs p from then non_positive p (NonPositiveOcc ty); + check_positivity_path fct p to_ + +let check_positivity fct dt = + let check ty () = check_positivity_path fct dt.dt_path ty + and iter l f = List.iter f l in + iter dt.dt_ctors @@ fun (name, argty) -> + iter argty @@ fun ty -> + with_context dt.dt_path (Variant name) (check ty) + +let indsc_of_datatype ?(normty = identity) (mode : indmode) (dt : datatype) = let tpath = dt.dt_path in let rec scheme1 p (pred, fac) ty = @@ -103,13 +213,11 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = | scs -> Some (FL.f_let (LTuple xs) fac (FL.f_ands scs)) end - | Tconstr (p', ts) -> - if List.exists (occurs p) ts then raise NonPositive; + | Tconstr (p', _) -> if not (EcPath.p_equal p p') then None else Some (FL.f_app pred [fac] tbool) | Tfun (ty1, ty2) -> - if occurs p ty1 then raise NonPositive; let x = fresh_id_of_ty ty1 in scheme1 p (pred, FL.f_app fac [FL.f_local x ty1] ty2) ty2 |> omap (FL.f_forall [x, GTty ty1]) @@ -152,11 +260,6 @@ let indsc_of_datatype ?normty (mode : indmode) (dt : datatype) = let form = FL.f_forall [predx, GTty predty] form in form - and occurs p t = - match (normty t).ty_node with - | Tconstr (p', _) when EcPath.p_equal p p' -> true - | _ -> EcTypes.ty_sub_exists (occurs p) t - in scheme mode (List.map fst dt.dt_tparams, tpath) dt.dt_ctors (* -------------------------------------------------------------------- *) diff --git a/src/ecInductive.mli b/src/ecInductive.mli index 2b1c5a97c5..32d9cd4b0a 100644 --- a/src/ecInductive.mli +++ b/src/ecInductive.mli @@ -43,7 +43,25 @@ val datatype_proj_name : symbol -> symbol val datatype_proj_path : path -> symbol -> path (* -------------------------------------------------------------------- *) -exception NonPositive +type non_positive_intype = Concrete | Record of symbol | Variant of symbol + +type non_positive_description = + | InType of EcIdent.ident option * non_positive_intype + | NonPositiveOcc of ty + | AbstractTypeRestriction + | TypePositionRestriction of ty + +type non_positive_context = (symbol * non_positive_description) list + +exception NonPositive of non_positive_context + +val check_positivity : (path -> tydecl) -> datatype -> unit +(** Evaluates whether a given datatype protype satisfies the strict + positivity check. The first argument defines how to retrieve the + effective definition of a type constructor from its path. + + raises the exception [NonPositive] if the check fails, otherwise + the function returns a unit value. *) val indsc_of_datatype : ?normty:(ty -> ty) -> [`Elim|`Case] -> datatype -> form diff --git a/src/ecScope.ml b/src/ecScope.ml index 1ca3e4e21d..1ab346c66f 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2246,13 +2246,16 @@ module Ty = struct let body = transty tp_tydecl env ue bd in EcUnify.UniEnv.tparams ue, Concrete body - | PTYD_Datatype dt -> - let datatype = EHI.trans_datatype env (mk_loc loc (args,name)) dt in - let tparams, tydt = - try ELI.datatype_as_ty_dtype datatype - with ELI.NonPositive -> EHI.dterror loc env EHI.DTE_NonPositive - in - tparams, Datatype tydt + | PTYD_Datatype dt -> ( + let datatype = EHI.trans_datatype env (mk_loc loc (args, name)) dt in + let ty_from_ctor ctor = EcEnv.Ty.by_path ctor env in + try + ELI.check_positivity ty_from_ctor datatype; + let tparams, tydt = ELI.datatype_as_ty_dtype datatype in + (tparams, Datatype tydt) + with ELI.NonPositive ctx -> + let symbol = basename datatype.dt_path in + EHI.dterror loc env (EHI.DTE_NonPositive (symbol, ctx))) | PTYD_Record rt -> let record = EHI.trans_record env (mk_loc loc (args,name)) rt in diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 87efc57bee..bebd2087e2 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -154,6 +154,12 @@ let rec ty_check_uni t = | Tunivar _ -> raise FoundUnivar | _ -> ty_iter ty_check_uni t +let rec var_mem ?(check_glob = false) id t = + match t.ty_node with + | Tvar id' -> EcIdent.id_equal id id' + | Tglob id' when check_glob -> EcIdent.id_equal id id' + | _ -> ty_sub_exists (var_mem ~check_glob id) t + (* -------------------------------------------------------------------- *) let symbol_of_ty (ty : ty) = match ty.ty_node with diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 34b7b4cbf2..95ee26bb3c 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -79,6 +79,8 @@ val ty_sub_exists : (ty -> bool) -> ty -> bool val ty_fold : ('a -> ty -> 'a) -> 'a -> ty -> 'a val ty_iter : (ty -> unit) -> ty -> unit +val var_mem : ?check_glob:bool -> EcIdent.t -> ty -> bool + (* -------------------------------------------------------------------- *) val symbol_of_ty : ty -> string val fresh_id_of_ty : ty -> EcIdent.t diff --git a/src/ecUserMessages.ml b/src/ecUserMessages.ml index 9c947c1b6c..249cfb5209 100644 --- a/src/ecUserMessages.ml +++ b/src/ecUserMessages.ml @@ -573,6 +573,7 @@ module InductiveError : sig val pp_fxerror : env -> Format.formatter -> fxerror -> unit end = struct open EcHiInductive + open EcInductive open TypingError let pp_rcerror env fmt error = @@ -591,8 +592,38 @@ end = struct | RCE_Empty -> msg "this record type is empty" + let format_intype fmt p (tyvar, ctx) = + (match ctx with + | Concrete -> Format.fprintf fmt "... in type %s" p + | Record s -> Format.fprintf fmt "... in record field %s of type %s" s p + | Variant s -> Format.fprintf fmt "... in variant %s of type %s" s p); + let subty tyvar = + Format.fprintf fmt " (in an instance of type variable %a)" + EcIdent.pp_ident tyvar + in + Option.iter subty tyvar + +let format_context pp fmt (p, ctx) = match ctx with + | InType (tyvar, ctx) -> format_intype fmt p (tyvar, ctx) + | NonPositiveOcc ty -> + Format.fprintf fmt "non-positive occurrence of %s in type %a" + p (EcPrinting.pp_type pp) ty + | AbstractTypeRestriction -> + Format.fprintf fmt "unauthorised abstract type constructor %s" p + | TypePositionRestriction ty -> + Format.fprintf fmt + "recursive occurrence %a in the definition of %s has different \ + arguments, which is not allowed." + (EcPrinting.pp_type pp) ty p + +let format_context_list p l pp fmt = + Format.fprintf fmt "Could not verify strict positivity of type %s:@.@;<0 2>@[" p; + Format.pp_print_list (format_context pp) fmt l; + Format.fprintf fmt "@;@]" + let pp_dterror env fmt error = let msg x = Format.fprintf fmt x in + let env1 = EcPrinting.PPEnv.ofenv env in match error with | DTE_TypeError ee -> @@ -605,12 +636,11 @@ end = struct msg "invalid constructor type: `%s`: %a'" name (pp_tyerror env) ee - | DTE_NonPositive -> - msg "the datatype does not respect the positivity condition" - | DTE_Empty -> msg "the datatype may be empty" + | DTE_NonPositive (s, ctx) -> format_context_list s ctx env1 fmt + let pp_fxerror env fmt error = match error with | FXLowError ee -> diff --git a/tests/positivity_checking.ec b/tests/positivity_checking.ec new file mode 100644 index 0000000000..d50d815bfc --- /dev/null +++ b/tests/positivity_checking.ec @@ -0,0 +1,40 @@ +(* Simple type *) +type 'a list = [ Nil | Cons of 'a & 'a list ]. + +type 'a tree = [ + | Leaf + (* Recursive occurrence within a pre-existing type constructor *) + | Node of 'a tree list + (* Positive occurrence in a function *) + | Fun of (bool -> 'a tree) +]. + +theory Bad. +type ('a, 'b) permlist = [ + | N of ('a -> 'b) (* Aaaaah *) + | C of 'a & ('a, 'b) permlist + | P of ('b, 'a) permlist +]. + +fail type posrej = [ A | B of (bool, posrej) permlist ]. +end Bad. + +theory Good. +type ('a, 'b) permlist = [ + | N (* No problem *) + | C of 'a & ('a, 'b) permlist + | P of ('b, 'a) permlist list (* For the sake of nesting in a list *) +]. + +(* this type fails because of the same limitation, + even though it is in fact strictly positive. *) +fail type posrej = [ A | B of (bool, posrej) permlist ]. +end Good. + +type ('a, 'b) arr = 'a -> 'b. +type ('a, 'b) orr = ('a, 'b) arr. +fail type 'a u = [ S | U of ('a u, bool) orr ]. + +type 'a t. +fail type tt = [ N | T of tt t ]. +fail type 'a tt = [ N | T of 'a tt tt]. From 4a5231c2a3266811b611a380e3a89470149de877 Mon Sep 17 00:00:00 2001 From: Benjamin Gregoire Date: Fri, 23 Jan 2026 18:58:03 +0100 Subject: [PATCH 25/26] fix alpha-conversion problems in ehoare --- src/phl/ecPhlApp.ml | 7 ++++--- src/phl/ecPhlConseq.ml | 6 ++++++ src/phl/ecPhlDeno.ml | 3 ++- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/src/phl/ecPhlApp.ml b/src/phl/ecPhlApp.ml index 4ebf52413e..2d2ea618b7 100644 --- a/src/phl/ecPhlApp.ml +++ b/src/phl/ecPhlApp.ml @@ -26,12 +26,13 @@ let t_hoare_app_r i phi tc = let t_hoare_app = FApi.t_low2 "hoare-app" t_hoare_app_r (* -------------------------------------------------------------------- *) -let t_ehoare_app_r i f tc = +let t_ehoare_app_r i phi tc = let env = FApi.tc1_env tc in let hs = tc1_as_ehoareS tc in let s1, s2 = s_split env i hs.ehs_s in - let a = f_eHoareS (snd hs.ehs_m) (ehs_pr hs) (stmt s1) f in - let b = f_eHoareS (snd hs.ehs_m) f (stmt s2) (ehs_po hs) in + let phi = ss_inv_rebind phi (fst hs.ehs_m) in + let a = f_eHoareS (snd hs.ehs_m) (ehs_pr hs) (stmt s1) phi in + let b = f_eHoareS (snd hs.ehs_m) phi (stmt s2) (ehs_po hs) in FApi.xmutate1 tc `HlApp [a; b] let t_ehoare_app = FApi.t_low2 "hoare-app" t_ehoare_app_r diff --git a/src/phl/ecPhlConseq.ml b/src/phl/ecPhlConseq.ml index d4631bfe6f..97bdfb2dfa 100644 --- a/src/phl/ecPhlConseq.ml +++ b/src/phl/ecPhlConseq.ml @@ -453,6 +453,9 @@ let t_bdHoareS_conseq_nm = gen_conseq_nm t_bdHoareS_notmod t_bdHoareS_conseq let t_ehoareF_concave (fc: ss_inv) pre post tc = let env = FApi.tc1_env tc in let hf = tc1_as_ehoareF tc in + let pre = ss_inv_rebind pre hf.ehf_m in + let post = ss_inv_rebind post hf.ehf_m in + let fc = ss_inv_rebind fc hf.ehf_m in let f = hf.ehf_f in let mpr,mpo = Fun.hoareF_memenv hf.ehf_m f env in let fsig = (Fun.by_xpath f env).f_sig in @@ -491,6 +494,9 @@ let t_ehoareS_concave (fc: ss_inv) (* xreal -> xreal *) pre post tc = let hs = tc1_as_ehoareS tc in let s = hs.ehs_s in let m = fst hs.ehs_m in + let pre = ss_inv_rebind pre m in + let post = ss_inv_rebind post m in + let fc = ss_inv_rebind fc m in (* ensure that f only depend of notmod *) let modi = s_write env s in let fv = PV.fv env m fc.inv in diff --git a/src/phl/ecPhlDeno.ml b/src/phl/ecPhlDeno.ml index 4ea1b7d6cd..544e6f3086 100644 --- a/src/phl/ecPhlDeno.ml +++ b/src/phl/ecPhlDeno.ml @@ -86,8 +86,8 @@ let t_phoare_deno_r pre post tc = (* -------------------------------------------------------------------- *) let t_ehoare_deno_r pre post tc = - assert (pre.m = post.m); let m = pre.m in + assert (m = post.m); let env, _, concl = FApi.tc1_eflat tc in let f, bd = @@ -111,6 +111,7 @@ let t_ehoare_deno_r pre post tc = (* forall m, ev%r%xr <= post *) let ev = pr.pr_event in + let ev = ss_inv_rebind ev m in let concl_po = map_ss_inv2 f_xreal_le (map_ss_inv1 f_b2xr ev) post in let concl_po = f_forall_mems_ss_inv mpo concl_po in From 7a76e83791f8b41c5348e5053bb63e8f96552ffe Mon Sep 17 00:00:00 2001 From: Xingyu Xie Date: Mon, 1 Dec 2025 17:35:29 +0100 Subject: [PATCH 26/26] another example for eHoare --- examples/ehoare/random_boolean_matrix.ec | 207 +++++++++++++++++++++++ theories/datatypes/Xreal.ec | 13 +- 2 files changed, 219 insertions(+), 1 deletion(-) create mode 100644 examples/ehoare/random_boolean_matrix.ec diff --git a/examples/ehoare/random_boolean_matrix.ec b/examples/ehoare/random_boolean_matrix.ec new file mode 100644 index 0000000000..512e47ee48 --- /dev/null +++ b/examples/ehoare/random_boolean_matrix.ec @@ -0,0 +1,207 @@ +require import AllCore Array Real RealExp List. +(*---*) import RField. +require import Distr DBool Xreal. +(*---*) import Biased. +require import StdOrder. +(*---*) import RealOrder. + +(* uniformly sampling a 2-d boolean array of size n x m *) +module M = { + proc sample (n : int, m : int, a : bool array) : (bool array) = { + var i, j : int; + var b : bool; + i <- 0; + while (i < n) { + j <- 0; + while (j < m) { + b <$ dbiased 0.5; + a.[i * m + j] <- b; + j <- j + 1; + } + i <- i + 1; + } + return a; + } +}. + +op outer_shape_pred (i n m : int) (a a' : bool array) = + 0 <= i <= n + /\ 0 <= m + /\ size a = n * m + /\ size a = size a'. + +op shape_pred (i j n m : int) (a a' : bool array) = + 0 <= i < n + /\ 0 <= j <= m + /\ size a = n * m + /\ size a = size a'. + +op row_eq_upto (i m : int) (a1 a2 : bool array) = + forall (i' j' : int), + 0 <= i' < i + => 0 <= j' < m + => a1.[i' * m + j'] = a2.[i' * m + j']. + +op cell_eq_upto (i j m : int) (a1 a2 : bool array) = + forall (j' : int), + 0 <= j' < j + => a1.[i * m + j'] = a2.[i * m + j']. + +lemma row_eq_upto_increase (i m : int) (a1 a2 : bool array): + 0 <= i + => (row_eq_upto i m a1 a2 /\ cell_eq_upto i m m a1 a2 + <=> row_eq_upto (i + 1) m a1 a2). +proof. +move => ? @/row_eq_upto @/cell_eq_upto; split. +- move => ? i' j' *. + by case: (i' < i) => /#. +- move => H; split. + - move => i' j' ??. + have ?: 0 <= i' < i + 1 by smt(). + by have := H i' j' _ _ => //. + - by have := H i => /#. +qed. + +lemma cell_eq_upto_false (i j' j m : int) (a1 a2 : bool array) : + 0 <= j' < j + => a1.[i * m + j'] <> a2.[i * m + j'] + => cell_eq_upto i j m a1 a2 = false. +proof. by smt(). qed. + +lemma cell_eq_upto_split (i j m : int) (a1 a2 : bool array) : + 0 <= j < m + => (cell_eq_upto i (j + 1) m a1 a2 + <=> (cell_eq_upto i j m a1 a2 + /\ a1.[i * m + j] = a2.[i * m + j]) + ). +proof. +move => ? @/cell_eq_upto; split. +- move => H; split. + - move => j' ?. + have ?: 0 <= j' < j + 1 by smt(). + have := H j' _ => //. + - by smt(). +- move => ? j' ?. + by case (j' < j) => /#. +qed. + +lemma row_eq_upto_unrelated_set (i m x : int) (v : bool) (a1 a2 : bool array): + i * m <= x < size a1 + => (row_eq_upto i m a1 a2 <=> row_eq_upto i m a1.[x <- v] a2). +proof. +move => ? @/row_eq_upto; split. +- move => ? i' j' ??. + rewrite get_set 1:/#. + have -> /=: !(i' * m + j' = x) by smt(). + by smt(). +- move => ? i' j' ??. + by rewrite (_: a1.[_] = a1.[x <- v].[i' * m + j']) 1:get_set /#. +qed. + +lemma cell_eq_upto_unrelated_set (i j m x : int) (v : bool) (a1 a2 : bool array) : + 0 <= i /\ 0 <= j < m /\ i * m + j <= x < size a1 + => (cell_eq_upto i j m a1 a2 <=> cell_eq_upto i j m a1.[x <- v] a2). +proof. +move => [#] ????? @/cell_eq_upto; split. +- move => ? j' ?. + rewrite get_set 1:/#. + have -> /=: !(i * m + j' = x) by smt(). + by smt(). +- move => ? j' ?. + by rewrite (_: a1.[_] = a1.[x <- v].[i * m + j']) 1:get_set /#. +qed. + +(* The probability of every possible boolean matrix of size n x m is no more than 2 ^ -(n * m) *) +lemma L: + forall (a0 : bool array), + ehoare [M.sample : + (0 <= arg.`1 + /\ 0 <= arg.`2 + /\ size arg.`3 = arg.`1 * arg.`2 + /\ size arg.`3 = size a0) + `|` (1%r / (2%r ^ (n * m)))%xr ==> (res = a0)%xr]. +proof. +move => a0. +proc. +while ((0 <= i <= n + /\ 0 <= m + /\ size a = n * m + /\ size a0 = size a) + `|` (2%r ^ ((-(n - i) * m)%r))%xr + * (row_eq_upto i m a a0)%xr). +(* !cond => inv => pos_f <= inv_f *) ++ move => &hr. + apply xle_cxr_r => ?. + apply xle_cxr_r => ?. + have ->: n{hr} - i{hr} = 0 by smt(). + rewrite Ring.IntID.mul0r Ring.IntID.oppr0 rpow0 mul1m_simpl. + apply xle_rle; split => * ; 1: by smt(). + exact le_b2r. +(* {cond /\ inv | inv_f} c {inv | inv_f} *) ++ wp. + while (( 0 <= i < n + /\ 0 <= j <= m + /\ size a = n * m + /\ size a = size a0) + `|` (2%r ^ ((-((n - i) * m - j))%r))%xr + * (row_eq_upto i m a a0 /\ cell_eq_upto i j m a a0)%xr). + (* !cond => inv => pos_f <= inv_f *) + + move => &hr />. + rewrite xle_cxr_r => *. + rewrite xle_cxr_l => *. + + by smt(). + + rewrite (_: - _ * m{hr} = - ((n{hr} - i{hr}) * m{hr} - j{hr})) //= 1:/#. + rewrite (_: j{hr} = m{hr}) 1:/#. + rewrite -row_eq_upto_increase 1:/#. + rewrite ler_eqVlt; left; reflexivity. + (* {cond /\ inv | inv_f} c {inv | inv_f} *) + + wp; skip => /> &hr. + rewrite xle_cxr_r => [#] 5? Hsize *. + rewrite Ep_dbiased /= 1:/#. + have-> /=: 0 <= i{hr} < n{hr} by smt(). + have-> /=: 0 <= j{hr} + 1 <= m{hr} by smt(). + rewrite !size_set !Hsize /=. + have-> /=: n{hr} * m{hr} = size a0 by smt(). + rewrite !to_pos_pos 1,2,3,4,5:#smt:(rpow_gt0 b2r_ge0). + rewrite !cell_eq_upto_split 1,2:/#. + rewrite !get_set //=. + - split; 1: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + - split; 1: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + case (a0.[i{hr} * m{hr} + j{hr}]) => Hcase /=. + + rewrite -row_eq_upto_unrelated_set. + - split; 1: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + rewrite -cell_eq_upto_unrelated_set. + - do! split; 1,2,3: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + rewrite -{2}(rpow1 2%r) // -rpowN // -mulrA. + rewrite (mulrC (b2r _) (2%r ^ - 1%r)). + by rewrite mulrA -rpowD // /#. + + rewrite /= -row_eq_upto_unrelated_set. + - split; 1: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + rewrite -cell_eq_upto_unrelated_set. + - do! split; 1,2,3: by smt(). + move => ?. + by apply (IntOrder.ltr_le_trans ((n{hr} - 1) * m{hr} + m{hr})) => /#. + rewrite -{2}(rpow1 2%r) // -rpowN // -mulrA. + rewrite (mulrC (b2r _) (2%r ^ - 1%r)). + by rewrite mulrA -rpowD // /#. + (* pre => inv *) + + wp; skip => &hr />. + rewrite xle_cxr_r => [#] *. + rewrite xle_cxr_l 1:/#. + have-> //: cell_eq_upto i{hr} 0 m{hr} a{hr} a0 by smt(). +auto => /> &hr. +rewrite xle_cxr_r => [#] *. +rewrite xle_cxr_l 1:/#. +rewrite fromintN rpowN //= rpow_int //=. +by have-> //: row_eq_upto 0 m{hr} a{hr} a0 by smt(). +qed. diff --git a/theories/datatypes/Xreal.ec b/theories/datatypes/Xreal.ec index a395b40172..026327f55e 100644 --- a/theories/datatypes/Xreal.ec +++ b/theories/datatypes/Xreal.ec @@ -1,7 +1,7 @@ require import AllCore RealSeries List Distr StdBigop DBool DInterval. require import StdOrder. require Subtype Bigop. -import Bigreal Bigint RealOrder. +import Bigreal Bigint RealOrder Biased. (* -------------------------------------------------------------------- *) (* Definition of R+ *) @@ -399,6 +399,9 @@ proof. case: x y => [x|] [y|] //=; smt(@Rp). qed. lemma xle_add_l x y : x <= y + x. proof. rewrite addmC xle_add_r. qed. +lemma xle_rle (x y : real) : 0%r <= x <= y => x%xr <= y%xr. +proof. by move => [??] /=; rewrite !to_pos_pos // &(ler_trans x). qed. + lemma xler_add2r (x:realp) (y z : xreal) : y + x%xr <= z + x%xr <=> y <= z. proof. case: z => // z; case: y => //= y; smt(@Rp). qed. @@ -963,6 +966,14 @@ proof. by rewrite big_consT big_seq1 /= !dbool1E. qed. +lemma Ep_dbiased (p : real) (f : bool -> xreal) : + 0%r <= p <= 1%r => Ep (dbiased p) f = p ** f true + (1%r - p) ** f false. +proof. + move => ?. + rewrite (Ep_fin [true; false]) //; 1: by case. + by rewrite /BXA.big /predT /= !dbiased1E /= !clamp_id //. +qed. + (* -------------------------------------------------------------------- *) lemma Ep_dinterval (f : int -> xreal) i j: Ep [i..j] f =