diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml
new file mode 100644
index 000000000..43a02784d
--- /dev/null
+++ b/.github/workflows/docs.yml
@@ -0,0 +1,112 @@
+name: Build documentation
+
+on:
+ push:
+ branches:
+ - "main"
+ pull_request:
+
+permissions:
+ contents: read
+ pages: write
+ id-token: write
+
+concurrency:
+ group: "refman"
+ cancel-in-progress: false
+
+jobs:
+ build:
+ runs-on: ubuntu-latest
+
+ 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'
+
+ 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/INSTALL.md b/INSTALL.md
index a9808fe4f..99a9a91de 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 000000000..e69de29bb
diff --git a/assets/styles/styles.css b/assets/styles/styles.css
new file mode 100644
index 000000000..e3bdc9944
--- /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/doc/.gitignore b/doc/.gitignore
new file mode 100644
index 000000000..88503a8c6
--- /dev/null
+++ b/doc/.gitignore
@@ -0,0 +1,2 @@
+__pycache__/
+_build/
diff --git a/doc/Makefile b/doc/Makefile
new file mode 100644
index 000000000..bb8b8c368
--- /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 000000000..e69de29bb
diff --git a/doc/conf.py b/doc/conf.py
new file mode 100644
index 000000000..5ba1204ea
--- /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 000000000..6efe0f445
--- /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 000000000..3d2bc6269
--- /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 000000000..4680cd7c9
--- /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 000000000..61cbf24b4
--- /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 000000000..414e0110a
--- /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 000000000..900f7747b
--- /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 000000000..421434db0
--- /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 000000000..cea082ad0
--- /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 000000000..e645807e5
--- /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 = `
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
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 000000000..7fb05381b
--- /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 000000000..732013b9b
--- /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 000000000..8b6c7d9b2
--- /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 000000000..012938edf
--- /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 000000000..a496b96f3
--- /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 000000000..5b954bbad
--- /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 000000000..6c3ff2a44
--- /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.
diff --git a/dune b/dune
index e19b69c5a..7c8edf709 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 b285ee175..85f142616 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 47ea3eb08..08bdb40ea 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/PRG.ec b/examples/PRG.ec
index f32ddf910..870a3ce0e 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 2450f14fb..e7b3c0983 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/examples/docgen/docgenbasic.ec b/examples/docgen/docgenbasic.ec
new file mode 100644
index 000000000..691efa23e
--- /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/examples/ehoare/random_boolean_matrix.ec b/examples/ehoare/random_boolean_matrix.ec
new file mode 100644
index 000000000..512e47ee4
--- /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/scripts/docker/Dockerfile.base b/scripts/docker/Dockerfile.base
index b8aff9ce1..1a43903b0 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.formosa b/scripts/docker/Dockerfile.formosa
new file mode 100644
index 000000000..8ff376734
--- /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
diff --git a/scripts/docker/Dockerfile.test b/scripts/docker/Dockerfile.test
index f8dcd165d..2e9522d3a 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/*
diff --git a/src/dune b/src/dune
index d3e809314..487e9cfcf 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 -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)))
+
(include_subdirs unqualified)
(generate_sites_module
@@ -15,7 +16,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
@@ -30,4 +31,4 @@
(menhir
(modules ecParser)
(explain true)
- (flags --table))
+ (flags --table --unused-token COMMENT))
diff --git a/src/ec.ml b/src/ec.ml
index d61bd4329..627d25b81 100644
--- a/src/ec.ml
+++ b/src/ec.ml
@@ -407,13 +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;
+ (*---*) 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 =
@@ -467,7 +490,10 @@ let main () =
; terminal = terminal
; interactive = true
; eco = false
- ; gccompact = None }
+ ; gccompact = None
+ ; docgen = false
+ ; outdirp = None
+ ; trace = None }
end
@@ -489,18 +515,66 @@ 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
; interactive = false
; eco = cmpopts.cmpo_noeco
- ; gccompact = cmpopts.cmpo_compact }
+ ; gccompact = cmpopts.cmpo_compact
+ ; docgen = false
+ ; outdirp = None
+ ; trace = trace0 }
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
+ ; trace = None }
+ end
+
in
(match state.input with
@@ -511,9 +585,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
@@ -525,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;
@@ -538,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
@@ -606,15 +695,23 @@ 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 ->
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;
@@ -633,8 +730,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 ->
@@ -642,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 ~timed ~break p.EP.gl_action in
+ 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"))
@@ -661,20 +776,24 @@ 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)
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 +808,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 f2da6001d..135a2b3de 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
@@ -903,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
@@ -925,19 +939,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;
@@ -997,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 69e6c47fd..a72d31a43 100644
--- a/src/ecCommands.mli
+++ b/src/ecCommands.mli
@@ -24,17 +24,19 @@ 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
val addnotifier : notifier -> unit
+val notify : EcGState.loglevel -> ('a, Format.formatter, unit, unit) format4 -> 'a
(* -------------------------------------------------------------------- *)
val process_internal :
@@ -44,7 +46,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,9 +56,12 @@ 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
+val pp_all_goals : unit -> string list
(* -------------------------------------------------------------------- *)
val pragma_verbose : bool -> unit
diff --git a/src/ecCoreModules.ml b/src/ecCoreModules.ml
index 6f96118ab..a07f9ab2a 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 1b84c0df2..178b4c581 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/ecCorePrinting.ml b/src/ecCorePrinting.ml
index d906a61e3..29051f0a0 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/ecCoreSubst.ml b/src/ecCoreSubst.ml
index c39a87a27..161d7d3c7 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 80531ef9c..f829b8d38 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 5636641ac..bcc414242 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,10 +65,10 @@ 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) =
+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 7864a0e0d..a974a6048 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
@@ -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/ecDoc.ml b/src/ecDoc.ml
new file mode 100644
index 000000000..01b343770
--- /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 000000000..1e8fd31d2
--- /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/ecEco.ml b/src/ecEco.ml
index cd80c8020..fc8f41c98 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/ecEnv.ml b/src/ecEnv.ml
index a4a5c8a7c..4490390b9 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 =
@@ -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
@@ -2544,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
@@ -2585,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
@@ -2608,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
@@ -2814,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
@@ -2934,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/ecEnv.mli b/src/ecEnv.mli
index 5a1d5bf60..fe21dc247 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 108bed966..080a4d3de 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/ecHiGoal.ml b/src/ecHiGoal.ml
index f08413545..b16b7eb03 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 =
diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml
index a51dede08..72cf50e85 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;
@@ -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
@@ -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_instanciate 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)
+ | Abstract _ ->
+ List.exists isempty targs
- | `Concrete ty ->
- isempty_1 [tyinst () ty]
+ | Concrete ty ->
+ isempty_1 [ tyinst ty ]
- | `Record (_, fields) ->
- isempty_1 (List.map (tyinst () |- snd) fields)
+ | Record (_, fields) ->
+ isempty_1 (List.map (tyinst |- snd) fields)
- | `Datatype dt ->
- isempty_n (List.map (List.map (tyinst ()) |- snd) dt.tydt_ctors)
+ | Datatype dt ->
+ (* 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 32fd11645..1db4bd011 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/ecHiTacticals.ml b/src/ecHiTacticals.ml
index 9eb6521e3..45af10852 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/ecInductive.ml b/src/ecInductive.ml
index a873688f4..f21f3003c 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 2b1c5a97c..32d9cd4b0 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/ecIo.ml b/src/ecIo.ml
index e630d4b49..016545d85 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 ce52869b4..42d28ba74 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 a1b90c7c8..19536eaae 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/ecLowGoal.ml b/src/ecLowGoal.ml
index fd20b27fd..14e2e72f6 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
@@ -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 56004018a..ef5dca098 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 4bec3d0ca..97fe5f0b4 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/ecMatching.ml b/src/ecMatching.ml
index 7c8e6a2fb..b84d8d430 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 `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 (`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) =
@@ -914,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/ecOptions.ml b/src/ecOptions.ml
index b3704e1a1..f012e8e8d 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 = {
@@ -24,6 +25,7 @@ and cmp_option = {
cmpo_tstats : string option;
cmpo_noeco : bool;
cmpo_script : bool;
+ cmpo_trace : bool;
}
and cli_option = {
@@ -40,6 +42,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;
@@ -341,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", [
@@ -359,6 +367,10 @@ let specs = {
]);
("why3config", "Configure why3", []);
+
+ ("docgen", "Generate documentation", [
+ `Spec ("outdir", `String, "Output documentation files in ")
+ ]);
];
xp_groups = [
@@ -506,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;
@@ -516,6 +529,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 +592,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 b779aa44e..59009718a 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 = {
@@ -20,6 +21,7 @@ and cmp_option = {
cmpo_tstats : string option;
cmpo_noeco : bool;
cmpo_script : bool;
+ cmpo_trace : bool;
}
and cli_option = {
@@ -36,6 +38,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 eb1a1a980..a1c9acf08 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
@@ -2845,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 }
@@ -3904,6 +3896,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 b438cc904..e9991a3ea 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;
@@ -596,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
@@ -776,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)
@@ -1318,5 +1318,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/ecPrinting.ml b/src/ecPrinting.ml
index b37fbe228..854a61a59 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 =
@@ -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
@@ -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
diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml
index 7f3c3d0e1..0f1a19d11 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 73164e474..2674da433 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
@@ -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 b450ac189..359b57045 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 1dce11fab..976c52312 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 116cb8015..27dea22f8 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/ecRelocate.ml b/src/ecRelocate.ml
index f07cb429a..0505a9b36 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 8600315c0..59e80d735 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 bce77e0ab..1ab346c66 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;
@@ -1948,25 +2239,28 @@ 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
-
- | 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
+ EcUnify.UniEnv.tparams ue, Concrete body
+
+ | 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
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; })
@@ -1979,21 +2273,21 @@ 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
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 +2309,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 +2337,7 @@ module Ty = struct
) in
let proofs = Cloning.replay_proofs scope `Check proofs in
-
+
Ax.add_defer scope proofs
(* ------------------------------------------------------------------ *)
@@ -2074,7 +2368,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
@@ -2508,3 +2802,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 bc3c2812d..d64007674 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 cdd5b1cb2..b87cf7b68 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 ->
@@ -91,325 +94,396 @@ 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 *)
+ type_ : Sp.t; (* Type 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; type_ = 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
-let on_pv (cb : cb) (pv : prog_var)=
+(* -------------------------------------------------------------------- *)
+and on_memenv (aenv : aenv) (m : EcMemory.memenv) =
+ on_memtype aenv (snd m)
+
+(* -------------------------------------------------------------------- *)
+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
-let on_binding (cb : cb) ((_, ty) : (EcIdent.t * ty)) =
- on_ty cb ty
+(* -------------------------------------------------------------------- *)
+and on_binding (aenv : aenv) ((_, ty) : (EcIdent.t * ty)) =
+ on_ty aenv ty
-let on_bindings (cb : cb) (bds : (EcIdent.t * ty) list) =
- List.iter (on_binding cb) bds
+(* -------------------------------------------------------------------- *)
+and on_bindings (aenv : aenv) (bds : (EcIdent.t * ty) list) =
+ List.iter (on_binding aenv) bds
-let rec on_expr (cb : cb) (e : expr) =
- let cbrec = on_expr cb in
+(* -------------------------------------------------------------------- *)
+and on_ty (aenv : aenv) (ty : ty) =
+ match ty.ty_node with
+ | Tunivar _ -> ()
+ | Tvar _ -> ()
+ | 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]
+
+(* -------------------------------------------------------------------- *)
+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);
+ 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
+
+(* -------------------------------------------------------------------- *)
+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_mstruct1 aenv) st.ms_body
-and on_mpath_mstruct1 (cb : cb) (item : module_item) =
+(* -------------------------------------------------------------------- *)
+and on_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
- | `Record (f, fds) ->
- on_form cb f;
- List.iter (on_ty cb |- 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]
-
-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
+ | 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 ->
+ List.iter (List.iter (on_ty aenv) |- snd) dt.tydt_ctors;
+ List.iter (on_form aenv) [dt.tydt_schelim; dt.tydt_schcase]
+
+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 +492,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 =
@@ -504,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
@@ -574,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
@@ -643,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
@@ -739,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
@@ -758,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
@@ -779,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
@@ -973,7 +1051,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 ->
@@ -1067,7 +1145,7 @@ let sc_decl_mod (id,mt) = SC_decl_mod (id,mt)
(* ---------------------------------------------------------------- *)
let is_abstract_ty = function
- | `Abstract _ -> true
+ | Abstract _ -> true
| _ -> false
(*
@@ -1159,27 +1237,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 +1263,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 +1275,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 +1294,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 +1326,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 =
@@ -1278,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 (cb scenv from cd) me
+ on_module (mkaenv scenv.sc_env (cb scenv from cd)) me
+ end
| `Declare -> (* Should be SC_decl_mod ... *)
assert false
@@ -1297,7 +1357,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 +1365,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 =
@@ -1443,7 +1504,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 +1513,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 }
@@ -1527,7 +1588,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 }
diff --git a/src/ecSmt.ml b/src/ecSmt.ml
index 84ccddd80..c6119dff3 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 45bdb2f74..33274e240 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/ecSymbols.ml b/src/ecSymbols.ml
index e1e37313f..9b2ee1cc6 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 a761df52f..b42cb35e9 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 7ed63fd89..94f7c048e 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 f18cee1ac..0a96a56d2 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
diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml
index a2f24e593..2731d928b 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 a135698ba..82e160cfa 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 0eff5cf66..a6af17b16 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
@@ -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
diff --git a/src/ecTypes.ml b/src/ecTypes.ml
index 87efc57be..bebd2087e 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 34b7b4cbf..95ee26bb3 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/ecTyping.ml b/src/ecTyping.ml
index 75f594a10..6af2f28e3 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
diff --git a/src/ecUnify.ml b/src/ecUnify.ml
index e5bb56299..4664a8a71 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 90488fabc..1f6ed3e45 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/ecUserMessages.ml b/src/ecUserMessages.ml
index 9c947c1b6..249cfb520 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/src/phl/ecPhlApp.ml b/src/phl/ecPhlApp.ml
index d63286429..2d2ea618b 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
@@ -67,7 +68,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)]
@@ -125,12 +126,12 @@ let t_equiv_app_onesided side i pre post tc =
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
+ 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
+ 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
@@ -227,13 +228,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 +249,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 298e0588d..8231b9f27 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 0cc9e48b4..f3ec2c513 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/ecPhlConseq.ml b/src/phl/ecPhlConseq.ml
index 90a07c86f..97bdfb2df 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
@@ -719,10 +725,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 +743,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 +768,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
@@ -785,26 +793,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 +838,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]
@@ -1120,7 +1137,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;
@@ -1152,7 +1169,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
(* ------------------------------------------------------------------ *)
@@ -1171,10 +1188,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
@@ -1229,8 +1246,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;
@@ -1247,8 +1264,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;
@@ -1276,11 +1293,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/src/phl/ecPhlDeno.ml b/src/phl/ecPhlDeno.ml
index 0a6ce9af2..544e6f308 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 =
+ let m = pre.m in
+ assert (m = post.m);
let env, _, concl = FApi.tc1_eflat tc in
let f, bd =
@@ -99,16 +101,17 @@ 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
(* 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
diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml
index a99092c82..e4f23a790 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))
-
- 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
+ if (not (e_equal e (sub_to_left_mem _e))) then
+ tc_error !!tc "eager: both while guards must be syntactically equal";
- and cT = f_equivS (snd eC.es_mr) (snd eC.es_mr) eqI2 c' c' eqI2
- in
+ let eqMem1 = eq_on_form_and_stmt env i c' and eqI = eq_on_sided_form env i in
+
+ let el = ss_inv_of_expr ml e and er = ss_inv_of_expr mr e in
- let tsolve tc =
- FApi.t_first
- (t_apply_hyp h)
- (FApi.xmutate1 tc `EagerWhile [tH; aT; bT; cT])
+ 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
- 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 (s_equal s eg.eg_sl && s_equal s' eg.eg_sr) then
- tc_error !!tc "cannot reconize the swapping statement";
+ 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";
- 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 s, fl, fr = (eg.eg_sl, eg.eg_fl, eg.eg_fr) in
- let do1 og sg =
+ 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 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)
- 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
+ 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 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 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_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 = EcProofTyping.tc1_process_codepos1 tc (Some `Left , i) in
- let j = EcProofTyping.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 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 1958df552..6d5c2b058 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/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml
index 6fc4497fd..8466ac935 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 77ffeb1b2..89225fb4d 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 bdf1a7ef6..d40f5ab8b 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 bef120984..434dece2c 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 1fd63d0bb..2898a138b 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 20bd429ad..d45a50ede 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 da5057855..57abab3d5 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 48a8ed32f..35bb3de4d 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 b47d05084..100d49e72 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;
@@ -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
@@ -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/src/phl/ecPhlSym.ml b/src/phl/ecPhlSym.ml
index 4868fa478..7d706dcc3 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/byehoare-arg.ec b/tests/byehoare-arg.ec
new file mode 100644
index 000000000..3fd7eb934
--- /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.
diff --git a/tests/call_with_op.ec b/tests/call_with_op.ec
new file mode 100644
index 000000000..f0832de4f
--- /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/conseq_equiv_phoare.ec b/tests/conseq_equiv_phoare.ec
new file mode 100644
index 000000000..d6383d90e
--- /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.
+
diff --git a/tests/conseq_equiv_phoare_at_equiv.ec b/tests/conseq_equiv_phoare_at_equiv.ec
new file mode 100644
index 000000000..e45598b97
--- /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.
diff --git a/tests/conseq_phoare_hoare.ec b/tests/conseq_phoare_hoare.ec
new file mode 100644
index 000000000..021622544
--- /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.
diff --git a/tests/positivity_checking.ec b/tests/positivity_checking.ec
new file mode 100644
index 000000000..d50d815bf
--- /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].
diff --git a/tests/proc_with_op.ec b/tests/proc_with_op.ec
new file mode 100644
index 000000000..7c79de262
--- /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.
diff --git a/tests/symmetry.ec b/tests/symmetry.ec
new file mode 100644
index 000000000..a2c527c06
--- /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.
diff --git a/theories/crypto/PROM.ec b/theories/crypto/PROM.ec
index c672898f6..59fd19bc5 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/datatypes/Xreal.ec b/theories/datatypes/Xreal.ec
index a395b4017..026327f55 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 =
diff --git a/theories/distributions/SDist.ec b/theories/distributions/SDist.ec
index ef3b2f244..70610147a 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.